diff --git a/yesod/Build.hs b/yesod/Build.hs index 3b5f4b13..fb147114 100644 --- a/yesod/Build.hs +++ b/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 diff --git a/yesod/Devel.hs b/yesod/Devel.hs index 457c96f1..e7765cba 100644 --- a/yesod/Devel.hs +++ b/yesod/Devel.hs @@ -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 diff --git a/yesod/scaffold/Application.hs.cg b/yesod/scaffold/Application.hs.cg index 3ad1551b..20a58b61 100644 --- a/yesod/scaffold/Application.hs.cg +++ b/yesod/scaffold/Application.hs.cg @@ -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