to-directory-tree: Create parents of files when using fixpoint directory tree representation (#2653)

* to-directory-tree: Fixed --allow-path-separators for fixpointed files

Before, when one uses `to-directory-tree --allow-path-separators` to
create a file using the fixpoint representation of a filesystem tree,
then that failed if a path with path separators was passed to the `file`
or `binary-file` constructors. The reason was that we did not create the
parent directories, which is intended by the use of
--allow-path-separators.

This commit fixes that.

* Added tests

* Remove generated package.dhall after test for recursive package generation

Author: mmhat

dhall/src/Dhall/DirectoryTree.hs

@@ -296,10 +296,16 @@ processFilesystemEntry allowSeparators path (DirectoryEntry entry) =
     processEntryWith path entry $ \path' content -> do
         Directory.createDirectoryIfMissing allowSeparators path'
         processFilesystemEntryList allowSeparators path' content
-processFilesystemEntry _ path (BinaryFileEntry entry) =
-    processEntryWith path entry ByteString.writeFile
-processFilesystemEntry _ path (TextFileEntry entry) =
-    processEntryWith path entry  Text.IO.writeFile
+processFilesystemEntry allowSeparators path (BinaryFileEntry entry) =
+    processEntryWith path entry $ \path' content -> do
+        when allowSeparators $ do
+            Directory.createDirectoryIfMissing True (FilePath.takeDirectory path')
+        ByteString.writeFile path' content
+processFilesystemEntry allowSeparators path (TextFileEntry entry) =
+    processEntryWith path entry $ \path' content -> do
+        when allowSeparators $ do
+            Directory.createDirectoryIfMissing True (FilePath.takeDirectory path')
+        Text.IO.writeFile path' content
 
 -- | A helper function used by 'processFilesystemEntry'.
 processEntryWith

dhall/tests/Dhall/Test/DirectoryTree.hs

@@ -13,6 +13,7 @@ import System.FilePath        ((</>))
 import Test.Tasty
 import Test.Tasty.HUnit
 
+import qualified Data.List
 import qualified Data.Text.IO
 import qualified Dhall
 import qualified Dhall.Core
@@ -26,6 +27,7 @@ tests = testGroup "to-directory-tree"
         [ fixpointedType
         , fixpointedEmpty
         , fixpointedSimple
+        , fixpointedAllowPathSeparators
 #ifndef mingw32_HOST_OS
         , fixpointedPermissions
         , fixpointedUserGroup
@@ -54,12 +56,25 @@ fixpointedSimple = testCase "simple" $ do
     let outDir = "./tests/to-directory-tree/fixpoint-simple.out"
         path = "./tests/to-directory-tree/fixpoint-simple.dhall"
     entries <- runDirectoryTree False outDir path
-    entries @?=
+    entries @?= Data.List.sort
         [ Directory outDir
         , File $ outDir </> "file"
         , Directory $ outDir </> "directory"
         ]
 
+fixpointedAllowPathSeparators :: TestTree
+fixpointedAllowPathSeparators = testCase "allow-path-separators" $ do
+    let outDir = "./tests/to-directory-tree/fixpoint-allow-path-separators.out"
+        path = "./tests/to-directory-tree/fixpoint-allow-path-separators.dhall"
+    entries <- runDirectoryTree True outDir path
+    entries @?= Data.List.sort
+        [ Directory outDir
+        , Directory $ outDir </> "non-existent-1"
+        , File $ outDir </> "non-existent-1" </> "file"
+        , Directory $ outDir </> "non-existent-2"
+        , Directory $ outDir </> "non-existent-2" </> "directory"
+        ]
+
 {-
 This test is disabled on Windows as it fails due to limitations of the :
     expected: 448
@@ -116,12 +131,12 @@ runDirectoryTree allowSeparators outDir path = do
 
     toDirectoryTree allowSeparators outDir $ Dhall.Core.denote expr
 
-    walkFsTree outDir
+    Data.List.sort <$> walkFsTree outDir
 
 data WalkEntry
     = Directory FilePath
     | File FilePath
-    deriving (Eq, Show)
+    deriving (Eq, Ord, Show)
 
 walkFsTree :: FilePath -> IO [WalkEntry]
 walkFsTree dir = do

dhall/tests/Dhall/Test/Package.hs

@@ -3,7 +3,7 @@
 
 module Dhall.Test.Package where
 
-import           Control.Exception  (Exception, displayException, try)
+import           Control.Exception  (Exception, displayException, finally, try)
 import           Data.List.NonEmpty (NonEmpty (..))
 import           Data.Void          (Void)
 import           Dhall.Core
@@ -20,6 +20,7 @@ import           Dhall.Core
 import qualified Dhall.Map          as Map
 import           Dhall.Package
 import           Lens.Micro         (set)
+import qualified System.Directory   as Directory
 import           System.FilePath    ((</>))
 import           Test.Tasty
 import           Test.Tasty.HUnit
@@ -122,7 +123,7 @@ packageNested = testCase "nested files" $ do
     assertEqual "content" package expr
 
 packageRecursive :: TestTree
-packageRecursive = testCase "recursively create subpackages" $ do
+packageRecursive = testCase "recursively create subpackages" $ removePackagesAfter $ do
     let path = "./tests/package/dir" </> "package.dhall"
 
     let package :: Expr Void Import
@@ -139,6 +140,11 @@ packageRecursive = testCase "recursively create subpackages" $ do
         ( "./tests/package/dir" :| [] )
     assertEqual "path" path output
     assertEqual "content" package expr
+    where
+        removePackagesAfter :: IO a -> IO a
+        removePackagesAfter action = action `finally` do
+            Directory.removePathForcibly "./tests/package/dir/subdirectory1/package.dhall"
+            Directory.removePathForcibly "./tests/package/dir/subdirectory2/package.dhall"
 
 packageMissingFile :: TestTree
 packageMissingFile = testCase "missing file" $ do

dhall/tests/to-directory-tree/fixpoint-allow-path-separators.dhall

@@ -0,0 +1,25 @@
+let User = (./fixpoint-helper.dhall).User
+
+let Group = (./fixpoint-helper.dhall).Group
+
+let Mode = (./fixpoint-helper.dhall).Mode
+
+let Make = (./fixpoint-helper.dhall).Make
+
+in  \(r : Type) ->
+    \(make : Make r) ->
+      [ make.file
+          { name = "non-existent-1/file"
+          , content = ""
+          , user = None User
+          , group = None Group
+          , mode = None Mode
+          }
+      , make.directory
+          { name = "non-existent-2/directory"
+          , content = [] : List r
+          , user = None User
+          , group = None Group
+          , mode = None Mode
+          }
+      ]