compiler: add option to add implicit directory tags

GitHub: closes #7

4 files changed, 22 insertions, 11 deletions

diff --git a/compiler/src/Compiler.hs b/compiler/src/Compiler.hs
index f15192f..9572d50 100644
--- a/compiler/src/Compiler.hs
+++ b/compiler/src/Compiler.hs
@@ -74,7 +74,7 @@ compileGallery inputDirPath outputDirPath rebuildAll =
 
     let itemProc = itemProcessor (pictureMaxResolution config) cache
     let thumbnailProc = thumbnailProcessor (thumbnailResolution config) cache
-    let galleryBuilder = buildGalleryTree dirProcessor itemProc thumbnailProc
+    let galleryBuilder = buildGalleryTree dirProcessor itemProc thumbnailProc (implicitDirectoryTag config)
     resources <- galleryBuilder (galleryName config) inputTree
 
     galleryCleanupResourceDir resources outputDirPath
diff --git a/compiler/src/Config.hs b/compiler/src/Config.hs
index c75ab01..d025afd 100644
--- a/compiler/src/Config.hs
+++ b/compiler/src/Config.hs
@@ -42,6 +42,7 @@ import Resource (Resolution(..))
 
 data CompilerConfig = CompilerConfig
   { galleryName :: String
+  , implicitDirectoryTag :: Bool
   , thumbnailResolution :: Resolution
   , pictureMaxResolution :: Maybe Resolution
   } deriving (Generic, Show)
@@ -49,6 +50,7 @@ data CompilerConfig = CompilerConfig
 instance FromJSON CompilerConfig where
   parseJSON = withObject "CompilerConfig" $ \v -> CompilerConfig
     <$> v .:? "galleryName" .!= "Gallery"
+    <*> v .:? "implicitDirectoryTag" .!= False
     <*> v .:? "thumbnailResolution" .!= (Resolution 400 400)
     <*> v .:? "pictureMaxResolution"
 
diff --git a/compiler/src/Files.hs b/compiler/src/Files.hs
index ed082ba..a6649c8 100644
--- a/compiler/src/Files.hs
+++ b/compiler/src/Files.hs
@@ -23,7 +23,8 @@
 
 module Files
   ( FileName, LocalPath, WebPath, Path
-  , (</>), (</), (/>), (<.>), fileName, subPaths, pathLength
+  , (</>), (</), (/>), (<.>)
+  , fileName, maybeFileName, subPaths, pathLength
   , localPath, webPath
   , FSNode(..), AnchoredFSNode(..)
   , nodePath, nodeName, isHidden, flattenDir, filterDir, readDirectory
@@ -80,6 +81,10 @@ file /> (Path path) = Path (path ++ [file])
 fileName :: Path -> FileName
 fileName (Path (name:_)) = name
 
+maybeFileName :: Path -> Maybe FileName
+maybeFileName (Path (name:_)) = Just name
+maybeFileName _ = Nothing
+
 subPaths :: Path -> [Path]
 subPaths (Path path) = map Path $ subsequences path
 
diff --git a/compiler/src/Resource.hs b/compiler/src/Resource.hs
index bffa569..bbabf18 100644
--- a/compiler/src/Resource.hs
+++ b/compiler/src/Resource.hs
@@ -105,15 +105,15 @@ type ThumbnailProcessor = Path -> IO (Maybe Path)
 
 buildGalleryTree ::
      DirProcessor -> ItemProcessor -> ThumbnailProcessor
-  -> String -> InputTree -> IO GalleryItem
-buildGalleryTree processDir processItem processThumbnail galleryName inputTree =
-  mkGalleryItem inputTree >>= return . named galleryName
+  -> Bool -> String -> InputTree -> IO GalleryItem
+buildGalleryTree processDir processItem processThumbnail addDirTag galleryName inputTree =
+  mkGalleryItem Nothing inputTree >>= return . named galleryName
   where
     named :: String -> GalleryItem -> GalleryItem
     named name item = item { title = name }
 
-    mkGalleryItem :: InputTree -> IO GalleryItem
-    mkGalleryItem InputFile{path, sidecar} =
+    mkGalleryItem :: Maybe String -> InputTree -> IO GalleryItem
+    mkGalleryItem parent InputFile{path, sidecar} =
       do
         (processedItemPath, properties) <- processItem path
         processedThumbnail <- processThumbnail path
@@ -121,7 +121,7 @@ buildGalleryTree processDir processItem processThumbnail galleryName inputTree =
           { title = optMeta title $ fileName path
           , date = optMeta date "" -- TODO: check and normalise dates
           , description = optMeta description ""
-          , tags = optMeta tags []
+          , tags = (optMeta tags []) ++ implicitParentTag parent
           , path = processedItemPath
           , thumbnail = processedThumbnail
           , properties = properties } -- TODO
@@ -129,18 +129,18 @@ buildGalleryTree processDir processItem processThumbnail galleryName inputTree =
         optMeta :: (Sidecar -> Maybe a) -> a -> a
         optMeta get fallback = fromMaybe fallback $ get sidecar
 
-    mkGalleryItem InputDir{path, dirThumbnailPath, items} =
+    mkGalleryItem parent InputDir{path, dirThumbnailPath, items} =
       do
         processedDir <- processDir path
         processedThumbnail <- maybeThumbnail dirThumbnailPath
-        processedItems <- parallel $ map mkGalleryItem items
+        processedItems <- parallel $ map (mkGalleryItem $ maybeFileName path) items
         return GalleryItem
           { title = fileName path
             -- TODO: consider using the most recent item's date? what if empty?
           , date = ""
             -- TODO: consider allowing metadata sidecars for directories too
           , description = ""
-          , tags = aggregateChildTags processedItems
+          , tags = (aggregateChildTags processedItems) ++ implicitParentTag parent
           , path = processedDir
           , thumbnail = processedThumbnail
           , properties = Directory processedItems }
@@ -155,6 +155,10 @@ buildGalleryTree processDir processItem processThumbnail galleryName inputTree =
         unique :: Ord a => [a] -> [a]
         unique = Set.toList . Set.fromList
 
+    implicitParentTag :: Maybe String -> [Tag]
+    implicitParentTag Nothing = []
+    implicitParentTag (Just parent) = if addDirTag then [parent] else []
+
 
 flattenGalleryTree :: GalleryItem -> [GalleryItem]
 flattenGalleryTree dir@(GalleryItem _ _ _ _ _ _ (Directory items)) =