diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index ac11a4b67..2527f95ad 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -16,15 +16,13 @@ {-# LANGUAGE CPP #-} module Language.Haskell.GhcMod.CabalHelper -#ifndef SPEC ( getComponents , getGhcMergedPkgOptions , getCabalPackageDbStack , prepareCabalHelper , withAutogen - ) -#endif - where + , withCabal + ) where import Control.Applicative import Control.Monad diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs index 07c8fb282..d37eab52e 100644 --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/Language/Haskell/GhcMod/Cradle.hs @@ -1,15 +1,14 @@ {-# LANGUAGE CPP #-} module Language.Haskell.GhcMod.Cradle -#ifndef SPEC - ( - findCradle + ( findCradle , findCradle' , findCradleNoLog , findSpecCradle , cleanupCradle - ) -#endif - where + + -- * for @spec@ + , plainCradle + ) where import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Monad.Types diff --git a/Setup.hs b/Setup.hs index 91354522a..888994383 100755 --- a/Setup.hs +++ b/Setup.hs @@ -1,13 +1,18 @@ #!/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.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 @@ -18,37 +23,130 @@ 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 + xBuildDependsLike <$> (confHook simpleUserHooks) (gpd, hbi) cf, + + buildHook = \pd lbi hooks flags -> (buildHook simpleUserHooks) pd (patchLibexecdir lbi) hooks flags } +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 e4875d823..000000000 --- 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 3cfe5c11f..7220dcc6b 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 Language/Haskell/GhcMod/Monad/Compat.hs_h @@ -99,9 +98,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 @@ -209,6 +209,22 @@ Library Build-Depends: ghc-boot Executable ghc-mod + Default-Language: Haskell2010 + Main-Is: GHCModWrapper.hs + Other-Modules: Paths_ghc_mod + HS-Source-Dirs: src, . + GHC-Options: -Wall + Build-Depends: base < 5 && >= 4.0 + , directory < 1.3 + , filepath < 1.5 + , process < 1.5 + + , deepseq < 1.5 + , binary < 0.9 && >= 0.5.1.0 + , old-time < 1.2 + , time < 1.7 + +Executable ghc-mod-real Default-Language: Haskell2010 Main-Is: GHCMod.hs Other-Modules: Paths_ghc_mod @@ -230,6 +246,8 @@ Executable ghc-mod , fclabels == 2.0.* , optparse-applicative >=0.11.0 && <0.13.0 , ghc-mod + X-Internal: True + Executable ghc-modi Default-Language: Haskell2010 diff --git a/src/GHCModWrapper.hs b/src/GHCModWrapper.hs new file mode 100644 index 000000000..d01ff2eb9 --- /dev/null +++ b/src/GHCModWrapper.hs @@ -0,0 +1,30 @@ +-- | Dispatcher program to support co-installation of multiple ghc-mod +-- instances (compiled against different GHC versions) without breaking the +-- commandline API +module Main where + +import System.IO +import System.Exit +import System.Process +import System.FilePath +import System.Environment +import Utils + +import Paths_ghc_mod + +main :: IO () +main = do + args <- getArgs + libexecdir <- getLibexecDir + let installedExe = libexecdir "ghc-mod-real" + mexe <- mightExist installedExe + case mexe of + Nothing -> do + hPutStrLn stderr $ + "ghc-mod: Could not find '"++installedExe++"', check your installation!" + exitWith $ ExitFailure 1 + + Just exe -> do + (_, _, _, h) <- + createProcess $ proc exe args + exitWith =<< waitForProcess h