From 2a6467272e18af4864745b9d0267f9fa3ed382dd Mon Sep 17 00:00:00 2001
From: pacien
Date: Thu, 26 Dec 2019 01:13:42 +0100
Subject: compiler: implement output dir cleanup

---
 compiler/src/Files.hs    | 11 ++++++-----
 compiler/src/Lib.hs      | 32 +++++++++++++++++++-------------
 compiler/src/Resource.hs | 35 ++++++++++++++++++++++++++++++-----
 3 files changed, 55 insertions(+), 23 deletions(-)

(limited to 'compiler/src')

diff --git a/compiler/src/Files.hs b/compiler/src/Files.hs
index 30e4b94..77a8c5b 100644
--- a/compiler/src/Files.hs
+++ b/compiler/src/Files.hs
@@ -23,7 +23,7 @@ module Files
   ( FileName, LocalPath, WebPath, Path
   , (</>), (</), (/>), localPath, webPath
   , FSNode(..), AnchoredFSNode(..)
-  , nodePath, nodeName, isHidden, flatten, filterDir, readDirectory
+  , nodePath, nodeName, isHidden, flattenDir, filterDir, readDirectory
   ) where
 
 
@@ -76,9 +76,10 @@ isHidden :: FSNode -> Bool
 isHidden node = "." `isPrefixOf` filename && length filename > 1
   where filename = nodeName node
 
-flatten :: FSNode -> [FSNode]
-flatten file@(File _) = [file]
-flatten dir@(Dir _ childs) = dir:(concatMap flatten childs)
+-- | DFS with intermediate dirs first.
+flattenDir :: FSNode -> [FSNode]
+flattenDir file@(File _) = [file]
+flattenDir dir@(Dir _ childs) = dir:(concatMap flattenDir childs)
 
 -- | Filters a dir tree. The root is always returned.
 filterDir :: (FSNode -> Bool) -> FSNode -> FSNode
@@ -87,7 +88,7 @@ filterDir cond (Dir path childs) =
   filter cond childs & map (filterDir cond) & Dir path
 
 readDirectory :: LocalPath -> IO AnchoredFSNode
-readDirectory root = mkNode [""] >>= return . AnchoredFSNode root
+readDirectory root = mkNode [] >>= return . AnchoredFSNode root
   where
     mkNode :: Path -> IO FSNode
     mkNode path =
diff --git a/compiler/src/Lib.hs b/compiler/src/Lib.hs
index 2068b4a..643e5f6 100644
--- a/compiler/src/Lib.hs
+++ b/compiler/src/Lib.hs
@@ -26,15 +26,17 @@ module Lib
 
 import GHC.Generics (Generic)
 import Data.Function ((&))
-import System.Directory (createDirectoryIfMissing)
+import Data.Ord (comparing)
+import Data.List (sortBy, length)
+import System.Directory (createDirectoryIfMissing, removePathForcibly)
 import System.FilePath (dropFileName, (</>))
 
 import Data.Aeson (ToJSON, FromJSON)
 import qualified Data.Aeson as JSON
 
-import Files (FileName, readDirectory)
+import Files (FileName, readDirectory, localPath, flattenDir, root, (/>))
 import Input (decodeYamlFile, readInputTree)
-import Resource (buildResourceTree)
+import Resource (ResourceTree, buildResourceTree, outputDiff)
 import Gallery (buildGalleryTree)
 
 
@@ -60,10 +62,6 @@ process inputDirPath outputDirPath =
     putStrLn "\nINPUT DIR"
     putStrLn (show inputDir)
 
-    outputDir <- readDirectory outputDirPath
-    putStrLn "\nOUTPUT DIR"
-    putStrLn (show outputDir)
-
     inputTree <- readInputTree inputDir
     putStrLn "\nINPUT TREE"
     putStrLn (show inputTree)
@@ -79,18 +77,26 @@ process inputDirPath outputDirPath =
     --   (or recompile everything if the config file has changed!)
     -- execute in parallel
 
-    -- TODO: clean up output dir by comparing its content with the resource tree
-    -- aggregate both trees as list
-    -- compute the difference
-    -- sort by deepest and erase files and dirs
+    cleanup resourceTree outputDirPath
 
     -- TODO: execute (in parallel) the resource compilation strategy list
     -- need to find a good library for that
 
-    buildGalleryTree resourceTree & writeJSON (outputDirPath </> "index.json")
-    writeJSON (outputDirPath </> "viewer.json") (viewer config)
+    buildGalleryTree resourceTree
+      & writeJSON (outputDirPath </> "index.json")
+
+    viewer config
+      & writeJSON (outputDirPath </> "viewer.json")
 
   where
+    cleanup :: ResourceTree -> FileName -> IO ()
+    cleanup resourceTree outputDir =
+      readDirectory outputDir
+      >>= return . outputDiff resourceTree . root
+      >>= return . sortBy (flip $ comparing length) -- nested files before dirs
+      >>= return . map (localPath . (/>) outputDir)
+      >>= mapM_ removePathForcibly
+
     writeJSON :: ToJSON a => FileName -> a -> IO ()
     writeJSON path obj =
       createDirectoryIfMissing True (dropFileName path)
diff --git a/compiler/src/Resource.hs b/compiler/src/Resource.hs
index 04e315a..60b783e 100644
--- a/compiler/src/Resource.hs
+++ b/compiler/src/Resource.hs
@@ -22,10 +22,13 @@
 module Resource
   ( ResourceTree(..)
   , buildResourceTree
+  , flattenResourceTree
+  , outputDiff
   ) where
 
 
 import Data.Function ((&))
+import Data.List ((\\))
 import Files
 import Input
 
@@ -34,25 +37,47 @@ import Input
 data ResourceTree =
     ItemResource
       { sidecar :: Sidecar
-      , path :: Path
+      , resPath :: Path
       , itemThumbnailPath :: Path }
   | DirResource
       { items :: [ResourceTree]
-      , path :: Path
+      , resPath :: Path
       , dirThumbnailPath :: Maybe Path }
   deriving Show
 
 
-  -- TODO: actually generate compilation strategies
+-- TODO: actually generate compilation strategies
 buildResourceTree :: InputTree -> ResourceTree
 buildResourceTree = resNode
   where
     resNode (InputFile path sidecar) =
-      ItemResource sidecar (itemsDir /> path) (thumbnailsDir /> path)
+      ItemResource
+        { sidecar = sidecar
+        , resPath = itemsDir /> path
+        , itemThumbnailPath = thumbnailsDir /> path }
 
     resNode (InputDir path thumbnailPath items) =
       map resNode items
-      & \dirItems -> DirResource dirItems (itemsDir /> path) Nothing
+      & \dirItems -> DirResource
+        { items = dirItems
+        , resPath = itemsDir /> path
+        , dirThumbnailPath = fmap ((/>) thumbnailsDir) thumbnailPath }
 
     itemsDir = "items"
     thumbnailsDir = "thumbnails"
+
+
+flattenResourceTree :: ResourceTree -> [ResourceTree]
+flattenResourceTree item@ItemResource{} = [item]
+flattenResourceTree dir@(DirResource items _ _) =
+  dir:(concatMap flattenResourceTree items)
+
+
+outputDiff :: ResourceTree -> FSNode -> [Path]
+outputDiff resources ref = (fsPaths ref) \\ (resPaths resources)
+  where
+    resPaths :: ResourceTree -> [Path]
+    resPaths = map resPath . flattenResourceTree
+
+    fsPaths :: FSNode -> [Path]
+    fsPaths = map nodePath . tail . flattenDir
-- 
cgit v1.2.3