Explicitly watch for changes before recompiling

project_template/default/foo.cabal

@@ -18,9 +18,8 @@ Executable projname
   hs-source-dirs: src
   main-is: Main.hs
 
-  if !flag(development)
-    cpp-options: -DPRODUCTION
-  else
+  if flag(development)
+    cpp-options: -DDEVELOPMENT
     build-depends: hint >= 0.3.2 && < 0.4
 
   Build-depends:

project_template/default/src/Main.hs

@@ -3,61 +3,63 @@
 
 {-|
 
-This is the entry point for this web server application.  It supports easily
-switching between interpreting source and running statically compiled code.
-
-In either mode, the generated program should be run from the root of the
-project tree.  It locates its templates, static content, and source files in 
-development mode, relative to the current working directory when it is run.
-
-When compiled without the production flag, only changes to the libraries, your
-cabal file, or this file should require a recompile to be picked up.
-Everything else is interpreted at runtime.  There are a few consequences of
-this.
-
-First, this is much slower.  Running the interpreter seems to take about
-300ms, regardless of the simplicity of the loaded code.  The results of the
-interpreter process are cached for a few seconds, to hopefully ensure that
-the the interpreter is only invoked once for each load of a page and the
-resources it depends on.
-
-Second, the generated server binary is MUCH larger, since it links in the GHC
-API (via the hint library).
-
-Third, it results in initialization\/cleanup code defined by the @Initializer@
-being called for each request.  This is to ensure that the current state is
-compatible with the running action.  If your application state takes a long
-time to load or clean up, the penalty will be visible.
-
-Fourth, and the reason you would ever want to actually compile without
-production mode, is that it enables a *much* faster development cycle. You can
-simply edit a file, save your changes, and hit reload to see your changes
-reflected immediately.
-
-When this is compiled with the production flag, all the actions are statically
-compiled in.  This results in much faster execution, a smaller binary size,
-only running initialization and cleanup once per application run, and having
-to recompile the server for any code change.
+This is the entry point for this web server application.  It supports
+easily switching between interpreting source and running statically
+compiled code.
+
+In either mode, the generated program should be run from the root of
+the project tree.  When it is run, it locates its templates, static
+content, and source files in development mode, relative to the current
+working directory.
+
+When compiled with the development flag, only changes to the
+libraries, your cabal file, or this file should require a recompile to
+be picked up.  Everything else is interpreted at runtime.  There are a
+few consequences of this.
+
+First, this is much slower.  Running the interpreter takes a
+significant chunk of time (a couple tenths of a second on the author's
+machine, at this time), regardless of the simplicity of the loaded
+code.  In order to recompile and re-load server state as infrequently
+as possible, the source directories are watched for updates, as are
+any extra directories specified below.
+
+Second, the generated server binary is MUCH larger, since it links in
+the GHC API (via the hint library).
+
+Third, and the reason you would ever want to actually compile with
+development mode, is that it enables a faster development cycle. You
+can simply edit a file, save your changes, and hit reload to see your
+changes reflected immediately.
+
+When this is compiled without the development flag, all the actions
+are statically compiled in.  This results in faster execution, a
+smaller binary size, and having to recompile the server for any code
+change.
 
 -}
 
 module Main where
 
-#ifdef PRODUCTION
-import           Snap.Extension.Server
-#else
+#ifdef DEVELOPMENT
 import           Snap.Extension.Loader.Devel
 import           Snap.Http.Server (quickHttpServe)
+#else
+import           Snap.Extension.Server
 #endif
 
 import           Application
 import           Site
 
 main :: IO ()
-#ifdef PRODUCTION
-main = quickHttpServe applicationInitializer site
-#else
+#ifdef DEVELOPMENT
 main = do
-    snap <- $(loadSnapTH 'applicationInitializer 'site)
+    -- All source directories will be watched for updates
+    -- automatically.  If any extra directories should be watched for
+    -- updates, include them here.
+    snap <- $(let extraWatcheDirs = ["resources/templates"]
+              in loadSnapTH 'applicationInitializer 'site extraWatcheDirs)
     quickHttpServe snap
+#else
+main = quickHttpServe applicationInitializer site
 #endif

project_template/default/src/Site.hs

@@ -31,7 +31,7 @@ import           Application
 index :: Application ()
 index = ifTop $ heistLocal (bindSplices indexSplices) $ render "index"
   where
-    indexSplices = 
+    indexSplices =
         [ ("start-time",   startTimeSplice)
         , ("current-time", currentTimeSplice)
         ]

