fix building with GHC API

yesod/Devel.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE CPP                 #-}
 module Devel
     ( devel
+    , DevelOpts(..)
     ) where
 
 
@@ -11,9 +12,17 @@ import qualified Distribution.Verbosity as D
 import qualified Distribution.PackageDescription.Parse as D
 import qualified Distribution.PackageDescription as D
 import qualified Distribution.ModuleName as D
+import qualified Distribution.Simple.Setup as DSS
 import qualified Distribution.Simple.Configure as D
 import qualified Distribution.Simple.Program as D
+import qualified Distribution.Simple.Build as D
+import qualified Distribution.Simple.Register as D
 import qualified Distribution.Compiler as D
+-- import qualified Distribution.InstalledPackageInfo as D
+import qualified Distribution.InstalledPackageInfo as IPI
+import qualified Distribution.Simple.LocalBuildInfo as D
+import qualified Distribution.Package as D
+import qualified Distribution.Verbosity as D
 
 import           Control.Applicative ((<$>), (<*>))
 import           Control.Concurrent (forkIO, threadDelay)
@@ -24,6 +33,7 @@ import           Data.Char (isUpper, isNumber)
 import qualified Data.List as L
 import qualified Data.Map as Map
 import qualified Data.Set as Set
+import           Data.Maybe (fromMaybe)
 
 import           System.Directory
 import           System.Exit (exitFailure, exitSuccess, ExitCode (..))
@@ -33,6 +43,7 @@ import           System.PosixCompat.Files (modificationTime, getFileStatus)
 import           System.Process (createProcess, proc, terminateProcess, readProcess, ProcessHandle,
                                        getProcessExitCode,waitForProcess, rawSystem, runInteractiveProcess)
 import           System.IO (hClose, hIsEOF, hGetLine, stdout, stderr, hPutStrLn)
+import           System.IO.Error (isDoesNotExistError)
 
 import           Build (recompDeps, getDeps, isNewerThan)
 import           GhcBuild (getBuildFlags, buildPackage)
@@ -49,10 +60,22 @@ writeLock = do
     writeFile lockFile ""
 
 removeLock :: IO ()
-removeLock = try_ (removeFile lockFile)
+removeLock = removeFileIfExists lockFile
 
-devel :: Bool -> Bool -> [String] -> IO ()
+data DevelOpts = DevelOpts
-devel isCabalDev forceCabal passThroughArgs = do
+      { isCabalDev :: Bool
+      , forceCabal :: Bool
+      , verbose    :: Bool
+      } deriving (Show, Eq)
+
+cabalCommand :: DevelOpts -> FilePath
+cabalCommand opts | isCabalDev opts = "cabal-dev"
+                  | otherwise       = "cabal"
+
+defaultDevelOpts = DevelOpts False False False
+
+devel :: DevelOpts -> [String] -> IO ()
+devel opts passThroughArgs = do
     checkDevelFile
     writeLock
 
@@ -62,54 +85,35 @@ devel isCabalDev forceCabal passThroughArgs = do
       gpd   <- D.readPackageDescription D.normal cabal
 
       ldar <- lookupLdAr
-      hsSourceDirs <- checkCabalFile gpd
+      (hsSourceDirs, lib) <- checkCabalFile gpd
 
-      _<- rawSystem cmd args
+      removeFileIfExists "dist/setup-config"
-
+      configure cabal gpd opts
-      mainLoop hsSourceDirs cabal ldar
+      removeFileIfExists "dist/ghcargs.txt"  -- these files contain the wrong data after
+      removeFileIfExists "dist/arargs.txt"   -- the configure step, remove them to force
+      removeFileIfExists "dist/ldargs.txt"   -- a cabal build first
+      mainLoop hsSourceDirs cabal gpd lib ldar
 
     _ <- getLine
     writeLock
     exitSuccess
   where
