Fixed ambiguous type for CmdString in Shake.hs
[gipeda.git] / src / Shake.hs
1 {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, NondecreasingIndentation #-}
2 module Shake where
3
4 import Prelude hiding ((*>))
5
6 import Development.Shake hiding (withTempFile)
7 import Development.Shake.FilePath
8 import Development.Shake.Classes
9 import Control.Monad
10 import qualified Data.Map as M
11 import Data.Functor
12 import Data.List
13 import System.IO.Extra (newTempFile)
14 import qualified Data.ByteString as BS
15 import qualified Data.ByteString.Lazy as LBS
16 import qualified System.Directory
17 import Data.Aeson
18 import qualified Data.Text as T
19
20 import Development.Shake.Gitlib
21
22 import Paths hiding (Hash)
23 import ParentMap
24 import BenchmarksInCSV
25 import qualified BenchmarkSettings as S
26 import JsonUtils
27
28 {- Global settings -}
29 cGRAPH_HISTORY :: Integer
30 cGRAPH_HISTORY = 50
31
32 git :: (CmdResult b) => String -> [String] -> Action b
33 git gitcmd args = do
34     cmd (Traced $ "git " ++ gitcmd) (words "git -C repository" ++ gitcmd : args)
35
36 self :: (CmdResult b) => String -> [String] -> Action b
37 self name args = do
38     -- orderOnly ["gipeda"]
39     cmd (Traced name) "./gipeda" name args
40
41 gitRange :: Action [String]
42 gitRange = do
43     s <- liftIO $ S.readSettings "settings.yaml"
44     let first = S.start s
45     heads <- readFileLines "site/out/heads.txt"
46     Stdout range <- git "log" $ ["--format=%H","^"++first] ++ heads
47     return $ words range
48
49 needIfThere :: [FilePath] -> Action [FilePath]
50 needIfThere files = do
51     existing <- filterM doesFileExist files
52     need existing
53     return existing
54
55 doesLogExist :: LogSource -> Hash -> Action Bool
56 doesLogExist BareGit    hash = doesGitFileExist "logs" (hash <.> "log")
57 doesLogExist FileSystem hash = doesFileExist (logsOf hash)
58 doesLogExist NoLogs     hash = doesFileExist (resultsOf hash)
59
60 findPred, findPredOrSelf :: LogSource -> ParentMap -> Hash -> Action (Maybe Hash)
61 findPredOrSelf logSource m h = do
62     ex <- doesLogExist logSource h
63     if ex then return (Just h)
64           else findPred logSource m h
65 findPred logSource m h = case M.lookup h m of
66     Just h' -> findPredOrSelf logSource m h'
67     Nothing -> return Nothing
68
69 findRecent :: LogSource -> ParentMap -> Integer -> FilePath -> Action [FilePath]
70 findRecent _ _ 0 _ = return []
71 findRecent logSource m n h = do
72     pM <- findPred logSource m h
73     (h:) <$> case pM of
74         Nothing -> return []
75         Just p ->  findRecent logSource m (n-1) p
76
77 newtype LimitRecent = LimitRecent ()
78     deriving (Show,Typeable,Eq,Hashable,Binary,NFData)
79
80 data LogSource = FileSystem | BareGit | NoLogs deriving Show
81
82 determineLogSource :: IO LogSource
83 determineLogSource = do
84     haveLogs <- System.Directory.doesDirectoryExist "logs"
85     if haveLogs
86     then do
87         (Exit _, Stdouterr s) <- cmd "git -C logs rev-parse --is-bare-repository"
88         if s == "true\n"
89         then return BareGit
90         else return FileSystem
91     else return NoLogs
92
93 shakeMain :: IO ()
94 shakeMain = do
95     logSource <- determineLogSource
96
97     shakeArgs shakeOptions $ do
98     defaultRuleGitLib
99
100 {-
101     "gipeda" *> \out ->  do
102         sources <- getDirectoryFiles "src" ["*.hs"]
103         need (map ("src" </>) sources)
104         cmd "ghc -isrc --make -O src/gipeda.hs -o" out
105     want ["gipeda"]
106 -}
107
108     getLimitRecent <- addOracle $ \(LimitRecent _) -> do
109         need ["settings.yaml"]
110         S.limitRecent <$> liftIO (S.readSettings "settings.yaml")
111
112     "reports" ~> do
113         hashes <- gitRange
114         withLogs <- filterM (doesLogExist logSource) hashes
115         need $ map reportOf withLogs
116     want ["reports"]
117
118     "summaries" ~> do
119         hashes <- gitRange
120         withLogs <- filterM (doesLogExist logSource) hashes
121         need $ map summaryOf withLogs
122     want ["summaries"]
123
124     "site/out/head.txt" *> \ out -> do
125         alwaysRerun
126         Stdout stdout <- git "rev-parse" ["master"]
127         writeFileChanged out stdout
128
129     "site/out/heads.txt" *> \ out -> do
130         tags <- readFileLines "site/out/tags.txt"
131         tagHashes <- forM tags $ \t -> do
132             getGitReference "repository" ("refs/tags/" ++ t)
133
134         branches <- readFileLines "site/out/branches.txt"
135         branchHashes <- forM branches $ \t -> do
136             getGitReference "repository" ("refs/heads/" ++ t)
137
138         masterHash <- getGitReference "repository" "refs/heads/master"
139
140         let heads = nub $ masterHash : tagHashes ++ branchHashes
141         writeFileChanged out $ unlines $ heads
142
143
144     "site/out/history.csv" *> \out -> do
145         heads <- readFileLines "site/out/heads.txt"
146
147         s <- liftIO $ S.readSettings "settings.yaml"
148         let first = S.start s
149
150         Stdout stdout <- git "log" $
151                 "--format=%H;%P": ("^"++first) : heads
152         writeFileChanged out stdout
153     want ["site/out/history.csv"]
154
155     history' <- newCache $ \() -> do
156          orderOnly ["site/out/history.csv"]
157          liftIO $ ssvFileToMap "site/out/history.csv"
158     let history = history' ()
159     let pred h = do { hist <- history; findPred logSource hist h }
160     let predOrSelf h = do { hist <- history; findPredOrSelf logSource hist h }
161     let recent n h = do { hist <- history; findRecent logSource hist n h }
162
163     "site/out/latest.txt" *> \ out -> do
164         [head] <- readFileLines "site/out/head.txt"
165         latestM <- predOrSelf head
166         case latestM of
167            Just latest ->
168                 writeFileChanged out latest
169            Nothing ->
170                 fail "Head has no parent with logs?"
171
172     "site/out/tags.txt" *> \ out -> do
173         alwaysRerun
174
175         need ["settings.yaml"]
176         s <- liftIO $ S.readSettings "settings.yaml"
177         case S.interestingTags s of
178             Nothing ->
179                 writeFileChanged out ""
180             Just pattern -> do
181                 Stdout tags <- git "tag" ["-l", pattern]
182                 tags' <- filterM (isGitAncestor "repository" (S.start s)) (lines tags)
183                 writeFileChanged out (unlines tags')
184
185     "site/out/branches.txt" *> \ out -> do
186         alwaysRerun
187
188         need ["settings.yaml"]
189         s <- liftIO $ S.readSettings "settings.yaml"
190         case S.interestingBranches s of
191             Nothing ->
192                 writeFileChanged out ""
193             Just pattern -> do
194                 Stdout branches <- git "branch" ["--list", pattern]
195                 branches <- filterM (isGitAncestor "repository" (S.start s)) (map (drop 2) $ lines branches)
196                 branches <- filterM (\b -> not <$> isGitAncestor "repository" b "master") branches
197                 writeFileChanged out (unlines branches)
198
199     "graphs" ~> do
200         [latest] <- readFileLines "site/out/latest.txt"
201         need [resultsOf latest]
202         b <- liftIO $ benchmarksInCSVFile (resultsOf latest)
203         need (map graphFile b)
204     want ["graphs"]
205
206     case logSource of
207         BareGit ->
208             "site/out/results/*.csv" *> \out -> do
209                 let hash = takeBaseName out
210                 withTempFile $ \fn -> do
211                     log <- readGitFile "logs" (hash <.> "log")
212                     liftIO $ BS.writeFile fn log
213                     Stdout csv <- cmd "./log2csv" fn
214                     writeFile' out csv
215         FileSystem ->
216             "site/out/results/*.csv" *> \out -> do
217                 let hash = takeBaseName out
218                 need [logsOf hash]
219                 Stdout csv <- cmd "./log2csv" (logsOf hash)
220                 writeFile' out csv
221         NoLogs -> return ()
222
223     "site/out/graphs//*.json" *> \out -> do
224         let bench = dropDirectory1 (dropDirectory1 (dropDirectory1 (dropExtension out)))
225
226         [latest] <- readFileLines "site/out/latest.txt"
227         limitRecent <- getLimitRecent (LimitRecent ())
228         r <- recent limitRecent latest
229         need (map reportOf r)
230
231         Stdout json <- self "GraphReport" (bench : r)
232         writeFile' out json
233
234     "site/out/reports/*.json" *> \out -> do
235         let hash = takeBaseName out
236         need [resultsOf hash]
237
238         pred <- pred hash
239         need [resultsOf h | Just h <- return pred]
240
241         Stdout json <- self "RevReport" (hash : [h | Just h <- return pred])
242         writeFile' out json
243
244     "site/out/summaries/*.json" *> \out -> do
245         let hash = takeBaseName out
246         need [reportOf hash]
247
248         Stdout json <- self "Summary" [hash]
249         writeFile' out json
250
251     "site/out/latest-summaries.json" *> \out -> do
252         [latest] <- readFileLines "site/out/latest.txt"
253         recentCommits <- recent cGRAPH_HISTORY latest
254
255         tags <- readFileLines "site/out/tags.txt"
256         tagsAndHashes <- forM tags $ \t -> do
257             h <- getGitReference "repository" ("refs/tags/" ++ t)
258             return $ (t, h)
259
260         branches <- readFileLines "site/out/branches.txt"
261         branchesAndHashes <- forM branches $ \t -> do
262             h <- getGitReference "repository" ("refs/heads/" ++ t)
263             return $ (t, h)
264
265         let o = object
266                 [ T.pack "tags" .= object [ (T.pack t .= h) | (t,h) <- tagsAndHashes ]
267                 , T.pack "branches" .= object [ (T.pack t .= h) | (t,h) <- branchesAndHashes ]
268                 ]
269         liftIO $ LBS.writeFile out (encode o)
270         extraCommits <- filterM (doesLogExist logSource) (map snd tagsAndHashes ++ map snd branchesAndHashes)
271
272         let revs = nub $ recentCommits ++ extraCommits
273
274         need $ map summaryOf revs
275
276         g <- forM revs $ \rev -> do
277             json <- liftIO $ LBS.readFile (summaryOf rev)
278             case eitherDecode json of
279                 Left e -> fail e
280                 Right rep -> return (rep :: Value)
281         liftIO $ LBS.writeFile out (encode (merges (o:g)))
282     want ["site/out/latest-summaries.json"]
283
284     "site/out/graph-summaries.json" *> \out -> do
285         [latest] <- readFileLines "site/out/latest.txt"
286         need [resultsOf latest]
287         b <- liftIO $ benchmarksInCSVFile (resultsOf latest)
288         need (map graphFile b)
289
290         Stdout json <- self "GraphSummaries" b
291         writeFile' out json
292     want ["site/out/graph-summaries.json"]
293
294     "site/out/benchNames.json" *> \out -> do
295         [latest] <- readFileLines "site/out/latest.txt"
296         need [resultsOf latest]
297         b <- liftIO $ benchmarksInCSVFile (resultsOf latest)
298
299         need ["settings.yaml"]
300
301         Stdout json <- self "BenchNames" (nub b)
302         writeFile' out json
303     want ["site/out/benchNames.json"]
304
305
306     "site/out/all-summaries.json" *> \out -> do
307         hashes <- gitRange
308         revs <- filterM (doesLogExist logSource) hashes
309         need (map summaryOf revs)
310
311         g <- forM revs $ \rev -> do
312             json <- liftIO $ LBS.readFile (summaryOf rev)
313             case eitherDecode json of
314                 Left e -> fail e
315                 Right rep -> return (rep :: Value)
316         liftIO $ LBS.writeFile out (encode (merges g))
317     want ["site/out/all-summaries.json"]
318
319     "site/out/settings.json" *> \out -> do
320         need ["settings.yaml"]
321
322         Stdout json <- self "JsonSettings" []
323         writeFile' out json
324     want ["site/out/settings.json"]
325
326     phony "clean" $ do
327         removeFilesAfter "site/out" ["//*"]
328
329
330 -- | Create a temporary file in the temporary directory. The file will be deleted
331 --   after the action completes (provided the file is not still open).
332 --   The 'FilePath' will not have any file extension, will exist, and will be zero bytes long.
333 --   If you require a file with a specific name, use 'withTempDir'.
334 withTempFile :: (FilePath -> Action a) -> Action a
335 withTempFile act = do
336     (file, del) <- liftIO newTempFile
337     act file `actionFinally` del