diff options
| -rw-r--r-- | lib/Distribution/Helper.hs | 24 | ||||
| -rw-r--r-- | src/CabalHelper/Runtime/Main.hs | 85 | ||||
| -rw-r--r-- | src/CabalHelper/Shared/InterfaceTypes.hs | 18 | ||||
| -rw-r--r-- | tests/GhcSession.hs | 53 |
4 files changed, 121 insertions, 59 deletions
diff --git a/lib/Distribution/Helper.hs b/lib/Distribution/Helper.hs index bef95ba..f98955c 100644 --- a/lib/Distribution/Helper.hs +++ b/lib/Distribution/Helper.hs @@ -56,6 +56,7 @@ module Distribution.Helper ( , ghcOptions , sourceDirs , entrypoints + , needsBuildOutput -- * Query environment , QueryEnv @@ -206,7 +207,8 @@ data SomeLocalBuildInfo = SomeLocalBuildInfo { slbiGhcOptions :: [(ChComponentName, [String])], slbiSourceDirs :: [(ChComponentName, [String])], - slbiEntrypoints :: [(ChComponentName, ChEntrypoint)] + slbiEntrypoints :: [(ChComponentName, ChEntrypoint)], + slbiNeedsBuildOutput :: [(ChComponentName, NeedsBuildOutput)] } deriving (Eq, Ord, Read, Show) -- | A lazy, cached, query against a package's Cabal configuration. Use @@ -295,6 +297,9 @@ components (ComponentQuery sc) = map (\(cn, f) -> f cn) `liftM` sc -- to compute the home module closure for a component. entrypoints :: MonadIO m => ComponentQuery m ChEntrypoint +-- | The component has a non-default module renaming, so needs build output (). +needsBuildOutput :: MonadIO m => ComponentQuery m NeedsBuildOutput + -- | A component's @source-dirs@ field, beware since if this is empty implicit -- behaviour in GHC kicks in. sourceDirs :: MonadIO m => ComponentQuery m [FilePath] @@ -321,12 +326,13 @@ ghcMergedPkgOptions = Query $ slbiGhcMergedPkgOptions `liftM` getSlbi configFlags = Query $ slbiConfigFlags `liftM` getSlbi nonDefaultConfigFlags = Query $ slbiNonDefaultConfigFlags `liftM` getSlbi -ghcSrcOptions = ComponentQuery $ Query $ slbiGhcSrcOptions `liftM` getSlbi -ghcPkgOptions = ComponentQuery $ Query $ slbiGhcPkgOptions `liftM` getSlbi -ghcOptions = ComponentQuery $ Query $ slbiGhcOptions `liftM` getSlbi -ghcLangOptions = ComponentQuery $ Query $ slbiGhcLangOptions `liftM` getSlbi -sourceDirs = ComponentQuery $ Query $ slbiSourceDirs `liftM` getSlbi -entrypoints = ComponentQuery $ Query $ slbiEntrypoints `liftM` getSlbi +ghcSrcOptions = ComponentQuery $ Query $ slbiGhcSrcOptions `liftM` getSlbi +ghcPkgOptions = ComponentQuery $ Query $ slbiGhcPkgOptions `liftM` getSlbi +ghcOptions = ComponentQuery $ Query $ slbiGhcOptions `liftM` getSlbi +ghcLangOptions = ComponentQuery $ Query $ slbiGhcLangOptions `liftM` getSlbi +sourceDirs = ComponentQuery $ Query $ slbiSourceDirs `liftM` getSlbi +entrypoints = ComponentQuery $ Query $ slbiEntrypoints `liftM` getSlbi +needsBuildOutput = ComponentQuery $ Query $ slbiNeedsBuildOutput `liftM` getSlbi -- | Run @cabal configure@ reconfigure :: MonadIO m @@ -398,6 +404,7 @@ getSomeConfigState = ask >>= \QueryEnv {..} -> do , "source-dirs" , "entrypoints" + , "needsbuildoutput" ] let [ Just (ChResponsePkgDbs slbiPackageDbStack), Just (ChResponseFlags slbiPackageFlags), @@ -415,7 +422,8 @@ getSomeConfigState = ask >>= \QueryEnv {..} -> do Just (ChResponseCompList slbiGhcOptions), Just (ChResponseCompList slbiSourceDirs), - Just (ChResponseEntrypoints slbiEntrypoints) + Just (ChResponseEntrypoints slbiEntrypoints), + Just (ChResponseNeedsBuild slbiNeedsBuildOutput) ] = res slbiCompilerVersion = (comp, compVer) return $ SomeLocalBuildInfo {..} diff --git a/src/CabalHelper/Runtime/Main.hs b/src/CabalHelper/Runtime/Main.hs index 737b590..0173fe9 100644 --- a/src/CabalHelper/Runtime/Main.hs +++ b/src/CabalHelper/Runtime/Main.hs @@ -70,6 +70,8 @@ import Distribution.Simple.LocalBuildInfo , withComponentsLBI , withLibLBI , withExeLBI + , allLibModules + , componentBuildDir ) import Distribution.Simple.GHC ( componentGhcOptions @@ -149,15 +151,22 @@ import Distribution.Types.UnqualComponentName #if CH_MIN_VERSION_Cabal(2,0,0) -- CPP >= 2.0 -import Distribution.Backpack (OpenUnitId(..)) +import Distribution.Backpack + ( OpenUnitId(..), + OpenModule(..) + ) import Distribution.ModuleName ( ModuleName ) import Distribution.Types.ComponentId ( unComponentId ) +import Distribution.Types.ComponentLocalBuildInfo + ( maybeComponentInstantiatedWith + ) import Distribution.Types.ModuleRenaming - ( ModuleRenaming(..) + ( ModuleRenaming(..), + isDefaultRenaming ) import Distribution.Types.MungedPackageId ( MungedPackageId @@ -226,6 +235,7 @@ usage = do ++" | ghc-lang-options [--with-inplace]\n" ++" | package-db-stack\n" ++" | entrypoints\n" + ++" | needsbuildoutput\n" ++" | source-dirs\n" ++" | licenses\n" ++" ) ...\n" @@ -244,6 +254,7 @@ commands = [ "print-lbi" , "ghc-lang-options" , "package-db-stack" , "entrypoints" + , "needsbuildoutput" , "source-dirs" , "licenses"] @@ -324,6 +335,7 @@ main = do "ghc-options":flags -> do res <- componentOptions lvd True flags id + -- putStrLn $ "\n*************ghc-options:" ++ show res return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])]) "ghc-src-options":flags -> do @@ -383,14 +395,9 @@ main = do "entrypoints":[] -> do #if CH_MIN_VERSION_Cabal(2,0,0) includeDirMap <- recursiveDepInfo lbi v distdir - appendFile "/tmp/cbli.txt" "\n--------------------------------------" eps <- componentsMap lbi v distdir $ \c clbi _bi -> do - appendFile "/tmp/cbli.txt" ("\n" ++ show clbi) let (_,_,seps) = recursiveIncludeDirs includeDirMap (componentUnitId clbi) - appendFile "/tmp/cbli.txt" ("\n" ++ show (componentEntrypoints c) ) - appendFile "/tmp/cbli.txt" "\n-------" return seps - appendFile "/tmp/cbli.txt" "\n--------------------------------------" #else eps <- componentsMap lbi v distdir $ \c _clbi _bi -> return $ componentEntrypoints c @@ -400,6 +407,17 @@ main = do let eps' = eps ++ [(ChSetupHsName, ChSetupEntrypoint)] return $ Just $ ChResponseEntrypoints eps' + "needsbuildoutput":[] -> do +#if CH_MIN_VERSION_Cabal(2,0,0) + includeDirMap <- recursiveDepInfo lbi v distdir + nbs <- componentsMap lbi v distdir $ \c clbi _bi -> + return $ needsBuildOutput includeDirMap (componentUnitId clbi) +#else + nbs <- componentsMap lbi v distdir $ \c _clbi _bi -> + return $ NoBuildOutput +#endif + return $ Just $ ChResponseNeedsBuild nbs + "source-dirs":[] -> do res <- componentsMap lbi v distdir $$ \_ _ bi -> return $ hsSourceDirs bi return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])]) @@ -471,9 +489,9 @@ componentsMap lbi _v _distdir f = do l' <- readIORef lr r <- f c clbi bi #if CH_MIN_VERSION_Cabal(2,0,0) - writeIORef lr $ (componentNameToCh (ChUnitId $ unUnitId $ componentUnitId clbi) name, r):l' + writeIORef lr $ (componentNameToCh (unUnitId $ componentUnitId clbi) name, r):l' #else - writeIORef lr $ (componentNameToCh ChNoUnitId name, r):l' + writeIORef lr $ (componentNameToCh "" name, r):l' #endif reverse <$> readIORef lr @@ -482,11 +500,13 @@ 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 + -- putStrLn $ "\nincludeDirMap=" ++ show includeDirMap ++ "\n" #endif componentsMap lbi v distdir $ \c clbi bi -> let - outdir = componentOutDir lbi c + -- outdir = componentOutDir lbi c + outdir = componentBuildDir lbi clbi (clbi', adopts) = case flags of _ | not inplaceFlag -> (clbi, mempty) ["--with-inplace"] -> (clbi, mempty) @@ -524,6 +544,8 @@ removeInplaceDeps _v lbi pd clbi includeDirs = let , componentIncludes = incs } in (hasIdeps',c') + cleanRecursiveOpts :: Component + -> BuildInfo -> ComponentLocalBuildInfo -> GhcOptions cleanRecursiveOpts comp libbi libclbi = let -- libbi = libBuildInfo lib @@ -534,6 +556,7 @@ removeInplaceDeps _v lbi pd clbi includeDirs = let opts = (componentGhcOptions normal lbi libbi libclbi' liboutdir) { ghcOptPackageDBs = [] } + in opts { ghcOptSourcePath = ghcOptSourcePath opts <> toNubListR extraIncludes , ghcOptPackages = ghcOptPackages opts <> toNubListR extraDeps } @@ -544,8 +567,10 @@ removeInplaceDeps _v lbi pd clbi includeDirs = let (Just (lib, libclbi),_) | hasIdeps -> let libbi = libBuildInfo lib + opts = cleanRecursiveOpts (CLib lib) libbi libclbi in - cleanRecursiveOpts (CLib lib) libbi libclbi + -- ghcOptInputModules = toNubListR $ allLibModules lib clbi, + opts { ghcOptInputModules = ghcOptInputModules opts <> (toNubListR $ allLibModules lib libclbi) } (_,Just (exe,execlbi)) | hasIdeps -> let exebi = buildInfo exe @@ -588,7 +613,7 @@ recursiveDepInfo lbi v distdir = do , componentEntrypoints c)) return $ Map.fromList $ map snd includeDirs -type SubDeps = ([UnitId],[FilePath], [(OpenUnitId, ModuleRenaming)], ChEntrypoint) +type SubDeps = ([UnitId], [FilePath], [(OpenUnitId, ModuleRenaming)], ChEntrypoint) recursiveIncludeDirs :: Map.Map UnitId SubDeps -> UnitId -> ([FilePath], [(OpenUnitId, ModuleRenaming)] @@ -600,12 +625,30 @@ recursiveIncludeDirs includeDirs unit = go ([],[],Nothing) [unit] Nothing -> go acc us Just (us',sfp,sci,sep) -> go (afp++sfp,aci++sci,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 (us',sfp,sci,sep) -> + if any (isIndef . fst) sci + then ProduceBuildOutput + else go (us++us') + combineEp Nothing e = Just e combineEp (Just ChSetupEntrypoint) e = Just e combineEp (Just (ChLibEntrypoint es1 os1 ss1)) (ChLibEntrypoint es2 os2 ss2) = Just (ChLibEntrypoint (nub $ es2++es1) (nub $ os2++os1) (nub $ ss2++ss1)) combineEp (Just (ChLibEntrypoint es1 os1 ss1)) (ChExeEntrypoint mi os2) = Just (ChExeEntrypoint mi (nub $ os2++es1++os1++ss1)) combineEp (Just (ChExeEntrypoint _ os1)) (ChLibEntrypoint es2 os2 ss2) = Just (ChLibEntrypoint es2 (nub $ os2++os1) ss2) combineEp (Just (ChExeEntrypoint _ os1)) (ChExeEntrypoint mi os2) = Just (ChExeEntrypoint mi (nub $ os2++os1)) + +instantiatedGhcPackage :: (ModuleName,OpenModule) -> [(OpenUnitId, ModuleRenaming)] +instantiatedGhcPackage (_,OpenModule oui@(DefiniteUnitId _) _) = [(oui,DefaultRenaming)] +instantiatedGhcPackage (_, _) = [] #endif initialBuildStepsForAllComponents distdir pd lbi v = @@ -635,12 +678,16 @@ toDataVersion = id componentNameToCh _uid CLibName = ChLibName #if CH_MIN_VERSION_Cabal(1,25,0) -- CPP >= 1.25 -componentNameToCh uid (CSubLibName n) = ChSubLibName (unUnqualComponentName' n) uid -componentNameToCh uid (CFLibName n) = ChFLibName (unUnqualComponentName' n) uid +#if CH_MIN_VERSION_Cabal(2,0,0) +componentNameToCh uid (CSubLibName n) = ChSubLibName uid +#else +componentNameToCh _uid (CSubLibName n) = ChSubLibName (unUnqualComponentName' n) +#endif +componentNameToCh uid (CFLibName n) = ChFLibName (unUnqualComponentName' n) #endif -componentNameToCh uid (CExeName n) = ChExeName (unUnqualComponentName' n) uid -componentNameToCh uid (CTestName n) = ChTestName (unUnqualComponentName' n) uid -componentNameToCh uid (CBenchName n) = ChBenchName (unUnqualComponentName' n) uid +componentNameToCh _uid (CExeName n) = ChExeName (unUnqualComponentName' n) +componentNameToCh _uid (CTestName n) = ChTestName (unUnqualComponentName' n) +componentNameToCh _uid (CBenchName n) = ChBenchName (unUnqualComponentName' n) #if CH_MIN_VERSION_Cabal(1,25,0) -- CPP >= 1.25 @@ -717,8 +764,8 @@ componentEntrypoints (CBench Benchmark {}) #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 -isInplaceCompInc clbi (IndefFullUnitId uid _, _mmr) = unComponentId uid `elem` map unUnitId (componentInternalDeps clbi) +isInplaceCompInc clbi (IndefFullUnitId uid _, _mmr) = False +-- isInplaceCompInc clbi (IndefFullUnitId uid _, _mmr) = unComponentId uid `elem` map unUnitId (componentInternalDeps clbi) #endif #if CH_MIN_VERSION_Cabal(2,0,0) diff --git a/src/CabalHelper/Shared/InterfaceTypes.hs b/src/CabalHelper/Shared/InterfaceTypes.hs index bf61bb7..2f2e6a3 100644 --- a/src/CabalHelper/Shared/InterfaceTypes.hs +++ b/src/CabalHelper/Shared/InterfaceTypes.hs @@ -37,6 +37,7 @@ import Data.Version data ChResponse = ChResponseCompList [(ChComponentName, [String])] | ChResponseEntrypoints [(ChComponentName, ChEntrypoint)] + | ChResponseNeedsBuild [(ChComponentName, NeedsBuildOutput)] | ChResponseList [String] | ChResponsePkgDbs [ChPkgDb] | ChResponseLbi String @@ -47,15 +48,11 @@ data ChResponse data ChComponentName = ChSetupHsName | ChLibName - | ChSubLibName String ChUnitId - | ChFLibName String ChUnitId - | ChExeName String ChUnitId - | ChTestName String ChUnitId - | ChBenchName String ChUnitId - deriving (Eq, Ord, Read, Show, Generic) - -data ChUnitId = ChNoUnitId - | ChUnitId String + | ChSubLibName String + | ChFLibName String + | ChExeName String + | ChTestName String + | ChBenchName String deriving (Eq, Ord, Read, Show, Generic) newtype ChModuleName = ChModuleName String @@ -78,3 +75,6 @@ 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 127dd8e..e8d3977 100644 --- a/tests/GhcSession.hs +++ b/tests/GhcSession.hs @@ -32,12 +32,12 @@ main = do topdir <- getCurrentDirectory res <- mapM (setup topdir test) $ case args of [] -> [ - -- ("tests/exelib" , parseVer "1.10") - -- , ("tests/exeintlib", parseVer "2.0") - -- , ("tests/fliblib" , parseVer "2.0") - ("tests/bkpregex" , parseVer "2.0") + -- ("tests/exelib" , parseVer "1.10",False) + -- , ("tests/exeintlib", parseVer "2.0", False) + -- , ("tests/fliblib" , parseVer "2.0", False) + ("tests/bkpregex" , parseVer "2.0", True) ] - xs -> map (,parseVer "0") xs + xs -> map (,parseVer "0",False) xs if any (==False) $ concat res then exitFailure @@ -52,8 +52,8 @@ cabalInstallBuiltinCabalVersion = parseVer . trim <$> readProcess "cabal" ["act-as-setup", "--", "--numeric-version"] "" -setup :: FilePath -> (FilePath -> IO [Bool]) -> (FilePath, Version) -> IO [Bool] -setup topdir act (srcdir, min_cabal_ver) = do +setup :: FilePath -> (FilePath -> IO [Bool]) -> (FilePath, Version,Bool) -> IO [Bool] +setup topdir act (srcdir, min_cabal_ver,invokeCabalBuild) = do ci_ver <- cabalInstallVersion c_ver <- cabalInstallBuiltinCabalVersion let mreason @@ -70,13 +70,19 @@ setup topdir act (srcdir, min_cabal_ver) = do putStrLn $ "Skipping test '" ++ srcdir ++ "' because " ++ reason ++ "." return [] Nothing -> do - withSystemTempDirectory "cabal-helper.ghc-session.test" $ \dir -> do + -- withSystemTempDirectory "cabal-helper.ghc-session.test" $ \dir -> do + let dir = "/tmp/xxxx" + e <- doesDirectoryExist dir + when e $ removeDirectoryRecursive dir + createDirectoryIfMissing True dir + do setCurrentDirectory $ topdir </> srcdir run "cabal" [ "sdist", "--output-dir", dir ] setCurrentDirectory dir run "cabal" [ "configure" ] --- run "cabal" [ "build" ] + when invokeCabalBuild $ do + run "cabal" [ "build" ] act dir where @@ -89,21 +95,20 @@ setup topdir act (srcdir, min_cabal_ver) = do test :: FilePath -> IO [Bool] test dir = do let qe = mkQueryEnv dir (dir </> "dist") + let packageDir = dir </> "dist" </> "package.conf.inplace" + cs <- runQuery qe $ components $ (,,,) <$> entrypoints <.> ghcOptions <.> needsBuildOutput + forM cs $ \(ep, opts, nb, cn) -> do - cs <- runQuery qe $ components $ (,) <$> entrypoints - putStrLn "\n--------------------------------eps-----------------------------" - forM cs $ \(ep, cn) -> do - putStrLn $ "\n" ++ show (ep,cn) - putStrLn "\n--------------------------------eps end-----------------------------" - - cs <- runQuery qe $ components $ (,,) <$> entrypoints <.> ghcOptions - putStrLn "\n--------------------------------components-----------------------------" - forM cs $ \(ep, opts, cn) -> do - putStrLn $ "\n" ++ show cn ++ ": " ++ show opts - putStrLn "\n--------------------------------components end-------------------------" - forM cs $ \(ep, opts, cn) -> do - let opts' = "-Werror" : opts - let sopts = intercalate " " $ map formatArg $ "ghc" : opts' + putStrLn $ "\n" ++ show cn ++ ":::: " ++ show nb + + exists <- doesDirectoryExist packageDir + let opts' = if exists + then ("-package-db " ++ packageDir) : "-Werror" : opts + else "-Werror" : opts + + -- let opts' = "-Werror" : opts + -- let opts' = "-v 3" : "-Werror" : opts + let sopts = intercalate " " $ map formatArg $ "\nghc" : opts' putStrLn $ "\n" ++ show cn ++ ": " ++ sopts hFlush stdout compileModule ep opts' @@ -115,6 +120,8 @@ test dir = do compileModule :: ChEntrypoint -> [String] -> IO Bool compileModule ep opts = do + putStrLn $ "compiling:" ++ show ep + E.handle (\(ec :: ExitCode) -> print ec >> return False) $ do #if __GLASGOW_HASKELL__ <= 704 |