-    cmd | isCabalDev = "cabal-dev"
+    mainLoop :: [FilePath] -> FilePath -> D.GenericPackageDescription -> D.Library -> (FilePath, FilePath) -> IO ()
-        | otherwise  = "cabal"
+    mainLoop hsSourceDirs cabal gpd lib ldar = do
-
-    diffArgs | isCabalDev = [
-              "--cabal-install-arg=--with-compiler=yesod-ghc-wrapper"
-            , "--cabal-install-arg=--with-hc-pkg=ghc-pkg"
-            , "--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  = [
-              "--with-compiler=yesod-ghc-wrapper"
-            , "--with-hc-pkg=ghc-pkg"
-            , "--with-ld=yesod-ld-wrapper"
-            , "--with-ar=yesod-ar-wrapper"
-            , "-fdevel" -- legacy
-            , "-flibrary-only"
-            ]
-    args = "configure":diffArgs ++ ["--disable-library-profiling" ]
-
-    mainLoop :: [FilePath] -> FilePath -> (FilePath, FilePath) -> IO ()
-    mainLoop hsSourceDirs cabal ldar = do
        ghcVer <- ghcVersion
-       _ <- rebuildCabal cmd
+       rebuild <- mkRebuild gpd ghcVer cabal opts ldar
-       pkgArgs <- ghcPackageArgs isCabalDev ghcVer
-       rebuild <- mkRebuild ghcVer cabal cmd forceCabal ldar
-       let devArgs = pkgArgs ++ ["devel.hs"] ++ passThroughArgs
        forever $ do
            recompDeps hsSourceDirs
-
            list <- getFileList hsSourceDirs [cabal]
            success <- rebuild
+           pkgArgs <- ghcPackageArgs opts ghcVer (D.packageDescription gpd) lib
+           let devArgs = pkgArgs ++ ["devel.hs"] ++ passThroughArgs
            if not success
              then putStrLn "Build failure, pausing..."
              else do
                    removeLock
-                   putStrLn $ "Starting development server: runghc " ++ L.unwords devArgs
+                   putStrLn $ if verbose opts then "Starting development server: runghc " ++ L.unwords devArgs
+                                              else "Starting development server..."
                    (_,_,_,ph) <- createProcess $ proc "runghc" devArgs
                    watchTid <- forkIO . try_ $ do
                          watchForChanges hsSourceDirs [cabal] list
@@ -123,34 +127,107 @@ devel isCabalDev forceCabal passThroughArgs = do
                    Ex.throwTo watchTid (userError "process finished")
            watchForChanges hsSourceDirs [cabal] list
 
-mkRebuild :: String -> FilePath -> String -> Bool -> (FilePath, FilePath) -> IO (IO Bool)
+
-mkRebuild ghcVer cabalFile cabalCmd forceCabal (ldPath, arPath)
+{-
-  | forceCabal = return (rebuildCabal cabalCmd)
+  configure with the built-in Cabal lib for non-cabal-dev, since
-  | GHC.cProjectVersion == ghcVer = do
+  otherwise we cannot read the configuration later
-      bf <- getBuildFlags
+
+  cabal-dev uses the command-line tool, we can fall back to
+  cabal-dev buildopts if required
+-}
+configure :: FilePath -> D.GenericPackageDescription -> DevelOpts -> IO ()
+configure cabal gpd opts
+  | isCabalDev opts = rawSystem (cabalCommand opts) args >> return ()
+  | otherwise       = do
+                        lbi <- D.configure (gpd, hookedBuildInfo) configFlags
+                        D.writePersistBuildConfig "dist" lbi -- fixme we could keep this in memory instead of file
+  where
+    hookedBuildInfo = (Nothing, [])
+    configFlags | 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"
+                       }
+
+    config = (DSS.defaultConfigFlags D.defaultProgramConfiguration)
+               { DSS.configConfigurationsFlags =
+                     [ (D.FlagName "devel", True)  -- legaxy
+                     , (D.FlagName "library-only", True)
+                     ]
+               , DSS.configProfLib     = DSS.Flag False
+               , DSS.configUserInstall = DSS.Flag True
+               }
+    cabalArgs
+        | isCabalDev opts = map ("--cabal-install-arg=" ++) args
+        | otherwise       = args
+        where
+          args =
+            [ "-fdevel" -- legacy
+            , "-flibrary-only"
+            ] ++ wrapperArgs
+          wrapperArgs
+              | forceCabal opts = []
+              | otherwise       =
+                  [ "--with-compiler=yesod-ghc-wrapper"
+                  , "--with-hc-pkg=ghc-pkg"
+                  , "--with-ld=yesod-ld-wrapper"
+                  , "--with-ar=yesod-ar-wrapper"
+                  ]
+    args :: [String]
+    args = "configure":cabalArgs ++ ["--disable-library-profiling" ]
+
+
+removeFileIfExists :: FilePath -> IO ()
+removeFileIfExists file = removeFile file `Ex.catch` handler
+    where
+      handler :: IOError -> IO ()
+      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)
+  | otherwise                     = do
       return $ do
         n1 <- cabalFile `isNewerThan` "dist/ghcargs.txt"
         n2 <- cabalFile `isNewerThan` "dist/arargs.txt"
         n3 <- cabalFile `isNewerThan` "dist/ldargs.txt"
         if n1 || n2 || n3
