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

use fsnotify to watch folder

Browse Source
This commit is contained in:
Luite Stegeman 2012-10-15 19:17:08 +02:00
parent 77383f8002
commit 19d4834378
4 changed files with 73 additions and 105 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

84
yesod/Devel.hs
View File

@ -4,35 +4,36 @@
module Devel module Devel
( devel ( devel
, DevelOpts(..) , DevelOpts(..)
, defaultDevelOpts
) where ) where
import qualified Distribution.Compiler as D import qualified Distribution.Compiler as D
import qualified Distribution.InstalledPackageInfo as IPI
import qualified Distribution.ModuleName as D import qualified Distribution.ModuleName as D
import qualified Distribution.Package as D
import qualified Distribution.PackageDescription as D import qualified Distribution.PackageDescription as D
import qualified Distribution.PackageDescription.Parse as D import qualified Distribution.PackageDescription.Parse as D
import qualified Distribution.Simple.Build as D import qualified Distribution.Simple.Build as D
import qualified Distribution.Simple.Configure as D import qualified Distribution.Simple.Configure as D
import qualified Distribution.Simple.LocalBuildInfo as D
import qualified Distribution.Simple.Program as D import qualified Distribution.Simple.Program as D
import qualified Distribution.Simple.Register as D import qualified Distribution.Simple.Register as D
import qualified Distribution.Simple.Setup as DSS import qualified Distribution.Simple.Setup as DSS
import qualified Distribution.Simple.Utils as D import qualified Distribution.Simple.Utils as D
import qualified Distribution.Verbosity as D import qualified Distribution.Verbosity as D
-- import qualified Distribution.InstalledPackageInfo as D
import qualified Distribution.InstalledPackageInfo as IPI
import qualified Distribution.Package as D
import qualified Distribution.Simple.LocalBuildInfo as D
import qualified Distribution.Verbosity as D
import Control.Applicative ((<$>), (<*>)) import Control.Applicative ((<$>), (<*>))
import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.MVar (MVar, newEmptyMVar,
takeMVar, tryPutMVar)
import qualified Control.Exception as Ex import qualified Control.Exception as Ex
import Control.Monad (forever, unless, when) import Control.Monad (forever, unless, void,
when)
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
import Data.Maybe (fromMaybe)
import qualified Data.Set as Set import qualified Data.Set as Set
import System.Directory import System.Directory
@ -42,6 +43,7 @@ import System.Exit (ExitCode (..),
import System.FilePath (dropExtension, import System.FilePath (dropExtension,
splitDirectories, splitDirectories,
takeExtension) takeExtension)
import System.FSNotify
import System.IO (hClose, hGetLine, import System.IO (hClose, hGetLine,
hIsEOF, hPutStrLn, hIsEOF, hPutStrLn,
stderr, stdout) stderr, stdout)
@ -56,8 +58,8 @@ import System.Process (ProcessHandle,
readProcess, readProcess,
runInteractiveProcess, runInteractiveProcess,
system, system,
terminateProcess, terminateProcess)
waitForProcess) import System.Timeout (timeout)
import Build (getDeps, isNewerThan, import Build (getDeps, isNewerThan,
recompDeps) recompDeps)
@ -79,21 +81,23 @@ removeLock :: IO ()
removeLock = removeFileIfExists lockFile removeLock = removeFileIfExists lockFile
data DevelOpts = DevelOpts data DevelOpts = DevelOpts
{ isCabalDev :: Bool { isCabalDev :: Bool
, forceCabal :: Bool , forceCabal :: Bool
, verbose :: Bool , verbose :: Bool
, successHook :: Maybe String , eventTimeout :: Int -- negative value for no timeout
, failHook :: Maybe String , successHook :: Maybe String
, failHook :: Maybe String
} deriving (Show, Eq) } deriving (Show, Eq)
cabalCommand :: DevelOpts -> FilePath cabalCommand :: DevelOpts -> FilePath
cabalCommand opts | isCabalDev opts = "cabal-dev" cabalCommand opts | isCabalDev opts = "cabal-dev"
| otherwise = "cabal" | otherwise = "cabal"
defaultDevelOpts = DevelOpts False False False Nothing Nothing defaultDevelOpts :: DevelOpts
defaultDevelOpts = DevelOpts False False False (-1) Nothing Nothing
devel :: DevelOpts -> [String] -> IO () devel :: DevelOpts -> [String] -> IO ()
devel opts passThroughArgs = do devel opts passThroughArgs = withManager $ \manager -> do
checkDevelFile checkDevelFile
writeLock writeLock
@ -110,14 +114,22 @@ devel opts passThroughArgs = do
removeFileIfExists "dist/ghcargs.txt" -- these files contain the wrong data after removeFileIfExists "dist/ghcargs.txt" -- these files contain the wrong data after
removeFileIfExists "dist/arargs.txt" -- the configure step, remove them to force removeFileIfExists "dist/arargs.txt" -- the configure step, remove them to force
removeFileIfExists "dist/ldargs.txt" -- a cabal build first removeFileIfExists "dist/ldargs.txt" -- a cabal build first
mainLoop hsSourceDirs cabal gpd lib ldar filesModified <- newEmptyMVar
watchTree manager "." (const True) (\_ -> void (tryPutMVar filesModified ()))
mainLoop hsSourceDirs filesModified cabal gpd lib ldar
_ <- getLine _ <- getLine
writeLock writeLock
exitSuccess exitSuccess
where where
mainLoop :: [FilePath] -> FilePath -> D.GenericPackageDescription -> D.Library -> (FilePath, FilePath) -> IO () mainLoop :: [FilePath]
mainLoop hsSourceDirs cabal gpd lib ldar = do -> MVar ()
-> FilePath
-> D.GenericPackageDescription
-> D.Library
-> (FilePath, FilePath)
-> IO ()
mainLoop hsSourceDirs filesModified cabal gpd lib ldar = do
ghcVer <- ghcVersion ghcVer <- ghcVersion
rebuild <- mkRebuild gpd ghcVer cabal opts ldar rebuild <- mkRebuild gpd ghcVer cabal opts ldar
forever $ do forever $ do
@ -137,7 +149,7 @@ devel opts passThroughArgs = do
else "Starting development server..." else "Starting development server..."
(_,_,_,ph) <- createProcess $ proc "runghc" devArgs (_,_,_,ph) <- createProcess $ proc "runghc" devArgs
watchTid <- forkIO . try_ $ do watchTid <- forkIO . try_ $ do
watchForChanges hsSourceDirs [cabal] list watchForChanges filesModified hsSourceDirs [cabal] list (eventTimeout opts)
putStrLn "Stopping development server..." putStrLn "Stopping development server..."
writeLock writeLock
threadDelay 1000000 threadDelay 1000000
@ -146,14 +158,14 @@ devel opts passThroughArgs = do
ec <- waitForProcess' ph ec <- waitForProcess' ph
putStrLn $ "Exit code: " ++ show ec putStrLn $ "Exit code: " ++ show ec
Ex.throwTo watchTid (userError "process finished") Ex.throwTo watchTid (userError "process finished")
watchForChanges hsSourceDirs [cabal] list watchForChanges filesModified hsSourceDirs [cabal] list (eventTimeout opts)
runBuildHook :: Maybe String -> IO () runBuildHook :: Maybe String -> IO ()
runBuildHook (Just s) = do runBuildHook (Just s) = do
ret <- system s ret <- system s
case ret of case ret of
ExitFailure f -> putStrLn $ "Error executing hook: " ++ s ExitFailure _ -> putStrLn ("Error executing hook: " ++ s)
otherwise -> return () _ -> return ()
runBuildHook Nothing = return () runBuildHook Nothing = return ()
{- {-
@ -164,7 +176,7 @@ runBuildHook Nothing = return ()
cabal-dev buildopts if required cabal-dev buildopts if required
-} -}
configure :: FilePath -> D.GenericPackageDescription -> DevelOpts -> IO () configure :: FilePath -> D.GenericPackageDescription -> DevelOpts -> IO ()
configure cabal gpd opts configure _cabalFile gpd opts
| isCabalDev opts = rawSystem (cabalCommand opts) args >> return () | isCabalDev opts = rawSystem (cabalCommand opts) args >> return ()
| otherwise = do | otherwise = do
lbi <- D.configure (gpd, hookedBuildInfo) configFlags lbi <- D.configure (gpd, hookedBuildInfo) configFlags
@ -191,9 +203,9 @@ configure cabal gpd opts
} }
cabalArgs cabalArgs
| isCabalDev opts = map ("--cabal-install-arg=" ++) args | isCabalDev opts = map ("--cabal-install-arg=" ++) args
| otherwise = args | otherwise = as
where where
args = as =
[ "-fdevel" -- legacy [ "-fdevel" -- legacy
, "-flibrary-only" , "-flibrary-only"
] ++ wrapperArgs ] ++ wrapperArgs
@ -238,7 +250,7 @@ rebuildGhc bf ld ar = do
buildPackage bf ld ar buildPackage bf ld ar
rebuildCabal :: D.GenericPackageDescription -> DevelOpts -> IO Bool rebuildCabal :: D.GenericPackageDescription -> DevelOpts -> IO Bool
rebuildCabal gpd opts rebuildCabal _gpd opts
| isCabalDev opts = do | isCabalDev opts = do
let cmd = cabalCommand opts let cmd = cabalCommand opts
putStrLn $ "Rebuilding application... (using " ++ cmd ++ ")" putStrLn $ "Rebuilding application... (using " ++ cmd ++ ")"
@ -253,6 +265,7 @@ rebuildCabal gpd opts
| otherwise = DSS.defaultBuildFlags { DSS.buildVerbosity = DSS.Flag D.silent } | otherwise = DSS.defaultBuildFlags { DSS.buildVerbosity = DSS.Flag D.silent }
tryBool $ D.build (D.localPkgDescr lbi) lbi buildFlags [] tryBool $ D.build (D.localPkgDescr lbi) lbi buildFlags []
tryBool :: IO a -> IO Bool
tryBool a = (a >> return True) `Ex.catch` \(e::Ex.SomeException) -> do tryBool a = (a >> return True) `Ex.catch` \(e::Ex.SomeException) -> do
putStrLn $ "Exception: " ++ show e putStrLn $ "Exception: " ++ show e
return False return False
@ -272,12 +285,13 @@ 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 :: [FilePath] -> [FilePath] -> FileList -> IO () watchForChanges :: MVar () -> [FilePath] -> [FilePath] -> FileList -> Int -> IO ()
watchForChanges hsSourceDirs extraFiles list = 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 return ()
else threadDelay 1000000 >> watchForChanges hsSourceDirs extraFiles list else timeout (1000000*t) (takeMVar filesModified) >>
watchForChanges filesModified hsSourceDirs extraFiles list t
checkDevelFile :: IO () checkDevelFile :: IO ()
checkDevelFile = do checkDevelFile = do
@ -337,7 +351,7 @@ ghcPackageArgs opts ghcVer cabal lib = do
else return ("-hide-all-packages" : inplaceConf : selfPkgArg lbi : depArgs lbi cbi) else return ("-hide-all-packages" : inplaceConf : selfPkgArg lbi : depArgs lbi cbi)
where where
selfPkgArg lbi = pkgArg . D.inplacePackageId . D.package . D.localPkgDescr $ lbi selfPkgArg lbi = pkgArg . D.inplacePackageId . D.package . D.localPkgDescr $ lbi
pkgArg (D.InstalledPackageId id) = "-package-id" ++ id pkgArg (D.InstalledPackageId pkgId) = "-package-id" ++ pkgId
depArgs lbi cbi = map pkgArg (deps lbi cbi) depArgs lbi cbi = map pkgArg (deps lbi cbi)
deps lbi cbi = let pkgInfo = D.inplaceInstalledPackageInfo "." "dist" cabal lib lbi cbi deps lbi cbi = let pkgInfo = D.inplaceInstalledPackageInfo "." "dist" cabal lib lbi cbi
in IPI.depends $ pkgInfo in IPI.depends $ pkgInfo
@ -374,7 +388,7 @@ lookupLdAr = do
lookupLdAr' :: IO (Maybe (FilePath, FilePath)) lookupLdAr' :: IO (Maybe (FilePath, FilePath))
lookupLdAr' = do lookupLdAr' = do
(comp, pgmc) <- D.configCompiler (Just D.GHC) Nothing Nothing D.defaultProgramConfiguration D.silent (_, pgmc) <- D.configCompiler (Just D.GHC) Nothing Nothing D.defaultProgramConfiguration D.silent
pgmc' <- D.configureAllKnownPrograms D.silent pgmc pgmc' <- D.configureAllKnownPrograms D.silent pgmc
return $ (,) <$> look D.ldProgram pgmc' <*> look D.arProgram pgmc' return $ (,) <$> look D.ldProgram pgmc' <*> look D.arProgram pgmc'
where where
@ -397,7 +411,7 @@ rawSystemFilter command args = do
_ <- forkIO $ go errh stderr _ <- forkIO $ go errh stderr
waitForProcess' ph waitForProcess' ph
-- nonblocking version -- | nonblocking version of @waitForProcess@
waitForProcess' :: ProcessHandle -> IO ExitCode waitForProcess' :: ProcessHandle -> IO ExitCode
waitForProcess' pid = go waitForProcess' pid = go
where where

