{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase   #-}
{-# LANGUAGE MultiWayIf   #-}

-- | Create a package.dhall from files and directory contents.

module Dhall.Package
    ( writePackage
    , getPackagePathAndContent
    , PackageError(..)
    ) where

import           Control.Exception  (Exception, throwIO)
import           Control.Monad
import           Data.List.NonEmpty (NonEmpty (..))
import           Data.Maybe         (fromMaybe)
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           System.Directory
import           System.FilePath

-- | Create a package.dhall from files and directory contents.
-- For a description of how the package file is constructed see
-- 'getPackagePathAndContent'.
writePackage :: CharacterSet -> Maybe String -> NonEmpty FilePath -> IO ()
writePackage :: CharacterSet -> Maybe String -> NonEmpty String -> IO ()
writePackage CharacterSet
characterSet Maybe String
outputFn NonEmpty String
inputs = do
    (String
outputPath, Expr Src Import
expr) <- forall s.
Maybe String -> NonEmpty String -> IO (String, Expr s Import)
getPackagePathAndContent Maybe String
outputFn NonEmpty String
inputs
    forall a.
Pretty a =>
CharacterSet -> Bool -> Maybe String -> Expr Src a -> IO ()
renderExpression CharacterSet
characterSet Bool
True (forall a. a -> Maybe a
Just String
outputPath) Expr Src Import
expr

-- | Get the path and the Dhall expression for a package file.
--
-- The location of the resulting package file is determined by the first path of the second argument:
--
--   * If it is a directory, it is also the output directory and the package
--     file will be placed there.
--
--   * If it is a file, then the directory that file resides in is the output
--     directory and the package file will be placed there.
--
-- All inputs provided as the second argument must be either in the output
-- directory or below it. They are processed depending on whether
-- the path points to a directory or a file:
--
--   * If the path points to a directory, all files with a @.dhall@ extensions
--     in that directory are included in the package.
--
--   * If the path points to a regular file, it is included in the package
--     unless it is the path of the package file itself.
--
getPackagePathAndContent :: Maybe String -> NonEmpty FilePath -> IO (FilePath, Expr s Import)
getPackagePathAndContent :: forall s.
Maybe String -> NonEmpty String -> IO (String, Expr s Import)
getPackagePathAndContent Maybe String
outputFn (String
path :| [String]
paths) = do
    String
outputDir <- do
        Bool
isDirectory <- String -> IO Bool
doesDirectoryExist String
path
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
isDirectory then String
path else String -> String
takeDirectory String
path
    String
outputDir' <- String -> String
addTrailingPathSeparator forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
makeAbsolute (String -> String
normalise String
outputDir)

    -- Check if the supplied @dir@ argument points to a filesystem entry below
    -- the output directory and return the path relative to the output directory.
    let checkOutputDir :: String -> IO String
checkOutputDir String
dir = do
            String
absoluteDir <- String -> String
addTrailingPathSeparator forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
makeAbsolute (String -> String
normalise String
dir)
            let relativeDir :: String
relativeDir = String -> String -> String
makeRelative String
outputDir' String
absoluteDir
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
isRelative String
relativeDir) forall a b. (a -> b) -> a -> b
$
                forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> String -> PackageError
AmbiguousOutputDirectory String
outputDir String
dir
            forall (m :: * -> *) a. Monad m => a -> m a
return String
relativeDir

    Map Text (RecordField s Import)
resultMap <- forall s.
Map Text (RecordField s Import)
-> (String -> IO String)
-> [String]
-> IO (Map Text (RecordField s Import))
go forall k v. Ord k => Map k v
Map.empty String -> IO String
checkOutputDir (String
pathforall a. a -> [a] -> [a]
:[String]
paths)
    forall (m :: * -> *) a. Monad m => a -> m a
return (String
outputDir String -> String -> String
</> String
outputFn', forall s a. Map Text (RecordField s a) -> Expr s a
RecordLit forall a b. (a -> b) -> a -> b
$ forall k v. Map k v -> Map k v
Map.sort Map Text (RecordField s Import)
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 [] = 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
            Bool
isDirectory <- String -> IO Bool
doesDirectoryExist String
p
            Bool
isFile <- String -> IO Bool
doesFileExist String
p
            if | Bool
isDirectory -> do
                    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ String -> IO String
checkOutputDir String
p
                    [String]
entries <- String -> IO [String]
listDirectory String
p
                    let entries' :: [String]
entries' = forall a. (a -> Bool) -> [a] -> [a]
filter (\String
entry -> String -> String
takeExtension String
entry forall a. Eq a => a -> a -> Bool
== String
".dhall") [String]
entries
                    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 (forall a b. (a -> b) -> [a] -> [b]
map (String
p String -> String -> String
</>) [String]
entries' forall a. Semigroup a => a -> a -> a
<> [String]
ps)
               | Bool
isFile -> do
                    String
dir <- String -> IO String
checkOutputDir forall a b. (a -> b) -> a -> b
$ String -> String
takeDirectory String
p

                    let p' :: String
p' = String -> String
normalise forall a b. (a -> b) -> a -> b
$ String
dir String -> String -> String
</> String -> String
takeFileName String
p

                    let resultMap :: Map Text (RecordField s Import)
resultMap = if String
p' forall a. Eq a => a -> a -> Bool
== String
outputFn'
                            then forall k v. Ord k => Map k v
Map.empty
                            else forall s. String -> String -> Map Text (RecordField s Import)
filepathToMap String
outputFn' String
p'

                    Map Text (RecordField s Import)
acc' <- forall s.
Map Text (RecordField s Import)
-> Map Text (RecordField s Import)
-> IO (Map Text (RecordField s Import))
mergeMaps Map Text (RecordField s Import)
acc forall {s}. Map Text (RecordField s Import)
resultMap
                    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 [String]
ps
                | Bool
otherwise -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> PackageError
InvalidPath String
p

        outputFn' :: String
outputFn' = forall a. a -> Maybe a -> a
fromMaybe String
"package.dhall" Maybe String
outputFn

-- | Construct a nested 'Map' from a 'FilePath'.
-- For example, the filepath @some/file/path.dhall@ will result in something
-- similar to the following:
--
-- fromList
--   [ ("some", fromList
--     [ ("file", fromList
--       [ ("path", ./some/file/path.dhall)
--       ])
--     ])
--   ])
--
-- ... where ./some/file/path.dhall is a Dhall import. If the last component
-- equals the value passed in the @outputFn@ argument we produce a slightly
-- different result. Consider for example the Dhall Prelude: We have some
-- sub-packages there like @List/package.dhall@. If we want to construct the
-- top-level @package.dhall@ we want an entry like
--
-- > List = ./List/package.dhall
--
-- in there and not:
--
-- > List = { package = ./List/package.dhall }
--
filepathToMap :: FilePath -> FilePath -> Map Text (RecordField s Import)
filepathToMap :: forall s. String -> String -> Map Text (RecordField s Import)
filepathToMap String
outputFn = forall {s}. [Text] -> [String] -> Map Text (RecordField s Import)
go [] 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 = 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 forall k v. k -> v -> Map k v
Map.singleton (String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ String -> String
dropExtension String
x) forall a b. (a -> b) -> a -> b
$ forall s a. Expr s a -> RecordField s a
makeRecordField forall a b. (a -> b) -> a -> b
$ forall s a. a -> Expr s a
Embed Import
import_
        go ![Text]
acc [String
x, String
y] | String
y forall a. Eq a => a -> a -> Bool
== String
outputFn =
                    let import_ :: Import
import_ = Import
                            { importHashed :: ImportHashed
importHashed = ImportHashed
                                { hash :: Maybe SHA256Digest
hash = 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 forall a. a -> [a] -> [a]
: [Text]
acc)
                                    , file :: Text
file = String -> Text
Text.pack String
y
                                    }
                                }
                            , importMode :: ImportMode
