rebuild application with GHC API (incomplete, only tested on linux, GHC 7.4.1 required)

yesod/Build.hs

@@ -5,6 +5,7 @@ module Build
     , touchDeps
     , touch
     , recompDeps
+    , isNewerThan
     ) where
 
 -- FIXME there's a bug when getFileStatus applies to a file

yesod/Devel.hs

@@ -30,7 +30,10 @@ import           System.Process (createProcess, proc, terminateProcess, readProc
                                            waitForProcess, rawSystem, runInteractiveProcess)
 import           System.IO (hClose, hIsEOF, hGetLine, stdout, stderr, hPutStrLn)
 
-import Build (recompDeps, getDeps)
+import Build (recompDeps, getDeps, isNewerThan)
+import GhcBuild (getBuildFlags, buildPackage)
+
+import qualified Config as GHC
 
 lockFile :: FilePath
 lockFile = "dist/devel-terminate"
@@ -57,7 +60,7 @@ devel isCabalDev passThroughArgs = do
 
       _<- rawSystem cmd args
 
-      mainLoop hsSourceDirs
+      mainLoop hsSourceDirs cabal
 
     _ <- getLine
     writeLock
@@ -67,32 +70,36 @@ devel isCabalDev passThroughArgs = do
         | otherwise  = "cabal"
 
     diffArgs | isCabalDev = [
-              "--cabal-install-arg=-fdevel" -- legacy
+              "--cabal-install-arg=--with-compiler=yesod-ghc-wrapper"
+            , "--cabal-install-arg=--with-ld=yesod-ld-wrapper"
+            , "--cabal-install-arg=--with-ar=yesod-ar-wrapper"
+            , "--cabal-install-arg=-fdevel" -- legacy
             , "--cabal-install-arg=-flibrary-only"
             ]
              | otherwise  = [
-              "-fdevel" -- legacy
+              "--with-compiler=yesod-ghc-wrapper"
+            , "--with-ld=yesod-ld-wrapper"
+            , "--with-ar=yesod-ar-wrapper"
+            , "-fdevel" -- legacy
             , "-flibrary-only"
             ]
     args = "configure":diffArgs ++ ["--disable-library-profiling" ]
 
-    mainLoop :: [FilePath] -> IO ()
+    mainLoop :: [FilePath] -> FilePath -> IO ()
-    mainLoop hsSourceDirs = do
+    mainLoop hsSourceDirs cabal = do
        ghcVer <- ghcVersion
-       when isCabalDev (rawSystemFilter cmd ["build"] >> return ())  -- cabal-dev fails with strange errors sometimes if we cabal-dev buildinfo before cabal-dev build
+       rebuildCabal cmd
        pkgArgs <- ghcPackageArgs isCabalDev ghcVer
+       rebuild <- mkRebuild ghcVer cabal cmd
        let devArgs = pkgArgs ++ ["devel.hs"] ++ passThroughArgs
        forever $ do
-           putStrLn "Rebuilding application..."
-
            recompDeps hsSourceDirs
 
            list <- getFileList hsSourceDirs
-           exit <- rawSystemFilter cmd ["build"]
+           success <- rebuild
-
+           if not success
-           case exit of
+             then putStrLn "Build failure, pausing..."
-             ExitFailure _ -> putStrLn "Build failure, pausing..."
+             else do
-             _ -> do
                    removeLock
                    putStrLn $ "Starting development server: runghc " ++ L.unwords devArgs
                    (_,_,_,ph) <- createProcess $ proc "runghc" devArgs
@@ -108,6 +115,30 @@ devel isCabalDev passThroughArgs = do
                    Ex.throwTo watchTid (userError "process finished")
            watchForChanges hsSourceDirs list
 
