cabal-helper 0.8.1.2 → 0.8.2.0
raw patch · 6 files changed
+368/−51 lines, 6 filesdep ~ghcdep ~pretty-showdep ~semigroupoidsPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: ghc, pretty-show, semigroupoids, template-haskell, temporary
API changes (from Hackage documentation)
- Distribution.Helper: instance GHC.Exception.Exception Distribution.Helper.LibexecNotFoundError
+ Distribution.Helper: instance GHC.Exception.Type.Exception Distribution.Helper.LibexecNotFoundError
Files
- cabal-helper.cabal +12/−12
- lib/Distribution/Helper.hs +4/−2
- tests/CacheTest.hs +243/−0
- tests/CompileTest.hs +4/−0
- tests/LibexecTest.hs +0/−37
- tests/MultiGhcSession.hs +105/−0
cabal-helper.cabal view
@@ -1,5 +1,5 @@ name: cabal-helper-version: 0.8.1.2+version: 0.8.2.0 synopsis: Simple interface to some of Cabal's configuration state, mainly used by ghc-mod description:@@ -113,7 +113,7 @@ if !os(windows) build-depends: unix < 2.8 && >= 2.5.1.1 build-depends: unix-compat < 0.6 && >= 0.4.3.1- , semigroupoids < 5.3 && >= 5.2+ , semigroupoids < 5.4 && >= 5.2 @@ -152,10 +152,10 @@ , filepath < 1.5 && >= 1.3.0.0 , mtl < 2.3 && >= 2.0 , process < 1.7 && >= 1.1.0.1- , pretty-show < 1.9 && >= 1.8.1+ , pretty-show < 1.9 && >= 1.7 , text < 1.3 && >= 1.0.0.0- , template-haskell < 2.14 && >= 2.7.0.0- , temporary < 1.3 && >= 1.2.1+ , template-haskell < 2.15 && >= 2.7.0.0+ , temporary < 1.4 && >= 1.2.1 , transformers < 0.6 && >= 0.3.0.0 if !os(windows) build-depends: unix < 2.8 && >= 2.5.1.1@@ -200,10 +200,10 @@ , filepath < 1.5 && >= 1.3.0.0 , mtl < 2.3 && >= 2.0 , process < 1.7 && >= 1.1.0.1- , pretty-show < 1.9 && >= 1.8.1+ , pretty-show < 1.9 && >= 1.7 , text < 1.3 && >= 1.0.0.0- , template-haskell < 2.14 && >= 2.7.0.0- , temporary < 1.3 && >= 1.2.1+ , template-haskell < 2.15 && >= 2.7.0.0+ , temporary < 1.4 && >= 1.2.1 , transformers < 0.6 && >= 0.3.0.0 if !os(windows) build-depends: unix < 2.8 && >= 2.5.1.1@@ -218,7 +218,7 @@ hs-source-dirs: tests ghc-options: -Wall build-depends: base < 5 && >= 4.7- , ghc < 8.5 && >= 7.8+ , ghc < 8.7 && >= 7.8 , ghc-paths < 0.2 && >= 0.1.0.9 , cabal-helper @@ -251,10 +251,10 @@ , filepath < 1.5 && >= 1.3.0.0 , mtl < 2.3 && >= 2.0 , process < 1.7 && >= 1.1.0.1- , pretty-show < 1.9 && >= 1.8.1+ , pretty-show < 1.9 && >= 1.7 , text < 1.3 && >= 1.0.0.0- , template-haskell < 2.14 && >= 2.7.0.0- , temporary < 1.3 && >= 1.2.1+ , template-haskell < 2.15 && >= 2.7.0.0+ , temporary < 1.4 && >= 1.2.1 , transformers < 0.6 && >= 0.3.0.0 if !os(windows) build-depends: unix < 2.8 && >= 2.5.1.1
lib/Distribution/Helper.hs view
@@ -380,8 +380,10 @@ getPackageId :: MonadQuery m => m (String, Version) getPackageId = ask >>= \QueryEnv {..} -> do- [ Just (ChResponseVersion pkgName pkgVer) ] <- readHelper [ "package-id" ]- return (pkgName, pkgVer)+ pkgId <- readHelper [ "package-id" ]+ case pkgId of+ [ Just (ChResponseVersion pkgName pkgVer) ] -> return (pkgName, pkgVer)+ _ -> error "getPackageId: unexpected response" getSomeConfigState :: MonadQuery m => m SomeLocalBuildInfo getSomeConfigState = ask >>= \QueryEnv {..} -> do
+ tests/CacheTest.hs view
@@ -0,0 +1,243 @@+-- | This test ensures caches are updated when on-disk project state changes.+--+-- For example when a cabal file changes we have to call the project's build+-- tool to regenerate @setup-config@s. When a @setup-config@ file changes we+-- have to re-run the helper to get the 'UnitInfo'.++module Main where++import GHC+import GHC.Paths (libdir)+import DynFlags++import qualified Control.Exception as E+import Control.Monad+import Control.Monad.IO.Class+import Data.List+import Data.Version+import qualified Data.Map as Map+import System.Environment (getArgs)+import System.Exit+import System.FilePath ((</>), takeFileName, takeDirectory)+import System.Directory+import System.IO+import System.IO.Temp+import System.Process (readProcess)++import Distribution.Helper++import CabalHelper.Shared.Common+import CabalHelper.Compiletime.Process+++main :: IO ()+main = do+ args <- getArgs+ topdir <- getCurrentDirectory+ res <- mapM (setup topdir test) $ case args of+ [] -> [ ("tests/exelib/exelib.cabal", parseVer "1.10", parseVer "0")+ , ("tests/exeintlib/exeintlib.cabal", parseVer "2.0", parseVer "0")+ , ("tests/fliblib/fliblib.cabal", parseVer "2.0", parseVer "0")+ , ("tests/bkpregex/bkpregex.cabal", parseVer "2.0", parseVer "8.1")+ -- min Cabal lib ver -^ min GHC ver -^+ ]+ xs -> map (, parseVer "0", parseVer "0") xs++ if any (==False) $ concat res+ then exitFailure+ else exitSuccess++cabalInstallVersion :: IO Version+cabalInstallVersion =+ parseVer . trim <$> readProcess "cabal" ["--numeric-version"] ""++ghcVersion :: IO Version+ghcVersion =+ parseVer . trim <$> readProcess "ghc" ["--numeric-version"] ""++cabalInstallBuiltinCabalVersion :: IO Version+cabalInstallBuiltinCabalVersion =+ parseVer . trim <$> readProcess "cabal"+ ["act-as-setup", "--", "--numeric-version"] ""++data ProjSetup pt =+ ProjSetup+ { psDistDir :: FilePath -> DistDir pt+ , psProjDir :: FilePath -> ProjLoc pt+ , psConfigure :: FilePath -> IO ()+ , psBuild :: FilePath -> IO ()+ , psSdist :: FilePath -> FilePath -> IO ()+ }++oldBuild :: ProjSetup 'V1+oldBuild = ProjSetup+ { psDistDir = \dir -> DistDirV1 (dir </> "dist")+ , psProjDir = \cabal_file -> ProjLocCabalFile cabal_file+ , psConfigure = \dir ->+ runWithCwd dir "cabal" [ "configure" ]+ , psBuild = \dir ->+ runWithCwd dir "cabal" [ "build" ]+ , psSdist = \srcdir destdir ->+ runWithCwd srcdir "cabal" [ "sdist", "-v0", "--output-dir", destdir ]+ }++newBuild :: ProjSetup 'V2+newBuild = ProjSetup+ { psDistDir = \dir -> DistDirV2 (dir </> "dist-newstyle")+ , psProjDir = \cabal_file -> ProjLocV2Dir (takeDirectory cabal_file)+ , psConfigure = \dir ->+ runWithCwd dir "cabal" [ "new-configure" ]+ , psBuild = \dir ->+ runWithCwd dir "cabal" [ "new-build" ]+ , psSdist = \srcdir destdir ->+ runWithCwd srcdir "cabal" [ "sdist", "-v0", "--output-dir", destdir ]+ }++setup :: FilePath -> (forall pt . ProjSetup pt -> FilePath -> IO [Bool]) -> (FilePath, Version, Version) -> IO [Bool]+setup topdir act (cabal_file, min_cabal_ver, min_ghc_ver) = do+ let projdir = takeDirectory cabal_file+ ci_ver <- cabalInstallVersion+ c_ver <- cabalInstallBuiltinCabalVersion+ g_ver <- ghcVersion+ let mreason+ | (ci_ver < parseVer "1.24") =+ Just $ "cabal-install-" ++ showVersion ci_ver ++ " is too old"+ | c_ver < min_cabal_ver =+ Just $ "Cabal-" ++ showVersion c_ver+ ++ " < " ++ showVersion min_cabal_ver+ | g_ver < min_ghc_ver =+ Just $ "ghc-" ++ showVersion g_ver+ ++ " < " ++ showVersion min_ghc_ver+ | otherwise =+ Nothing++ case mreason of+ Just reason -> do+ putStrLn $ "Skipping test '" ++ projdir ++ "' because " ++ reason ++ "."+ return []+ Nothing -> do+ putStrLn $ "Running test '" ++ projdir ++ "' with " ++ showVersion ci_ver ++ "."+ putStrLn "Old build -------------------------------------"+ rold <- runTest oldBuild topdir projdir cabal_file act+ putStrLn "New build -------------------------------------"+ rnew <- runTest newBuild topdir projdir cabal_file act+ return (rold ++ rnew)++runTest :: ProjSetup pt -> FilePath -> String -> FilePath+ -> (ProjSetup pt -> FilePath -> IO [Bool]) -> IO [Bool]+runTest ps@ProjSetup{..} topdir projdir cabal_file act = do+ putStrLn $ "Running test '" ++ projdir ++ "'-------------------------"+ withSystemTempDirectory' "cabal-helper.ghc-session.test" $ \tmpdir -> do++ psSdist (topdir </> projdir) tmpdir+ psConfigure tmpdir++ act ps $ tmpdir </> takeFileName cabal_file++runWithCwd :: FilePath -> String -> [String] -> IO ()+runWithCwd cwd x xs = do+ let ?verbose = True+ callProcessStderr (Just cwd) x xs++run :: String -> [String] -> IO ()+run x xs = do+ let ?verbose = True+ callProcessStderr Nothing x xs++test :: ProjSetup pt -> FilePath -> IO [Bool]+test ProjSetup{..} cabal_file = do+ let projdir = takeDirectory cabal_file+ qe <- mkQueryEnv+ (psProjDir cabal_file)+ (psDistDir projdir)+ cs <- concat <$> runQuery (allUnits (Map.elems . uiComponents)) qe+ forM cs $ \ChComponentInfo{..} -> do+ putStrLn $ "\n" ++ show ciComponentName ++ ":::: " ++ show ciNeedsBuildOutput++ when (ciNeedsBuildOutput == ProduceBuildOutput) $ do+ psBuild projdir++ let opts' = "-Werror" : ciGhcOptions++ let sopts = intercalate " " $ map formatArg $ "\nghc" : opts'+ putStrLn $ "\n" ++ show ciComponentName ++ ": " ++ sopts+ hFlush stdout+ compileModule projdir ciNeedsBuildOutput ciEntrypoints opts'+ where+ formatArg x+ | "-" `isPrefixOf` x = "\n "++x+ | otherwise = x++addCabalProject :: FilePath -> IO ()+addCabalProject dir = do+ writeFile (dir </> "cabal.project") "packages: .\n"++compileModule+ :: FilePath -> NeedsBuildOutput -> ChEntrypoint -> [String] -> IO Bool+compileModule projdir nb ep opts = do+ setCurrentDirectory projdir++ putStrLn $ "compiling:" ++ show ep ++ " (" ++ show nb ++ ")"++ E.handle (\(ec :: ExitCode) -> print ec >> return False) $ do++ defaultErrorHandler defaultFatalMessager defaultFlushOut $ do++ runGhc (Just libdir) $ 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 = target+ , optLevel = 0+ }++ (dflags2, _, _) <- parseDynamicFlags dflags1 (map noLoc opts)+ _ <- setSessionDynFlags dflags2++ ts <- mapM (\t -> guessTarget t Nothing) $+ case ep of+ ChLibEntrypoint ms ms' ss -> map unChModuleName $ ms ++ ms' ++ ss+ ChExeEntrypoint m' ms ->+ let++ -- The options first clear out includes, then put in the build+ -- dir. We want the first one after that, so "regex-example" in+ -- the following case+ --+ -- ,"-i"+ -- ,"-idist/build/regex-example"+ -- ,"-iregex-example"+ firstInclude = drop 2 $ head $ drop 2 $ filter (isPrefixOf "-i") opts+ m = firstInclude </> m'+ in [m] ++ map unChModuleName ms+ ChSetupEntrypoint -> ["Setup.hs"]++ let ts' = case nb of+ NoBuildOutput -> map (\t -> t { targetAllowObjCode = False }) ts+ ProduceBuildOutput -> ts++ setTargets ts'+ _ <- load LoadAllTargets++ 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"]++ liftIO $ print ExitSuccess+ return True++unChModuleName :: ChModuleName -> String+unChModuleName (ChModuleName mn) = mn
tests/CompileTest.hs view
@@ -109,6 +109,9 @@ , "2.0.1.1" , "2.2.0.0" , "2.2.0.1"+ , "2.4.0.0"+ , "2.4.0.1"+ , "2.4.1.0" ] constraint :: VersionRange@@ -130,6 +133,7 @@ , ("8.2.2", ">= 2.0.0.2 ") , ("8.4.1", ">= 2.0.0.2 ") , ("8.4.2", ">= 2.2.0.1 ")+ , ("8.6", ">= 2.4.0.0 ") ] in reverse $ filter (flip withinRange'CH constraint) cabal_versions
− tests/LibexecTest.hs
@@ -1,37 +0,0 @@-import Control.Applicative-import Control.Monad-import Control.Exception as E-import Data.Char-import Data.List-import Data.Maybe-import Data.Version-import Data.Typeable-import System.Environment-import System.FilePath hiding ((<.>))-import qualified System.FilePath as FP-import System.Directory-import System.IO.Unsafe-import Text.Printf-import GHC.Generics-import Prelude--main = do- print =<< tryFindCabalHelperTreeLibexecDir--tryFindCabalHelperTreeLibexecDir :: IO (Maybe FilePath)-tryFindCabalHelperTreeLibexecDir = do- exe <- getExecutablePath'- dir <- case takeFileName exe of- "ghc" -> do -- we're probably in ghci; try CWD- getCurrentDirectory- _ ->- return $ (!!4) $ iterate takeDirectory exe-- print ("dir", dir)- exists <- doesFileExist $ dir </> "cabal-helper.cabal"- return $ if exists- then Just dir- else Nothing--getExecutablePath' :: IO FilePath-getExecutablePath' = getExecutablePath
+ tests/MultiGhcSession.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Main where++import Distribution.Helper+import Data.Foldable+ ( toList )+import System.Process+ ( system )+import System.Environment+ ( getArgs )+import System.Exit+ ( ExitCode(ExitSuccess) )+import System.IO+ ( hPutStrLn, stderr )+import System.Console.GetOpt+ ( OptDescr(Option), ArgDescr(NoArg), ArgOrder(RequireOrder), getOpt+ , usageInfo )++import System.Directory+import Text.Printf++import Control.Concurrent+import Control.Concurrent.QSemN+import Control.Monad+import Control.Monad.IO.Class++import GHC+import GHC.Paths (libdir)+import Outputable+import DynFlags+++main :: IO ()+main = do+ [dir] <- getArgs+ setCurrentDirectory dir+ _ <- systemV "sh -c pwd"+ _ <- systemV "cabal new-build --builddir=dist-newstyle"+ qe <- mkQueryEnv (ProjLocV2Dir ".") (DistDirV2 "dist-newstyle/")++ components :: [ChComponentInfo]+ <- concat <$> runQuery (allUnits (toList . uiComponents)) qe++ sem <- newQSemN 0++ _threads <- forM components $ \comp -> forkIO $ compile sem comp++ waitQSemN sem $ length components++ return ()++compile sem ci@ChComponentInfo{..} =+ defaultErrorHandler defaultFatalMessager defaultFlushOut $ do+ runGhc (Just libdir) $ do+ handleSourceError (\e -> GHC.printException e) $ do++ dflags0 <- getSessionDynFlags+ let dflags1 = dflags0 {+ ghcMode = CompManager+ , ghcLink = LinkInMemory+ , hscTarget = HscNothing+ , optLevel = 0+ }++ (dflags2, _, _) <- parseDynamicFlags dflags1 (map noLoc ciGhcOptions)+ _ <- setSessionDynFlags dflags2++ ts <- mapM (\t -> guessTarget t Nothing) =<<+ case ciEntrypoints of+ ChLibEntrypoint ms ms' ss -> return $+ map unChModuleName $ ms ++ ms' ++ ss+ ChExeEntrypoint m ms -> do+ m1 <- liftIO $ findFile ciSourceDirs m+ case m1 of+ Just m2 -> return $ [m2] ++ map unChModuleName ms+ Nothing -> error $ printf+ "Couldn't find source file for Main module (%s), search path:\n\+ \%s\n" m (show ciSourceDirs)+ ChSetupEntrypoint -> return $+ ["Setup.hs"]++ setTargets $ map (\t -> t { targetAllowObjCode = False }) ts+ _ <- load LoadAllTargets++ setContext $ case ciEntrypoints 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"]++ _ <- execStmt "print foo" execOptions++ liftIO $ print ci+ liftIO $ signalQSemN sem 1+ liftIO $ forever $ threadDelay 100000++-- | Run shell command and+systemV :: String -> IO ()+systemV shell_cmd = do+ hPutStrLn stderr $ "$ " ++ shell_cmd+ ExitSuccess <- system shell_cmd+ return ()