{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
module Dhall.Package
( Options
, defaultOptions
, characterSet
, packageFileName
, packagingMode
, PackagingMode(..)
, writePackage
, getPackagePathAndContent
, PackageError(..)
) where
import Control.Exception (Exception, throwIO)
import Control.Monad
import Data.List.NonEmpty (NonEmpty (..))
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Traversable (for)
import Dhall.Core
( Directory (..)
, Expr (..)
, File (..)
, FilePrefix (..)
, Import (..)
, ImportHashed (..)
, ImportMode (..)
, ImportType (..)
, RecordField (..)
, makeRecordField
)
import Dhall.Map (Map)
import qualified Dhall.Map as Map
import Dhall.Pretty (CharacterSet (..))
import qualified Dhall.Pretty
import Dhall.Util (_ERROR, renderExpression)
import Lens.Micro (Lens', lens)
import System.Directory
import System.FilePath
data Options = Options
{ Options -> CharacterSet
optionsCharacterSet :: CharacterSet
, Options -> String
optionsPackageFileName :: String
, Options -> PackagingMode
optionsPackagingMode :: PackagingMode
}
defaultOptions :: Options
defaultOptions :: Options
defaultOptions = Options
{ optionsCharacterSet :: CharacterSet
optionsCharacterSet = CharacterSet
Dhall.Pretty.defaultCharacterSet
, optionsPackageFileName :: String
optionsPackageFileName = String
"package.dhall"
, optionsPackagingMode :: PackagingMode
optionsPackagingMode = PackagingMode
OnlyThisPackage
}
characterSet :: Lens' Options CharacterSet
characterSet :: Lens' Options CharacterSet
characterSet = (Options -> CharacterSet)
-> (Options -> CharacterSet -> Options)
-> Lens' Options CharacterSet
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Options -> CharacterSet
optionsCharacterSet (\Options
s CharacterSet
x -> Options
s { optionsCharacterSet = x })
packageFileName :: Lens' Options String
packageFileName :: Lens' Options String
packageFileName =
(Options -> String)
-> (Options -> String -> Options) -> Lens' Options String
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Options -> String
optionsPackageFileName (\Options
s String
x -> Options
s { optionsPackageFileName = x })
packagingMode :: Lens' Options PackagingMode
packagingMode :: Lens' Options PackagingMode
packagingMode =
(Options -> PackagingMode)
-> (Options -> PackagingMode -> Options)
-> Lens' Options PackagingMode
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Options -> PackagingMode
optionsPackagingMode (\Options
s PackagingMode
x -> Options
s { optionsPackagingMode = x })
data PackagingMode
= OnlyThisPackage
| RecursiveSubpackages
writePackage :: Options -> NonEmpty FilePath -> IO ()
writePackage :: Options -> NonEmpty String -> IO ()
writePackage Options
options NonEmpty String
inputs = do
(outputPath, expr) <- Options -> NonEmpty String -> IO (String, Expr Src Import)
forall s. Options -> NonEmpty String -> IO (String, Expr s Import)
getPackagePathAndContent Options
options NonEmpty String
inputs
renderExpression (optionsCharacterSet options) True (Just outputPath) expr
getPackagePathAndContent
:: Options
-> NonEmpty FilePath
-> IO (FilePath, Expr s Import)
getPackagePathAndContent :: forall s. Options -> NonEmpty String -> IO (String, Expr s Import)
getPackagePathAndContent Options
options (String
path :| [String]
paths) = do
outputDir <- do
isDirectory <- String -> IO Bool
doesDirectoryExist String
path
return $ if isDirectory then path else takeDirectory path
outputDir' <- addTrailingPathSeparator <$> makeAbsolute (normalise outputDir)
let checkOutputDir String
dir = do
absoluteDir <- String -> String
addTrailingPathSeparator (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
makeAbsolute (String -> String
normalise String
dir)
let relativeDir = String -> String -> String
makeRelative String
outputDir' String
absoluteDir
unless (isRelative relativeDir) $
throwIO $ AmbiguousOutputDirectory outputDir dir
return relativeDir
resultMap <- go Map.empty checkOutputDir (path:paths)
return (outputDir </> outputFn, RecordLit $ Map.sort resultMap)
where
go
:: Map Text (RecordField s Import)
-> (FilePath -> IO FilePath)
-> [FilePath]
-> IO (Map Text (RecordField s Import))
go :: forall s.
Map Text (RecordField s Import)
-> (String -> IO String)
-> [String]
-> IO (Map Text (RecordField s Import))
go !Map Text (RecordField s Import)
acc String -> IO String
_checkOutputDir [] = Map Text (RecordField s Import)
-> IO (Map Text (RecordField s Import))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Map Text (RecordField s Import)
acc
go !Map Text (RecordField s Import)
acc String -> IO String
checkOutputDir (String
p:[String]
ps) = do
isDirectory <- String -> IO Bool
doesDirectoryExist String
p
isFile <- doesFileExist p
if | isDirectory -> do
void $ checkOutputDir p
entries <- listDirectory p
(dhallFiles, subdirectories) <- foldMap
( \String
entry -> do
let entry' :: String
entry' = String
p String -> String -> String
</> String
entry
isDirectoryEntry <- String -> IO Bool
doesDirectoryExist String
entry'
return $ if isDirectoryEntry
then (mempty, [entry'])
else if hasDhallExtension entry
then ([entry'], mempty)
else mempty
) entries
subpackages <- case optionsPackagingMode options of
PackagingMode
RecursiveSubpackages ->
[String] -> (String -> IO String) -> IO [String]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [String]
subdirectories ((String -> IO String) -> IO [String])
-> (String -> IO String) -> IO [String]
forall a b. (a -> b) -> a -> b
$ \String
subdirectory -> do
Options -> NonEmpty String -> IO ()
writePackage Options
options (String
subdirectory String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| [])
String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
subdirectory String -> String -> String
</> String
outputFn)
PackagingMode
OnlyThisPackage -> [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
go acc checkOutputDir (dhallFiles <> subpackages <> ps)
| isFile -> do
dir <- checkOutputDir $ takeDirectory p
let p' = String -> String
normalise (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
dir String -> String -> String
</> String -> String
takeFileName String
p
let resultMap = if String
p' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
outputFn
then Map Text (RecordField s Import)
forall k v. Ord k => Map k v
Map.empty
else String -> String -> Map Text (RecordField s Import)
forall s. String -> String -> Map Text (RecordField s Import)
filepathToMap String
outputFn String
p'
acc' <- mergeMaps acc resultMap
go acc' checkOutputDir ps
| otherwise -> throwIO $ InvalidPath p
hasDhallExtension :: FilePath -> Bool
hasDhallExtension :: String -> Bool
hasDhallExtension String
entry = String -> String
takeExtension String
entry String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".dhall"
outputFn :: String
outputFn :: String
outputFn = Options -> String
optionsPackageFileName Options
options
filepathToMap :: FilePath -> FilePath -> Map Text (RecordField s Import)
filepathToMap :: forall s. String -> String -> Map Text (RecordField s Import)
filepathToMap String
outputFn = [Text] -> [String] -> Map Text (RecordField s Import)
forall {s}. [Text] -> [String] -> Map Text (RecordField s Import)
go [] ([String] -> Map Text (RecordField s Import))
-> (String -> [String])
-> String
-> Map Text (RecordField s Import)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
splitDirectories
where
go :: [Text] -> [String] -> Map Text (RecordField s Import)
go [Text]
acc [] = [Text] -> [String] -> Map Text (RecordField s Import)
go [Text]
acc [String
"."]
go ![Text]
acc [String
x] =
let import_ :: Import
import_ = Import
{ importHashed :: ImportHashed
importHashed = ImportHashed
{ hash :: Maybe SHA256Digest
hash = Maybe SHA256Digest
forall a. Maybe a
Nothing
, importType :: ImportType
importType = FilePrefix -> File -> ImportType
Local FilePrefix
Here File
{ directory :: Directory
directory = [Text] -> Directory
Directory [Text]
acc
, file :: Text
file = String -> Text
Text.pack String
x
}
}
, importMode :: ImportMode
importMode = ImportMode
Code
}
in Text -> RecordField s Import -> Map Text (RecordField s Import)
forall k v. k -> v -> Map k v
Map.singleton (String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> String
dropExtension String
x) (RecordField s Import -> Map Text (RecordField s Import))
-> RecordField s Import -> Map Text (RecordField s Import)
forall a b. (a -> b) -> a -> b
$ Expr s Import -> RecordField s Import
forall s a. Expr s a -> RecordField s a
makeRecordField (Expr s Import -> RecordField s Import)
-> Expr s Import -> RecordField s Import
forall a b. (a -> b) -> a -> b
$ Import -> Expr s Import
forall s a. a -> Expr s a
Embed Import
import_
go ![Text]
acc [String
x, String
y] | String
y String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
outputFn =
let import_ :: Import
import_ = Import
{ importHashed :: ImportHashed
importHashed = ImportHashed
{ hash :: Maybe SHA256Digest
hash = Maybe SHA256Digest
forall a. Maybe a
Nothing
, importType :: ImportType
importType = FilePrefix -> File -> ImportType
Local FilePrefix
Here File
{ directory :: Directory
directory = [Text] -> Directory
Directory (String -> Text
Text.pack String
x Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc)
, file :: Text
file = String -> Text
Text.pack String
y
}
}
, importMode :: ImportMode
importMode = ImportMode
Code
}
in Text -> RecordField s Import -> Map Text (RecordField s Import)
forall k v. k -> v -> Map k v
Map.singleton (String -> Text
Text.pack String
x) (RecordField s Import -> Map Text (RecordField s Import))
-> RecordField s Import -> Map Text (RecordField s Import)
forall a b. (a -> b) -> a -> b
$ Expr s Import -> RecordField s Import
forall s a. Expr s a -> RecordField s a
makeRecordField (Expr s Import -> RecordField s Import)
-> Expr s Import -> RecordField s Import
forall a b. (a -> b) -> a -> b
$ Import -> Expr s Import
forall s a. a -> Expr s a
Embed Import
import_
go ![Text]
acc (String
x:[String]
xs) = Text -> RecordField s Import -> Map Text (RecordField s Import)
forall k v. k -> v -> Map k v
Map.singleton (String -> Text
Text.pack String
x) (RecordField s Import -> Map Text (RecordField s Import))
-> RecordField s Import -> Map Text (RecordField s Import)
forall a b. (a -> b) -> a -> b
$ Expr s Import -> RecordField s Import
forall s a. Expr s a -> RecordField s a
makeRecordField (Expr s Import -> RecordField s Import)
-> Expr s Import -> RecordField s Import
forall a b. (a -> b) -> a -> b
$ Map Text (RecordField s Import) -> Expr s Import
forall s a. Map Text (RecordField s a) -> Expr s a
RecordLit (Map Text (RecordField s Import) -> Expr s Import)
-> Map Text (RecordField s Import) -> Expr s Import
forall a b. (a -> b) -> a -> b
$ [Text] -> [String] -> Map Text (RecordField s Import)
go (String -> Text
Text.pack String
x Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc) [String]
xs
mergeMaps :: Map Text (RecordField s Import) -> Map Text (RecordField s Import) -> IO (Map Text (RecordField s Import))
mergeMaps :: forall s.
Map Text (RecordField s Import)
-> Map Text (RecordField s Import)
-> IO (Map Text (RecordField s Import))
mergeMaps Map Text (RecordField s Import)
x Map Text (RecordField s Import)
y = do
let x' :: Map Text (NonEmpty (RecordField s Import))
x' = (RecordField s Import -> NonEmpty (RecordField s Import))
-> Map Text (RecordField s Import)
-> Map Text (NonEmpty (RecordField s Import))
forall a b. (a -> b) -> Map Text a -> Map Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RecordField s Import
-> [RecordField s Import] -> NonEmpty (RecordField s Import)
forall a. a -> [a] -> NonEmpty a
:| []) Map Text (RecordField s Import)
x
y' :: Map Text (NonEmpty (RecordField s Import))
y' = (RecordField s Import -> NonEmpty (RecordField s Import))
-> Map Text (RecordField s Import)
-> Map Text (NonEmpty (RecordField s Import))
forall a b. (a -> b) -> Map Text a -> Map Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RecordField s Import
-> [RecordField s Import] -> NonEmpty (RecordField s Import)
forall a. a -> [a] -> NonEmpty a
:| []) Map Text (RecordField s Import)
y
z :: Map Text (NonEmpty (RecordField s Import))
z = (NonEmpty (RecordField s Import)
-> NonEmpty (RecordField s Import)
-> NonEmpty (RecordField s Import))
-> Map Text (NonEmpty (RecordField s Import))
-> Map Text (NonEmpty (RecordField s Import))
-> Map Text (NonEmpty (RecordField s Import))
forall k v. Ord k => (v -> v -> v) -> Map k v -> Map k v -> Map k v
Map.unionWith NonEmpty (RecordField s Import)
-> NonEmpty (RecordField s Import)
-> NonEmpty (RecordField s Import)
forall a. Semigroup a => a -> a -> a
(<>) Map Text (NonEmpty (RecordField s Import))
x' Map Text (NonEmpty (RecordField s Import))
y'
Map Text (NonEmpty (RecordField s Import))
-> (NonEmpty (RecordField s Import) -> IO (RecordField s Import))
-> IO (Map Text (RecordField s Import))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Map Text (NonEmpty (RecordField s Import))
z ((NonEmpty (RecordField s Import) -> IO (RecordField s Import))
-> IO (Map Text (RecordField s Import)))
-> (NonEmpty (RecordField s Import) -> IO (RecordField s Import))
-> IO (Map Text (RecordField s Import))
forall a b. (a -> b) -> a -> b
$ \case
v :: RecordField s Import
v@RecordField{recordFieldValue :: forall s a. RecordField s a -> Expr s a
recordFieldValue = Embed{}} :| [] -> RecordField s Import -> IO (RecordField s Import)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RecordField s Import
v
NonEmpty (RecordField s Import)
vs | Just NonEmpty (Map Text (RecordField s Import))
rs <- (RecordField s Import -> Maybe (Map Text (RecordField s Import)))
-> NonEmpty (RecordField s Import)
-> Maybe (NonEmpty (Map Text (RecordField s Import)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
traverse RecordField s Import -> Maybe (Map Text (RecordField s Import))
forall s.
RecordField s Import -> Maybe (Map Text (RecordField s Import))
extractRecordLit NonEmpty (RecordField s Import)
vs -> Expr s Import -> RecordField s Import
forall s a. Expr s a -> RecordField s a
makeRecordField (Expr s Import -> RecordField s Import)
-> (Map Text (RecordField s Import) -> Expr s Import)
-> Map Text (RecordField s Import)
-> RecordField s Import
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text (RecordField s Import) -> Expr s Import
forall s a. Map Text (RecordField s a) -> Expr s a
RecordLit (Map Text (RecordField s Import) -> Expr s Import)
-> (Map Text (RecordField s Import)
-> Map Text (RecordField s Import))
-> Map Text (RecordField s Import)
-> Expr s Import
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text (RecordField s Import) -> Map Text (RecordField s Import)
forall k v. Map k v -> Map k v
Map.sort (Map Text (RecordField s Import) -> RecordField s Import)
-> IO (Map Text (RecordField s Import))
-> IO (RecordField s Import)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Map Text (RecordField s Import)
-> Map Text (RecordField s Import)
-> IO (Map Text (RecordField s Import)))
-> Map Text (RecordField s Import)
-> NonEmpty (Map Text (RecordField s Import))
-> IO (Map Text (RecordField s Import))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Map Text (RecordField s Import)
-> Map Text (RecordField s Import)
-> IO (Map Text (RecordField s Import))
forall s.
Map Text (RecordField s Import)
-> Map Text (RecordField s Import)
-> IO (Map Text (RecordField s Import))
mergeMaps Map Text (RecordField s Import)
forall k v. Ord k => Map k v
Map.empty NonEmpty (Map Text (RecordField s Import))
rs
| Bool
otherwise -> PackageError -> IO (RecordField s Import)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (PackageError -> IO (RecordField s Import))
-> PackageError -> IO (RecordField s Import)
forall a b. (a -> b) -> a -> b
$ [Import] -> PackageError
IncompatiblePaths ([Import] -> PackageError) -> [Import] -> PackageError
forall a b. (a -> b) -> a -> b
$ (RecordField s Import -> [Import])
-> NonEmpty (RecordField s Import) -> [Import]
forall m a. Monoid m => (a -> m) -> NonEmpty a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap RecordField s Import -> [Import]
forall s. RecordField s Import -> [Import]
extractEmbeds NonEmpty (RecordField s Import)
vs
where
extractEmbeds :: RecordField s Import -> [Import]
extractEmbeds :: forall s. RecordField s Import -> [Import]
extractEmbeds RecordField{recordFieldValue :: forall s a. RecordField s a -> Expr s a
recordFieldValue = Embed Import
import_} = [Import
import_]
extractEmbeds RecordField{recordFieldValue :: forall s a. RecordField s a -> Expr s a
recordFieldValue = RecordLit Map Text (RecordField s Import)
xs} = (RecordField s Import -> [Import])
-> Map Text (RecordField s Import) -> [Import]
forall m a. Monoid m => (a -> m) -> Map Text a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap RecordField s Import -> [Import]
forall s. RecordField s Import -> [Import]
extractEmbeds Map Text (RecordField s Import)
xs
extractEmbeds RecordField s Import
_ = [Import]
forall a. Monoid a => a
mempty
extractRecordLit :: RecordField s Import -> Maybe (Map Text (RecordField s Import))
extractRecordLit :: forall s.
RecordField s Import -> Maybe (Map Text (RecordField s Import))
extractRecordLit RecordField{recordFieldValue :: forall s a. RecordField s a -> Expr s a
recordFieldValue = RecordLit Map Text (RecordField s Import)
xs} = Map Text (RecordField s Import)
-> Maybe (Map Text (RecordField s Import))
forall a. a -> Maybe a
Just Map Text (RecordField s Import)
xs
extractRecordLit RecordField s Import
_ = Maybe (Map Text (RecordField s Import))
forall a. Maybe a
Nothing
data PackageError
= AmbiguousOutputDirectory FilePath FilePath
| IncompatiblePaths [Import]
| InvalidPath FilePath
instance Exception PackageError
instance Show PackageError where
show :: PackageError -> String
show (AmbiguousOutputDirectory String
dir1 String
dir2) =
String
forall string. IsString string => string
_ERROR String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": ❰dhall package❱ failed because the inputs make it impossible to\n\
\determine the output directory of the package file. You asked to include files\n\
\from the following directories in the package:\n\
\\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
dir1 String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
dir2 String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
String
"\n\n\
\Although those paths might point to the same location they are not lexically the\n\
\same."
show (IncompatiblePaths [Import]
imports) =
String
forall string. IsString string => string
_ERROR String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": ❰dhall package❱ failed because some inputs are not compatible with\n\
\each other:\n\
\\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unlines ((Import -> String) -> [Import] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Doc Ann -> String
forall a. Show a => a -> String
show (Doc Ann -> String) -> (Import -> Doc Ann) -> Import -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr (ZonkAny 0) Import -> Doc Ann
forall a s. Pretty a => Expr s a -> Doc Ann
Dhall.Pretty.prettyExpr (Expr (ZonkAny 0) Import -> Doc Ann)
-> (Import -> Expr (ZonkAny 0) Import) -> Import -> Doc Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Import -> Expr (ZonkAny 0) Import
forall s a. a -> Expr s a
Embed) [Import]
imports)
show (InvalidPath String
fp) =
String
forall string. IsString string => string
_ERROR String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": ❰dhall package❱ failed because the input does not exist or is\n\
\neither a directory nor a regular file:\n\
\\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
fp