Merge remote-tracking branch 'origin/master' into HEAD
This commit is contained in:
Michael Snoyman
commit
4d7355cf33
104
yesod/Build.hs
104
yesod/Build.hs
@ -1,46 +1,50 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Build
|
||||
( getDeps
|
||||
, touchDeps
|
||||
, touch
|
||||
, recompDeps
|
||||
, findHaskellFiles
|
||||
) where
|
||||
|
||||
-- FIXME there's a bug when getFileStatus applies to a file
|
||||
-- temporary deleted (e.g., Vim saving a file)
|
||||
|
||||
import Control.Applicative ((<|>), many)
|
||||
import Control.Exception (SomeException, try)
|
||||
import Control.Monad (when, filterM, forM, forM_)
|
||||
|
||||
import qualified Data.Attoparsec.Text.Lazy as A
|
||||
import Data.Char (isSpace)
|
||||
import Data.Char (isSpace, isUpper)
|
||||
import qualified Data.Text.Lazy.IO as TIO
|
||||
|
||||
import Control.Exception (SomeException, try)
|
||||
import Control.Monad (when, filterM, forM, forM_, (>=>))
|
||||
|
||||
import Data.Monoid (mappend)
|
||||
import Data.List (isSuffixOf)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text.Lazy.IO as TIO
|
||||
|
||||
import qualified System.Posix.Types
|
||||
import System.Directory
|
||||
import System.FilePath (replaceExtension, (</>))
|
||||
import System.FilePath (takeExtension, replaceExtension, (</>))
|
||||
import System.PosixCompat.Files (getFileStatus, setFileTimes,
|
||||
accessTime, modificationTime)
|
||||
|
||||
touch :: IO ()
|
||||
touch = touchDeps id updateFileTime =<< getDeps
|
||||
|
||||
recompDeps :: IO ()
|
||||
recompDeps = touchDeps hiFile removeHi =<< getDeps
|
||||
touch :: IO ()
|
||||
touch = touchDeps id updateFileTime =<< fmap snd (getDeps [])
|
||||
|
||||
recompDeps :: [FilePath] -> IO ()
|
||||
recompDeps = getDeps >=> touchDeps hiFile removeHi . snd
|
||||
|
||||
type Deps = Map.Map FilePath (Set.Set FilePath)
|
||||
|
||||
getDeps :: IO Deps
|
||||
getDeps = do
|
||||
hss <- findHaskellFiles "."
|
||||
deps' <- mapM determineHamletDeps hss
|
||||
return $ fixDeps $ zip hss deps'
|
||||
getDeps :: [FilePath] -> IO ([FilePath], Deps)
|
||||
getDeps hsSourceDirs = do
|
||||
let defSrcDirs = case hsSourceDirs of
|
||||
[] -> ["."]
|
||||
ds -> ds
|
||||
hss <- fmap concat $ mapM findHaskellFiles defSrcDirs
|
||||
deps' <- mapM determineDeps hss
|
||||
return $ (hss, fixDeps $ zip hss deps')
|
||||
|
||||
touchDeps :: (FilePath -> FilePath) ->
|
||||
(FilePath -> FilePath -> IO ()) ->
|
||||
@ -103,42 +107,52 @@ findHaskellFiles path = do
|
||||
fmap concat $ mapM go contents
|
||||
where
|
||||
go ('.':_) = return []
|
||||
go ('c':"abal-dev") = return []
|
||||
go ('d':"ist") = return []
|
||||
go x = do
|
||||
let y = path </> x
|
||||
d <- doesDirectoryExist y
|
||||
if d
|
||||
then findHaskellFiles y
|
||||
else if ".hs" `isSuffixOf` x || ".lhs" `isSuffixOf` x
|
||||
then return [y]
|
||||
else return []
|
||||
go filename = do
|
||||
d <- doesDirectoryExist full
|
||||
if not d
|
||||
then if isHaskellFile
|
||||
then return [full]
|
||||
else return []
|
||||
else if isHaskellDir
|
||||
then findHaskellFiles full
|
||||
else return []
|
||||
where
|
||||
-- this could fail on unicode
|
||||
isHaskellDir = isUpper (head filename)
|
||||
isHaskellFile = takeExtension filename `elem` watch_files
|
||||
full = path </> filename
|
||||
watch_files = [".hs", ".lhs"]
|
||||
|
||||
data TempType = Hamlet | Verbatim | Messages FilePath | StaticFiles FilePath
|
||||
data TempType = StaticFiles FilePath
|
||||
| Verbatim | Messages FilePath | Hamlet
|
||||
deriving Show
|
||||
|
||||
determineHamletDeps :: FilePath -> IO [FilePath]
|
||||
determineHamletDeps x = do
|
||||
determineDeps :: FilePath -> IO [FilePath]
|
||||
determineDeps x = do
|
||||
y <- TIO.readFile x -- FIXME catch IO exceptions
|
||||
let z = A.parse (many $ (parser <|> (A.anyChar >> return Nothing))) y
|
||||
case z of
|
||||
A.Fail{} -> return []
|
||||
A.Done _ r -> mapM go r >>= filterM doesFileExist . concat
|
||||
where
|
||||
go (Just (StaticFiles fp, _)) = getFolderContents fp
|
||||
go (Just (Hamlet, f)) = return [f, "templates/" ++ f ++ ".hamlet"]
|
||||
go (Just (Verbatim, f)) = return [f]
|
||||
go (Just (Messages f, _)) = return [f]
|
||||
go (Just (StaticFiles fp, _)) = getFolderContents fp
|
||||
go Nothing = return []
|
||||
|
||||
parser = do
|
||||
ty <- (A.string "$(hamletFile " >> return Hamlet)
|
||||
ty <- (do _ <- A.string "\nstaticFiles \""
|
||||
x' <- A.many1 $ A.satisfy (/= '"')
|
||||
return $ StaticFiles x')
|
||||
<|> (A.string "$(parseRoutesFile " >> return Verbatim)
|
||||
<|> (A.string "$(hamletFile " >> return Hamlet)
|
||||
<|> (A.string "$(ihamletFile " >> return Hamlet)
|
||||
<|> (A.string "$(whamletFile " >> return Hamlet)
|
||||
<|> (A.string "$(html " >> return Hamlet)
|
||||
<|> (A.string "$(widgetFile " >> return Hamlet)
|
||||
<|> (A.string "$(Settings.hamletFile " >> return Hamlet)
|
||||
<|> (A.string "$(Settings.widgetFile " >> return Hamlet)
|
||||
<|> (A.string "$(parseRoutesFile " >> return Verbatim)
|
||||
<|> (A.string "$(persistFile " >> return Verbatim)
|
||||
<|> (
|
||||
A.string "$(persistFileWith " >>
|
||||
@ -153,10 +167,6 @@ determineHamletDeps x = do
|
||||
y <- A.many1 $ A.satisfy (/= '"')
|
||||
_ <- A.string "\""
|
||||
return $ Messages $ concat [x', "/", y, ".msg"])
|
||||
<|> (do
|
||||
_ <- A.string "\nstaticFiles \""
|
||||
x' <- A.many1 $ A.satisfy (/= '"')
|
||||
return $ StaticFiles x')
|
||||
case ty of
|
||||
Messages{} -> return $ Just (ty, "")
|
||||
StaticFiles{} -> return $ Just (ty, "")
|
||||
@ -169,13 +179,13 @@ determineHamletDeps x = do
|
||||
_ <- A.char ')'
|
||||
return $ Just (ty, y)
|
||||
|
||||
getFolderContents :: FilePath -> IO [FilePath]
|
||||
getFolderContents fp = do
|
||||
cs <- getDirectoryContents fp
|
||||
let notHidden ('.':_) = False
|
||||
notHidden ('t':"mp") = False
|
||||
notHidden _ = True
|
||||
fmap concat $ forM (filter notHidden cs) $ \c -> do
|
||||
let f = fp ++ '/' : c
|
||||
isFile <- doesFileExist f
|
||||
if isFile then return [f] else getFolderContents f
|
||||
getFolderContents :: FilePath -> IO [FilePath]
|
||||
getFolderContents fp = do
|
||||
cs <- getDirectoryContents fp
|
||||
let notHidden ('.':_) = False
|
||||
notHidden ('t':"mp") = False
|
||||
notHidden _ = True
|
||||
fmap concat $ forM (filter notHidden cs) $ \c -> do
|
||||
let f = fp ++ '/' : c
|
||||
isFile <- doesFileExist f
|
||||
if isFile then return [f] else getFolderContents f
|
||||
|
||||
@ -1,6 +1,4 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Devel
|
||||
@ -16,7 +14,7 @@ import qualified Distribution.ModuleName as D
|
||||
|
||||
import Control.Concurrent (forkIO, threadDelay)
|
||||
import qualified Control.Exception as Ex
|
||||
import Control.Monad (forever, when)
|
||||
import Control.Monad (forever, when, unless)
|
||||
|
||||
import Data.Char (isUpper, isNumber)
|
||||
import qualified Data.List as L
|
||||
@ -31,7 +29,7 @@ import System.PosixCompat.Files (modificationTime, getFileStatus)
|
||||
import System.Process (createProcess, proc, terminateProcess, readProcess,
|
||||
waitForProcess, rawSystem)
|
||||
|
||||
import Build (recompDeps, getDeps,findHaskellFiles)
|
||||
import Build (recompDeps, getDeps)
|
||||
|
||||
lockFile :: FilePath
|
||||
lockFile = "dist/devel-terminate"
|
||||
@ -43,11 +41,10 @@ writeLock = do
|
||||
|
||||
removeLock :: IO ()
|
||||
removeLock = try_ (removeFile lockFile)
|
||||
|
||||
devel :: Bool -> [String] -> IO ()
|
||||
devel isCabalDev passThroughArgs = do
|
||||
|
||||
checkDevelFile
|
||||
|
||||
writeLock
|
||||
|
||||
putStrLn "Yesod devel server. Press ENTER to quit"
|
||||
@ -55,20 +52,20 @@ devel isCabalDev passThroughArgs = do
|
||||
cabal <- D.findPackageDesc "."
|
||||
gpd <- D.readPackageDescription D.normal cabal
|
||||
|
||||
checkCabalFile gpd
|
||||
hsSourceDirs <- checkCabalFile gpd
|
||||
|
||||
_<- rawSystem cmd args
|
||||
|
||||
mainLoop
|
||||
mainLoop hsSourceDirs
|
||||
|
||||
_ <- getLine
|
||||
writeLock
|
||||
exitSuccess
|
||||
where
|
||||
cmd | isCabalDev == True = "cabal-dev"
|
||||
cmd | isCabalDev = "cabal-dev"
|
||||
| otherwise = "cabal"
|
||||
|
||||
diffArgs | isCabalDev == True = [
|
||||
diffArgs | isCabalDev = [
|
||||
"--cabal-install-arg=-fdevel" -- legacy
|
||||
, "--cabal-install-arg=-flibrary-only"
|
||||
]
|
||||
@ -78,8 +75,8 @@ devel isCabalDev passThroughArgs = do
|
||||
]
|
||||
args = "configure":diffArgs ++ ["--disable-library-profiling" ]
|
||||
|
||||
mainLoop :: IO ()
|
||||
mainLoop = do
|
||||
mainLoop :: [FilePath] -> IO ()
|
||||
mainLoop hsSourceDirs = do
|
||||
ghcVer <- ghcVersion
|
||||
when isCabalDev (rawSystem cmd ["build"] >> return ()) -- cabal-dev fails with strange errors sometimes if we cabal-dev buildinfo before cabal-dev build
|
||||
pkgArgs <- ghcPackageArgs isCabalDev ghcVer
|
||||
@ -87,19 +84,19 @@ devel isCabalDev passThroughArgs = do
|
||||
forever $ do
|
||||
putStrLn "Rebuilding application..."
|
||||
|
||||
recompDeps
|
||||
recompDeps hsSourceDirs
|
||||
|
||||
list <- getFileList
|
||||
list <- getFileList hsSourceDirs
|
||||
exit <- rawSystem cmd ["build"]
|
||||
|
||||
case exit of
|
||||
ExitFailure _ -> putStrLn "Build failure, pausing..."
|
||||
_ -> do
|
||||
removeLock
|
||||
putStrLn $ "Starting development server: runghc " ++ L.intercalate " " devArgs
|
||||
putStrLn $ "Starting development server: runghc " ++ L.unwords devArgs
|
||||
(_,_,_,ph) <- createProcess $ proc "runghc" devArgs
|
||||
watchTid <- forkIO . try_ $ do
|
||||
watchForChanges list
|
||||
watchForChanges hsSourceDirs list
|
||||
putStrLn "Stopping development server..."
|
||||
writeLock
|
||||
threadDelay 1000000
|
||||
@ -108,17 +105,16 @@ devel isCabalDev passThroughArgs = do
|
||||
ec <- waitForProcess ph
|
||||
putStrLn $ "Exit code: " ++ show ec
|
||||
Ex.throwTo watchTid (userError "process finished")
|
||||
watchForChanges list
|
||||
watchForChanges hsSourceDirs list
|
||||
|
||||
try_ :: forall a. IO a -> IO ()
|
||||
try_ x = (Ex.try x :: IO (Either Ex.SomeException a)) >> return ()
|
||||
|
||||
type FileList = Map.Map FilePath EpochTime
|
||||
|
||||
getFileList :: IO FileList
|
||||
getFileList = do
|
||||
files <- findHaskellFiles "."
|
||||
deps <- getDeps
|
||||
getFileList :: [FilePath] -> IO FileList
|
||||
getFileList hsSourceDirs = do
|
||||
(files, deps) <- getDeps hsSourceDirs
|
||||
let files' = files ++ map fst (Map.toList deps)
|
||||
fmap Map.fromList $ flip mapM files' $ \f -> do
|
||||
efs <- Ex.try $ getFileStatus f
|
||||
@ -126,19 +122,19 @@ getFileList = do
|
||||
Left (_ :: Ex.SomeException) -> (f, 0)
|
||||
Right fs -> (f, modificationTime fs)
|
||||
|
||||
watchForChanges :: FileList -> IO ()
|
||||
watchForChanges list = do
|
||||
newList <- getFileList
|
||||
watchForChanges :: [FilePath] -> FileList -> IO ()
|
||||
watchForChanges hsSourceDirs list = do
|
||||
newList <- getFileList hsSourceDirs
|
||||
if list /= newList
|
||||
then return ()
|
||||
else threadDelay 1000000 >> watchForChanges list
|
||||
else threadDelay 1000000 >> watchForChanges hsSourceDirs list
|
||||
|
||||
checkDevelFile :: IO ()
|
||||
checkDevelFile = do
|
||||
e <- doesFileExist "devel.hs"
|
||||
when (not e) $ failWith "file devel.hs not found"
|
||||
unless e $ failWith "file devel.hs not found"
|
||||
|
||||
checkCabalFile :: D.GenericPackageDescription -> IO ()
|
||||
checkCabalFile :: D.GenericPackageDescription -> IO [FilePath]
|
||||
checkCabalFile gpd = case D.condLibrary gpd of
|
||||
Nothing -> failWith "incorrect cabal file, no library"
|
||||
Just ct ->
|
||||
@ -146,19 +142,15 @@ checkCabalFile gpd = case D.condLibrary gpd of
|
||||
Nothing ->
|
||||
failWith "no development flag found in your configuration file. Expected a 'library-only' flag or the older 'devel' flag"
|
||||
Just dLib -> do
|
||||
case (D.hsSourceDirs . D.libBuildInfo) dLib of
|
||||
[] -> return ()
|
||||
["."] -> return ()
|
||||
_ ->
|
||||
putStrLn $ "WARNING: yesod devel may not work correctly with " ++
|
||||
"custom hs-source-dirs"
|
||||
fl <- getFileList
|
||||
let unlisted = checkFileList fl dLib
|
||||
when (not . null $ unlisted) $ do
|
||||
putStrLn "WARNING: the following source files are not listed in exposed-modules or other-modules:"
|
||||
mapM_ putStrLn unlisted
|
||||
when (D.fromString "Application" `notElem` D.exposedModules dLib) $ do
|
||||
putStrLn "WARNING: no exposed module Application"
|
||||
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 (D.fromString "Application" `notElem` D.exposedModules dLib) $
|
||||
putStrLn "WARNING: no exposed module Application"
|
||||
return hsSourceDirs
|
||||
|
||||
failWith :: String -> IO a
|
||||
failWith msg = do
|
||||
@ -209,7 +201,7 @@ lookupDevelLib ct | found = Just (D.condTreeData ct)
|
||||
where
|
||||
found = not . null . map (\(_,x,_) -> D.condTreeData x) .
|
||||
filter isDevelLib . D.condTreeComponents $ ct
|
||||
isDevelLib ((D.Var (D.Flag (D.FlagName f))), _, _) = f `elem` ["library-only", "devel"]
|
||||
isDevelLib (D.Var (D.Flag (D.FlagName f)), _, _) = f `elem` ["library-only", "devel"]
|
||||
isDevelLib _ = False
|
||||
|
||||
|
||||
|
||||
@ -34,7 +34,7 @@ mkYesodDispatch "~sitearg~" resources~sitearg~
|
||||
-- migrations handled by Yesod.
|
||||
makeApplication :: AppConfig DefaultEnv Extra -> Logger -> IO Application
|
||||
makeApplication conf logger = do
|
||||
foundation <- makeFoundation conf logger
|
||||
foundation <- makeFoundation conf setLogger
|
||||
app <- toWaiAppPlain foundation
|
||||
return $ logWare app
|
||||
where
|
||||
|
||||
Loading…
Reference in New Issue
Block a user