diff options
Diffstat (limited to 'compiler')
-rw-r--r-- | compiler/package.yaml | 1 | ||||
-rw-r--r-- | compiler/src/Lib.hs | 65 |
2 files changed, 41 insertions, 25 deletions
diff --git a/compiler/package.yaml b/compiler/package.yaml index f2a319e..253f16a 100644 --- a/compiler/package.yaml +++ b/compiler/package.yaml | |||
@@ -17,6 +17,7 @@ description: Please see the README on GitHub at <https://github.com/paci | |||
17 | dependencies: | 17 | dependencies: |
18 | - base >= 4.7 && < 5 | 18 | - base >= 4.7 && < 5 |
19 | - text | 19 | - text |
20 | - containers | ||
20 | - optparse-applicative | 21 | - optparse-applicative |
21 | - cmdargs | 22 | - cmdargs |
22 | - filepath | 23 | - filepath |
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) | |||
34 | import Data.Function | 34 | import Data.Function |
35 | import Data.Maybe (fromMaybe) | 35 | import Data.Maybe (fromMaybe) |
36 | import Data.List (map) | 36 | import Data.List (map) |
37 | import Data.Set (fromList, toList) | ||
37 | import Data.Char (toLower) | 38 | import Data.Char (toLower) |
38 | import Data.Text (Text, empty, pack) | 39 | import Data.Text (Text, empty, pack) |
39 | import Data.Yaml (ParseException, decodeFileEither) | 40 | import Data.Yaml (ParseException, decodeFileEither) |
40 | import Data.Aeson | 41 | import Data.Aeson |
41 | 42 | ||
42 | import System.FilePath | 43 | import System.FilePath (isExtensionOf) |
44 | import qualified System.FilePath.Posix (joinPath) | ||
43 | import System.Directory.Tree | 45 | import System.Directory.Tree |
44 | import System.Directory | 46 | import 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 | ||
140 | toItemTree :: (MonadIO m) => [FileName] -> DirTree SidecarItemMetadata -> m Item | 142 | unique :: Ord a => [a] -> [a] |
141 | toItemTree pathTo d@(Dir dname dcontents) = | 143 | unique = Data.Set.toList . Data.Set.fromList |
142 | mapM (toItemTree path) dcontents | 144 | |
143 | >>= \items -> return Item | 145 | |
144 | { title = pack dname | 146 | joinURLPath :: [FileName] -> Text |
145 | , date = empty -- TODO: would it make sense to take the date of child elements? | 147 | joinURLPath = 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 | 150 | toItemTree :: (MonadIO m) => FilePath -> FilePath -> DirTree SidecarItemMetadata -> m Item |
149 | , thumbnail = Nothing | 151 | toItemTree itemsDir thumbnailsDir = nodeToItem [] |
150 | , properties = Directory { items = items }} | ||
151 | where | ||
152 | path = pathTo ++ [dname] | ||
153 | toItemTree 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 | ||
166 | process :: FilePath -> FilePath -> IO () | 181 | process :: FilePath -> FilePath -> IO () |
167 | process inputDir outputDir = | 182 | process 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 | ||