snap.cabal

@@ -43,7 +43,8 @@ Library
 
   other-modules:
     Snap.Extension.Loader.Devel.Evaluator,
-    Snap.Extension.Loader.Devel.Signal
+    Snap.Extension.Loader.Devel.Signal,
+    Snap.Extension.Loader.Devel.TreeWatcher
 
   build-depends:
     base >= 4 && < 5,

src/Snap/Extension/Loader/Devel.hs

@@ -9,6 +9,8 @@ module Snap.Extension.Loader.Devel
   ( loadSnapTH
   ) where
 
+import           Control.Monad (liftM2)
+
 import           Data.List (groupBy, intercalate, isPrefixOf, nub)
 import           Data.Maybe (catMaybes)
 import           Data.Time.Clock (diffUTCTime, getCurrentTime)
@@ -25,6 +27,7 @@ import           Snap.Types
 import           Snap.Extension (runInitializerWithoutReloadAction)
 import           Snap.Extension.Loader.Devel.Signal
 import           Snap.Extension.Loader.Devel.Evaluator
+import           Snap.Extension.Loader.Devel.TreeWatcher
 
 ------------------------------------------------------------------------------
 -- | This function derives all the information necessary to use the
@@ -33,35 +36,31 @@ import           Snap.Extension.Loader.Devel.Evaluator
 --
 -- This could be considered a TH wrapper around a function
 --
--- > loadSnap :: Initializer s -> SnapExtend s () -> IO (Snap ())
+-- > loadSnap :: Initializer s -> SnapExtend s () -> [String] -> IO (Snap ())
 --
 -- with a magical implementation.
 --
--- The returned Snap action runs the 'Initializer', runs the 'Snap' handler,
--- and does the cleanup.  This means that the whole application state will be
--- loaded and unloaded for each request.  To make this worthwhile, those steps
--- should be made quite fast.
---
 -- The upshot is that you shouldn't need to recompile your server
 -- during development unless your .cabal file changes, or the code
 -- that uses this splice changes.
-loadSnapTH :: Name -> Name -> Q Exp
-loadSnapTH initializer action = do
+loadSnapTH :: Name -> Name -> [String] -> Q Exp
+loadSnapTH initializer action additionalWatchDirs = do
     args <- runIO getArgs
 
     let initMod = nameModule initializer
         initBase = nameBase initializer
         actMod = nameModule action
         actBase = nameBase action
 
-        modules = catMaybes [initMod, actMod]
         opts = getHintOpts args
+        modules = catMaybes [initMod, actMod]
+        srcPaths = additionalWatchDirs ++ getSrcPaths args
 
     -- The let in this block causes an extra static type check that the
     -- types of the names passed in were correct at compile time.
     [| let _ = runInitializerWithoutReloadAction $(varE initializer)
                                                  $(varE action)
-       in hintSnap opts modules initBase actBase |]
+       in hintSnap opts modules srcPaths initBase actBase |]
 
 
 ------------------------------------------------------------------------------
@@ -89,6 +88,14 @@ getHintOpts args = removeBad opts
     init' xs = init xs
 
 
+------------------------------------------------------------------------------
+-- | This function extracts the source paths from the compilation args
+getSrcPaths :: [String] -> [String]
+getSrcPaths = filter (not . null) . map (drop 2) . filter srcArg
+  where
+    srcArg x = "-i" `isPrefixOf` x && not ("-idist" `isPrefixOf` x)
+
+
 ------------------------------------------------------------------------------
 -- | This function creates the Snap handler that actually is
 -- responsible for doing the dynamic loading of actions via hint,
@@ -97,12 +104,6 @@ getHintOpts args = removeBad opts
 -- and caches the interpreter results for a short time before allowing
 -- it to run again.
 --
--- This constructs an expression of type Snap (), that is essentially
---
--- > bracketSnap initialization cleanup handler
---
--- for the values of initialization, cleanup, and handler passed in.
---
 -- Generally, this won't be called manually.  Instead, loadSnapTH will
 -- generate a call to it at compile-time, calculating all the
 -- arguments from its environment.
@@ -112,36 +113,41 @@ hintSnap :: [String] -- ^ A list of command-line options for the interpreter
                      -- modules which contain the initialization,
                      -- cleanup, and handler actions.  Everything else
                      -- they require will be loaded transitively.
+         -> [String] -- ^ A list of paths to watch for updates
          -> String   -- ^ The name of the initializer action
          -> String   -- ^ The name of the SnapExtend action
          -> IO (Snap ())
