diff --git a/dhall/src/Dhall/Package.hs b/dhall/src/Dhall/Package.hs index 790ac5d40..41b231bf9 100644 --- a/dhall/src/Dhall/Package.hs +++ b/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 [] = go acc ["."] + 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\ diff --git a/dhall/tests/Dhall/Test/Package.hs b/dhall/tests/Dhall/Test/Package.hs index 3bc014963..403446615 100644 --- a/dhall/tests/Dhall/Test/Package.hs +++ b/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 diff --git a/dhall/tests/package/dir/package.dhall b/dhall/tests/package/dir/package.dhall new file mode 100644 index 000000000..e69de29bb diff --git a/dhall/tests/package/other/package.dhall b/dhall/tests/package/other/package.dhall new file mode 100644 index 000000000..e69de29bb diff --git a/dhall/tests/package/test/test.dhall b/dhall/tests/package/test/test.dhall new file mode 100644 index 000000000..e69de29bb