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