haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Check for import changes in Shakespeare files (#413)

Browse Source
This commit is contained in:
Michael Snoyman 2012-10-30 16:16:29 +02:00
parent 83264153fc
commit bdbb73f94d
3 changed files with 140 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

110
yesod/Build.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Build module Build
( getDeps ( getDeps
, touchDeps , touchDeps
@ -11,32 +12,53 @@ module Build
-- FIXME there's a bug when getFileStatus applies to a file -- FIXME there's a bug when getFileStatus applies to a file
-- temporary deleted (e.g., Vim saving a file) -- temporary deleted (e.g., Vim saving a file)
import Control.Applicative ((<|>), many) import Control.Applicative ((<|>), many, (<$>))
import qualified Data.Attoparsec.Text.Lazy as A import qualified Data.Attoparsec.Text.Lazy as A
import Data.Char (isSpace, isUpper) import Data.Char (isSpace, isUpper)
import qualified Data.Text.Lazy.IO as TIO import qualified Data.Text.Lazy.IO as TIO
import Control.Exception (SomeException, try) import Control.Exception (SomeException, try)
import Control.Exception.Lifted (handle)
import Control.Monad (when, filterM, forM, forM_, (>=>)) import Control.Monad (when, filterM, forM, forM_, (>=>))
import Control.Monad.Trans.State (StateT, get, put, execStateT)
import Control.Monad.Trans.Writer (WriterT, tell, execWriterT)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Class (lift)
import Data.Monoid (mappend) import Data.Monoid (Monoid (mappend, mempty))
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified System.Posix.Types import qualified System.Posix.Types
import System.Directory import System.Directory
import System.FilePath (takeExtension, replaceExtension, (</>)) import System.FilePath (takeExtension, replaceExtension, (</>), takeDirectory)
import System.PosixCompat.Files (getFileStatus, setFileTimes, import System.PosixCompat.Files (getFileStatus, setFileTimes,
accessTime, modificationTime) accessTime, modificationTime)
import Text.Shakespeare (Deref)
import Text.Julius (juliusUsedIdentifiers)
import Text.Cassius (cassiusUsedIdentifiers)
import Text.Lucius (luciusUsedIdentifiers)
touch :: IO () touch :: IO ()
touch = touchDeps id updateFileTime =<< fmap snd (getDeps []) touch = do
m <- handle (\(_ :: SomeException) -> return Map.empty) $ readFile touchCache >>= readIO
x <- fmap snd (getDeps [])
m' <- execStateT (execWriterT $ touchDeps id updateFileTime x) m
createDirectoryIfMissing True $ takeDirectory touchCache
writeFile touchCache $ show m'
where
touchCache = "dist/touchCache.txt"
recompDeps :: [FilePath] -> IO () -- | Returns True if any files were touched, otherwise False
recompDeps = getDeps >=> touchDeps hiFile removeHi . snd recompDeps :: [FilePath] -> StateT (Map.Map FilePath (Set.Set Deref)) IO Bool
recompDeps =
fmap toBool . execWriterT . (liftIO . getDeps >=> touchDeps hiFile removeHi . snd)
where
toBool NoFilesTouched = False
toBool SomeFilesTouched = True
type Deps = Map.Map FilePath (Set.Set FilePath) type Deps = Map.Map FilePath ([FilePath], ComparisonType)
getDeps :: [FilePath] -> IO ([FilePath], Deps) getDeps :: [FilePath] -> IO ([FilePath], Deps)
getDeps hsSourceDirs = do getDeps hsSourceDirs = do
@ -47,17 +69,35 @@ getDeps hsSourceDirs = do
deps' <- mapM determineDeps hss deps' <- mapM determineDeps hss
return $ (hss, fixDeps $ zip hss deps') return $ (hss, fixDeps $ zip hss deps')
data AnyFilesTouched = NoFilesTouched | SomeFilesTouched
instance Monoid AnyFilesTouched where
mempty = NoFilesTouched
mappend NoFilesTouched NoFilesTouched = mempty
mappend _ _ = SomeFilesTouched
touchDeps :: (FilePath -> FilePath) -> touchDeps :: (FilePath -> FilePath) ->
(FilePath -> FilePath -> IO ()) -> (FilePath -> FilePath -> IO ()) ->
Deps -> IO () Deps -> WriterT AnyFilesTouched (StateT (Map.Map FilePath (Set.Set Deref)) IO) ()
touchDeps f action deps = (mapM_ go . Map.toList) deps touchDeps f action deps = (mapM_ go . Map.toList) deps
where where
go (x, ys) = go (x, (ys, ct)) = do
forM_ (Set.toList ys) $ \y -> do isChanged <- handle (\(_ :: SomeException) -> return True) $ lift $
n <- x `isNewerThan` f y case ct of
AlwaysOutdated -> return True
CompareUsedIdentifiers getDerefs -> do
derefMap <- get
s <- liftIO $ readFile x
let newDerefs = Set.fromList $ getDerefs s
put $ Map.insert x newDerefs derefMap
case Map.lookup x derefMap of
Just oldDerefs | oldDerefs == newDerefs -> return False
_ -> return True
when isChanged $ forM_ ys $ \y -> do
n <- liftIO $ x `isNewerThan` f y
when n $ do when n $ do
putStrLn ("Forcing recompile for " ++ y ++ " because of " ++ x) liftIO $ putStrLn ("Forcing recompile for " ++ y ++ " because of " ++ x)
action x y liftIO $ action x y
tell SomeFilesTouched
-- | remove the .hi files for a .hs file, thereby forcing a recompile -- | remove the .hi files for a .hs file, thereby forcing a recompile
removeHi :: FilePath -> FilePath -> IO () removeHi :: FilePath -> FilePath -> IO ()
@ -95,12 +135,14 @@ getFileStatus' fp = do
Left _ -> return (0, 0) Left _ -> return (0, 0)
Right fs -> return (accessTime fs, modificationTime fs) Right fs -> return (accessTime fs, modificationTime fs)
fixDeps :: [(FilePath, [FilePath])] -> Deps fixDeps :: [(FilePath, [(ComparisonType, FilePath)])] -> Deps
fixDeps = fixDeps =
Map.unionsWith mappend . map go Map.unionsWith combine . map go
where where
go :: (FilePath, [FilePath]) -> Deps go :: (FilePath, [(ComparisonType, FilePath)]) -> Deps
go (x, ys) = Map.fromList $ map (\y -> (y, Set.singleton x)) ys go (x, ys) = Map.fromList $ map (\(ct, y) -> (y, ([x], ct))) ys
combine (ys1, ct) (ys2, _) = (ys1 `mappend` ys2, ct)
findHaskellFiles :: FilePath -> IO [FilePath] findHaskellFiles :: FilePath -> IO [FilePath]
findHaskellFiles path = do findHaskellFiles path = do
@ -125,21 +167,34 @@ findHaskellFiles path = do
watch_files = [".hs", ".lhs"] watch_files = [".hs", ".lhs"]
data TempType = StaticFiles FilePath data TempType = StaticFiles FilePath
| Verbatim | Messages FilePath | Hamlet | Verbatim | Messages FilePath | Hamlet | Widget | Julius | Cassius | Lucius
deriving Show deriving Show
determineDeps :: FilePath -> IO [FilePath] -- | How to tell if a file is outdated.
data ComparisonType = AlwaysOutdated
| CompareUsedIdentifiers (String -> [Deref])
determineDeps :: FilePath -> IO [(ComparisonType, FilePath)]
determineDeps x = do determineDeps x = do
y <- TIO.readFile x -- FIXME catch IO exceptions y <- TIO.readFile x -- FIXME catch IO exceptions
let z = A.parse (many $ (parser <|> (A.anyChar >> return Nothing))) y let z = A.parse (many $ (parser <|> (A.anyChar >> return Nothing))) y
case z of case z of
A.Fail{} -> return [] A.Fail{} -> return []
A.Done _ r -> mapM go r >>= filterM doesFileExist . concat A.Done _ r -> mapM go r >>= filterM (doesFileExist . snd) . concat
where where
go (Just (StaticFiles fp, _)) = getFolderContents fp go (Just (StaticFiles fp, _)) = map ((,) AlwaysOutdated) <$> getFolderContents fp
go (Just (Hamlet, f)) = return [f, "templates/" ++ f ++ ".hamlet"] go (Just (Hamlet, f)) = return [(AlwaysOutdated, f)]
go (Just (Verbatim, f)) = return [f] go (Just (Widget, f)) = return
go (Just (Messages f, _)) = getFolderContents f [ (AlwaysOutdated, "templates/" ++ f ++ ".hamlet")
, (CompareUsedIdentifiers $ map fst . juliusUsedIdentifiers, "templates/" ++ f ++ ".julius")
, (CompareUsedIdentifiers $ map fst . luciusUsedIdentifiers, "templates/" ++ f ++ ".lucius")
, (CompareUsedIdentifiers $ map fst . cassiusUsedIdentifiers, "templates/" ++ f ++ ".cassius")
]
go (Just (Julius, f)) = return [(CompareUsedIdentifiers $ map fst . juliusUsedIdentifiers, f)]
go (Just (Cassius, f)) = return [(CompareUsedIdentifiers $ map fst . cassiusUsedIdentifiers, f)]
go (Just (Lucius, f)) = return [(CompareUsedIdentifiers $ map fst . luciusUsedIdentifiers, f)]
go (Just (Verbatim, f)) = return [(AlwaysOutdated, f)]
go (Just (Messages f, _)) = map ((,) AlwaysOutdated) <$> getFolderContents f
go Nothing = return [] go Nothing = return []
parser = do parser = do
@ -151,9 +206,12 @@ determineDeps x = do
<|> (A.string "$(ihamletFile " >> return Hamlet) <|> (A.string "$(ihamletFile " >> return Hamlet)
<|> (A.string "$(whamletFile " >> return Hamlet) <|> (A.string "$(whamletFile " >> return Hamlet)
<|> (A.string "$(html " >> return Hamlet) <|> (A.string "$(html " >> return Hamlet)
<|> (A.string "$(widgetFile " >> return Hamlet) <|> (A.string "$(widgetFile " >> return Widget)
<|> (A.string "$(Settings.hamletFile " >> return Hamlet) <|> (A.string "$(Settings.hamletFile " >> return Hamlet)
<|> (A.string "$(Settings.widgetFile " >> return Hamlet) <|> (A.string "$(Settings.widgetFile " >> return Widget)
<|> (A.string "$(juliusFile " >> return Julius)
<|> (A.string "$(cassiusFile " >> return Cassius)
<|> (A.string "$(luciusFile " >> return Lucius)
<|> (A.string "$(persistFile " >> return Verbatim) <|> (A.string "$(persistFile " >> return Verbatim)
<|> ( <|> (
A.string "$(persistFileWith " >> A.string "$(persistFileWith " >>

83
yesod/Devel.hs
View File

@ -28,9 +28,12 @@ import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.MVar (MVar, newEmptyMVar, import Control.Concurrent.MVar (MVar, newEmptyMVar,
takeMVar, tryPutMVar) takeMVar, tryPutMVar)
import qualified Control.Exception as Ex import qualified Control.Exception as Ex
import Control.Monad (forever, unless, void, import Control.Monad (unless, void,
when) when)
import Control.Monad.Trans.State (evalStateT, get)
import Control.Monad.IO.Class (liftIO)
import Data.Char (isNumber, isUpper) import Data.Char (isNumber, isUpper)
import qualified Data.List as L import qualified Data.List as L
import qualified Data.Map as Map import qualified Data.Map as Map
@ -114,7 +117,7 @@ devel opts passThroughArgs = withManager $ \manager -> do
_ <- forkIO $ do _ <- forkIO $ do
filesModified <- newEmptyMVar filesModified <- newEmptyMVar
watchTree manager "." (const True) (\_ -> void (tryPutMVar filesModified ())) watchTree manager "." (const True) (\_ -> void (tryPutMVar filesModified ()))
mainOuterLoop filesModified evalStateT (mainOuterLoop filesModified) Map.empty
_ <- getLine _ <- getLine
writeLock opts writeLock opts
exitSuccess exitSuccess
@ -123,50 +126,57 @@ devel opts passThroughArgs = withManager $ \manager -> do
-- outer loop re-reads the cabal file -- outer loop re-reads the cabal file
mainOuterLoop filesModified = do mainOuterLoop filesModified = do
cabal <- D.findPackageDesc "." cabal <- liftIO $ D.findPackageDesc "."
gpd <- D.readPackageDescription D.normal cabal gpd <- liftIO $ D.readPackageDescription D.normal cabal
ldar <- lookupLdAr ldar <- liftIO lookupLdAr
(hsSourceDirs, lib) <- checkCabalFile gpd (hsSourceDirs, lib) <- liftIO $ checkCabalFile gpd
removeFileIfExists (bd </> "setup-config") liftIO $ removeFileIfExists (bd </> "setup-config")
configure cabal gpd opts liftIO $ configure cabal gpd opts
removeFileIfExists "yesod-devel/ghcargs.txt" -- these files contain the wrong data after liftIO $ removeFileIfExists "yesod-devel/ghcargs.txt" -- these files contain the wrong data after
removeFileIfExists "yesod-devel/arargs.txt" -- the configure step, remove them to force liftIO $ removeFileIfExists "yesod-devel/arargs.txt" -- the configure step, remove them to force
removeFileIfExists "yesod-devel/ldargs.txt" -- a cabal build first liftIO $ removeFileIfExists "yesod-devel/ldargs.txt" -- a cabal build first
ghcVer <- ghcVersion ghcVer <- liftIO ghcVersion
rebuild <- mkRebuild gpd ghcVer cabal opts ldar rebuild <- liftIO $ mkRebuild gpd ghcVer cabal opts ldar
mainInnerLoop hsSourceDirs filesModified cabal gpd lib ghcVer rebuild mainInnerLoop hsSourceDirs filesModified cabal gpd lib ghcVer rebuild
-- inner loop rebuilds after files change -- inner loop rebuilds after files change
mainInnerLoop hsSourceDirs filesModified cabal gpd lib ghcVer rebuild = go mainInnerLoop hsSourceDirs filesModified cabal gpd lib ghcVer rebuild = go
where where
go = do go = do
recompDeps hsSourceDirs _ <- recompDeps hsSourceDirs
list <- getFileList hsSourceDirs [cabal] list <- liftIO $ getFileList hsSourceDirs [cabal]
success <- rebuild success <- liftIO rebuild
pkgArgs <- ghcPackageArgs opts ghcVer (D.packageDescription gpd) lib pkgArgs <- liftIO $ ghcPackageArgs opts ghcVer (D.packageDescription gpd) lib
let devArgs = pkgArgs ++ ["devel.hs"] ++ passThroughArgs let devArgs = pkgArgs ++ ["devel.hs"] ++ passThroughArgs
let loop list0 = do
(haskellFileChanged, list1) <- liftIO $ watchForChanges filesModified hsSourceDirs [cabal] list0 (eventTimeout opts)
anyTouched <- recompDeps hsSourceDirs
unless (anyTouched || haskellFileChanged) $ loop list1
if not success if not success
then do then liftIO $ do
putStrLn "Build failure, pausing..." putStrLn "Build failure, pausing..."
runBuildHook $ failHook opts runBuildHook $ failHook opts
else do else do
runBuildHook $ successHook opts liftIO $ runBuildHook $ successHook opts
removeLock opts liftIO $ removeLock opts
putStrLn $ if verbose opts then "Starting development server: runghc " ++ L.unwords devArgs liftIO $ putStrLn
$ if verbose opts then "Starting development server: runghc " ++ L.unwords devArgs
else "Starting development server..." else "Starting development server..."
(_,_,_,ph) <- createProcess $ proc "runghc" devArgs (_,_,_,ph) <- liftIO $ createProcess $ proc "runghc" devArgs
watchTid <- forkIO . try_ $ do derefMap <- get
watchForChanges filesModified hsSourceDirs [cabal] list (eventTimeout opts) watchTid <- liftIO . forkIO . try_ $ flip evalStateT derefMap $ do
loop list
liftIO $ do
putStrLn "Stopping development server..." putStrLn "Stopping development server..."
writeLock opts writeLock opts
threadDelay 1000000 threadDelay 1000000
putStrLn "Terminating development server..." putStrLn "Terminating development server..."
terminateProcess ph terminateProcess ph
ec <- waitForProcess' ph ec <- liftIO $ waitForProcess' ph
putStrLn $ "Exit code: " ++ show ec liftIO $ putStrLn $ "Exit code: " ++ show ec
Ex.throwTo watchTid (userError "process finished") liftIO $ Ex.throwTo watchTid (userError "process finished")
watchForChanges filesModified hsSourceDirs [cabal] list (eventTimeout opts) loop list
n <- cabal `isNewerThan` (bd </> "setup-config") n <- liftIO $ cabal `isNewerThan` (bd </> "setup-config")
if n then mainOuterLoop filesModified else go if n then mainOuterLoop filesModified else go
runBuildHook :: Maybe String -> IO () runBuildHook :: Maybe String -> IO ()
@ -294,13 +304,24 @@ getFileList hsSourceDirs extraFiles = do
Left (_ :: Ex.SomeException) -> (f, 0) Left (_ :: Ex.SomeException) -> (f, 0)
Right fs -> (f, modificationTime fs) Right fs -> (f, modificationTime fs)
watchForChanges :: MVar () -> [FilePath] -> [FilePath] -> FileList -> Int -> IO () -- | Returns @True@ if a .hs file changed.
watchForChanges :: MVar () -> [FilePath] -> [FilePath] -> FileList -> Int -> IO (Bool, FileList)
watchForChanges filesModified hsSourceDirs extraFiles list t = do watchForChanges filesModified hsSourceDirs extraFiles list t = do
newList <- getFileList hsSourceDirs extraFiles newList <- getFileList hsSourceDirs extraFiles
if list /= newList if list /= newList
then return () then do
let haskellFileChanged = not $ Map.null $ Map.filterWithKey isHaskell $
Map.differenceWith compareTimes newList list `Map.union`
Map.differenceWith compareTimes list newList
return (haskellFileChanged, newList)
else timeout (1000000*t) (takeMVar filesModified) >> else timeout (1000000*t) (takeMVar filesModified) >>
watchForChanges filesModified hsSourceDirs extraFiles list t watchForChanges filesModified hsSourceDirs extraFiles list t
where
compareTimes x y
| x == y = Nothing
| otherwise = Just x
isHaskell filename _ = takeExtension filename `elem` [".hs", ".lhs", ".hsc", ".cabal"]
checkDevelFile :: IO () checkDevelFile :: IO ()
checkDevelFile = do checkDevelFile = do

4
yesod/yesod.cabal
View File

@ -113,6 +113,9 @@ executable yesod
, parsec >= 2.1 && < 4 , parsec >= 2.1 && < 4
, text >= 0.11 , text >= 0.11
, shakespeare-text >= 1.0 && < 1.1 , shakespeare-text >= 1.0 && < 1.1
, shakespeare >= 1.0.2 && < 1.1
, shakespeare-js >= 1.0.1 && < 1.1
, shakespeare-css >= 1.0.2 && < 1.1
, bytestring >= 0.9.1.4 , bytestring >= 0.9.1.4
, time >= 1.1.4 , time >= 1.1.4
, template-haskell , template-haskell
@ -134,6 +137,7 @@ executable yesod
, optparse-applicative >= 0.4 && < 0.5 , optparse-applicative >= 0.4 && < 0.5
, fsnotify >= 0.0 && < 0.1 , fsnotify >= 0.0 && < 0.1
, split >= 0.2 && < 0.3 , split >= 0.2 && < 0.3
, lifted-base
ghc-options: -Wall -threaded ghc-options: -Wall -threaded
main-is: main.hs main-is: main.hs