Added more to-directory-tree tests

Author: mmhat

dhall/src/Dhall/DirectoryTree.hs

@@ -12,7 +12,9 @@ module Dhall.DirectoryTree
       toDirectoryTree
     , FilesystemError(..)
 
-      -- * Exported for testing only
+      -- * Low-level types and functions
+    , module Dhall.DirectoryTree.Types
+    , decodeDirectoryTree
     , directoryTreeType
     ) where
 
@@ -170,7 +172,7 @@ toDirectoryTree
     -> FilePath
     -> Expr Void Void
     -> IO ()
-toDirectoryTree allowSeparators path expression = case Core.alphaNormalize expression of
+toDirectoryTree allowSeparators path expression = case expression of
     RecordLit keyValues ->
         Map.unorderedTraverseWithKey_ process $ recordFieldValue <$> keyValues
 
@@ -197,24 +199,10 @@ toDirectoryTree allowSeparators path expression = case Core.alphaNormalize expre
     -- If this pattern matches we assume the user wants to use the fixpoint
     -- approach, hence we typecheck it and output error messages like we would
     -- do for every other Dhall program.
-    Lam _ _ (Lam _ _ body) -> do
-        let body' = Core.renote body
-        let expression' = Core.renote expression
-
-        expected' <- case directoryTreeType of
-            Success x -> return x
-            Failure e -> Exception.throwIO e
-
-        _ <- Core.throws $ TypeCheck.typeOf $ Annot expression' expected'
-
-        entries <- case Decode.extract decoder body' of
-            Success x -> return x
-            Failure e -> Exception.throwIO e
+    Lam _ _ (Lam _ _ _) -> do
+        entries <- decodeDirectoryTree expression
 
         processFilesystemEntryList allowSeparators path entries
-            where
-                decoder :: Decoder (Seq FilesystemEntry)
-                decoder = Decode.auto
 
     _ ->
         die
@@ -241,6 +229,23 @@ toDirectoryTree allowSeparators path expression = case Core.alphaNormalize expre
       where
         unexpectedExpression = expression
 
+-- | Decode a fixpoint directory tree from a Dhall expression.
+decodeDirectoryTree :: Expr s Void -> IO (Seq FilesystemEntry)
+decodeDirectoryTree (Core.alphaNormalize . Core.denote -> expression@(Lam _ _ (Lam _ _ body))) = do
+    expected' <- case directoryTreeType of
+        Success x -> return x
+        Failure e -> Exception.throwIO e
+
+    _ <- Core.throws $ TypeCheck.typeOf $ Annot expression expected'
+
+    case Decode.extract decoder body of
+        Success x -> return x
+        Failure e -> Exception.throwIO e
+    where
+        decoder :: Decoder (Seq FilesystemEntry)
+        decoder = Decode.auto
+decodeDirectoryTree expr = Exception.throwIO $ FilesystemError $ Core.denote expr
+
 -- | The type of a fixpoint directory tree expression.
 directoryTreeType :: Expector (Expr Src Void)
 directoryTreeType = Pi Nothing "tree" (Const Type)

