From 8a75458290002c765a0fa673912c162020de2bd1 Mon Sep 17 00:00:00 2001
From: pacien
Date: Mon, 30 Dec 2019 01:40:55 +0100
Subject: compiler: refactor path handling

---
 compiler/src/Files.hs      | 45 +++++++++++++++++++++++++++++++++------------
 compiler/src/Gallery.hs    | 20 ++++++++++----------
 compiler/src/Input.hs      |  4 ++--
 compiler/src/Processors.hs | 10 ++++------
 compiler/src/Resource.hs   |  4 ++--
 5 files changed, 51 insertions(+), 32 deletions(-)

(limited to 'compiler/src')

diff --git a/compiler/src/Files.hs b/compiler/src/Files.hs
index d1363a1..457f1da 100644
--- a/compiler/src/Files.hs
+++ b/compiler/src/Files.hs
@@ -23,7 +23,8 @@
 
 module Files
   ( FileName, LocalPath, WebPath, Path
-  , (</>), (</), (/>), (<.>), localPath, webPath
+  , (</>), (</), (/>), (<.>), fileName, subPaths, pathLength
+  , localPath, webPath
   , FSNode(..), AnchoredFSNode(..)
   , nodePath, nodeName, isHidden, flattenDir, filterDir, readDirectory
   , ensureParentDir, remove, isOutdated
@@ -32,8 +33,12 @@ module Files
 
 import Control.Monad (filterM, mapM)
 import Data.Bool (bool)
-import Data.List (isPrefixOf, length, deleteBy)
+import Data.List (isPrefixOf, length, deleteBy, subsequences)
 import Data.Function ((&))
+import Data.Text (pack)
+import Data.Aeson (ToJSON)
+import qualified Data.Aeson as JSON
+
 import System.Directory
   ( doesDirectoryExist
   , doesPathExist
@@ -51,25 +56,41 @@ type LocalPath = String
 type WebPath = String
 
  -- | Reversed path component list
-type Path = [FileName]
+data Path = Path [FileName] deriving Show
+
+instance ToJSON Path where
+  toJSON = JSON.String . pack . webPath
+
+instance Eq Path where
+  (Path left) == (Path right) = left == right
 
 (</>) :: Path -> Path -> Path
-l </> r = r ++ l
+(Path l) </> (Path r) = Path (r ++ l)
 
 (</) :: Path -> FileName -> Path
-path </ file = file:path
+(Path path) </ file = Path (file:path)
 
 (/>) :: FileName -> Path -> Path
-file /> path = path ++ [file]
+file /> (Path path) = Path (path ++ [file])
 
 (<.>) :: Path -> String -> Path
-(filename:pathto) <.> ext = System.FilePath.addExtension filename ext : pathto
+(Path (filename:pathto)) <.> ext =
+  Path $ System.FilePath.addExtension filename ext : pathto
+
+fileName :: Path -> FileName
+fileName (Path (name:_)) = name
+
+subPaths :: Path -> [Path]
+subPaths (Path path) = map (Path . subsequences) path
+
+pathLength :: Path -> Int
+pathLength (Path path) = Data.List.length path
 
 localPath :: Path -> LocalPath
-localPath = System.FilePath.joinPath . reverse
+localPath (Path path) = System.FilePath.joinPath $ reverse path
 
 webPath :: Path -> WebPath
-webPath = System.FilePath.Posix.joinPath . reverse
+webPath (Path path) = System.FilePath.Posix.joinPath $ reverse path
 
 
 data FSNode = File Path | Dir Path [FSNode] deriving Show
@@ -82,10 +103,10 @@ nodePath (File path) = path
 nodePath (Dir path _) = path
 
 nodeName :: FSNode -> FileName
-nodeName = head . nodePath
+nodeName = fileName . nodePath
 
 isHidden :: FSNode -> Bool
-isHidden node = "." `isPrefixOf` filename && length filename > 1
+isHidden node = "." `isPrefixOf` filename &&length filename > 1
   where filename = nodeName node
 
 -- | DFS with intermediate dirs first.
@@ -104,7 +125,7 @@ filterDir cond (AnchoredFSNode anchor root) =
     filter cond items & map filterNode & Dir path
 
 readDirectory :: LocalPath -> IO AnchoredFSNode
-readDirectory root = mkNode [] >>= return . AnchoredFSNode root
+readDirectory root = mkNode (Path []) >>= return . AnchoredFSNode root
   where
     mkNode :: Path -> IO FSNode
     mkNode path =
diff --git a/compiler/src/Gallery.hs b/compiler/src/Gallery.hs
index 1fa4036..a1b1674 100644
--- a/compiler/src/Gallery.hs
+++ b/compiler/src/Gallery.hs
@@ -86,8 +86,8 @@ data GalleryItem = GalleryItem
   , date :: String -- TODO: checked ISO8601 date
   , description :: String
   , tags :: [Tag]
-  , path :: ResourcePath
-  , thumbnail :: Maybe ResourcePath
+  , path :: Path
+  , thumbnail :: Maybe Path
   , properties :: GalleryItemProps
   } deriving (Generic, Show)
 
@@ -97,30 +97,30 @@ instance ToJSON GalleryItem where
 
 
 buildGalleryTree :: ResourceTree -> GalleryItem
-buildGalleryTree (ItemResource sidecar path@(filename:_) thumbnail) =
+buildGalleryTree (ItemResource sidecar path thumbnail) =
   GalleryItem
-    { title = optMeta title filename
+    { title = optMeta title $ fileName path
     , date = optMeta date "" -- TODO: check and normalise dates
     , description = optMeta description ""
     , tags = optMeta tags []
-    , path = webPath path
-    , thumbnail = fmap webPath thumbnail
+    , path = path
+    , thumbnail = thumbnail
     , properties = Unknown } -- TODO
   where
     optMeta :: (Sidecar -> Maybe a) -> a -> a
     optMeta get fallback = fromMaybe fallback $ get sidecar
 
-buildGalleryTree (DirResource dirItems path@(dirname:_) thumbnail) =
+buildGalleryTree (DirResource dirItems path thumbnail) =
   map buildGalleryTree dirItems
   & \items -> GalleryItem
-    { title = dirname
+    { title = fileName path
       -- TODO: consider using the most recent item's date? what if empty?
     , date = ""
       -- TODO: consider allowing metadata sidecars for directories too
     , description = ""
     , tags = aggregateChildTags items
-    , path = webPath path
-    , thumbnail = fmap webPath thumbnail
+    , path = path
+    , thumbnail = thumbnail
     , properties = Directory items }
   where
     aggregateChildTags :: [GalleryItem] -> [Tag]
diff --git a/compiler/src/Input.hs b/compiler/src/Input.hs
index 597394e..cb9fc60 100644
--- a/compiler/src/Input.hs
+++ b/compiler/src/Input.hs
@@ -92,7 +92,7 @@ readInputTree :: AnchoredFSNode -> IO InputTree
 readInputTree (AnchoredFSNode anchor root@Dir{}) = mkDirNode root
   where
     mkInputNode :: FSNode -> IO (Maybe InputTree)
-    mkInputNode (File path@(filename:_)) | not (sidecarExt `isExtensionOf` filename) =
+    mkInputNode (File path) | not (sidecarExt `isExtensionOf` (fileName path)) =
       readSidecarFile (localPath $ anchor /> path <.> sidecarExt)
       >>= return . InputFile path
       >>= return . Just
@@ -110,4 +110,4 @@ readInputTree (AnchoredFSNode anchor root@Dir{}) = mkDirNode root
 
         matchThumbnail :: FSNode -> Bool
         matchThumbnail Dir{} = False
-        matchThumbnail (File (filename:_)) = (dropExtension filename) == "thumbnail"
+        matchThumbnail (File path) = (dropExtension $ fileName path) == "thumbnail"
diff --git a/compiler/src/Processors.hs b/compiler/src/Processors.hs
index 7362822..ded3cc5 100644
--- a/compiler/src/Processors.hs
+++ b/compiler/src/Processors.hs
@@ -59,8 +59,8 @@ data Format =
   | Gif -- TODO: might be animated
   | Other
 
-formatFromExt :: String -> Format
-formatFromExt = aux . (map toLower)
+formatFromPath :: Path -> Format
+formatFromPath = aux . (map toLower) . fileName
   where
     aux ".bmp" = Bmp
     aux ".jpg" = Jpg
@@ -169,10 +169,9 @@ type ItemFileProcessor =
 
 itemFileProcessor :: Maybe Resolution -> Cache -> ItemFileProcessor
 itemFileProcessor maxRes cached inputBase outputBase resClass inputRes =
-  cached (processor maxRes (extOf inputRes)) inPath outPath
+  cached (processor maxRes (formatFromPath inputRes)) inPath outPath
   >> return relOutPath
   where
-    extOf = formatFromExt . takeExtension . head
     relOutPath = resClass /> inputRes
     inPath = localPath $ inputBase /> inputRes
     outPath = localPath $ outputBase /> relOutPath
@@ -196,10 +195,9 @@ type ThumbnailFileProcessor =
 
 thumbnailFileProcessor :: Resolution -> Cache -> ThumbnailFileProcessor
 thumbnailFileProcessor maxRes cached inputBase outputBase resClass inputRes =
-  cached <$> processor (extOf inputRes)
+  cached <$> processor (formatFromPath inputRes)
   & process
   where
-    extOf = formatFromExt . takeExtension . head
     relOutPath = resClass /> inputRes
     inPath = localPath $ inputBase /> inputRes
     outPath = localPath $ outputBase /> relOutPath
diff --git a/compiler/src/Resource.hs b/compiler/src/Resource.hs
index 9d60185..afc8203 100644
--- a/compiler/src/Resource.hs
+++ b/compiler/src/Resource.hs
@@ -100,7 +100,7 @@ outputDiff resources ref =
     resPaths resList = map resPath resList ++ thumbnailPaths resList
 
     thumbnailPaths :: [ResourceTree] -> [Path]
-    thumbnailPaths = (concatMap subsequences) . (mapMaybe thumbnailPath)
+    thumbnailPaths = (concatMap subPaths) . (mapMaybe thumbnailPath)
 
     fsPaths :: FSNode -> [Path]
     fsPaths = map nodePath . tail . flattenDir
@@ -109,6 +109,6 @@ cleanupResourceDir :: ResourceTree -> FileName -> IO ()
 cleanupResourceDir resourceTree outputDir =
   readDirectory outputDir
   >>= return . outputDiff resourceTree . root
-  >>= return . sortBy (flip $ comparing length) -- nested files before dirs
+  >>= return . sortBy (flip $ comparing pathLength) -- nested files before dirs
   >>= return . map (localPath . (/>) outputDir)
   >>= mapM_ remove
-- 
cgit v1.2.3