Added dhall package command

dhall/dhall.cabal

@@ -332,6 +332,7 @@ Library
         Dhall.Marshal.Encode
         Dhall.Map
         Dhall.Optics
+        Dhall.Package
         Dhall.Parser
         Dhall.Parser.Expression
         Dhall.Parser.Token
@@ -420,6 +421,7 @@ Test-Suite tasty
         Dhall.Test.Import
         Dhall.Test.Lint
         Dhall.Test.Normalization
+        Dhall.Test.Package
         Dhall.Test.Parser
         Dhall.Test.QuickCheck
         Dhall.Test.Regression

dhall/src/Dhall/Main.hs

@@ -36,6 +36,7 @@ import Dhall.Import
     , SemanticCacheMode (..)
     , _semanticCacheMode
     )
+import Dhall.Package       (writePackage)
 import Dhall.Parser        (Src)
 import Dhall.Pretty
     ( Ann
@@ -162,6 +163,7 @@ data Mode
     | DirectoryTree { allowSeparators :: Bool, file :: Input, path :: FilePath }
     | Schemas { file :: Input, outputMode :: OutputMode, schemas :: Text }
     | SyntaxTree { file :: Input, noted :: Bool }
+    | Package { name :: Maybe String, files :: NonEmpty FilePath }
 
 -- | This specifies how to resolve transitive dependencies
 data ResolveMode
@@ -310,6 +312,11 @@ parseMode =
             "hash"
             "Compute semantic hashes for Dhall expressions"
             (Hash <$> parseFile <*> parseCache)
+    <|> subcommand
+            Miscellaneous
+            "package"
+            "Create a package.dhall referencing the provided paths"
+            (Package <$> parsePackageName <*> parsePackageFiles)
     <|> subcommand
             Miscellaneous
             "tags"
@@ -559,6 +566,22 @@ parseMode =
             <>  Options.Applicative.help "Cache the hashed expression"
             )
 
+    parsePackageName = optional $
+        Options.Applicative.strOption
+            (   Options.Applicative.long "name"
+            <>  Options.Applicative.help "The filename of the package"
+            <>  Options.Applicative.metavar "NAME"
+            <>  Options.Applicative.action "file"
+            )
+
+    parsePackageFiles = (:|) <$> p <*> Options.Applicative.many p
+      where
+        p = Options.Applicative.strArgument
+                (   Options.Applicative.help "Paths that may either point to files or directories. If the latter is the case all *.dhall files in the directory will be included."
+                <>  Options.Applicative.metavar "PATH"
+                <>  Options.Applicative.action "file"
+                )
+
 -- | `ParserInfo` for the `Options` type
 parserInfoOptions :: ParserInfo Options
 parserInfoOptions =
@@ -1018,6 +1041,8 @@ command (Options {..}) = do
                     denoted = Dhall.Core.denote expression
                 in Text.Pretty.Simple.pPrintNoColor denoted
 
+        Package {..} -> writePackage (fromMaybe Unicode chosenCharacterSet) name files
+
 -- | Entry point for the @dhall@ executable
 main :: IO ()
 main = do

dhall/src/Dhall/Package.hs

