Simplify Setup.hs by renaming int. exe into place

This commit is contained in:
Daniel Gröber 2017-05-17 23:59:29 +02:00
parent d7a00ffcca
commit 9804b29aaa
3 changed files with 116 additions and 213 deletions

120
Setup.hs
View File

@ -1,14 +1,19 @@
#!/usr/bin/env runhaskell
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
import Distribution.Simple
import Distribution.Simple.Utils
import Distribution.Simple.Setup
import Distribution.Simple.Install
import Distribution.Simple.Program
import Distribution.Simple.Register
import Distribution.Simple.InstallDirs as ID
import Distribution.Simple.BuildPaths
import qualified Distribution.Simple.InstallDirs as ID
import Distribution.Simple.LocalBuildInfo
import Distribution.PackageDescription
import qualified Data.Map as M
import Data.Map (Map)
import Control.Arrow
import Control.Applicative
import Control.Monad
@ -19,38 +24,131 @@ import Data.Monoid
import System.Process
import System.Exit
import System.FilePath
import SetupCompat
import System.Directory (renameFile)
main :: IO ()
main = defaultMainWithHooks $ simpleUserHooks {
instHook = inst,
copyHook = copy,
confHook = \(gpd, hbi) cf ->
xBuildDependsLike <$> (confHook simpleUserHooks) (gpd, hbi) cf
, buildHook = \pd lbi hooks flags -> (buildHook simpleUserHooks) pd (patchLibexecdir lbi) hooks flags
, hookedPrograms = [ simpleProgram "shelltest" ]
}
patchLibexecdir :: LocalBuildInfo -> LocalBuildInfo
patchLibexecdir lbi = let
idirtpl = installDirTemplates lbi
libexecdir' = toPathTemplate $ fromPathTemplate (libexecdir idirtpl) </> "$abi/$pkgid"
lbi' = lbi { installDirTemplates = idirtpl { libexecdir = libexecdir' } }
in
lbi'
xBuildDependsLike :: LocalBuildInfo -> LocalBuildInfo
xBuildDependsLike lbi =
let
cc = componentsConfigs lbi
pd = localPkgDescr lbi
deps = dependsMap lbi
in setComponentsConfigs lbi
in lbi {
componentsConfigs =
[ (cn, updateClbi deps comp clbi, cdeps)
| (cn, clbi, cdeps) <- cc
, let comp = getComponent pd cn
]
}
where
updateClbi deps comp clbi = setUnionDeps (otherDeps deps comp) clbi
dependsMap ::
LocalBuildInfo -> [(ComponentName, Deps)]
-- dependsMap ::
-- LocalBuildInfo -> [(ComponentName, ([(UnitId, PackageId)], Map PackageName ModuleRenaming))]
dependsMap lbi =
second getDeps <$> allComponentsInBuildOrder lbi
second (componentPackageDeps &&& componentPackageRenaming)
<$> allComponentsInBuildOrder lbi
otherDeps :: [(ComponentName, Deps)] -> Component -> Deps
otherDeps deps comp = fromMaybe noDeps $
-- otherDeps :: [(ComponentName, ([(UnitId, PackageId)], Map PackageName ModuleRenaming))] -> Component -> ([(UnitId, PackageId)], Map PackageName ModuleRenaming)
otherDeps deps comp = fromMaybe ([], M.empty) $
flip lookup deps =<< read <$> lookup "x-build-depends-like" fields
where
fields = customFieldsBI (componentBuildInfo comp)
setComponentPackageRenaming clbi cprn =
clbi { componentPackageRenaming =
componentPackageRenaming clbi `M.union` cprn }
-- setUnionDeps :: ([(UnitId, PackageId)], Map PackageName ModuleRenaming) -> ComponentLocalBuildInfo -> ComponentLocalBuildInfo
setUnionDeps (deps, rns) clbi = let
clbi' = setComponentPackageRenaming clbi rns
cpdeps = componentPackageDeps clbi
in
clbi' {
componentPackageDeps = cpdeps `union` deps
}
-- mostly copypasta from 'defaultInstallHook'
inst ::
PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO ()
inst pd lbi _uf ifl = do
let copyFlags = defaultCopyFlags {
copyDistPref = installDistPref ifl,
copyDest = toFlag NoCopyDest,
copyVerbosity = installVerbosity ifl
}
xInstallTarget pd lbi copyFlags (\pd' lbi' -> install pd' lbi' copyFlags)
let registerFlags = defaultRegisterFlags {
regDistPref = installDistPref ifl,
regInPlace = installInPlace ifl,
regPackageDB = installPackageDB ifl,
regVerbosity = installVerbosity ifl
}
when (hasLibs pd) $ register pd lbi registerFlags
copy :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO ()
copy pd lbi _uh cf =
xInstallTarget pd lbi cf (\pd' lbi' -> install pd' lbi' cf)
xInstallTarget :: PackageDescription
-> LocalBuildInfo
-> CopyFlags
-> (PackageDescription -> LocalBuildInfo -> IO ())
-> IO ()
xInstallTarget pd lbi cf fn = do
let (extended, regular) = partition isInternal (executables pd)
let pd_regular = pd { executables = regular }
_ <- flip mapM extended $ \exe -> do
let pd_extended = onlyExePackageDesc [exe] pd
fn pd_extended lbi
let lbi' = patchLibexecdir lbi
copydest = fromFlag (copyDest cf)
verbosity = fromFlag (copyVerbosity cf)
InstallDirs { bindir, libexecdir } = absoluteInstallDirs pd lbi' copydest
progprefix = substPathTemplate (packageId pd) lbi (progPrefix lbi)
progsuffix = substPathTemplate (packageId pd) lbi (progSuffix lbi)
fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix
fixedExeFileName = bindir </> fixedExeBaseName <.> exeExtension
newExeFileName = libexecdir </> fixedExeBaseName <.> exeExtension
when (exeName exe == "ghc-mod-real") $ do
createDirectoryIfMissingVerbose verbosity True libexecdir
renameFile fixedExeFileName newExeFileName
fn pd_regular lbi
where
isInternal :: Executable -> Bool
isInternal exe =
fromMaybe False $ (=="True") <$> lookup "x-internal" (customFieldsBI $ buildInfo exe)
onlyExePackageDesc :: [Executable] -> PackageDescription -> PackageDescription
onlyExePackageDesc exes pd = emptyPackageDescription {
package = package pd
, executables = exes
}

