compiler: add option to add tags from n parent directories

GitHub: closes #15

3 files changed, 16 insertions, 21 deletions

diff --git a/compiler/src/Compiler.hs b/compiler/src/Compiler.hs
index d0ec003..fc4e272 100644
--- a/compiler/src/Compiler.hs
+++ b/compiler/src/Compiler.hs
@@ -111,7 +111,7 @@ compileGallery inputDirPath outputDirPath rebuildAll =
 
     let itemProc = itemProcessor (pictureMaxResolution config) cache
     let thumbnailProc = thumbnailProcessor (thumbnailMaxResolution config) cache
-    let galleryBuilder = buildGalleryTree itemProc thumbnailProc (implicitDirectoryTag config)
+    let galleryBuilder = buildGalleryTree itemProc thumbnailProc (tagsFromDirectories config)
     resources <- galleryBuilder (galleryName config) inputTree
 
     galleryCleanupResourceDir resources outputDirPath
diff --git a/compiler/src/Config.hs b/compiler/src/Config.hs
index b9434ba..20bc3bb 100644
--- a/compiler/src/Config.hs
+++ b/compiler/src/Config.hs
@@ -35,7 +35,7 @@ import Resource (Resolution(..))
 data CompilerConfig = CompilerConfig
   { galleryName :: String
   , ignoreFiles :: String
-  , implicitDirectoryTag :: Bool
+  , tagsFromDirectories :: Int
   , thumbnailMaxResolution :: Resolution
   , pictureMaxResolution :: Maybe Resolution
   } deriving (Generic, Show)
@@ -44,7 +44,7 @@ instance FromJSON CompilerConfig where
   parseJSON = withObject "CompilerConfig" $ \v -> CompilerConfig
     <$> v .:? "galleryName" .!= "Gallery"
     <*> v .:? "ignoreFiles" .!= ".^"
-    <*> v .:? "implicitDirectoryTag" .!= False
+    <*> v .:? "tagsFromDirectories" .!= 0
     <*> v .:? "thumbnailMaxResolution" .!= (Resolution 400 400)
     <*> v .:? "pictureMaxResolution"
 
diff --git a/compiler/src/Resource.hs b/compiler/src/Resource.hs
index 2019418..261191b 100644
--- a/compiler/src/Resource.hs
+++ b/compiler/src/Resource.hs
@@ -27,7 +27,7 @@ import Control.Concurrent.ParallelIO.Global (parallel)
 import Data.List ((\\), sortBy)
 import Data.Ord (comparing)
 import Data.Char (toLower)
-import Data.Maybe (mapMaybe, fromMaybe, maybeToList)
+import Data.Maybe (mapMaybe, fromMaybe)
 import Data.Function ((&))
 import qualified Data.Set as Set
 
@@ -94,15 +94,12 @@ type ThumbnailProcessor = Path -> IO (Maybe Path)
 
 buildGalleryTree ::
      ItemProcessor -> ThumbnailProcessor
-  -> Bool -> String -> InputTree -> IO GalleryItem
-buildGalleryTree processItem processThumbnail addDirTag galleryName inputTree =
-  mkGalleryItem (Path []) inputTree >>= return . named galleryName
+  -> Int -> String -> InputTree -> IO GalleryItem
+buildGalleryTree processItem processThumbnail tagsFromDirectories galleryName inputTree =
+  mkGalleryItem (Just galleryName) (Path []) inputTree
   where
-    named :: String -> GalleryItem -> GalleryItem
-    named name item = item { title = name }
-
-    mkGalleryItem :: Path -> InputTree -> IO GalleryItem
-    mkGalleryItem parents InputFile{path, sidecar} =
+    mkGalleryItem :: Maybe String -> Path -> InputTree -> IO GalleryItem
+    mkGalleryItem _ parents InputFile{path, sidecar} =
       do
         properties <- processItem path
         processedThumbnail <- processThumbnail path
@@ -110,7 +107,7 @@ buildGalleryTree processItem processThumbnail addDirTag galleryName inputTree =
           { title = itemTitle
           , date = optMeta date "" -- TODO: check and normalise dates
           , description = optMeta description ""
-          , tags = (optMeta tags []) ++ implicitParentTag parents
+          , tags = (optMeta tags []) ++ implicitParentTags parents
           , path = parents </ itemTitle
           , thumbnail = processedThumbnail
           , properties = properties } -- TODO
@@ -121,23 +118,23 @@ buildGalleryTree processItem processThumbnail addDirTag galleryName inputTree =
         optMeta :: (Sidecar -> Maybe a) -> a -> a
         optMeta get fallback = fromMaybe fallback $ get sidecar
 
-    mkGalleryItem parents InputDir{path, dirThumbnailPath, items} =
+    mkGalleryItem rootTitle parents InputDir{path, dirThumbnailPath, items} =
       do
         processedThumbnail <- maybeThumbnail dirThumbnailPath
-        processedItems <- parallel $ map (mkGalleryItem itemPath) items
+        processedItems <- parallel $ map (mkGalleryItem Nothing itemPath) items
         return GalleryItem
           { title = itemTitle
             -- 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) ++ implicitParentTag parents
+          , tags = (aggregateChildTags processedItems) ++ implicitParentTags parents
           , path = itemPath
           , thumbnail = processedThumbnail
           , properties = Directory processedItems }
       where
         itemTitle :: String
-        itemTitle = fromMaybe "" $ fileName path
+        itemTitle = flip fromMaybe rootTitle (fromMaybe "" $ fileName path)
 
         itemPath :: Path
         itemPath = parents </ itemTitle
@@ -152,10 +149,8 @@ buildGalleryTree processItem processThumbnail addDirTag galleryName inputTree =
         unique :: Ord a => [a] -> [a]
         unique = Set.toList . Set.fromList
 
-    implicitParentTag :: Path -> [Tag]
-    implicitParentTag parents
-      | addDirTag = maybeToList $ fileName parents
-      | otherwise = []
+    implicitParentTags :: Path -> [Tag]
+    implicitParentTags (Path elements) = take tagsFromDirectories elements
 
 
 flattenGalleryTree :: GalleryItem -> [GalleryItem]