1{-# LANGUAGE CPP #-}
2{-# LANGUAGE ViewPatterns #-}
3module Main where
4import Control.Applicative
5import Control.Monad
6import Data.Foldable
7import Data.Monoid
8import Data.Traversable
9import System.Directory
10import System.Environment
11import System.FilePath
12import System.IO
13import Prelude
14
15import System.IO.Temp
16import System.Process
17import Test.Tasty
18import Test.Tasty.HUnit
19import qualified Data.Attoparsec.Text.Lazy as ATL
20import qualified Data.Set as Set
21import qualified Data.Text.Lazy.IO as TL
22import qualified Data.Text.IO as T
23
24import GHC.Prof
25
26#if !MIN_VERSION_directory(1, 2, 3)
27import Control.Exception
28#endif
29
30main :: IO ()
31main = withSystemTempDirectory "test" $ \dir -> withCurrentDirectory dir $
32  defaultMain $ testCaseSteps "Regression tests" $ \step -> do
33    step "Generating profiling reports"
34    profiles <- generateProfiles
35    for_ profiles $ \prof -> do
36      step $ "Parsing " ++ prof
37      assertProfile prof
38    for_ profiles $ \prof -> do
39      step $ "Decode  " ++ prof
40      assertDecode prof
41      step $ "Decode' " ++ prof
42      assertDecode' prof
43
44generateProfiles :: IO [FilePath]
45generateProfiles = do
46  withFile "hello.hs" WriteMode $ \h ->
47    hPutStrLn h $ unlines
48      [ "import Control.Exception"
49      , "main = evaluate $ fib 100000"
50      , "fib n = fibs !! n"
51      , "fibs = 0:1:zipWith (+) fibs (tail fibs)"
52      ]
53  ghc <- findGhc
54  void $ readProcess ghc ["-prof", "-rtsopts", "-fforce-recomp", "hello.hs"] ""
55  for profilingFlags $ \(name, flag) -> do
56    void $ readProcess "./hello" ["+RTS", flag, "-RTS"] ""
57    let profName = "hello" <.> name <.> "prof"
58    renameFile "hello.prof" profName
59    return profName
60
61findGhc :: IO String
62findGhc = Prelude.foldr go (fail "cannot find a GHC")
63  [ lookupEnv "HC"
64  , findExecutable "ghc"
65  ]
66  where
67    go act next = do
68      r <- act
69      case r of
70        Just path -> return path
71        Nothing -> next
72
73profilingFlags :: [(String, String)]
74profilingFlags =
75  [ ("standard", "-p")
76  , ("detailed", "-P")
77  , ("full", "-pa")
78  ]
79
80caseStudy :: Profile -> IO ()
81caseStudy prof = do
82  let actual = Set.fromList $ map Similar $ aggregatedCostCentres prof
83      expected = Set.fromList $ map Similar $ profileTopCostCentres prof
84  assertBool
85    ("Missing cost centre(s): " ++ show (Set.difference expected actual)) $
86      Set.isSubsetOf expected actual
87
88
89assertProfile :: FilePath -> Assertion
90assertProfile path = do
91  text <- TL.readFile path
92  case ATL.parse profile text of
93    ATL.Done _ prof -> caseStudy prof
94    ATL.Fail _ _ reason -> assertFailure reason
95
96assertDecode :: FilePath -> Assertion
97assertDecode path = do
98  text <- TL.readFile path
99  case decode text of
100    Right prof -> caseStudy prof
101    Left reason -> assertFailure reason
102
103assertDecode' :: FilePath -> Assertion
104assertDecode' path = do
105  text <- T.readFile path
106  case decode' text of
107    Right prof -> caseStudy prof
108    Left reason -> assertFailure reason
109
110newtype Similar = Similar AggregatedCostCentre
111
112instance Show Similar where
113  show (Similar a) = show a
114
115instance Eq Similar where
116  Similar a == Similar b =
117    aggregatedCostCentreName a == aggregatedCostCentreName b
118    && aggregatedCostCentreModule a == aggregatedCostCentreModule b
119    && aggregatedCostCentreTime a == aggregatedCostCentreTime b
120    && aggregatedCostCentreAlloc a == aggregatedCostCentreAlloc b
121    && aggregatedCostCentreTicks a == aggregatedCostCentreTicks b
122    && aggregatedCostCentreBytes a == aggregatedCostCentreBytes b
123
124
125instance Ord Similar where
126  compare (Similar a) (Similar b) =
127    compare (aggregatedCostCentreName a) (aggregatedCostCentreName b)
128    <> compare (aggregatedCostCentreModule a) (aggregatedCostCentreModule b)
129    <> compare (aggregatedCostCentreTime a) (aggregatedCostCentreTime b)
130    <> compare (aggregatedCostCentreAlloc a) (aggregatedCostCentreAlloc b)
131    <> compare (aggregatedCostCentreTicks a) (aggregatedCostCentreTicks b)
132    <> compare (aggregatedCostCentreBytes a) (aggregatedCostCentreBytes b)
133
134#if !MIN_VERSION_directory(1, 2, 3)
135withCurrentDirectory :: FilePath -> IO a -> IO a
136withCurrentDirectory dir io = bracket
137  (getCurrentDirectory <* setCurrentDirectory dir)
138  (setCurrentDirectory)
139  (const io)
140#endif
141