From 19d48343785613315582cbaf453369920a22d56b Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Mon, 15 Oct 2012 19:17:08 +0200 Subject: [PATCH] use fsnotify to watch folder --- yesod/Devel.hs | 84 +++++++++++++++++++++++++++-------------------- yesod/Types.hs | 54 ------------------------------ yesod/main.hs | 38 ++++++++++++--------- yesod/yesod.cabal | 2 ++ 4 files changed, 73 insertions(+), 105 deletions(-) delete mode 100644 yesod/Types.hs diff --git a/yesod/Devel.hs b/yesod/Devel.hs index c48c1f3d..54a55ab4 100644 --- a/yesod/Devel.hs +++ b/yesod/Devel.hs @@ -4,35 +4,36 @@ module Devel ( devel , DevelOpts(..) + , defaultDevelOpts ) where import qualified Distribution.Compiler as D +import qualified Distribution.InstalledPackageInfo as IPI import qualified Distribution.ModuleName as D +import qualified Distribution.Package as D import qualified Distribution.PackageDescription as D import qualified Distribution.PackageDescription.Parse as D import qualified Distribution.Simple.Build 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.Register as D import qualified Distribution.Simple.Setup as DSS import qualified Distribution.Simple.Utils 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.Concurrent (forkIO, threadDelay) +import Control.Concurrent.MVar (MVar, newEmptyMVar, + takeMVar, tryPutMVar) 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 qualified Data.List as L import qualified Data.Map as Map -import Data.Maybe (fromMaybe) import qualified Data.Set as Set import System.Directory @@ -42,6 +43,7 @@ import System.Exit (ExitCode (..), import System.FilePath (dropExtension, splitDirectories, takeExtension) +import System.FSNotify import System.IO (hClose, hGetLine, hIsEOF, hPutStrLn, stderr, stdout) @@ -56,8 +58,8 @@ import System.Process (ProcessHandle, readProcess, runInteractiveProcess, system, - terminateProcess, - waitForProcess) + terminateProcess) +import System.Timeout (timeout) import Build (getDeps, isNewerThan, recompDeps) @@ -79,21 +81,23 @@ removeLock :: IO () removeLock = removeFileIfExists lockFile data DevelOpts = DevelOpts - { isCabalDev :: Bool - , forceCabal :: Bool - , verbose :: Bool - , successHook :: Maybe String - , failHook :: Maybe String + { isCabalDev :: Bool + , forceCabal :: Bool + , verbose :: Bool + , eventTimeout :: Int -- negative value for no timeout + , successHook :: Maybe String + , failHook :: Maybe String } deriving (Show, Eq) cabalCommand :: DevelOpts -> FilePath cabalCommand opts | isCabalDev opts = "cabal-dev" | otherwise = "cabal" -defaultDevelOpts = DevelOpts False False False Nothing Nothing +defaultDevelOpts :: DevelOpts +defaultDevelOpts = DevelOpts False False False (-1) Nothing Nothing devel :: DevelOpts -> [String] -> IO () -devel opts passThroughArgs = do +devel opts passThroughArgs = withManager $ \manager -> do checkDevelFile writeLock @@ -110,14 +114,22 @@ devel opts passThroughArgs = do removeFileIfExists "dist/ghcargs.txt" -- these files contain the wrong data after removeFileIfExists "dist/arargs.txt" -- the configure step, remove them to force 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 writeLock exitSuccess where - mainLoop :: [FilePath] -> FilePath -> D.GenericPackageDescription -> D.Library -> (FilePath, FilePath) -> IO () - mainLoop hsSourceDirs cabal gpd lib ldar = do + mainLoop :: [FilePath] + -> MVar () + -> FilePath + -> D.GenericPackageDescription + -> D.Library + -> (FilePath, FilePath) + -> IO () + mainLoop hsSourceDirs filesModified cabal gpd lib ldar = do ghcVer <- ghcVersion rebuild <- mkRebuild gpd ghcVer cabal opts ldar forever $ do @@ -137,7 +149,7 @@ devel opts passThroughArgs = do else "Starting development server..." (_,_,_,ph) <- createProcess $ proc "runghc" devArgs watchTid <- forkIO . try_ $ do - watchForChanges hsSourceDirs [cabal] list + watchForChanges filesModified hsSourceDirs [cabal] list (eventTimeout opts) putStrLn "Stopping development server..." writeLock threadDelay 1000000 @@ -146,14 +158,14 @@ devel opts passThroughArgs = do ec <- waitForProcess' ph putStrLn $ "Exit code: " ++ show ec Ex.throwTo watchTid (userError "process finished") - watchForChanges hsSourceDirs [cabal] list + watchForChanges filesModified hsSourceDirs [cabal] list (eventTimeout opts) runBuildHook :: Maybe String -> IO () runBuildHook (Just s) = do - ret <- system s - case ret of - ExitFailure f -> putStrLn $ "Error executing hook: " ++ s - otherwise -> return () + ret <- system s + case ret of + ExitFailure _ -> putStrLn ("Error executing hook: " ++ s) + _ -> return () runBuildHook Nothing = return () {- @@ -164,7 +176,7 @@ runBuildHook Nothing = return () cabal-dev buildopts if required -} configure :: FilePath -> D.GenericPackageDescription -> DevelOpts -> IO () -configure cabal gpd opts +configure _cabalFile gpd opts | isCabalDev opts = rawSystem (cabalCommand opts) args >> return () | otherwise = do lbi <- D.configure (gpd, hookedBuildInfo) configFlags @@ -191,9 +203,9 @@ configure cabal gpd opts } cabalArgs | isCabalDev opts = map ("--cabal-install-arg=" ++) args - | otherwise = args + | otherwise = as where - args = + as = [ "-fdevel" -- legacy , "-flibrary-only" ] ++ wrapperArgs @@ -238,7 +250,7 @@ rebuildGhc bf ld ar = do buildPackage bf ld ar rebuildCabal :: D.GenericPackageDescription -> DevelOpts -> IO Bool -rebuildCabal gpd opts +rebuildCabal _gpd opts | isCabalDev opts = do let cmd = cabalCommand opts putStrLn $ "Rebuilding application... (using " ++ cmd ++ ")" @@ -253,6 +265,7 @@ rebuildCabal gpd opts | otherwise = DSS.defaultBuildFlags { DSS.buildVerbosity = DSS.Flag D.silent } tryBool $ D.build (D.localPkgDescr lbi) lbi buildFlags [] +tryBool :: IO a -> IO Bool tryBool a = (a >> return True) `Ex.catch` \(e::Ex.SomeException) -> do putStrLn $ "Exception: " ++ show e return False @@ -272,12 +285,13 @@ getFileList hsSourceDirs extraFiles = do Left (_ :: Ex.SomeException) -> (f, 0) Right fs -> (f, modificationTime fs) -watchForChanges :: [FilePath] -> [FilePath] -> FileList -> IO () -watchForChanges hsSourceDirs extraFiles list = do +watchForChanges :: MVar () -> [FilePath] -> [FilePath] -> FileList -> Int -> IO () +watchForChanges filesModified hsSourceDirs extraFiles list t = do newList <- getFileList hsSourceDirs extraFiles if list /= newList then return () - else threadDelay 1000000 >> watchForChanges hsSourceDirs extraFiles list + else timeout (1000000*t) (takeMVar filesModified) >> + watchForChanges filesModified hsSourceDirs extraFiles list t checkDevelFile :: IO () checkDevelFile = do @@ -337,7 +351,7 @@ ghcPackageArgs opts ghcVer cabal lib = do else return ("-hide-all-packages" : inplaceConf : selfPkgArg lbi : depArgs lbi cbi) where 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) deps lbi cbi = let pkgInfo = D.inplaceInstalledPackageInfo "." "dist" cabal lib lbi cbi in IPI.depends $ pkgInfo @@ -374,7 +388,7 @@ lookupLdAr = do lookupLdAr' :: IO (Maybe (FilePath, FilePath)) 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 return $ (,) <$> look D.ldProgram pgmc' <*> look D.arProgram pgmc' where @@ -397,7 +411,7 @@ rawSystemFilter command args = do _ <- forkIO $ go errh stderr waitForProcess' ph --- nonblocking version +-- | nonblocking version of @waitForProcess@ waitForProcess' :: ProcessHandle -> IO ExitCode waitForProcess' pid = go where diff --git a/yesod/Types.hs b/yesod/Types.hs deleted file mode 100644 index c1d43cd8..00000000 --- a/yesod/Types.hs +++ /dev/null @@ -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" - }) - diff --git a/yesod/main.hs b/yesod/main.hs index 3fcdaaa1..1f6d250d 100755 --- a/yesod/main.hs +++ b/yesod/main.hs @@ -51,6 +51,7 @@ data Command = Init | Devel { _develDisableApi :: Bool , _develSuccessHook :: Maybe String , _develFailHook :: Maybe String + , _develRescan :: Int } | Test | AddHandler @@ -62,19 +63,19 @@ main = do o <- execParser optParser' let cabal xs = rawSystem' (cabalCommand o) xs case optCommand o of - Init -> scaffold - Configure -> cabal ["configure"] - Build -> touch' >> cabal ["build"] -- fixme passthrough remaining args - Touch -> touch' - (Devel da s f) -> devel (DevelOpts (optCabalPgm o == CabalDev) da (optVerbose o) s f) [] -- fixme, passthrough remaining args - (Keter noRebuild) -> keter (cabalCommand o) noRebuild - Version -> do putStrLn ("yesod-core version:" ++ yesodVersion) - putStrLn ("yesod version:" ++ showVersion Paths_yesod.version) - AddHandler -> addHandler - Test -> do touch' - cabal ["configure", "--enable-tests", "-flibrary-only"] - cabal ["build"] - cabal ["test"] + Init -> scaffold + Configure -> cabal ["configure"] + Build -> touch' >> cabal ["build"] -- fixme passthrough remaining args + Touch -> touch' + (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 + Version -> do putStrLn ("yesod-core version:" ++ yesodVersion) + putStrLn ("yesod version:" ++ showVersion Paths_yesod.version) + AddHandler -> addHandler + Test -> do touch' + cabal ["configure", "--enable-tests", "-flibrary-only"] + cabal ["build"] + cabal ["test"] optParser' :: ParserInfo Options 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" ) develOptions :: Parser Command -develOptions = Devel <$> switch ( long "disable-api" <> short 'd' <> help "Disable fast GHC API rebuilding") - <*> optStr ( long "success-hook" <> short 's' <> help "Run command after rebuild succeeds") - <*> optStr ( long "failure-hook" <> short 'f' <> help "Run command when rebuild fails") +develOptions = Devel <$> switch ( long "disable-api" <> short 'd' + <> help "Disable fast GHC API rebuilding") + <*> 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 optStr :: Mod OptionFields (Maybe String) -> Parser (Maybe String) diff --git a/yesod/yesod.cabal b/yesod/yesod.cabal index 207de629..784d369c 100644 --- a/yesod/yesod.cabal +++ b/yesod/yesod.cabal @@ -131,6 +131,8 @@ executable yesod , unordered-containers , yaml >= 0.8 && < 0.9 , optparse-applicative >= 0.4 && < 0.5 + , fsnotify >= 0.0 && < 0.1 + ghc-options: -Wall -threaded main-is: main.hs other-modules: Scaffolding.CodeGen