Improve equivalence tests

Better generator distribution.

Author: hasufell

filepath.cabal

@@ -133,6 +133,7 @@ test-suite filepath-equivalent-tests
     Legacy.System.FilePath.Posix
     Legacy.System.FilePath.Windows
     TestUtil
+    Gen
 
   build-depends:
     , base

tests/filepath-equivalent-tests/Gen.hs

@@ -0,0 +1,200 @@
+{-# LANGUAGE OverlappingInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingVia, TypeOperators #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DataKinds #-}
+
+module Gen where
+
+import System.FilePath
+import Data.List.NonEmpty (NonEmpty(..))
+import GHC.Generics
+import Generic.Random
+import Generics.Deriving.Show
+import Prelude as P
+import Test.Tasty.QuickCheck hiding ((==>))
+
+import qualified Data.List.NonEmpty as NE
+
+
+class AltShow a where
+  altShow :: a -> String
+
+instance {-# OVERLAPPABLE #-} Show a => AltShow a where
+  altShow = show
+
+instance {-# OVERLAPS #-} AltShow String where
+  altShow = id
+
+instance {-# OVERLAPPABLE #-} AltShow a => AltShow (Maybe a) where
+  altShow Nothing = ""
+  altShow (Just a) = altShow a
+
+
+newtype WindowsFilePaths = WindowsFilePaths { unWindowsFilePaths :: [WindowsFilePath] }
+  deriving (Show, Eq, Ord, Generic)
+
+-- filepath = namespace *"\" namespace-tail
+--          / UNC
+--          / [ disk ] *"\" relative-path
+--          / disk *"\"
+data WindowsFilePath = NS NameSpace [Separator] NSTail
+                     | UNC UNCShare
+                     | N (Maybe Char) [Separator] (Maybe RelFilePath)
+                     -- ^ This differs from the grammar, because we allow
+                     -- empty paths
+                     | PotentiallyInvalid FilePath
+                     -- ^ this branch is added purely for the tests
+  deriving (GShow, Eq, Ord, Generic)
+  deriving Arbitrary via (GenericArbitraryRec '[6, 2, 2, 1] `AndShrinking` WindowsFilePath)
+
+instance Show WindowsFilePath where
+  show wf = gshow wf ++ " (" ++ altShow wf ++ ")"
+
+instance AltShow WindowsFilePath where
+  altShow (NS ns seps nstail) = altShow ns ++ altShow seps ++ altShow nstail
+  altShow (UNC unc) = altShow unc
+  altShow (N mdisk seps mfrp) = maybe [] (:[]) mdisk ++ (altShow seps ++ altShow mfrp)
+  altShow (PotentiallyInvalid fp) = fp
+
+
+-- namespace-tail     = ( disk 1*"\" relative-path ; C:foo\bar is not valid
+--                                                 ; namespaced paths are all absolute
+--                      / disk *"\"
+--                      / relative-path
+--                      )
+data NSTail = NST1 Char (NonEmpty Separator) RelFilePath
+            | NST2 Char [Separator]
+            | NST3 RelFilePath
+  deriving (GShow, Show, Eq, Ord, Generic)
+  deriving Arbitrary via (GenericArbitraryRec '[1, 1, 1] `AndShrinking` NSTail)
+
+instance AltShow NSTail where
+  altShow (NST1 disk seps relfp) = disk:':':(altShow seps ++ altShow relfp)
+  altShow (NST2 disk seps) = disk:':':altShow seps
+  altShow (NST3 relfp) = altShow relfp
+
+
+--  UNC = "\\" 1*pchar "\" 1*pchar  [ 1*"\" [ relative-path ] ]
+data UNCShare = UNCShare Separator Separator
+                         NonEmptyString
+                         (NonEmpty Separator)
+                         NonEmptyString
+                         (Maybe (NonEmpty Separator, Maybe RelFilePath))
+  deriving (GShow, Show, Eq, Ord, Generic)
+  deriving Arbitrary via (GenericArbitraryRec '[1] `AndShrinking` UNCShare)
+
+instance AltShow UNCShare where
+  altShow (UNCShare sep1 sep2 fp1 seps fp2 mrfp) = altShow sep1 ++ altShow sep2 ++ altShow fp1 ++ altShow seps ++ altShow fp2 ++ maybe "" (\(a, b) -> altShow a ++ maybe "" altShow b) mrfp
+
+newtype NonEmptyString = NonEmptyString (NonEmpty Char)
+  deriving (GShow, Show, Eq, Ord, Generic)
+  deriving Arbitrary via (GenericArbitraryRec '[1] `AndShrinking` NonEmptyString)
+
+instance Semigroup NonEmptyString where
+  (<>) (NonEmptyString ne) (NonEmptyString ne') = NonEmptyString (ne <> ne')
+
+instance AltShow NonEmptyString where
+  altShow (NonEmptyString ns) = NE.toList ns
+
+
+-- | Windows API Namespaces
+--
+-- https://docs.microsoft.com/en-us/windows/win32/fileio/naming-a-file#namespaces
+-- https://support.microsoft.com/en-us/topic/70b92942-a643-2f2d-2ac6-aad8acad49fb
+-- https://superuser.com/a/1096784/854039
+-- https://reverseengineering.stackexchange.com/a/15178
+-- https://stackoverflow.com/a/25099634
+--
+-- namespace          = file-namespace / device-namespace / nt-namespace
+-- file-namespace     = "\" "\" "?" "\"
+-- device-namespace   = "\" "\" "." "\"
+-- nt-namespace       = "\" "?" "?" "\"
+data NameSpace = FileNameSpace
+               | DeviceNameSpace
+               | NTNameSpace
+  deriving (GShow, Show, Eq, Ord, Generic)
+  deriving Arbitrary via (GenericArbitraryRec '[3, 1, 1] `AndShrinking` NameSpace)
+
+instance AltShow NameSpace where
+  altShow FileNameSpace = "\\\\?\\"
+  altShow DeviceNameSpace = "\\\\.\\"
+  altShow NTNameSpace = "\\??\\"
+
+
+data Separator = UnixSep
+               | WindowsSep
+  deriving (GShow, Show, Eq, Ord, Generic)
+  deriving Arbitrary via (GenericArbitraryRec '[1, 1] `AndShrinking` Separator)
+
+instance AltShow Separator where
+  altShow UnixSep = "/"
+  altShow WindowsSep = "\\"
+
+instance {-# OVERLAPS #-} AltShow (NonEmpty Separator) where
+  altShow ne = mconcat $ NE.toList (altShow <$> ne)
+
+instance {-# OVERLAPS #-} AltShow [Separator] where
+  altShow [] = ""
+  altShow ne = altShow (NE.fromList ne)
+
+--  relative-path = 1*(path-name 1*"\") [ file-name ] / file-name
+data RelFilePath = Rel1 (NonEmpty (NonEmptyString, NonEmpty Separator)) (Maybe FileName)
+                 | Rel2 FileName
+  deriving (GShow, Show, Eq, Ord, Generic)
+  deriving Arbitrary via (GenericArbitraryRec '[2, 1] `AndShrinking` RelFilePath)
+
+instance AltShow RelFilePath where
+  altShow (Rel1 ns mf) = (mconcat $ NE.toList $ fmap (\(a, b) -> altShow a ++ altShow b) ns) ++ altShow mf
+  altShow (Rel2 fn) = altShow fn
+
+--  file-name = 1*pchar [ stream ]
+data FileName = FileName NonEmptyString (Maybe DataStream)
+  deriving (GShow, Show, Eq, Ord, Generic)
+
+instance Arbitrary FileName where
+  arbitrary = do
+    ns <- arbitrary
+    ds <- arbitrary
+    i <- chooseInt (0, 100)
+    if i >= 50
+    then do
+           ns' <- arbitrary
+           pure $ FileName (ns <> NonEmptyString ('.':|[]) <> ns') ds
+    else pure $ FileName ns ds
+  shrink = genericShrink
+
+
+instance Arbitrary (Maybe DataStream) where
+  arbitrary = genericArbitraryRec (1 % 1 % ())
+  shrink = genericShrink
+
+instance AltShow FileName where
+  altShow (FileName ns ds) = altShow ns ++ altShow ds
+
+--  stream = ":" 1*schar [ ":" 1*schar ] / ":" ":" 1*schar
+data DataStream = DS1 NonEmptyString (Maybe NonEmptyString)
+                | DS2 NonEmptyString -- ::datatype
+  deriving (GShow, Show, Eq, Ord, Generic)
+  deriving Arbitrary via (GenericArbitraryRec '[1, 1] `AndShrinking` DataStream)
+
+instance AltShow DataStream where
+  altShow (DS1 ns Nothing) = ":" ++ altShow ns
+  altShow (DS1 ns (Just ns2)) = ":" ++ altShow ns ++ ":" ++ altShow ns2
+  altShow (DS2 ns) = "::" ++ altShow ns
+
+instance Arbitrary WindowsFilePaths where
+  arbitrary = WindowsFilePaths <$> listOf' arbitrary
+  shrink = genericShrink
+
+instance Arbitrary [Separator] where
+  arbitrary = listOf' arbitrary
+  shrink = genericShrink
+
+instance Arbitrary a => Arbitrary (NonEmpty a) where
+  arbitrary = NE.fromList <$> listOf1' arbitrary
+  shrink = genericShrink
+