Implement shake caching (#66)

* Add fsatrace to nix
* Use cacheActionWith to prevent rebuilds
* Log whenever a HTML file is written
* Change the type signature of `SourceReader` accordingly

CHANGELOG.md

@@ -8,6 +8,8 @@
 - API: Expose `ribInputDir` and `ribOutputDir` for use in custom Shake actions
 - Fix #63: create intermediate directories when generating post HTML
 - Advance nixpkgs; require Shake >=0.18.4
+- Fix unnecessary rebuild of all files when only one file changed
+  - Use caching (via Shake's `cacheActionWith`), to avoid writing HTML to disk until it has changed.
 
 ## 0.5.0.0
 

default.nix

@@ -76,6 +76,7 @@ haskellPackages.developPackage {
         (t.flip h.addBuildTools) (with haskellPackages;
           [ cabal-install
             ghcid
+            pkgs.fsatrace  # Used by Shake.Development.Forward
           ]);
     in (t.flip t.pipe) [
       addExtraDeps

src/Rib/App.hs

@@ -20,7 +20,7 @@ import Development.Shake
 import Development.Shake.Forward (shakeForward)
 import Path
 import qualified Rib.Server as Server
-import Rib.Shake (Dirs (..))
+import Rib.Shake (RibSettings (..))
 import System.Console.CmdArgs
 import System.FSNotify (watchTree, withManager)
 
@@ -80,11 +80,15 @@ runWith :: Path Rel Dir -> Path Rel Dir -> Action () -> App -> IO ()
 runWith src dst buildAction = \case
   WatchAndGenerate -> withManager $ \mgr -> do
     -- Begin with a *full* generation as the HTML layout may have been changed.
-    runWith src dst buildAction $ Generate True
+    -- TODO: This assumption is not true when running the program from compiled
+    -- binary (as opposed to say via ghcid) as the HTML layout has become fixed
+    -- by being part of the binary. In this scenario, we should not do full
+    -- generation (i.e., toggle the bool here to False).
+    runShake True
     -- And then every time a file changes under the current directory
-    putStrLn $ "[Rib] Watching " <> toFilePath src
+    putStrLn $ "[Rib] Watching " <> toFilePath src <> " for changes"
     void $ watchTree mgr (toFilePath src) (const True) $ \_ -> do
-      runWith src dst buildAction (Generate False)
+      runShake False
         `catch` \(e :: SomeException) -> putStrLn $ show e
     -- Wait forever, effectively.
     forever $ threadDelay maxBound
@@ -92,11 +96,14 @@ runWith src dst buildAction = \case
     concurrently_
       (unless dw $ runWith src dst buildAction WatchAndGenerate)
       (Server.serve p $ toFilePath dst)
-  Generate fullGen ->
-    flip shakeForward buildAction $
-      shakeOptions
-        { shakeVerbosity = Chatty,
-          shakeRebuild = bool [] [(RebuildNow, "**")] fullGen,
-          shakeLintInside = [toFilePath src, toFilePath dst],
-          shakeExtra = addShakeExtra (Dirs (src, dst)) (shakeExtra shakeOptions)
-        }
+  Generate fullGen -> do
+    runShake fullGen
+  where
+    runShake fullGen =
+      flip shakeForward buildAction $
+        shakeOptions
+          { shakeVerbosity = Verbose,
+            shakeRebuild = bool [] [(RebuildNow, "**")] fullGen,
+            shakeLintInside = [""],
+            shakeExtra = addShakeExtra (RibSettings src dst) (shakeExtra shakeOptions)
+          }

src/Rib/Parser/MMark.hs

@@ -43,8 +43,8 @@ parsePure k s = case MMark.parse k s of
   Left e -> Left $ toText $ M.errorBundlePretty e
   Right doc -> Right $ MMark.useExtensions exts $ useTocExt doc
 
-parseIO :: MonadIO m => Path b File -> m (Either Text MMark)
-parseIO f = parsePure (toFilePath f) <$> readFileText (toFilePath f)
+parseIO :: MonadIO m => Path Rel File -> Text -> m (Either Text MMark)
+parseIO k s = pure $ parsePure (toFilePath k) s
 
 -- | Get the first image in the document if one exists
 getFirstImg :: MMark -> Maybe URI

src/Rib/Parser/Pandoc.hs

@@ -51,9 +51,8 @@ parsePure fmt s =
     runPure'
     $ readPandocFormat fmt readerSettings s
 
-parseIO :: MonadIO m => PandocFormat -> Path b File -> m (Either Text Pandoc)
-parseIO fmt f = fmap (first show) $ runExceptT $ do
-  content <- readFileText (toFilePath f)
+parseIO :: MonadIO m => PandocFormat -> Path Rel File -> Text -> m (Either Text Pandoc)
+parseIO fmt _k content = fmap (first show) $ runExceptT $ do
   v' <- runIO' $ readPandocFormat fmt readerSettings content
   liftIO $ walkM includeSources v'
   where

src/Rib/Shake.hs

@@ -12,37 +12,39 @@ module Rib.Shake
     buildHtmlMulti,
     buildHtml,
 
-    -- * Read helpers
-    readSourceMulti,
-
     -- * Misc
-    Dirs (..),
+    RibSettings (..),
     ribInputDir,
     ribOutputDir,
   )
 where
 
 import Development.Shake
+import Development.Shake.Forward
 import Lucid (Html)
 import qualified Lucid
 import Path
 import Path.IO
 import Rib.Source
 
-data Dirs = Dirs (Path Rel Dir, Path Rel Dir)
+data RibSettings
+  = RibSettings
+      { _ribSettings_inputDir :: Path Rel Dir,
+        _ribSettings_outputDir :: Path Rel Dir
+      }
   deriving (Typeable)
 
-getDirs :: Action (Path Rel Dir, Path Rel Dir)
-getDirs = getShakeExtra >>= \case
-  Just (Dirs d) -> return d
-  Nothing -> fail "Input output directories are not initialized"
+ribSettings :: Action RibSettings
+ribSettings = getShakeExtra >>= \case
+  Just v -> pure v
+  Nothing -> fail "RibSettings not initialized"
 
 ribInputDir :: Action (Path Rel Dir)
-ribInputDir = fst <$> getDirs
+ribInputDir = _ribSettings_inputDir <$> ribSettings
 
 ribOutputDir :: Action (Path Rel Dir)
 ribOutputDir = do
-  output <- snd <$> getDirs
+  output <- _ribSettings_outputDir <$> ribSettings
   liftIO $ createDirIfMissing True output
   return output
 
@@ -68,43 +70,43 @@ buildHtmlMulti ::
   (Source repr -> Html ()) ->
   -- | Result
   Action [Source repr]
-buildHtmlMulti pat parser r = do
-  srcs <- readSourceMulti pat parser
-  void $ forP srcs $ \src -> do
-    outfile <- liftIO $ replaceExtension ".html" $ sourcePath src
-    buildHtml outfile $ r src
-  pure srcs
-
--- | Like `readSource'` but operates on multiple files
-readSourceMulti ::
-  -- | Source file patterns
-  [Path Rel File] ->
-  -- | How to parse the source
-  SourceReader repr ->
-  -- | Result
-  Action [Source repr]
-readSourceMulti pats parser = do
+buildHtmlMulti pats parser r = do
   input <- ribInputDir
   fs <- getDirectoryFiles' input pats
   forP fs $ \k -> do
     let f = input </> k
-    need $ toFilePath <$> [f]
-    readSource parser k f >>= \case
+    content <- fmap toText <$> readFile' $ toFilePath f
+    -- NOTE: We don't really use cacheActionWith prior to parsing content,
+    -- because the parsed representation (`repr`) may not always have instances
+    -- for Typeable/Binary/Generic (for example, MMark does not expose its
+    -- structure.). Consequently we are forced to cache merely the HTML writing
+    -- stage (see buildHtml').
+    readSource parser k content >>= \case
       Left e ->
-        fail $ "Error converting " <> toFilePath k <> " to HTML: " <> show e
-      Right v -> pure v
+        fail $ "Error parsing source " <> toFilePath k <> ": " <> show e
+      Right src -> do
+        outfile <- liftIO $ replaceExtension ".html" k
+        writeFileCached outfile $ toString $ Lucid.renderText $ r src
+        pure src
 
--- | Build a single HTML file with the given value
+-- | Build a single HTML file with the given HTML value
+--
+-- The HTML text value will be cached, so subsequent writes of the same value
+-- will be skipped.
 buildHtml :: Path Rel File -> Html () -> Action ()
-buildHtml f html = do
-  output <- ribOutputDir
-  writeHtml (output </> f) html
-  where
-    writeHtml :: MonadIO m => Path b File -> Html () -> m ()
-    writeHtml p htmlVal = do
-      -- TODO: Is there a way to make Shake automatically do this for us?
-      createDirIfMissing True $ parent p
-      writeFileLText (toFilePath p) $! Lucid.renderText htmlVal
+buildHtml f = writeFileCached f . toString . Lucid.renderText
+
+-- | Like writeFile' but uses `cacheAction`.
+--
+-- Also, always writes under ribOutputDir
+writeFileCached :: Path Rel File -> String -> Action ()
+writeFileCached k s = do
+  f <- fmap (toFilePath . (</> k)) ribOutputDir
+  let cacheClosure = (f, s)
+      cacheKey = ("writeFileCached" :: Text, f)
+  cacheActionWith cacheKey cacheClosure $ do
+    writeFile' f $! s
+    putInfo $ "W " <> f
 
 -- | Like `getDirectoryFiles` but works with `Path`
 getDirectoryFiles' :: Path b Dir -> [Path Rel File] -> Action [Path Rel File]

src/Rib/Source.hs

@@ -50,12 +50,12 @@ sourceUrl doc = toText $ toFilePath ([absdir|/|] </> (sourcePath doc)) -<.> ".ht
 
 -- | A function that parses a source representation out of the given file
 type SourceReader repr =
-  forall m b. MonadIO m => Path b File -> m (Either Text repr)
+  forall m. MonadIO m => Path Rel File -> Text -> m (Either Text repr)
 
 readSource ::
   MonadIO m =>
   SourceReader repr ->
   Path Rel File ->
-  Path b File ->
+  Text ->
   m (Either Text (Source repr))
-readSource r k f = fmap (Source k) <$> r f
+readSource r k f = fmap (Source k) <$> r k f