compiler: reuse derived item properties from last compilation

A benchmark on an already bulit gallery with ~600 pictures shows a ~90% speedup:

Before:

  Time (mean ± σ):      2.879 s ±  0.125 s    [User: 14.686 s, System: 5.511 s]
  Range (min … max):    2.774 s …  3.203 s    10 runs

After:

  Time (mean ± σ):     289.5 ms ±  15.1 ms    [User: 596.1 ms, System: 359.3 ms]
  Range (min … max):   272.8 ms … 323.0 ms    10 runs

GitHub: closes #97

6 files changed, 185 insertions, 104 deletions

diff --git a/compiler/src/Caching.hs b/compiler/src/Caching.hs
index b2b1ee1..c2b5a43 100644
--- a/compiler/src/Caching.hs
+++ b/compiler/src/Caching.hs
@@ -18,39 +18,59 @@
 
 module Caching
   ( Cache
-  , skipCache
-  , withCache
+  , noCache
+  , ItemCache
+  , buildItemCache
+  , useCached
   ) where
 
 
 import Control.Monad (when)
+import qualified Data.Map.Strict as Map
 import System.Directory (removePathForcibly, doesDirectoryExist, doesFileExist)
 
 import FileProcessors (FileProcessor)
+import Resource (GalleryItem(..), flattenGalleryTree)
 import Files
 
 
-type Cache = FileProcessor -> FileProcessor
+type Cache a = FileProcessor a -> FileProcessor a
 
-skipCache :: Cache
-skipCache processor inputPath outputPath =
-  removePathForcibly outputPath
-  >> processor inputPath outputPath
 
-withCache :: Cache
-withCache processor inputPath outputPath =
+noCache :: Cache a
+noCache processor itemPath resPath inputFsPath outputFsPath =
+  removePathForcibly outputFsPath
+  >> processor itemPath resPath inputFsPath outputFsPath
+
+
+type ItemCache = Path -> Maybe GalleryItem
+
+buildItemCache :: Maybe GalleryItem -> ItemCache
+buildItemCache cachedItems = lookupCache
+  where
+    withKey item = (webPath $ Resource.path item, item)
+    cachedItemList = maybe [] flattenGalleryTree cachedItems
+    cachedMap = Map.fromList (map withKey cachedItemList)
+    lookupCache path = Map.lookup (webPath path) cachedMap
+
+useCached :: ItemCache -> (GalleryItem -> a) -> Cache a
+useCached cache propGetter processor itemPath resPath inputFsPath outputFsPath =
   do
-    isDir <- doesDirectoryExist outputPath
-    when isDir $ removePathForcibly outputPath
+    isDir <- doesDirectoryExist outputFsPath
+    when isDir $ removePathForcibly outputFsPath
 
-    fileExists <- doesFileExist outputPath
+    fileExists <- doesFileExist outputFsPath
     if fileExists then
       do
-        needUpdate <- isOutdated True inputPath outputPath
-        if needUpdate then update else skip
+        needUpdate <- isOutdated True inputFsPath outputFsPath
+        case (needUpdate, cache itemPath) of
+          (False, Just props) -> fromCache props
+          _ -> update
     else
       update
 
   where
-    update = processor inputPath outputPath
-    skip = putStrLn $ "Skipping:\t" ++ outputPath
+    update = processor itemPath resPath inputFsPath outputFsPath
+    fromCache props =
+      putStrLn ("From cache:\t" ++ outputFsPath)
+      >> return (propGetter props)
diff --git a/compiler/src/Compiler.hs b/compiler/src/Compiler.hs
index 92e6ed6..1ec55c5 100644
--- a/compiler/src/Compiler.hs
+++ b/compiler/src/Compiler.hs
@@ -24,17 +24,25 @@ module Compiler
 
 import GHC.Generics (Generic)
 import Control.Monad (liftM2, when)
+import Data.Bool (bool)
 import Data.Maybe (fromMaybe)
 import System.FilePath ((</>))
 import qualified System.FilePath.Glob as Glob
-import System.Directory (canonicalizePath)
+import System.Directory (canonicalizePath, doesFileExist)
 
 import Data.Aeson (ToJSON, FromJSON)
 import qualified Data.Aeson as JSON
 
 import Config
 import Input (InputTree, readInputTree, filterInputTree, sidecar, tags)
