Skip to content

Commit 891b7ae

Browse files
mmhatmmhat
committed
Added dedicated Options type for packaging
1 parent 0bbf5be commit 891b7ae

File tree

5 files changed

+135
-52
lines changed

5 files changed

+135
-52
lines changed

‎dhall/src/Dhall/Main.hs

+32-19
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 (Recurse(..), 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 { recurse :: Recurse, 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 <$> parseRecurse <*> 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
@@ -582,15 +599,6 @@ parseMode =
582599
<> Options.Applicative.action "file"
583600
)
584601

585-
parseRecurse = adjust <$> Options.Applicative.switch
586-
( Options.Applicative.short 'r'
587-
<> Options.Applicative.long "recurse"
588-
<> Options.Applicative.help "Create packages for all subdirectories first."
589-
)
590-
where
591-
adjust True = Recurse
592-
adjust False = Exact
593-
594602
-- | `ParserInfo` for the `Options` type
595603
parserInfoOptions :: ParserInfo Options
596604
parserInfoOptions =
@@ -1050,7 +1058,12 @@ command (Options {..}) = do
10501058
denoted = Dhall.Core.denote expression
10511059
in Text.Pretty.Simple.pPrintNoColor denoted
10521060

1053-
Package {..} -> writePackage (fromMaybe Unicode chosenCharacterSet) recurse 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
10541067

10551068
-- | Entry point for the @dhall@ executable
10561069
main :: IO ()

‎dhall/src/Dhall/Package.hs

+72-21
Original file line numberDiff line numberDiff line change
@@ -5,7 +5,12 @@
55
-- | Create a package.dhall from files and directory contents.
66

77
module Dhall.Package
8-
( Recurse(..)
8+
( Options
9+
, defaultOptions
10+
, characterSet
11+
, packageFileName
12+
, packagingMode
13+
, PackagingMode(..)
914
, writePackage
1015
, getPackagePathAndContent
1116
, PackageError(..)
@@ -14,7 +19,6 @@ module Dhall.Package
1419
import Control.Exception (Exception, throwIO)
1520
import Control.Monad
1621
import Data.List.NonEmpty (NonEmpty (..))
17-
import Data.Maybe (fromMaybe)
1822
import Data.Text (Text)
1923
import qualified Data.Text as Text
2024
import Data.Traversable (for)
@@ -35,22 +39,60 @@ import qualified Dhall.Map as Map
3539
import Dhall.Pretty (CharacterSet (..))
3640
import qualified Dhall.Pretty
3741
import Dhall.Util (_ERROR, renderExpression)
42+
import Lens.Family (LensLike')
3843
import System.Directory
3944
import System.FilePath
4045

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+
4183
-- | Whether to recursively create a package for each subdirectory or not.
4284
-- See the documentation of 'getPackagePathAndContent'.
43-
data Recurse
44-
= Recurse
45-
| Exact
85+
data PackagingMode
86+
= OnlyThisPackage
87+
| RecursiveSubpackages
4688

4789
-- | Create a package.dhall from files and directory contents.
4890
-- For a description of how the package file is constructed see
4991
-- 'getPackagePathAndContent'.
50-
writePackage :: CharacterSet -> Recurse -> Maybe String -> NonEmpty FilePath -> IO ()
51-
writePackage characterSet doRecurse outputFn inputs = do
52-
(outputPath, expr) <- getPackagePathAndContent characterSet doRecurse outputFn inputs
53-
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
5496

5597
-- | Get the path and the Dhall expression for a package file.
5698
--
@@ -76,8 +118,11 @@ writePackage characterSet doRecurse outputFn inputs = do
76118
-- * If the path points to a regular file, it is included in the package
77119
-- unless it is the path of the package file itself.
78120
--
79-
getPackagePathAndContent :: CharacterSet -> Recurse -> Maybe String -> NonEmpty FilePath -> IO (FilePath, Expr s Import)
80-
getPackagePathAndContent characterSet doRecurse outputFn (path :| paths) = do
121+
getPackagePathAndContent
122+
:: Options
123+
-> NonEmpty FilePath
124+
-> IO (FilePath, Expr s Import)
125+
getPackagePathAndContent options (path :| paths) = do
81126
outputDir <- do
82127
isDirectory <- doesDirectoryExist path
83128
return $ if isDirectory then path else takeDirectory path
@@ -93,9 +138,13 @@ getPackagePathAndContent characterSet doRecurse outputFn (path :| paths) = do
93138
return relativeDir
94139

95140
resultMap <- go Map.empty checkOutputDir (path:paths)
96-
return (outputDir </> outputFn', RecordLit $ Map.sort resultMap)
141+
return (outputDir </> outputFn, RecordLit $ Map.sort resultMap)
97142
where
98-
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))
99148
go !acc _checkOutputDir [] = return acc
100149
go !acc checkOutputDir (p:ps) = do
101150
isDirectory <- doesDirectoryExist p
@@ -113,29 +162,31 @@ getPackagePathAndContent characterSet doRecurse outputFn (path :| paths) = do
113162
then ([entry'], mempty)
114163
else mempty
115164
) entries
116-
subpackages <- case doRecurse of
117-
Recurse ->
165+
subpackages <- case optionsPackagingMode options of
166+
RecursiveSubpackages ->
118167
for subdirectories $ \subdirectory -> do
119-
writePackage characterSet Recurse outputFn (subdirectory :| [])
120-
return (subdirectory </> outputFn')
121-
Exact -> return []
168+
writePackage options (subdirectory :| [])
169+
return (subdirectory </> outputFn)
170+
OnlyThisPackage -> return []
122171
go acc checkOutputDir (dhallFiles <> subpackages <> ps)
123172
| isFile -> do
124173
dir <- checkOutputDir $ takeDirectory p
125174

126175
let p' = normalise $ dir </> takeFileName p
127176

128-
let resultMap = if p' == outputFn'
177+
let resultMap = if p' == outputFn
129178
then Map.empty
130-
else filepathToMap outputFn' p'
179+
else filepathToMap outputFn p'
131180

132181
acc' <- mergeMaps acc resultMap
133182
go acc' checkOutputDir ps
134183
| otherwise -> throwIO $ InvalidPath p
135184

185+
hasDhallExtension :: FilePath -> Bool
136186
hasDhallExtension entry = takeExtension entry == ".dhall"
137187

138-
outputFn' = fromMaybe "package.dhall" outputFn
188+
outputFn :: String
189+
outputFn = optionsPackageFileName options
139190

140191
-- | Construct a nested 'Map' from a 'FilePath'.
141192
-- 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)