+mkRebuild :: String -> FilePath -> String -> IO (IO Bool)
+mkRebuild ghcVer cabalFile cabalCmd
+  | GHC.cProjectVersion == ghcVer = do
+      bf <- getBuildFlags
+      return $ do
+        n <- cabalFile `isNewerThan` "dist/ghcargs.txt"
+        if n
+          then rebuildCabal cabalCmd
+          else rebuildGhc bf
+  | otherwise = return $ do
+                  putStrLn "WARNING: yesod is compiled with a different ghc version, falling back to cabal"
+                  rebuildCabal cabalCmd
+
+rebuildGhc bf = do
+  putStrLn "Rebuilding application... (GHC API)"
+  buildPackage bf
+
+rebuildCabal cmd = do
+  putStrLn "Rebuilding application... (cabal)"
+  exit <- rawSystemFilter cmd ["build"]
+  return $ case exit of
+             ExitSuccess -> True
+             _           -> False
+
 try_ :: forall a. IO a -> IO ()
 try_ x = (Ex.try x :: IO (Either Ex.SomeException a)) >> return ()
 
@@ -221,3 +252,5 @@ rawSystemFilter command args = do
     _ <- forkIO $ go outh stdout
     _ <- forkIO $ go errh stderr
     waitForProcess ph
+
+

yesod/GhcBuild.hs

