ProjectConfig.hs 22.1 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module UnitTests.Distribution.Client.ProjectConfig (tests) where

#if !MIN_VERSION_base(4,8,0)
import Data.Monoid
import Control.Applicative
#endif
import Data.Map (Map)
import qualified Data.Map as Map
import Data.List

import Distribution.Package
15
import Distribution.Types.Dependency
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
import Distribution.PackageDescription hiding (Flag)
import Distribution.Compiler
import Distribution.Version
import Distribution.ParseUtils
import Distribution.Simple.Compiler
import Distribution.Simple.Setup
import Distribution.Simple.InstallDirs
import qualified Distribution.Compat.ReadP as Parse
import Distribution.Simple.Utils
import Distribution.Simple.Program.Types
import Distribution.Simple.Program.Db

import Distribution.Client.Types
import Distribution.Client.Dependency.Types
import Distribution.Client.BuildReports.Types
import Distribution.Client.Targets
import Distribution.Utils.NubList
import Network.URI

35
import Distribution.Solver.Types.PackageConstraint
36
import Distribution.Solver.Types.ConstraintSource
37
38
39
import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.Settings

40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
import Distribution.Client.ProjectConfig
import Distribution.Client.ProjectConfig.Legacy

import UnitTests.Distribution.Client.ArbitraryInstances

import Test.Tasty
import Test.Tasty.QuickCheck

tests :: [TestTree]
tests =
  [ testGroup "ProjectConfig <-> LegacyProjectConfig round trip" $
    [ testProperty "packages"  prop_roundtrip_legacytypes_packages
    , testProperty "buildonly" prop_roundtrip_legacytypes_buildonly
    , testProperty "specific"  prop_roundtrip_legacytypes_specific
    ] ++
    -- a couple tests seem to trigger a RTS fault in ghc-7.6 and older
    -- unclear why as of yet
    concat
    [ [ testProperty "shared"    prop_roundtrip_legacytypes_shared
      , testProperty "local"     prop_roundtrip_legacytypes_local
      , testProperty "all"       prop_roundtrip_legacytypes_all
      ]
    | not usingGhc76orOlder
    ]

  , testGroup "individual parser tests"
    [ testProperty "package location"  prop_parsePackageLocationTokenQ
    ]

  , testGroup "ProjectConfig printing/parsing round trip"
    [ testProperty "packages"  prop_roundtrip_printparse_packages
    , testProperty "buildonly" prop_roundtrip_printparse_buildonly
    , testProperty "shared"    prop_roundtrip_printparse_shared
    , testProperty "local"     prop_roundtrip_printparse_local
    , testProperty "specific"  prop_roundtrip_printparse_specific
    , testProperty "all"       prop_roundtrip_printparse_all
    ]
  ]
  where
    usingGhc76orOlder =
      case buildCompilerId of
81
        CompilerId GHC v -> v < mkVersion [7,7]
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
        _                -> False


------------------------------------------------
-- Round trip: conversion to/from legacy types
--

roundtrip :: Eq a => (a -> b) -> (b -> a) -> a -> Bool
roundtrip f f_inv x =
    (f_inv . f) x == x

roundtrip_legacytypes :: ProjectConfig -> Bool
roundtrip_legacytypes =
    roundtrip convertToLegacyProjectConfig
              convertLegacyProjectConfig


prop_roundtrip_legacytypes_all :: ProjectConfig -> Bool
100
prop_roundtrip_legacytypes_all config =
101
    roundtrip_legacytypes
102
103
104
      config {
        projectConfigProvenance = mempty
      }
105
106
107
108
109
110
111

prop_roundtrip_legacytypes_packages :: ProjectConfig -> Bool
prop_roundtrip_legacytypes_packages config =
    roundtrip_legacytypes
      config {
        projectConfigBuildOnly       = mempty,
        projectConfigShared          = mempty,
112
        projectConfigProvenance      = mempty,
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
        projectConfigLocalPackages   = mempty,
        projectConfigSpecificPackage = mempty
      }

prop_roundtrip_legacytypes_buildonly :: ProjectConfigBuildOnly -> Bool
prop_roundtrip_legacytypes_buildonly config =
    roundtrip_legacytypes
      mempty { projectConfigBuildOnly = config }

