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