ghc-mod/SetupCompat.hs

199 lines
6.3 KiB
Haskell
Raw Normal View History

{-# LANGUAGE TemplateHaskell, RecordWildCards, StandaloneDeriving #-}
module SetupCompat where
import Control.Arrow
import Control.Monad.Trans.State
import Data.List
import Data.Maybe
import Data.Functor
import Data.Function
import Distribution.Simple.LocalBuildInfo
import Distribution.PackageDescription
import Distribution.Simple
import Distribution.Simple.Setup
import Distribution.Simple.Install
import qualified Data.Map as M
2015-03-04 20:48:21 +00:00
import Data.Map (Map)
import NotCPP.Declarations
import Language.Haskell.TH
2015-03-04 20:48:21 +00:00
-- $(ifdefD "componentsConfigs" [d| deriving instance (Ord ComponentName) |] )
$(ifD [d|
showComponentName :: ComponentName -> String
showComponentName CLibName = "library"
showComponentName (CExeName name) = "executable '" ++ name ++ "'"
showComponentName (CTestName name) = "test suite '" ++ name ++ "'"
showComponentName (CBenchName name) = "benchmark '" ++ name ++ "'"
|])
$(ifelsedefD "componentsConfigs" [d|
setComponentsConfigs
:: LocalBuildInfo
-> [(ComponentName, ComponentLocalBuildInfo, [ComponentName])]
-> LocalBuildInfo
setComponentsConfigs lbi cs = $(recUpdE' (nE "lbi") (mkName "componentsConfigs") (VarE $ mkName "cs"))
|] [d|
setComponentsConfigs
:: LocalBuildInfo
-> [(ComponentName, ComponentLocalBuildInfo, a)]
-> LocalBuildInfo
setComponentsConfigs lbi cs = flip execState lbi $ mapM setClbis gcs
where
2015-03-04 20:48:21 +00:00
gcs = groupBy (sameKind `on` fst3) $ sortBy (compare `on` showComponentName . fst3) cs
fst3 (x,_,_) = x
sameKind CLibName CLibName = True
sameKind CLibName _ = False
sameKind (CExeName _) (CExeName _) = True
sameKind (CExeName _) _ = False
sameKind (CTestName _) (CTestName _) = True
sameKind (CTestName _) _ = False
sameKind (CBenchName _) (CBenchName _) = True
sameKind (CBenchName _) _ = False
setClbis [(CLibName, clbi, _)] =
get >>= \lbi ->
put $ $(recUpdE' (nE "lbi") (mkName "libraryConfig") (AppE (ConE (mkName "Just")) (VarE (mkName "clbi"))))
setClbis cs@((CExeName _, _, _):_) =
let cfg = (\((CExeName n), clbi, _) -> (n, clbi)) <$> cs in
get >>= \lbi ->
put $ $(recUpdE' (nE "lbi") (mkName "executableConfigs") (VarE $ mkName "cfg"))
setClbis cs@((CTestName _, _, _):_) =
let cfg = (\((CTestName n), clbi, _) -> (n, clbi)) <$> cs in
get >>= \lbi ->
put $ $(recUpdE' (nE "lbi") (mkName "testSuiteConfigs") (VarE $ mkName "cfg"))
setClbis cs@((CBenchName _, _, _):_) =
let cfg = (\((CBenchName n), clbi, _) -> (n, clbi)) <$> cs in
get >>= \lbi ->
put $ $(recUpdE' (nE "lbi") (mkName "benchmarkConfigs") (VarE $ mkName "cfg"))
|])
$(ifD [d|
componentsConfigs ::
LocalBuildInfo -> [(ComponentName, ComponentLocalBuildInfo, [ComponentName])]
componentsConfigs LocalBuildInfo {..} =
(maybe [] (\c -> [(CLibName, c, [])]) $(nE "libraryConfig"))
++ ((\(n, clbi) -> (CExeName n, clbi, [])) <$> $(nE "executableConfigs"))
++ ((\(n, clbi) -> (CTestName n, clbi, [])) <$> $(nE "testSuiteConfigs"))
++ ((\(n, clbi) -> (CBenchName n, clbi, [])) <$> $(nE "benchmarkConfigs"))
getComponent :: PackageDescription -> ComponentName -> Component
getComponent pkg cname =
case lookupComponent pkg cname of
Just cpnt -> cpnt
Nothing -> missingComponent
where
missingComponent =
error $ "internal error: the package description contains no "
++ "component corresponding to " ++ show cname
lookupComponent :: PackageDescription -> ComponentName -> Maybe Component
lookupComponent pkg CLibName =
fmap CLib $ library pkg
lookupComponent pkg (CExeName name) =
fmap CExe $ find ((name ==) . exeName) (executables pkg)
lookupComponent pkg (CTestName name) =
fmap CTest $ find ((name ==) . testName) (testSuites pkg)
lookupComponent pkg (CBenchName name) =
fmap CBench $ find ((name ==) . benchmarkName) (benchmarks pkg)
-- We're lying here can't be bothered to order these
allComponentsInBuildOrder :: LocalBuildInfo
-> [(ComponentName, ComponentLocalBuildInfo)]
allComponentsInBuildOrder lbi =
[ (cname, clbi) | (cname, clbi, _) <- componentsConfigs lbi ]
getComponentLocalBuildInfo :: LocalBuildInfo -> ComponentName -> ComponentLocalBuildInfo
getComponentLocalBuildInfo lbi cname =
case [ clbi
| (cname', clbi, _) <- componentsConfigs lbi
, cname == cname' ] of
[clbi] -> clbi
_ -> missingComponent
where
missingComponent =
error $ "internal error: there is no configuration data "
++ "for component " ++ show cname
componentBuildInfo :: Component -> BuildInfo
componentBuildInfo =
foldComponent libBuildInfo buildInfo testBuildInfo benchmarkBuildInfo
|])
$(ifelsedefD "componentPackageRenaming" [d|
2015-03-04 20:48:21 +00:00
-- M.Map PackageName
newtype Deps = Deps { unDeps :: ([(InstalledPackageId, PackageId)], Map PackageName $(cT "ModuleRenaming")) }
-- $(return $ TySynD $(mkName "Deps") [] [t| |] )
2015-03-04 20:48:21 +00:00
noDeps = Deps ([], M.empty)
getDeps :: ComponentLocalBuildInfo -> Deps
2015-03-04 20:48:21 +00:00
getDeps = componentPackageDeps &&& $(nE "componentPackageRenaming") >>> Deps
setUnionDeps :: Deps -> ComponentLocalBuildInfo -> ComponentLocalBuildInfo
2015-03-04 20:48:21 +00:00
setUnionDeps (Deps (deps, rns)) clbi = let
clbi' = setComponentPackageRenaming clbi rns
cpdeps = componentPackageDeps clbi
in
clbi' {
componentPackageDeps = cpdeps `union` deps
}
setComponentPackageRenaming clbi cprn =
-- [| clbi { componentPackageRenaming = componentPackageRenaming clbi `M.union` cprn } |]
$(recUpdE'
(nE "clbi")
(mkName "componentPackageRenaming")
(InfixE
(Just
(AppE
(VarE
(mkName "componentPackageRenaming"))
(VarE (mkName "clbi"))
))
(VarE (mkName "M.union"))
(Just (VarE (mkName "cprn")))
)
)
|] [d|
2015-03-04 20:48:21 +00:00
newtype Deps = Deps { unDeps :: [(InstalledPackageId, PackageId)] }
2015-03-04 20:48:21 +00:00
noDeps = Deps []
getDeps :: ComponentLocalBuildInfo -> Deps
2015-03-04 20:48:21 +00:00
getDeps lbi = Deps $ componentPackageDeps lbi
2015-02-07 22:05:04 +00:00
setUnionDeps :: Deps -> ComponentLocalBuildInfo -> ComponentLocalBuildInfo
2015-03-04 20:48:21 +00:00
setUnionDeps (Deps deps) clbi = let
cpdeps = componentPackageDeps clbi
in
clbi {
componentPackageDeps = cpdeps `union` deps
}
2015-02-07 22:05:04 +00:00
-- setComponentPackageRenaming clbi _cprn = clbi
2015-02-07 22:05:04 +00:00
|])