cabal-install/tests/UnitTests/Distribution/Client/Glob.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3
   4 module UnitTests.Distribution.Client.Glob (tests) where
   5
   6 import Distribution.Client.Compat.Prelude hiding (last)
   7 import Prelude ()
   8
   9 import Distribution.Client.Glob
  10 import Distribution.Utils.Structured (structureHash)
  11 import UnitTests.Distribution.Client.ArbitraryInstances ()
  12
  13 import GHC.Fingerprint (Fingerprint (..))
  14 import Test.Tasty
  15 import Test.Tasty.HUnit
  16 import Test.Tasty.QuickCheck
  17
  18 tests :: [TestTree]
  19 tests =
  20   [ testProperty "print/parse roundtrip" prop_roundtrip_printparse
  21   , testCase "parse examples" testParseCases
  22   , testGroup
  23       "Structured hashes"
  24       [ testCase "GlobPiece" $ structureHash (Proxy :: Proxy GlobPiece) @?= Fingerprint 0xd5e5361866a30ea2 0x31fbfe7b58864782
  25       , testCase "Glob" $ structureHash (Proxy :: Proxy Glob) @?= Fingerprint 0x3a5af41e8194eaa3 0xd8e461fdfdb0e07b
  26       , testCase "FilePathRoot" $ structureHash (Proxy :: Proxy FilePathRoot) @?= Fingerprint 0x713373d51426ec64 0xda7376a38ecee5a5
  27       , testCase "RootedGlob" $ structureHash (Proxy :: Proxy RootedGlob) @?= Fingerprint 0x0031d198379cd1bf 0x7246ab9b6c6e0e7d
  28       ]
  29   ]
  30
  31 -- TODO: [nice to have] tests for trivial globs, tests for matching,
  32 -- tests for windows style file paths
  33
  34 prop_roundtrip_printparse :: RootedGlob -> Property
  35 prop_roundtrip_printparse pathglob =
  36   counterexample (prettyShow pathglob) $
  37     eitherParsec (prettyShow pathglob) === Right pathglob
  38
  39 -- first run, where we don't even call updateMonitor
  40 testParseCases :: Assertion
  41 testParseCases = do
  42   RootedGlob (FilePathRoot "/") GlobDirTrailing <- testparse "/"
  43   RootedGlob FilePathHomeDir GlobDirTrailing <- testparse "~/"
  44
  45   RootedGlob (FilePathRoot "A:\\") GlobDirTrailing <- testparse "A:/"
  46   RootedGlob (FilePathRoot "Z:\\") GlobDirTrailing <- testparse "z:/"
  47   RootedGlob (FilePathRoot "C:\\") GlobDirTrailing <- testparse "C:\\"
  48   RootedGlob FilePathRelative (GlobFile [Literal "_:"]) <- testparse "_:"
  49
  50   RootedGlob
  51     FilePathRelative
  52     (GlobFile [Literal "."]) <-
  53     testparse "."
  54
  55   RootedGlob
  56     FilePathRelative
  57     (GlobFile [Literal "~"]) <-
  58     testparse "~"
  59
  60   RootedGlob
  61     FilePathRelative
  62     (GlobDir [Literal "."] GlobDirTrailing) <-
  63     testparse "./"
  64
  65   RootedGlob
  66     FilePathRelative
  67     (GlobFile [Literal "foo"]) <-
  68     testparse "foo"
  69
  70   RootedGlob
  71     FilePathRelative
  72     ( GlobDir
  73         [Literal "foo"]
  74         (GlobFile [Literal "bar"])
  75       ) <-
  76     testparse "foo/bar"
  77
  78   RootedGlob
  79     FilePathRelative
  80     ( GlobDir
  81         [Literal "foo"]
  82         (GlobDir [Literal "bar"] GlobDirTrailing)
  83       ) <-
  84     testparse "foo/bar/"
  85
  86   RootedGlob
  87     (FilePathRoot "/")
  88     ( GlobDir
  89         [Literal "foo"]
  90         (GlobDir [Literal "bar"] GlobDirTrailing)
  91       ) <-
  92     testparse "/foo/bar/"
  93
  94   RootedGlob
  95     (FilePathRoot "C:\\")
  96     ( GlobDir
  97         [Literal "foo"]
  98         (GlobDir [Literal "bar"] GlobDirTrailing)
  99       ) <-
 100     testparse "C:\\foo\\bar\\"
 101
 102   RootedGlob
 103     FilePathRelative
 104     (GlobFile [WildCard]) <-
 105     testparse "*"
 106
 107   RootedGlob
 108     FilePathRelative
 109     (GlobFile [WildCard, WildCard]) <-
 110     testparse "**" -- not helpful but valid
 111   RootedGlob
 112     FilePathRelative
 113     (GlobFile [WildCard, Literal "foo", WildCard]) <-
 114     testparse "*foo*"
 115
 116   RootedGlob
 117     FilePathRelative
 118     (GlobFile [Literal "foo", WildCard, Literal "bar"]) <-
 119     testparse "foo*bar"
 120
 121   RootedGlob
 122     FilePathRelative
 123     (GlobFile [Union [[WildCard], [Literal "foo"]]]) <-
 124     testparse "{*,foo}"
 125
 126   parseFail "{"
 127   parseFail "}"
 128   parseFail ","
 129   parseFail "{"
 130   parseFail "{{}"
 131   parseFail "{}"
 132   parseFail "{,}"
 133   parseFail "{foo,}"
 134   parseFail "{,foo}"
 135
 136   return ()
 137
 138 testparse :: String -> IO RootedGlob
 139 testparse s =
 140   case eitherParsec s of
 141     Right p -> return p
 142     Left err -> throwIO $ HUnitFailure Nothing ("expected parse of: " ++ s ++ " -- " ++ err)
 143
 144 parseFail :: String -> Assertion
 145 parseFail s =
 146   case eitherParsec s :: Either String RootedGlob of
 147     Right p -> throwIO $ HUnitFailure Nothing ("expected no parse of: " ++ s ++ " -- " ++ show p)
 148     Left _ -> return ()