Skip to content

Commit a5ca632

Browse files
mmhatmmhat
authored
dhall package command: Added support for automatic sub-packages (#2639)
* dhall package command: Added support for automatic sub-packages When you pass the `--recurse` flag to the `dhall package` command, then for each directory passed as an argument a sub-package is created in each subdirectory, and that sub-package is included in the (main) package in addition to the *.dhall files of that directory. * Silence unused-import in Dhall.Test.Util * Added simple test for recursive subpackage creation * Added dedicated Options type for packaging
1 parent f48fda9 commit a5ca632

File tree

8 files changed

+202
-36
lines changed

8 files changed

+202
-36
lines changed

‎dhall/src/Dhall/Main.hs

+32-10
Original file line numberDiff line numberDiff line change
@@ -27,6 +27,7 @@ import Control.Monad (when)
2727
import Data.Foldable (for_)
2828
import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
2929
import Data.Maybe (fromMaybe)
30+
import Data.Monoid (Endo (..))
3031
import Data.Text (Text)
3132
import Data.Void (Void)
3233
import Dhall.Freeze (Intent (..), Scope (..))
@@ -36,7 +37,7 @@ import Dhall.Import
3637
, SemanticCacheMode (..)
3738
, _semanticCacheMode
3839
)
39-
import Dhall.Package (writePackage)
40+
import Dhall.Package (PackagingMode(..), writePackage)
4041
import Dhall.Parser (Src)
4142
import Dhall.Pretty
4243
( Ann
@@ -47,6 +48,7 @@ import Dhall.Pretty
4748
import Dhall.Schemas (Schemas (..))
4849
import Dhall.TypeCheck (Censored (..), DetailedTypeError (..), TypeError)
4950
import Dhall.Version (dhallVersionString)
51+
import Lens.Family (set)
5052
import Options.Applicative (Parser, ParserInfo)
5153
import Prettyprinter (Doc, Pretty)
5254
import System.Exit (ExitCode, exitFailure)
@@ -95,6 +97,7 @@ import qualified Dhall.Import
9597
import qualified Dhall.Import.Types
9698
import qualified Dhall.Lint
9799
import qualified Dhall.Map
100+
import qualified Dhall.Package
98101
import qualified Dhall.Pretty
99102
import qualified Dhall.Repl
100103
import qualified Dhall.Schemas
@@ -163,7 +166,10 @@ data Mode
163166
| DirectoryTree { allowSeparators :: Bool, file :: Input, path :: FilePath }
164167
| Schemas { file :: Input, outputMode :: OutputMode, schemas :: Text }
165168
| SyntaxTree { file :: Input, noted :: Bool }
166-
| Package { name :: Maybe String, files :: NonEmpty FilePath }
169+
| Package
170+
{ packageOptions :: Endo Dhall.Package.Options
171+
, packageFiles :: NonEmpty FilePath
172+
}
167173

168174
-- | This specifies how to resolve transitive dependencies
169175
data ResolveMode
@@ -316,7 +322,7 @@ parseMode =
316322
Miscellaneous
317323
"package"
318324
"Create a package.dhall referencing the provided paths"
319-
(Package <$> parsePackageName <*> parsePackageFiles)
325+
(Package <$> parsePackageOptions <*> parsePackageFiles)
320326
<|> subcommand
321327
Miscellaneous
322328
"tags"
@@ -566,14 +572,25 @@ parseMode =
566572
<> Options.Applicative.help "Cache the hashed expression"
567573
)
568574

