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