]> Git — Sourcephile - haskell/symantic-parser.git/blob - Setup.hs
test: add goldens for TH splices
[haskell/symantic-parser.git] / Setup.hs
1 {-# OPTIONS_GHC -Wall #-}
2 -- | This module autogenerates a Build_symantic_parser module
3 -- exporting ghcPath, ghcFlags and rootDir
4 -- used to build TemplateHaskell splices in golden tests.
5 -- The code is adapted from singletons-base's Setup.hs
6 module Main (main) where
7
8 import Control.Monad (when)
9 import Data.List (nub)
10 import Data.String (fromString)
11 import Distribution.PackageDescription
12 import Distribution.Simple
13 import Distribution.Simple.BuildPaths
14 import Distribution.Simple.LocalBuildInfo
15 import Distribution.Simple.PackageIndex
16 import Distribution.Simple.Program
17 import Distribution.Simple.Setup
18 import Distribution.Simple.Utils
19 import Distribution.Text
20 import System.Directory (getCurrentDirectory)
21 import System.FilePath ((</>), (<.>), isRelative)
22
23 buildModule :: FilePath
24 buildModule = "Build_symantic_parser"
25
26 testSuiteName :: String
27 testSuiteName = "symantic-parser-test"
28
29 main :: IO ()
30 main = defaultMainWithHooks simpleUserHooks
31 { buildHook = \pkg lbi hooks flags -> do
32 generateBuildModule flags pkg lbi
33 buildHook simpleUserHooks pkg lbi hooks flags
34 , confHook = \(gpd, hbi) flags ->
35 confHook simpleUserHooks (amendGPD gpd, hbi) flags
36 , haddockHook = \pkg lbi hooks flags -> do
37 generateBuildModule (haddockToBuildFlags flags) pkg lbi
38 haddockHook simpleUserHooks pkg lbi hooks flags
39 }
40
41 -- | Convert only flags used by 'generateBuildModule'.
42 haddockToBuildFlags :: HaddockFlags -> BuildFlags
43 haddockToBuildFlags f = emptyBuildFlags
44 { buildVerbosity = haddockVerbosity f
45 , buildDistPref = haddockDistPref f
46 }
47
48 generateBuildModule :: BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()
49 generateBuildModule flags pkg lbi = do
50 rootDir <- getCurrentDirectory
51 let verbosity = fromFlag (buildVerbosity flags)
52 distPref = fromFlag (buildDistPref flags)
53 distPref' | isRelative distPref = rootDir</>distPref
54 | otherwise = distPref
55 -- Package DBs
56 dbStack = withPackageDB lbi <> [ SpecificPackageDB $ distPref'</>"package.conf.inplace" ]
57 dbFlags = "-hide-all-packages" : "-package-env=-" : packageDbArgsDb dbStack
58
59 ghc = case lookupProgram ghcProgram (withPrograms lbi) of
60 Just fp -> locationPath $ programLocation fp
61 Nothing -> error "Can't find GHC path"
62 withTestLBI pkg lbi $ \suite suitecfg ->
63 when (testName suite == fromString testSuiteName) $ do
64 let testAutogenDir = autogenComponentModulesDir lbi suitecfg
65 createDirectoryIfMissingVerbose verbosity True testAutogenDir
66 let buildFile = testAutogenDir</>buildModule<.>"hs"
67 withLibLBI pkg lbi $ \_ libCLBI -> do
68 let libDeps = fst <$> componentPackageDeps libCLBI
69 pidx = case dependencyClosure (installedPkgs lbi) libDeps of
70 Left p -> p
71 Right _ -> error "Broken dependency closure"
72 libTransDeps = installedUnitId <$> allPackages pidx
73 packageUnitId = componentUnitId libCLBI
74 depsFlags = formatDep <$> (packageUnitId:libTransDeps)
75 allFlags = dbFlags <> depsFlags <>
76 -- This -i enables to `import Grammar`
77 -- in TemplateHaskell splicing modules.
78 -- Because `test/Grammar.hs' is not in a package.
79 ["-i"<>buildDir lbi</>testSuiteName</>testSuiteName<>"-tmp"]
80 writeFile buildFile $ unlines
81 [ "module "<>buildModule<>" where"
82 , "import Data.String (String)"
83 , "import System.FilePath (FilePath)"
84 , ""
85 , "ghcPath :: FilePath"
86 , "ghcPath = " <> show ghc
87 , ""
88 , "ghcFlags :: [String]"
89 , "ghcFlags = " <> show allFlags
90 , ""
91 , "rootDir :: FilePath"
92 , "rootDir = " <> show rootDir
93 ]
94 where
95 formatDep installedPkgId = "-package-id=" <> display installedPkgId
96
97 -- GHC >= 7.6 uses the '-package-db' flag.
98 -- See https://ghc.haskell.org/trac/ghc/ticket/5977.
99 packageDbArgsDb :: [PackageDB] -> [String]
100 -- special cases to make arguments prettier in common scenarios
101 packageDbArgsDb dbstack = case dbstack of
102 (GlobalPackageDB:UserPackageDB:dbs)
103 | all isSpecific dbs ->
104 concatMap single dbs
105 (GlobalPackageDB:dbs)
106 | all isSpecific dbs ->
107 "-no-user-package-db" : concatMap single dbs
108 dbs -> "-clear-package-db" : concatMap single dbs
109 where
110 single (SpecificPackageDB db) = [ "-package-db=" <> db ]
111 single GlobalPackageDB = [ "-global-package-db" ]
112 single UserPackageDB = [ "-user-package-db" ]
113 isSpecific (SpecificPackageDB _) = True
114 isSpecific _ = False
115
116 amendGPD :: GenericPackageDescription -> GenericPackageDescription
117 amendGPD gpd = gpd { condTestSuites = f <$> condTestSuites gpd }
118 where
119 f (name, condTree)
120 | name == fromString testSuiteName = (name, condTree')
121 | otherwise = (name, condTree)
122 where
123 condTree' = condTree { condTreeData =
124 testSuite { testBuildInfo =
125 bi { otherModules = om'
126 , autogenModules = am' } } }
127 testSuite = condTreeData condTree
128 bi = testBuildInfo testSuite
129 om = otherModules bi
130 am = autogenModules bi
131
132 -- Cons the module to both other-modules and autogen-modules.
133 -- At the moment, cabal-spec-2.0 and cabal-spec-2.2 don't have
134 -- "all autogen-modules are other-modules
135 -- if they aren't exposed-modules" rule.
136 -- Hopefully cabal-spec-3.0 will have.
137 --
138 -- Note: we `nub`, because it's unclear
139 -- if that's ok to have duplicate modules in the lists.
140 om' = nub $ mn : om
141 am' = nub $ mn : am
142 mn = fromString buildModule