-          then rebuildCabal cabalCmd
+          then rebuildCabal gpd opts
-          else rebuildGhc bf ldPath arPath
+          else do
-  | otherwise = return $ do
+            bf <- getBuildFlags
-                  putStrLn "WARNING: yesod is compiled with a different ghc version, falling back to cabal"
+            rebuildGhc bf ldPath arPath
-                  rebuildCabal cabalCmd
+
 
 rebuildGhc :: [Located String] -> FilePath -> FilePath -> IO Bool
 rebuildGhc bf ld ar = do
   putStrLn "Rebuilding application... (GHC API)"
   buildPackage bf ld ar
 
-rebuildCabal :: String -> IO Bool
+rebuildCabal :: D.GenericPackageDescription -> DevelOpts -> IO Bool
-rebuildCabal cmd = do
+rebuildCabal gpd opts
-  putStrLn $ "Rebuilding application... (" ++ cmd ++ ")"
+    | isCabalDev opts = do
-  exit <- rawSystemFilter cmd ["build"]
+       let cmd = cabalCommand opts
-  return $ case exit of
+       putStrLn $ "Rebuilding application... (" ++ cmd ++ ")"
+       exit <- (if verbose opts then rawSystem else rawSystemFilter) cmd ["build"]
+       return $ case exit of
              ExitSuccess -> True
              _           -> False
+    | otherwise = do
+       putStrLn $ "Rebuilding application... (Cabal library)"
+       lbi <- getPersistBuildConfig "dist" -- 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 a = (a >> return True) `Ex.catch` \(e::Ex.SomeException) -> do
+  putStrLn $ "Exception: " ++ show e
+  return False
 
 try_ :: forall a. IO a -> IO ()
 try_ x = (Ex.try x :: IO (Either Ex.SomeException a)) >> return ()
@@ -179,7 +256,7 @@ checkDevelFile = do
   e <- doesFileExist "devel.hs"
   unless e $ failWith "file devel.hs not found"
 
-checkCabalFile :: D.GenericPackageDescription -> IO [FilePath]
+checkCabalFile :: D.GenericPackageDescription -> IO ([FilePath], D.Library)
 checkCabalFile gpd = case D.condLibrary gpd of
     Nothing -> failWith "incorrect cabal file, no library"
     Just ct ->
@@ -195,7 +272,7 @@ checkCabalFile gpd = case D.condLibrary gpd of
                 mapM_ putStrLn unlisted
            when (D.fromString "Application" `notElem` D.exposedModules dLib) $
                 putStrLn "WARNING: no exposed module Application"
-           return hsSourceDirs
+           return (hsSourceDirs, dLib)
 
 failWith :: String -> IO a
 failWith msg = do
@@ -223,22 +300,33 @@ ghcVersion = fmap getNumber $ readProcess "runghc" ["--numeric-version", "0"] []
     where
       getNumber = filter (\x -> isNumber x || x == '.')
 
