Skip to content

Commit 4ce3e65

Browse files
mmhatmmhat
authored
Added dhall package command (#2487)
* Added dhall package command Fixes #1645 * Simplified implementation We require that all files are in the same directory. The package.dhall will be written to that directory. * Moved package filename defaulting to getPackagePathAndContent * Fixed haddocks * Fixed tests: Wrong path separator on Windows * Renamed some test files
1 parent 0f1b05c commit 4ce3e65

File tree

10 files changed

+306
-0
lines changed

10 files changed

+306
-0
lines changed

‎dhall/dhall.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -332,6 +332,7 @@ Library
332332
Dhall.Marshal.Encode
333333
Dhall.Map
334334
Dhall.Optics
335+
Dhall.Package
335336
Dhall.Parser
336337
Dhall.Parser.Expression
337338
Dhall.Parser.Token
@@ -420,6 +421,7 @@ Test-Suite tasty
420421
Dhall.Test.Import
421422
Dhall.Test.Lint
422423
Dhall.Test.Normalization
424+
Dhall.Test.Package
423425
Dhall.Test.Parser
424426
Dhall.Test.QuickCheck
425427
Dhall.Test.Regression

‎dhall/src/Dhall/Main.hs‎

Lines changed: 25 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -36,6 +36,7 @@ import Dhall.Import
3636
, SemanticCacheMode (..)
3737
, _semanticCacheMode
3838
)
39+
import Dhall.Package (writePackage)
3940
import Dhall.Parser (Src)
4041
import Dhall.Pretty
4142
( Ann
@@ -162,6 +163,7 @@ data Mode
162163
| DirectoryTree { allowSeparators :: Bool, file :: Input, path :: FilePath }
163164
| Schemas { file :: Input, outputMode :: OutputMode, schemas :: Text }
164165
| SyntaxTree { file :: Input, noted :: Bool }
166+
| Package { name :: Maybe String, files :: NonEmpty FilePath }
165167

166168
-- | This specifies how to resolve transitive dependencies
167169
data ResolveMode
@@ -310,6 +312,11 @@ parseMode =
310312
"hash"
311313
"Compute semantic hashes for Dhall expressions"
312314
(Hash <$> parseFile <*> parseCache)
315+
<|> subcommand
316+
Miscellaneous
317+
"package"
318+
"Create a package.dhall referencing the provided paths"
319+
(Package <$> parsePackageName <*> parsePackageFiles)
313320
<|> subcommand
314321
Miscellaneous
315322
"tags"
@@ -559,6 +566,22 @@ parseMode =
559566
<> Options.Applicative.help "Cache the hashed expression"
560567
)
561568

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+
)
576+
577+
parsePackageFiles = (:|) <$> p <*> Options.Applicative.many p
578+
where
579+
p = Options.Applicative.strArgument
580+
( 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."
581+
<> Options.Applicative.metavar "PATH"
582+
<> Options.Applicative.action "file"
583+
)
584+
562585
-- | `ParserInfo` for the `Options` type
563586
parserInfoOptions :: ParserInfo Options
564587
parserInfoOptions =
@@ -1018,6 +1041,8 @@ command (Options {..}) = do
10181041
denoted = Dhall.Core.denote expression
10191042
in Text.Pretty.Simple.pPrintNoColor denoted
10201043

1044+
Package {..} -> writePackage (fromMaybe Unicode chosenCharacterSet) name files
1045+
10211046
-- | Entry point for the @dhall@ executable
10221047
main :: IO ()
10231048
main = do

‎dhall/src/Dhall/Package.hs‎