dhall/src/Dhall/DirectoryTree/Types.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP                #-}
+{-# LANGUAGE DeriveAnyClass     #-}
 {-# LANGUAGE DeriveGeneric      #-}
 {-# LANGUAGE FlexibleInstances  #-}
 {-# LANGUAGE LambdaCase         #-}
@@ -12,9 +13,9 @@
 
 -- | Types used by the implementation of the @to-directory-tree@ subcommand
 module Dhall.DirectoryTree.Types
-    ( DirectoryEntry
+    ( FilesystemEntry(..)
+    , DirectoryEntry
     , FileEntry
-    , FilesystemEntry(..)
     , Entry(..)
     , User(..)
     , Group(..)
@@ -61,7 +62,7 @@ type FileEntry = Entry Text
 data FilesystemEntry
     = DirectoryEntry (Entry (Seq FilesystemEntry))
     | FileEntry (Entry Text)
-    deriving Show
+    deriving (Eq, Generic, Ord, Show)
 
 instance FromDhall FilesystemEntry where
     autoWith normalizer = Decoder
@@ -83,7 +84,7 @@ data Entry a = Entry
     , entryGroup :: Maybe Group
     , entryMode :: Maybe (Mode Maybe)
     }
-    deriving (Generic, Show)
+    deriving (Eq, Generic, Ord, Show)
 
 instance FromDhall a => FromDhall (Entry a) where
     autoWith = Decode.genericAutoWithInputNormalizer Decode.defaultInterpretOptions
@@ -94,7 +95,7 @@ instance FromDhall a => FromDhall (Entry a) where
 data User
     = UserId UserID
     | UserName String
-    deriving (Generic, Show)
+    deriving (Eq, Generic, Ord, Show)
 
 instance FromDhall User
 
@@ -110,7 +111,7 @@ instance FromDhall Posix.CUid where
 data Group
     = GroupId GroupID
     | GroupName String
-    deriving (Generic, Show)
+    deriving (Eq, Generic, Ord, Show)
 
 instance FromDhall Group
 
@@ -137,6 +138,8 @@ data Mode f = Mode
 
 deriving instance Eq (Mode Identity)
 deriving instance Eq (Mode Maybe)
+deriving instance Ord (Mode Identity)
+deriving instance Ord (Mode Maybe)
 deriving instance Show (Mode Identity)
 deriving instance Show (Mode Maybe)
 
@@ -161,6 +164,8 @@ data Access f = Access
 
 deriving instance Eq (Access Identity)
 deriving instance Eq (Access Maybe)
+deriving instance Ord (Access Identity)
+deriving instance Ord (Access Maybe)
 deriving instance Show (Access Identity)
 deriving instance Show (Access Maybe)
 

dhall/tests/Dhall/Test/DirectoryTree.hs

@@ -1,8 +1,12 @@
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+
 module Dhall.Test.DirectoryTree (tests) where
 
 import Control.Monad
 import Data.Either (partitionEithers)
 import Data.Either.Validation
+import Dhall.DirectoryTree (Entry(..), Group(..), User(..))
 import Lens.Family (set)
 import System.FilePath ((</>))
 import Test.Tasty
@@ -22,15 +26,15 @@ tests = testGroup "to-directory-tree"
         [ fixpointedType
         , fixpointedEmpty
         , fixpointedSimple
-        , fixpointedMetadata
+        , fixpointedPermissions
+        , fixpointedUserGroup
         ]
     ]
 
 fixpointedType :: TestTree
 fixpointedType = testCase "Type is as expected" $ do
     let file = "./tests/to-directory-tree/type.dhall"
-    text <- Data.Text.IO.readFile file
-    ref <- Dhall.inputExpr text
+    ref <- Dhall.inputExpr file
     expected' <- case Dhall.DirectoryTree.directoryTreeType of
         Failure e -> assertFailure $ show e
         Success expr -> return expr
@@ -54,10 +58,10 @@ fixpointedSimple = testCase "simple" $ do
         , Directory $ outDir </> "directory"
         ]
 
-fixpointedMetadata :: TestTree
-fixpointedMetadata = testCase "metadata" $ do
-    let outDir = "./tests/to-directory-tree/fixpoint-metadata.out"
-        path = "./tests/to-directory-tree/fixpoint-metadata.dhall"
+fixpointedPermissions :: TestTree
+fixpointedPermissions = testCase "permissions" $ do
+    let outDir = "./tests/to-directory-tree/fixpoint-permissions.out"
+        path = "./tests/to-directory-tree/fixpoint-permissions.dhall"
     entries <- runDirectoryTree False outDir path
     entries @?=
         [ Directory outDir
@@ -67,6 +71,28 @@ fixpointedMetadata = testCase "metadata" $ do
     let mode = Files.fileMode s `Files.intersectFileModes` Files.accessModes
     mode @?= Files.ownerModes
 
+fixpointedUserGroup :: TestTree
+fixpointedUserGroup = testCase "user and group" $ do
+    let file = "./tests/to-directory-tree/fixpoint-usergroup.dhall"
+    expr <- Dhall.inputExpr file
+    entries <- Dhall.DirectoryTree.decodeDirectoryTree expr
+    entries @?=
+        [ Dhall.DirectoryTree.FileEntry $ Entry
+            { entryName = "ids"
+            , entryContent = ""
+            , entryUser = Just (UserId 0)
+            , entryGroup = Just (GroupId 0)
+            , entryMode = Nothing
+            }
+        , Dhall.DirectoryTree.FileEntry $ Entry
+            { entryName = "names"
+            , entryContent = ""
+            , entryUser = Just (UserName "user")
+            , entryGroup = Just (GroupName "group")
+            , entryMode = Nothing
+            }
+        ]
+
 runDirectoryTree :: Bool -> FilePath -> FilePath -> IO [FilesystemEntry]
 runDirectoryTree allowSeparators outDir path = do
     doesOutDirExist <- Directory.doesDirectoryExist outDir

dhall/tests/to-directory-tree/fixpoint-metadata.dhall renamed to dhall/tests/to-directory-tree/fixpoint-permissions.dhall

@@ -2,8 +2,6 @@ let User = (./fixpoint-helper.dhall).User
 
 let Group = (./fixpoint-helper.dhall).Group
 
-let Access = (./fixpoint-helper.dhall).Access
-
 let Make = (./fixpoint-helper.dhall).Make
 
 let no-access = { execute = Some False, read = Some False, write = Some False }

dhall/tests/to-directory-tree/fixpoint-usergroup.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 = "ids"
+          , content = ""
+          , user = Some (User.UserId 0)
+          , group = Some (Group.GroupId 0)
+          , mode = None Mode
+          }
+      , make.file
+          { name = "names"
+          , content = ""
+          , user = Some (User.UserName "user")
+          , group = Some (Group.GroupName "group")
+          , mode = None Mode
+          }
+      ]