@@ -0,0 +1,131 @@
+{-# LANGUAGE BangPatterns #-}
+{-# 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           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           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 outputFn inputs = do
+    (outputPath, expr) <- getPackagePathAndContent outputFn inputs
+    renderExpression characterSet True (Just outputPath) expr
+
+-- | Get the path and the Dhall expression for a package file.
+--
+-- The inputs provided as the second argument 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.
+--     The package file will be located in that directory.
+--
+--   * If the path points to a regular file, it is included in the package
+--     unless it is the path of the package file itself.
+--     All files passed as input must reside in the same directory.
+--     The package file will be located in the (shared) parent directory of the
+--     files passed as input to this function.
+--
+getPackagePathAndContent :: Maybe String -> NonEmpty FilePath -> IO (FilePath, Expr s Import)
+getPackagePathAndContent outputFn (path :| paths) = do
+    outputDir <- do
+        isDirectory <- doesDirectoryExist path
+        return $ if isDirectory then path else takeDirectory path
+    outputDir' <- makeAbsolute $ normalise outputDir
+
+    let checkOutputDir dir = do
+            dir' <- makeAbsolute $ normalise dir
+            when (dir' /= outputDir') $
+                throwIO $ AmbiguousOutputDirectory outputDir dir
+
+    resultMap <- go Map.empty checkOutputDir (path:paths)
+    return (outputDir </> outputFn', RecordLit resultMap)
+    where
+        go :: Map Text (RecordField s Import) -> (FilePath -> IO ()) -> [FilePath] -> IO (Map Text (RecordField s Import))
+        go !acc _checkOutputDir [] = return acc
+        go !acc checkOutputDir (p:ps) = do
+            isDirectory <- doesDirectoryExist p
+            isFile <- doesFileExist p
+            if | isDirectory -> do
+                    checkOutputDir p
+                    entries <- listDirectory p
+                    let entries' = filter (\entry -> takeExtension entry == ".dhall") entries
+                    go acc checkOutputDir (map (p </>) entries' <> ps)
+               | isFile -> do
+                    checkOutputDir $ takeDirectory p
+
+                    let key = Text.pack $ dropExtension $ takeFileName p
+
+                    let import_ = Import
+                            { importHashed = ImportHashed
+                                { hash = Nothing
+                                , importType = Local Here File
+                                    { directory = Directory []
+                                    , file = Text.pack (takeFileName p)
+                                    }
+                                }
+                            , importMode = Code
+                            }
+
+                    let resultMap = if takeFileName p == outputFn'
+                            then Map.empty
+                            else Map.singleton key (makeRecordField $ Embed import_)
+
+                    go (resultMap <> acc) checkOutputDir ps
+                | otherwise -> throwIO $ InvalidPath p
+
+        outputFn' = fromMaybe "package.dhall" outputFn
+
+-- | Exception thrown when creating a package file.
+data PackageError
+    = AmbiguousOutputDirectory FilePath FilePath
+    | InvalidPath FilePath
+
+instance Exception PackageError
+
+instance Show PackageError where
+    show (AmbiguousOutputDirectory dir1 dir2) =
+        _ERROR <> ": ❰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" <> dir1 <>
+        "\n" <> dir2 <>
+        "\n\n\
+        \Although those paths might point to the same location they are not lexically the\n\
+        \same."
+
+    show (InvalidPath fp) =
+        _ERROR <> ": ❰dhall package❱ failed because the input does not exist or is\n\
+        \neither a directory nor a regular file:\n\
+        \\n" <> fp

dhall/tests/Dhall/Test/Main.hs

@@ -11,6 +11,7 @@ import qualified Dhall.Test.Freeze
 import qualified Dhall.Test.Import
 import qualified Dhall.Test.Lint
 import qualified Dhall.Test.Normalization
+import qualified Dhall.Test.Package
 import qualified Dhall.Test.Parser
 import qualified Dhall.Test.QuickCheck
 import qualified Dhall.Test.Regression
@@ -69,6 +70,7 @@ getAllTests = do
                 , Dhall.Test.QuickCheck.tests
                 , Dhall.Test.Dhall.tests
                 , Dhall.Test.TH.tests
+                , Dhall.Test.Package.tests
                 ]
 
     return testTree

dhall/tests/Dhall/Test/Package.hs

@@ -0,0 +1,146 @@
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Dhall.Test.Package where
+
+import           Control.Exception  (Exception, displayException, try)
+import           Data.List.NonEmpty (NonEmpty (..))
+import           Data.Void          (Void)
+import           Dhall.Core
+    ( Directory (..)
+    , Expr (..)
+    , File (..)
+    , FilePrefix (..)
+    , Import (..)
+    , ImportHashed (..)
+    , ImportMode (..)
+    , ImportType (..)
+    , makeRecordField
+    )
+import qualified Dhall.Map          as Map
+import           Dhall.Package
+import           System.FilePath    ((</>))
+import           Test.Tasty
+import           Test.Tasty.HUnit
+
+tests :: TestTree
+tests = testGroup "Package"
+    [ packagePackageFile
+    , packageCustomPackageFile
+    , packageSingleFile
+    , packageEmptyDirectory
+    , packageSingleDirectory
+    , packageMissingFile
+    , packageFilesDifferentDirs
+    ]
+
+packagePackageFile :: TestTree
+packagePackageFile = testCase "package file" $ do
+    let path = "./tests/package" </> "package.dhall"
+
+    let package :: Expr Void Import
+        package = RecordLit Map.empty
+
+    (output, expr) <- getPackagePathAndContent Nothing ("./tests/package/package.dhall" :| [])
+    assertEqual "path" path output
+    assertEqual "content" package expr
+
+packageCustomPackageFile :: TestTree
+packageCustomPackageFile = testCase "custom package file" $ do
+    let path = "./tests/package" </> "custom.dhall"
+
+    let package :: Expr Void Import
+        package = RecordLit $ Map.singleton "package" $
+            makeRecordField $ Embed Import
+                { importHashed = ImportHashed
+                    { hash = Nothing
+                    , importType = Local Here File
+                        { directory = Directory []
+                        , file = "package.dhall"
+                        }
+                    }
+                , importMode = Code
+                }
+
+    (output, expr) <- getPackagePathAndContent (Just "custom.dhall") ("./tests/package/package.dhall" :| [])
+    assertEqual "path" path output
+    assertEqual "content" package expr
+
+packageSingleFile :: TestTree
+packageSingleFile = testCase "single file" $ do
+    let path = "./tests/package/dir" </> "package.dhall"
+
+    let package :: Expr Void Import
+        package = RecordLit $ Map.singleton "test" $
+            makeRecordField $ Embed Import
+                { importHashed = ImportHashed
+                    { hash = Nothing
+                    , importType = Local Here File
+                        { directory = Directory []
+                        , file = "test.dhall"
+                        }
+                    }
+                , importMode = Code
+                }
+
+    (output, expr) <- getPackagePathAndContent Nothing ("./tests/package/dir/test.dhall" :| [])
+    assertEqual "path" path output
+    assertEqual "content" package expr
+
+packageEmptyDirectory :: TestTree
+packageEmptyDirectory = testCase "empty directory" $ do
+    let path = "./tests/package/empty" </> "package.dhall"
+
+    let package :: Expr Void Import
+        package = RecordLit Map.empty
+
+    (output, expr) <- getPackagePathAndContent Nothing ("./tests/package/empty" :| [])
+    assertEqual "path" path output
+    assertEqual "content" package expr
+
+packageSingleDirectory :: TestTree
+packageSingleDirectory = testCase "single directory" $ do
+    let path = "./tests/package/dir" </> "package.dhall"
+
+    let package :: Expr Void Import
+        package = RecordLit $ Map.singleton "test" $
+            makeRecordField $ Embed Import
+                { importHashed = ImportHashed
+                    { hash = Nothing
+                    , importType = Local Here File
+                        { directory = Directory []
+                        , file = "test.dhall"
+                        }
+                    }
+                , importMode = Code
+                }
+
+    (output, expr) <- getPackagePathAndContent Nothing ("./tests/package/dir" :| [])
+    assertEqual "path" path output
+    assertEqual "content" package expr
+
+packageMissingFile :: TestTree
+packageMissingFile = testCase "missing file" $ do
+    let action :: IO (FilePath, Expr Void Import)
+        action = getPackagePathAndContent Nothing ("./tests/package/missing.dhall" :| [])
+
+    assertThrow action $ \case
+        InvalidPath "./tests/package/missing.dhall" -> True
+        _ -> False
+
+packageFilesDifferentDirs :: TestTree
+packageFilesDifferentDirs = testCase "files from different directories" $ do
+    let action :: IO (FilePath, Expr Void Import)
+        action = getPackagePathAndContent Nothing ("./tests/package/test.dhall" :| ["./tests/package/dir/test.dhall"])
+
+    assertThrow action $ \case
+        AmbiguousOutputDirectory "./tests/package" "./tests/package/dir" -> True
+        _ -> False
+
+assertThrow :: (Exception e, Show a) => IO a -> (e -> Bool) -> IO ()
+assertThrow k p = do
+    result <- try k
+    case result of
+        Left e | p e -> return ()
+        Left e -> assertFailure $ "Predicate did not match: " <> displayException e
+        Right result' -> assertFailure $ "Expected exception, but got: " <> show result'