Skip to content

Commit 4fd1865

Browse files
mmhatGabriella439
mmhat
and
Gabriella439
authored
Improved package command (#2508)
* Improved package command You can now include files that reside below the output directory in the package. This is for example useful if you want to include sub-packages in a top-level package. * Update dhall/src/Dhall/Package.hs Co-authored-by: Gabriella Gonzalez <GenuineGabriella@gmail.com> * Update dhall/src/Dhall/Package.hs Co-authored-by: Gabriella Gonzalez <GenuineGabriella@gmail.com> * Update dhall/src/Dhall/Package.hs Co-authored-by: Gabriella Gonzalez <GenuineGabriella@gmail.com> --------- Co-authored-by: Gabriella Gonzalez <GenuineGabriella@gmail.com>
1 parent 44e7b97 commit 4fd1865

File tree

5 files changed

+211
-57
lines changed

5 files changed

+211
-57
lines changed

‎dhall/src/Dhall/Package.hs‎

Lines changed: 111 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,5 @@
11
{-# LANGUAGE BangPatterns #-}
2+
{-# LANGUAGE LambdaCase #-}
23
{-# LANGUAGE MultiWayIf #-}
34

45
-- | Create a package.dhall from files and directory contents.
@@ -15,6 +16,7 @@ import Data.List.NonEmpty (NonEmpty (..))
1516
import Data.Maybe (fromMaybe)
1617
import Data.Text (Text)
1718
import qualified Data.Text as Text
19+
import Data.Traversable (for)
1820
import Dhall.Core
1921
( Directory (..)
2022
, Expr (..)
@@ -24,12 +26,13 @@ import Dhall.Core
2426
, ImportHashed (..)
2527
, ImportMode (..)
2628
, ImportType (..)
27-
, RecordField
29+
, RecordField (..)
2830
, makeRecordField
2931
)
3032
import Dhall.Map (Map)
3133
import qualified Dhall.Map as Map
3234
import Dhall.Pretty (CharacterSet (..))
35+
import qualified Dhall.Pretty
3336
import Dhall.Util (_ERROR, renderExpression)
3437
import System.Directory
3538
import System.FilePath
@@ -44,72 +47,152 @@ writePackage characterSet outputFn inputs = do
4447

4548
-- | Get the path and the Dhall expression for a package file.
4649
--
47-
-- The inputs provided as the second argument are processed depending on whether
50+
-- The location of the resulting package file is determined by the first path of the second argument:
51+
--
52+
-- * If it is a directory, it is also the output directory and the package
53+
-- file will be placed there.
54+
--
55+
-- * If it is a file, then the directory that file resides in is the output
56+
-- directory and the package file will be placed there.
57+
--
58+
-- All inputs provided as the second argument must be either in the output
59+
-- directory or below it. They are processed depending on whether
4860
-- the path points to a directory or a file:
4961
--
5062
-- * If the path points to a directory, all files with a @.dhall@ extensions
5163
-- in that directory are included in the package.
52-
-- The package file will be located in that directory.
5364
--
5465
-- * If the path points to a regular file, it is included in the package
5566
-- 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.
5967
--
6068
getPackagePathAndContent :: Maybe String -> NonEmpty FilePath -> IO (FilePath, Expr s Import)
6169
getPackagePathAndContent outputFn (path :| paths) = do
6270
outputDir <- do
6371
isDirectory <- doesDirectoryExist path
6472
return $ if isDirectory then path else takeDirectory path
65-
outputDir' <- makeAbsolute $ normalise outputDir
73+
outputDir' <- addTrailingPathSeparator <$> makeAbsolute (normalise outputDir)
6674

75+
-- Check if the supplied @dir@ argument points to a filesystem entry below
76+
-- the output directory and return the path relative to the output directory.
6777
let checkOutputDir dir = do
68-
dir' <- makeAbsolute $ normalise dir
69-
when (dir' /= outputDir') $
78+
absoluteDir <- addTrailingPathSeparator <$> makeAbsolute (normalise dir)
79+
let relativeDir = makeRelative outputDir' absoluteDir
80+
unless (isRelative relativeDir) $
7081
throwIO $ AmbiguousOutputDirectory outputDir dir
82+
return relativeDir
7183

7284
resultMap <- go Map.empty checkOutputDir (path:paths)
73-
return (outputDir </> outputFn', RecordLit resultMap)
85+
return (outputDir </> outputFn', RecordLit $ Map.sort resultMap)
7486
where
75-
go :: Map Text (RecordField s Import) -> (FilePath -> IO ()) -> [FilePath] -> IO (Map Text (RecordField s Import))
87+
go :: Map Text (RecordField s Import) -> (FilePath -> IO FilePath) -> [FilePath] -> IO (Map Text (RecordField s Import))
7688
go !acc _checkOutputDir [] = return acc
7789
go !acc checkOutputDir (p:ps) = do
7890
isDirectory <- doesDirectoryExist p
7991
isFile <- doesFileExist p
8092
if | isDirectory -> do
81-
checkOutputDir p
93+
void $ checkOutputDir p
8294
entries <- listDirectory p
8395
let entries' = filter (\entry -> takeExtension entry == ".dhall") entries
8496
go acc checkOutputDir (map (p </>) entries' <> ps)
8597
| isFile -> do
86-
checkOutputDir $ takeDirectory p
98+
dir <- checkOutputDir $ takeDirectory p
99+
100+
let p' = normalise $ dir </> takeFileName p
101+
102+
let resultMap = if p' == outputFn'
103+
then Map.empty
104+
else filepathToMap outputFn' p'
105+
106+
acc' <- mergeMaps acc resultMap
107+
go acc' checkOutputDir ps
108+
| otherwise -> throwIO $ InvalidPath p
87109

88-
let key = Text.pack $ dropExtension $ takeFileName p
110+
outputFn' = fromMaybe "package.dhall" outputFn
89111

112+
-- | Construct a nested 'Map' from a 'FilePath'.
113+
-- For example, the filepath @some/file/path.dhall@ will result in something
114+
-- similar to the following:
115+
--
116+
-- fromList
117+
-- [ ("some", fromList
118+
-- [ ("file", fromList
119+
-- [ ("path", ./some/file/path.dhall)
120+
-- ])
121+
-- ])
122+
-- ])
123+
--
124+
-- ... where ./some/file/path.dhall is a Dhall import. If the last component
125+
-- equals the value passed in the @outputFn@ argument we produce a slightly
126+
-- different result. Consider for example the Dhall Prelude: We have some
127+
-- sub-packages there like @List/package.dhall@. If we want to construct the
128+
-- top-level @package.dhall@ we want an entry like
129+
--
130+
-- > List = ./List/package.dhall
131+
--
132+
-- in there and not:
133+
--
134+
-- > List = { package = ./List/package.dhall }
135+
--
136+
filepathToMap :: FilePath -> FilePath -> Map Text (RecordField s Import)
137+
filepathToMap outputFn = go [] . splitDirectories
138+
where
139+
go acc [] = go acc ["."]
140+
go !acc [x] =
90141
let import_ = Import
91142
{ importHashed = ImportHashed
92143
{ hash = Nothing
93144
, importType = Local Here File
94-
{ directory = Directory []
95-
, file = Text.pack (takeFileName p)
145+
{ directory = Directory acc
146+
, file = Text.pack x
96147
}
97148
}
98149
, importMode = Code
99150
}
151+
in Map.singleton (Text.pack $ dropExtension x) $ makeRecordField $ Embed import_
152+
go !acc [x, y] | y == outputFn =
153+
let import_ = Import
154+
{ importHashed = ImportHashed
155+
{ hash = Nothing
156+
, importType = Local Here File
157+
{ directory = Directory (Text.pack x : acc)
158+
, file = Text.pack y
159+
}
160+
}
161+
, importMode = Code
162+
}
163+
in Map.singleton (Text.pack x) $ makeRecordField $ Embed import_
164+
go !acc (x:xs) = Map.singleton (Text.pack x) $ makeRecordField $ RecordLit $ go (Text.pack x : acc) xs
100165

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
166+
-- | Merge two 'Map's constructed with 'filepathToMap'.
167+
-- It will throw an error if the arguments are not compatible with each other, e.g.
168+
-- we cannot merge the following two maps:
169+
--
170+
-- > fromList [ ("file", ./file.dhall) ]
171+
-- > fromList [ ("file", fromList [("nested", ./file/nested.dhall)]) ]
172+
--
173+
mergeMaps :: Map Text (RecordField s Import) -> Map Text (RecordField s Import) -> IO (Map Text (RecordField s Import))
174+
mergeMaps x y = do
175+
let x' = fmap (:| []) x
176+
y' = fmap (:| []) y
177+
z = Map.unionWith (<>) x' y'
178+
for z $ \case
179+
v@RecordField{recordFieldValue = Embed{}} :| [] -> return v
180+
vs | Just rs <- traverse extractRecordLit vs -> makeRecordField . RecordLit . Map.sort <$> foldM mergeMaps Map.empty rs
181+
| otherwise -> throwIO $ IncompatiblePaths $ foldMap extractEmbeds vs
182+
where
183+
extractEmbeds :: RecordField s Import -> [Import]
184+
extractEmbeds RecordField{recordFieldValue = Embed import_} = [import_]
185+
extractEmbeds RecordField{recordFieldValue = RecordLit xs} = foldMap extractEmbeds xs
186+
extractEmbeds _ = mempty
107187

108-
outputFn' = fromMaybe "package.dhall" outputFn
188+
extractRecordLit :: RecordField s Import -> Maybe (Map Text (RecordField s Import))
189+
extractRecordLit RecordField{recordFieldValue = RecordLit xs} = Just xs
190+
extractRecordLit _ = Nothing
109191

110192
-- | Exception thrown when creating a package file.
111193
data PackageError
112194
= AmbiguousOutputDirectory FilePath FilePath
195+
| IncompatiblePaths [Import]
113196
| InvalidPath FilePath
114197

115198
instance Exception PackageError
@@ -125,6 +208,11 @@ instance Show PackageError where
125208
\Although those paths might point to the same location they are not lexically the\n\
126209
\same."
127210

211+
show (IncompatiblePaths imports) =
212+
_ERROR <> ": ❰dhall package❱ failed because some inputs are not compatible with\n\
213+
\each other:\n\
214+
\\n" <> unlines (map (show . Dhall.Pretty.prettyExpr . Embed) imports)
215+
128216
show (InvalidPath fp) =
129217
_ERROR <> ": ❰dhall package❱ failed because the input does not exist or is\n\
130218
\neither a directory nor a regular file:\n\

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

Lines changed: 100 additions & 34 deletions
Original file line numberDiff line numberDiff line change
@@ -30,8 +30,10 @@ tests = testGroup "Package"
3030
, packageSingleFile
3131
, packageEmptyDirectory
3232
, packageSingleDirectory
33+
, packageNested
3334
, packageMissingFile
3435
, packageFilesDifferentDirs
36+
, packageIncompatibleFiles
3537
]
3638

3739
packagePackageFile :: TestTree
@@ -50,17 +52,8 @@ packageCustomPackageFile = testCase "custom package file" $ do
5052
let path = "./tests/package" </> "custom.dhall"
5153

5254
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-
}
55+
package = RecordLit $
56+
Map.singleton "package" $ makeRecordField $ Embed packageDhall
6457

6558
(output, expr) <- getPackagePathAndContent (Just "custom.dhall") ("./tests/package/package.dhall" :| [])
6659
assertEqual "path" path output
@@ -71,17 +64,8 @@ packageSingleFile = testCase "single file" $ do
7164
let path = "./tests/package/dir" </> "package.dhall"
7265

7366
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-
}
67+
package = RecordLit $
68+
Map.singleton "test" $ makeRecordField $ Embed testDhall
8569

8670
(output, expr) <- getPackagePathAndContent Nothing ("./tests/package/dir/test.dhall" :| [])
8771
assertEqual "path" path output
@@ -104,21 +88,34 @@ packageSingleDirectory = testCase "single directory" $ do
10488

10589
let package :: Expr Void Import
10690
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-
}
91+
makeRecordField $ Embed testDhall
11792

11893
(output, expr) <- getPackagePathAndContent Nothing ("./tests/package/dir" :| [])
11994
assertEqual "path" path output
12095
assertEqual "content" package expr
12196

97+
packageNested :: TestTree
98+
packageNested = testCase "nested files" $ do
99+
let path = "./tests/package" </> "package.dhall"
100+
101+
let package :: Expr Void Import
102+
package = RecordLit $ Map.fromList
103+
[ ("dir", makeRecordField $ RecordLit $ Map.fromList
104+
[ ("test", makeRecordField $ Embed dirTestDhall)
105+
]
106+
)
107+
, ("other", makeRecordField $ Embed otherPackageDhall)
108+
, ("test", makeRecordField $ Embed testDhall)
109+
]
110+
111+
(output, expr) <- getPackagePathAndContent Nothing
112+
( "./tests/package/test.dhall" :|
113+
[ "./tests/package/dir/test.dhall"
114+
, "./tests/package/other/package.dhall"
115+
])
116+
assertEqual "path" path output
117+
assertEqual "content" package expr
118+
122119
packageMissingFile :: TestTree
123120
packageMissingFile = testCase "missing file" $ do
124121
let action :: IO (FilePath, Expr Void Import)
@@ -131,12 +128,81 @@ packageMissingFile = testCase "missing file" $ do
131128
packageFilesDifferentDirs :: TestTree
132129
packageFilesDifferentDirs = testCase "files from different directories" $ do
133130
let action :: IO (FilePath, Expr Void Import)
134-
action = getPackagePathAndContent Nothing ("./tests/package/test.dhall" :| ["./tests/package/dir/test.dhall"])
131+
action = getPackagePathAndContent Nothing ("./tests/package/dir/test.dhall" :| ["./tests/package/test/test.dhall"])
135132

136133
assertThrow action $ \case
137-
AmbiguousOutputDirectory "./tests/package" "./tests/package/dir" -> True
134+
AmbiguousOutputDirectory "./tests/package/dir" "./tests/package/test" -> True
138135
_ -> False
139136

137+
packageIncompatibleFiles :: TestTree
138+
packageIncompatibleFiles = testCase "files that are incompatible" $ do
139+
let action :: IO (FilePath, Expr Void Import)
140+
action = getPackagePathAndContent Nothing ("./tests/package/test.dhall" :| ["./tests/package/test/test.dhall"])
141+
142+
assertThrow action $ \case
143+
IncompatiblePaths xs -> xs == [ testDhall , testTestDhall ]
144+
_ -> False
145+
146+
packageDhall :: Import
147+
packageDhall = Import
148+
{ importHashed = ImportHashed
149+
{ hash = Nothing
150+
, importType = Local Here File
151+
{ directory = Directory []
152+
, file = "package.dhall"
153+
}
154+
}
155+
, importMode = Code
156+
}
157+
158+
testDhall :: Import
159+
testDhall = Import
160+
{ importHashed = ImportHashed
161+
{ hash = Nothing
162+
, importType = Local Here File
163+
{ directory = Directory []
164+
, file = "test.dhall"
165+
}
166+
}
167+
, importMode = Code
168+
}
169+
170+
dirTestDhall :: Import
171+
dirTestDhall = Import
172+
{ importHashed = ImportHashed
173+
{ hash = Nothing
174+
, importType = Local Here $ File
175+
{ directory = Directory {components = ["dir"]}
176+
, file = "test.dhall"
177+
}
178+
}
179+
, importMode = Code
180+
}
181+
182+
otherPackageDhall :: Import
183+
otherPackageDhall = Import
184+
{ importHashed = ImportHashed
185+
{ hash = Nothing
186+
, importType = Local Here $ File
187+
{ directory = Directory {components = ["other"]}
188+
, file = "package.dhall"
189+
}
190+
}
191+
, importMode = Code
192+
}
193+
194+
testTestDhall :: Import
195+
testTestDhall = Import
196+
{ importHashed = ImportHashed
197+
{ hash = Nothing
198+
, importType = Local Here (File
199+
{ directory = Directory {components = ["test"]}
200+
, file = "test.dhall"
201+
})
202+
}
203+
, importMode = Code
204+
}
205+
140206
assertThrow :: (Exception e, Show a) => IO a -> (e -> Bool) -> IO ()
141207
assertThrow k p = do
142208
result <- try k

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

Whitespace-only changes.

‎dhall/tests/package/other/package.dhall‎

Whitespace-only changes.

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

Whitespace-only changes.

0 commit comments

Comments
 (0)