dhall package command: Added support for automatic sub-packages

dhall/src/Dhall/Main.hs

@@ -27,6 +27,7 @@ import Control.Monad       (when)
 import Data.Foldable       (for_)
 import Data.List.NonEmpty  (NonEmpty (..), nonEmpty)
 import Data.Maybe          (fromMaybe)
+import Data.Monoid         (Endo (..))
 import Data.Text           (Text)
 import Data.Void           (Void)
 import Dhall.Freeze        (Intent (..), Scope (..))
@@ -36,7 +37,7 @@ import Dhall.Import
     , SemanticCacheMode (..)
     , _semanticCacheMode
     )
-import Dhall.Package       (writePackage)
+import Dhall.Package       (PackagingMode(..), writePackage)
 import Dhall.Parser        (Src)
 import Dhall.Pretty
     ( Ann
@@ -47,6 +48,7 @@ import Dhall.Pretty
 import Dhall.Schemas       (Schemas (..))
 import Dhall.TypeCheck     (Censored (..), DetailedTypeError (..), TypeError)
 import Dhall.Version       (dhallVersionString)
+import Lens.Family         (set)
 import Options.Applicative (Parser, ParserInfo)
 import Prettyprinter       (Doc, Pretty)
 import System.Exit         (ExitCode, exitFailure)
@@ -95,6 +97,7 @@ import qualified Dhall.Import
 import qualified Dhall.Import.Types
 import qualified Dhall.Lint
 import qualified Dhall.Map
+import qualified Dhall.Package
 import qualified Dhall.Pretty
 import qualified Dhall.Repl
 import qualified Dhall.Schemas
@@ -163,7 +166,10 @@ 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 }
+    | Package
+        { packageOptions :: Endo Dhall.Package.Options
+        , packageFiles :: NonEmpty FilePath
+        }
 
 -- | This specifies how to resolve transitive dependencies
 data ResolveMode
@@ -316,7 +322,7 @@ parseMode =
             Miscellaneous
             "package"
             "Create a package.dhall referencing the provided paths"
-            (Package <$> parsePackageName <*> parsePackageFiles)
+            (Package <$> parsePackageOptions <*> parsePackageFiles)
     <|> subcommand
             Miscellaneous
             "tags"