569-
parsePackageName = optional $
570-
Options.Applicative.strOption
571-
( Options.Applicative.long "name"
572-
<> Options.Applicative.help "The filename of the package"
573-
<> Options.Applicative.metavar "NAME"
574-
<> Options.Applicative.action "file"
575+
parsePackageOptions :: Parser (Endo Dhall.Package.Options)
576+
parsePackageOptions = do
577+
packageMode <- (optional . Options.Applicative.flag' RecursiveSubpackages)
578+
( Options.Applicative.short 'r'
579+
<> Options.Applicative.long "recursive"
580+
<> Options.Applicative.help "Create packages for all subdirectories first."
575581
)
576582

583+
packageFileName <- (optional . Options.Applicative.strOption)
584+
( Options.Applicative.long "name"
585+
<> Options.Applicative.help "The filename of the package"
586+
<> Options.Applicative.metavar "NAME"
587+
<> Options.Applicative.action "file"
588+
)
589+
590+
pure $
591+
maybe mempty (Endo . set Dhall.Package.packagingMode) packageMode <>
592+
maybe mempty (Endo . set Dhall.Package.packageFileName) packageFileName
593+
577594
parsePackageFiles = (:|) <$> p <*> Options.Applicative.many p
578595
where
579596
p = Options.Applicative.strArgument
@@ -1041,7 +1058,12 @@ command (Options {..}) = do
10411058
denoted = Dhall.Core.denote expression
10421059
in Text.Pretty.Simple.pPrintNoColor denoted
10431060

1044-
Package {..} -> writePackage (fromMaybe Unicode chosenCharacterSet) name files
1061+
Package {..} -> do
1062+
let options = appEndo
1063+
(maybe mempty (Endo . set Dhall.Package.characterSet) chosenCharacterSet
1064+
<> packageOptions
1065+
) Dhall.Package.defaultOptions
1066+
writePackage options packageFiles
10451067

10461068
-- | Entry point for the @dhall@ executable
10471069
main :: IO ()

‎dhall/src/Dhall/Package.hs

+94-15
Original file line numberDiff line numberDiff line change
@@ -5,15 +5,20 @@
55
-- | Create a package.dhall from files and directory contents.
66

77
module Dhall.Package
8-
( writePackage
8+
( Options
9+
, defaultOptions
10+
, characterSet
11+
, packageFileName
12+
, packagingMode
13+
, PackagingMode(..)
14+
, writePackage
915
, getPackagePathAndContent
1016
, PackageError(..)
1117
) where
1218

1319
import Control.Exception (Exception, throwIO)
1420
import Control.Monad
1521
import Data.List.NonEmpty (NonEmpty (..))
16-
import Data.Maybe (fromMaybe)
1722
import Data.Text (Text)
1823
import qualified Data.Text as Text
1924
import Data.Traversable (for)
@@ -34,16 +39,60 @@ import qualified Dhall.Map as Map
3439
import Dhall.Pretty (CharacterSet (..))
3540
import qualified Dhall.Pretty
3641
import Dhall.Util (_ERROR, renderExpression)
42+
import Lens.Family (LensLike')
3743
import System.Directory
3844
import System.FilePath
3945

46+
-- | Options for package creation.
47+
data Options = Options
48+
{ optionsCharacterSet :: CharacterSet
49+
, optionsPackageFileName :: String
50+
, optionsPackagingMode :: PackagingMode
51+
}
52+
53+
-- | The default options used for packaging.
54+
--
55+
-- The default values for the different settings are:
56+
--
57+
-- * The character set used is the one given by 'Dhall.Pretty.defaultCharacterSet'.
58+
-- * The package file name is @package.dhall@.
59+
-- * The packaging mode is 'OnlyThisPackage'.
60+
defaultOptions :: Options
61+
defaultOptions = Options
62+
{ optionsCharacterSet = Dhall.Pretty.defaultCharacterSet
63+
, optionsPackageFileName = "package.dhall"
64+
, optionsPackagingMode = OnlyThisPackage
65+
}
66+
67+
-- | Access the character set used to render the package content.
68+
characterSet :: Functor f => LensLike' f Options CharacterSet
69+
characterSet k s =
70+
fmap (\x -> s { optionsCharacterSet = x }) (k (optionsCharacterSet s))
71+
72+
-- | Access the file name used for the package file.
73+
packageFileName :: Functor f => LensLike' f Options String
74+
packageFileName k s =
75+
fmap (\x -> s { optionsPackageFileName = x }) (k (optionsPackageFileName s))
76+
77+
-- | Access the packaging mode.
78+
-- See the documentation of 'getPackagePathAndContent'.
79+
packagingMode :: Functor f => LensLike' f Options PackagingMode
80+
packagingMode k s =
81+
fmap (\x -> s { optionsPackagingMode = x }) (k (optionsPackagingMode s))
82+
83+
-- | Whether to recursively create a package for each subdirectory or not.
84+
-- See the documentation of 'getPackagePathAndContent'.
85+
data PackagingMode
86+
= OnlyThisPackage
87+
| RecursiveSubpackages
88+
4089
-- | Create a package.dhall from files and directory contents.
4190
-- For a description of how the package file is constructed see
4291
-- 'getPackagePathAndContent'.
43-
writePackage :: CharacterSet -> Maybe String -> NonEmpty FilePath -> IO ()
44-
writePackage characterSet outputFn inputs = do
45-
(outputPath, expr) <- getPackagePathAndContent outputFn inputs
46-
renderExpression characterSet True (Just outputPath) expr
92+
writePackage :: Options -> NonEmpty FilePath -> IO ()
93+
writePackage options inputs = do
94+
(outputPath, expr) <- getPackagePathAndContent options inputs
95+
renderExpression (optionsCharacterSet options) True (Just outputPath) expr
4796

4897
-- | Get the path and the Dhall expression for a package file.
4998
--
@@ -62,11 +111,18 @@ writePackage characterSet outputFn inputs = do
62111
-- * If the path points to a directory, all files with a @.dhall@ extensions
63112
-- in that directory are included in the package.
64113
--
114+
-- If you passed `Recurse` to the this function, then in addition to these
115+
-- files all subdirectories are traversed and a sub-package created for each
116+
-- one. That sub-package will be included in the package too.
117+
--
65118
-- * If the path points to a regular file, it is included in the package
66119
-- unless it is the path of the package file itself.
67120
--
68-
getPackagePathAndContent :: Maybe String -> NonEmpty FilePath -> IO (FilePath, Expr s Import)
69-
getPackagePathAndContent outputFn (path :| paths) = do
121+
getPackagePathAndContent
122+
:: Options
123+
-> NonEmpty FilePath
124+
-> IO (FilePath, Expr s Import)
125+
getPackagePathAndContent options (path :| paths) = do
70126
outputDir <- do
71127
isDirectory <- doesDirectoryExist path
72128
return $ if isDirectory then path else takeDirectory path
@@ -82,32 +138,55 @@ getPackagePathAndContent outputFn (path :| paths) = do
82138
return relativeDir
83139

84140
resultMap <- go Map.empty checkOutputDir (path:paths)
85-
return (outputDir </> outputFn', RecordLit $ Map.sort resultMap)
141+
return (outputDir </> outputFn, RecordLit $ Map.sort resultMap)
86142
where
87-
go :: Map Text (RecordField s Import) -> (FilePath -> IO FilePath) -> [FilePath] -> IO (Map Text (RecordField s Import))
143+
go
144+
:: Map Text (RecordField s Import)
145+
-> (FilePath -> IO FilePath)
146+
-> [FilePath]
147+
-> IO (Map Text (RecordField s Import))
88148
go !acc _checkOutputDir [] = return acc
89149
go !acc checkOutputDir (p:ps) = do
90150
isDirectory <- doesDirectoryExist p
91151
isFile <- doesFileExist p
92152
if | isDirectory -> do
93153
void $ checkOutputDir p
94154
entries <- listDirectory p
95-
let entries' = filter (\entry -> takeExtension entry == ".dhall") entries
96-
go acc checkOutputDir (map (p </>) entries' <> ps)
155+
(dhallFiles, subdirectories) <- foldMap
156+
( \entry -> do
157+
let entry' = p </> entry
158+
isDirectoryEntry <- doesDirectoryExist entry'
159+
return $ if isDirectoryEntry
160+
then (mempty, [entry'])
161+
else if hasDhallExtension entry
162+
then ([entry'], mempty)
163+
else mempty
164+
) entries
165+
subpackages <- case optionsPackagingMode options of
166+
RecursiveSubpackages ->
167+
for subdirectories $ \subdirectory -> do
168+
writePackage options (subdirectory :| [])
169+
return (subdirectory </> outputFn)
170+
OnlyThisPackage -> return []
171+
go acc checkOutputDir (dhallFiles <> subpackages <> ps)
97172
| isFile -> do
98173
dir <- checkOutputDir $ takeDirectory p
99174

100175
let p' = normalise $ dir </> takeFileName p
101176

102-
let resultMap = if p' == outputFn'
177+
let resultMap = if p' == outputFn
103178
then Map.empty
104-
else filepathToMap outputFn' p'
179+
else filepathToMap outputFn p'
105180

106181
acc' <- mergeMaps acc resultMap
107182
go acc' checkOutputDir ps
108183
| otherwise -> throwIO $ InvalidPath p
109184

110-
outputFn' = fromMaybe "package.dhall" outputFn
185+
hasDhallExtension :: FilePath -> Bool
186+
hasDhallExtension entry = takeExtension entry == ".dhall"
187+
188+
outputFn :: String
189+
outputFn = optionsPackageFileName options
111190

112191
-- | Construct a nested 'Map' from a 'FilePath'.
113192
-- For example, the filepath @some/file/path.dhall@ will result in something

‎dhall/src/Dhall/Pretty.hs

+1
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,7 @@ module Dhall.Pretty
88
, prettyExpr
99

1010
, CharacterSet(..)
11+
, defaultCharacterSet
1112
, detectCharacterSet
1213
, prettyCharacterSet
1314

‎dhall/src/Dhall/Pretty/Internal.hs

+7-1
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,7 @@ module Dhall.Pretty.Internal (
2020
, prettySrcExpr
2121

2222
, CharacterSet(..)
23+
, defaultCharacterSet
2324
, detectCharacterSet
2425
, prettyCharacterSet
2526
, prettyImportExpression
@@ -155,6 +156,11 @@ instance FromJSON CharacterSet where
155156
parseJSON v@(String _) = unexpected v
156157
parseJSON v = typeMismatch "String" v
157158

159+
-- | The character set used by default in functions throughout the Dhall code
160+
-- base.
161+
defaultCharacterSet :: CharacterSet
162+
defaultCharacterSet = Unicode
163+
158164
-- | Detect which character set is used for the syntax of an expression
159165
-- If any parts of the expression uses the Unicode syntax, the whole expression
160166
-- is deemed to be using the Unicode syntax.
@@ -176,7 +182,7 @@ prettyExpr :: Pretty a => Expr s a -> Doc Ann
176182
prettyExpr = prettySrcExpr . denote
177183

178184
prettySrcExpr :: Pretty a => Expr Src a -> Doc Ann
179-
prettySrcExpr = prettyCharacterSet Unicode
185+
prettySrcExpr = prettyCharacterSet defaultCharacterSet
180186

181187
{-| Internal utility for pretty-printing, used when generating element lists
182188
to supply to `enclose` or `enclose'`. This utility indicates that the

0 commit comments

Comments
 (0)