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, makeAbsolute)
  21 import System.FilePath ((</>), (<.>))
  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   distPref{-ix-} <- makeAbsolute $ fromFlag (buildDistPref flags)
  52   let verbosity = fromFlag (buildVerbosity flags)
  53       dbStack = withPackageDB lbi <> [ SpecificPackageDB $ distPref</>"package.conf.inplace" ]
  54       dbFlags = "-hide-all-packages" : "-package-env=-" : packageDbArgsDb dbStack
  55       Just ghc = lookupProgram ghcProgram (withPrograms lbi)
  56       -- globalAutogenDir = autogenPackageModulesDir lbi
  57   -- createDirectoryIfMissingVerbose verbosity True globalAutogenDir
  58   withTestLBI pkg lbi $ \testSuite testCLBI ->
  59     when (testName testSuite == fromString testSuiteName) $ do
  60       let testAutogenDir = autogenComponentModulesDir lbi testCLBI
  61       let buildFile = testAutogenDir</>buildModule<.>"hs"
  62       createDirectoryIfMissingVerbose verbosity True testAutogenDir
  63       withLibLBI pkg lbi $ \_libSuite libCLBI -> do
  64         let libDeps = fst <$> componentPackageDeps libCLBI
  65             Left pidx = dependencyClosure (installedPkgs lbi) libDeps
  66             libTransDeps = installedUnitId <$> allPackages pidx
  67             packageUnitId = componentUnitId libCLBI
  68             depsFlags = (\installedPkgId -> "-package-id=" <> display installedPkgId) <$> (packageUnitId:libTransDeps)
  69             PerCompilerFlavor profFlags _ghcjs = profOptions (testBuildInfo testSuite)
  70             TestSuiteExeV10 _ mainFile = testInterface testSuite
  71             exe = Executable {
  72               exeName = testName testSuite,
  73               modulePath = mainFile,
  74               exeScope = ExecutablePublic,
  75               buildInfo = testBuildInfo testSuite
  76             }
  77             ghcFlags = mconcat
  78               [ dbFlags
  79               , depsFlags
  80               -- This -i enables to `import Grammar` in TemplateHaskell splicing modules.
  81               -- Because `test/Grammar.hs' is not in a package.
  82               , [ "-i"<>exeBuildDir lbi exe ]
  83               , [ x | withProfExe lbi, x <- ["-prof", "-osuf", "p_o", "-hisuf", "p_hi"] <> profFlags ]
  84               -- , [ x | libCoverage lbi, x <- ["-fhpc"] <> profFlags ]
  85               , programOverrideArgs ghc
  86               ]
  87         writeFile buildFile $ unlines
  88           [ "module "<>buildModule<>" where"
  89           , "import Data.String (String)"
  90           , "import System.FilePath (FilePath)"
  91           , ""
  92           , "ghcPath :: FilePath"
  93           , "ghcPath = "<>show (locationPath $ programLocation ghc)
  94           , ""
  95           , "ghcFlags :: [String]"
  96           , "ghcFlags = "<>show ghcFlags
  97           , ""
  98           , "rootDir :: FilePath"
  99           , "rootDir = "<>show rootDir
 100           ]
 101   where
 102   -- GHC >= 7.6 uses the '-package-db' flag.
 103   -- See https://ghc.haskell.org/trac/ghc/ticket/5977.
 104   packageDbArgsDb :: [PackageDB] -> [String]
 105   -- special cases to make arguments prettier in common scenarios
 106   packageDbArgsDb dbstack = case dbstack of
 107     (GlobalPackageDB:UserPackageDB:dbs)
 108       | all isSpecific dbs -> concatMap single dbs
 109     (GlobalPackageDB:dbs)
 110       | all isSpecific dbs -> "-no-user-package-db" : concatMap single dbs
 111     dbs -> "-clear-package-db" : concatMap single dbs
 112     where
 113     single (SpecificPackageDB db) = [ "-package-db=" <> db ]
 114     single GlobalPackageDB = [ "-global-package-db" ]
 115     single UserPackageDB = [ "-user-package-db" ]
 116     isSpecific (SpecificPackageDB _) = True
 117     isSpecific _ = False
 118
 119 amendGPD :: GenericPackageDescription -> GenericPackageDescription
 120 amendGPD gpd = gpd { condTestSuites = f <$> condTestSuites gpd }
 121   where
 122   f (name, condTree)
 123       | name == fromString testSuiteName = (name, condTree')
 124       | otherwise = (name, condTree)
 125     where
 126     condTree' = condTree { condTreeData =
 127       testSuite { testBuildInfo =
 128         bi { otherModules = om'
 129            , autogenModules = am' } } }
 130     testSuite = condTreeData condTree
 131     bi = testBuildInfo testSuite
 132     om = otherModules bi
 133     am = autogenModules bi
 134
 135     -- Cons the module to both other-modules and autogen-modules.
 136     -- At the moment, cabal-spec-2.0 and cabal-spec-2.2 don't have
 137     -- "all autogen-modules are other-modules
 138     -- if they aren't exposed-modules" rule.
 139     -- Hopefully cabal-spec-3.0 will have.
 140     --
 141     -- Note: we `nub`, because it's unclear
 142     -- if that's ok to have duplicate modules in the lists.
 143     om' = nub $ mn : om
 144     am' = nub $ mn : am
 145     mn = fromString buildModule