-hintSnap opts modules initialization handler = do
-    let action = intercalate " " [ "runInitializerWithoutReloadAction"
-                                 , initialization
-                                 , handler
-                                 ]
-        interpreter = do
-            loadModules . nub $ modules
-            let imports = "Prelude" :
-                          "Snap.Extension" :
-                          "Snap.Types" :
-                          modules
-            setImports . nub $ imports
-
-            interpret action (as :: HintLoadable)
-
-        loadInterpreter = unsafeRunInterpreterWithArgs opts interpreter
-
-        formatOnError (Left err) = error $ format err
-        formatOnError (Right a) = a
-
-        loader = formatOnError `fmap` protectHandlers loadInterpreter
-
-        test prevTime = do
-            now <- getCurrentTime
-            return $ diffUTCTime now prevTime < 4
-
-    protectedHintEvaluator getCurrentTime test loader
+hintSnap opts modules srcPaths initialization handler =
+    protectedHintEvaluator initialize test loader
+  where
+    action = intercalate " " [ "runInitializerWithoutReloadAction"
+                             , initialization
+                             , handler
+                             ]
+    interpreter = do
+        loadModules . nub $ modules
+        let imports = "Prelude" :
+                      "Snap.Extension" :
+                      "Snap.Types" :
+                      modules
+        setImports . nub $ imports
+
+        interpret action (as :: HintLoadable)
+
+    loadInterpreter = unsafeRunInterpreterWithArgs opts interpreter
+
+    formatOnError (Left err) = error $ format err
+    formatOnError (Right a) = a
+
+    loader = formatOnError `fmap` protectHandlers loadInterpreter
+
+    initialize = liftM2 (,) getCurrentTime $ getTreeStatus srcPaths
+
+    test (prevTime, ts) = do
+        now <- getCurrentTime
+        if diffUTCTime now prevTime < 3
+            then return True
+            else checkTreeStatus ts
 
 
 ------------------------------------------------------------------------------

src/Snap/Extension/Loader/Devel/Evaluator.hs

@@ -38,7 +38,7 @@ type HintLoadable = IO (Snap (), IO ())
 --
 -- If an exception is raised during the processing of the action, it
 -- will be thrown to all waiting threads, and for all requests made
--- before the delay time has expired after the exception was raised.
+-- before the recompile condition is reached.
 protectedHintEvaluator :: forall a.
                           IO a
                        -> (a -> IO Bool)

src/Snap/Extension/Loader/Devel/TreeWatcher.hs

@@ -0,0 +1,46 @@
+module Snap.Extension.Loader.Devel.TreeWatcher
+    ( TreeStatus
+    , getTreeStatus
+    , checkTreeStatus
+    ) where
+
+import Control.Applicative
+
+import System.Directory
+import System.Directory.Tree
+
+import System.Time
+
+
+------------------------------------------------------------------------------
+-- | An opaque representation of the contents and last modification
+-- times of a forest of directory trees.
+data TreeStatus = TS [FilePath] [AnchoredDirTree ClockTime]
+
+
+------------------------------------------------------------------------------
+-- | Create a 'TreeStatus' for later checking with 'checkTreeStatus'
+getTreeStatus :: [FilePath] -> IO TreeStatus
+getTreeStatus = liftA2 (<$>) TS readModificationTimes
+
+
+------------------------------------------------------------------------------
+-- | Checks that all the files present in the initial set of paths are
+-- the exact set of files currently present, with unchanged modifcations times
+checkTreeStatus :: TreeStatus -> IO Bool
+checkTreeStatus (TS paths entries) = check <$> readModificationTimes paths
+  where
+    check = and . zipWith adtEq entries
+    adtEq (n1 :/ dt1) (n2 :/ dt2) = n1 == n2 && dtEq dt1 dt2
+
+    dtEq (Dir n1 d1) (Dir n2 d2) = n1 == n2 && and (zipWith dtEq d1 d2)
+    dtEq (File n1 t1) (File n2 t2) = n1 == n2 && t1 == t2
+    dtEq _ _ = False
+
+
+------------------------------------------------------------------------------
+-- | This is the core of the functions in this module.  It converts a
+-- list of filepaths into a list of 'AnchoredDirTree' annotated with
+-- the modification times of the files located in those paths.
+readModificationTimes :: [FilePath] -> IO [AnchoredDirTree ClockTime]
+readModificationTimes = mapM $ readDirectoryWith getModificationTime