diff options
| -rw-r--r-- | .gitlab-ci.yml | 5 | ||||
| -rw-r--r-- | cabal-helper.cabal | 26 | ||||
| -rw-r--r-- | lib/Distribution/Helper.hs | 23 | ||||
| -rw-r--r-- | src/CabalHelper/Compiletime/Types.hs | 3 | ||||
| -rw-r--r-- | src/CabalHelper/Runtime/Compat.hs | 7 | ||||
| -rw-r--r-- | src/CabalHelper/Runtime/HelperMain.hs | 330 | ||||
| -rw-r--r-- | src/CabalHelper/Shared/InterfaceTypes.hs | 45 | ||||
| -rw-r--r-- | tests/GhcSession.hs | 26 |
8 files changed, 83 insertions, 382 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 4e36e41..07c0a3c 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -27,11 +27,6 @@ job-ghc8.0: stage: build script: "$CI_PROJECT_DIR/scripts/ci/build.sh" -job-ghc7.10: - image: registry.gitlab.com/dxld/ghc-mod:ghc7.10.3-cabal-install2.4.1.0-stack2.1.1 - stage: build - script: "$CI_PROJECT_DIR/scripts/ci/build.sh" - job-check-upd: image: registry.gitlab.com/dxld/ghc-mod:ghc7.10.3-cabal-install2.4.1.0-stack2.1.0.1 stage: build diff --git a/cabal-helper.cabal b/cabal-helper.cabal index 9cc7215..9d23b93 100644 --- a/cabal-helper.cabal +++ b/cabal-helper.cabal @@ -100,27 +100,27 @@ common extensions other-extensions: TemplateHaskell common build-deps - build-depends: base < 5 && >= 4.8 - , Cabal < 2.5 && >= 2.0 || < 1.26 && >= 1.14 + build-depends: base < 5 && >= 4.9.1.0 + , Cabal < 2.5 && >= 2.0 || < 1.26 && >= 1.24.2.0 , cabal-plan < 0.6 && >= 0.5.0.0 , clock < 0.8 && >= 0.7.2 - , containers < 1 && >= 0.5.5.1 - , bytestring < 0.11 && >= 0.9.2.1 - , directory < 1.4 && >= 1.2.1.0 - , filepath < 1.5 && >= 1.3.0.0 + , containers < 1 && >= 0.5.7.1 + , bytestring < 0.11 && >= 0.10.8.1 + , directory < 1.4 && >= 1.3.0.0 + , filepath < 1.5 && >= 1.4.1.1 , mtl < 2.3 && >= 2.0 - , process < 1.7 && >= 1.2.3.0 + , process < 1.7 && >= 1.4.3.0 , pretty-show < 1.9 && >= 1.8.1 , semigroups < 0.19 && >= 0.18 , semigroupoids < 5.4 && >= 5.2 , SHA < 1.7 && >= 1.6.4.4 , text < 1.3 && >= 1.0.0.0 - , template-haskell < 2.15 && >= 2.7.0.0 + , template-haskell < 2.15 && >= 2.11.1.0 , temporary < 1.3 && >= 1.2.1 - , time < 1.9 && >= 1.5.0.1 - , transformers < 0.6 && >= 0.3.0.0 + , time < 1.9 && >= 1.6.0.1 + , transformers < 0.6 && >= 0.5.2.0 if !os(windows) - build-depends: unix < 2.8 && >= 2.5.1.1 + build-depends: unix < 2.8 && >= 2.7.2.1 build-depends: unix-compat < 0.6 && >= 0.4.3.1 , utf8-string < 1.1 && >= 1.0.1.1 if flag(dev) @@ -182,7 +182,7 @@ test-suite ghc-session main-is: GhcSession.hs hs-source-dirs: tests ghc-options: -Wall - build-depends: ghc < 8.7 && >= 7.10 + build-depends: ghc < 8.7 && >= 8.0.2 , ghc-paths < 0.2 && >= 0.1.0.9 , cabal-helper , c-h-internal @@ -215,7 +215,7 @@ executable cabal-helper-main buildable: False ghc-options: -Wall -fno-warn-unused-imports - build-depends: base < 5 && >= 4.8 + build-depends: base < 5 && >= 4.9.1.0 , Cabal , containers , bytestring diff --git a/lib/Distribution/Helper.hs b/lib/Distribution/Helper.hs index 98afbd3..89ce6f9 100644 --- a/lib/Distribution/Helper.hs +++ b/lib/Distribution/Helper.hs @@ -86,7 +86,6 @@ module Distribution.Helper ( , ChModuleName(..) , ChPkgDb(..) , ChEntrypoint(..) - , NeedsBuildOutput(..) -- * General information , Distribution.Helper.buildPlatform @@ -499,17 +498,15 @@ readUnitInfo :: Helper pt -> Unit pt -> IO UnitInfo readUnitInfo helper unit@Unit {uUnitId=uiUnitId} = do res <- runHelper helper unit [ "package-id" - , "package-db-stack" - , "flags" , "compiler-id" + , "flags" , "config-flags" , "non-default-config-flags" , "component-info" ] let [ Just (ChResponseVersion uiPackageId), - Just (ChResponsePkgDbs uiPackageDbStack), - Just (ChResponseFlags uiPackageFlags), Just (ChResponseVersion uiCompilerId), + Just (ChResponseFlags uiPackageFlags), Just (ChResponseFlags uiConfigFlags), Just (ChResponseFlags uiNonDefaultConfigFlags), Just (ChResponseComponentsInfo uiComponents) @@ -653,12 +650,13 @@ newtype Helper pt = Helper { runHelper :: Unit pt -> [String] -> IO [Maybe ChResponse] } getHelper :: ProjInfo pt -> QueryEnvI c pt -> IO (Helper pt) -getHelper ProjInfo{piCabalVersion} QueryEnv{..} +getHelper ProjInfo{piCabalVersion} qe@QueryEnv{..} | piCabalVersion == bultinCabalVersion = return $ Helper $ \Unit{ uCabalFile=CabalFile cabal_file , uDistDir=DistDirLib distdir } args -> - helper_main $ cabal_file : distdir : args + let pt = dispHelperProjectType (projTypeOfQueryEnv qe) in + helper_main $ cabal_file : distdir : pt : args getHelper proj_info qe@QueryEnv{..} = do withVerbosity $ withProgs (piImpl proj_info) qe $ do t0 <- Clock.getTime Monotonic @@ -671,8 +669,17 @@ getHelper proj_info qe@QueryEnv{..} = do Left rv -> panicIO $ "compileHelper': compiling helper failed! exit code "++ show rv Right exe -> + let pt = dispHelperProjectType (projTypeOfQueryEnv qe) in return $ Helper $ \Unit{uCabalFile, uDistDir} args -> - readHelper qe exe uCabalFile uDistDir args + readHelper qe exe uCabalFile uDistDir (pt : args) + +dispHelperProjectType :: SProjType pt -> String +dispHelperProjectType (SCabal SCV1) = "v1" +-- ^ v1-build needs a last minute addition of the inplace package-db +-- beyond what lbi has +dispHelperProjectType (SCabal SCV2) = "v2" +dispHelperProjectType SStack = "v2" +-- ^ stack also embeds all necessary options into lbi like v2 mkCompHelperEnv :: Verbose diff --git a/src/CabalHelper/Compiletime/Types.hs b/src/CabalHelper/Compiletime/Types.hs index 748b8d1..3871576 100644 --- a/src/CabalHelper/Compiletime/Types.hs +++ b/src/CabalHelper/Compiletime/Types.hs @@ -372,9 +372,6 @@ data UnitInfo = UnitInfo , uiCompilerId :: !(String, Version) -- ^ The version of GHC the unit is configured to use - , uiPackageDbStack :: !([ChPkgDb]) - -- ^ List of package databases to use. - , uiPackageFlags :: !([(String, Bool)]) -- ^ Flag definitions from cabal file diff --git a/src/CabalHelper/Runtime/Compat.hs b/src/CabalHelper/Runtime/Compat.hs index 1673b7a..d3fe5e6 100644 --- a/src/CabalHelper/Runtime/Compat.hs +++ b/src/CabalHelper/Runtime/Compat.hs @@ -29,6 +29,7 @@ module CabalHelper.Runtime.Compat , unUnqualComponentName' , componentNameFromComponent , componentOutDir + , internalPackageDBPath ) where import System.FilePath @@ -224,3 +225,9 @@ componentOutDir' lbi compName' = let targetDir = (buildDir lbi) </> compName' compDir = targetDir </> (compName' ++ "-tmp") in compDir + +#if !CH_MIN_VERSION_Cabal(2,0,0) +internalPackageDBPath :: LocalBuildInfo -> FilePath -> FilePath +internalPackageDBPath lbi distPref = + distPref </> "package.conf.inplace" +#endif diff --git a/src/CabalHelper/Runtime/HelperMain.hs b/src/CabalHelper/Runtime/HelperMain.hs index a3119e5..08cb9c5 100644 --- a/src/CabalHelper/Runtime/HelperMain.hs +++ b/src/CabalHelper/Runtime/HelperMain.hs @@ -160,9 +160,6 @@ import Distribution.Simple.LocalBuildInfo ( allLibModules , componentBuildDir ) -import Distribution.Simple.Register - ( internalPackageDBPath - ) import Distribution.Backpack ( OpenUnitId(..), OpenModule(..) @@ -235,7 +232,7 @@ usage = do hPutStr stderr $ "Usage: " ++ prog ++ " " ++ usageMsg where usageMsg = "" - ++"PROJ_DIR DIST_DIR [--with-* ...]\n" + ++"PROJ_DIR DIST_DIR (v1|v2)\n" ++" ( version\n" ++" | flags\n" ++" | config-flags\n" @@ -259,7 +256,7 @@ commands = [ "flags" helper_main :: [String] -> IO [Maybe ChResponse] helper_main args = do - cfile : distdir : args' + cfile : distdir : pt : args' <- case args of [] -> usage >> exitFailure _ -> return args @@ -342,17 +339,8 @@ helper_main args = do let CompilerId comp ver = compilerId $ compiler lbi return $ Just $ ChResponseVersion $ (,) (show comp) (toDataVersion ver) - "package-db-stack":[] -> do - let - pkgDb GlobalPackageDB = ChPkgGlobal - pkgDb UserPackageDB = ChPkgUser - pkgDb (SpecificPackageDB s) = ChPkgSpecific s - - -- TODO: Setup.hs has access to the sandbox as well: ghc-mod#478 - return $ Just $ ChResponsePkgDbs $ map pkgDb $ withPackageDB lbi - - "component-info":flags -> do - res <- componentsInfo flags lvd lbi v distdir + "component-info":[] -> do + res <- componentsInfo lvd pt return $ Just $ ChResponseComponentsInfo res "print-lbi":flags -> @@ -365,64 +353,29 @@ helper_main args = do _ -> errMsg "Invalid usage!" >> usage >> exitFailure +type ProjectType = String -- either "v1" or "v2" componentsInfo - :: [String] - -> (LocalBuildInfo, Verbosity, FilePath) - -> LocalBuildInfo - -> Verbosity - -> FilePath + :: (LocalBuildInfo, Verbosity, FilePath) + -> ProjectType -> IO (Map.Map ChComponentName ChComponentInfo) -componentsInfo flags lvd lbi v distdir = do - ciGhcOptions <- componentOptions lvd True flags id - - ciGhcSrcOptions <- componentOptions lvd False flags $ \opts -> mempty { - -- Not really needed but "unexpected package db stack: []" - ghcOptPackageDBs = [GlobalPackageDB, UserPackageDB], - - ghcOptCppOptions = ghcOptCppOptions opts, - ghcOptCppIncludePath = ghcOptCppIncludePath opts, - ghcOptCppIncludes = ghcOptCppIncludes opts, - ghcOptFfiIncludes = ghcOptFfiIncludes opts, - ghcOptSourcePathClear = ghcOptSourcePathClear opts, - ghcOptSourcePath = ghcOptSourcePath opts - } - - ciGhcPkgOptions <- componentOptions lvd True flags $ \opts -> mempty { - ghcOptPackageDBs = ghcOptPackageDBs opts, - ghcOptPackages = ghcOptPackages opts, - ghcOptHideAllPackages = ghcOptHideAllPackages opts - } - - ciGhcLangOptions <- componentOptions lvd False flags $ \opts -> mempty { - ghcOptPackageDBs = [GlobalPackageDB, UserPackageDB], - - ghcOptLanguage = ghcOptLanguage opts, - ghcOptExtensions = ghcOptExtensions opts, - ghcOptExtensionMap = ghcOptExtensionMap opts - } +componentsInfo lvd@(lbi, v, distdir) pt = do + let mod_ghc_opts opts + | pt == "v1" = opts { + ghcOptPackageDBs = + -- c.f. Simple/Build.hs createInternalPackageDB call + ghcOptPackageDBs opts ++ + [SpecificPackageDB $ internalPackageDBPath lbi distdir] + } + | pt == "v2" = opts + | otherwise = error $ "Unknown project-type '"++pt++"'!" + + ciGhcOptions <- componentOptions lvd mod_ghc_opts ciSourceDirs <- componentsMap lbi v distdir $ \_ _ bi -> return $ hsSourceDirs bi -#if CH_MIN_VERSION_Cabal(2,0,0) - includeDirMap <- recursiveDepInfo lbi v distdir - ciEntrypoints <- componentsMap lbi v distdir $ \c clbi _bi -> do - case needsBuildOutput includeDirMap (componentUnitId clbi) of - ProduceBuildOutput -> return $ componentEntrypoints c - NoBuildOutput -> return seps - where (_,_,seps) = recursiveIncludeDirs includeDirMap (componentUnitId clbi) -#else ciEntrypoints <- componentsMap lbi v distdir $ \c _clbi _bi -> return $ componentEntrypoints c -#endif - -#if CH_MIN_VERSION_Cabal(2,0,0) - ciNeedsBuildOutput <- componentsMap lbi v distdir $ \_c clbi _bi -> - return $ needsBuildOutput includeDirMap (componentUnitId clbi) -#else - ciNeedsBuildOutput <- componentsMap lbi v distdir $ \_c _clbi _bi -> - return $ NoBuildOutput -#endif let comp_name = map fst ciGhcOptions uiComponents = Map.fromList @@ -431,12 +384,8 @@ componentsInfo flags lvd lbi v distdir = do $ ChComponentInfo <$> ZipList comp_name <*> ZipList (map snd ciGhcOptions) - <*> ZipList (map snd ciGhcSrcOptions) - <*> ZipList (map snd ciGhcPkgOptions) - <*> ZipList (map snd ciGhcLangOptions) <*> ZipList (map snd ciSourceDirs) <*> ZipList (map snd ciEntrypoints) - <*> ZipList (map snd ciNeedsBuildOutput) return uiComponents @@ -444,25 +393,6 @@ componentsInfo flags lvd lbi v distdir = do flagName' :: Distribution.PackageDescription.Flag -> String flagName' = unFlagName . flagName --- getLibrary :: PackageDescription -> Library --- getLibrary pd = unsafePerformIO $ do --- lr <- newIORef (error "libraryMap: empty IORef") --- withLib pd (writeIORef lr) --- readIORef lr - -getLibraryClbi - :: PackageDescription - -> LocalBuildInfo - -> Maybe (Library, ComponentLocalBuildInfo) -getLibraryClbi pd lbi = unsafePerformIO $ do - lr <- newIORef Nothing - - withLibLBI pd lbi $ \ lib clbi -> - writeIORef lr $ Just (lib,clbi) - - readIORef lr - - componentsMap :: LocalBuildInfo -> Verbosity -> FilePath @@ -490,210 +420,27 @@ componentsMap lbi _v _distdir f = do componentOptions' :: (LocalBuildInfo, Verbosity, FilePath) - -> Bool - -> [String] -> (LocalBuildInfo -> Verbosity -> GhcOptions -> IO a) -> (GhcOptions -> GhcOptions) -> IO [(ChComponentName, a)] -componentOptions' (lbi, v, distdir) inplaceFlag flags rf f = do - let pd = localPkgDescr lbi -#if CH_MIN_VERSION_Cabal(2,0,0) - includeDirMap <- recursiveDepInfo lbi v distdir -#endif - +componentOptions' (lbi, v, distdir) rf f = do componentsMap lbi v distdir $ \c clbi bi -> let outdir = componentOutDir lbi c - (clbi', adopts) = case flags of - _ | not inplaceFlag -> (clbi, mempty) - ["--with-inplace"] -> (clbi, mempty) -#if CH_MIN_VERSION_Cabal(2,0,0) - [] -> removeInplaceDeps v lbi pd clbi includeDirMap -#else - [] -> removeInplaceDeps v lbi pd clbi -#endif - _ -> error $ "invalid flags: " ++ show flags - opts = componentGhcOptions normal lbi bi clbi' outdir - opts' = f opts + opts = componentGhcOptions normal lbi bi clbi outdir - in rf lbi v $ nubPackageFlags $ opts' `mappend` adopts + in rf lbi v $ f opts componentOptions :: (LocalBuildInfo, Verbosity, FilePath) - -> Bool - -> [String] -> (GhcOptions -> GhcOptions) -> IO [(ChComponentName, [String])] -componentOptions (lbi, v, distdir) inplaceFlag flags f = - componentOptions' (lbi, v, distdir) inplaceFlag flags renderGhcOptions' f +componentOptions (lbi, v, distdir) f = + componentOptions' (lbi, v, distdir) renderGhcOptions' f gmModuleName :: C.ModuleName -> ChModuleName gmModuleName = ChModuleName . intercalate "." . components -#if CH_MIN_VERSION_Cabal(2,0,0) -removeInplaceDeps :: Verbosity - -> LocalBuildInfo - -> PackageDescription - -> ComponentLocalBuildInfo - -> Map.Map UnitId SubDeps - -> (ComponentLocalBuildInfo, GhcOptions) -removeInplaceDeps _v lbi pd clbi includeDirs = let - removeInplace c = - let - (ideps, incs) = partition (isInplaceCompInc c) (componentIncludes c) - hasIdeps' = not $ null ideps - c' = c { componentPackageDeps = error "using deprecated field:componentPackageDeps" - , componentInternalDeps = [] - , componentIncludes = incs } - in (hasIdeps',c') - - needsBuild = needsBuildOutput includeDirs (componentUnitId clbi) - - cleanRecursiveOpts :: Component - -> BuildInfo -> ComponentLocalBuildInfo -> GhcOptions - cleanRecursiveOpts comp libbi libclbi = - let - liboutdir = componentOutDir lbi comp - (_,libclbi') = removeInplace libclbi - (extraIncludes,extraDeps',_ems) = recursiveIncludeDirs includeDirs (componentUnitId libclbi) - (_,extraDeps) = partition (isInplaceCompInc libclbi) extraDeps' - opts = (componentGhcOptions normal lbi libbi libclbi' liboutdir) { - ghcOptPackageDBs = [] - } - - in - opts { ghcOptSourcePath = ghcOptSourcePath opts <> toNubListR extraIncludes - , ghcOptPackages = ghcOptPackages opts <> toNubListR extraDeps } - - libopts = - case (getLibraryClbi pd lbi, getExeClbi pd lbi) of - (Just (lib, libclbi),_) | hasIdeps -> - let - libbi = libBuildInfo lib - opts = cleanRecursiveOpts (CLib lib) libbi libclbi - in - opts { ghcOptInputModules = ghcOptInputModules opts <> (toNubListR $ allLibModules lib libclbi) } - (_,Just (exe,execlbi)) | hasIdeps -> - let - exebi = buildInfo exe - in - cleanRecursiveOpts (CExe exe) exebi execlbi - _ -> mempty - - distDir = fromFlagOrDefault ("." </> "dist") (configDistPref $ configFlags lbi) - packageDbDir = internalPackageDBPath lbi distDir - (hasIdeps,clbi') = case needsBuild of - NoBuildOutput -> removeInplace clbi - ProduceBuildOutput -> (False, clbi) - libopts' = case needsBuild of - NoBuildOutput -> libopts - ProduceBuildOutput -> mempty { ghcOptPackageDBs = [SpecificPackageDB packageDbDir] } - in (clbi', libopts') - -getExeClbi - :: PackageDescription - -> LocalBuildInfo - -> Maybe (Executable, ComponentLocalBuildInfo) -getExeClbi pd lbi = unsafePerformIO $ do - lr <- newIORef Nothing - - withExeLBI pd lbi $ \ exe clbi -> - writeIORef lr $ Just (exe,clbi) - - readIORef lr - -#else - -removeInplaceDeps :: Verbosity - -> LocalBuildInfo - -> PackageDescription - -> ComponentLocalBuildInfo - -> (ComponentLocalBuildInfo, GhcOptions) -removeInplaceDeps _v lbi pd clbi = let - (ideps, deps) = partition (isInplaceDep lbi) (componentPackageDeps clbi) - hasIdeps = not $ null ideps - libopts = - case getLibraryClbi pd lbi of - Just (lib, libclbi) | hasIdeps -> - let - libbi = libBuildInfo lib - liboutdir = componentOutDir lbi (CLib lib) - in - (componentGhcOptions normal lbi libbi libclbi liboutdir) { - ghcOptPackageDBs = [] - } - _ -> mempty - clbi' = clbi { componentPackageDeps = deps } - in (clbi', libopts) - -#endif - - -#if CH_MIN_VERSION_Cabal(2,0,0) -recursiveDepInfo - :: LocalBuildInfo - -> Verbosity - -> FilePath - -> IO (Map.Map UnitId SubDeps) -recursiveDepInfo lbi v distdir = do - includeDirs <- componentsMap lbi v distdir $ \c clbi bi -> do - return (componentUnitId clbi - , ( SubDeps - { sdComponentInternalDeps = componentInternalDeps clbi - , sdHsSourceDirs = hsSourceDirs bi - , sdComponentIncludes = componentIncludes clbi - , sdComponentEntryPoints = componentEntrypoints c}) ) - return $ Map.fromList $ map snd includeDirs - -data SubDeps = SubDeps - { sdComponentInternalDeps :: [UnitId] - , sdHsSourceDirs :: [FilePath] - , sdComponentIncludes :: [(OpenUnitId, ModuleRenaming)] - , sdComponentEntryPoints :: ChEntrypoint - } - -recursiveIncludeDirs :: Map.Map UnitId SubDeps - -> UnitId -> ([FilePath], [(OpenUnitId, ModuleRenaming)] - , ChEntrypoint) -recursiveIncludeDirs includeDirs unit = go ([],[],Nothing) [unit] - where - go (afp,aci,Nothing ) [] = (afp,aci,error "recursiveIncludeDirs:no ChEntrypoint") - go (afp,aci,Just amep) [] = (afp,aci,amep) - go acc@(afp,aci,amep) (u:us) = case Map.lookup u includeDirs of - Nothing -> go acc us - Just (SubDeps us' sfp sci sep) -> go (afp++sfp,aci++sci,Just (combineEp amep sep)) (us++us') - -needsBuildOutput :: Map.Map UnitId SubDeps -> UnitId -> NeedsBuildOutput -needsBuildOutput includeDirs unit = go [unit] - where - isIndef (IndefFullUnitId _ _) = True - isIndef _ = False - go [] = NoBuildOutput - go (u:us) = case Map.lookup u includeDirs of - Nothing -> go us - Just (SubDeps us' _sfp sci _sep) -> - if any (isIndef . fst) sci - then ProduceBuildOutput - else go (us++us') - --- | combineEP is used to combine the entrypoints when recursively chasing --- through the dependencies of a given entry point. The first parameter is the --- current accumulated value, and the second one is the current sub-dependency --- being considered. So the bias should be to preserve the type of entrypoint --- from the first parameter. -combineEp :: Maybe ChEntrypoint -> ChEntrypoint -> ChEntrypoint -combineEp Nothing e = e -combineEp (Just ChSetupEntrypoint) e = e -combineEp (Just (ChLibEntrypoint es1 os1 ss1)) (ChLibEntrypoint es2 os2 ss2) = (ChLibEntrypoint (nub $ es2++es1) (nub $ os2++os1) (nub $ ss2++ss1)) -combineEp _ e@(ChExeEntrypoint _mi _os2) = error $ "combineEP: cannot have a sub exe:" ++ show e -combineEp (Just (ChExeEntrypoint mi os1)) (ChLibEntrypoint es2 os2 ss2) = (ChExeEntrypoint mi (nub $ os1++es2++os2++ss2)) -combineEp me e = error $ "combineEp: undhandled case: " ++ show (me, e) - --- no, you unconditionally always wrap the result in Just, so instead of `f x = Just y; f x = Just z` do `f x = y; f x = z` and use f as `Just . f` - -#endif - - initialBuildStepsForAllComponents :: FilePath -> PackageDescription @@ -756,35 +503,6 @@ componentEntrypoints (CBench Benchmark { benchmarkInterface = BenchmarkExeV10 _ componentEntrypoints (CBench Benchmark {}) = ChLibEntrypoint [] [] [] -#if CH_MIN_VERSION_Cabal(2,0,0) -isInplaceCompInc :: ComponentLocalBuildInfo -> (OpenUnitId, ModuleRenaming) -> Bool -isInplaceCompInc clbi (DefiniteUnitId uid, _mr) = unDefUnitId uid `elem` componentInternalDeps clbi -isInplaceCompInc _clbi (IndefFullUnitId _uid _, _mmr) = False -#endif - -#if CH_MIN_VERSION_Cabal(2,0,0) --- isInplaceDep :: LocalBuildInfo -> ComponentLocalBuildInfo -> (UnitId, MungedPackageId) -> Bool --- isInplaceDep lbi clbi (uid, _mpid) = uid `elem` componentInternalDeps clbi -#else -isInplaceDep :: LocalBuildInfo -> (UnitId, PackageId) -> Bool -# if CH_MIN_VERSION_Cabal(1,23,0) --- CPP >= 1.23 -isInplaceDep lbi (ipid, _pid) = localUnitId lbi == ipid -# else --- CPP <= 1.22 -isInplaceDep _lbi (ipid, pid) = inplacePackageId pid == ipid -# endif -#endif - -nubPackageFlags :: GhcOptions -> GhcOptions -#if CH_MIN_VERSION_Cabal(1,22,0) --- CPP >= 1.22 --- >= 1.22 uses NubListR -nubPackageFlags opts = opts -#else -nubPackageFlags opts = opts { ghcOptPackages = nub $ ghcOptPackages opts } -#endif - renderGhcOptions' :: LocalBuildInfo -> Verbosity -> GhcOptions diff --git a/src/CabalHelper/Shared/InterfaceTypes.hs b/src/CabalHelper/Shared/InterfaceTypes.hs index 87536a5..ed06045 100644 --- a/src/CabalHelper/Shared/InterfaceTypes.hs +++ b/src/CabalHelper/Shared/InterfaceTypes.hs @@ -39,10 +39,8 @@ import Data.Map.Strict (Map) data ChResponse = ChResponseComponentsInfo (Map ChComponentName ChComponentInfo) | ChResponseList [String] - | ChResponsePkgDbs [ChPkgDb] | ChResponseLbi String | ChResponseVersion (String, Version) - | ChResponseLicenses [(String, [(String, Version)])] | ChResponseFlags [(String, Bool)] deriving (Eq, Ord, Read, Show, Generic) @@ -68,16 +66,6 @@ data ChComponentInfo = ChComponentInfo , ciGhcOptions :: [String] -- ^ Full set of GHC options, ready for loading this component into GHCi. - , ciGhcSrcOptions :: [String] - -- ^ Only search path related GHC options. - - , ciGhcPkgOptions :: [String] - -- ^ Only package related GHC options, sufficient for things don't need to - -- access any home modules. - - , ciGhcLangOptions :: [String] - -- ^ Only Haskell language extension related options, i.e. @-XSomeExtension@ - , ciSourceDirs :: [String] -- ^ A component's @hs-source-dirs@ field, note that this only contains the -- directories specified by the cabal file, however cabal also adds the @@ -87,32 +75,21 @@ data ChComponentInfo = ChComponentInfo , ciEntrypoints :: ChEntrypoint -- ^ Modules or files Cabal would have the compiler build directly. Can be -- used to compute the home module closure for a component. - - , ciNeedsBuildOutput :: NeedsBuildOutput - -- ^ If a component has a non-default module renaming (backpack) it cannot - -- be built in memory and instead needs proper build output. - -- TODO: This is a ghc-mod legacy thing and has to be removed } deriving (Eq, Ord, Read, Show) --- TODO: we know the source-dir now so we can resolve ChSetupEntrypoint --- internally -data ChEntrypoint = ChSetupEntrypoint -- ^ Almost like 'ChExeEntrypoint' but - -- @main-is@ could either be @"Setup.hs"@ - -- or @"Setup.lhs"@. Since we don't know - -- where the source directory is you have - -- to find these files. - | ChLibEntrypoint { chExposedModules :: [ChModuleName] - , chOtherModules :: [ChModuleName] - , chSignatures :: [ChModuleName] -- backpack only - } - | ChExeEntrypoint { chMainIs :: FilePath - , chOtherModules :: [ChModuleName] - } deriving (Eq, Ord, Read, Show, Generic) +data ChEntrypoint + = ChSetupEntrypoint + | ChLibEntrypoint + { chExposedModules :: [ChModuleName] + , chOtherModules :: [ChModuleName] + , chSignatures :: [ChModuleName] -- backpack only + } + | ChExeEntrypoint + { chMainIs :: FilePath + , chOtherModules :: [ChModuleName] + } deriving (Eq, Ord, Read, Show, Generic) data ChPkgDb = ChPkgGlobal | ChPkgUser | ChPkgSpecific FilePath deriving (Eq, Ord, Read, Show, Generic) - -data NeedsBuildOutput = ProduceBuildOutput | NoBuildOutput - deriving (Eq, Ord, Read, Show, Generic) diff --git a/tests/GhcSession.hs b/tests/GhcSession.hs index a963ae4..2fdd3e2 100644 --- a/tests/GhcSession.hs +++ b/tests/GhcSession.hs @@ -324,8 +324,9 @@ test modProgs (psdImpl -> ProjSetupImpl{..}) topdir tmpdir projdir cabal_file cs <- concat <$> runQuery (allUnits (Map.elems . uiComponents)) qe - when (any ((==ProduceBuildOutput) . ciNeedsBuildOutput) cs) $ - psiBuild progs projdir + + -- TODO: Cludge until we can just build the unit dependencies + psiBuild progs projdir let pkgdir = takeDirectory cabal_file homedir <- getHomeDirectory @@ -343,7 +344,7 @@ test modProgs (psdImpl -> ProjSetupImpl{..}) topdir tmpdir projdir cabal_file putStrLn sopts hFlush stdout - tr <- compileModule pkgdir ciNeedsBuildOutput ciEntrypoints ciSourceDirs opts' + tr <- compileModule pkgdir ciEntrypoints ciSourceDirs opts' return $ tr ciComponentName where formatArg x @@ -355,14 +356,14 @@ addCabalProject dir = do writeFile (dir </> "cabal.project") "packages: .\n" compileModule - :: FilePath -> NeedsBuildOutput -> ChEntrypoint -> [FilePath] -> [String] + :: FilePath -> ChEntrypoint -> [FilePath] -> [String] -> IO (ChComponentName -> FilePath -> String -> String -> TestResult) -compileModule pkgdir nb ep srcdirs opts = do +compileModule pkgdir ep srcdirs opts = do cwd_before <- getCurrentDirectory setCurrentDirectory pkgdir flip E.finally (setCurrentDirectory cwd_before) $ do - putStrLn $ "compiling: " ++ show ep ++ " (" ++ show nb ++ ")" + putStrLn $ "compiling: " ++ show ep E.handle (\(ec :: ExitCode) -> print ec >> return (TestResult False)) $ do @@ -371,9 +372,7 @@ compileModule pkgdir nb ep srcdirs opts = do let printGhcEx e = GHC.printException e >> return (TestResult False) handleSourceError printGhcEx $ do - let target = case nb of - ProduceBuildOutput -> HscNothing -- AZ: what should this be? - NoBuildOutput -> HscInterpreted + let target = HscInterpreted -- TODO dflags0 <- getSessionDynFlags let dflags1 = dflags0 { @@ -403,16 +402,17 @@ compileModule pkgdir nb ep srcdirs opts = do -- TODO: this doesn't support Setup.lhs ["Setup.hs"] - let ts' = case nb of - NoBuildOutput -> map (\t -> t { targetAllowObjCode = False }) ts - ProduceBuildOutput -> ts + -- Always compile targets as GHCi bytecode so the setContext call below + -- can always succeed + let ts' = map (\t -> t { targetAllowObjCode = False }) ts liftIO $ putStrLn $ "targets: " ++ showPpr dflags2 ts' setTargets ts' _ <- load LoadAllTargets - when (nb == NoBuildOutput) $ do +-- when (nb == NoBuildOutput) $ do + do setContext $ case ep of ChLibEntrypoint ms ms' ss -> map (IIModule . mkModuleName . unChModuleName) $ ms ++ ms' ++ ss |