Improved package command

dhall/src/Dhall/Package.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase   #-}
 {-# LANGUAGE MultiWayIf   #-}
 
 -- | Create a package.dhall from files and directory contents.
@@ -15,6 +16,7 @@ import           Data.List.NonEmpty (NonEmpty (..))
 import           Data.Maybe         (fromMaybe)
 import           Data.Text          (Text)
 import qualified Data.Text          as Text
+import           Data.Traversable   (for)
 import           Dhall.Core
     ( Directory (..)
     , Expr (..)
@@ -24,12 +26,13 @@ import           Dhall.Core
     , ImportHashed (..)
     , ImportMode (..)
     , ImportType (..)
-    , RecordField
+    , RecordField (..)
     , makeRecordField
     )
 import           Dhall.Map          (Map)
 import qualified Dhall.Map          as Map
 import           Dhall.Pretty       (CharacterSet (..))
+import qualified Dhall.Pretty
 import           Dhall.Util         (_ERROR, renderExpression)
 import           System.Directory
 import           System.FilePath
@@ -44,72 +47,152 @@ writePackage characterSet outputFn inputs = do
 
 -- | Get the path and the Dhall expression for a package file.
 --
--- The inputs provided as the second argument are processed depending on whether
+-- The location of the resulting package file is determined by the first path of the second argument:
+--
+--   * If it is a directory, it is also the output directory and the package
+--     file will be placed there.
+--
+--   * If it is a file, then the directory that file resides in is the output
+--     directory and the package file will be placed there.
+--
+-- All inputs provided as the second argument must be either in the output
+-- directory or below it. They are processed depending on whether
 -- the path points to a directory or a file:
 --
 --   * If the path points to a directory, all files with a @.dhall@ extensions
 --     in that directory are included in the package.
---     The package file will be located in that directory.
 --
 --   * If the path points to a regular file, it is included in the package
 --     unless it is the path of the package file itself.
---     All files passed as input must reside in the same directory.
---     The package file will be located in the (shared) parent directory of the
---     files passed as input to this function.
 --
 getPackagePathAndContent :: Maybe String -> NonEmpty FilePath -> IO (FilePath, Expr s Import)
 getPackagePathAndContent outputFn (path :| paths) = do
     outputDir <- do
         isDirectory <- doesDirectoryExist path
         return $ if isDirectory then path else takeDirectory path
-    outputDir' <- makeAbsolute $ normalise outputDir
+    outputDir' <- addTrailingPathSeparator <$> makeAbsolute (normalise outputDir)
 
+    -- Check if the supplied @dir@ argument points to a filesystem entry below
+    -- the output directory and return the path relative to the output directory.
     let checkOutputDir dir = do
-            dir' <- makeAbsolute $ normalise dir
-            when (dir' /= outputDir') $
+            absoluteDir <- addTrailingPathSeparator <$> makeAbsolute (normalise dir)
+            let relativeDir = makeRelative outputDir' absoluteDir
+            unless (isRelative relativeDir) $
                 throwIO $ AmbiguousOutputDirectory outputDir dir
+            return relativeDir
 
     resultMap <- go Map.empty checkOutputDir (path:paths)
-    return (outputDir </> outputFn', RecordLit resultMap)
+    return (outputDir </> outputFn', RecordLit $ Map.sort resultMap)
     where
-        go :: Map Text (RecordField s Import) -> (FilePath -> IO ()) -> [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
-                    checkOutputDir p
+                    void $ checkOutputDir p
                     entries <- listDirectory p
                     let entries' = filter (\entry -> takeExtension entry == ".dhall") entries
                     go acc checkOutputDir (map (p </>) entries' <> ps)
                | isFile -> do
-                    checkOutputDir $ takeDirectory p
+                    dir <- checkOutputDir $ takeDirectory p
+
+                    let p' = normalise $ dir </> takeFileName p
+
+                    let resultMap = if p' == outputFn'
+                            then Map.empty
+                            else filepathToMap outputFn' p'
+
+                    acc' <- mergeMaps acc resultMap
+                    go acc' checkOutputDir ps
+                | otherwise -> throwIO $ InvalidPath p
 
-                    let key = Text.pack $ dropExtension $ takeFileName p
+        outputFn' = fromMaybe "package.dhall" outputFn
 
+-- | Construct a nested 'Map' from a 'FilePath'.
+-- For example, the filepath @some/file/path.dhall@ will result in something
+-- similar to the following:
+--
+-- fromList
+--   [ ("some", fromList
+--     [ ("file", fromList
+--       [ ("path", ./some/file/path.dhall)
+--       ])
+--     ])
+--   ])
+--
+-- ... where ./some/file/path.dhall is a Dhall import. If the last component
+-- equals the value passed in the @outputFn@ argument we produce a slightly
+-- different result. Consider for example the Dhall Prelude: We have some
+-- sub-packages there like @List/package.dhall@. If we want to construct the
+-- top-level @package.dhall@ we want an entry like
+--
+-- > List = ./List/package.dhall
+--
+-- in there and not:
+--
+-- > List = { package = ./List/package.dhall }
+--
+filepathToMap :: FilePath -> FilePath -> Map Text (RecordField s Import)
+filepathToMap outputFn = go [] . splitDirectories
+    where
+        go _acc [] = error "filepathToMap: Path is empty"
+        go !acc [x] =
                     let import_ = Import
                             { importHashed = ImportHashed
                                 { hash = Nothing
                                 , importType = Local Here File
-                                    { directory = Directory []
-                                    , file = Text.pack (takeFileName p)
+                                    { directory = Directory acc
+                                    , file = Text.pack x
                                     }
                                 }
                             , importMode = Code
                             }
+            in Map.singleton (Text.pack $ dropExtension x) $ makeRecordField $ Embed import_
+        go !acc [x, y] | y == outputFn =
+                    let import_ = Import
+                            { importHashed = ImportHashed
+                                { hash = Nothing
+                                , importType = Local Here File
+                                    { directory = Directory (Text.pack x : acc)
+                                    , file = Text.pack y
+                                    }
+                                }
+                            , importMode = Code
+                            }
+            in Map.singleton (Text.pack x) $ makeRecordField $ Embed import_
+        go !acc (x:xs) = Map.singleton (Text.pack x) $ makeRecordField $ RecordLit $ go (Text.pack x : acc) xs
 
-                    let resultMap = if takeFileName p == outputFn'
-                            then Map.empty
-                            else Map.singleton key (makeRecordField $ Embed import_)
-
-                    go (resultMap <> acc) checkOutputDir ps
-                | otherwise -> throwIO $ InvalidPath p
+-- | Merge two 'Map's constructed with 'filepathToMap'.
+-- It will throw an ... error if the arguments are not compatible with each other, e.g.
+-- we cannot merge the following two maps:
+--
+-- > fromList [ ("file", ./file.dhall) ]
+-- > fromList [ ("file", fromList [("nested", ./file/nested.dhall)]) ]
+--
+mergeMaps :: Map Text (RecordField s Import) -> Map Text (RecordField s Import) -> IO (Map Text (RecordField s Import))
+mergeMaps x y = do
+    let x' = fmap ((:| [])) x
+        y' = fmap ((:| [])) y
+        z = Map.unionWith (<>) x' y'
+    for z $ \case
+        v@RecordField{recordFieldValue = Embed{}} :| [] -> return v
+        vs | Just rs <- traverse extractRecordLit vs -> makeRecordField . RecordLit . Map.sort <$> foldM mergeMaps Map.empty rs
+           | otherwise -> throwIO $ IncompatiblePaths $ foldMap extractEmbeds vs
+    where
+        extractEmbeds :: RecordField s Import -> [Import]
+        extractEmbeds RecordField{recordFieldValue = Embed import_} = [import_]
+        extractEmbeds RecordField{recordFieldValue = RecordLit xs} = foldMap extractEmbeds xs
+        extractEmbeds _ = mempty
 
-        outputFn' = fromMaybe "package.dhall" outputFn
+        extractRecordLit :: RecordField s Import -> Maybe (Map Text (RecordField s Import))
+        extractRecordLit RecordField{recordFieldValue = RecordLit xs} = Just xs
+        extractRecordLit _ = Nothing
 
 -- | Exception thrown when creating a package file.
 data PackageError
     = AmbiguousOutputDirectory FilePath FilePath
+    | IncompatiblePaths [Import]
     | InvalidPath FilePath
 
 instance Exception PackageError
@@ -125,6 +208,11 @@ instance Show PackageError where
         \Although those paths might point to the same location they are not lexically the\n\
         \same."
 
+    show (IncompatiblePaths imports) =
+        _ERROR <> ": ❰dhall package❱ failed because some inputs are not compatible with\n\
+        \each other:\n\
+        \\n" <> unlines (map (show . Dhall.Pretty.prettyExpr . Embed) imports)
+
     show (InvalidPath fp) =
         _ERROR <> ": ❰dhall package❱ failed because the input does not exist or is\n\
         \neither a directory nor a regular file:\n\

dhall/tests/Dhall/Test/Package.hs

@@ -30,8 +30,10 @@ tests = testGroup "Package"
     , packageSingleFile
     , packageEmptyDirectory
     , packageSingleDirectory
+    , packageNested
     , packageMissingFile
     , packageFilesDifferentDirs
+    , packageIncompatibleFiles
     ]
 
 packagePackageFile :: TestTree
@@ -50,17 +52,8 @@ packageCustomPackageFile = testCase "custom package file" $ do
     let path = "./tests/package" </> "custom.dhall"
 
     let package :: Expr Void Import
-        package = RecordLit $ Map.singleton "package" $
-            makeRecordField $ Embed Import
-                { importHashed = ImportHashed
-                    { hash = Nothing
-                    , importType = Local Here File
-                        { directory = Directory []
-                        , file = "package.dhall"
-                        }
-                    }
-                , importMode = Code
-                }
+        package = RecordLit $
+            Map.singleton "package" $ makeRecordField $ Embed packageDhall
 
     (output, expr) <- getPackagePathAndContent (Just "custom.dhall") ("./tests/package/package.dhall" :| [])
     assertEqual "path" path output
@@ -71,17 +64,8 @@ packageSingleFile = testCase "single file" $ do
     let path = "./tests/package/dir" </> "package.dhall"
 
     let package :: Expr Void Import
-        package = RecordLit $ Map.singleton "test" $
-            makeRecordField $ Embed Import
-                { importHashed = ImportHashed
-                    { hash = Nothing
-                    , importType = Local Here File
-                        { directory = Directory []
-                        , file = "test.dhall"
-                        }
-                    }
-                , importMode = Code
-                }
+        package = RecordLit $
+            Map.singleton "test" $ makeRecordField $ Embed testDhall
 
     (output, expr) <- getPackagePathAndContent Nothing ("./tests/package/dir/test.dhall" :| [])
     assertEqual "path" path output
@@ -104,21 +88,34 @@ packageSingleDirectory = testCase "single directory" $ do
 
     let package :: Expr Void Import
         package = RecordLit $ Map.singleton "test" $
-            makeRecordField $ Embed Import
-                { importHashed = ImportHashed
-                    { hash = Nothing
-                    , importType = Local Here File
-                        { directory = Directory []
-                        , file = "test.dhall"
-                        }
-                    }
-                , importMode = Code
-                }
+            makeRecordField $ Embed testDhall
 
     (output, expr) <- getPackagePathAndContent Nothing ("./tests/package/dir" :| [])
     assertEqual "path" path output
     assertEqual "content" package expr
 
+packageNested :: TestTree
+packageNested = testCase "nested files" $ do
+    let path = "./tests/package" </> "package.dhall"
+
+    let package :: Expr Void Import
+        package = RecordLit $ Map.fromList
+            [ ("dir", makeRecordField $ RecordLit $ Map.fromList
+                [ ("test", makeRecordField $ Embed dirTestDhall)
+                ]
+              )
+            , ("other", makeRecordField $ Embed otherPackageDhall)
+            , ("test", makeRecordField $ Embed testDhall)
+            ]
+
+    (output, expr) <- getPackagePathAndContent Nothing
+        ( "./tests/package/test.dhall" :|
+        [ "./tests/package/dir/test.dhall"
+        , "./tests/package/other/package.dhall"
+        ])
+    assertEqual "path" path output
+    assertEqual "content" package expr
+
 packageMissingFile :: TestTree
 packageMissingFile = testCase "missing file" $ do
     let action :: IO (FilePath, Expr Void Import)
@@ -131,12 +128,81 @@ packageMissingFile = testCase "missing file" $ do
 packageFilesDifferentDirs :: TestTree
 packageFilesDifferentDirs = testCase "files from different directories" $ do
     let action :: IO (FilePath, Expr Void Import)
-        action = getPackagePathAndContent Nothing ("./tests/package/test.dhall" :| ["./tests/package/dir/test.dhall"])
+        action = getPackagePathAndContent Nothing ("./tests/package/dir/test.dhall" :| ["./tests/package/test/test.dhall"])
 
     assertThrow action $ \case
-        AmbiguousOutputDirectory "./tests/package" "./tests/package/dir" -> True
+        AmbiguousOutputDirectory "./tests/package/dir" "./tests/package/test" -> True
         _ -> False
 
+packageIncompatibleFiles :: TestTree
+packageIncompatibleFiles = testCase "files that are incompatible" $ do
+    let action :: IO (FilePath, Expr Void Import)
+        action = getPackagePathAndContent Nothing ("./tests/package/test.dhall" :| ["./tests/package/test/test.dhall"])
+
+    assertThrow action $ \case
+        IncompatiblePaths xs -> xs == [ testDhall , testTestDhall ]
+        _ -> False
+
+packageDhall :: Import
+packageDhall = Import
+    { importHashed = ImportHashed
+        { hash = Nothing
+        , importType = Local Here File
+            { directory = Directory []
+            , file = "package.dhall"
+            }
+        }
+    , importMode = Code
+    }
+
+testDhall :: Import
+testDhall = Import
+    { importHashed = ImportHashed
+        { hash = Nothing
+        , importType = Local Here File
+            { directory = Directory []
+            , file = "test.dhall"
+            }
+        }
+    , importMode = Code
+    }
+
+dirTestDhall :: Import
+dirTestDhall = Import
+    { importHashed = ImportHashed
+        { hash = Nothing
+        , importType = Local Here $ File
+            { directory = Directory {components = ["dir"]}
+            , file = "test.dhall"
+            }
+        }
+    , importMode = Code
+    }
+
+otherPackageDhall :: Import
+otherPackageDhall = Import
+    { importHashed = ImportHashed
+        { hash = Nothing
+        , importType = Local Here $ File
+            { directory = Directory {components = ["other"]}
+            , file = "package.dhall"
+            }
+        }
+    , importMode = Code
+    }
+
+testTestDhall :: Import
+testTestDhall = Import
+    { importHashed = ImportHashed
+        { hash = Nothing
+        , importType = Local Here (File
+            { directory = Directory {components = ["test"]}
+            , file = "test.dhall"
+            })
+        }
+    , importMode = Code
+    }
+
 assertThrow :: (Exception e, Show a) => IO a -> (e -> Bool) -> IO ()
 assertThrow k p = do
     result <- try k