-ghcPackageArgs :: Bool -> String -> IO [String]
+ghcPackageArgs :: DevelOpts -> String -> D.PackageDescription -> D.Library -> IO [String]
-ghcPackageArgs isCabalDev ghcVer
+ghcPackageArgs opts ghcVer cabal lib = do
-  | isCabalDev = do
+   lbi <- getPersistBuildConfig "dist"
-      r <- readProcess "cabal-dev" ["buildopts"] []
+   cbi <- fromMaybeErr errCbi (D.libraryConfig lbi)
-      let opts = L.lines r
+   if isCabalDev opts
-      return $ "-hide-all-packages" : "-no-user-package-conf" : inplacePkg : cabaldevConf : pkgid opts : depPkgIds opts
+     then return ("-hide-all-packages" : "-no-user-package-conf" : inplaceConf : selfPkgArg lbi : cabalDevConf : depArgs lbi cbi)
-  | otherwise = return [inplacePkg]
+     else return ("-hide-all-packages" : inplaceConf : selfPkgArg lbi : depArgs lbi cbi)
       where
-        pkgid opts      = let (_,p) = head (selectOpts ["-package-name"] opts) in "-package-id" ++ p ++ "-inplace"
+        selfPkgArg lbi  = pkgArg . D.inplacePackageId . D.package . D.localPkgDescr $ lbi
-        depPkgIds opts  = map (uncurry (++)) (selectOpts ["-package-id"] opts)
+        pkgArg (D.InstalledPackageId id) = "-package-id" ++ id
-        inplacePkg   = "-package-confdist/package.conf.inplace"
+        depArgs lbi cbi = map pkgArg (deps lbi cbi)
-        cabaldevConf = "-package-confcabal-dev/packages-" ++ ghcVer ++ ".conf"
+        deps lbi cbi    = let pkgInfo = D.inplaceInstalledPackageInfo "." "dist" cabal lib lbi cbi
-        selectOpts opts (x1:x2:xs)
+                          in  IPI.depends $ pkgInfo
-           | x1 `elem` opts = (x1,x2):selectOpts opts xs
+        errCbi          = "No library ComponentBuildInfo"
-           | otherwise      = selectOpts opts (x2:xs)
+        cabalDevConf    = "-package-confcabal-dev/packages-" ++ ghcVer ++ ".conf"
-        selectOpts _ _ = []
+        inplaceConf     = "-package-confdist/package.conf.inplace"
+
+getPersistBuildConfig :: FilePath ->IO D.LocalBuildInfo
+getPersistBuildConfig path = fromMaybeErr errLbi =<< D.maybeGetPersistBuildConfig path
+    where
+        errLbi          = "Could not read BuildInfo file: " ++ D.localBuildInfoFile "dist" ++
+                          "\nMake sure that cabal-install has been compiled with the same GHC version as yesod."
+
+
+fromMaybeErr :: String -> Maybe b -> IO b
+fromMaybeErr err Nothing = failWith err
+fromMaybeErr _  (Just x) = return x
 
 lookupDevelLib :: D.CondTree D.ConfVar c a -> Maybe a
 lookupDevelLib ct | found     = Just (D.condTreeData ct)

yesod/GhcBuild.hs

@@ -19,6 +19,7 @@ module GhcBuild (getBuildFlags, buildPackage) where
 import qualified Control.Exception as Ex
 import System.Process (rawSystem)
 import Control.Monad (when)
+import Data.IORef
 
 import qualified GHC
 import DriverPhases ( Phase(..), isSourceFilename, anyHsc, startPhase, isHaskellSrcFilename )
@@ -37,7 +38,15 @@ import Data.Maybe (fromMaybe)
 import Panic (panic, ghcError)
 import Data.List (partition, isPrefixOf)
 import qualified DynFlags
+import qualified StaticFlags
 
+{-
+  This contains a huge hack:
+  GHC only accepts setting static flags once per process, however it has no way to
+  get the remaining options from the command line, without setting the static flags.
+  This code overwrites the IORef to disable the check. This will likely cause
+  problems if the flags are modified, but fortunately that's relatively uncommon.
+-}
 getBuildFlags :: IO [Located String]
 getBuildFlags = do
   argv0 <- fmap read $ readFile "dist/ghcargs.txt" -- generated by yesod-ghc-wrapper