importMode = ImportMode
Code
                            }
            in forall k v. k -> v -> Map k v
Map.singleton (String -> Text
Text.pack String
x) forall a b. (a -> b) -> a -> b
$ forall s a. Expr s a -> RecordField s a
makeRecordField forall a b. (a -> b) -> a -> b
$ forall s a. a -> Expr s a
Embed Import
import_
        go ![Text]
acc (String
x:[String]
xs) = forall k v. k -> v -> Map k v
Map.singleton (String -> Text
Text.pack String
x) forall a b. (a -> b) -> a -> b
$ forall s a. Expr s a -> RecordField s a
makeRecordField forall a b. (a -> b) -> a -> b
$ forall s a. Map Text (RecordField s a) -> Expr s a
RecordLit forall a b. (a -> b) -> a -> b
$ [Text] -> [String] -> Map Text (RecordField s Import)
go (String -> Text
Text.pack String
x forall a. a -> [a] -> [a]
: [Text]
acc) [String]
xs

-- | Merge two 'Map's constructed with 'filepathToMap'.
-- It will throw an error if the arguments are not compatible with each other, e.g.
-- we cannot merge the following two maps:
--
-- > fromList [ ("file", ./file.dhall) ]
-- > fromList [ ("file", fromList [("nested", ./file/nested.dhall)]) ]
--
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' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> [a] -> NonEmpty a
:| []) Map Text (RecordField s Import)
x
        y' :: Map Text (NonEmpty (RecordField s Import))
y' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> [a] -> NonEmpty a
:| []) Map Text (RecordField s Import)
y
        z :: Map Text (NonEmpty (RecordField s Import))
z = forall k v. Ord k => (v -> v -> v) -> Map k v -> Map k v -> Map k v
Map.unionWith forall a. Semigroup a => a -> a -> a
(<>) Map Text (NonEmpty (RecordField s Import))
x' Map Text (NonEmpty (RecordField s Import))
y'
    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 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{}} :| [] -> 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 <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall s.
RecordField s Import -> Maybe (Map Text (RecordField s Import))
extractRecordLit NonEmpty (RecordField s Import)
vs -> forall s a. Expr s a -> RecordField s a
makeRecordField forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. Map Text (RecordField s a) -> Expr s a
RecordLit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. Map k v -> Map k v
Map.sort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall s.
Map Text (RecordField s Import)
-> Map Text (RecordField s Import)
-> IO (Map Text (RecordField s Import))
mergeMaps forall k v. Ord k => Map k v
Map.empty NonEmpty (Map Text (RecordField s Import))
rs
           | Bool
otherwise -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ [Import] -> PackageError
IncompatiblePaths forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap 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} = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall s. RecordField s Import -> [Import]
extractEmbeds Map Text (RecordField s Import)
xs
        extractEmbeds RecordField s 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} = forall a. a -> Maybe a
Just Map Text (RecordField s Import)
xs
        extractRecordLit RecordField s Import
_ = forall a. Maybe a
Nothing

-- | Exception thrown when creating a package file.
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) =
        forall string. IsString string => string
_ERROR 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" forall a. Semigroup a => a -> a -> a
<> String
dir1 forall a. Semigroup a => a -> a -> a
<>
        String
"\n" forall a. Semigroup a => a -> a -> a
<> String
dir2 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) =
        forall string. IsString string => string
_ERROR forall a. Semigroup a => a -> a -> a
<> String
": ❰dhall package❱ failed because some inputs are not compatible with\n\
        \each other:\n\
        \\n" forall a. Semigroup a => a -> a -> a
<> [String] -> String
unlines (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. Pretty a => Expr s a -> Doc Ann
Dhall.Pretty.prettyExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. a -> Expr s a
Embed) [Import]
imports)

    show (InvalidPath String
fp) =
        forall string. IsString string => string
_ERROR 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" forall a. Semigroup a => a -> a -> a
<> String
fp