54
yesod/Types.hs
View File

@ -1,54 +0,0 @@
{-# LANGUAGE TemplateHaskell #-}
module Types where
import Options
mkOptCabalDev name = option name (\o -> o
{ optionLongFlags = ["dev", "use-cabal-dev"]
, optionShortFlags = ['d']
, optionType = optionTypeBool
, optionDefault = "false"
, optionDescription = "use cabal-dev to build the package"
})
mkOptNoApi name = option name (\o -> o
{ optionLongFlags = ["no-ghc-api"]
, optionShortFlags = ['n']
, optionType = optionTypeBool
, optionDefault = "false"
, optionDescription = "do not use the GHC API to build, use `cabal build' instead"
})
mkOptApi name = option name (\o -> o
{ optionLongFlags = ["ghc-api"]
, optionShortFlags = ['a']
, optionType = optionTypeBool
, optionDefault = "false"
, optionDescription = "use the GHC API to build (faster, but experimental)"
})
mkOptSuccessHook name = option name (\o -> o
{ optionLongFlags = ["success-hook"]
, optionShortFlags = ['s']
, optionType = optionTypeMaybe optionTypeString
, optionDefault = ""
, optionDescription = "Shell command to run when compilation succeeds (e.g. 'beep')"
})
mkOptFailHook name = option name (\o -> o
{ optionLongFlags = ["fail-hook"]
, optionShortFlags = ['f']
, optionType = optionTypeMaybe optionTypeString
, optionDefault = ""
, optionDescription = "Shell command to run when compilation fails (e.g. 'beep')"
})
mkOptVerbose name = option name (\o -> o
{ optionLongFlags = ["verbose"]
, optionShortFlags = ['v']
, optionType = optionTypeBool
, optionDefault = "false"
, optionDescription = "more verbose output"
})

38
yesod/main.hs
View File

@ -51,6 +51,7 @@ data Command = Init
| Devel { _develDisableApi :: Bool | Devel { _develDisableApi :: Bool
, _develSuccessHook :: Maybe String , _develSuccessHook :: Maybe String
, _develFailHook :: Maybe String , _develFailHook :: Maybe String
, _develRescan :: Int
} }
| Test | Test
| AddHandler | AddHandler
@ -62,19 +63,19 @@ main = do
o <- execParser optParser' o <- execParser optParser'
let cabal xs = rawSystem' (cabalCommand o) xs let cabal xs = rawSystem' (cabalCommand o) xs
case optCommand o of case optCommand o of
Init -> scaffold Init -> scaffold
Configure -> cabal ["configure"] Configure -> cabal ["configure"]
Build -> touch' >> cabal ["build"] -- fixme passthrough remaining args Build -> touch' >> cabal ["build"] -- fixme passthrough remaining args
Touch -> touch' Touch -> touch'
(Devel da s f) -> devel (DevelOpts (optCabalPgm o == CabalDev) da (optVerbose o) s f) [] -- fixme, passthrough remaining args (Devel da s f r) -> devel (DevelOpts (optCabalPgm o == CabalDev) da (optVerbose o) r s f) [] -- fixme, passthrough remaining args
(Keter noRebuild) -> keter (cabalCommand o) noRebuild (Keter noRebuild) -> keter (cabalCommand o) noRebuild
Version -> do putStrLn ("yesod-core version:" ++ yesodVersion) Version -> do putStrLn ("yesod-core version:" ++ yesodVersion)
putStrLn ("yesod version:" ++ showVersion Paths_yesod.version) putStrLn ("yesod version:" ++ showVersion Paths_yesod.version)
AddHandler -> addHandler AddHandler -> addHandler
Test -> do touch' Test -> do touch'
cabal ["configure", "--enable-tests", "-flibrary-only"] cabal ["configure", "--enable-tests", "-flibrary-only"]
cabal ["build"] cabal ["build"]
cabal ["test"] cabal ["test"]
optParser' :: ParserInfo Options optParser' :: ParserInfo Options
optParser' = info (helper <*> optParser) ( fullDesc <> header "Yesod Web Framework command line utility" ) optParser' = info (helper <*> optParser) ( fullDesc <> header "Yesod Web Framework command line utility" )
@ -107,9 +108,14 @@ keterOptions :: Parser Command
keterOptions = Keter <$> switch ( long "nobuild" <> short 'n' <> help "Skip rebuilding" ) keterOptions = Keter <$> switch ( long "nobuild" <> short 'n' <> help "Skip rebuilding" )
develOptions :: Parser Command develOptions :: Parser Command
develOptions = Devel <$> switch ( long "disable-api" <> short 'd' <> help "Disable fast GHC API rebuilding") develOptions = Devel <$> switch ( long "disable-api" <> short 'd'
<*> optStr ( long "success-hook" <> short 's' <> help "Run command after rebuild succeeds") <> help "Disable fast GHC API rebuilding")
<*> optStr ( long "failure-hook" <> short 'f' <> help "Run command when rebuild fails") <*> optStr ( long "success-hook" <> short 's'
<> help "Run command after rebuild succeeds")
<*> optStr ( long "failure-hook" <> short 'f'
<> help "Run command when rebuild fails")
<*> option ( long "event-timeout" <> short 't' <> value (-1) <> metavar "N"
<> help "Force rescan of files every N seconds" )
-- | Optional @String@ argument -- | Optional @String@ argument
optStr :: Mod OptionFields (Maybe String) -> Parser (Maybe String) optStr :: Mod OptionFields (Maybe String) -> Parser (Maybe String)

2
yesod/yesod.cabal
View File

@ -131,6 +131,8 @@ executable yesod
, unordered-containers , unordered-containers
, yaml >= 0.8 && < 0.9 , yaml >= 0.8 && < 0.9
, optparse-applicative >= 0.4 && < 0.5 , optparse-applicative >= 0.4 && < 0.5
, fsnotify >= 0.0 && < 0.1
ghc-options: -Wall -threaded ghc-options: -Wall -threaded
main-is: main.hs main-is: main.hs
other-modules: Scaffolding.CodeGen other-modules: Scaffolding.CodeGen