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

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3
   4 module UnitTests.Distribution.Client.DescribedInstances where
   5
   6 import Distribution.Client.Compat.Prelude
   7
   8 import Data.List ((\\))
   9 import Distribution.Described
  10
  11 import Distribution.Types.PackageId (PackageIdentifier)
  12 import Distribution.Types.PackageName (PackageName)
  13 import Distribution.Types.VersionRange (VersionRange)
  14
  15 import Distribution.Client.BuildReports.Types (InstallOutcome, Outcome)
  16 import Distribution.Client.Glob (RootedGlob)
  17 import Distribution.Client.IndexUtils.ActiveRepos (ActiveRepoEntry, ActiveRepos, CombineStrategy)
  18 import Distribution.Client.IndexUtils.IndexState (RepoIndexState, TotalIndexState)
  19 import Distribution.Client.IndexUtils.Timestamp (Timestamp)
  20 import Distribution.Client.Targets (UserConstraint)
  21 import Distribution.Client.Types (RepoName)
  22 import Distribution.Client.Types.AllowNewer (RelaxDepSubject, RelaxDeps, RelaxedDep)
  23
  24 -------------------------------------------------------------------------------
  25 -- BuildReport
  26 -------------------------------------------------------------------------------
  27
  28 instance Described InstallOutcome where
  29   describe _ =
  30     REUnion
  31       [ "PlanningFailed"
  32       , "DependencyFailed" <> RESpaces1 <> describe (Proxy :: Proxy PackageIdentifier)
  33       , "DownloadFailed"
  34       , "UnpackFailed"
  35       , "SetupFailed"
  36       , "ConfigureFailed"
  37       , "BuildFailed"
  38       , "TestsFailed"
  39       , "InstallFailed"
  40       , "InstallOk"
  41       ]
  42 instance Described Outcome where
  43   describe _ =
  44     REUnion
  45       [ fromString (prettyShow o)
  46       | o <- [minBound .. maxBound :: Outcome]
  47       ]
  48
  49 -------------------------------------------------------------------------------
  50 -- Glob
  51 -------------------------------------------------------------------------------
  52
  53 -- This instance is incorrect as it may generate C:\dir\{foo,bar}
  54 instance Described RootedGlob where
  55   describe _ = REUnion [root, relative, homedir]
  56     where
  57       root =
  58         REUnion
  59           [ fromString "/"
  60           , reChars (['a' .. 'z'] ++ ['A' .. 'Z']) <> ":" <> reChars "/\\"
  61           ]
  62           <> REOpt pieces
  63       homedir = "~/" <> REOpt pieces
  64       relative = pieces
  65
  66       pieces :: GrammarRegex void
  67       pieces = REMunch1 sep piece <> REOpt "/"
  68
  69       piece :: GrammarRegex void
  70       piece =
  71         RERec "glob" $
  72           REMunch1 mempty $
  73             REUnion
  74               [ normal
  75               , escape
  76               , wildcard
  77               , "{" <> REMunch1 "," (REVar Nothing) <> "}"
  78               ]
  79
  80       sep :: GrammarRegex void
  81       sep = reChars "/\\"
  82
  83       wildcard :: GrammarRegex void
  84       wildcard = "*"
  85
  86       normal = reChars $ ['\0' .. '\128'] \\ "*{},/\\"
  87       escape = fromString "\\" <> reChars "*{},"
  88
  89 -------------------------------------------------------------------------------
  90 -- AllowNewer
  91 -------------------------------------------------------------------------------
  92
  93 instance Described RelaxedDep where
  94   describe _ =
  95     REOpt (describeRelaxDepScope <> ":" <> REOpt ("^"))
  96       <> describe (Proxy :: Proxy RelaxDepSubject)
  97     where
  98       describeRelaxDepScope =
  99         REUnion
 100           [ "*"
 101           , "all"
 102           , RENamed "package-name" (describe (Proxy :: Proxy PackageName))
 103           , RENamed "package-id" (describe (Proxy :: Proxy PackageIdentifier))
 104           ]
 105
 106 instance Described RelaxDepSubject where
 107   describe _ =
 108     REUnion
 109       [ "*"
 110       , "all"
 111       , RENamed "package-name" (describe (Proxy :: Proxy PackageName))
 112       ]
 113
 114 instance Described RelaxDeps where
 115   describe _ =
 116     REUnion
 117       [ "*"
 118       , "all"
 119       , "none"
 120       , RECommaNonEmpty (describe (Proxy :: Proxy RelaxedDep))
 121       ]
 122
 123 -------------------------------------------------------------------------------
 124 -- ActiveRepos
 125 -------------------------------------------------------------------------------
 126
 127 instance Described ActiveRepos where
 128   describe _ =
 129     REUnion
 130       [ ":none"
 131       , RECommaNonEmpty (describe (Proxy :: Proxy ActiveRepoEntry))
 132       ]
 133
 134 instance Described ActiveRepoEntry where
 135   describe _ =
 136     REUnion
 137       [ ":rest" <> strategy
 138       , REOpt ":repo:" <> describe (Proxy :: Proxy RepoName) <> strategy
 139       ]
 140     where
 141       strategy = REOpt $ ":" <> describe (Proxy :: Proxy CombineStrategy)
 142
 143 instance Described CombineStrategy where
 144   describe _ =
 145     REUnion
 146       [ "skip"
 147       , "merge"
 148       , "override"
 149       ]
 150
 151 -------------------------------------------------------------------------------
 152 -- UserConstraint
 153 -------------------------------------------------------------------------------
 154
 155 instance Described UserConstraint where
 156   describe _ =
 157     REAppend
 158       [ describeConstraintScope
 159       , describeConstraintProperty
 160       ]
 161     where
 162       describeConstraintScope :: GrammarRegex void
 163       describeConstraintScope =
 164         REUnion
 165           [ "any." <> describePN
 166           , "setup." <> describePN
 167           , describePN
 168           , describePN <> ":setup." <> describePN
 169           ]
 170
 171       describeConstraintProperty :: GrammarRegex void
 172       describeConstraintProperty =
 173         REUnion
 174           [ RESpaces <> RENamed "version-range" (describe (Proxy :: Proxy VersionRange))
 175           , RESpaces1 <> describeConstraintProperty'
 176           ]
 177
 178       describeConstraintProperty' :: GrammarRegex void
 179       describeConstraintProperty' =
 180         REUnion
 181           [ "installed"
 182           , "source"
 183           , "test"
 184           , "bench"
 185           , describeFlagAssignmentNonEmpty
 186           ]
 187
 188       describePN :: GrammarRegex void
 189       describePN = RENamed "package-name" (describe (Proxy :: Proxy PackageName))
 190
 191 -------------------------------------------------------------------------------
 192 -- IndexState
 193 -------------------------------------------------------------------------------
 194
 195 instance Described TotalIndexState where
 196   describe _ =
 197     reCommaNonEmpty $
 198       REUnion
 199         [ describe (Proxy :: Proxy RepoName) <> RESpaces1 <> ris
 200         , ris
 201         ]
 202     where
 203       ris = describe (Proxy :: Proxy RepoIndexState)
 204
 205 instance Described RepoName where
 206   describe _ = lead <> rest
 207     where
 208       lead = RECharSet $ csAlpha <> "_-."
 209       rest = reMunchCS $ csAlphaNum <> "_-."
 210
 211 instance Described RepoIndexState where
 212   describe _ =
 213     REUnion
 214       [ "HEAD"
 215       , RENamed "timestamp" (describe (Proxy :: Proxy Timestamp))
 216       ]
 217
 218 instance Described Timestamp where
 219   describe _ =
 220     REUnion
 221       [ posix
 222       , utc
 223       ]
 224     where
 225       posix = reChar '@' <> reMunch1CS "0123456789"
 226       utc = RENamed "date" date <> reChar 'T' <> RENamed "time" time <> reChar 'Z'
 227
 228       date =
 229         REOpt digit
 230           <> REUnion
 231             [ leapYear <> reChar '-' <> leapMD
 232             , commonYear <> reChar '-' <> commonMD
 233             ]
 234
 235       -- leap year: either
 236       -- \* divisible by 400
 237       -- \* not divisible by 100 and divisible by 4
 238       leapYear =
 239         REUnion
 240           [ div4 <> "00"
 241           , digit <> digit <> div4not0
 242           ]
 243
 244       -- common year: either
 245       -- \* not divisible by 400 but divisible by 100
 246       -- \* not divisible by 4
 247       commonYear =
 248         REUnion
 249           [ notDiv4 <> "00"
 250           , digit <> digit <> notDiv4
 251           ]
 252
 253       div4 =
 254         REUnion
 255           [ "0" <> reChars "048"
 256           , "1" <> reChars "26"
 257           , "2" <> reChars "048"
 258           , "3" <> reChars "26"
 259           , "4" <> reChars "048"
 260           , "5" <> reChars "26"
 261           , "6" <> reChars "048"
 262           , "7" <> reChars "26"
 263           , "8" <> reChars "048"
 264           , "9" <> reChars "26"
 265           ]
 266
 267       div4not0 =
 268         REUnion
 269           [ "0" <> reChars "48" -- no zero
 270           , "1" <> reChars "26"
 271           , "2" <> reChars "048"
 272           , "3" <> reChars "26"
 273           , "4" <> reChars "048"
 274           , "5" <> reChars "26"
 275           , "6" <> reChars "048"
 276           , "7" <> reChars "26"
 277           , "8" <> reChars "048"
 278           , "9" <> reChars "26"
 279           ]
 280
 281       notDiv4 =
 282         REUnion
 283           [ "0" <> reChars "1235679"
 284           , "1" <> reChars "01345789"
 285           , "2" <> reChars "1235679"
 286           , "3" <> reChars "01345789"
 287           , "4" <> reChars "1235679"
 288           , "5" <> reChars "01345789"
 289           , "6" <> reChars "1235679"
 290           , "7" <> reChars "01345789"
 291           , "8" <> reChars "1235679"
 292           , "9" <> reChars "01345789"
 293           ]
 294
 295       leapMD =
 296         REUnion
 297           [jan, fe', mar, apr, may, jun, jul, aug, sep, oct, nov, dec]
 298
 299       commonMD =
 300         REUnion
 301           [jan, feb, mar, apr, may, jun, jul, aug, sep, oct, nov, dec]
 302
 303       jan = "01-" <> d31
 304       feb = "02-" <> d28
 305       fe' = "02-" <> d29
 306       mar = "03-" <> d31
 307       apr = "04-" <> d30
 308       may = "05-" <> d31
 309       jun = "06-" <> d30
 310       jul = "07-" <> d31
 311       aug = "08-" <> d31
 312       sep = "09-" <> d30
 313       oct = "10-" <> d31
 314       nov = "11-" <> d30
 315       dec = "12-" <> d31
 316
 317       d28 =
 318         REUnion
 319           ["0" <> digit1, "1" <> digit, "2" <> reChars "012345678"]
 320       d29 =
 321         REUnion
 322           ["0" <> digit1, "1" <> digit, "2" <> digit]
 323       d30 =
 324         REUnion
 325           ["0" <> digit1, "1" <> digit, "2" <> digit, "30"]
 326       d31 =
 327         REUnion
 328           ["0" <> digit1, "1" <> digit, "2" <> digit, "30", "31"]
 329
 330       time = ho <> reChar ':' <> minSec <> reChar ':' <> minSec
 331
 332       -- 0..23
 333       ho =
 334         REUnion
 335           [ "0" <> digit
 336           , "1" <> digit
 337           , "2" <> reChars "0123"
 338           ]
 339
 340       -- 0..59
 341       minSec = reChars "012345" <> digit
 342
 343       digit = reChars "0123456789"
 344       digit1 = reChars "123456789"