aboutsummaryrefslogtreecommitdiff
path: root/compiler/src
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/src')
-rw-r--r--compiler/src/Lib.hs65
1 files changed, 40 insertions, 25 deletions
diff --git a/compiler/src/Lib.hs b/compiler/src/Lib.hs
index c52e095..6cecfc5 100644
--- a/compiler/src/Lib.hs
+++ b/compiler/src/Lib.hs
@@ -34,12 +34,14 @@ import Control.Exception (Exception, throwIO)
34import Data.Function 34import Data.Function
35import Data.Maybe (fromMaybe) 35import Data.Maybe (fromMaybe)
36import Data.List (map) 36import Data.List (map)
37import Data.Set (fromList, toList)
37import Data.Char (toLower) 38import Data.Char (toLower)
38import Data.Text (Text, empty, pack) 39import Data.Text (Text, empty, pack)
39import Data.Yaml (ParseException, decodeFileEither) 40import Data.Yaml (ParseException, decodeFileEither)
40import Data.Aeson 41import Data.Aeson
41 42
42import System.FilePath 43import System.FilePath (isExtensionOf)
44import qualified System.FilePath.Posix (joinPath)
43import System.Directory.Tree 45import System.Directory.Tree
44import System.Directory 46import System.Directory
45 47
@@ -137,37 +139,50 @@ metadataDirTree d@(Dir _ dcontents) =
137 canContainMetadata (File fname _) = isExtensionOf ".yaml" fname 139 canContainMetadata (File fname _) = isExtensionOf ".yaml" fname
138 140
139 141
140toItemTree :: (MonadIO m) => [FileName] -> DirTree SidecarItemMetadata -> m Item 142unique :: Ord a => [a] -> [a]
141toItemTree pathTo d@(Dir dname dcontents) = 143unique = Data.Set.toList . Data.Set.fromList
142 mapM (toItemTree path) dcontents 144
143 >>= \items -> return Item 145
144 { title = pack dname 146joinURLPath :: [FileName] -> Text
145 , date = empty -- TODO: would it make sense to take the date of child elements? 147joinURLPath = pack . System.FilePath.Posix.joinPath
146 , description = empty 148
147 , tags = [] -- TODO: aggregate tags from childs 149
148 , path = pack $ joinPath $ "items":path -- FIXME: use URL path instead of system path sep 150toItemTree :: (MonadIO m) => FilePath -> FilePath -> DirTree SidecarItemMetadata -> m Item
149 , thumbnail = Nothing 151toItemTree itemsDir thumbnailsDir = nodeToItem []
150 , properties = Directory { items = items }}
151 where
152 path = pathTo ++ [dname]
153toItemTree pathTo f@(File fname metadata) =
154 return Item
155 { title = optMeta title (pack fname)
156 , date = optMeta date empty -- TODO: check and normalise dates
157 , description = optMeta description empty
158 , tags = optMeta tags []
159 , path = pack $ joinPath $ "items":(pathTo ++ [fname]) -- FIXME: use URL path instead of system path sep
160 , thumbnail = Just $ pack $ joinPath $ "thumbnails":(pathTo ++ [fname]) -- FIXME: use URL path instead of system path sep
161 , properties = Unknown } -- TODO
162 where 152 where
163 optMeta get fallback = fromMaybe fallback $ get (metadata::SidecarItemMetadata) 153 nodeToItem pathTo d@(Dir dname dcontents) =
154 mapM (nodeToItem path) dcontents
155 >>= \items -> return Item
156 { title = pack dname
157 , date = empty
158 , description = empty
159 , tags = aggregateTags items
160 , path = joinURLPath $ itemsDir:path
161 , thumbnail = Nothing
162 , properties = Directory { items = items } }
163 where
164 path = pathTo ++ [dname]
165 aggregateTags = unique . concatMap (\item -> tags (item::Item))
166
167 nodeToItem pathTo f@(File fname metadata) =
168 return Item
169 { title = optMeta title (pack fname)
170 , date = optMeta date empty -- TODO: check and normalise dates
171 , description = optMeta description empty
172 , tags = optMeta tags []
173 , path = joinURLPath $ itemsDir:path
174 , thumbnail = Just $ joinURLPath $ thumbnailsDir:path
175 , properties = Unknown } -- TODO
176 where
177 path = pathTo ++ [fname]
178 optMeta get fallback = fromMaybe fallback $ get (metadata::SidecarItemMetadata)
164 179
165 180
166process :: FilePath -> FilePath -> IO () 181process :: FilePath -> FilePath -> IO ()
167process inputDir outputDir = 182process inputDir outputDir =
168 readDirectoryWith return inputDir 183 readDirectoryWith return inputDir
169 >>= metadataDirTree . dirTree 184 >>= metadataDirTree . dirTree
170 >>= toItemTree [] 185 >>= toItemTree "items" "thumbnails"
171 >>= return . show . toEncoding 186 >>= return . show . toEncoding
172 >>= liftIO . putStrLn 187 >>= liftIO . putStrLn
173 188