From c76893a035c37c949cca9c09f10ccea59402cf55 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Thu, 14 Dec 2017 11:32:14 +0200 Subject: Progress on when to build and when not --- lib/Distribution/Helper.hs | 1 + src/CabalHelper/Runtime/Main.hs | 16 +++++++--- tests/GhcSession.hs | 65 +++++++++++++++++++++++------------------ 3 files changed, 50 insertions(+), 32 deletions(-) diff --git a/lib/Distribution/Helper.hs b/lib/Distribution/Helper.hs index f98955c..53b2f23 100644 --- a/lib/Distribution/Helper.hs +++ b/lib/Distribution/Helper.hs @@ -77,6 +77,7 @@ module Distribution.Helper ( , ChComponentName(..) , ChPkgDb(..) , ChEntrypoint(..) + , NeedsBuildOutput(..) -- * General information , buildPlatform diff --git a/src/CabalHelper/Runtime/Main.hs b/src/CabalHelper/Runtime/Main.hs index 0173fe9..e2829b3 100644 --- a/src/CabalHelper/Runtime/Main.hs +++ b/src/CabalHelper/Runtime/Main.hs @@ -70,8 +70,11 @@ import Distribution.Simple.LocalBuildInfo , withComponentsLBI , withLibLBI , withExeLBI + +#if CH_MIN_VERSION_Cabal(2,0,0) , allLibModules , componentBuildDir +#endif ) import Distribution.Simple.GHC ( componentGhcOptions @@ -396,8 +399,10 @@ main = do #if CH_MIN_VERSION_Cabal(2,0,0) includeDirMap <- recursiveDepInfo lbi v distdir eps <- componentsMap lbi v distdir $ \c clbi _bi -> do - let (_,_,seps) = recursiveIncludeDirs includeDirMap (componentUnitId clbi) - return seps + case needsBuildOutput includeDirMap (componentUnitId clbi) of + ProduceBuildOutput -> return $ componentEntrypoints c + NoBuildOutput -> return seps + where (_,_,seps) = recursiveIncludeDirs includeDirMap (componentUnitId clbi) #else eps <- componentsMap lbi v distdir $ \c _clbi _bi -> return $ componentEntrypoints c @@ -544,6 +549,8 @@ removeInplaceDeps _v lbi pd clbi includeDirs = let , componentIncludes = incs } in (hasIdeps',c') + needsBuild = needsBuildOutput includeDirs (componentUnitId clbi) + cleanRecursiveOpts :: Component -> BuildInfo -> ComponentLocalBuildInfo -> GhcOptions cleanRecursiveOpts comp libbi libclbi = @@ -563,15 +570,16 @@ removeInplaceDeps _v lbi pd clbi includeDirs = let (hasIdeps,clbi') = removeInplace clbi libopts = + -- AZ:TODO: we already have the clbi, use it rather case (getLibraryClbi pd lbi,getExeClbi pd lbi) of - (Just (lib, libclbi),_) | hasIdeps -> + (Just (lib, libclbi),_) | hasIdeps && (needsBuild == NoBuildOutput) -> let libbi = libBuildInfo lib opts = cleanRecursiveOpts (CLib lib) libbi libclbi in -- ghcOptInputModules = toNubListR $ allLibModules lib clbi, opts { ghcOptInputModules = ghcOptInputModules opts <> (toNubListR $ allLibModules lib libclbi) } - (_,Just (exe,execlbi)) | hasIdeps -> + (_,Just (exe,execlbi)) | hasIdeps && (needsBuild == NoBuildOutput) -> let exebi = buildInfo exe in diff --git a/tests/GhcSession.hs b/tests/GhcSession.hs index e8d3977..ab07e85 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",False) - -- , ("tests/exeintlib", parseVer "2.0", False) - -- , ("tests/fliblib" , parseVer "2.0", False) - ("tests/bkpregex" , parseVer "2.0", True) + -- ("tests/exelib" , parseVer "1.10") + -- , ("tests/exeintlib", parseVer "2.0") + -- , ("tests/fliblib" , parseVer "2.0") + ("tests/bkpregex" , parseVer "2.0") ] - xs -> map (,parseVer "0",False) xs + xs -> map (,parseVer "0") 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,Bool) -> IO [Bool] -setup topdir act (srcdir, min_cabal_ver,invokeCabalBuild) = do +setup :: FilePath -> (FilePath -> IO [Bool]) -> (FilePath, Version) -> IO [Bool] +setup topdir act (srcdir, min_cabal_ver) = do ci_ver <- cabalInstallVersion c_ver <- cabalInstallBuiltinCabalVersion let mreason @@ -81,16 +81,15 @@ setup topdir act (srcdir, min_cabal_ver,invokeCabalBuild) = do setCurrentDirectory dir run "cabal" [ "configure" ] - when invokeCabalBuild $ do - run "cabal" [ "build" ] act dir - where - run x xs = do - print $ x:xs - o <- readProcess x xs "" - putStrLn o - return () + +run :: String -> [String] -> IO () +run x xs = do + print $ x:xs + o <- readProcess x xs "" + putStrLn o + return () test :: FilePath -> IO [Bool] test dir = do @@ -101,6 +100,9 @@ test dir = do putStrLn $ "\n" ++ show cn ++ ":::: " ++ show nb + when (nb == ProduceBuildOutput) $ do + run "cabal" [ "build" ] + exists <- doesDirectoryExist packageDir let opts' = if exists then ("-package-db " ++ packageDir) : "-Werror" : opts @@ -111,16 +113,16 @@ test dir = do let sopts = intercalate " " $ map formatArg $ "\nghc" : opts' putStrLn $ "\n" ++ show cn ++ ": " ++ sopts hFlush stdout - compileModule ep opts' + compileModule nb ep opts' where formatArg x | "-" `isPrefixOf` x = "\n "++x | otherwise = x -compileModule :: ChEntrypoint -> [String] -> IO Bool -compileModule ep opts = do +compileModule :: NeedsBuildOutput -> ChEntrypoint -> [String] -> IO Bool +compileModule nb ep opts = do - putStrLn $ "compiling:" ++ show ep + putStrLn $ "compiling:" ++ show ep ++ " (" ++ show nb ++ ")" E.handle (\(ec :: ExitCode) -> print ec >> return False) $ do @@ -134,11 +136,15 @@ compileModule ep opts = do handleSourceError (\e -> GHC.printException e >> return False) $ do + let target = case nb of + ProduceBuildOutput -> HscNothing -- AZ: what should this be? + NoBuildOutput -> HscInterpreted + dflags0 <- getSessionDynFlags let dflags1 = dflags0 { ghcMode = CompManager , ghcLink = LinkInMemory - , hscTarget = HscInterpreted + , hscTarget = target , optLevel = 0 } @@ -150,19 +156,22 @@ compileModule ep opts = do ChLibEntrypoint ms ms' ss -> map unChModuleName $ ms ++ ms' ++ ss ChExeEntrypoint m ms -> [m] ++ map unChModuleName ms ChSetupEntrypoint -> ["Setup.hs"] - let ts' = map (\t -> t { targetAllowObjCode = False }) ts + let ts' = case nb of + NoBuildOutput -> map (\t -> t { targetAllowObjCode = False }) ts + ProduceBuildOutput -> ts setTargets ts' _ <- load LoadAllTargets #if __GLASGOW_HASKELL__ >= 706 - setContext $ case ep of - ChLibEntrypoint ms ms' ss -> - map (IIModule . mkModuleName . unChModuleName) $ ms ++ ms' ++ ss - ChExeEntrypoint _ ms -> - map (IIModule . mkModuleName . unChModuleName) $ ChModuleName "Main" : ms - ChSetupEntrypoint -> - map (IIModule . mkModuleName) ["Main"] + when (nb == NoBuildOutput) $ do + setContext $ case ep of + ChLibEntrypoint ms ms' ss -> + map (IIModule . mkModuleName . unChModuleName) $ ms ++ ms' ++ ss + ChExeEntrypoint _ ms -> + map (IIModule . mkModuleName . unChModuleName) $ ChModuleName "Main" : ms + ChSetupEntrypoint -> + map (IIModule . mkModuleName) ["Main"] #endif #if __GLASGOW_HASKELL__ <= 706 -- cgit v1.2.3