diff --git a/yesod/Build.hs b/yesod/Build.hs index 3b5f4b13..76071f8f 100644 --- a/yesod/Build.hs +++ b/yesod/Build.hs @@ -1,46 +1,52 @@ {-# 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 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.PosixCompat.Files (getFileStatus, setFileTimes, accessTime, modificationTime) +import Data.Char (isUpper) + touch :: IO () -touch = touchDeps id updateFileTime =<< getDeps +touch = touchDeps id updateFileTime =<< fmap snd (getDeps []) -recompDeps :: IO () -recompDeps = touchDeps hiFile removeHi =<< 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 +109,56 @@ 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 return [] + else if isHaskellDir + then findHaskellFiles full + else if isHaskellFile + then return [full] + else return [] + where + -- this could fail on unicode + isHaskellDir = isUpper (head filename) + isHaskellFile = ".hs" `isSuffixOf` filename || ".lhs" `isSuffixOf` filename + full = path filename -data TempType = Hamlet | Verbatim | Messages FilePath | StaticFiles FilePath +data TempType = Verbatim | Messages FilePath | StaticFiles FilePath +#if __GLASGOW_HASKELL__ < 704 + | Hamlet +#endif 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 +#if __GLASGOW_HASKELL__ < 704 go (Just (Hamlet, f)) = return [f, "templates/" ++ f ++ ".hamlet"] +#endif 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 <- (A.string "$(parseRoutesFile " >> return Verbatim) +#if __GLASGOW_HASKELL__ < 704 + <|> (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) +#endif + + <|> (A.string "$(persistFile " >> return Verbatim) <|> ( A.string "$(persistFileWith " >> @@ -169,13 +189,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 729494ef..153b4c6c 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,35 +105,34 @@ 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 fs <- getFileStatus f return (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 -> @@ -144,19 +140,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 @@ -207,7 +199,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