{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Dhall.DirectoryTree
(
toDirectoryTree
, FilesystemError(..)
) where
import Control.Applicative (empty)
import Control.Exception (Exception)
import Data.Monoid ((<>))
import Data.Void (Void)
import Dhall.Syntax (Chunks(..), Expr(..))
import System.FilePath ((</>))
import qualified Control.Exception as Exception
import qualified Data.Foldable as Foldable
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO
import qualified Data.Text.Prettyprint.Doc.Render.String as Pretty
import qualified Dhall.Map as Map
import qualified Dhall.Pretty
import qualified Dhall.Util as Util
import qualified System.Directory as Directory
import qualified System.FilePath as FilePath
toDirectoryTree :: FilePath -> Expr Void Void -> IO ()
toDirectoryTree path expression = case expression of
RecordLit keyValues -> do
Map.unorderedTraverseWithKey_ process keyValues
ListLit (Just (Record [ ("mapKey", Text), ("mapValue", _) ])) [] -> do
return ()
ListLit _ records
| not (null records)
, Just keyValues <- extract (Foldable.toList records) -> do
Foldable.traverse_ (uncurry process) keyValues
TextLit (Chunks [] text) -> do
Text.IO.writeFile path text
Some value -> do
toDirectoryTree path value
App (Field (Union _) _) value -> do
toDirectoryTree path value
App None _ -> do
return ()
_ -> do
die
where
extract [] = do
return []
extract (RecordLit [("mapKey", TextLit (Chunks [] key)), ("mapValue", value)]:records) = do
fmap ((key, value) :) (extract records)
extract _ = do
empty
process key value = do
if Text.isInfixOf (Text.pack [ FilePath.pathSeparator ]) key
then die
else return ()
Directory.createDirectoryIfMissing False path
toDirectoryTree (path </> Text.unpack key) value
die = Exception.throwIO FilesystemError{..}
where
unexpectedExpression = expression
newtype FilesystemError =
FilesystemError { unexpectedExpression :: Expr Void Void }
instance Show FilesystemError where
show FilesystemError{..} =
Pretty.renderString (Dhall.Pretty.layout message)
where
message =
Util._ERROR <> ": Not a valid directory tree expression\n\
\ \n\
\Explanation: Only a subset of Dhall expressions can be converted to a directory \n\
\tree. Specifically, record literals or maps can be converted to directories, \n\
\❰Text❱ literals can be converted to files, and ❰Optional❱ values are included if\n\
\❰Some❱ and omitted if ❰None❱. Values of union types can also be converted if \n\
\they are an alternative which has a non-nullary constructor whose argument is of\n\
\an otherwise convertible type. No other type of value can be translated to a \n\
\directory tree. \n\
\ \n\
\For example, this is a valid expression that can be translated to a directory \n\
\tree: \n\
\ \n\
\ \n\
\ ┌──────────────────────────────────┐ \n\
\ │ { `example.json` = \"[1, true]\" } │ \n\
\ └──────────────────────────────────┘ \n\
\ \n\
\ \n\
\In contrast, the following expression is not allowed due to containing a \n\
\❰Natural❱ field, which cannot be translated in this way: \n\
\ \n\
\ \n\
\ ┌───────────────────────┐ \n\
\ │ { `example.txt` = 1 } │ \n\
\ └───────────────────────┘ \n\
\ \n\
\ \n\
\Note that key names cannot contain path separators: \n\
\ \n\
\ \n\
\ ┌───────────────────────────────────┐ \n\
\ │ { `directory/example.txt` = \"ABC\" │ Invalid: Key contains a forward slash \n\
\ └───────────────────────────────────┘ \n\
\ \n\
\ \n\
\Instead, you need to refactor the expression to use nested records instead: \n\
\ \n\
\ \n\
\ ┌───────────────────────────────────────────┐ \n\
\ │ { directory = { `example.txt` = \"ABC\" } } │ \n\
\ └───────────────────────────────────────────┘ \n\
\ \n\
\ \n\
\You tried to translate the following expression to a directory tree: \n\
\ \n\
\" <> Util.insert unexpectedExpression <> "\n\
\ \n\
\... which is not an expression that can be translated to a directory tree. \n"
instance Exception FilesystemError