Lines changed: 131 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,131 @@
1+
{-# LANGUAGE BangPatterns #-}
2+
{-# LANGUAGE MultiWayIf #-}
3+
4+
-- | Create a package.dhall from files and directory contents.
5+
6+
module Dhall.Package
7+
( writePackage
8+
, getPackagePathAndContent
9+
, PackageError(..)
10+
) where
11+
12+
import Control.Exception (Exception, throwIO)
13+
import Control.Monad
14+
import Data.List.NonEmpty (NonEmpty (..))
15+
import Data.Maybe (fromMaybe)
16+
import Data.Text (Text)
17+
import qualified Data.Text as Text
18+
import Dhall.Core
19+
( Directory (..)
20+
, Expr (..)
21+
, File (..)
22+
, FilePrefix (..)
23+
, Import (..)
24+
, ImportHashed (..)
25+
, ImportMode (..)
26+
, ImportType (..)
27+
, RecordField
28+
, makeRecordField
29+
)
30+
import Dhall.Map (Map)
31+
import qualified Dhall.Map as Map
32+
import Dhall.Pretty (CharacterSet (..))
33+
import Dhall.Util (_ERROR, renderExpression)
34+
import System.Directory
35+
import System.FilePath
36+
37+
-- | Create a package.dhall from files and directory contents.
38+
-- For a description of how the package file is constructed see
39+
-- 'getPackagePathAndContent'.
40+
writePackage :: CharacterSet -> Maybe String -> NonEmpty FilePath -> IO ()
41+
writePackage characterSet outputFn inputs = do
42+
(outputPath, expr) <- getPackagePathAndContent outputFn inputs
43+
renderExpression characterSet True (Just outputPath) expr
44+
45+
-- | Get the path and the Dhall expression for a package file.
46+
--
47+
-- The inputs provided as the second argument are processed depending on whether
48+
-- the path points to a directory or a file:
49+
--
50+
-- * If the path points to a directory, all files with a @.dhall@ extensions
51+
-- in that directory are included in the package.
52+
-- The package file will be located in that directory.
53+
--
54+
-- * If the path points to a regular file, it is included in the package
55+
-- unless it is the path of the package file itself.
56+
-- All files passed as input must reside in the same directory.
57+
-- The package file will be located in the (shared) parent directory of the
58+
-- files passed as input to this function.
59+
--
60+
getPackagePathAndContent :: Maybe String -> NonEmpty FilePath -> IO (FilePath, Expr s Import)
61+
getPackagePathAndContent outputFn (path :| paths) = do
62+
outputDir <- do
63+
isDirectory <- doesDirectoryExist path
64+
return $ if isDirectory then path else takeDirectory path
65+
outputDir' <- makeAbsolute $ normalise outputDir
66+
67+
let checkOutputDir dir = do
68+
dir' <- makeAbsolute $ normalise dir
69+
when (dir' /= outputDir') $
70+
throwIO $ AmbiguousOutputDirectory outputDir dir
71+
72+
resultMap <- go Map.empty checkOutputDir (path:paths)
73+
return (outputDir </> outputFn', RecordLit resultMap)
74+
where
75+
go :: Map Text (RecordField s Import) -> (FilePath -> IO ()) -> [FilePath] -> IO (Map Text (RecordField s Import))
76+
go !acc _checkOutputDir [] = return acc
77+
go !acc checkOutputDir (p:ps) = do
78+
isDirectory <- doesDirectoryExist p
79+
isFile <- doesFileExist p
80+
if | isDirectory -> do
81+
checkOutputDir p
82+
entries <- listDirectory p
83+
let entries' = filter (\entry -> takeExtension entry == ".dhall") entries
84+
go acc checkOutputDir (map (p </>) entries' <> ps)
85+
| isFile -> do
86+
checkOutputDir $ takeDirectory p
87+
88+
let key = Text.pack $ dropExtension $ takeFileName p
89+
90+
let import_ = Import
91+
{ importHashed = ImportHashed
92+
{ hash = Nothing
93+
, importType = Local Here File
94+
{ directory = Directory []
95+
, file = Text.pack (takeFileName p)
96+
}
97+
}
98+
, importMode = Code
99+
}
100+
101+
let resultMap = if takeFileName p == outputFn'
102+
then Map.empty
103+
else Map.singleton key (makeRecordField $ Embed import_)
104+
105+
go (resultMap <> acc) checkOutputDir ps
106+
| otherwise -> throwIO $ InvalidPath p
107+
108+
outputFn' = fromMaybe "package.dhall" outputFn
109+
110+
-- | Exception thrown when creating a package file.
111+
data PackageError
112+
= AmbiguousOutputDirectory FilePath FilePath
113+
| InvalidPath FilePath
114+
115+
instance Exception PackageError
116+
117+
instance Show PackageError where
118+
show (AmbiguousOutputDirectory dir1 dir2) =
119+
_ERROR <> ": ❰dhall package❱ failed because the inputs make it impossible to\n\
120+
\determine the output directory of the package file. You asked to include files\n\
121+
\from the following directories in the package:\n\
122+
\\n" <> dir1 <>
123+
"\n" <> dir2 <>
124+
"\n\n\
125+
\Although those paths might point to the same location they are not lexically the\n\
126+
\same."
127+
128+
show (InvalidPath fp) =
129+
_ERROR <> ": ❰dhall package❱ failed because the input does not exist or is\n\
130+
\neither a directory nor a regular file:\n\
131+
\\n" <> fp

‎dhall/tests/Dhall/Test/Main.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,7 @@ import qualified Dhall.Test.Freeze
1111
import qualified Dhall.Test.Import
1212
import qualified Dhall.Test.Lint
1313
import qualified Dhall.Test.Normalization
14+
import qualified Dhall.Test.Package
1415
import qualified Dhall.Test.Parser
1516
import qualified Dhall.Test.QuickCheck
1617
import qualified Dhall.Test.Regression
@@ -69,6 +70,7 @@ getAllTests = do
6970
, Dhall.Test.QuickCheck.tests
7071
, Dhall.Test.Dhall.tests
7172
, Dhall.Test.TH.tests
73+
, Dhall.Test.Package.tests
7274
]
7375

7476
return testTree

‎dhall/tests/Dhall/Test/Package.hs‎

Lines changed: 146 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,146 @@
1+
{-# LANGUAGE LambdaCase #-}
2+
{-# LANGUAGE OverloadedStrings #-}
3+
4+
module Dhall.Test.Package where
5+
6+
import Control.Exception (Exception, displayException, try)
7+
import Data.List.NonEmpty (NonEmpty (..))
8+
import Data.Void (Void)
9+
import Dhall.Core
10+
( Directory (..)
11+
, Expr (..)
12+
, File (..)
13+
, FilePrefix (..)
14+
, Import (..)
15+
, ImportHashed (..)
16+
, ImportMode (..)
17+
, ImportType (..)
18+
, makeRecordField
19+
)
20+
import qualified Dhall.Map as Map
21+
import Dhall.Package
22+
import System.FilePath ((</>))
23+
import Test.Tasty
24+
import Test.Tasty.HUnit
25+
26+
tests :: TestTree
27+
tests = testGroup "Package"
28+
[ packagePackageFile
29+
, packageCustomPackageFile
30+
, packageSingleFile
31+
, packageEmptyDirectory
32+
, packageSingleDirectory
33+
, packageMissingFile
34+
, packageFilesDifferentDirs
35+
]
36+
37+
packagePackageFile :: TestTree
38+
packagePackageFile = testCase "package file" $ do
39+
let path = "./tests/package" </> "package.dhall"
40+
41+
let package :: Expr Void Import
42+
package = RecordLit Map.empty
43+
44+
(output, expr) <- getPackagePathAndContent Nothing ("./tests/package/package.dhall" :| [])
45+
assertEqual "path" path output
46+
assertEqual "content" package expr
47+
48+
packageCustomPackageFile :: TestTree
49+
packageCustomPackageFile = testCase "custom package file" $ do
50+
let path = "./tests/package" </> "custom.dhall"
51+
52+
let package :: Expr Void Import
53+
package = RecordLit $ Map.singleton "package" $
54+
makeRecordField $ Embed Import
55+
{ importHashed = ImportHashed
56+
{ hash = Nothing
57+
, importType = Local Here File
58+
{ directory = Directory []
59+
, file = "package.dhall"
60+
}
61+
}
62+
, importMode = Code
63+
}
64+
65+
(output, expr) <- getPackagePathAndContent (Just "custom.dhall") ("./tests/package/package.dhall" :| [])
66+
assertEqual "path" path output
67+
assertEqual "content" package expr
68+
69+
packageSingleFile :: TestTree
70+
packageSingleFile = testCase "single file" $ do
71+
let path = "./tests/package/dir" </> "package.dhall"
72+
73+
let package :: Expr Void Import
74+
package = RecordLit $ Map.singleton "test" $
75+
makeRecordField $ Embed Import
76+
{ importHashed = ImportHashed
77+
{ hash = Nothing
78+
, importType = Local Here File
79+
{ directory = Directory []
80+
, file = "test.dhall"
81+
}
82+
}
83+
, importMode = Code
84+
}
85+
86+
(output, expr) <- getPackagePathAndContent Nothing ("./tests/package/dir/test.dhall" :| [])
87+
assertEqual "path" path output
88+
assertEqual "content" package expr
89+
90+
packageEmptyDirectory :: TestTree
91+
packageEmptyDirectory = testCase "empty directory" $ do
92+
let path = "./tests/package/empty" </> "package.dhall"
93+
94+
let package :: Expr Void Import
95+
package = RecordLit Map.empty
96+
97+
(output, expr) <- getPackagePathAndContent Nothing ("./tests/package/empty" :| [])
98+
assertEqual "path" path output
99+
assertEqual "content" package expr
100+
101+
packageSingleDirectory :: TestTree
102+
packageSingleDirectory = testCase "single directory" $ do
103+
let path = "./tests/package/dir" </> "package.dhall"
104+
105+
let package :: Expr Void Import
106+
package = RecordLit $ Map.singleton "test" $
107+
makeRecordField $ Embed Import
108+
{ importHashed = ImportHashed
109+
{ hash = Nothing
110+
, importType = Local Here File
111+
{ directory = Directory []
112+
, file = "test.dhall"
113+
}
114+
}
115+
, importMode = Code
116+
}
117+
118+
(output, expr) <- getPackagePathAndContent Nothing ("./tests/package/dir" :| [])
119+
assertEqual "path" path output
120+
assertEqual "content" package expr
121+
122+
packageMissingFile :: TestTree
123+
packageMissingFile = testCase "missing file" $ do
124+
let action :: IO (FilePath, Expr Void Import)
125+
action = getPackagePathAndContent Nothing ("./tests/package/missing.dhall" :| [])
126+
127+
assertThrow action $ \case
128+
InvalidPath "./tests/package/missing.dhall" -> True
129+
_ -> False
130+
131+
packageFilesDifferentDirs :: TestTree
132+
packageFilesDifferentDirs = testCase "files from different directories" $ do
133+
let action :: IO (FilePath, Expr Void Import)
134+
action = getPackagePathAndContent Nothing ("./tests/package/test.dhall" :| ["./tests/package/dir/test.dhall"])
135+
136+
assertThrow action $ \case
137+
AmbiguousOutputDirectory "./tests/package" "./tests/package/dir" -> True
138+
_ -> False
139+
140+
assertThrow :: (Exception e, Show a) => IO a -> (e -> Bool) -> IO ()
141+
assertThrow k p = do
142+
result <- try k
143+
case result of
144+
Left e | p e -> return ()
145+
Left e -> assertFailure $ "Predicate did not match: " <> displayException e
146+
Right result' -> assertFailure $ "Expected exception, but got: " <> show result'

‎dhall/tests/package/dir/test.dhall‎

Whitespace-only changes.

‎dhall/tests/package/dir/wrong-extension.txt‎

Whitespace-only changes.

‎dhall/tests/package/empty/wrong-extension.txt‎

Whitespace-only changes.

‎dhall/tests/package/package.dhall‎

Whitespace-only changes.

‎dhall/tests/package/test.dhall‎

Whitespace-only changes.

0 commit comments

Comments
 (0)