From 9804b29aaaa70b8d591a4c37fbd331ae630ff3ae Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 17 May 2017 23:59:29 +0200 Subject: [PATCH] Simplify Setup.hs by renaming int. exe into place --- Setup.hs | 128 ++++++++++++++++++++++++++++---- SetupCompat.hs | 195 ------------------------------------------------- ghc-mod.cabal | 6 +- 3 files changed, 116 insertions(+), 213 deletions(-) delete mode 100644 SetupCompat.hs diff --git a/Setup.hs b/Setup.hs index f8a0992..6ddcda6 100755 --- a/Setup.hs +++ b/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 - [ (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 + } diff --git a/SetupCompat.hs b/SetupCompat.hs deleted file mode 100644 index e4875d8..0000000 --- a/SetupCompat.hs +++ /dev/null @@ -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 - - |]) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index ab6786f..2fff718 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -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