Merge remote-tracking branch 'origin/master' into HEAD

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 ()
+touch :: IO ()
-recompDeps = touchDeps hiFile removeHi =<< getDeps
+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 :: [FilePath] -> IO ([FilePath], Deps)
-getDeps = do
+getDeps hsSourceDirs = do
-    hss <- findHaskellFiles "."
+    let defSrcDirs = case hsSourceDirs of
-    deps' <- mapM determineHamletDeps hss
+                        [] -> ["."]
-    return $ fixDeps $ zip hss deps'
+                        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 filename = do
-    go ('d':"ist")      = return []
+        d <- doesDirectoryExist full
-    go x = do
+        if not d
-        let y = path </> x
+          then if isHaskellFile
-        d <- doesDirectoryExist y
+                  then return [full]
-        if d
+                  else return []
-            then findHaskellFiles y
+          else if isHaskellDir
-            else if ".hs" `isSuffixOf` x || ".lhs" `isSuffixOf` x
+                 then findHaskellFiles full
-                    then return [y]
+                 else return []
-                    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]
+determineDeps :: FilePath -> IO [FilePath]
-determineHamletDeps x = do
+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 :: FilePath -> IO [FilePath]
-getFolderContents fp = do
+    getFolderContents fp = do
-    cs <- getDirectoryContents fp
+        cs <- getDirectoryContents fp
-    let notHidden ('.':_) = False
+        let notHidden ('.':_) = False
-        notHidden ('t':"mp") = False
+            notHidden ('t':"mp") = False
-        notHidden _ = True
+            notHidden _ = True
-    fmap concat $ forM (filter notHidden cs) $ \c -> do
+        fmap concat $ forM (filter notHidden cs) $ \c -> do
-        let f = fp ++ '/' : c
+            let f = fp ++ '/' : c
-        isFile <- doesFileExist f
+            isFile <- doesFileExist f
-        if isFile then return [f] else getFolderContents f
+            if isFile then return [f] else getFolderContents f

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 :: [FilePath] -> IO ()
-    mainLoop = do
+    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 :: [FilePath] -> IO FileList
-getFileList = do
+getFileList hsSourceDirs = do
-    files <- findHaskellFiles "."
+    (files, deps) <- getDeps hsSourceDirs
-    deps <- getDeps
     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 :: [FilePath] ->  FileList -> IO ()
-watchForChanges list = do
+watchForChanges hsSourceDirs list = do
-    newList <- getFileList
+    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
+           let hsSourceDirs = D.hsSourceDirs . D.libBuildInfo $ dLib
-           []     -> return ()
+           fl <- getFileList hsSourceDirs
-           ["."]  -> return ()
+           let unlisted = checkFileList fl dLib
-           _      ->
+           unless (null unlisted) $ do
-             putStrLn $ "WARNING: yesod devel may not work correctly with " ++
+                putStrLn "WARNING: the following source files are not listed in exposed-modules or other-modules:"
-                        "custom hs-source-dirs"
+                mapM_ putStrLn unlisted
-         fl <- getFileList
+           when (D.fromString "Application" `notElem` D.exposedModules dLib) $
-         let unlisted = checkFileList fl dLib
+                putStrLn "WARNING: no exposed module Application"
-         when (not . null $ unlisted) $ do
+           return hsSourceDirs
-              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"
 
 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
 
 

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