restore original yesod touch behaviour

This commit is contained in:
Luite Stegeman 2011-09-10 01:04:58 +02:00
parent 064b8da896
commit d342798b4f
4 changed files with 46 additions and 15 deletions

View File

@ -3,6 +3,7 @@ module Build
( getDeps ( getDeps
, touchDeps , touchDeps
, touch , touch
, recompDeps
, findHaskellFiles , findHaskellFiles
) where ) where
@ -24,11 +25,14 @@ import qualified Data.Text.Lazy.IO as TIO
import qualified System.Posix.Types import qualified System.Posix.Types
import System.Directory import System.Directory
import System.FilePath (replaceExtension, (</>)) import System.FilePath (replaceExtension, (</>))
import System.PosixCompat.Files (getFileStatus, import System.PosixCompat.Files (getFileStatus, setFileTimes,
accessTime, modificationTime) accessTime, modificationTime)
touch :: IO () touch :: IO ()
touch = touchDeps =<< getDeps touch = touchDeps id updateFileTime =<< getDeps
recompDeps :: IO ()
recompDeps = touchDeps hiFile removeHi =<< getDeps
type Deps = Map.Map FilePath (Set.Set FilePath) type Deps = Map.Map FilePath (Set.Set FilePath)
@ -38,24 +42,34 @@ getDeps = do
deps' <- mapM determineHamletDeps hss deps' <- mapM determineHamletDeps hss
return $ fixDeps $ zip hss deps' return $ fixDeps $ zip hss deps'
touchDeps :: Deps -> IO () touchDeps :: (FilePath -> FilePath) ->
touchDeps deps = (mapM_ go . Map.toList) deps (FilePath -> FilePath -> IO ()) ->
Deps -> IO ()
touchDeps f action deps = (mapM_ go . Map.toList) deps
where where
go (x, ys) = go (x, ys) =
forM_ (Set.toList ys) $ \y -> do forM_ (Set.toList ys) $ \y -> do
n <- x `isNewerThan` (hiFile y) n <- x `isNewerThan` f y
when n $ do when n $ do
putStrLn ("Forcing recompile for " ++ y ++ " because of " ++ x) putStrLn ("Forcing recompile for " ++ y ++ " because of " ++ x)
removeHi y action x y
-- | 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 -> IO () removeHi :: FilePath -> FilePath -> IO ()
removeHi hs = mapM_ removeFile' hiFiles removeHi _ hs = mapM_ removeFile' hiFiles
where where
removeFile' file = try' (removeFile file) >> return () removeFile' file = try' (removeFile file) >> return ()
hiFiles = map (\e -> "dist/build" </> replaceExtension hs e) hiFiles = map (\e -> "dist/build" </> replaceExtension hs e)
["hi", "p_hi"] ["hi", "p_hi"]
-- | change file mtime of .hs file to that of the dependency
updateFileTime :: FilePath -> FilePath -> IO ()
updateFileTime x hs = do
(_ , modx) <- getFileStatus' x
(access, _ ) <- getFileStatus' hs
_ <- try' (setFileTimes hs access modx)
return ()
hiFile :: FilePath -> FilePath hiFile :: FilePath -> FilePath
hiFile hs = "dist/build" </> replaceExtension hs "hi" hiFile hs = "dist/build" </> replaceExtension hs "hi"

View File

@ -33,7 +33,7 @@ import System.Process (runCommand, terminateProcess,
import Text.Shakespeare.Text (st) import Text.Shakespeare.Text (st)
import Build (touch, getDeps, findHaskellFiles) import Build (recompDeps, getDeps,findHaskellFiles)
lockFile :: FilePath lockFile :: FilePath
lockFile = "dist/devel-terminate" lockFile = "dist/devel-terminate"
@ -76,7 +76,7 @@ mainLoop :: Bool -> IO ()
mainLoop isDevel = forever $ do mainLoop isDevel = forever $ do
putStrLn "Rebuilding application..." putStrLn "Rebuilding application..."
touch recompDeps
list <- getFileList list <- getFileList
_ <- if isDevel _ <- if isDevel

View File

@ -1,11 +1,22 @@
{-# LANGUAGE CPP #-}
import Scaffolding.Scaffolder import Scaffolding.Scaffolder
import System.Environment (getArgs) import System.Environment (getArgs)
import System.Exit (exitWith) import System.Exit (exitWith)
import System.Process (rawSystem) import System.Process (rawSystem)
#ifndef WINDOWS
import Build (touch) import Build (touch)
#endif
import Devel (devel) import Devel (devel)
windowsWarning :: String
#ifdef WINDOWS
windowsWarning = "\n (does not work on Windows)"
#else
windowsWarning = ""
#endif
main :: IO () main :: IO ()
main = do main = do
args' <- getArgs args' <- getArgs
@ -17,8 +28,10 @@ main = do
let build rest = rawSystem cmd $ "build":rest let build rest = rawSystem cmd $ "build":rest
case args of case args of
["init"] -> scaffold ["init"] -> scaffold
#ifndef WINDOWS
"build":rest -> touch >> build rest >>= exitWith "build":rest -> touch >> build rest >>= exitWith
["touch"] -> touch ["touch"] -> touch
#endif
["devel"] -> devel isDev ["devel"] -> devel isDev
["version"] -> putStrLn "0.9" ["version"] -> putStrLn "0.9"
"configure":rest -> rawSystem cmd ("configure":rest) >>= exitWith "configure":rest -> rawSystem cmd ("configure":rest) >>= exitWith
@ -27,8 +40,10 @@ main = do
putStrLn "Available commands:" putStrLn "Available commands:"
putStrLn " init Scaffold a new site" putStrLn " init Scaffold a new site"
putStrLn " configure Configure a project for building" putStrLn " configure Configure a project for building"
putStrLn " build Build project (performs TH dependency analysis)" putStrLn $ " build Build project (performs TH dependency analysis)"
putStrLn " touch Touch any files with altered TH dependencies but do not build" ++ windowsWarning
putStrLn $ " touch Touch any files with altered TH dependencies but do not build"
++ windowsWarning
putStrLn " devel Run project with the devel server" putStrLn " devel Run project with the devel server"
putStrLn " use --dev devel to build with cabal-dev" putStrLn " use --dev devel to build with cabal-dev"
putStrLn " version Print the version of Yesod" putStrLn " version Print the version of Yesod"

View File

@ -85,6 +85,8 @@ executable yesod
cpp-options: -DGHC7 cpp-options: -DGHC7
else else
build-depends: base >= 4 && < 4.3 build-depends: base >= 4 && < 4.3
if os(windows)
cpp-options: -DWINDOWS
build-depends: parsec >= 2.1 && < 4 build-depends: parsec >= 2.1 && < 4
, text >= 0.11 && < 0.12 , text >= 0.11 && < 0.12
, shakespeare-text >= 0.10 && < 0.11 , shakespeare-text >= 0.10 && < 0.11