Rewrite yesod devel based on Stack #1304
Please see ChangeLog for explanation.
This commit is contained in:
Michael Snoyman
parent
54cc4205d8
commit
83d3a12a23
@ -26,3 +26,5 @@ extra-deps:
|
||||
|
||||
- conduit-extra-1.1.14
|
||||
- streaming-commons-0.1.16
|
||||
- typed-process-0.1.0.0
|
||||
- say-0.1.0.0
|
||||
|
||||
@ -1,3 +1,21 @@
|
||||
## 1.5.0
|
||||
|
||||
Rewrite of `yesod devel` to take advantage of Stack for a simpler codebase.
|
||||
|
||||
Advantages:
|
||||
|
||||
* Does not link against the ghc library, so can be used with multiple
|
||||
GHC versions
|
||||
* Leverages Stack's ability to check for dependent files, which is
|
||||
more robust than what yesod devel was doing previously
|
||||
* Seems to involve less rebuilding of the library on initial run
|
||||
|
||||
Disadvantages:
|
||||
|
||||
* Lost some functionality (e.g., failure hooks, controlling the exit
|
||||
command)
|
||||
* Newer codebase, quite likely has bugs that need to be ironed out.
|
||||
|
||||
## 1.4.18.7
|
||||
|
||||
* Actually release the changes for #1284
|
||||
|
||||
@ -1,163 +1,124 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module Devel
|
||||
( devel
|
||||
, develSignal
|
||||
, DevelOpts(..)
|
||||
, DevelTermOpt(..)
|
||||
, defaultDevelOpts
|
||||
) where
|
||||
|
||||
import qualified Distribution.Compiler as D
|
||||
import qualified Distribution.ModuleName as D
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Concurrent.Async (race_)
|
||||
import Control.Concurrent.MVar (newEmptyMVar, putMVar,
|
||||
takeMVar)
|
||||
import Control.Concurrent.STM
|
||||
import qualified Control.Exception.Safe as Ex
|
||||
import Control.Monad (forever, unless, void,
|
||||
when)
|
||||
import qualified Data.ByteString.Lazy as LB
|
||||
import Data.Default.Class (def)
|
||||
import Data.FileEmbed (embedFile)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Streaming.Network (bindPortTCP,
|
||||
bindRandomPortTCP)
|
||||
import Data.Time (getCurrentTime)
|
||||
import qualified Distribution.Package as D
|
||||
import qualified Distribution.PackageDescription as D
|
||||
import qualified Distribution.PackageDescription.Parse as D
|
||||
import qualified Distribution.Simple.Configure as D
|
||||
import qualified Distribution.Simple.Program as D
|
||||
import qualified Distribution.Simple.Utils as D
|
||||
import qualified Distribution.Verbosity as D
|
||||
|
||||
import Control.Applicative ((<$>), (<*>))
|
||||
import Control.Concurrent (forkIO, threadDelay)
|
||||
import Control.Concurrent.MVar (MVar, newEmptyMVar,
|
||||
takeMVar, tryPutMVar)
|
||||
import Control.Concurrent.Async (race_)
|
||||
import qualified Control.Exception as Ex
|
||||
import Control.Monad (forever, unless, void,
|
||||
when, forM)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Trans.State (evalStateT, get)
|
||||
import qualified Data.IORef as I
|
||||
|
||||
import qualified Data.ByteString.Lazy as LB
|
||||
import Data.Char (isNumber, isUpper)
|
||||
import qualified Data.List as L
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import System.Directory
|
||||
import System.Environment (getEnvironment)
|
||||
import System.Exit (ExitCode (..),
|
||||
exitFailure,
|
||||
exitSuccess)
|
||||
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,
|
||||
modificationTime)
|
||||
import System.Process (ProcessHandle,
|
||||
createProcess, env,
|
||||
getProcessExitCode,
|
||||
proc, readProcess,
|
||||
system,
|
||||
terminateProcess)
|
||||
import System.Timeout (timeout)
|
||||
|
||||
import Build (getDeps, isNewerThan,
|
||||
recompDeps)
|
||||
import GhcBuild (buildPackage,
|
||||
getBuildFlags, getPackageArgs)
|
||||
|
||||
import qualified Config as GHC
|
||||
import Data.Streaming.Network (bindPortTCP)
|
||||
import Network (withSocketsDo)
|
||||
import Network.HTTP.Conduit (conduitManagerSettings, newManager)
|
||||
import Data.Default.Class (def)
|
||||
#if MIN_VERSION_http_client(0,4,7)
|
||||
import Network.HTTP.Client (managerSetProxy, noProxy)
|
||||
#endif
|
||||
import Network.HTTP.Client (newManager)
|
||||
import Network.HTTP.Client (managerSetProxy,
|
||||
noProxy)
|
||||
import Network.HTTP.Client.TLS (tlsManagerSettings)
|
||||
import Network.HTTP.ReverseProxy (ProxyDest (ProxyDest),
|
||||
waiProxyToSettings, wpsTimeout, wpsOnExc)
|
||||
waiProxyToSettings,
|
||||
wpsOnExc, wpsTimeout)
|
||||
import qualified Network.HTTP.ReverseProxy as ReverseProxy
|
||||
import Network.HTTP.Types (status200, status503)
|
||||
import Network.Socket (sClose)
|
||||
import Network.Wai (responseLBS, requestHeaders,
|
||||
requestHeaderHost)
|
||||
import qualified Network.Socket
|
||||
import Network.Wai (requestHeaderHost,
|
||||
requestHeaders,
|
||||
responseLBS)
|
||||
import Network.Wai.Handler.Warp (defaultSettings, run,
|
||||
setPort)
|
||||
import Network.Wai.Handler.WarpTLS (runTLS,
|
||||
tlsSettingsMemory)
|
||||
import Network.Wai.Parse (parseHttpAccept)
|
||||
import Network.Wai.Handler.Warp (run, defaultSettings, setPort)
|
||||
import Network.Wai.Handler.WarpTLS (runTLS, tlsSettingsMemory)
|
||||
import SrcLoc (Located)
|
||||
import Data.FileEmbed (embedFile)
|
||||
import Say
|
||||
import System.Directory
|
||||
import System.Environment (getEnvironment,
|
||||
getExecutablePath)
|
||||
import System.FilePath (takeDirectory,
|
||||
takeFileName, (</>))
|
||||
import System.FSNotify
|
||||
import System.IO.Error (isDoesNotExistError)
|
||||
import System.Process.Typed
|
||||
|
||||
lockFile :: FilePath
|
||||
lockFile = "yesod-devel/devel-terminate"
|
||||
-- We have two special files:
|
||||
--
|
||||
-- * The terminate file tells the child process to die simply by being
|
||||
-- present. Ideally we'd handle this via killing the process
|
||||
-- directly, but that's historically never worked reliably.
|
||||
--
|
||||
-- * The signal file, which tells us that "stack build" has succeeded
|
||||
-- yet again.
|
||||
data SpecialFile = TermFile | SignalFile
|
||||
|
||||
writeLock :: DevelOpts -> IO ()
|
||||
writeLock _opts = do
|
||||
createDirectoryIfMissing True "yesod-devel"
|
||||
writeFile lockFile ""
|
||||
createDirectoryIfMissing True "dist" -- for compatibility with old devel.hs
|
||||
writeFile "dist/devel-terminate" ""
|
||||
specialFilePath :: SpecialFile -> FilePath
|
||||
|
||||
removeLock :: DevelOpts -> IO ()
|
||||
removeLock _opts = do
|
||||
removeFileIfExists lockFile
|
||||
removeFileIfExists "dist/devel-terminate" -- for compatibility with old devel.hs
|
||||
-- used by scaffolded app, cannot change
|
||||
specialFilePath TermFile = "yesod-devel/devel-terminate"
|
||||
|
||||
data DevelTermOpt = TerminateOnEnter | TerminateOnlyInterrupt
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- only used internally, can change
|
||||
specialFilePath SignalFile = "yesod-devel/rebuild"
|
||||
|
||||
-- | Write a special file
|
||||
writeSpecialFile :: SpecialFile -> IO ()
|
||||
writeSpecialFile sp = do
|
||||
let fp = specialFilePath sp
|
||||
createDirectoryIfMissing True $ takeDirectory fp
|
||||
now <- getCurrentTime
|
||||
writeFile fp $ show now
|
||||
|
||||
-- | Remove a special file
|
||||
removeSpecialFile :: SpecialFile -> IO ()
|
||||
removeSpecialFile sp = removeFile (specialFilePath sp) `Ex.catch` \e ->
|
||||
if isDoesNotExistError e
|
||||
then return ()
|
||||
else Ex.throwIO e
|
||||
|
||||
-- | Get an absolute path to the special file
|
||||
canonicalizeSpecialFile :: SpecialFile -> IO FilePath
|
||||
canonicalizeSpecialFile sp = do
|
||||
let fp = specialFilePath sp
|
||||
dir = takeDirectory fp
|
||||
file = takeFileName fp
|
||||
createDirectoryIfMissing True dir
|
||||
dir' <- canonicalizePath dir
|
||||
return $ dir' </> file
|
||||
|
||||
-- | Used as a callback from "stack build --exec" to write the signal file
|
||||
develSignal :: IO ()
|
||||
develSignal = writeSpecialFile SignalFile
|
||||
|
||||
-- | Options to be provided on the command line
|
||||
data DevelOpts = DevelOpts
|
||||
{ isCabalDev :: Bool
|
||||
, forceCabal :: Bool
|
||||
, verbose :: Bool
|
||||
, eventTimeout :: Int -- negative value for no timeout
|
||||
, successHook :: Maybe String
|
||||
, failHook :: Maybe String
|
||||
, buildDir :: Maybe String
|
||||
, develPort :: Int
|
||||
, develTlsPort :: Int
|
||||
, proxyTimeout :: Int
|
||||
{ verbose :: Bool
|
||||
, successHook :: Maybe String
|
||||
, develPort :: Int
|
||||
, develTlsPort :: Int
|
||||
, proxyTimeout :: Int
|
||||
, useReverseProxy :: Bool
|
||||
, terminateWith :: DevelTermOpt
|
||||
|
||||
-- Support for GHC_PACKAGE_PATH wrapping
|
||||
, develConfigOpts :: [String]
|
||||
, develEnv :: Maybe [(String, String)]
|
||||
} deriving (Show, Eq)
|
||||
|
||||
getBuildDir :: DevelOpts -> String
|
||||
getBuildDir opts = fromMaybe "dist" (buildDir opts)
|
||||
|
||||
defaultDevelOpts :: DevelOpts
|
||||
defaultDevelOpts = DevelOpts
|
||||
{ isCabalDev = False
|
||||
, forceCabal = False
|
||||
, verbose = False
|
||||
, eventTimeout = -1
|
||||
, successHook = Nothing
|
||||
, failHook = Nothing
|
||||
, buildDir = Nothing
|
||||
, develPort = 3000
|
||||
, develTlsPort = 3443
|
||||
, proxyTimeout = 10
|
||||
, useReverseProxy = True
|
||||
, terminateWith = TerminateOnEnter
|
||||
, develConfigOpts = []
|
||||
, develEnv = Nothing
|
||||
}
|
||||
|
||||
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 ()
|
||||
reverseProxy opts iappPort = do
|
||||
#if MIN_VERSION_http_client(0,4,7)
|
||||
manager <- newManager $ managerSetProxy noProxy conduitManagerSettings
|
||||
#else
|
||||
manager <- newManager conduitManagerSettings
|
||||
#endif
|
||||
let refreshHtml = LB.fromChunks $ return $(embedFile "refreshing.html")
|
||||
-- | Run a reverse proxy from the develPort and develTlsPort ports to
|
||||
-- the app running in appPortVar. If there is no response on the
|
||||
-- application port, give an appropriate message to the user.
|
||||
reverseProxy :: DevelOpts -> TVar Int -> IO ()
|
||||
reverseProxy opts appPortVar = do
|
||||
manager <- newManager $ managerSetProxy noProxy tlsManagerSettings
|
||||
let refreshHtml = LB.fromChunks [$(embedFile "refreshing.html")]
|
||||
let onExc _ req
|
||||
| maybe False (("application/json" `elem`) . parseHttpAccept)
|
||||
(lookup "accept" $ requestHeaders req) =
|
||||
@ -173,7 +134,7 @@ reverseProxy opts iappPort = do
|
||||
|
||||
let proxyApp = waiProxyToSettings
|
||||
(const $ do
|
||||
appPort <- liftIO $ I.readIORef iappPort
|
||||
appPort <- atomically $ readTVar appPortVar
|
||||
return $
|
||||
ReverseProxy.WPRProxyDest
|
||||
$ ProxyDest "127.0.0.1" appPort)
|
||||
@ -209,361 +170,226 @@ reverseProxy opts iappPort = do
|
||||
app req' send
|
||||
httpProxy = run (develPort opts) proxyApp
|
||||
httpsProxy = runProxyTls (develTlsPort opts) proxyApp
|
||||
putStrLn "Application can be accessed at:\n"
|
||||
putStrLn $ "http://localhost:" ++ show (develPort opts)
|
||||
putStrLn $ "https://localhost:" ++ show (develTlsPort opts)
|
||||
putStrLn $ "If you wish to test https capabilities, you should set the following variable:"
|
||||
putStrLn $ " export APPROOT=https://localhost:" ++ show (develTlsPort opts)
|
||||
putStrLn ""
|
||||
loop (race_ httpProxy httpsProxy) `Ex.catch` \e -> do
|
||||
print (e :: Ex.SomeException)
|
||||
_ <- exitFailure
|
||||
Ex.throwIO e -- heh, just for good measure
|
||||
where
|
||||
loop proxies = forever $ do
|
||||
void proxies
|
||||
putStrLn $ "Reverse proxy stopped, but it shouldn't"
|
||||
threadDelay 1000000
|
||||
putStrLn $ "Restarting reverse proxies"
|
||||
say "Application can be accessed at:\n"
|
||||
sayString $ "http://localhost:" ++ show (develPort opts)
|
||||
sayString $ "https://localhost:" ++ show (develTlsPort opts)
|
||||
say $ "If you wish to test https capabilities, you should set the following variable:"
|
||||
sayString $ " export APPROOT=https://localhost:" ++ show (develTlsPort opts)
|
||||
say ""
|
||||
race_ httpProxy httpsProxy
|
||||
|
||||
-- | Check if the given port is available.
|
||||
checkPort :: Int -> IO Bool
|
||||
checkPort p = do
|
||||
es <- Ex.try $ bindPortTCP p "*4"
|
||||
es <- Ex.tryIO $ bindPortTCP p "*4"
|
||||
case es of
|
||||
Left (_ :: Ex.IOException) -> return False
|
||||
Left _ -> return False
|
||||
Right s -> do
|
||||
sClose s
|
||||
Network.Socket.close s
|
||||
return True
|
||||
|
||||
getPort :: DevelOpts -> Int -> IO Int
|
||||
getPort opts _
|
||||
| not (useReverseProxy opts) = return $ develPort opts
|
||||
getPort _ p0 =
|
||||
loop p0
|
||||
where
|
||||
loop p = do
|
||||
avail <- checkPort p
|
||||
if avail then return p else loop (succ p)
|
||||
-- | Get a random, unused port.
|
||||
getNewPort :: DevelOpts -> IO Int
|
||||
getNewPort opts = do
|
||||
(port, socket) <- bindRandomPortTCP "*"
|
||||
when (verbose opts) $ sayString $ "Got new port: " ++ show port
|
||||
Network.Socket.close socket
|
||||
return port
|
||||
|
||||
-- | Utility function
|
||||
unlessM :: Monad m => m Bool -> m () -> m ()
|
||||
unlessM c a = c >>= \res -> unless res a
|
||||
|
||||
devel :: DevelOpts -> [String] -> IO ()
|
||||
devel opts passThroughArgs = withSocketsDo $ withManager $ \manager -> do
|
||||
unlessM (checkPort $ develPort opts) $ error "devel port unavailable"
|
||||
iappPort <- getPort opts 17834 >>= I.newIORef
|
||||
when (useReverseProxy opts) $ void $ forkIO $ reverseProxy opts iappPort
|
||||
develHsPath <- checkDevelFile
|
||||
writeLock opts
|
||||
|
||||
let (terminator, after) = case terminateWith opts of
|
||||
TerminateOnEnter ->
|
||||
("Type 'quit'", blockQuit)
|
||||
TerminateOnlyInterrupt -> -- run for one year
|
||||
("Interrupt", threadDelay $ 1000 * 1000 * 60 * 60 * 24 * 365)
|
||||
|
||||
blockQuit = do
|
||||
s <- getLine
|
||||
if s == "quit"
|
||||
then return ()
|
||||
else do
|
||||
putStrLn "Type 'quit' to quit"
|
||||
blockQuit
|
||||
|
||||
|
||||
putStrLn $ "Yesod devel server. " ++ terminator ++ " to quit"
|
||||
void $ forkIO $ do
|
||||
filesModified <- newEmptyMVar
|
||||
void $ forkIO $
|
||||
void $ watchTree manager "." (const True) (\_ -> void (tryPutMVar filesModified ()))
|
||||
evalStateT (mainOuterLoop develHsPath iappPort filesModified) Map.empty
|
||||
after
|
||||
writeLock opts
|
||||
exitSuccess
|
||||
where
|
||||
bd = getBuildDir opts
|
||||
|
||||
-- outer loop re-reads the cabal file
|
||||
mainOuterLoop develHsPath iappPort filesModified = do
|
||||
ghcVer <- liftIO ghcVersion
|
||||
#if MIN_VERSION_Cabal(1,20,0)
|
||||
cabal <- liftIO $ D.tryFindPackageDesc "."
|
||||
#else
|
||||
cabal <- liftIO $ D.findPackageDesc "."
|
||||
#endif
|
||||
gpd <- liftIO $ D.readPackageDescription D.normal cabal
|
||||
ldar <- liftIO lookupLdAr
|
||||
(hsSourceDirs, _) <- liftIO $ checkCabalFile gpd
|
||||
liftIO $ removeFileIfExists (bd </> "setup-config")
|
||||
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 develHsPath iappPort hsSourceDirs filesModified cabal rebuild
|
||||
else do
|
||||
liftIO (threadDelay 5000000)
|
||||
mainOuterLoop develHsPath iappPort filesModified
|
||||
|
||||
-- inner loop rebuilds after files change
|
||||
mainInnerLoop develHsPath iappPort hsSourceDirs filesModified cabal rebuild = go
|
||||
where
|
||||
go = do
|
||||
_ <- recompDeps hsSourceDirs
|
||||
list <- liftIO $ getFileList hsSourceDirs [cabal]
|
||||
success <- liftIO rebuild
|
||||
pkgArgs <- liftIO (ghcPackageArgs opts)
|
||||
let devArgs = pkgArgs ++ [develHsPath]
|
||||
let loop list0 = do
|
||||
(haskellFileChanged, list1) <- liftIO $
|
||||
watchForChanges filesModified hsSourceDirs [cabal] list0 (eventTimeout opts)
|
||||
anyTouched <- recompDeps hsSourceDirs
|
||||
unless (anyTouched || haskellFileChanged) $ loop list1
|
||||
if not success
|
||||
then liftIO $ do
|
||||
putStrLn "\x1b[1;31mBuild failure, pausing...\x1b[0m"
|
||||
runBuildHook $ failHook opts
|
||||
else do
|
||||
liftIO $ runBuildHook $ successHook opts
|
||||
liftIO $ removeLock opts
|
||||
liftIO $ putStrLn
|
||||
$ if verbose opts then "Starting development server: runghc " ++ L.unwords devArgs
|
||||
else "Starting development server..."
|
||||
env0 <- liftIO getEnvironment
|
||||
|
||||
-- get a new port for the new process to listen on
|
||||
appPort <- liftIO $ I.readIORef iappPort >>= getPort opts . (+ 1)
|
||||
liftIO $ I.writeIORef iappPort appPort
|
||||
|
||||
(_,_,_,ph) <- liftIO $ createProcess (proc "runghc" devArgs)
|
||||
{ env = Just $ Map.toList
|
||||
$ Map.insert "PORT" (show appPort)
|
||||
$ Map.insert "DISPLAY_PORT" (show $ develPort opts)
|
||||
$ Map.fromList env0
|
||||
}
|
||||
derefMap <- get
|
||||
watchTid <- liftIO . forkIO . try_ $ flip evalStateT derefMap $ do
|
||||
loop list
|
||||
liftIO $ do
|
||||
putStrLn "Stopping development server..."
|
||||
writeLock opts
|
||||
threadDelay 1000000
|
||||
putStrLn "Terminating development server..."
|
||||
terminateProcess ph
|
||||
ec <- liftIO $ waitForProcess' ph
|
||||
liftIO $ putStrLn $ "Exit code: " ++ show ec
|
||||
liftIO $ Ex.throwTo watchTid (userError "process finished")
|
||||
loop list
|
||||
n <- liftIO $ cabal `isNewerThan` (bd </> "setup-config")
|
||||
if n then mainOuterLoop develHsPath iappPort filesModified else go
|
||||
|
||||
runBuildHook :: Maybe String -> IO ()
|
||||
runBuildHook (Just s) = do
|
||||
ret <- system s
|
||||
case ret of
|
||||
ExitFailure _ -> putStrLn ("Error executing hook: " ++ s)
|
||||
_ -> return ()
|
||||
runBuildHook Nothing = return ()
|
||||
|
||||
{-
|
||||
run `cabal configure' with our wrappers
|
||||
-}
|
||||
configure :: DevelOpts -> [String] -> IO Bool
|
||||
configure opts extraArgs =
|
||||
checkExit =<< createProcess (proc (cabalProgram opts) $
|
||||
[ "configure"
|
||||
, "-flibrary-only"
|
||||
, "--disable-tests"
|
||||
, "--disable-benchmarks"
|
||||
, "-fdevel"
|
||||
, "--disable-library-profiling"
|
||||
, "--with-ld=yesod-ld-wrapper"
|
||||
, "--with-ghc=yesod-ghc-wrapper"
|
||||
, "--with-ar=yesod-ar-wrapper"
|
||||
, "--with-hc-pkg=ghc-pkg"
|
||||
] ++ develConfigOpts opts ++ extraArgs
|
||||
) { env = develEnv opts }
|
||||
|
||||
removeFileIfExists :: FilePath -> IO ()
|
||||
removeFileIfExists file = removeFile file `Ex.catch` handler
|
||||
where
|
||||
handler :: IOError -> IO ()
|
||||
handler e | isDoesNotExistError e = return ()
|
||||
| otherwise = Ex.throw e
|
||||
|
||||
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 yesod-bin"
|
||||
| forceCabal opts = return (rebuildCabal opts)
|
||||
| otherwise =
|
||||
return $ do
|
||||
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
|
||||
|
||||
|
||||
rebuildGhc :: [Located String] -> FilePath -> FilePath -> IO Bool
|
||||
rebuildGhc bf ld ar = do
|
||||
putStrLn "Rebuilding application... (using GHC API)"
|
||||
buildPackage bf ld ar
|
||||
|
||||
rebuildCabal :: DevelOpts -> IO Bool
|
||||
rebuildCabal opts = do
|
||||
putStrLn $ "Rebuilding application... (using " ++ cabalProgram opts ++ ")"
|
||||
checkExit =<< createProcess (proc (cabalProgram opts) args)
|
||||
{ env = develEnv opts
|
||||
}
|
||||
where
|
||||
args | verbose opts = [ "build" ]
|
||||
| otherwise = [ "build", "-v0" ]
|
||||
|
||||
try_ :: forall a. IO a -> IO ()
|
||||
try_ x = void (Ex.try x :: IO (Either Ex.SomeException a))
|
||||
|
||||
type FileList = Map.Map FilePath EpochTime
|
||||
|
||||
getFileList :: [FilePath] -> [FilePath] -> IO FileList
|
||||
getFileList hsSourceDirs extraFiles = do
|
||||
(files, deps) <- getDeps hsSourceDirs
|
||||
let files' = extraFiles ++ files ++ map fst (Map.toList deps)
|
||||
fmap Map.fromList $ forM files' $ \f -> do
|
||||
efs <- Ex.try $ getFileStatus f
|
||||
return $ case efs of
|
||||
Left (_ :: Ex.SomeException) -> (f, 0)
|
||||
Right fs -> (f, modificationTime fs)
|
||||
|
||||
-- | Returns @True@ if a .hs file changed.
|
||||
watchForChanges :: MVar () -> [FilePath] -> [FilePath] -> FileList -> Int -> IO (Bool, FileList)
|
||||
watchForChanges filesModified hsSourceDirs extraFiles list t = do
|
||||
newList <- getFileList hsSourceDirs extraFiles
|
||||
if list /= newList
|
||||
then do
|
||||
let haskellFileChanged = not $ Map.null $ Map.filterWithKey isHaskell $
|
||||
Map.differenceWith compareTimes newList list `Map.union`
|
||||
Map.differenceWith compareTimes list newList
|
||||
return (haskellFileChanged, newList)
|
||||
else timeout (1000000*t) (takeMVar filesModified) >>
|
||||
watchForChanges filesModified hsSourceDirs extraFiles list t
|
||||
where
|
||||
compareTimes x y
|
||||
| x == y = Nothing
|
||||
| otherwise = Just x
|
||||
|
||||
isHaskell filename _ = takeExtension filename `elem` [".hs", ".lhs", ".hsc", ".cabal"]
|
||||
|
||||
-- | Find the file containing the devel code to be run.
|
||||
checkDevelFile :: IO FilePath
|
||||
checkDevelFile =
|
||||
loop paths
|
||||
where
|
||||
paths = ["app/devel.hs", "devel.hs", "src/devel.hs"]
|
||||
|
||||
loop [] = failWith $ "file devel.hs not found, checked: " ++ show paths
|
||||
loop [] = error $ "file devel.hs not found, checked: " ++ show paths
|
||||
loop (x:xs) = do
|
||||
e <- doesFileExist x
|
||||
if e
|
||||
then return x
|
||||
else loop xs
|
||||
|
||||
checkCabalFile :: D.GenericPackageDescription -> IO ([FilePath], D.Library)
|
||||
checkCabalFile gpd = case D.condLibrary gpd of
|
||||
Nothing -> failWith "incorrect cabal file, no library"
|
||||
Just ct ->
|
||||
case lookupDevelLib gpd ct of
|
||||
Nothing ->
|
||||
failWith "no development flag found in your configuration file. Expected a 'library-only' flag or the older 'devel' flag"
|
||||
Just dLib -> do
|
||||
let hsSourceDirs = D.hsSourceDirs . D.libBuildInfo $ dLib
|
||||
fl <- getFileList hsSourceDirs []
|
||||
let unlisted = checkFileList fl dLib
|
||||
unless (null unlisted) $ do
|
||||
putStrLn "WARNING: the following source files are not listed in exposed-modules or other-modules:"
|
||||
mapM_ putStrLn unlisted
|
||||
when ("Application" `notElem` (map (last . D.components) $ D.exposedModules dLib)) $
|
||||
putStrLn "WARNING: no exposed module Application"
|
||||
return (hsSourceDirs, dLib)
|
||||
-- | This is the main entry point. Run the devel server.
|
||||
devel :: DevelOpts -- ^ command line options
|
||||
-> [String] -- ^ extra options to pass to Stack
|
||||
-> IO ()
|
||||
devel opts passThroughArgs = do
|
||||
-- Check that the listening ports are available
|
||||
unlessM (checkPort $ develPort opts) $ error "devel port unavailable"
|
||||
unlessM (checkPort $ develTlsPort opts) $ error "devel TLS port unavailable"
|
||||
|
||||
failWith :: String -> IO a
|
||||
failWith msg = do
|
||||
putStrLn $ "ERROR: " ++ msg
|
||||
exitFailure
|
||||
-- Friendly message to the user
|
||||
say "Yesod devel server. Enter 'quit' or hit Ctrl-C to quit."
|
||||
|
||||
checkFileList :: FileList -> D.Library -> [FilePath]
|
||||
checkFileList fl lib = filter (not . isSetup) . filter isUnlisted . filter isSrcFile $ sourceFiles
|
||||
-- Find out the name of our package, needed for the upcoming Stack
|
||||
-- commands
|
||||
cabal <- D.tryFindPackageDesc "."
|
||||
gpd <- D.readPackageDescription D.normal cabal
|
||||
let pd = D.packageDescription gpd
|
||||
D.PackageIdentifier (D.PackageName packageName) _version = D.package pd
|
||||
|
||||
-- Create a baton to indicate we're watching for file changes. We
|
||||
-- need to ensure that we install the file watcher before we start
|
||||
-- the Stack build loop.
|
||||
watchingBaton <- newEmptyMVar
|
||||
|
||||
-- Which file contains the code to run
|
||||
develHsPath <- checkDevelFile
|
||||
|
||||
-- The port that we're currently listening on, and that the
|
||||
-- reverse proxy should point to
|
||||
appPortVar <- newTVarIO (-1)
|
||||
|
||||
-- If we're actually using reverse proxying, spawn off a reverse
|
||||
-- proxy thread
|
||||
let withRevProxy =
|
||||
if useReverseProxy opts
|
||||
then race_ (reverseProxy opts appPortVar)
|
||||
else id
|
||||
|
||||
-- Run the following concurrently. If any of them exit, take the
|
||||
-- whole thing down.
|
||||
withRevProxy $ race_
|
||||
-- Wait until we're watching for file changes, then start the
|
||||
-- build loop
|
||||
(takeMVar watchingBaton >> runStackBuild packageName)
|
||||
|
||||
-- Run the app itself, restarting when a build succeeds
|
||||
(runApp appPortVar watchingBaton develHsPath)
|
||||
where
|
||||
al = allModules lib
|
||||
-- a file is only a possible 'module file' if all path pieces start with a capital letter
|
||||
sourceFiles = filter isSrcFile . map fst . Map.toList $ fl
|
||||
isSrcFile file = let dirs = filter (/=".") $ splitDirectories file
|
||||
in all (isUpper . head) dirs && (takeExtension file `elem` [".hs", ".lhs"])
|
||||
isUnlisted file = not (toModuleName file `Set.member` al)
|
||||
toModuleName = L.intercalate "." . filter (/=".") . splitDirectories . dropExtension
|
||||
-- say, but only when verbose is on
|
||||
sayV = when (verbose opts) . sayString
|
||||
|
||||
isSetup "Setup.hs" = True
|
||||
isSetup "./Setup.hs" = True
|
||||
isSetup "Setup.lhs" = True
|
||||
isSetup "./Setup.lhs" = True
|
||||
isSetup _ = False
|
||||
-- Leverage "stack build --file-watch" to do the build
|
||||
runStackBuild packageName = do
|
||||
-- We call into this app for the devel-signal command
|
||||
myPath <- getExecutablePath
|
||||
runProcess_ $
|
||||
setDelegateCtlc True $
|
||||
proc "stack" $
|
||||
[ "build"
|
||||
, "--fast"
|
||||
, "--file-watch"
|
||||
|
||||
allModules :: D.Library -> Set.Set String
|
||||
allModules lib = Set.fromList $ map toString $ D.exposedModules lib ++ (D.otherModules . D.libBuildInfo) lib
|
||||
where
|
||||
toString = L.intercalate "." . D.components
|
||||
-- Turn on various flags, and indicate the specific
|
||||
-- component we want
|
||||
, "--flag", packageName ++ ":dev"
|
||||
, "--flag", packageName ++ ":library-only"
|
||||
, packageName ++ ":lib"
|
||||
|
||||
ghcVersion :: IO String
|
||||
ghcVersion = fmap getNumber $ readProcess "runghc" ["--numeric-version", "0"] []
|
||||
where
|
||||
getNumber = filter (\x -> isNumber x || x == '.')
|
||||
-- signal the watcher that a build has succeeded
|
||||
, "--exec", myPath ++ " devel-signal"
|
||||
] ++
|
||||
-- Add the success hook
|
||||
(case successHook opts of
|
||||
Nothing -> []
|
||||
Just h -> ["--exec", h]) ++
|
||||
|
||||
ghcPackageArgs :: DevelOpts -> IO [String]
|
||||
ghcPackageArgs opts = getBuildFlags >>= getPackageArgs (buildDir opts)
|
||||
-- Any extra args passed on the command line
|
||||
passThroughArgs
|
||||
|
||||
lookupDevelLib :: D.GenericPackageDescription -> D.CondTree D.ConfVar c a -> Maybe a
|
||||
lookupDevelLib gpd ct | found = Just (D.condTreeData ct)
|
||||
| otherwise = Nothing
|
||||
where
|
||||
flags = map (unFlagName . D.flagName) $ D.genPackageFlags gpd
|
||||
unFlagName (D.FlagName x) = x
|
||||
found = any (`elem` ["library-only", "devel"]) flags
|
||||
-- Each time the library builds successfully, run the application
|
||||
runApp appPortVar watchingBaton develHsPath = do
|
||||
-- Get the absolute path of the signal file, needed for the
|
||||
-- file watching
|
||||
develSignalFile' <- canonicalizeSpecialFile SignalFile
|
||||
|
||||
-- location of `ld' and `ar' programs
|
||||
lookupLdAr :: IO (FilePath, FilePath)
|
||||
lookupLdAr = do
|
||||
mla <- lookupLdAr'
|
||||
case mla of
|
||||
Nothing -> failWith "Cannot determine location of `ar' or `ld' program"
|
||||
Just la -> return la
|
||||
-- Enable file watching
|
||||
withManager $ \manager -> do
|
||||
-- Variable indicating that the signal file has been
|
||||
-- changed. We reset it each time we handle the signal.
|
||||
changedVar <- newTVarIO False
|
||||
|
||||
lookupLdAr' :: IO (Maybe (FilePath, FilePath))
|
||||
lookupLdAr' = do
|
||||
#if MIN_VERSION_Cabal(1,18,0)
|
||||
(_, _, pgmc) <- D.configCompilerEx (Just D.GHC) Nothing Nothing D.defaultProgramConfiguration D.silent
|
||||
#else
|
||||
(_, pgmc) <- D.configCompiler (Just D.GHC) Nothing Nothing D.defaultProgramConfiguration D.silent
|
||||
#endif
|
||||
pgmc' <- D.configureAllKnownPrograms D.silent pgmc
|
||||
return $ (,) <$> look D.ldProgram pgmc' <*> look D.arProgram pgmc'
|
||||
where
|
||||
look pgm pdb = fmap D.programPath (D.lookupProgram pgm pdb)
|
||||
-- Start watching the signal file, and set changedVar to
|
||||
-- True each time it's changed.
|
||||
void $ watchDir manager
|
||||
(takeDirectory develSignalFile')
|
||||
(\e -> eventPath e == develSignalFile')
|
||||
(const $ atomically $ writeTVar changedVar True)
|
||||
|
||||
-- | nonblocking version of @waitForProcess@
|
||||
waitForProcess' :: ProcessHandle -> IO ExitCode
|
||||
waitForProcess' pid = go
|
||||
where
|
||||
go = do
|
||||
mec <- getProcessExitCode pid
|
||||
case mec of
|
||||
Just ec -> return ec
|
||||
Nothing -> threadDelay 100000 >> go
|
||||
-- Alright, watching is set up, let the build thread know
|
||||
-- it can get started.
|
||||
putMVar watchingBaton ()
|
||||
|
||||
-- | 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
|
||||
-- Wait for the first change, indicating that the library
|
||||
-- has been built
|
||||
atomically $ do
|
||||
changed <- readTVar changedVar
|
||||
check changed
|
||||
writeTVar changedVar False
|
||||
|
||||
sayV "First successful build complete, running app"
|
||||
|
||||
-- We're going to set the PORT and DISPLAY_PORT variables
|
||||
-- for the child below
|
||||
env <- fmap Map.fromList getEnvironment
|
||||
|
||||
-- Keep looping forever, print any synchronous exceptions,
|
||||
-- and eventually die from an async exception from one of
|
||||
-- the other threads (via race_ above).
|
||||
forever $ Ex.handleAny (\e -> sayErrString $ "Exception in runApp: " ++ show e) $ do
|
||||
-- Get the port the child should listen on, and tell
|
||||
-- the reverse proxy about it
|
||||
newPort <-
|
||||
if useReverseProxy opts
|
||||
then getNewPort opts
|
||||
-- no reverse proxy, so use the develPort directly
|
||||
else return (develPort opts)
|
||||
atomically $ writeTVar appPortVar newPort
|
||||
|
||||
-- Modified environment
|
||||
let env' = Map.toList
|
||||
$ Map.insert "PORT" (show newPort)
|
||||
$ Map.insert "DISPLAY_PORT" (show $ develPort opts)
|
||||
env
|
||||
|
||||
-- Remove the terminate file so we don't immediately exit
|
||||
removeSpecialFile TermFile
|
||||
|
||||
-- Launch the main function in the Main module defined
|
||||
-- in the file develHsPath. We use ghc instead of
|
||||
-- runghc to avoid the extra (confusing) resident
|
||||
-- runghc process. Starting with GHC 8.0.2, that will
|
||||
-- not be necessary.
|
||||
let procDef = setEnv env' $ proc "stack"
|
||||
[ "ghc"
|
||||
, "--"
|
||||
, develHsPath
|
||||
, "-e"
|
||||
, "Main.main"
|
||||
]
|
||||
|
||||
-- Start running the child process with GHC
|
||||
withProcess procDef $ \p -> do
|
||||
-- Wait for either the process to exit, or for a new build to come through
|
||||
eres <- atomically (fmap Left (waitExitCodeSTM p) <|> fmap Right
|
||||
(do changed <- readTVar changedVar
|
||||
check changed
|
||||
writeTVar changedVar False))
|
||||
-- on an async exception, make sure the child dies
|
||||
`Ex.onException` writeSpecialFile TermFile
|
||||
case eres of
|
||||
-- Child exited, which indicates some
|
||||
-- error. Let the user know, sleep for a bit
|
||||
-- to avoid busy-looping, and then we'll try
|
||||
-- again.
|
||||
Left ec -> do
|
||||
sayErrString $ "Unexpected: child process exited with " ++ show ec
|
||||
threadDelay 1000000
|
||||
sayErrString "Trying again"
|
||||
-- New build succeeded
|
||||
Right () -> do
|
||||
-- Kill the child process, both with the
|
||||
-- TermFile, and by signaling the process
|
||||
-- directly.
|
||||
writeSpecialFile TermFile
|
||||
stopProcess p
|
||||
|
||||
-- Wait until the child properly exits, then we'll try again
|
||||
ec <- waitExitCode p
|
||||
sayV $ "Expected: child process exited with " ++ show ec
|
||||
|
||||
@ -1,547 +0,0 @@
|
||||
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
|
||||
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
|
||||
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
|
||||
{-# OPTIONS_GHC -fno-warn-unused-matches #-}
|
||||
{-
|
||||
There is a lot of code copied from GHC here, and some conditional
|
||||
compilation. Instead of fixing all warnings and making it much more
|
||||
difficult to compare the code to the original, just ignore unused
|
||||
binds and imports.
|
||||
-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
{-
|
||||
build package with the GHC API
|
||||
-}
|
||||
|
||||
module GhcBuild (getBuildFlags, buildPackage, getPackageArgs) where
|
||||
|
||||
import qualified Control.Exception as Ex
|
||||
import Control.Monad (when)
|
||||
import Data.IORef
|
||||
import System.Process (rawSystem)
|
||||
import System.Environment (getEnvironment)
|
||||
|
||||
import CmdLineParser
|
||||
import Data.Char (toLower)
|
||||
import Data.List (isPrefixOf, isSuffixOf, partition)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import DriverPhases (Phase (..), anyHsc, isHaskellSrcFilename,
|
||||
isSourceFilename, startPhase)
|
||||
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 (throwGhcException, panic)
|
||||
import SrcLoc (Located, mkGeneralLocated)
|
||||
import qualified StaticFlags
|
||||
#if __GLASGOW_HASKELL__ >= 707
|
||||
import DynFlags (ldInputs)
|
||||
#else
|
||||
import StaticFlags (v_Ld_inputs)
|
||||
#endif
|
||||
import System.FilePath (normalise, (</>))
|
||||
import Util (consIORef, looksLikeModuleName)
|
||||
|
||||
{-
|
||||
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 "yesod-devel/ghcargs.txt" -- generated by yesod-ghc-wrapper
|
||||
argv0' <- prependHsenvArgv argv0
|
||||
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
|
||||
writeIORef StaticFlags.v_opt_C_ready False -- the huge hack
|
||||
(argv2, staticFlagWarnings) <- GHC.parseStaticFlags argv1'
|
||||
return argv2
|
||||
|
||||
prependHsenvArgv :: [String] -> IO [String]
|
||||
prependHsenvArgv argv = do
|
||||
env <- getEnvironment
|
||||
return $ case (lookup "HSENV" env) of
|
||||
Nothing -> argv
|
||||
_ -> hsenvArgv ++ argv
|
||||
where hsenvArgv = words $ fromMaybe "" (lookup "PACKAGE_DB_FOR_GHC" env)
|
||||
|
||||
-- construct a command line for loading the right packages
|
||||
getPackageArgs :: Maybe String -> [Located String] -> IO [String]
|
||||
getPackageArgs buildDir 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)
|
||||
ignorePkgFlags =
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
map convertIgnorePkgFlag (GHC.ignorePackageFlags dflags1)
|
||||
#else
|
||||
[]
|
||||
#endif
|
||||
trustPkgFlags =
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
map convertTrustPkgFlag (GHC.trustFlags dflags1)
|
||||
#else
|
||||
[]
|
||||
#endif
|
||||
hideAll | gopt DF.Opt_HideAllPackages dflags1 = [ "-hide-all-packages"]
|
||||
| otherwise = []
|
||||
ownPkg = packageString (DF.thisPackage dflags1)
|
||||
return (reverse (extra dflags1) ++ hideAll ++ trustPkgFlags ++ ignorePkgFlags ++ pkgFlags ++ ownPkg)
|
||||
where
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
convertIgnorePkgFlag (DF.IgnorePackage p) = "-ignore-package" ++ p
|
||||
convertTrustPkgFlag (DF.TrustPackage p) = "-trust" ++ p
|
||||
convertTrustPkgFlag (DF.DistrustPackage p) = "-distrust" ++ p
|
||||
#else
|
||||
convertPkgFlag (DF.IgnorePackage p) = "-ignore-package" ++ p
|
||||
convertPkgFlag (DF.TrustPackage p) = "-trust" ++ p
|
||||
convertPkgFlag (DF.DistrustPackage p) = "-distrust" ++ p
|
||||
#endif
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
convertPkgFlag (DF.ExposePackage _ (DF.PackageArg p) _) = "-package" ++ p
|
||||
convertPkgFlag (DF.ExposePackage _ (DF.UnitIdArg p) _) = "-package-id" ++ p
|
||||
#elif __GLASGOW_HASKELL__ == 710
|
||||
convertPkgFlag (DF.ExposePackage (DF.PackageArg p) _) = "-package" ++ p
|
||||
convertPkgFlag (DF.ExposePackage (DF.PackageIdArg p) _) = "-package-id" ++ p
|
||||
convertPkgFlag (DF.ExposePackage (DF.PackageKeyArg p) _) = "-package-key" ++ p
|
||||
#else
|
||||
convertPkgFlag (DF.ExposePackage p) = "-package" ++ p
|
||||
convertPkgFlag (DF.ExposePackageId p) = "-package-id" ++ p
|
||||
#endif
|
||||
convertPkgFlag (DF.HidePackage p) = "-hide-package" ++ p
|
||||
#if __GLASGOW_HASKELL__ >= 800
|
||||
-- See: https://github.com/yesodweb/yesod/issues/1284
|
||||
packageString _flags = []
|
||||
--packageString flags = "-package-id" ++ Module.unitIdString flags
|
||||
#elif __GLASGOW_HASKELL__ == 710
|
||||
packageString flags = ["-package-key" ++ Module.packageKeyString flags]
|
||||
#else
|
||||
packageString flags = ["-package-id" ++ Module.packageIdString flags ++ "-inplace"]
|
||||
#endif
|
||||
#if __GLASGOW_HASKELL__ >= 705
|
||||
extra df = inplaceConf ++ extra'
|
||||
where
|
||||
extra' = concatMap convertExtra (extraConfs df)
|
||||
-- old cabal-install sometimes misses the .inplace db, fix it here
|
||||
inplaceConf
|
||||
| any (".inplace" `isSuffixOf`) extra' = []
|
||||
| otherwise = ["-package-db" ++ fromMaybe "dist" buildDir
|
||||
++ "/package.conf.inplace"]
|
||||
extraConfs df = GHC.extraPkgConfs df []
|
||||
convertExtra DF.GlobalPkgConf = [ ]
|
||||
convertExtra DF.UserPkgConf = [ ]
|
||||
convertExtra (DF.PkgConfFile file) = [ "-package-db" ++ file ]
|
||||
#else
|
||||
extra df = inplaceConf ++ extra'
|
||||
where
|
||||
extra' = map ("-package-conf"++) (GHC.extraPkgConfs df)
|
||||
-- old cabal-install sometimes misses the .inplace db, fix it here
|
||||
inplaceConf
|
||||
| any (".inplace" `isSuffixOf`) extra' = []
|
||||
| otherwise = ["-package-conf" ++ fromMaybe "dist" buildDir
|
||||
++ "/package.conf.inplace"]
|
||||
#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))
|
||||
return False
|
||||
|
||||
buildPackage' :: [Located String] -> FilePath -> FilePath -> IO Bool
|
||||
buildPackage' argv2 ld ar = 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) =
|
||||
#if MIN_VERSION_ghc(8,0,0)
|
||||
phase `notElem` [As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm, StopLn]
|
||||
#elif MIN_VERSION_ghc(7,8,3)
|
||||
phase `notElem` [As True, As False, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn]
|
||||
#elif MIN_VERSION_ghc(7,4,0)
|
||||
phase `notElem` [As, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn]
|
||||
#else
|
||||
phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn]
|
||||
#endif
|
||||
hsc_env <- GHC.getSession
|
||||
-- if (null hs_srcs)
|
||||
-- then liftIO (oneShot hsc_env StopLn srcs)
|
||||
-- else do
|
||||
#if MIN_VERSION_ghc(7,2,0)
|
||||
o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)
|
||||
#else
|
||||
o_files <- mapM (\x -> compileFile hsc_env StopLn x)
|
||||
#endif
|
||||
non_hs_srcs
|
||||
#if __GLASGOW_HASKELL__ >= 707
|
||||
let dflags4 = dflags3
|
||||
{ ldInputs = map (DF.FileOption "") (reverse o_files)
|
||||
++ ldInputs dflags3
|
||||
}
|
||||
GHC.setSessionDynFlags dflags4
|
||||
#else
|
||||
liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files)
|
||||
#endif
|
||||
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 ld ar) >> return True
|
||||
|
||||
linkPkg :: FilePath -> FilePath -> IO ()
|
||||
linkPkg ld ar = do
|
||||
arargs <- fmap read $ readFile "yesod-devel/arargs.txt"
|
||||
rawSystem ar arargs
|
||||
ldargs <- fmap read $ readFile "yesod-devel/ldargs.txt"
|
||||
rawSystem ld ldargs
|
||||
return ()
|
||||
|
||||
--------------------------------------------------------------------------------------------
|
||||
-- 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
|
||||
#if __GLASGOW_HASKELL__ >= 710
|
||||
errorsToGhcException' = errorsToGhcException . map (\(GHC.L _ e) -> ("on the commandline", e))
|
||||
#else
|
||||
errorsToGhcException' = errorsToGhcException
|
||||
#endif
|
||||
|
||||
when (not (null errs)) $ throwGhcException $ 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 ----------------------------------------------
|
||||
mkFlag "?" (PassFlag (setMode showGhcUsageMode))
|
||||
, mkFlag "-help" (PassFlag (setMode showGhcUsageMode))
|
||||
, mkFlag "V" (PassFlag (setMode showVersionMode))
|
||||
, mkFlag "-version" (PassFlag (setMode showVersionMode))
|
||||
, mkFlag "-numeric-version" (PassFlag (setMode showNumVersionMode))
|
||||
, mkFlag "-info" (PassFlag (setMode showInfoMode))
|
||||
, mkFlag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode))
|
||||
, mkFlag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))
|
||||
] ++
|
||||
[ mkFlag 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 ----------------------------------------------------
|
||||
[ mkFlag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f)
|
||||
"--show-iface"))
|
||||
|
||||
------- primary modes ------------------------------------------------
|
||||
, mkFlag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f
|
||||
addFlag "-no-link" f))
|
||||
, mkFlag "M" (PassFlag (setMode doMkDependHSMode))
|
||||
, mkFlag "E" (PassFlag (setMode (stopBeforeMode anyHsc)))
|
||||
, mkFlag "C" (PassFlag (\f -> do setMode (stopBeforeMode HCc) f
|
||||
addFlag "-fvia-C" f))
|
||||
#if MIN_VERSION_ghc(7,8,3)
|
||||
, mkFlag "S" (PassFlag (setMode (stopBeforeMode (As True))))
|
||||
#else
|
||||
, mkFlag "S" (PassFlag (setMode (stopBeforeMode As)))
|
||||
#endif
|
||||
, mkFlag "-make" (PassFlag (setMode doMakeMode))
|
||||
, mkFlag "-interactive" (PassFlag (setMode doInteractiveMode))
|
||||
, mkFlag "-abi-hash" (PassFlag (setMode doAbiHashMode))
|
||||
, mkFlag "e" (SepArg (\s -> setMode (doEvalMode s) "-e"))
|
||||
]
|
||||
#if MIN_VERSION_ghc(7,10,1)
|
||||
where mkFlag fName fOptKind = Flag fName fOptKind AllModes
|
||||
#else
|
||||
where mkFlag fName fOptKind = Flag fName fOptKind
|
||||
#endif
|
||||
|
||||
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))
|
||||
#if MIN_VERSION_ghc(7,2,0)
|
||||
$ lookup k (compilerInfo dflags)
|
||||
#else
|
||||
$ fmap convertPrintable (lookup k compilerInfo)
|
||||
where
|
||||
convertPrintable (DynFlags.String s) = s
|
||||
convertPrintable (DynFlags.FromDynFlags f) = f dflags
|
||||
#endif
|
||||
|
||||
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
|
||||
@ -1,65 +0,0 @@
|
||||
{-
|
||||
wrapper executable that captures arguments to ghc, ar or ld
|
||||
-}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Main where
|
||||
|
||||
import Control.Monad (when)
|
||||
import Data.Maybe (fromMaybe)
|
||||
|
||||
import Distribution.Compiler (CompilerFlavor (..))
|
||||
import qualified Distribution.Simple.Configure as D
|
||||
import Distribution.Simple.Program (arProgram,
|
||||
defaultProgramConfiguration,
|
||||
ghcProgram, ldProgram,
|
||||
programPath)
|
||||
import Distribution.Simple.Program.Db (configureAllKnownPrograms,
|
||||
lookupProgram)
|
||||
import Distribution.Simple.Program.Types (Program (..))
|
||||
import Distribution.Verbosity (silent)
|
||||
|
||||
import System.Directory (doesDirectoryExist)
|
||||
import System.Environment (getArgs)
|
||||
import System.Exit (ExitCode (..), exitWith)
|
||||
import System.IO (hPutStrLn, stderr)
|
||||
import System.Process (rawSystem, readProcess)
|
||||
|
||||
|
||||
#ifdef LDCMD
|
||||
cmd :: Program
|
||||
cmd = ldProgram
|
||||
outFile = "yesod-devel/ldargs.txt"
|
||||
#else
|
||||
#ifdef ARCMD
|
||||
cmd :: Program
|
||||
cmd = arProgram
|
||||
outFile ="yesod-devel/arargs.txt"
|
||||
#else
|
||||
cmd :: Program
|
||||
cmd = ghcProgram
|
||||
outFile = "yesod-devel/ghcargs.txt"
|
||||
#endif
|
||||
#endif
|
||||
|
||||
runProgram :: Program -> [String] -> IO ExitCode
|
||||
runProgram pgm args = do
|
||||
#if MIN_VERSION_Cabal(1,18,0)
|
||||
(_, comp, pgmc) <- D.configCompilerEx (Just GHC) Nothing Nothing defaultProgramConfiguration silent
|
||||
#else
|
||||
(comp, pgmc) <- D.configCompiler (Just GHC) Nothing Nothing defaultProgramConfiguration silent
|
||||
#endif
|
||||
pgmc' <- configureAllKnownPrograms silent pgmc
|
||||
case lookupProgram pgm pgmc' of
|
||||
Nothing -> do
|
||||
hPutStrLn stderr ("cannot find program '" ++ programName pgm ++ "'")
|
||||
return (ExitFailure 1)
|
||||
Just p -> rawSystem (programPath p) args
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
args <- getArgs
|
||||
e <- doesDirectoryExist "yesod-devel"
|
||||
when e $ writeFile outFile (show args ++ "\n")
|
||||
ex <- runProgram cmd args
|
||||
exitWith ex
|
||||
@ -1,5 +1,6 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Main (main) where
|
||||
|
||||
import Control.Monad (unless)
|
||||
import Data.Monoid
|
||||
@ -7,11 +8,10 @@ import Data.Version (showVersion)
|
||||
import Options.Applicative
|
||||
import System.Environment (getEnvironment)
|
||||
import System.Exit (ExitCode (ExitSuccess), exitWith, exitFailure)
|
||||
import System.FilePath (splitSearchPath)
|
||||
import System.Process (rawSystem)
|
||||
|
||||
import AddHandler (addHandler)
|
||||
import Devel (DevelOpts (..), devel, DevelTermOpt(..))
|
||||
import Devel (DevelOpts (..), devel, develSignal)
|
||||
import Keter (keter)
|
||||
import Options (injectDefaults)
|
||||
import qualified Paths_yesod_bin
|
||||
@ -48,19 +48,14 @@ data Command = Init [String]
|
||||
| Configure
|
||||
| Build { buildExtraArgs :: [String] }
|
||||
| Touch
|
||||
| Devel { _develDisableApi :: Bool
|
||||
, _develSuccessHook :: Maybe String
|
||||
, _develFailHook :: Maybe String
|
||||
, _develRescan :: Int
|
||||
, _develBuildDir :: Maybe String
|
||||
, develIgnore :: [String]
|
||||
| Devel { develSuccessHook :: Maybe String
|
||||
, develExtraArgs :: [String]
|
||||
, _develPort :: Int
|
||||
, _develTlsPort :: Int
|
||||
, _proxyTimeout :: Int
|
||||
, _noReverseProxy :: Bool
|
||||
, _interruptOnly :: Bool
|
||||
, develPort :: Int
|
||||
, develTlsPort :: Int
|
||||
, proxyTimeout :: Int
|
||||
, noReverseProxy :: Bool
|
||||
}
|
||||
| DevelSignal
|
||||
| Test
|
||||
| AddHandler
|
||||
{ addHandlerRoute :: Maybe String
|
||||
@ -89,11 +84,6 @@ main = do
|
||||
d@Devel{} -> d { develExtraArgs = args }
|
||||
c -> c
|
||||
})
|
||||
, ("yesod.devel.ignore" , \o args -> o { optCommand =
|
||||
case optCommand o of
|
||||
d@Devel{} -> d { develIgnore = args }
|
||||
c -> c
|
||||
})
|
||||
, ("yesod.build.extracabalarg" , \o args -> o { optCommand =
|
||||
case optCommand o of
|
||||
b@Build{} -> b { buildExtraArgs = args }
|
||||
@ -111,25 +101,15 @@ main = do
|
||||
Version -> putStrLn ("yesod-bin version: " ++ showVersion Paths_yesod_bin.version)
|
||||
AddHandler{..} -> addHandler addHandlerRoute addHandlerPattern addHandlerMethods
|
||||
Test -> cabalTest cabal
|
||||
Devel{..} ->do
|
||||
(configOpts, menv) <- handleGhcPackagePath
|
||||
let develOpts = DevelOpts
|
||||
{ isCabalDev = optCabalPgm o == CabalDev
|
||||
, forceCabal = _develDisableApi
|
||||
, verbose = optVerbose o
|
||||
, eventTimeout = _develRescan
|
||||
, successHook = _develSuccessHook
|
||||
, failHook = _develFailHook
|
||||
, buildDir = _develBuildDir
|
||||
, develPort = _develPort
|
||||
, develTlsPort = _develTlsPort
|
||||
, proxyTimeout = _proxyTimeout
|
||||
, useReverseProxy = not _noReverseProxy
|
||||
, terminateWith = if _interruptOnly then TerminateOnlyInterrupt else TerminateOnEnter
|
||||
, develConfigOpts = configOpts
|
||||
, develEnv = menv
|
||||
}
|
||||
devel develOpts develExtraArgs
|
||||
Devel{..} -> devel DevelOpts
|
||||
{ verbose = optVerbose o
|
||||
, successHook = develSuccessHook
|
||||
, develPort = develPort
|
||||
, develTlsPort = develTlsPort
|
||||
, proxyTimeout = proxyTimeout
|
||||
, useReverseProxy = not noReverseProxy
|
||||
} develExtraArgs
|
||||
DevelSignal -> develSignal
|
||||
where
|
||||
cabalTest cabal = do
|
||||
env <- getEnvironment
|
||||
@ -154,19 +134,6 @@ main = do
|
||||
]
|
||||
exitFailure
|
||||
|
||||
|
||||
handleGhcPackagePath :: IO ([String], Maybe [(String, String)])
|
||||
handleGhcPackagePath = do
|
||||
env <- getEnvironment
|
||||
case lookup "GHC_PACKAGE_PATH" env of
|
||||
Nothing -> return ([], Nothing)
|
||||
Just gpp -> do
|
||||
let opts = "--package-db=clear"
|
||||
: "--package-db=global"
|
||||
: map ("--package-db=" ++)
|
||||
(drop 1 $ reverse $ splitSearchPath gpp)
|
||||
return (opts, Just $ filter (\(x, _) -> x /= "GHC_PACKAGE_PATH") env)
|
||||
|
||||
optParser' :: ParserInfo Options
|
||||
optParser' = info (helper <*> optParser) ( fullDesc <> header "Yesod Web Framework command line utility" )
|
||||
|
||||
@ -186,6 +153,8 @@ optParser = Options
|
||||
(progDesc $ "Touch any files with altered TH dependencies but do not build" ++ windowsWarning))
|
||||
<> command "devel" (info (helper <*> develOptions)
|
||||
(progDesc "Run project with the devel server"))
|
||||
<> command "devel-signal" (info (helper <*> pure DevelSignal)
|
||||
(progDesc "Used internally by the devel command"))
|
||||
<> command "test" (info (pure Test)
|
||||
(progDesc "Build and run the integration tests"))
|
||||
<> command "add-handler" (info (helper <*> addHandlerOptions)
|
||||
@ -208,25 +177,9 @@ keterOptions = Keter
|
||||
where
|
||||
optStrToList m = option (words <$> str) $ value [] <> m
|
||||
|
||||
defaultRescan :: Int
|
||||
defaultRescan = 10
|
||||
|
||||
develOptions :: Parser Command
|
||||
develOptions = Devel <$> switch ( long "disable-api" <> short 'd'
|
||||
<> help "Disable fast GHC API rebuilding")
|
||||
<*> optStr ( long "success-hook" <> short 's' <> metavar "COMMAND"
|
||||
develOptions = Devel <$> optStr ( long "success-hook" <> short 's' <> metavar "COMMAND"
|
||||
<> help "Run COMMAND after rebuild succeeds")
|
||||
<*> optStr ( long "failure-hook" <> short 'f' <> metavar "COMMAND"
|
||||
<> help "Run COMMAND when rebuild fails")
|
||||
<*> option auto ( long "event-timeout" <> short 't' <> value defaultRescan <> metavar "N"
|
||||
<> help ("Force rescan of files every N seconds (default "
|
||||
++ show defaultRescan
|
||||
++ ", use -1 to rely on FSNotify alone)") )
|
||||
<*> optStr ( long "builddir" <> short 'b'
|
||||
<> help "Set custom cabal build directory, default `dist'")
|
||||
<*> many ( strOption ( long "ignore" <> short 'i' <> metavar "DIR"
|
||||
<> help "ignore file changes in DIR" )
|
||||
)
|
||||
<*> extraCabalArgs
|
||||
<*> option auto ( long "port" <> short 'p' <> value 3000 <> metavar "N"
|
||||
<> help "Devel server listening port" )
|
||||
@ -236,8 +189,6 @@ develOptions = Devel <$> switch ( long "disable-api" <> short 'd'
|
||||
<> help "Devel server timeout before returning 'not ready' message (in seconds, 0 for none)" )
|
||||
<*> switch ( long "disable-reverse-proxy" <> short 'n'
|
||||
<> help "Disable reverse proxy" )
|
||||
<*> switch ( long "interrupt-only" <> short 'c'
|
||||
<> help "Disable exiting when enter is pressed")
|
||||
|
||||
extraCabalArgs :: Parser [String]
|
||||
extraCabalArgs = many (strOption ( long "extra-cabal-arg" <> short 'e' <> metavar "ARG"
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-bin
|
||||
version: 1.4.18.7
|
||||
version: 1.5.0
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -17,26 +17,6 @@ extra-source-files:
|
||||
ChangeLog.md
|
||||
*.pem
|
||||
|
||||
executable yesod-ghc-wrapper
|
||||
main-is: ghcwrapper.hs
|
||||
build-depends:
|
||||
base >= 4 && < 5
|
||||
, Cabal
|
||||
|
||||
executable yesod-ld-wrapper
|
||||
main-is: ghcwrapper.hs
|
||||
cpp-options: -DLDCMD
|
||||
build-depends:
|
||||
base >= 4 && < 5
|
||||
, Cabal
|
||||
|
||||
executable yesod-ar-wrapper
|
||||
main-is: ghcwrapper.hs
|
||||
cpp-options: -DARCMD
|
||||
build-depends:
|
||||
base >= 4 && < 5
|
||||
, Cabal
|
||||
|
||||
executable yesod
|
||||
if os(windows)
|
||||
cpp-options: -DWINDOWS
|
||||
@ -44,8 +24,6 @@ executable yesod
|
||||
ld-options: -Wl,-zwxneeded
|
||||
|
||||
build-depends: base >= 4.3 && < 5
|
||||
, ghc >= 7.0.3
|
||||
, ghc-paths >= 0.1
|
||||
, parsec >= 2.1 && < 4
|
||||
, text >= 0.11
|
||||
, shakespeare >= 2.0
|
||||
@ -53,7 +31,7 @@ executable yesod
|
||||
, time >= 1.1.4
|
||||
, template-haskell
|
||||
, directory >= 1.2.1
|
||||
, Cabal
|
||||
, Cabal >= 1.20
|
||||
, unix-compat >= 0.2 && < 0.5
|
||||
, containers >= 0.2
|
||||
, attoparsec >= 0.10
|
||||
@ -75,10 +53,13 @@ executable yesod
|
||||
, base64-bytestring
|
||||
, lifted-base
|
||||
, http-reverse-proxy >= 0.4
|
||||
, network
|
||||
, http-conduit >= 2.1.4
|
||||
, http-client
|
||||
, network >= 2.5
|
||||
, http-client-tls
|
||||
, http-client >= 0.4.7
|
||||
, project-template >= 0.1.1
|
||||
, safe-exceptions
|
||||
, say
|
||||
, stm
|
||||
, transformers
|
||||
, transformers-compat
|
||||
, warp >= 1.3.7.5
|
||||
@ -89,12 +70,12 @@ executable yesod
|
||||
, warp-tls >= 3.0.1
|
||||
, async
|
||||
, deepseq
|
||||
, typed-process
|
||||
|
||||
ghc-options: -Wall -threaded -rtsopts
|
||||
main-is: main.hs
|
||||
other-modules: Devel
|
||||
Build
|
||||
GhcBuild
|
||||
Keter
|
||||
AddHandler
|
||||
Paths_yesod_bin
|
||||
|
||||
Loading…
Reference in New Issue
Block a user