@@ -566,14 +572,25 @@ 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"
+    parsePackageOptions :: Parser (Endo Dhall.Package.Options)
+    parsePackageOptions = do
+        packageMode <- (optional . Options.Applicative.flag' RecursiveSubpackages)
+            ( Options.Applicative.short 'r'
+            <> Options.Applicative.long "recursive"
+            <> Options.Applicative.help "Create packages for all subdirectories first."
             )
 
+        packageFileName <- (optional . Options.Applicative.strOption)
+                (   Options.Applicative.long "name"
+                <>  Options.Applicative.help "The filename of the package"
+                <>  Options.Applicative.metavar "NAME"
+                <>  Options.Applicative.action "file"
+                )
+
+        pure $
+            maybe mempty (Endo . set Dhall.Package.packagingMode) packageMode <>
+            maybe mempty (Endo . set Dhall.Package.packageFileName) packageFileName
+
     parsePackageFiles = (:|) <$> p <*> Options.Applicative.many p
       where
         p = Options.Applicative.strArgument
@@ -1041,7 +1058,12 @@ command (Options {..}) = do
                     denoted = Dhall.Core.denote expression
                 in Text.Pretty.Simple.pPrintNoColor denoted
 
-        Package {..} -> writePackage (fromMaybe Unicode chosenCharacterSet) name files
+        Package {..} -> do
+            let options = appEndo
+                    (maybe mempty (Endo . set Dhall.Package.characterSet) chosenCharacterSet
+                    <> packageOptions
+                    ) Dhall.Package.defaultOptions
+            writePackage options packageFiles
 
 -- | Entry point for the @dhall@ executable
 main :: IO ()

dhall/src/Dhall/Package.hs

@@ -5,15 +5,20 @@
 -- | Create a package.dhall from files and directory contents.
 
 module Dhall.Package
-    ( writePackage
+    ( 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.Maybe         (fromMaybe)
 import           Data.Text          (Text)
 import qualified Data.Text          as Text
 import           Data.Traversable   (for)
@@ -34,16 +39,60 @@ import qualified Dhall.Map          as Map
 import           Dhall.Pretty       (CharacterSet (..))
 import qualified Dhall.Pretty
 import           Dhall.Util         (_ERROR, renderExpression)
+import           Lens.Family        (LensLike')
 import           System.Directory
 import           System.FilePath
 
+-- | Options for package creation.
+data Options = Options
+    { optionsCharacterSet :: CharacterSet
+    , optionsPackageFileName :: String
+    , optionsPackagingMode :: PackagingMode
+    }
+
+-- | The default options used for packaging.
+--
+-- The default values for the different settings are:
+--
+--  * The character set used is the one given by 'Dhall.Pretty.defaultCharacterSet'.
+--  * The package file name is @package.dhall@.
+--  * The packaging mode is 'OnlyThisPackage'.
+defaultOptions :: Options
+defaultOptions = Options
+    { optionsCharacterSet = Dhall.Pretty.defaultCharacterSet
+    , optionsPackageFileName = "package.dhall"
+    , optionsPackagingMode = OnlyThisPackage
+    }
+
+-- | Access the character set used to render the package content.
+characterSet :: Functor f => LensLike' f Options CharacterSet
+characterSet k s =
+    fmap (\x -> s { optionsCharacterSet = x }) (k (optionsCharacterSet s))
+
+-- | Access the file name used for the package file.
+packageFileName :: Functor f => LensLike' f Options String
+packageFileName k s =
+    fmap (\x -> s { optionsPackageFileName = x }) (k (optionsPackageFileName s))
+
+-- | Access the packaging mode.
+-- See the documentation of 'getPackagePathAndContent'.
+packagingMode :: Functor f => LensLike' f Options PackagingMode
+packagingMode k s =
+    fmap (\x -> s { optionsPackagingMode = x }) (k (optionsPackagingMode s))
+
+-- | Whether to recursively create a package for each subdirectory or not.
+-- See the documentation of 'getPackagePathAndContent'.
+data PackagingMode
+    = OnlyThisPackage
+    | RecursiveSubpackages
+
 -- | 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
+writePackage :: Options -> NonEmpty FilePath -> IO ()
+writePackage options inputs = do
+    (outputPath, expr) <- getPackagePathAndContent options inputs
+    renderExpression (optionsCharacterSet options) True (Just outputPath) expr
 
 -- | Get the path and the Dhall expression for a package file.
 --
@@ -62,11 +111,18 @@ writePackage characterSet outputFn inputs = do
 --   * If the path points to a directory, all files with a @.dhall@ extensions
 --     in that directory are included in the package.
 --
+--     If you passed `Recurse` to the this function, then in addition to these
+--     files all subdirectories are traversed and a sub-package created for each
+--     one. That sub-package will be included in the package too.
+--
 --   * 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 outputFn (path :| paths) = do
+getPackagePathAndContent
+    :: Options
+    -> NonEmpty FilePath
+    -> IO (FilePath, Expr s Import)
+getPackagePathAndContent options (path :| paths) = do
     outputDir <- do
         isDirectory <- doesDirectoryExist path
         return $ if isDirectory then path else takeDirectory path
@@ -82,32 +138,55 @@ getPackagePathAndContent outputFn (path :| paths) = do
             return relativeDir
 
     resultMap <- go Map.empty checkOutputDir (path:paths)
-    return (outputDir </> outputFn', RecordLit $ Map.sort resultMap)
+    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
+            :: Map Text (RecordField s Import)
+            -> (FilePath -> IO FilePath)
+            -> [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
                     void $ checkOutputDir p
                     entries <- listDirectory p
-                    let entries' = filter (\entry -> takeExtension entry == ".dhall") entries
-                    go acc checkOutputDir (map (p </>) entries' <> ps)
+                    (dhallFiles, subdirectories) <- foldMap
+                        ( \entry -> do
+                            let entry' = p </> entry
+                            isDirectoryEntry <- doesDirectoryExist entry'
+                            return $ if isDirectoryEntry
+                                then (mempty, [entry'])
+                                else if hasDhallExtension entry
+                                    then ([entry'], mempty)
+                                    else mempty
+                        ) entries
+                    subpackages <- case optionsPackagingMode options of
+                        RecursiveSubpackages ->
+                            for subdirectories $ \subdirectory -> do
+                                writePackage options (subdirectory :| [])
+                                return (subdirectory </> outputFn)
+                        OnlyThisPackage -> return []
+                    go acc checkOutputDir (dhallFiles <> subpackages <> ps)
                | isFile -> do
                     dir <- checkOutputDir $ takeDirectory p
 
                     let p' = normalise $ dir </> takeFileName p
 
-                    let resultMap = if p' == outputFn'
+                    let resultMap = if p' == outputFn
                             then Map.empty
-                            else filepathToMap outputFn' p'
+                            else filepathToMap outputFn p'
 
                     acc' <- mergeMaps acc resultMap
                     go acc' checkOutputDir ps
                 | otherwise -> throwIO $ InvalidPath p
 
-        outputFn' = fromMaybe "package.dhall" outputFn
+        hasDhallExtension :: FilePath -> Bool
+        hasDhallExtension entry = takeExtension entry == ".dhall"
+
+        outputFn :: String
+        outputFn = optionsPackageFileName options
 
 -- | Construct a nested 'Map' from a 'FilePath'.
 -- For example, the filepath @some/file/path.dhall@ will result in something

dhall/src/Dhall/Pretty.hs

@@ -8,6 +8,7 @@ module Dhall.Pretty
     , prettyExpr
 
     , CharacterSet(..)
+    , defaultCharacterSet
     , detectCharacterSet
     , prettyCharacterSet
 

dhall/src/Dhall/Pretty/Internal.hs

@@ -20,6 +20,7 @@ module Dhall.Pretty.Internal (
     , prettySrcExpr
 
     , CharacterSet(..)
+    , defaultCharacterSet
     , detectCharacterSet
     , prettyCharacterSet
     , prettyImportExpression
@@ -155,6 +156,11 @@ instance FromJSON CharacterSet where
   parseJSON v@(String _) = unexpected v
   parseJSON v = typeMismatch "String" v
 
+-- | The character set used by default in functions throughout the Dhall code
+-- base.
+defaultCharacterSet :: CharacterSet
+defaultCharacterSet = Unicode
+
 -- | Detect which character set is used for the syntax of an expression
 -- If any parts of the expression uses the Unicode syntax, the whole expression
 -- is deemed to be using the Unicode syntax.
@@ -176,7 +182,7 @@ prettyExpr :: Pretty a => Expr s a -> Doc Ann
 prettyExpr = prettySrcExpr . denote
 
 prettySrcExpr :: Pretty a => Expr Src a -> Doc Ann
-prettySrcExpr = prettyCharacterSet Unicode
+prettySrcExpr = prettyCharacterSet defaultCharacterSet
 
 {-| Internal utility for pretty-printing, used when generating element lists
     to supply to `enclose` or `enclose'`.  This utility indicates that the