@@ -0,0 +1,379 @@
+{-# LANGUAGE CPP, ScopedTypeVariables #-}
+
+{-
+  build package with the GHC API
+-}
+
+module GhcBuild (getBuildFlags, buildPackage) where
+
+import qualified Control.Exception as Ex
+import System.Process (rawSystem)
+import Control.Monad (when)
+
+import qualified GHC
+import DriverPhases ( Phase(..), isSourceFilename, anyHsc, startPhase, isHaskellSrcFilename )
+import Util (looksLikeModuleName, consIORef)
+import DriverPipeline (oneShot, compileFile, link, linkBinary )
+import StaticFlags (v_Ld_inputs)
+import HscTypes ( emptyHomePackageTable, HscEnv(..) )
+import System.FilePath (normalise)
+import GHC.Paths (libdir)
+import MonadUtils ( liftIO )
+import CmdLineParser
+import SrcLoc (Located, mkGeneralLocated)
+import DynFlags (DynFlags, compilerInfo)
+import Data.Char (toLower)
+import Data.Maybe (fromMaybe)
+import Panic (panic, ghcError)
+import Data.List (partition, isPrefixOf)
+
+getBuildFlags :: IO [Located String]
+getBuildFlags = do
+  argv0 <- fmap read $ readFile "dist/ghcargs.txt" -- generated by yesod-ghc-wrapper
+  let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0
+      mbMinusB | null minusB_args = Nothing
+               | otherwise = Just (drop 2 (last minusB_args))
+  let argv1' = map (mkGeneralLocated "on the commandline") argv1
+  (argv2, staticFlagWarnings) <- GHC.parseStaticFlags argv1'
+  return argv2
+
+buildPackage :: [Located String] -> IO Bool
+buildPackage a = buildPackage' a `Ex.catch` \(e::Ex.SomeException) -> do
+  putStrLn ("exception building package: " ++ show e)
+  return False
+
+buildPackage' argv2 = do
+  (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2
+  GHC.runGhc (Just libdir) $ do
+    dflags0 <- GHC.getSessionDynFlags
+    (dflags1, _, _) <- GHC.parseDynamicFlags dflags0 argv3
+    let dflags2 = dflags1 { GHC.ghcMode   = GHC.CompManager
+                          , GHC.hscTarget = GHC.hscTarget dflags1
+                          , GHC.ghcLink   = GHC.LinkBinary
+                          , GHC.verbosity = 1
+                          }
+    (dflags3, fileish_args, _) <- GHC.parseDynamicFlags dflags2 argv3
+    GHC.setSessionDynFlags dflags3
+    let normal_fileish_paths = map (normalise . GHC.unLoc) fileish_args
+        (srcs, objs)         = partition_args normal_fileish_paths [] []
+        (hs_srcs, non_hs_srcs) = partition haskellish srcs
+        haskellish (f,Nothing) =
+          looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f
+        haskellish (_,Just phase) =
+          phase `notElem` [As, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn]
+    hsc_env <- GHC.getSession
+--    if (null hs_srcs)
+--       then liftIO (oneShot hsc_env StopLn srcs)
+--       else do
+    o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)
+                 non_hs_srcs
+    liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files)
+    targets <- mapM (uncurry GHC.guessTarget) hs_srcs
+    GHC.setTargets targets
+    ok_flag <- GHC.load GHC.LoadAllTargets
+    if GHC.failed ok_flag
+      then return False
+      else liftIO linkPkg >> return True
+
+-- fixme, find default ar and ld versions
+linkPkg = do
+  arargs <- fmap read $ readFile "dist/arargs.txt"
+  rawSystem "ar" arargs
+  ldargs <- fmap read $ readFile "dist/ldargs.txt"
+  rawSystem "ld" ldargs
+
+
+--------------------------------------------------------------------------------------------
+-- stuff below copied from ghc main.hs
+--------------------------------------------------------------------------------------------
+
+partition_args :: [String] -> [(String, Maybe Phase)] -> [String]
+               -> ([(String, Maybe Phase)], [String])
+partition_args [] srcs objs = (reverse srcs, reverse objs)
+partition_args ("-x":suff:args) srcs objs
+  | "none" <- suff      = partition_args args srcs objs
+  | StopLn <- phase     = partition_args args srcs (slurp ++ objs)
+  | otherwise           = partition_args rest (these_srcs ++ srcs) objs
+        where phase = startPhase suff
+              (slurp,rest) = break (== "-x") args
+              these_srcs = zip slurp (repeat (Just phase))
+partition_args (arg:args) srcs objs
+  | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs
+  | otherwise               = partition_args args srcs (arg:objs)
+
+    {-
+      We split out the object files (.o, .dll) and add them
+      to v_Ld_inputs for use by the linker.
+
+      The following things should be considered compilation manager inputs:
+
+       - haskell source files (strings ending in .hs, .lhs or other
+         haskellish extension),
+
+       - module names (not forgetting hierarchical module names),
+
+       - and finally we consider everything not containing a '.' to be
+         a comp manager input, as shorthand for a .hs or .lhs filename.
+
+      Everything else is considered to be a linker object, and passed
+      straight through to the linker.
+    -}
+looks_like_an_input :: String -> Bool
+looks_like_an_input m =  isSourceFilename m
+                      || looksLikeModuleName m
+                      || '.' `notElem` m
+
+
+
+-- Parsing the mode flag
+
+parseModeFlags :: [Located String]
+               -> IO (Mode,
+                      [Located String],
+                      [Located String])
+parseModeFlags args = do
+  let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =
+          runCmdLine (processArgs mode_flags args)
+                     (Nothing, [], [])
+      mode = case mModeFlag of
+             Nothing     -> doMakeMode
+             Just (m, _) -> m
+      errs = errs1 ++ map (mkGeneralLocated "on the commandline") errs2
+  when (not (null errs)) $ ghcError $ errorsToGhcException errs
+  return (mode, flags' ++ leftover, warns)
+
+type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])
+  -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)
+  -- so we collect the new ones and return them.
+
+mode_flags :: [Flag ModeM]
+mode_flags =
+  [  ------- help / version ----------------------------------------------
+    Flag "?"                     (PassFlag (setMode showGhcUsageMode))
+  , Flag "-help"                 (PassFlag (setMode showGhcUsageMode))
+  , Flag "V"                     (PassFlag (setMode showVersionMode))
+  , Flag "-version"              (PassFlag (setMode showVersionMode))
+  , Flag "-numeric-version"      (PassFlag (setMode showNumVersionMode))
+  , Flag "-info"                 (PassFlag (setMode showInfoMode))
+  , Flag "-supported-languages"  (PassFlag (setMode showSupportedExtensionsMode))
+  , Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))
+  ] ++
+  [ Flag k'                      (PassFlag (setMode (printSetting k)))
+  | k <- ["Project version",
+          "Booter version",
+          "Stage",
+          "Build platform",
+          "Host platform",
+          "Target platform",
+          "Have interpreter",
+          "Object splitting supported",
+          "Have native code generator",
+          "Support SMP",
+          "Unregisterised",
+          "Tables next to code",
+          "RTS ways",
+          "Leading underscore",
+          "Debug on",
+          "LibDir",
+          "Global Package DB",
+          "C compiler flags",
+          "Gcc Linker flags",
+          "Ld Linker flags"],
+    let k' = "-print-" ++ map (replaceSpace . toLower) k
+        replaceSpace ' ' = '-'
+        replaceSpace c   = c
+  ] ++
+      ------- interfaces ----------------------------------------------------
+  [ Flag "-show-iface"  (HasArg (\f -> setMode (showInterfaceMode f)
+                                               "--show-iface"))
+
+      ------- primary modes ------------------------------------------------
+  , Flag "c"            (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f
+                                            addFlag "-no-link" f))
+  , Flag "M"            (PassFlag (setMode doMkDependHSMode))
+  , Flag "E"            (PassFlag (setMode (stopBeforeMode anyHsc)))
+  , Flag "C"            (PassFlag (\f -> do setMode (stopBeforeMode HCc) f
+                                            addFlag "-fvia-C" f))
+  , Flag "S"            (PassFlag (setMode (stopBeforeMode As)))
+  , Flag "-make"        (PassFlag (setMode doMakeMode))
+  , Flag "-interactive" (PassFlag (setMode doInteractiveMode))
+  , Flag "-abi-hash"    (PassFlag (setMode doAbiHashMode))
+  , Flag "e"            (SepArg   (\s -> setMode (doEvalMode s) "-e"))
+  ]
+
+setMode :: Mode -> String -> EwM ModeM ()
+setMode newMode newFlag = liftEwM $ do
+    (mModeFlag, errs, flags') <- getCmdLineState
+    let (modeFlag', errs') =
+            case mModeFlag of
+            Nothing -> ((newMode, newFlag), errs)
+            Just (oldMode, oldFlag) ->
+                case (oldMode, newMode) of
+                    -- -c/--make are allowed together, and mean --make -no-link
+                    _ |  isStopLnMode oldMode && isDoMakeMode newMode
+                      || isStopLnMode newMode && isDoMakeMode oldMode ->
+                      ((doMakeMode, "--make"), [])
+
+                    -- If we have both --help and --interactive then we
+                    -- want showGhciUsage
+                    _ | isShowGhcUsageMode oldMode &&
+                        isDoInteractiveMode newMode ->
+                            ((showGhciUsageMode, oldFlag), [])
+                      | isShowGhcUsageMode newMode &&
+                        isDoInteractiveMode oldMode ->
+                            ((showGhciUsageMode, newFlag), [])
+                    -- Otherwise, --help/--version/--numeric-version always win
+                      | isDominantFlag oldMode -> ((oldMode, oldFlag), [])
+                      | isDominantFlag newMode -> ((newMode, newFlag), [])
+                    -- We need to accumulate eval flags like "-e foo -e bar"
+                    (Right (Right (DoEval esOld)),
+                     Right (Right (DoEval [eNew]))) ->
+                        ((Right (Right (DoEval (eNew : esOld))), oldFlag),
+                         errs)
+                    -- Saying e.g. --interactive --interactive is OK
+                    _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs)
+                    -- Otherwise, complain
+                    _ -> let err = flagMismatchErr oldFlag newFlag
+                         in ((oldMode, oldFlag), err : errs)
+    putCmdLineState (Just modeFlag', errs', flags')
+  where isDominantFlag f = isShowGhcUsageMode   f ||
+                           isShowGhciUsageMode  f ||
+                           isShowVersionMode    f ||
+                           isShowNumVersionMode f
+
+flagMismatchErr :: String -> String -> String
+flagMismatchErr oldFlag newFlag
+    = "cannot use `" ++ oldFlag ++  "' with `" ++ newFlag ++ "'"
+
+addFlag :: String -> String -> EwM ModeM ()
+addFlag s flag = liftEwM $ do
+  (m, e, flags') <- getCmdLineState
+  putCmdLineState (m, e, mkGeneralLocated loc s : flags')
+    where loc = "addFlag by " ++ flag ++ " on the commandline"
+
+type Mode = Either PreStartupMode PostStartupMode
+type PostStartupMode = Either PreLoadMode PostLoadMode
+
+data PreStartupMode
+  = ShowVersion             -- ghc -V/--version
+  | ShowNumVersion          -- ghc --numeric-version
+  | ShowSupportedExtensions -- ghc --supported-extensions
+  | Print String            -- ghc --print-foo
+
+showVersionMode, showNumVersionMode, showSupportedExtensionsMode :: Mode
+showVersionMode             = mkPreStartupMode ShowVersion
+showNumVersionMode          = mkPreStartupMode ShowNumVersion
+showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions
+
+mkPreStartupMode :: PreStartupMode -> Mode
+mkPreStartupMode = Left
+
+isShowVersionMode :: Mode -> Bool
+isShowVersionMode (Left ShowVersion) = True
+isShowVersionMode _ = False
+
+isShowNumVersionMode :: Mode -> Bool
+isShowNumVersionMode (Left ShowNumVersion) = True
+isShowNumVersionMode _ = False
+
+data PreLoadMode
+  = ShowGhcUsage                           -- ghc -?
+  | ShowGhciUsage                          -- ghci -?
+  | ShowInfo                               -- ghc --info
+  | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo
+
+showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode
+showGhcUsageMode = mkPreLoadMode ShowGhcUsage
+showGhciUsageMode = mkPreLoadMode ShowGhciUsage
+showInfoMode = mkPreLoadMode ShowInfo
+
+printSetting :: String -> Mode
+printSetting k = mkPreLoadMode (PrintWithDynFlags f)
+    where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))
+                   $ lookup k (compilerInfo dflags)
+
+mkPreLoadMode :: PreLoadMode -> Mode
+mkPreLoadMode = Right . Left
+
+isShowGhcUsageMode :: Mode -> Bool
+isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True
+isShowGhcUsageMode _ = False
+
+isShowGhciUsageMode :: Mode -> Bool
+isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True
+isShowGhciUsageMode _ = False
+
+data PostLoadMode
+  = ShowInterface FilePath  -- ghc --show-iface
+  | DoMkDependHS            -- ghc -M
+  | StopBefore Phase        -- ghc -E | -C | -S
+                            -- StopBefore StopLn is the default
+  | DoMake                  -- ghc --make
+  | DoInteractive           -- ghc --interactive
+  | DoEval [String]         -- ghc -e foo -e bar => DoEval ["bar", "foo"]
+  | DoAbiHash               -- ghc --abi-hash
+
+doMkDependHSMode, doMakeMode, doInteractiveMode, doAbiHashMode :: Mode
+doMkDependHSMode = mkPostLoadMode DoMkDependHS
+doMakeMode = mkPostLoadMode DoMake
+doInteractiveMode = mkPostLoadMode DoInteractive
+doAbiHashMode = mkPostLoadMode DoAbiHash
+
+
+showInterfaceMode :: FilePath -> Mode
+showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)
+
+stopBeforeMode :: Phase -> Mode
+stopBeforeMode phase = mkPostLoadMode (StopBefore phase)
+
+doEvalMode :: String -> Mode
+doEvalMode str = mkPostLoadMode (DoEval [str])
+
+mkPostLoadMode :: PostLoadMode -> Mode
+mkPostLoadMode = Right . Right
+
+isDoInteractiveMode :: Mode -> Bool
+isDoInteractiveMode (Right (Right DoInteractive)) = True
+isDoInteractiveMode _ = False
+
+isStopLnMode :: Mode -> Bool
+isStopLnMode (Right (Right (StopBefore StopLn))) = True
+isStopLnMode _ = False
+
+isDoMakeMode :: Mode -> Bool
+isDoMakeMode (Right (Right DoMake)) = True
+isDoMakeMode _ = False
+
+#ifdef GHCI
+isInteractiveMode :: PostLoadMode -> Bool
+isInteractiveMode DoInteractive = True
+isInteractiveMode _             = False
+#endif
+
+-- isInterpretiveMode: byte-code compiler involved
+isInterpretiveMode :: PostLoadMode -> Bool
+isInterpretiveMode DoInteractive = True
+isInterpretiveMode (DoEval _)    = True
+isInterpretiveMode _             = False
+
+needsInputsMode :: PostLoadMode -> Bool
+needsInputsMode DoMkDependHS    = True
+needsInputsMode (StopBefore _)  = True
+needsInputsMode DoMake          = True
+needsInputsMode _               = False
+
+-- True if we are going to attempt to link in this mode.
+-- (we might not actually link, depending on the GhcLink flag)
+isLinkMode :: PostLoadMode -> Bool
+isLinkMode (StopBefore StopLn) = True
+isLinkMode DoMake              = True
+isLinkMode DoInteractive       = True
+isLinkMode (DoEval _)          = True
+isLinkMode _                   = False
+
+isCompManagerMode :: PostLoadMode -> Bool
+isCompManagerMode DoMake        = True
+isCompManagerMode DoInteractive = True
+isCompManagerMode (DoEval _)    = True
+isCompManagerMode _             = False
+

