aboutsummaryrefslogtreecommitdiff
path: root/compiler/src/Resource.hs
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/src/Resource.hs')
-rw-r--r--compiler/src/Resource.hs61
1 files changed, 30 insertions, 31 deletions
diff --git a/compiler/src/Resource.hs b/compiler/src/Resource.hs
index 400e18a..aadf60b 100644
--- a/compiler/src/Resource.hs
+++ b/compiler/src/Resource.hs
@@ -121,44 +121,52 @@ type ThumbnailProcessor = Path -> IO (Maybe Thumbnail)
121 121
122buildGalleryTree :: 122buildGalleryTree ::
123 ItemProcessor -> ThumbnailProcessor 123 ItemProcessor -> ThumbnailProcessor
124 -> Int -> String -> InputTree -> IO GalleryItem 124 -> Int -> InputTree -> IO GalleryItem
125buildGalleryTree processItem processThumbnail tagsFromDirectories galleryName inputTree = 125buildGalleryTree processItem processThumbnail tagsFromDirectories inputTree =
126 mkGalleryItem [] inputTree 126 mkGalleryItem [] [] inputTree
127 where 127 where
128 mkGalleryItem :: [String] -> InputTree -> IO GalleryItem 128 mkGalleryItem :: [String] -> [Tag] -> InputTree -> IO GalleryItem
129 mkGalleryItem parentTitles InputFile{path, modTime, sidecar} = 129 mkGalleryItem parentDirs inheritedTags InputFile{path, modTime, sidecar} =
130 do 130 do
131 properties <- processItem path 131 properties <- processItem path
132 processedThumbnail <- processThumbnail path 132 processedThumbnail <- processThumbnail path
133 return GalleryItem 133 return GalleryItem
134 { title = fromMeta title $ fromMaybe "" $ fileName path 134 { title = Input.title sidecar ?? fileName path ?? ""
135 , datetime = fromMaybe (toZonedTime modTime) (Input.datetime sidecar) 135 , datetime = Input.datetime sidecar ?? toZonedTime modTime
136 , description = fromMeta description "" 136 , description = Input.description sidecar ?? ""
137 , tags = unique ((fromMeta tags []) ++ implicitParentTags parentTitles) 137 , tags = unique ((Input.tags sidecar ?? []) ++ inheritedTags ++ parentDirTags parentDirs)
138 , path = "/" /> path 138 , path = "/" /> path
139 , thumbnail = processedThumbnail 139 , thumbnail = processedThumbnail
140 , properties = properties } 140 , properties = properties }
141 141
142 where 142 mkGalleryItem parentDirs inheritedTags InputDir{path, modTime, sidecar, dirThumbnailPath, items} =
143 fromMeta :: (Sidecar -> Maybe a) -> a -> a
144 fromMeta get fallback = fromMaybe fallback $ get sidecar
145
146 mkGalleryItem parentTitles InputDir{path, modTime, dirThumbnailPath, items} =
147 do 143 do
144 let itemsParents = (maybeToList $ fileName path) ++ parentDirs
145 let dirTags = (Input.tags sidecar ?? []) ++ inheritedTags
146 processedItems <- parallel $ map (mkGalleryItem itemsParents dirTags) items
148 processedThumbnail <- maybeThumbnail dirThumbnailPath 147 processedThumbnail <- maybeThumbnail dirThumbnailPath
149 processedItems <- parallel $ map (mkGalleryItem subItemsParents) items
150 return GalleryItem 148 return GalleryItem
151 { title = fromMaybe galleryName (fileName path) 149 { title = Input.title sidecar ?? fileName path ?? ""
152 , datetime = fromMaybe (toZonedTime modTime) (mostRecentModTime processedItems) 150 , datetime = Input.datetime sidecar ?? mostRecentModTime processedItems
153 , description = "" 151 ?? toZonedTime modTime
154 , tags = unique (aggregateTags processedItems ++ implicitParentTags parentTitles) 152 , description = Input.description sidecar ?? ""
153 , tags = unique (aggregateTags processedItems ++ parentDirTags parentDirs)
155 , path = "/" /> path 154 , path = "/" /> path
156 , thumbnail = processedThumbnail 155 , thumbnail = processedThumbnail
157 , properties = Directory processedItems } 156 , properties = Directory processedItems }
158 157
159 where 158 infixr ??
160 subItemsParents :: [String] 159 (??) :: Maybe a -> a -> a
161 subItemsParents = (maybeToList $ fileName path) ++ parentTitles 160 (??) = flip fromMaybe
161
162 unique :: Ord a => [a] -> [a]
163 unique = Set.toList . Set.fromList
164
165 parentDirTags :: [String] -> [Tag]
166 parentDirTags = take tagsFromDirectories
167
168 aggregateTags :: [GalleryItem] -> [Tag]
169 aggregateTags = concatMap (\item -> tags (item::GalleryItem))
162 170
163 maybeThumbnail :: Maybe Path -> IO (Maybe Thumbnail) 171 maybeThumbnail :: Maybe Path -> IO (Maybe Thumbnail)
164 maybeThumbnail Nothing = return Nothing 172 maybeThumbnail Nothing = return Nothing
@@ -171,15 +179,6 @@ buildGalleryTree processItem processThumbnail tagsFromDirectories galleryName in
171 comparingTime :: ZonedTime -> ZonedTime -> Ordering 179 comparingTime :: ZonedTime -> ZonedTime -> Ordering
172 comparingTime l r = compare (zonedTimeToUTC l) (zonedTimeToUTC r) 180 comparingTime l r = compare (zonedTimeToUTC l) (zonedTimeToUTC r)
173 181
174 aggregateTags :: [GalleryItem] -> [Tag]
175 aggregateTags = concatMap (\item -> tags (item::GalleryItem))
176
177 unique :: Ord a => [a] -> [a]
178 unique = Set.toList . Set.fromList
179
180 implicitParentTags :: [String] -> [Tag]
181 implicitParentTags = take tagsFromDirectories
182
183 toZonedTime :: UTCTime -> ZonedTime 182 toZonedTime :: UTCTime -> ZonedTime
184 toZonedTime = utcToZonedTime utc 183 toZonedTime = utcToZonedTime utc
185 184