1{-# LANGUAGE PatternGuards, ViewPatterns #-}
2
3module Test.Docs(main) where
4
5import Development.Shake
6import Development.Shake.FilePath
7import qualified System.FilePattern.Directory as IO
8import System.Directory
9import Test.Type
10import Control.Monad
11import Data.Char
12import Data.List.Extra
13import System.Info
14import Data.Version.Extra
15
16
17-- Older versions of Haddock (GHC 7.10 and below) garbage the --@ markup and have ambiguity errors
18-- GHC 8.0 has a segfault when linking Setup
19brokenHaddock = compilerVersion < makeVersion [8,2]
20
21main = testBuild (notCI . unless brokenHaddock . defaultTest) $ do
22    let index = "dist/doc/html/shake/index.html"
23    let setup = "dist/setup.exe"
24    let config = "dist/setup-config"
25    want ["Success.txt"]
26    let trackIgnore = trackAllow ["dist/**"]
27
28    let needSource = need =<< getDirectoryFiles "." (map (shakeRoot </>)
29            ["src/Development/Shake.hs","src/Development/Shake//*.hs","src/Development/Ninja/*.hs","src/General//*.hs"])
30
31    let runSetup :: [String] -> Action ()
32        runSetup args = do
33            trackIgnore
34            need [setup]
35            -- Make Cabal and Stack play nicely with GHC_PACKAGE_PATH
36            setup <- liftIO $ canonicalizePath setup
37            cmd_ (RemEnv "GHC_PACKAGE_PATH") (Cwd shakeRoot) setup args
38
39    setup %> \_ -> do
40        -- Important to compile the setup binary, or we run foul of
41        -- https://gitlab.haskell.org/ghc/ghc/issues/17575
42        trackIgnore
43        need [shakeRoot </> "Setup.hs"]
44        setup <- liftIO $ canonicalizePath setup
45        curdir <- liftIO $ canonicalizePath "dist"
46        cmd_ (Cwd shakeRoot) "ghc -package=Cabal Setup.hs -o" [setup] "-outputdir" [curdir]
47
48    config %> \_ -> do
49        path <- getEnv "GHC_PACKAGE_PATH"
50        dist <- liftIO $ canonicalizePath "dist" -- make sure it works even if we cwd
51        need [shakeRoot </> "shake.cabal"]
52        runSetup $
53            ["configure","--builddir=" ++ dist,"--user"] ++
54            -- package-db is very sensitive, see #267
55            -- note that the reverse ensures the behaviour is consistent between the flags and the env variable
56            ["--package-db=" ++ x | x <- maybe [] (reverse . filter (`notElem` [".",""]) . splitSearchPath) path]
57
58        -- Paths_shake is only created by "Setup build" (which we want to skip), and required by "Setup haddock", so we fake it
59        copyFile' (shakeRoot </> "src/Paths.hs") "dist/build/autogen/Paths_shake.hs"
60        copyFile' (shakeRoot </> "src/Paths.hs") "dist/build/shake/autogen/Paths_shake.hs"
61        writeFile' "dist/build/autogen/cabal_macros.h" ""
62        writeFile' "dist/build/shake/autogen/cabal_macros.h" ""
63
64    index %> \_ -> do
65        need $ config : map (shakeRoot </>) ["shake.cabal","Setup.hs","README.md","CHANGES.txt","docs/Manual.md","docs/shake-progress.png"]
66        needSource
67        trackIgnore
68        dist <- liftIO $ canonicalizePath "dist"
69        runSetup ["haddock", "--builddir=" ++ dist]
70
71    "Part_*.hs" %> \out -> do
72        need [shakeRoot </> "src/Test/Docs.hs"] -- so much of the generator is in this module
73        let noR = filter (/= '\r')
74        src <- if "_md" `isSuffixOf` takeBaseName out then
75            fmap (findCodeMarkdown . lines . checkBlacklist . noR) $ readFile' $ shakeRoot </> "docs/" ++ drop 5 (reverse (drop 3 $ reverse $ takeBaseName out)) ++ ".md"
76         else
77            fmap (findCodeHaddock . checkBlacklist . noR) $ readFile' $ "dist/doc/html/shake/" ++ replace "_" "-" (drop 5 $ takeBaseName out) ++ ".html"
78
79        let (imports,rest) = partition ("import " `isPrefixOf`) $ showCode src
80        writeFileChanged out $ unlines $
81            ["{-# LANGUAGE DeriveDataTypeable, RankNTypes, ExtendedDefaultRules, GeneralizedNewtypeDeriving #-}"
82            ,"{-# LANGUAGE NoMonomorphismRestriction, ScopedTypeVariables, ConstraintKinds, FlexibleContexts, TypeFamilies #-}"
83            ,"{-# OPTIONS_GHC -w #-}"
84            ,"module " ++ takeBaseName out ++ "() where"
85            ,"import Control.Applicative"
86            ,"import Control.Concurrent"
87            ,"import Control.Exception"
88            ,"import Control.Monad"
89            ,"import Control.Monad.Trans.Reader"
90            ,"import Data.ByteString(ByteString, pack, unpack)"
91            ,"import qualified Data.ByteString.Char8 as BS"
92            ,"import qualified System.Directory.Extra as IO"
93            ,"import qualified System.IO.Extra as IO"
94            ,"import Data.Char"
95            ,"import Data.Data"
96            ,"import Data.Dynamic"
97            ,"import Data.List.Extra"
98            ,"import System.Time.Extra"
99            ,"import Data.Maybe"
100            ,"import Data.Monoid"
101            ,"import Development.Shake hiding ((*>))"
102            ,"import Development.Shake.Command"
103            ,"import Development.Shake.Classes"
104            ,"import Development.Shake.Database"
105            ,"import Development.Shake.Rule"
106            ,"import Development.Shake.Util"
107            ,"import Development.Shake.FilePath"
108            ,"import System.Console.GetOpt"
109            ,"import System.Directory(setCurrentDirectory, withCurrentDirectory)"
110            ,"import qualified System.Directory"
111            ,"import System.Environment(withArgs, lookupEnv, getEnvironment)"
112            ,"import System.Process"
113            ,"import System.Exit"
114            ,"import Control.Applicative"
115            ,"import Control.Monad.IO.Class"
116            ,"import Control.Monad.Fail"
117            ,"import System.IO hiding (readFile')"] ++
118            ["import " ++ replace "_" "." (drop 5 $ takeBaseName out) | not $ "_md.hs" `isSuffixOf` out] ++
119            imports ++
120            ["(==>) :: Bool -> Bool -> Bool"
121            ,"(==>) = undefined"
122            ,"(<==) = ()"
123            ,"infix 1 ==>"
124            ,"infix 0 ==="
125            ,"(===) :: a -> a -> b"
126            ,"(===) = undefined"
127            ,"forAll f = f undefined"
128            ,"remaining = 1.1"
129            ,"done = 1.1"
130            ,"time_elapsed = 1.1"
131            ,"old = \"\""
132            ,"new = \"\""
133            ,"myvar = \"\""
134            ,"myfile = \"\""
135            ,"inputs = [\"\"]"
136            ,"files = [\"\"]"
137            ,"input = \"\""
138            ,"output = \"\""
139            ,"opts = shakeOptions"
140            ,"result = undefined :: IO (Maybe (Rules ()))"
141            ,"launchMissiles = undefined :: Bool -> IO ()"
142            ,"myVariable = ()"
143            ,"instance Eq (OptDescr a)"
144            ,"(foo,bar,baz) = undefined"
145            ,"(p1,p2) = (0.0, 0.0)"
146            ,"(r1,r2) = (pure () :: Rules(), pure () :: Rules())"
147            ,"xs = []"
148            ,"ys = []"
149            ,"os = [\"file.o\"]"
150            ,"out = \"\""
151            ,"str1 = \"\""
152            ,"str2 = \"\""
153            ,"def = undefined"
154            ,"var = undefined"
155            ,"newValue = undefined"
156            ,"newStore = BS.empty"
157            ,"change = ChangedNothing"
158            ,"str = \"\""] ++
159            rest
160
161    "Files.lst" %> \out -> do
162        need [shakeRoot </> "src/Test/Docs.hs"] -- so much of the generator is in this module
163        need [index]
164        filesHs <- liftIO $ IO.getDirectoryFiles "dist/doc/html/shake" ["Development-*.html"]
165        -- filesMd on Travis will only include Manual.md, since it's the only one listed in the .cabal
166        -- On AppVeyor, where we build from source, it will check the rest of the website
167        filesMd <- getDirectoryFiles (shakeRoot </> "docs") ["*.md"]
168        writeFileChanged out $ unlines $
169            ["Part_" ++ replace "-" "_" (takeBaseName x) | x <- filesHs,
170                not $ any (`isSuffixOf` x) ["-Classes.html", "-FilePath.html"]] ++
171            ["Part_" ++ takeBaseName x ++ "_md" | x <- filesMd,
172                takeBaseName x `notElem` ["Developing","Model","Architecture"]]
173
174    let needModules = do mods <- readFileLines "Files.lst"; need [m <.> "hs" | m <- mods]; pure mods
175
176    "Main.hs" %> \out -> do
177        mods <- needModules
178        writeFileLines out $ ["module Main(main) where"] ++ ["import " ++ m ++ "()" | m <- mods] ++ ["main = pure ()"]
179
180    "Success.txt" %> \out -> do
181        putInfo . ("Checking documentation for:\n" ++) =<< readFile' "Files.lst"
182        needModules
183        need ["Main.hs"]
184        trackIgnore
185        needSource
186        cmd_ "ghc -fno-code -ignore-package=hashmap" ["-idist/build/autogen","-i" ++ shakeRoot </> "src","Main.hs"]
187        writeFile' out ""
188
189checkBlacklist :: String -> String
190checkBlacklist xs = if null bad then xs else error $ show ("Blacklist", bad)
191    where bad = [(w, x) | x <- map lower $ lines xs, w <- blacklist, w `isInfixOf` x]
192
193---------------------------------------------------------------------
194-- FIND THE CODE
195
196newtype Code = Code [String] deriving (Show,Eq,Ord)
197
198
199findCodeHaddock :: String -> [Code]
200findCodeHaddock src =
201    [ Code $ unindent $ lines $ innerText x
202    | tag <- ["code","pre"]
203    , x <- insideTag tag src
204    , let bad = nubOrd (insideTag "em" x) \\ italics
205    , if null bad then True else error $ "Bad italics, " ++ show bad
206    ]
207
208
209findCodeMarkdown :: [String] -> [Code]
210findCodeMarkdown (x:xs) | indented x && not (isBlank x) =
211    let (a,b) = span (\x -> indented x || isBlank x) (x:xs)
212    in Code (dropWhileEnd isBlank $ unindent a) : findCodeMarkdown b
213    where
214        indented x = length (takeWhile isSpace x) >= 4
215findCodeMarkdown (x:xs) = map (Code . pure) (evens $ splitOn "`" x) ++ findCodeMarkdown xs
216    where
217        evens (_:x:xs) = x : evens xs
218        evens _ = []
219findCodeMarkdown [] = []
220
221
222---------------------------------------------------------------------
223-- RENDER THE CODE
224
225showCode :: [Code] -> [String]
226showCode = concat . zipWithFrom f 1 . nubOrd
227    where
228        f i (Code x) | "#" `isPrefixOf` concat x = []
229                     | all whitelist x = []
230                     | otherwise = showStmt i $ filter (not . isBlank . dropComment) $ fixCmd $ map undefDots x
231
232
233fixCmd :: [String] -> [String]
234fixCmd xs
235    | all ("cmd_ " `isPrefixOf`) xs = xs ++ ["pure () :: IO () "]
236    | otherwise = map (replace "Stdout out" "Stdout (out :: String)" . replace "Stderr err" "Stderr (err :: String)") xs
237
238-- | Replace ... with undefined (don't use undefined with cmd; two ...'s should become one replacement)
239undefDots :: String -> String
240undefDots x | Just x <- stripSuffix "..." x, Just (x,_) <- stripInfix "..." x = x ++ new
241            | otherwise = replace "..." new x
242    where new = if words x `disjoint` ["cmd","cmd_","Development.Shake.cmd","Development.Shake.cmd_"] then "undefined" else "[\"\"]"
243
244showStmt :: Int -> [String] -> [String]
245showStmt _ [] = []
246showStmt i xs | isDecl $ unlines xs = map f xs
247    where f x = if fst (word1 x) `elem` dupes then "_" ++ show i ++ "_" ++ x else x
248showStmt i [x] | filter isAlpha (fst $ word1 x) `elem` types = ["type Code_" ++ show i ++ " = " ++ x]
249showStmt i [x] | length (words x) <= 2 = ["code_" ++ show i ++ " = (" ++ x ++ ")"] -- deal with operators and sections
250showStmt i xs | all isPredicate xs, length xs > 1 =
251    zipWithFrom (\j x -> "code_" ++ show i ++ "_" ++ show j ++ " = " ++ x) 1 xs
252showStmt i xs = ("code_" ++ show i ++ " = do") : map ("  " ++) xs ++ ["  undefined" | isBindStmt $ last xs]
253
254isPredicate :: String -> Bool
255isPredicate x = not $ disjoint (words x) ["==","?=="]
256
257isBindStmt :: String -> Bool
258isBindStmt x = "let " `isPrefixOf` x || " <- " `isInfixOf` x
259
260isDecl :: String -> Bool
261isDecl x | fst (word1 x) `elem` ["import","infix","instance","newtype","data"] = True
262isDecl (words -> name:"::":_) | all isAlphaNum name = True -- foo :: Type Signature
263isDecl x | "=" `elem` takeWhile (`notElem` ["let","where"]) (words $ takeWhile (/= '{') x) = True -- foo arg1 arg2 = an implementation
264isDecl _ = False
265
266
267---------------------------------------------------------------------
268-- TEXT MANIPULATION
269
270-- | Is a string empty or whitespace
271isBlank :: String -> Bool
272isBlank = all isSpace
273
274-- | If all lines are indented by at least n spaces, then trim n spaces from each line
275unindent :: [String] -> [String]
276unindent xs = map (drop n) xs
277    where n = minimum $ 1000 : map (length . takeWhile (== ' ')) (filter (not . isBlank) xs)
278
279-- | Remove line comments from the end of lines
280dropComment :: String -> String
281dropComment = fst . breakOn "--"
282
283-- | Find all pieces of text inside a given tag
284insideTag :: String -> String -> [String]
285insideTag tag = map (fst . breakOn ("</" ++ tag ++ ">")) . drop1 . splitOn ("<" ++ tag ++ ">")
286
287-- | Given some HTML, find the raw text
288innerText :: String -> String
289innerText ('<':xs) = innerText $ drop1 $ dropWhile (/= '>') xs
290innerText ('&':xs)
291    | Just xs <- stripPrefix "quot;" xs = '\"' : innerText xs
292    | Just xs <- stripPrefix "lt;" xs = '<' : innerText xs
293    | Just xs <- stripPrefix "gt;" xs = '>' : innerText xs
294    | Just xs <- stripPrefix "amp;" xs = '&' : innerText xs
295innerText (x:xs) = x : innerText xs
296innerText [] = []
297
298
299---------------------------------------------------------------------
300-- DATA SECTION
301
302-- | Only the following identifiers can appear in italic code blocks in Haddock
303--   (otherwise it's a common markup mistake)
304italics :: [String]
305italics = words "command-name file-name N"
306
307-- | Identifiers that indicate the fragment is a type
308types :: [String]
309types = words $
310    "MVar IO String FilePath Maybe [String] FSATrace Char ExitCode ReaderT Change " ++
311    "Action Resource Rebuild FilePattern Development.Shake.FilePattern " ++
312    "Lint Verbosity Rules CmdOption Int Double " ++
313    "NFData Binary Hashable Eq Typeable Show Applicative " ++
314    "CmdResult ByteString ProcessHandle Rule Monad MonadFail Monoid Data TypeRep " ++
315    "BuiltinRun BuiltinLint BuiltinCheck ShakeDatabase"
316
317-- | Duplicated identifiers which require renaming
318dupes :: [String]
319dupes = words "main progressSimple rules"
320
321
322isFilePath :: String -> Bool
323isFilePath x = "C:\\" `isPrefixOf` x || (all validChar  x && ("foo/" `isPrefixOf` x || takeExtension x `elem` exts))
324    where
325        validChar x = isAlphaNum x || x `elem` "_./*"
326        exts = words $ ".txt .hi .hs .o .exe .tar .cpp .cfg .dep .out .deps .m .h .c .html .zip " ++
327                       ".js .json .trace .database .src .sh .bat .ninja .rot13 .version .digits .prof .md"
328
329isCmdFlag :: String -> Bool
330isCmdFlag "+RTS" = True
331isCmdFlag x = length a `elem` [1,2] && all (\x -> isAlphaNum x || x `elem` "-=/_[]") b
332    where (a,b) = span (== '-') x
333
334isCmdFlags :: String -> Bool
335isCmdFlags = all (\x -> let y = dropSuffix "," x in isCmdFlag y || isArg y) . words
336    where isArg = all (\x -> isUpper x || x == '=')
337
338isEnvVar :: String -> Bool
339isEnvVar x | Just x <- stripPrefix "$" x = all validChar x
340           | Just x <- stripPrefix "%" x, Just x <- stripSuffix "%" x = all validChar x
341           | otherwise = False
342    where validChar x = isAlpha x || x == '_'
343
344isProgram :: String -> Bool
345isProgram (words -> x:xs) = x `elem` programs && all (\x -> isCmdFlag x || isFilePath x || all isAlpha x || x == "&&") xs
346    where programs = words "excel gcc docker cl make ghc ghci cabal distcc npm build tar git fsatrace ninja touch pwd runhaskell rot13 main shake stack rm cat sed sh apt-get build-multiple"
347isProgram _ = False
348
349-- | Should a fragment be whitelisted and not checked
350whitelist :: String -> Bool
351whitelist x | null x || isFilePath x || isCmdFlags x || isEnvVar x || isProgram x = True
352whitelist x | elem x $ words $
353    "newtype do a q m c x value key os contents clean _make " ++
354    ".. /. // \\ //* dir/*/* dir [ " ++
355    "ConstraintKinds TemplateHaskell ApplicativeDo OverloadedLists OverloadedStrings GeneralizedNewtypeDeriving DeriveDataTypeable TypeFamilies SetConsoleTitle " ++
356    "Data.List System.Directory Development.Shake.FilePath run " ++
357    "NoProgress Error src about://tracing " ++
358    ".make/i586-linux-gcc/output build " ++
359    "/usr/special /usr/special/userbinary " ++
360    "Hidden extension xterm main opts result flagValues argValues fail " ++
361    "HEADERS_DIR /path/to/dir CFLAGS let linkFlags temp code out err " ++
362    "_shake _shake/build manual chrome://tracing/ compdb " ++
363    "docs/manual foo.* _build _build/run depfile 0.000s " ++
364    "@ndm_haskell file-name .PHONY filepath trim base stack extra #include " ++
365    "*> BuiltinRun BuiltinLint BuiltinIdentity RuleResult " ++
366    "oldStore mode node_modules llbuild Makefile " ++
367    "RebuildNever RLIMIT_NOFILE "
368    = True
369whitelist x = x `elem`
370    ["[Foo.hi, Foo.o]"
371    ,"shake-progress"
372    ,"type instance"
373    ,"1m25s (15%)"
374    ,"3m12s (82%)"
375    ,"getPkgVersion $ GhcPkgVersion \"shake\""
376    ,"ghc --make MyBuildSystem -threaded -rtsopts \"-with-rtsopts=-I0 -qg\""
377    ,"# command-name (for file-name)"
378    ,"<i>build rules</i>"
379    ,"<i>actions</i>"
380    ,"shakeFiles=\"_build\""
381    ,"#include \""
382    ,"pattern %> actions = (pattern ?==) ?> actions" -- because it overlaps
383    ,"buildDir = \"_build\""
384    ,"#!/bin/sh"
385    ,"shake-build-system"
386    ,"\"_build\" </> x -<.> \"o\""
387    ,"[item1,item2,item2]"
388    ,"$(LitE . StringL . loc_filename <$> location)"
389    ,"-d[ FILE], --debug[=FILE]"
390    ,"-r[ FILE], --report[=FILE], --profile[=FILE]"
391    ,"man 2 getrlimit"
392    ]
393
394blacklist :: [String]
395blacklist =
396    -- from https://twitter.com/jesstelford/status/992756386160234497
397    ["obviously"
398    ,"basically"
399    ,"simply"
400    ,"of course"
401    ,"clearly"
402    ,"everyone knows"
403    -- ,"however"
404    -- ,"so,"
405    -- ,"easy"
406    ]
407