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

128
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
[ (cn, updateClbi deps comp clbi, cdeps)
| (cn, clbi, cdeps) <- cc
, let comp = getComponent pd cn
]
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
}