From 0c6a319ae6a3bb33acef92297ac5438b178a196c Mon Sep 17 00:00:00 2001 From: gregwebs Date: Fri, 30 Mar 2012 09:12:27 -0700 Subject: [PATCH 1/6] use setLogger --- yesod/scaffold/Application.hs.cg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 From 8b3adbb01e9f4f1488a7a3ff1074df865c4cca72 Mon Sep 17 00:00:00 2001 From: gregwebs Date: Sat, 31 Mar 2012 21:31:10 -0700 Subject: [PATCH 2/6] use hs-source-dirs, no hamlet deps in 7.4 * pass along hs-source-dirs to the dependency finders * 7.4 tracks hamlet dependencies already --- yesod/Build.hs | 70 ++++++++++++++++++++++++++++------------------- yesod/Devel.hs | 74 ++++++++++++++++++++++---------------------------- 2 files changed, 75 insertions(+), 69 deletions(-) diff --git a/yesod/Build.hs b/yesod/Build.hs index 3b5f4b13..2f0db6bf 100644 --- a/yesod/Build.hs +++ b/yesod/Build.hs @@ -1,26 +1,27 @@ {-# 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 @@ -29,18 +30,21 @@ import System.PosixCompat.Files (getFileStatus, setFileTimes, accessTime, modificationTime) 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 ()) -> @@ -114,31 +118,41 @@ findHaskellFiles path = do then return [y] else return [] -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 +183,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 From 3fbe4c8f6256672e5c34df8b8e896a87d1e64a31 Mon Sep 17 00:00:00 2001 From: gregwebs Date: Sun, 1 Apr 2012 07:19:14 -0700 Subject: [PATCH 3/6] ignore lower case directories --- yesod/Build.hs | 26 ++++++++++++++++---------- 1 file changed, 16 insertions(+), 10 deletions(-) diff --git a/yesod/Build.hs b/yesod/Build.hs index 2f0db6bf..76071f8f 100644 --- a/yesod/Build.hs +++ b/yesod/Build.hs @@ -28,6 +28,8 @@ 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 =<< fmap snd (getDeps []) @@ -107,16 +109,20 @@ 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 = Verbatim | Messages FilePath | StaticFiles FilePath #if __GLASGOW_HASKELL__ < 704 From 1ccbf5ce062cfe4fae98903d12002912d1f61ecc Mon Sep 17 00:00:00 2001 From: gregwebs Date: Mon, 2 Apr 2012 06:47:41 -0700 Subject: [PATCH 4/6] fix yesod devel file finding breakage --- yesod/Build.hs | 21 +++++++++------------ 1 file changed, 9 insertions(+), 12 deletions(-) diff --git a/yesod/Build.hs b/yesod/Build.hs index 76071f8f..3ebcc11c 100644 --- a/yesod/Build.hs +++ b/yesod/Build.hs @@ -112,12 +112,12 @@ findHaskellFiles path = do go filename = do d <- doesDirectoryExist full if not d - then return [] + then if isHaskellFile + then return [full] + else return [] else if isHaskellDir then findHaskellFiles full - else if isHaskellFile - then return [full] - else return [] + else return [] where -- this could fail on unicode isHaskellDir = isUpper (head filename) @@ -147,8 +147,11 @@ determineDeps x = do go Nothing = return [] parser = do - ty <- (A.string "$(parseRoutesFile " >> return Verbatim) + ty <- (do _ <- A.string "\nstaticFiles \"" + x' <- A.many1 $ A.satisfy (/= '"') + return $ StaticFiles x') #if __GLASGOW_HASKELL__ < 704 + <|> (A.string "$(parseRoutesFile " >> return Verbatim) <|> (A.string "$(hamletFile " >> return Hamlet) <|> (A.string "$(ihamletFile " >> return Hamlet) <|> (A.string "$(whamletFile " >> return Hamlet) @@ -156,9 +159,6 @@ determineDeps x = do <|> (A.string "$(widgetFile " >> return Hamlet) <|> (A.string "$(Settings.hamletFile " >> return Hamlet) <|> (A.string "$(Settings.widgetFile " >> return Hamlet) -#endif - - <|> (A.string "$(persistFile " >> return Verbatim) <|> ( A.string "$(persistFileWith " >> @@ -173,10 +173,7 @@ determineDeps 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') +#endif case ty of Messages{} -> return $ Just (ty, "") StaticFiles{} -> return $ Just (ty, "") From 0020feff627bbd258fa48494676b252804dcba35 Mon Sep 17 00:00:00 2001 From: gregwebs Date: Mon, 2 Apr 2012 07:11:19 -0700 Subject: [PATCH 5/6] still need to invoke cabal on 7.4 --- yesod/Build.hs | 19 +++++++------------ 1 file changed, 7 insertions(+), 12 deletions(-) diff --git a/yesod/Build.hs b/yesod/Build.hs index 3ebcc11c..4792a71d 100644 --- a/yesod/Build.hs +++ b/yesod/Build.hs @@ -25,7 +25,7 @@ import qualified Data.Set as Set 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) import Data.Char (isUpper) @@ -120,14 +120,13 @@ findHaskellFiles path = do else return [] where -- this could fail on unicode - isHaskellDir = isUpper (head filename) - isHaskellFile = ".hs" `isSuffixOf` filename || ".lhs" `isSuffixOf` filename + isHaskellDir = isUpper (head filename) + isHaskellFile = takeExtension filename `elem` watch_files full = path filename + watch_files = [".hs", ".lhs"] -data TempType = Verbatim | Messages FilePath | StaticFiles FilePath -#if __GLASGOW_HASKELL__ < 704 - | Hamlet -#endif +data TempType = StaticFiles FilePath + | Verbatim | Messages FilePath | Hamlet deriving Show determineDeps :: FilePath -> IO [FilePath] @@ -138,19 +137,16 @@ determineDeps x = do A.Fail{} -> return [] A.Done _ r -> mapM go r >>= filterM doesFileExist . concat where -#if __GLASGOW_HASKELL__ < 704 + go (Just (StaticFiles fp, _)) = getFolderContents fp 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 <- (do _ <- A.string "\nstaticFiles \"" x' <- A.many1 $ A.satisfy (/= '"') return $ StaticFiles x') -#if __GLASGOW_HASKELL__ < 704 <|> (A.string "$(parseRoutesFile " >> return Verbatim) <|> (A.string "$(hamletFile " >> return Hamlet) <|> (A.string "$(ihamletFile " >> return Hamlet) @@ -173,7 +169,6 @@ determineDeps x = do y <- A.many1 $ A.satisfy (/= '"') _ <- A.string "\"" return $ Messages $ concat [x', "/", y, ".msg"]) -#endif case ty of Messages{} -> return $ Just (ty, "") StaticFiles{} -> return $ Just (ty, "") From db55170dffcd0fc3afde572a36fbd528ffa9496d Mon Sep 17 00:00:00 2001 From: gregwebs Date: Mon, 2 Apr 2012 07:35:30 -0700 Subject: [PATCH 6/6] fix import warnings --- yesod/Build.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/yesod/Build.hs b/yesod/Build.hs index 4792a71d..fb147114 100644 --- a/yesod/Build.hs +++ b/yesod/Build.hs @@ -12,14 +12,13 @@ module Build import Control.Applicative ((<|>), many) 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 @@ -28,7 +27,6 @@ import System.Directory import System.FilePath (takeExtension, replaceExtension, ()) import System.PosixCompat.Files (getFileStatus, setFileTimes, accessTime, modificationTime) -import Data.Char (isUpper) touch :: IO ()