Simplify Setup.hs by renaming int. exe into place
This commit is contained in:
Daniel Gröber
parent
d7a00ffcca
commit
9804b29aaa
120
Setup.hs
120
Setup.hs
@ -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
|
||||
}
|
||||
|
||||
195
SetupCompat.hs
195
SetupCompat.hs
@ -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
|
||||
|
||||
|])
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user