-import Resource (GalleryItem, buildGalleryTree, galleryCleanupResourceDir)
+import Resource
+  ( GalleryItem
+  , GalleryItemProps
+  , Thumbnail
+  , buildGalleryTree
+  , galleryCleanupResourceDir
+  , properties
+  , thumbnail)
 import Files
   ( FileName
   , FSNode(..)
@@ -43,8 +51,8 @@ import Files
   , nodeName
   , filterDir
   , ensureParentDir )
-import ItemProcessors (itemFileProcessor, thumbnailFileProcessor)
-import Caching (skipCache, withCache)
+import ItemProcessors (ItemProcessor, itemFileProcessor, thumbnailFileProcessor)
+import Caching (Cache, noCache, buildItemCache, useCached)
 
 
 defaultGalleryConf :: String
@@ -72,6 +80,15 @@ writeJSON outputPath object =
     putStrLn $ "Generating:\t" ++ outputPath
     ensureParentDir JSON.encodeFile outputPath object
 
+loadGalleryIndex :: FilePath -> IO (Maybe GalleryIndex)
+loadGalleryIndex path =
+  doesFileExist path >>= bool (return Nothing) decodeIndex
+  where
+    decodeIndex =
+      JSON.eitherDecodeFileStrict path
+      >>= either (\err -> warn err >> return Nothing) (return . Just)
+    warn = putStrLn . ("Warning:\tUnable to reuse existing index as cache: " ++)
+
 
 (&&&) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
 (&&&) = liftM2 (&&)
@@ -126,14 +143,17 @@ compileGallery configPath inputDirPath outputDirPath outputIndexPath excludedDir
     inputTree <- readInputTree sourceTree
     let curatedInputTree = filterInputTree (inputTreeFilter config) inputTree
 
-    let cache = if rebuildAll then skipCache else withCache
-    let itemProc = itemProcessor config cache
-    let thumbnailProc = thumbnailProcessor config cache
+    let galleryIndexPath = outputGalleryIndex outputIndexPath
+    cachedIndex <- loadCachedIndex galleryIndexPath
+    let cache = mkCache cachedIndex
+
+    let itemProc = itemProcessor config (cache Resource.properties)
+    let thumbnailProc = thumbnailProcessor config (cache Resource.thumbnail)
     let galleryBuilder = buildGalleryTree itemProc thumbnailProc (tagsFromDirectories config)
     resources <- galleryBuilder curatedInputTree
 
     when cleanOutput $ galleryCleanupResourceDir resources outputDirPath
-    writeJSON (outputGalleryIndex outputIndexPath) $ GalleryIndex (viewerConfig config) resources
+    writeJSON galleryIndexPath $ GalleryIndex (viewerConfig config) resources
 
   where
     inputGalleryConf :: FilePath -> FilePath
@@ -144,10 +164,25 @@ compileGallery configPath inputDirPath outputDirPath outputIndexPath excludedDir
     outputGalleryIndex "" = outputDirPath </> defaultIndexFile
     outputGalleryIndex file = file
 
+    loadCachedIndex :: FilePath -> IO (Maybe GalleryIndex)
+    loadCachedIndex galleryIndexPath =
+      if rebuildAll
+        then return Nothing
+        else loadGalleryIndex galleryIndexPath
+
+    mkCache :: Maybe GalleryIndex -> (GalleryItem -> a) -> Cache a
+    mkCache refGalleryIndex =
+      if rebuildAll
+        then const noCache
+        else useCached (buildItemCache $ fmap tree refGalleryIndex)
+
+    itemProcessor :: GalleryConfig -> Cache GalleryItemProps -> ItemProcessor GalleryItemProps
     itemProcessor config cache =
       itemFileProcessor
         (pictureMaxResolution config) cache
         inputDirPath outputDirPath itemsDir
+
+    thumbnailProcessor :: GalleryConfig -> Cache (Maybe Thumbnail) -> ItemProcessor (Maybe Thumbnail)
     thumbnailProcessor config cache =
       thumbnailFileProcessor
         (thumbnailMaxResolution config) cache
diff --git a/compiler/src/FileProcessors.hs b/compiler/src/FileProcessors.hs
index 8ea04d1..5c4e1c8 100644
--- a/compiler/src/FileProcessors.hs
+++ b/compiler/src/FileProcessors.hs
@@ -18,12 +18,18 @@
 
 module FileProcessors
   ( FileProcessor
+  , transformThenDescribe
+  , copyResource
+  , noopProcessor
+  , FileTransformer
   , copyFileProcessor
   , resizePictureUpTo
   , resourceAt
   , getImageResolution
-  , ItemDescriber
+  , FileDescriber
+  , getResProps
   , getPictureProps
+  , getThumbnailProps
   ) where