Replace active file eatching with event based FSNotify

slides.cabal

@@ -15,7 +15,7 @@ cabal-version:       >=1.10
 
 library
   hs-source-dirs:      src
-  exposed-modules:     Pandoc, Test, Embed, Context, Utilities, Filter, Student, Shuffle
+  exposed-modules:     Watch, Pandoc, Test, Embed, Context, Utilities, Filter, Student, Shuffle
   build-depends:       base
                      , aeson
                      , random
@@ -49,6 +49,7 @@ library
                      , http-types
                      , highlighting-kate
                      , multimap
+                     , fsnotify
   default-language:    Haskell2010
 
 executable decker

src/pandoc.hs

@@ -11,6 +11,7 @@ import qualified Data.HashMap.Strict as H
 import Data.List
 import Data.Maybe
 import qualified Data.Map as M
+import qualified Data.Text as T
 import qualified Data.MultiMap as MM
 import Data.Digest.Pure.MD5
 import qualified Data.Yaml as Y
@@ -66,3 +67,5 @@ readMetaData metaFiles =
         joinMeta :: Y.Value -> Y.Value -> Y.Value
         joinMeta (Y.Object old) (Y.Object new) = Y.Object (H.union new old)
         joinMeta _ _ = throw $ YamlException "Can only join YAML objects."
+
+-- extractMetaDataFromMarkdown :: T.Text -> Y.Value 

src/utilities.hs

@@ -4,11 +4,9 @@ module Utilities
   , terminate
   , threadDelay'
   , wantRepeat
-  , waitForModificationIn
   , defaultContext
   , runShakeInContext
   , watchFiles
-  , waitForTwitch
   , dropSuffix
   , stopServer
   , startServer
@@ -50,6 +48,7 @@ import Control.Exception
 import Development.Shake
 import Development.Shake.FilePath as SFP
 import Data.Dynamic
+import Data.List
 import Data.List.Extra
 import Data.Maybe
 import Data.IORef
@@ -87,6 +86,7 @@ import Network.URI
 import Text.Highlighting.Kate.Styles
 import Context
 import Embed
+import Watch
 
 -- Find the project directory and change current directory to there. 
 -- The project directory is the first upwards directory that contains a .git directory entry.
@@ -170,9 +170,6 @@ threadDelay' = liftIO . threadDelay
 wantRepeat :: IORef Bool -> Action ()
 wantRepeat justOnce = liftIO $ writeIORef justOnce False
 
-waitForModificationIn :: [FilePath] -> Action ()
-waitForModificationIn = liftIO . waitForTwitch
-
 -- The context of program invocation consists of a list of
 -- files to watch and a possibly running local http server.
 data Context =
@@ -201,27 +198,11 @@ runShakeInContext context options rules = do
       if null files
         then return True
         else do
-          waitForTwitch files
+          waitForTwitchPassive files
           return False
 
 watchFiles = setFilesToWatch
 
--- | Actively waits for the first change to any member in the set of specified
--- | files and their parent directories, then returns.
-waitForTwitch files = do
-  startTime <- getCurrentTime
-  let dirs = map takeDirectory files
-  let filesAndDirs = Set.toList . Set.fromList $ files ++ dirs
-  whileM_ (noModificationSince startTime filesAndDirs) (threadDelay 300000)
-  where
-    noModificationSince startTime pathes = do
-      modified <- mapM (modifiedSince startTime) pathes
-      return $ not (or modified)
-    modifiedSince time path =
-      handle (\(SomeException _) -> return False) $
-      do modTime <- getModificationTime path
-         return $ diffUTCTime modTime time > 0
-
 -- | Monadic version of list concatenation.
 (<++>)
   :: Monad m

src/watch.hs

+module Watch (waitForTwitchPassive) where
+    
+-- | A non-polling file watcher based on fsnotify
+
+import Data.List
+import System.FilePath
+import System.FilePath.Glob 
+import Control.Concurrent.MVar
+import System.FSNotify
+
+-- | Wait for something to happen on one of the matching files 
+-- in one of the supplied directories.
+waitForTwitch :: [FilePath] -> [Pattern] -> IO FilePath
+waitForTwitch directories patterns = do
+    done <- newEmptyMVar
+    mgr <- startManager
+    stops <- watchIt mgr done
+    filepath <- takeMVar done
+    sequence_ stops
+    stopManager mgr
+    return filepath
+    where
+        -- Match a filepath against the supplied patterns
+        isWatchedFile event =
+            any ((flip match) (eventPath event)) patterns
+        -- Stop the watch manager and notify the main thread
+        stopWatching mgr done event = do
+            putMVar done (eventPath event)
+        -- Watch everything within the supplied dirs
+        watchInDir mgr done dir = watchTree mgr dir isWatchedFile (stopWatching mgr done)
+        watchIt mgr done = do
+            mapM (watchInDir mgr done) directories
+            
+
+twitchPatterns = map compile ["**/*.md", "**/*.yaml", "**/*.png", "**/*.jpg"]
+
+waitForTwitchPassive files = do
+    let dirs = nub (map takeDirectory files)
+    waitForTwitch dirs twitchPatterns
+
+
+
+
+
+