prop_roundtrip_legacytypes_shared :: ProjectConfigShared -> Bool
prop_roundtrip_legacytypes_shared config =
    roundtrip_legacytypes
      mempty { projectConfigShared = config }

prop_roundtrip_legacytypes_local :: PackageConfig -> Bool
prop_roundtrip_legacytypes_local config =
    roundtrip_legacytypes
      mempty { projectConfigLocalPackages = config }

prop_roundtrip_legacytypes_specific :: Map PackageName PackageConfig -> Bool
prop_roundtrip_legacytypes_specific config =
    roundtrip_legacytypes
135
      mempty { projectConfigSpecificPackage = MapMappend config }
136
137
138
139
140
141
142
143
144
145
146
147
148


--------------------------------------------
-- Round trip: printing and parsing config
--

roundtrip_printparse :: ProjectConfig -> Bool
roundtrip_printparse config =
    case (fmap convertLegacyProjectConfig
        . parseLegacyProjectConfig
        . showLegacyProjectConfig
        . convertToLegacyProjectConfig)
          config of
149
      ParseOk _ x -> x == config { projectConfigProvenance = mempty }
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
      _           -> False


prop_roundtrip_printparse_all :: ProjectConfig -> Bool
prop_roundtrip_printparse_all config =
    roundtrip_printparse config {
      projectConfigBuildOnly =
        hackProjectConfigBuildOnly (projectConfigBuildOnly config),

      projectConfigShared =
        hackProjectConfigShared (projectConfigShared config)
    }

prop_roundtrip_printparse_packages :: [PackageLocationString]
                                   -> [PackageLocationString]
                                   -> [SourceRepo]
                                   -> [Dependency]
                                   -> Bool
prop_roundtrip_printparse_packages pkglocstrs1 pkglocstrs2 repos named =
    roundtrip_printparse
      mempty {
        projectPackages         = map getPackageLocationString pkglocstrs1,
        projectPackagesOptional = map getPackageLocationString pkglocstrs2,
        projectPackagesRepo     = repos,
        projectPackagesNamed    = named
      }

prop_roundtrip_printparse_buildonly :: ProjectConfigBuildOnly -> Bool
prop_roundtrip_printparse_buildonly config =
    roundtrip_printparse
      mempty {
        projectConfigBuildOnly = hackProjectConfigBuildOnly config
      }

hackProjectConfigBuildOnly :: ProjectConfigBuildOnly -> ProjectConfigBuildOnly
hackProjectConfigBuildOnly config =
    config {
      -- These two fields are only command line transitory things, not
      -- something to be recorded persistently in a config file
      projectConfigOnlyDeps = mempty,
      projectConfigDryRun   = mempty
    }

prop_roundtrip_printparse_shared :: ProjectConfigShared -> Bool
prop_roundtrip_printparse_shared config =
    roundtrip_printparse
      mempty {
        projectConfigShared = hackProjectConfigShared config
      }

hackProjectConfigShared :: ProjectConfigShared -> ProjectConfigShared
hackProjectConfigShared config =
    config {
      projectConfigConstraints =
      --TODO: [required eventually] parse ambiguity in constraint
      -- "pkgname -any" as either any version or disabled flag "any".
206
        let ambiguous (UserConstraint _ _ (PackagePropertyFlags flags), _) =
207
208
              (not . null) [ () | (name, False) <- flags
                                , "any" `isPrefixOf` unFlagName name ]
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
            ambiguous _ = False
         in filter (not . ambiguous) (projectConfigConstraints config)
    }


prop_roundtrip_printparse_local :: PackageConfig -> Bool
prop_roundtrip_printparse_local config =
    roundtrip_printparse
      mempty {
        projectConfigLocalPackages = config
      }

prop_roundtrip_printparse_specific :: Map PackageName (NonMEmpty PackageConfig)
                                   -> Bool
prop_roundtrip_printparse_specific config =
    roundtrip_printparse
      mempty {
226
        projectConfigSpecificPackage = MapMappend (fmap getNonMEmpty config)
227
228
229
230
231
232
233
234
235
      }


----------------------------
-- Individual Parser tests 
--

