diff --git a/cabal-helper.cabal b/cabal-helper.cabal --- a/cabal-helper.cabal +++ b/cabal-helper.cabal @@ -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 diff --git a/lib/Distribution/Helper.hs b/lib/Distribution/Helper.hs --- a/lib/Distribution/Helper.hs +++ b/lib/Distribution/Helper.hs @@ -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 diff --git a/tests/CacheTest.hs b/tests/CacheTest.hs new file mode 100644 --- /dev/null +++ b/tests/CacheTest.hs @@ -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 diff --git a/tests/CompileTest.hs b/tests/CompileTest.hs --- a/tests/CompileTest.hs +++ b/tests/CompileTest.hs @@ -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 diff --git a/tests/LibexecTest.hs b/tests/LibexecTest.hs deleted file mode 100644 --- a/tests/LibexecTest.hs +++ /dev/null @@ -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 diff --git a/tests/MultiGhcSession.hs b/tests/MultiGhcSession.hs new file mode 100644 --- /dev/null +++ b/tests/MultiGhcSession.hs @@ -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 ()