aboutsummaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/src/Lib.hs154
1 files changed, 97 insertions, 57 deletions
diff --git a/compiler/src/Lib.hs b/compiler/src/Lib.hs
index e21751c..70a2cca 100644
--- a/compiler/src/Lib.hs
+++ b/compiler/src/Lib.hs
@@ -32,7 +32,7 @@ import Control.Monad.IO.Class (MonadIO, liftIO)
32import Control.Exception (Exception, throwIO) 32import Control.Exception (Exception, throwIO)
33 33
34import Data.Function 34import Data.Function
35import Data.Maybe (fromMaybe) 35import Data.Maybe (fromMaybe, listToMaybe)
36import Data.List (map) 36import Data.List (map)
37import Data.Set (fromList, toList) 37import Data.Set (fromList, toList)
38import Data.Char (toLower) 38import Data.Char (toLower)
@@ -40,7 +40,7 @@ import Data.Text (Text, empty, pack)
40import Data.Yaml (ParseException, decodeFileEither) 40import Data.Yaml (ParseException, decodeFileEither)
41import Data.Aeson 41import Data.Aeson
42 42
43import System.FilePath ((</>), dropFileName, dropExtension, isExtensionOf) 43import System.FilePath ((</>), joinPath, dropFileName, dropExtension, isExtensionOf)
44import qualified System.FilePath.Posix (joinPath) 44import qualified System.FilePath.Posix (joinPath)
45import System.Directory.Tree 45import System.Directory.Tree
46import System.Directory 46import System.Directory
@@ -64,7 +64,7 @@ data SidecarItemMetadata = SidecarItemMetadata
64 , date :: Maybe Text 64 , date :: Maybe Text
65 , description :: Maybe Text 65 , description :: Maybe Text
66 , tags :: Maybe [Text] 66 , tags :: Maybe [Text]
67 } deriving Generic 67 } deriving (Generic, Show)
68 68
69instance FromJSON SidecarItemMetadata where 69instance FromJSON SidecarItemMetadata where
70 parseJSON = genericParseJSON encodingOptions 70 parseJSON = genericParseJSON encodingOptions
@@ -80,7 +80,7 @@ type FileSizeKB = Int
80data Resolution = Resolution 80data Resolution = Resolution
81 { width :: Int 81 { width :: Int
82 , height :: Int 82 , height :: Int
83 } deriving Generic 83 } deriving (Generic, Show)
84 84
85instance ToJSON Resolution where 85instance ToJSON Resolution where
86 toJSON = genericToJSON encodingOptions 86 toJSON = genericToJSON encodingOptions
@@ -92,7 +92,7 @@ data ItemProperties =
92 | Image { resolution :: Resolution, filesize :: FileSizeKB } 92 | Image { resolution :: Resolution, filesize :: FileSizeKB }
93-- | Video { filesize :: FileSizeKB } 93-- | Video { filesize :: FileSizeKB }
94 | Unknown 94 | Unknown
95 deriving Generic 95 deriving (Generic, Show)
96 96
97instance ToJSON ItemProperties where 97instance ToJSON ItemProperties where
98 toJSON = genericToJSON encodingOptions 98 toJSON = genericToJSON encodingOptions
@@ -107,7 +107,7 @@ data Item = Item
107 , path :: ResourcePath 107 , path :: ResourcePath
108 , thumbnail :: Maybe ResourcePath 108 , thumbnail :: Maybe ResourcePath
109 , properties :: ItemProperties 109 , properties :: ItemProperties
110 } deriving Generic 110 } deriving (Generic, Show)
111 111
112instance ToJSON Item where 112instance ToJSON Item where
113 toJSON = genericToJSON encodingOptions 113 toJSON = genericToJSON encodingOptions
@@ -125,87 +125,127 @@ decodeYamlFile fpath =
125 >>= either (throwIO . LoadException fpath) return 125 >>= either (throwIO . LoadException fpath) return
126 126
127 127
128metadataDirTree :: DirTree FilePath -> IO (DirTree SidecarItemMetadata) 128toMetaTree :: DirTree FilePath -> IO (DirTree SidecarItemMetadata)
129metadataDirTree (Failed _ ferr) = ioError ferr 129toMetaTree tree = return (filterDir canContainMetadata tree) >>= metaNode
130metadataDirTree f@(File _ fpath) =
131 decodeYamlFile fpath
132 >>= \metadata -> return f { file = metadata }
133metadataDirTree d@(Dir _ dcontents) =
134 filter canContainMetadata dcontents
135 & mapM metadataDirTree
136 >>= \contents -> return d { contents = contents }
137 where 130 where
138 canContainMetadata (Dir _ _) = True 131 -- TODO: exclude hidden files (name starting with '.')?
139 canContainMetadata (File fname _) = isExtensionOf ".yaml" fname 132 canContainMetadata :: DirTree a -> Bool
133 canContainMetadata (File fname _) = isExtensionOf ".yaml" fname
134 canContainMetadata (Dir _ _) = True
135
136 metaNode :: DirTree FilePath -> IO (DirTree SidecarItemMetadata)
137 metaNode (Failed _ ferr) = ioError ferr
138 metaNode file@(File _ fpath) = decodeYamlFile fpath
139 >>= \metadata -> return file { file = metadata }
140 metaNode dir@(Dir _ dcontents) = mapM metaNode dcontents
141 >>= \contents -> return dir { contents = contents }
140 142
141 143
142unique :: Ord a => [a] -> [a] 144unique :: Ord a => [a] -> [a]
143unique = Data.Set.toList . Data.Set.fromList 145unique = Data.Set.toList . Data.Set.fromList
144 146
145
146joinURLPath :: [FileName] -> Text 147joinURLPath :: [FileName] -> Text
147joinURLPath = pack . System.FilePath.Posix.joinPath 148joinURLPath = pack . System.FilePath.Posix.joinPath
148 149
149 150
150toItemTree :: (MonadIO m) => FilePath -> FilePath -> DirTree SidecarItemMetadata -> m (Item, DirTree SidecarItemMetadata) 151toItemTree :: FilePath -> FilePath -> DirTree SidecarItemMetadata -> IO Item
151toItemTree itemsDir thumbnailsDir = nodeToItem [] 152toItemTree itemsDir thumbnailsDir = itemNode []
152 where 153 where
153 nodeToItem pathTo d@(Dir dname dcontents) = 154 itemNode :: [FileName] -> DirTree SidecarItemMetadata -> IO Item
154 mapM (nodeToItem path) dcontents 155 itemNode pathTo (Dir dname dcontents) =
155 >>= return . unzip 156 mapM (itemNode path) dcontents
156 >>= \(items, _) -> return 157 >>= \items -> return Item
157 ( Item 158 { title = pack dname
158 { title = pack dname 159 , date = empty
159 , date = empty 160 , description = empty
160 , description = empty 161 , tags = aggregateChildTags items
161 , tags = aggregateTags items 162 , path = joinURLPath $ itemsDir:path
162 , path = joinURLPath $ itemsDir:path 163 , thumbnail = Nothing
163 , thumbnail = Nothing 164 , properties = Directory items }
164 , properties = Directory { items = items } }
165 , d)
166 where 165 where
167 path = pathTo ++ [dname] 166 path = pathTo ++ [dname]
168 aggregateTags = unique . concatMap (\item -> tags (item::Item)) 167 aggregateChildTags = unique . concatMap (\item -> tags (item::Item))
169 168
170 nodeToItem pathTo f@(File fname metadata) = 169 itemNode pathTo (File fname metadata) =
171 return 170 return Item
172 ( Item 171 { title = optMeta title $ pack name
173 { title = optMeta title $ pack $ dropExtension fname 172 , date = optMeta date empty -- TODO: check and normalise dates
174 , date = optMeta date empty -- TODO: check and normalise dates 173 , description = optMeta description empty
175 , description = optMeta description empty 174 , tags = optMeta tags []
176 , tags = optMeta tags [] 175 , path = joinURLPath $ itemsDir:path
177 , path = joinURLPath $ itemsDir:path 176 , thumbnail = Just $ joinURLPath $ thumbnailsDir:path
178 , thumbnail = Just $ joinURLPath $ thumbnailsDir:path 177 , properties = Unknown } -- TODO
179 , properties = Unknown } -- TODO
180 , f)
181 where 178 where
182 path = pathTo ++ [fname] 179 name = dropExtension fname
180 path = pathTo ++ [name]
183 optMeta get fallback = fromMaybe fallback $ get (metadata::SidecarItemMetadata) 181 optMeta get fallback = fromMaybe fallback $ get (metadata::SidecarItemMetadata)
184 182
185 183
184data ObjectTree = ObjectTree
185 { pathTo :: [ObjectTree]
186 , meta :: (DirTree SidecarItemMetadata)
187 , item :: Item } deriving Show
188
189rootObjectTree :: DirTree SidecarItemMetadata -> Item -> ObjectTree
190rootObjectTree = ObjectTree []
191
192toObjectTree :: (DirTree SidecarItemMetadata -> IO Item) -> DirTree SidecarItemMetadata -> IO ObjectTree
193toObjectTree itemGen meta = itemGen meta >>= return . (rootObjectTree meta)
194
195flatten :: ObjectTree -> [ObjectTree]
196flatten object@(ObjectTree _ (File _ _) _) = [object]
197flatten object@(ObjectTree pathTo (Dir _ dcontents) item) =
198 zip dcontents (items $ properties item)
199 & map (uncurry $ ObjectTree $ pathTo ++ [object])
200 & concatMap flatten
201 & (:) object
202
203objFileName :: ObjectTree -> FileName
204objFileName (ObjectTree _ (Dir name _) _) = name
205objFileName (ObjectTree _ (File name _) _) = dropExtension name -- without ".yaml"
206
207objFilePath :: ObjectTree -> FilePath
208objFilePath obj@(ObjectTree pathTo _ _) =
209 (map (name . meta) pathTo) ++ [objFileName obj]
210 & System.FilePath.joinPath
211
212
213data FileTransform = FileTransform
214 { src :: FilePath
215 , dst :: FilePath } deriving Show
216
217
218isUpToDate :: FilePath -> FilePath -> IO Bool
219isUpToDate ref target =
220 do
221 refTime <- getModificationTime ref
222 targetTime <- getModificationTime target
223 return (target >= ref)
224
225
186unrooted :: AnchoredDirTree a -> DirTree a 226unrooted :: AnchoredDirTree a -> DirTree a
187unrooted t = (dirTree t) { name = "" } 227unrooted t = (dirTree t) { name = "" }
188 228
189
190writeJSON :: ToJSON a => FilePath -> a -> IO () 229writeJSON :: ToJSON a => FilePath -> a -> IO ()
191writeJSON path obj = 230writeJSON path obj =
192 createDirectoryIfMissing True (dropFileName path) 231 createDirectoryIfMissing True (dropFileName path)
193 >> Data.Aeson.encodeFile path obj 232 >> Data.Aeson.encodeFile path obj
194 233
195 234passthrough :: Monad m => (a -> m b) -> a -> m a
196infixl 1 >>>>>> 235passthrough f a = return a >>= f >>= \_ -> return a
197(>>>>>>) :: Monad m => m a -> (a -> m b) -> m a
198a >>>>>> f = a >>= f >>= return a
199
200 236
201process :: FilePath -> FilePath -> IO () 237process :: FilePath -> FilePath -> IO ()
202process inputDir outputDir = 238process inputDir outputDir =
203 readDirectoryWith return inputDir 239 readDirectoryWith return inputDir
204 >>= return . unrooted 240 >>= return . unrooted
205 >>= metadataDirTree 241 >>= toMetaTree
206 >>= toItemTree itemsDir thumbnailsDir 242 >>= toObjectTree (toItemTree itemsDir thumbnailsDir)
207 >>>>>> writeJSON (outputDir </> indexFile) . fst 243 >>= passthrough (writeJSON (outputDir </> indexFile) . item)
208 >>= return . show . toEncoding . fst 244 >>= return . flatten
245-- >>= mapM (return . pathTo)
246 >>= return . (map objFilePath)
247 >>= return . show
248-- >>= return . show . toEncoding . item
209 >>= liftIO . putStrLn 249 >>= liftIO . putStrLn
210 where 250 where