yesod/ghcwrapper.hs

@@ -0,0 +1,41 @@
+{-
+  wrapper executable that captures arguments to ghc, ar or ld
+-}
+
+{-# LANGUAGE CPP #-}
+module Main where
+
+import System.Process (rawSystem, readProcess)
+import System.Environment (getArgs)
+import Data.Maybe (fromMaybe)
+import Control.Monad (when)
+import System.Exit (exitWith)
+import System.Directory (doesDirectoryExist)
+
+#ifdef LDCMD
+cmd = lookupGhcInfo "ld command" "ld"
+outFile = "dist/ldargs.txt"
+#else
+#ifdef ARCMD
+cmd = lookupGhcInfo "ar command" "ar"
+outFile ="dist/arargs.txt"
+#else
+cmd = return "ghc"
+outFile = "dist/ghcargs.txt"
+#endif
+#endif
+
+lookupGhcInfo :: String -> String -> IO String
+lookupGhcInfo xs d = fmap (fromMaybe d . lookup xs . read) (readProcess "ghc" ["--info"] "")
+
+passthrough args = do
+  c <- cmd
+  rawSystem c args
+
+main = do
+  args <- getArgs
+  e <- doesDirectoryExist "dist"
+  when e $ writeFile outFile (show args ++ "\n")
+  ex <- passthrough args
+  exitWith ex
+

yesod/yesod.cabal

@@ -90,6 +90,22 @@ library
     exposed-modules: Yesod
     ghc-options:     -Wall
 
+executable             yesod-ghc-wrapper
+    main-is: ghcwrapper.hs
+    build-depends:
+                   base                       >= 4         && < 5
+
+executable             yesod-ld-wrapper
+    main-is: ghcwrapper.hs
+    cpp-options:     -DLDCMD
+    build-depends:
+                   base                       >= 4         && < 5
+executable             yesod-ar-wrapper
+    main-is: ghcwrapper.hs
+    cpp-options:     -DARCMD
+    build-depends:
+                   base                       >= 4         && < 5
+
 executable             yesod
     if flag(ghc7)
         build-depends:   base                  >= 4.3      && < 5
@@ -114,6 +130,8 @@ executable             yesod
                      , filepath           >= 1.1
                      , fast-logger        >= 0.0.2        && < 0.1
                      , process
+                     , ghc                >= 7.4.1
+                     , ghc-paths          >= 0.1.0.8
     ghc-options:       -Wall
     if flag(threaded)
         ghc-options:    -threaded
@@ -122,6 +140,7 @@ executable             yesod
                        Scaffolding.Scaffolder
                        Devel
                        Build
+                       GhcBuild
 
 source-repository head
   type:     git