diff options
Diffstat (limited to 'compiler/src/Resource.hs')
-rw-r--r-- | compiler/src/Resource.hs | 61 |
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 | ||
122 | buildGalleryTree :: | 122 | buildGalleryTree :: |
123 | ItemProcessor -> ThumbnailProcessor | 123 | ItemProcessor -> ThumbnailProcessor |
124 | -> Int -> String -> InputTree -> IO GalleryItem | 124 | -> Int -> InputTree -> IO GalleryItem |
125 | buildGalleryTree processItem processThumbnail tagsFromDirectories galleryName inputTree = | 125 | buildGalleryTree 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 | ||