@@ -45,6 +54,7 @@ getBuildFlags = do
       mbMinusB | null minusB_args = Nothing
                | otherwise = Just (drop 2 (last minusB_args))
   let argv1' = map (mkGeneralLocated "on the commandline") argv1
+  writeIORef StaticFlags.v_opt_C_ready False -- the huge hack
   (argv2, staticFlagWarnings) <- GHC.parseStaticFlags argv1'
   return argv2
 

yesod/Types.hs

@@ -4,7 +4,6 @@ module Types where
 
 import Options
 
-
 mkOptCabalDev name = option name (\o -> o
   { optionLongFlags    = ["dev", "use-cabal-dev"]
   , optionShortFlags   = ['d']
@@ -21,4 +20,19 @@ mkOptNoApi name = option name (\o -> o
   , optionDescription  = "do not use the GHC API to build, use `cabal build' instead"
   })
 
+mkOptApi name = option name (\o -> o
+  { optionLongFlags    = ["ghc-api"]
+  , optionShortFlags   = ['a']
+  , optionType         = optionTypeBool
+  , optionDefault      = "false"
+  , optionDescription  = "use the GHC API to build (faster, but experimental)"
+  })
+
+mkOptVerbose name = option name (\o -> o
+  { optionLongFlags    = ["verbose"]
+  , optionShortFlags   = ['v']
+  , optionType         = optionTypeBool
+  , optionDefault      = "false"
+  , optionDescription  = "more verbose output"
+  })
 

yesod/main.hs

@@ -10,7 +10,7 @@ import Options
 import Types
 
 import Build (touch)
-import Devel (devel)
+import Devel (devel, DevelOpts(..))
 import System.IO (stdout, stderr, hPutStr, hPutStrLn)
 import System.Exit (exitSuccess, exitFailure)
 import Control.Monad.IO.Class (MonadIO, liftIO)
@@ -18,10 +18,12 @@ import Control.Monad.IO.Class (MonadIO, liftIO)
 defineOptions "NoOptions" (return ())
 
 defineOptions "DevelOptions" $ do
-  mkOptNoApi    "develOptNoApi"
+  mkOptApi        "develOptApi"
+--  mkOptNoApi    "develOptNoApi"  -- use this later when flag is enabled by default
 
 defineOptions "MainOptions" $ do
   mkOptCabalDev "optCabalDev"
+  mkOptVerbose  "optVerbose"
 
 type InitOptions      = NoOptions
 type ConfigureOptions = NoOptions
@@ -50,10 +52,10 @@ cmdInit :: MainOptions -> InitOptions -> [String] -> IO ()
 cmdInit _ _ _ = scaffold
 
 cmdConfigure :: MainOptions -> ConfigureOptions -> [String] -> IO ()
-cmdConfigure mopt opts args = exitWith =<< rawSystem (cabalCommand mopt) ("configure":args)
+cmdConfigure mopt _ args = exitWith =<< rawSystem (cabalCommand mopt) ("configure":args)
 
 cmdBuild :: MainOptions -> BuildOptions -> [String] -> IO ()
-cmdBuild mopt opts args = do
+cmdBuild mopt _ args = do
   touch
   exitWith =<< rawSystem (cabalCommand mopt) ("build":args)
 
@@ -61,9 +63,11 @@ cmdTouch :: MainOptions -> TouchOptions -> [String] -> IO ()
 cmdTouch _ _ _ = touch
 
 cmdDevel :: MainOptions -> DevelOptions -> [String] -> IO ()
-cmdDevel mopt opts args = devel (optCabalDev mopt) forceCabal args
+cmdDevel mopt opts args = devel dopts args
     where
-      forceCabal = develOptNoApi opts
+      dopts      = DevelOpts (optCabalDev mopt) forceCabal (optVerbose mopt)
+      forceCabal = not (develOptApi opts)
+--      forceCabal = develOptNoApi opts
 
 cmdVersion :: MainOptions -> VersionOptions -> [String] -> IO ()
 cmdVersion _ _ _ = putStrLn $ "yesod-core version: " ++ yesodVersion