View File

@ -1,195 +0,0 @@
{-# 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
import Data.Map (Map)
import NotCPP.Declarations
import Language.Haskell.TH
-- $(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
gcs = groupBy (sameKind `on` fst3) $ sortBy (compare `on` showComponentName . fst3) cs
fst3 (x,_,_) = x
sameKind CLibName CLibName = True
sameKind (CExeName _) (CExeName _) = True
sameKind (CTestName _) (CTestName _) = True
sameKind (CBenchName _) (CBenchName _) = True
sameKind _ _ = 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|
-- M.Map PackageName
newtype Deps = Deps { unDeps :: ([(InstalledPackageId, PackageId)], Map PackageName $(cT "ModuleRenaming")) }
-- $(return $ TySynD $(mkName "Deps") [] [t| |] )
noDeps = Deps ([], M.empty)
getDeps :: ComponentLocalBuildInfo -> Deps
getDeps = componentPackageDeps &&& $(nE "componentPackageRenaming") >>> Deps
setUnionDeps :: Deps -> ComponentLocalBuildInfo -> ComponentLocalBuildInfo
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|
newtype Deps = Deps { unDeps :: [(InstalledPackageId, PackageId)] }
noDeps = Deps []
getDeps :: ComponentLocalBuildInfo -> Deps
getDeps lbi = Deps $ componentPackageDeps lbi
setUnionDeps :: Deps -> ComponentLocalBuildInfo -> ComponentLocalBuildInfo
setUnionDeps (Deps deps) clbi = let
cpdeps = componentPackageDeps clbi
in
clbi {
componentPackageDeps = cpdeps `union` deps
}
-- setComponentPackageRenaming clbi _cprn = clbi
|])

View File

@ -25,13 +25,12 @@ Description:
For more information, please see its home page.
Category: GHC, Development
Cabal-Version: >= 1.14
Cabal-Version: >= 1.24
Build-Type: Custom
Data-Files: elisp/Makefile
elisp/*.el
Data-Files: LICENSE COPYING.BSD3 COPYING.AGPL3
Extra-Source-Files: ChangeLog
SetupCompat.hs
NotCPP/*.hs
NotCPP/COPYING
core/Language/Haskell/GhcMod/Monad/Compat.hs_h
@ -96,9 +95,10 @@ Extra-Source-Files: ChangeLog
Custom-Setup
Setup-Depends: base
, Cabal < 1.25
, Cabal >= 1.24 && < 1.25
, containers
, filepath
, directory
, process
, template-haskell
, transformers