1{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, TypeFamilies #-}
2
3module Test.Self(main, cabalBuildDepends) where
4
5import Development.Shake
6import Development.Shake.Classes
7import Development.Shake.FilePath
8import Test.Type
9
10import Control.Monad.Extra
11import Data.Char
12import Data.List.Extra
13import System.Info
14import Data.Version.Extra
15
16
17newtype GhcPkg = GhcPkg () deriving (Show,Typeable,Eq,Hashable,Binary,NFData)
18newtype GhcFlags = GhcFlags () deriving (Show,Typeable,Eq,Hashable,Binary,NFData)
19
20type instance RuleResult GhcPkg = [String]
21type instance RuleResult GhcFlags = [String]
22
23main = testBuild defaultTest $ do
24    let moduleToFile ext xs = replace "." "/" xs <.> ext
25    want ["Main" <.> exe]
26
27    -- fixup to cope with Cabal's generated files
28    let fixPaths x = if x == "Paths_shake.hs" then "Paths.hs" else x
29
30    ghcPkg <- addOracleHash $ \GhcPkg{} -> do
31        Stdout out <- quietly $ cmd "ghc-pkg list --simple-output"
32        pure $ words out
33
34    ghcFlags <- addOracleHash $ \GhcFlags{} ->
35        map ("-package=" ++) <$> readFileLines ".pkgs"
36
37    let ghc args = do
38            trackAllow ["**/package.cache", "**/.ghc.environment.*"]
39            -- since ghc-pkg includes the ghc package, it changes if the version does
40            ghcPkg $ GhcPkg ()
41            flags <- ghcFlags $ GhcFlags ()
42            cmd "ghc" flags args
43
44    "Main" <.> exe %> \out -> do
45        src <- readFileLines "Run.deps"
46        let os = map (moduleToFile "o") $ "Run" : src
47        need os
48        ghc $ ["-o",out] ++ os
49
50    "**/*.deps" %> \out -> do
51        dep <- readFileLines $ out -<.> "dep"
52        let xs = map (moduleToFile "deps") dep
53        need xs
54        ds <- nubOrd . sort . (++) dep <$> concatMapM readFileLines xs
55        writeFileLines out ds
56
57    "**/*.dep" %> \out -> do
58        src <- readFile' $ shakeRoot </> "src" </> fixPaths (out -<.> "hs")
59        let xs = hsImports src
60        xs <- filterM (doesFileExist . (\x -> shakeRoot </> "src" </> x) . fixPaths . moduleToFile "hs") xs
61        writeFileLines out xs
62
63    ["**/*.o","**/*.hi"] &%> \[out,_] -> do
64        deps <- readFileLines $ out -<.> "deps"
65        let hs = shakeRoot </> "src" </> fixPaths (out -<.> "hs")
66        need $ hs : map (moduleToFile "hi") deps
67        ghc ["-c",hs,"-i" ++ shakeRoot </> "src","-main-is","Run.main"
68            ,"-hide-all-packages","-outputdir=."
69            ,"-DPORTABLE"] -- to test one CPP branch
70
71    ".pkgs" %> \out -> do
72        src <- readFile' $ shakeRoot </> "shake.cabal"
73        writeFileLines out $ sort $ cabalBuildDepends src
74
75
76---------------------------------------------------------------------
77-- GRAB INFORMATION FROM FILES
78
79hsImports :: String -> [String]
80hsImports xs = [ takeWhile (\x -> isAlphaNum x || x `elem` "._") $ dropWhile (not . isUpper) x
81               | x <- concatMap (wordsBy (== ';')) $ lines xs, "import " `isPrefixOf` trim x]
82
83
84-- FIXME: Should actually parse the list from the contents of the .cabal file
85cabalBuildDepends :: String -> [String]
86cabalBuildDepends _ = packages ++ ["unix" | os /= "mingw32"]
87
88packages = words
89    ("base transformers binary unordered-containers hashable heaps time bytestring primitive " ++
90     "filepath directory process deepseq random utf8-string extra js-dgtable js-jquery js-flot filepattern") ++
91    ["old-time" | compilerVersion < makeVersion [7,6]] ++
92    ["semigroups" | compilerVersion < makeVersion [8,0]]
93