aboutsummaryrefslogtreecommitdiff
path: root/compiler/src/Input.hs
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/src/Input.hs')
-rw-r--r--compiler/src/Input.hs65
1 files changed, 40 insertions, 25 deletions
diff --git a/compiler/src/Input.hs b/compiler/src/Input.hs
index 6ed7471..48931ec 100644
--- a/compiler/src/Input.hs
+++ b/compiler/src/Input.hs
@@ -27,13 +27,15 @@ import GHC.Generics (Generic)
27import Control.Exception (Exception, AssertionFailed(..), throw, throwIO) 27import Control.Exception (Exception, AssertionFailed(..), throw, throwIO)
28import Control.Monad.IO.Class (MonadIO, liftIO) 28import Control.Monad.IO.Class (MonadIO, liftIO)
29import Data.Function ((&)) 29import Data.Function ((&))
30import Data.Maybe (catMaybes) 30import Data.Functor ((<&>))
31import Data.Maybe (catMaybes, fromMaybe)
31import Data.Bool (bool) 32import Data.Bool (bool)
32import Data.List (find) 33import Data.List (find, isSuffixOf)
33import Data.Time.Clock (UTCTime) 34import Data.Time.Clock (UTCTime)
34import Data.Time.LocalTime (ZonedTime) 35import Data.Time.LocalTime (ZonedTime)
35import Data.Yaml (ParseException, decodeFileEither) 36import Data.Yaml (ParseException, decodeFileEither)
36import Data.Aeson (FromJSON) 37import Data.Aeson (FromJSON)
38import qualified Data.Map.Strict as Map
37import System.FilePath (isExtensionOf, dropExtension) 39import System.FilePath (isExtensionOf, dropExtension)
38import System.Directory (doesFileExist, getModificationTime) 40import System.Directory (doesFileExist, getModificationTime)
39 41
@@ -54,12 +56,13 @@ data InputTree =
54 InputFile 56 InputFile
55 { path :: Path 57 { path :: Path
56 , modTime :: UTCTime 58 , modTime :: UTCTime
57 , sidecar :: Sidecar } 59 , sidecar :: Sidecar
60 , thumbnailPath :: Maybe Path }
58 | InputDir 61 | InputDir
59 { path :: Path 62 { path :: Path
60 , modTime :: UTCTime 63 , modTime :: UTCTime
61 , sidecar :: Sidecar 64 , sidecar :: Sidecar
62 , dirThumbnailPath :: Maybe Path 65 , thumbnailPath :: Maybe Path
63 , items :: [InputTree] } 66 , items :: [InputTree] }
64 deriving Show 67 deriving Show
65 68
@@ -80,6 +83,9 @@ emptySidecar = Sidecar
80sidecarExt :: String 83sidecarExt :: String
81sidecarExt = "yaml" 84sidecarExt = "yaml"
82 85
86thumbnailSuffix :: String
87thumbnailSuffix = "_thumbnail"
88
83dirPropFile :: String 89dirPropFile :: String
84dirPropFile = "_directory" 90dirPropFile = "_directory"
85 91
@@ -90,7 +96,7 @@ readSidecarFile :: FilePath -> IO Sidecar
90readSidecarFile filepath = 96readSidecarFile filepath =
91 doesFileExist filepath 97 doesFileExist filepath
92 >>= bool (return Nothing) (decodeYamlFile filepath) 98 >>= bool (return Nothing) (decodeYamlFile filepath)
93 >>= return . maybe emptySidecar id 99 <&> fromMaybe emptySidecar
94 100
95 101
96readInputTree :: AnchoredFSNode -> IO InputTree 102readInputTree :: AnchoredFSNode -> IO InputTree
@@ -98,40 +104,49 @@ readInputTree (AnchoredFSNode _ File{}) =
98 throw $ AssertionFailed "Input directory is a file" 104 throw $ AssertionFailed "Input directory is a file"
99readInputTree (AnchoredFSNode anchor root@Dir{}) = mkDirNode root 105readInputTree (AnchoredFSNode anchor root@Dir{}) = mkDirNode root
100 where 106 where
101 mkInputNode :: FSNode -> IO (Maybe InputTree) 107 mkInputNode :: Map.Map FileName FSNode -> FSNode -> IO (Maybe InputTree)
102 mkInputNode file@File{path} 108 mkInputNode dir file@File{path} | not (isSidecar file) && not (isThumbnail file) =
103 | (not $ isSidecar file) && (not $ isThumbnail file) = 109 do
104 do 110 sidecar <- readSidecarFile $ localPath (anchor /> path <.> sidecarExt)
105 sidecar <- readSidecarFile $ localPath (anchor /> path <.> sidecarExt) 111 modTime <- getModificationTime $ localPath (anchor /> path)
106 modTime <- getModificationTime $ localPath (anchor /> path) 112 let thumbnail = findFileThumbnail (fromMaybe "" $ fileName path) dir
107 return $ Just $ InputFile path modTime sidecar 113 return $ Just $ InputFile path modTime sidecar thumbnail
108 mkInputNode File{} = return Nothing 114 mkInputNode _ File{} = return Nothing
109 mkInputNode dir@Dir{} = mkDirNode dir >>= return . Just 115 mkInputNode _ dir@Dir{} = Just <$> mkDirNode dir
110 116
111 mkDirNode :: FSNode -> IO InputTree 117 mkDirNode :: FSNode -> IO InputTree
112 mkDirNode File{} = throw $ AssertionFailed "Input directory is a file" 118 mkDirNode File{} = throw $ AssertionFailed "Input directory is a file"
113 mkDirNode Dir{path, items} = 119 mkDirNode Dir{path, items} =
114 do 120 do
115 dirItems <- mapM mkInputNode items 121 dirItems <- mapM (mkInputNode $ Map.fromList (map withBaseName items)) items
116 modTime <- getModificationTime $ localPath (anchor /> path) 122 modTime <- getModificationTime $ localPath (anchor /> path)
117 sidecar <- readSidecarFile $ localPath (anchor /> path </> dirSidecar) 123 sidecar <- readSidecarFile $ localPath (anchor /> path </> dirSidecar)
118 return $ InputDir path modTime sidecar (findThumbnail items) (catMaybes dirItems) 124 return $ InputDir path modTime sidecar (findDirThumbnail items) (catMaybes dirItems)
125
126 withBaseName :: FSNode -> (FileName, FSNode)
127 withBaseName node = (fromMaybe "" $ baseName $ Files.path node, node)
128
129 findFileThumbnail :: FileName -> Map.Map FileName FSNode -> Maybe Path
130 findFileThumbnail name dict = Files.path <$> Map.lookup (name ++ thumbnailSuffix) dict
119 131
120 isSidecar :: FSNode -> Bool 132 isSidecar :: FSNode -> Bool
121 isSidecar Dir{} = False 133 isSidecar Dir{} = False
122 isSidecar File{path} = 134 isSidecar File{path} = fileName path & maybe False (isExtensionOf sidecarExt)
123 fileName path 135
124 & (maybe False $ isExtensionOf sidecarExt) 136 baseName :: Path -> Maybe FileName
137 baseName = fmap dropExtension . fileName
125 138
126 isThumbnail :: FSNode -> Bool 139 isThumbnail :: FSNode -> Bool
127 isThumbnail Dir{} = False 140 isThumbnail Dir{} = False
128 isThumbnail File{path} = 141 isThumbnail File{path} = baseName path & maybe False (thumbnailSuffix `isSuffixOf`)
129 fileName path 142
130 & fmap dropExtension 143 isDirThumbnail :: FSNode -> Bool
131 & (maybe False (dirPropFile ==)) 144 isDirThumbnail Dir{} = False
145 isDirThumbnail File{path} = baseName path & (== Just thumbnailSuffix)
146
147 findDirThumbnail :: [FSNode] -> Maybe Path
148 findDirThumbnail = fmap Files.path . find isDirThumbnail
132 149
133 findThumbnail :: [FSNode] -> Maybe Path
134 findThumbnail = (fmap Files.path) . (find isThumbnail)
135 150
136-- | Filters an InputTree. The root is always returned. 151-- | Filters an InputTree. The root is always returned.
137filterInputTree :: (InputTree -> Bool) -> InputTree -> InputTree 152filterInputTree :: (InputTree -> Bool) -> InputTree -> InputTree