prop_parsePackageLocationTokenQ :: PackageLocationString -> Bool
prop_parsePackageLocationTokenQ (PackageLocationString str) =
236
237
    case [ x | (x,"") <- Parse.readP_to_S parsePackageLocationTokenQ
                                         (renderPackageLocationToken str) ] of
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
      [str'] -> str' == str
      _      -> False


------------------------
-- Arbitrary instances
--

instance Arbitrary ProjectConfig where
    arbitrary =
      ProjectConfig
        <$> (map getPackageLocationString <$> arbitrary)
        <*> (map getPackageLocationString <$> arbitrary)
        <*> shortListOf 3 arbitrary
        <*> arbitrary
253
254
255
        <*> arbitrary
        <*> arbitrary
        <*> arbitrary
256
        <*> arbitrary
257
258
        <*> (MapMappend . fmap getNonMEmpty . Map.fromList
               <$> shortListOf 3 arbitrary)
259
260
261
        -- package entries with no content are equivalent to
        -- the entry not existing at all, so exclude empty

262
    shrink (ProjectConfig x0 x1 x2 x3 x4 x5 x6 x7 x8) =
263
      [ ProjectConfig x0' x1' x2' x3'
264
265
                      x4' x5' x6' x7' (MapMappend (fmap getNonMEmpty x8'))
      | ((x0', x1', x2', x3'), (x4', x5', x6', x7', x8'))
266
          <- shrink ((x0, x1, x2, x3),
267
                     (x4, x5, x6, x7, fmap NonMEmpty (getMapMappend x8)))
268
269
270
271
272
273
274
275
276
277
      ]

newtype PackageLocationString
      = PackageLocationString { getPackageLocationString :: String }
  deriving Show

instance Arbitrary PackageLocationString where
  arbitrary =
    PackageLocationString <$>
    oneof
278
279
      [ show . getNonEmpty <$> (arbitrary :: Gen (NonEmptyList String))
      , arbitraryGlobLikeStr
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
      , show <$> (arbitrary :: Gen URI)
      ]

arbitraryGlobLikeStr :: Gen String
arbitraryGlobLikeStr = outerTerm
  where
    outerTerm  = concat <$> shortListOf1 4
                  (frequency [ (2, token)
                             , (1, braces <$> innerTerm) ])
    innerTerm  = intercalate "," <$> shortListOf1 3
                  (frequency [ (3, token)
                             , (1, braces <$> innerTerm) ])
    token      = shortListOf1 4 (elements (['#'..'~'] \\ "{,}"))
    braces s   = "{" ++ s ++ "}"


instance Arbitrary ProjectConfigBuildOnly where
    arbitrary =
      ProjectConfigBuildOnly
        <$> arbitrary
        <*> arbitrary
        <*> arbitrary
        <*> (toNubList <$> shortListOf 2 arbitrary)             --  4
        <*> arbitrary
        <*> arbitrary
        <*> arbitrary
        <*> (fmap getShortToken <$> arbitrary)                  --  8
        <*> arbitrary
        <*> arbitraryNumJobs
        <*> arbitrary
310
311
        <*> arbitrary
        <*> arbitrary
312
313
314
        <*> (fmap getShortToken <$> arbitrary)
        <*> arbitrary
        <*> (fmap getShortToken <$> arbitrary)
315
        <*> (fmap getShortToken <$> arbitrary)
316
317
318
319
320
321
      where
        arbitraryNumJobs = fmap (fmap getPositive) <$> arbitrary

    shrink (ProjectConfigBuildOnly
              x00 x01 x02 x03 x04 x05 x06 x07
              x08 x09 x10 x11 x12 x13 x14 x15
322
              x16) =
323
324
325
      [ ProjectConfigBuildOnly
          x00' x01' x02' x03' x04'
          x05' x06' x07' x08' (postShrink_NumJobs x09')
326
          x10' x11' x12' x13  x14'
327
          x15  x16
328
329
      | ((x00', x01', x02', x03', x04'),
         (x05', x06', x07', x08', x09'),
330
         (x10', x11', x12',       x14'))
331
332
333
          <- shrink
               ((x00, x01, x02, x03, x04),
                (x05, x06, x07, x08, preShrink_NumJobs x09),
334
                (x10, x11, x12,      x14))
335
336
337
338
339
340
341
342
      ]
      where
        preShrink_NumJobs  = fmap (fmap Positive)
        postShrink_NumJobs = fmap (fmap getPositive)

instance Arbitrary ProjectConfigShared where
    arbitrary =
      ProjectConfigShared
343
        <$> arbitrary                                           --  4
344
345
346
        <*> arbitraryFlag arbitraryShortToken
        <*> arbitraryFlag arbitraryShortToken
        <*> arbitrary
347
        <*> arbitrary
348
        <*> (toNubList <$> listOf arbitraryShortToken)
349
        <*> arbitrary
350
        <*> arbitraryConstraints
351
352
        <*> shortListOf 2 arbitrary
        <*> arbitrary <*> arbitrary
353
354
        <*> arbitrary <*> arbitrary
        <*> arbitrary <*> arbitrary
355
        <*> arbitrary <*> arbitrary
356
357
358
359
360
361
362
363
      where
        arbitraryConstraints :: Gen [(UserConstraint, ConstraintSource)]
        arbitraryConstraints =
            map (\uc -> (uc, projectConfigConstraintSource)) <$> arbitrary

    shrink (ProjectConfigShared
              x00 x01 x02 x03 x04
              x05 x06 x07 x08 x09
364
365
              x10 x11 x12 x13 x14
              x15 x16) =
366
      [ ProjectConfigShared
367
          x00' (fmap getNonEmpty x01') (fmap getNonEmpty x02') x03' x04'
368
369
          x05' x06' (postShrink_Constraints x07') x08' x09'
          x10' x11' x12' x13' x14' x15' x16'
370
371
      | ((x00', x01', x02', x03', x04'),
         (x05', x06', x07', x08', x09'),
372
         (x10', x11', x12', x13', x14'),
373
         (x15', x16'))
374
          <- shrink
375
               ((x00, fmap NonEmpty x01, fmap NonEmpty x02, x03, x04),
376
377
378
                (x05, x06, preShrink_Constraints x07, x08, x09),
                (x10, x11, x12, x13, x14),
                (x15, x16))
379
380
381
382
383
384
385
386
387
      ]
      where
        preShrink_Constraints  = map fst
        postShrink_Constraints = map (\uc -> (uc, projectConfigConstraintSource))

projectConfigConstraintSource :: ConstraintSource
projectConfigConstraintSource = 
    ConstraintSourceProjectConfig "TODO"

388
389
390
instance Arbitrary ProjectConfigProvenance where
    arbitrary = elements [Implicit, Explicit "cabal.project"]

391
392
393
instance Arbitrary PackageConfig where
    arbitrary =
      PackageConfig
394
395
396
397
398
399
400
401
        <$> (MapLast . Map.fromList <$> shortListOf 10
              ((,) <$> arbitraryProgramName
                   <*> arbitraryShortToken))
        <*> (MapMappend . Map.fromList <$> shortListOf 10
              ((,) <$> arbitraryProgramName
                   <*> listOf arbitraryShortToken))
        <*> (toNubList <$> listOf arbitraryShortToken)
        <*> arbitrary
402
403
404
        <*> arbitrary <*> arbitrary
        <*> arbitrary <*> arbitrary
        <*> arbitrary <*> arbitrary
405
406
407
        <*> arbitrary <*> arbitrary
        <*> shortListOf 5 arbitraryShortToken
        <*> arbitrary
408
        <*> arbitrary <*> arbitrary
409
410
411
        <*> shortListOf 5 arbitraryShortToken
        <*> shortListOf 5 arbitraryShortToken
        <*> shortListOf 5 arbitraryShortToken
412
413
414
415
        <*> arbitrary
        <*> arbitrary <*> arbitrary
        <*> arbitrary <*> arbitrary
        <*> arbitrary <*> arbitrary
416
417
418
419
420
        <*> arbitrary <*> arbitrary
        <*> arbitrary <*> arbitrary
        <*> arbitrary <*> arbitrary
        <*> arbitraryFlag arbitraryShortToken
        <*> arbitrary
421
        <*> arbitrary
422
        <*> arbitrary <*> arbitrary
423
424
425
        <*> arbitrary
        <*> arbitraryFlag arbitraryShortToken
        <*> arbitrary
426
        <*> arbitraryFlag arbitraryShortToken
427
        <*> arbitrary
428
429
430
431
432
      where
        arbitraryProgramName :: Gen String
        arbitraryProgramName =
          elements [ programName prog
                   | (prog, _) <- knownPrograms (defaultProgramDb) ]
433
434
435
436
437
438
439
440

    shrink (PackageConfig
              x00 x01 x02 x03 x04
              x05 x06 x07 x08 x09
              x10 x11 x12 x13 x14
              x15 x16 x17 x18 x19
              x20 x21 x22 x23 x24
              x25 x26 x27 x28 x29
441
              x30 x31 x32 x33 x33_1 x34
442
443
              x35 x36 x37 x38 x39
              x40) =
444
      [ PackageConfig
445
446
447
448
449
450
451
452
          (postShrink_Paths x00')
          (postShrink_Args  x01') x02' x03' x04'
          x05' x06' x07' x08' x09'
          x10' x11' (map getNonEmpty x12') x13' x14'
          x15' (map getNonEmpty x16')
               (map getNonEmpty x17')
               (map getNonEmpty x18')
                              x19'
453
454
          x20' x21' x22' x23' x24'
          x25' x26' x27' x28' x29'
455
          x30' x31' x32' x33' x33_1' x34'
456
457
458
          x35' x36' (fmap getNonEmpty x37') x38'
                    (fmap getNonEmpty x39')
          x40'
459
460
461
462
463
464
      | (((x00', x01', x02', x03', x04'),
          (x05', x06', x07', x08', x09'),
          (x10', x11', x12', x13', x14'),
          (x15', x16', x17', x18', x19')),
         ((x20', x21', x22', x23', x24'),
          (x25', x26', x27', x28', x29'),
465
          (x30', x31', x32', (x33', x33_1'), x34'),
466
467
          (x35', x36', x37', x38', x39'),
          (x40')))
468
          <- shrink
469
470
471
472
473
474
475
               (((preShrink_Paths x00, preShrink_Args x01, x02, x03, x04),
                 (x05, x06, x07, x08, x09),
                 (x10, x11, map NonEmpty x12, x13, x14),
                 (x15, map NonEmpty x16,
                       map NonEmpty x17,
                       map NonEmpty x18,
                       x19)),
476
477
                ((x20, x21, x22, x23, x24),
                 (x25, x26, x27, x28, x29),
478
                 (x30, x31, x32, (x33, x33_1), x34),
479
480
                 (x35, x36, fmap NonEmpty x37, x38, fmap NonEmpty x39),
                 (x40)))
481
      ]
482
483
484
485
486
487
488
489
490
491
492
493
494
      where
        preShrink_Paths  = Map.map NonEmpty
                         . Map.mapKeys NoShrink
                         . getMapLast
        postShrink_Paths = MapLast
                         . Map.map getNonEmpty
                         . Map.mapKeys getNoShrink
        preShrink_Args   = Map.map (NonEmpty . map NonEmpty)
                         . Map.mapKeys NoShrink
                         . getMapMappend
        postShrink_Args  = MapMappend
                         . Map.map (map getNonEmpty . getNonEmpty)
                         . Map.mapKeys getNoShrink
495
496
497
498
499
500
501
502
503
504


instance Arbitrary SourceRepo where
    arbitrary = (SourceRepo RepoThis
                           <$> arbitrary
                           <*> (fmap getShortToken <$> arbitrary)
                           <*> (fmap getShortToken <$> arbitrary)
                           <*> (fmap getShortToken <$> arbitrary)
                           <*> (fmap getShortToken <$> arbitrary)
                           <*> (fmap getShortToken <$> arbitrary))
505
                `suchThat` (/= emptySourceRepo RepoThis)
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521

    shrink (SourceRepo _ x1 x2 x3 x4 x5 x6) =
      [ repo
      | ((x1', x2', x3'), (x4', x5', x6'))
          <- shrink ((x1,
                      fmap ShortToken x2,
                      fmap ShortToken x3),
                     (fmap ShortToken x4,
                      fmap ShortToken x5,
                      fmap ShortToken x6))
      , let repo = SourceRepo RepoThis x1'
                              (fmap getShortToken x2')
                              (fmap getShortToken x3')
                              (fmap getShortToken x4')
                              (fmap getShortToken x5')
                              (fmap getShortToken x6')
522
      , repo /= emptySourceRepo RepoThis
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
      ]

instance Arbitrary RepoType where
    arbitrary = elements knownRepoTypes

instance Arbitrary ReportLevel where
    arbitrary = elements [NoReports .. DetailedReports]

instance Arbitrary CompilerFlavor where
    arbitrary = elements knownCompilerFlavors
      where
        --TODO: [code cleanup] export knownCompilerFlavors from D.Compiler
        -- it's already defined there, just need it exported.
        knownCompilerFlavors =
          [GHC, GHCJS, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC]

instance Arbitrary a => Arbitrary (InstallDirs a) where
    arbitrary =
      InstallDirs
        <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary --  4
        <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary --  8
        <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 12
545
        <*> arbitrary <*> arbitrary <*> arbitrary               -- 15
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566

instance Arbitrary PackageDB where
    arbitrary = oneof [ pure GlobalPackageDB
                      , pure UserPackageDB
                      , SpecificPackageDB . getShortToken <$> arbitrary
                      ]

instance Arbitrary RemoteRepo where
    arbitrary =
      RemoteRepo
        <$> arbitraryShortToken `suchThat` (not . (":" `isPrefixOf`))
        <*> arbitrary  -- URI
        <*> arbitrary
        <*> listOf arbitraryRootKey
        <*> (fmap getNonNegative arbitrary)
        <*> pure False
      where
        arbitraryRootKey =
          shortListOf1 5 (oneof [ choose ('0', '9')
                                , choose ('a', 'f') ])

567
568
569
570
571
572
573
574
575
576
instance Arbitrary UserConstraint where
    arbitrary =
      oneof [ UserConstraint UserUnqualified <$> arbitrary <*> prop
            | prop <- [ PackagePropertyVersion <$> arbitrary
                      , pure PackagePropertyInstalled
                      , pure PackagePropertySource
                      , PackagePropertyFlags <$> shortListOf1 3 arbitrary
                      , PackagePropertyStanzas . (\x->[x]) <$> arbitrary
                      ] ]

577
578
579
580
instance Arbitrary OptionalStanza where
    arbitrary = elements [minBound..maxBound]

instance Arbitrary FlagName where
581
    arbitrary = mkFlagName <$> flagident
582
583
584
585
586
587
588
589
      where
        flagident   = lowercase <$> shortListOf1 5 (elements flagChars)
                      `suchThat` (("-" /=) . take 1)
        flagChars   = "-_" ++ ['a'..'z']

instance Arbitrary PreSolver where
    arbitrary = elements [minBound..maxBound]

590
591
592
instance Arbitrary ReorderGoals where
    arbitrary = ReorderGoals <$> arbitrary

Andres Löh's avatar
Andres Löh committed
593
594
595
instance Arbitrary CountConflicts where
    arbitrary = CountConflicts <$> arbitrary

596
597
598
instance Arbitrary StrongFlags where
    arbitrary = StrongFlags <$> arbitrary

599
instance Arbitrary AllowNewer where
600
601
602
603
604
605
606
607
608
    arbitrary = AllowNewer <$> arbitrary

instance Arbitrary AllowOlder where
    arbitrary = AllowOlder <$> arbitrary

instance Arbitrary RelaxDeps where
    arbitrary = oneof [ pure RelaxDepsNone
                      , RelaxDepsSome <$> shortListOf1 3 arbitrary
                      , pure RelaxDepsAll
609
610
                      ]

611
612
613
instance Arbitrary RelaxedDep where
    arbitrary = oneof [ RelaxedDep       <$> arbitrary
                      , RelaxedDepScoped <$> arbitrary <*> arbitrary
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
                      ]

instance Arbitrary ProfDetailLevel where
    arbitrary = elements [ d | (_,_,d) <- knownProfDetailLevels ]

instance Arbitrary OptimisationLevel where
    arbitrary = elements [minBound..maxBound]

instance Arbitrary DebugInfoLevel where
    arbitrary = elements [minBound..maxBound]

instance Arbitrary URI where
    arbitrary =
      URI <$> elements ["file:", "http:", "https:"]
          <*> (Just <$> arbitrary)
          <*> (('/':) <$> arbitraryURIToken)
          <*> (('?':) <$> arbitraryURIToken)
          <*> pure ""

instance Arbitrary URIAuth where
    arbitrary =
      URIAuth <$> pure ""   -- no password as this does not roundtrip
              <*> arbitraryURIToken
              <*> arbitraryURIPort

arbitraryURIToken :: Gen String
arbitraryURIToken =
    shortListOf1 6 (elements (filter isUnreserved ['\0'..'\255']))

arbitraryURIPort :: Gen String
arbitraryURIPort =
    oneof [ pure "", (':':) <$> shortListOf1 4 (choose ('0','9')) ]