diff --git a/yesod/Devel.hs b/yesod/Devel.hs index 69ba08a0..ca88047b 100644 --- a/yesod/Devel.hs +++ b/yesod/Devel.hs @@ -9,18 +9,11 @@ module Devel import qualified Distribution.Compiler as D -import qualified Distribution.InstalledPackageInfo as IPI import qualified Distribution.ModuleName as D -import qualified Distribution.Package as D import qualified Distribution.PackageDescription as D import qualified Distribution.PackageDescription.Parse as D -import qualified Distribution.Simple.Build as D -import qualified Distribution.Simple.Compiler as D import qualified Distribution.Simple.Configure as D -import qualified Distribution.Simple.LocalBuildInfo as D import qualified Distribution.Simple.Program as D -import qualified Distribution.Simple.Register as D -import qualified Distribution.Simple.Setup as DSS import qualified Distribution.Simple.Utils as D import qualified Distribution.Verbosity as D @@ -40,9 +33,6 @@ import qualified Data.List as L import qualified Data.Map as Map import Data.Maybe (fromMaybe) import qualified Data.Set as Set -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8With) -import Data.Text.Encoding.Error (lenientDecode) import System.Directory import System.Environment (getEnvironment) @@ -53,6 +43,7 @@ import System.FilePath (dropExtension, splitDirectories, takeExtension, ()) import System.FSNotify +import System.IO (Handle) import System.IO.Error (isDoesNotExistError) import System.Posix.Types (EpochTime) import System.PosixCompat.Files (getFileStatus, @@ -66,9 +57,9 @@ import System.Process (ProcessHandle, import System.Timeout (timeout) import Build (getDeps, isNewerThan, - recompDeps, safeReadFile) + recompDeps) import GhcBuild (buildPackage, - getBuildFlags) + getBuildFlags, getPackageArgs) import qualified Config as GHC import Data.Conduit.Network (HostPreference (HostIPv4), @@ -116,6 +107,10 @@ getBuildDir opts = fromMaybe "dist" (buildDir opts) defaultDevelOpts :: DevelOpts defaultDevelOpts = DevelOpts False False False (-1) Nothing Nothing Nothing 3000 10 +cabalProgram :: DevelOpts -> FilePath +cabalProgram opts | isCabalDev opts = "cabal-dev" + | otherwise = "cabal" + -- | Run a reverse proxy from port 3000 to 3001. If there is no response on -- 3001, give an appropriate message to the user. reverseProxy :: DevelOpts -> I.IORef Int -> IO () @@ -183,26 +178,34 @@ devel opts passThroughArgs = withSocketsDo $ withManager $ \manager -> do cabal <- liftIO $ D.findPackageDesc "." gpd <- liftIO $ D.readPackageDescription D.normal cabal ldar <- liftIO lookupLdAr - (hsSourceDirs, lib) <- liftIO $ checkCabalFile gpd + (hsSourceDirs, _) <- liftIO $ checkCabalFile gpd liftIO $ removeFileIfExists (bd "setup-config") - liftIO $ configure cabal ghcVer gpd opts - liftIO $ removeFileIfExists "yesod-devel/ghcargs.txt" -- these files contain the wrong data after - liftIO $ removeFileIfExists "yesod-devel/arargs.txt" -- the configure step, remove them to force - liftIO $ removeFileIfExists "yesod-devel/ldargs.txt" -- a cabal build first - rebuild <- liftIO $ mkRebuild gpd ghcVer cabal opts ldar - mainInnerLoop iappPort hsSourceDirs filesModified cabal gpd lib ghcVer rebuild + c <- liftIO $ configure opts passThroughArgs + if c then do + -- these files contain the wrong data after the configure step, + -- remove them to force a cabal build first + liftIO $ mapM_ removeFileIfExists [ "yesod-devel/ghcargs.txt" + , "yesod-devel/arargs.txt" + , "yesod-devel/ldargs.txt" + ] + rebuild <- liftIO $ mkRebuild ghcVer cabal opts ldar + mainInnerLoop iappPort hsSourceDirs filesModified cabal rebuild + else do + liftIO (threadDelay 5000000) + mainOuterLoop iappPort filesModified -- inner loop rebuilds after files change - mainInnerLoop iappPort hsSourceDirs filesModified cabal gpd lib ghcVer rebuild = go + mainInnerLoop iappPort hsSourceDirs filesModified cabal rebuild = go where go = do _ <- recompDeps hsSourceDirs list <- liftIO $ getFileList hsSourceDirs [cabal] success <- liftIO rebuild - pkgArgs <- liftIO $ ghcPackageArgs opts ghcVer (D.packageDescription gpd) lib - let devArgs = pkgArgs ++ ["devel.hs"] ++ passThroughArgs + pkgArgs <- liftIO ghcPackageArgs + let devArgs = pkgArgs ++ ["devel.hs"] let loop list0 = do - (haskellFileChanged, list1) <- liftIO $ watchForChanges filesModified hsSourceDirs [cabal] list0 (eventTimeout opts) + (haskellFileChanged, list1) <- liftIO $ + watchForChanges filesModified hsSourceDirs [cabal] list0 (eventTimeout opts) anyTouched <- recompDeps hsSourceDirs unless (anyTouched || haskellFileChanged) $ loop list1 if not success @@ -249,53 +252,20 @@ runBuildHook (Just s) = do runBuildHook Nothing = return () {- - configure with the built-in Cabal lib for non-cabal-dev, since - otherwise we cannot read the configuration later - - cabal-dev uses the command-line tool, we can fall back to - cabal-dev buildopts if required + run `cabal configure' with our wrappers -} -configure :: FilePath -> String -> D.GenericPackageDescription -> DevelOpts -> IO () -configure _cabalFile ghcVer gpd opts = do - lbi <- D.configure (gpd, hookedBuildInfo) configFlags - D.writePersistBuildConfig (getBuildDir opts) lbi -- fixme we could keep this in memory instead of file - where - hookedBuildInfo = (Nothing, []) - configFlags0 | forceCabal opts = config - | otherwise = config - { DSS.configProgramPaths = - [ ("ar", "yesod-ar-wrapper") - , ("ld", "yesod-ld-wrapper") - , ("ghc", "yesod-ghc-wrapper") - ] - , DSS.configHcPkg = DSS.Flag "ghc-pkg" - } -#if MIN_VERSION_Cabal(1,16,0) - configFlags | isCabalDev opts = configFlags0 - { DSS.configPackageDBs = - [ Nothing - , Just D.GlobalPackageDB - , Just cabalDevPackageDb - ] - } -#else - configFlags | isCabalDev opts = configFlags0 - { DSS.configPackageDB = DSS.Flag cabalDevPackageDb - } -#endif - | otherwise = configFlags0 - - cabalDevPackageDb = D.SpecificPackageDB ("cabal-dev/packages-" ++ ghcVer ++ ".conf") - - - config = (DSS.defaultConfigFlags D.defaultProgramConfiguration) - { DSS.configConfigurationsFlags = - [ (D.FlagName "devel", True) -- legacy - , (D.FlagName "library-only", True) - ] - , DSS.configProfLib = DSS.Flag False - , DSS.configUserInstall = DSS.Flag True - } +configure :: DevelOpts -> [String] -> IO Bool +configure opts extraArgs = + checkExit =<< (createProcess $ proc (cabalProgram opts) + ([ "configure" + , "-flibrary-only" + , "-fdevel" + , "--with-ld=yesod-ld-wrapper" + , "--with-ghc=yesod-ghc-wrapper" + , "--with-ar=yesod-ar-wrapper" + , "--with-hc-pkg=ghc-pkg" + ] ++ extraArgs) + ) removeFileIfExists :: FilePath -> IO () removeFileIfExists file = removeFile file `Ex.catch` handler @@ -304,17 +274,17 @@ removeFileIfExists file = removeFile file `Ex.catch` handler handler e | isDoesNotExistError e = return () | otherwise = Ex.throw e -mkRebuild :: D.GenericPackageDescription -> String -> FilePath -> DevelOpts -> (FilePath, FilePath) -> IO (IO Bool) -mkRebuild gpd ghcVer cabalFile opts (ldPath, arPath) - | GHC.cProjectVersion /= ghcVer = failWith "Yesod has been compiled with a different GHC version, please reinstall" - | forceCabal opts = return (rebuildCabal gpd opts) +mkRebuild :: String -> FilePath -> DevelOpts -> (FilePath, FilePath) -> IO (IO Bool) +mkRebuild ghcVer cabalFile opts (ldPath, arPath) + | GHC.cProjectVersion /= ghcVer = + failWith "Yesod has been compiled with a different GHC version, please reinstall" + | forceCabal opts = return (rebuildCabal opts) | otherwise = do return $ do - n1 <- cabalFile `isNewerThan` "yesod-devel/ghcargs.txt" - n2 <- cabalFile `isNewerThan` "yesod-devel/arargs.txt" - n3 <- cabalFile `isNewerThan` "yesod-devel/ldargs.txt" - if n1 || n2 || n3 - then rebuildCabal gpd opts + ns <- mapM (cabalFile `isNewerThan`) + [ "yesod-devel/ghcargs.txt", "yesod-devel/arargs.txt", "yesod-devel/ldargs.txt" ] + if or ns + then rebuildCabal opts else do bf <- getBuildFlags rebuildGhc bf ldPath arPath @@ -325,18 +295,13 @@ rebuildGhc bf ld ar = do putStrLn "Rebuilding application... (using GHC API)" buildPackage bf ld ar -rebuildCabal :: D.GenericPackageDescription -> DevelOpts -> IO Bool -rebuildCabal _gpd opts = do - putStrLn $ "Rebuilding application... (using Cabal library)" - lbi <- getPersistBuildConfig opts -- fixme we could cache this from the configure step - let buildFlags | verbose opts = DSS.defaultBuildFlags - | otherwise = DSS.defaultBuildFlags { DSS.buildVerbosity = DSS.Flag D.silent } - tryBool $ D.build (D.localPkgDescr lbi) lbi buildFlags [] - -tryBool :: IO a -> IO Bool -tryBool a = (a >> return True) `Ex.catch` \(e::Ex.SomeException) -> do - putStrLn $ "Exception: " ++ show e - return False +rebuildCabal :: DevelOpts -> IO Bool +rebuildCabal opts = do + putStrLn $ "Rebuilding application... (using " ++ cabalProgram opts ++ ")" + checkExit =<< createProcess (proc (cabalProgram opts) args) + where + args | verbose opts = [ "build" ] + | otherwise = [ "build", "-v0" ] try_ :: forall a. IO a -> IO () try_ x = (Ex.try x :: IO (Either Ex.SomeException a)) >> return () @@ -421,57 +386,8 @@ ghcVersion = fmap getNumber $ readProcess "runghc" ["--numeric-version", "0"] [] where getNumber = filter (\x -> isNumber x || x == '.') -ghcPackageArgs :: DevelOpts -> String -> D.PackageDescription -> D.Library -> IO [String] -ghcPackageArgs opts ghcVer cabal lib = do - lbi <- getPersistBuildConfig opts - cbi <- fromMaybeErr errCbi (D.libraryConfig lbi) - if isCabalDev opts - then return ("-hide-all-packages" : "-no-user-package-conf" : inplaceConf - : selfPkgArg lbi : cabalDevConf : depArgs lbi cbi) - else return ("-hide-all-packages" : inplaceConf : selfPkgArg lbi : depArgs lbi cbi) - where - selfPkgArg lbi = pkgArg . D.inplacePackageId . D.package . D.localPkgDescr $ lbi - pkgArg (D.InstalledPackageId pkgId) = "-package-id" ++ pkgId - depArgs lbi cbi = map pkgArg (deps lbi cbi) - deps lbi cbi = let pkgInfo = D.inplaceInstalledPackageInfo "." (getBuildDir opts) cabal lib lbi cbi - in IPI.depends $ pkgInfo - errCbi = "No library ComponentBuildInfo" - cabalDevConf = "-package-confcabal-dev/packages-" ++ ghcVer ++ ".conf" - inplaceConf = "-package-conf" ++ (getBuildDir opts"package.conf.inplace") - -getPersistBuildConfig :: DevelOpts -> IO D.LocalBuildInfo -getPersistBuildConfig opts = fromRightErr errLbi =<< getPersistConfigLenient opts -- D.maybeGetPersistBuildConfig path - where - errLbi = "Could not read BuildInfo file: " ++ D.localBuildInfoFile (getBuildDir opts) ++ - "\nMake sure that cabal-install has been compiled with the same GHC version as yesod." ++ - "\nand that the Cabal library used by GHC is the same version" - --- there can be slight differences in the cabal version, ignore those when loading the file as long as we can parse it -getPersistConfigLenient :: DevelOpts -> IO (Either String D.LocalBuildInfo) -getPersistConfigLenient opts = do - let file = D.localBuildInfoFile (getBuildDir opts) - exists <- doesFileExist file - if not exists - then return (Left $ "file does not exist: " ++ file) - else do - xs <- safeReadFile file - case xs of - Left e -> return $ Left $ show e - Right bs -> - return $ case lines $ T.unpack $ decodeUtf8With lenientDecode bs of - [_,l2] -> -- two lines, header and serialized rest - case reads l2 of - [(bi,_)] -> Right bi - _ -> (Left "cannot parse contents") - _ -> (Left "not a valid header/content file") - -fromMaybeErr :: String -> Maybe b -> IO b -fromMaybeErr err Nothing = failWith err -fromMaybeErr _ (Just x) = return x - -fromRightErr :: String -> Either String b -> IO b -fromRightErr str (Left err) = failWith (str ++ "\n" ++ err) -fromRightErr _ (Right b) = return b +ghcPackageArgs :: IO [String] +ghcPackageArgs = getBuildFlags >>= getPackageArgs lookupDevelLib :: D.GenericPackageDescription -> D.CondTree D.ConfVar c a -> Maybe a lookupDevelLib gpd ct | found = Just (D.condTreeData ct) @@ -507,3 +423,7 @@ waitForProcess' pid = go Just ec -> return ec Nothing -> threadDelay 100000 >> go +-- | wait for process started by @createProcess@, return True for ExitSuccess +checkExit :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO Bool +checkExit (_,_,_,h) = (==ExitSuccess) <$> waitForProcess' h + diff --git a/yesod/GhcBuild.hs b/yesod/GhcBuild.hs index be4fecf7..7545337d 100644 --- a/yesod/GhcBuild.hs +++ b/yesod/GhcBuild.hs @@ -16,7 +16,7 @@ build package with the GHC API -} -module GhcBuild (getBuildFlags, buildPackage) where +module GhcBuild (getBuildFlags, buildPackage, getPackageArgs) where import qualified Control.Exception as Ex import Control.Monad (when) @@ -33,14 +33,16 @@ import DriverPhases (Phase (..), anyHsc, isHaskellSrcFilename, import DriverPipeline (compileFile, link, linkBinary, oneShot) import DynFlags (DynFlags, compilerInfo) import qualified DynFlags +import qualified DynFlags as DF import qualified GHC import GHC.Paths (libdir) import HscTypes (HscEnv (..), emptyHomePackageTable) +import qualified Module import MonadUtils (liftIO) import Panic (ghcError, panic) import SrcLoc (Located, mkGeneralLocated) -import StaticFlags (v_Ld_inputs) import qualified StaticFlags +import StaticFlags (v_Ld_inputs) import System.FilePath (normalise, ()) import Util (consIORef, looksLikeModuleName) @@ -71,6 +73,42 @@ prependHsenvArgv argv = do _ -> hsenvArgv ++ argv where hsenvArgv = words $ fromMaybe "" (lookup "PACKAGE_DB_FOR_GHC" env) +-- construct a command line for loading the right packages +getPackageArgs :: [Located String] -> IO [String] +getPackageArgs argv2 = do + (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2 + GHC.runGhc (Just libdir) $ do + dflags0 <- GHC.getSessionDynFlags + (dflags1, _, _) <- GHC.parseDynamicFlags dflags0 argv3 + let pkgFlags = map convertPkgFlag (GHC.packageFlags dflags1) + hideAll | gopt DF.Opt_HideAllPackages dflags1 = [ "-hide-all-packages"] + | otherwise = [] + ownPkg = "-package" ++ Module.packageIdString (DF.thisPackage dflags1) + return (extra dflags1 ++ hideAll ++ pkgFlags ++ [ownPkg]) + where + convertPkgFlag (DF.ExposePackage p) = "-package" ++ p + convertPkgFlag (DF.ExposePackageId p) = "-package-id" ++ p + convertPkgFlag (DF.HidePackage p) = "-hide-package" ++ p + convertPkgFlag (DF.IgnorePackage p) = "-ignore-package" ++ p + convertPkgFlag (DF.TrustPackage p) = "-trust" ++ p + convertPkgFlag (DF.DistrustPackage p) ="-distrust" ++ p +#if __GLASGOW_HASKELL__ >= 705 + extra df = concatMap convertExtra (extraConfs df) + extraConfs df = GHC.extraPkgConfs df [] + convertExtra DF.GlobalPkgConf = [ ] + convertExtra DF.UserPkgConf = [ ] + convertExtra (DF.PkgConfFile file) = [ "-package-db" ++ file ] +#else + extra df = map ("-package-conf"++) (GHC.extraPkgConfs df) +#endif + +#if __GLASGOW_HASKELL__ >= 707 + gopt = DF.gopt +#else + gopt = DF.dopt +#endif + + buildPackage :: [Located String] -> FilePath -> FilePath -> IO Bool buildPackage a ld ar = buildPackage' a ld ar `Ex.catch` \e -> do putStrLn ("exception building package: " ++ show (e :: Ex.SomeException))