From 26d31c3c169b634923ddce6ca6be62eb8c6f609c Mon Sep 17 00:00:00 2001
From: Joris Dral <joris@well-typed.com>
Date: Thu, 6 Jun 2024 16:16:06 +0200
Subject: [PATCH] Only generate valid names for FsPath tests

---
 fs-api/src/System/FS/API/Types.hs        | 11 +++++++++++
 fs-api/test/Test/System/FS/API/FsPath.hs | 14 +++++++++++---
 2 files changed, 22 insertions(+), 3 deletions(-)

diff --git a/fs-api/src/System/FS/API/Types.hs b/fs-api/src/System/FS/API/Types.hs
index 0863271..8798f01 100644
--- a/fs-api/src/System/FS/API/Types.hs
+++ b/fs-api/src/System/FS/API/Types.hs
@@ -101,6 +101,17 @@ allowExisting openMode = case openMode of
 -------------------------------------------------------------------------------}
 
 -- | A relative path.
+--
+-- === Invariant
+--
+-- The user of this library is tasked with picking sensible names of
+-- directories/files on a path, such that the resulting 'FsPath' remains
+-- relative to the HasFS instance root. For example, an @'FsPath' ["/"]@ would
+-- try to access the root folder, which is most likely outside of the scope of
+-- the HasFS instance. Amongst others, the following should hold:
+-- * Names are non-empty
+-- * Names are monotonic, i.e., they are not equal to @..@
+-- * Names should not contain path separators or drive letters
 newtype FsPath = UnsafeFsPath { fsPathToList :: [Strict.Text] }
   deriving (Eq, Ord, Generic)
   deriving newtype NFData
diff --git a/fs-api/test/Test/System/FS/API/FsPath.hs b/fs-api/test/Test/System/FS/API/FsPath.hs
index 6e02244..b1e3eb3 100644
--- a/fs-api/test/Test/System/FS/API/FsPath.hs
+++ b/fs-api/test/Test/System/FS/API/FsPath.hs
@@ -19,8 +19,16 @@ tests = testGroup "Test.System.FS.API.FsPath" [
 
 -- | Orphan instance that generates a __non-empty__ text!
 instance Arbitrary Text where
-  arbitrary = Text.pack <$> (arbitrary `suchThat` (not . null))
-  shrink x = [Text.pack x'' | let x' = Text.unpack x, x'' <- shrink x']
+  arbitrary = Text.pack <$> QC.listOf (QC.elements validChars) `suchThat` (not . null)
+  shrink x = [ x''' | let x' = Text.unpack x
+                    , x'' <- shrink x'
+                    , not (null x'')
+                    , let x''' = Text.pack x'' ]
+
+-- | We pick a small subset of characters to use in directory/file names, so
+-- that we don't break the invariant of 'FsPath'.
+validChars :: [Char]
+validChars = concat [['a'..'z'], ['A'..'Z'], ['0'..'9']]
 
 -- | Commutativity property for 'FS.</>' and 'FilePath.</>'.
 --
@@ -65,7 +73,7 @@ prop_addExtensionCommutes mnt path ext =
     .&&. FilePath.makeValid lhs === FilePath.makeValid rhs
   where
     mnt' = filePathFromList mnt
-    mnt'' = FS.MountPoint (filePathFromList mnt)
+    mnt'' = FS.MountPoint mnt'
     fsp = FS.fsPathFromList path FS.<.> ext
     lhs = FS.fsToFilePath mnt'' fsp
     rhs = mnt' FilePath.</> filePathFromList path FilePath.<.> ext