• Home
  • Features
  • Pricing
  • Docs
  • Announcements
  • Sign In

input-output-hk / constrained-generators / 416

21 Nov 2025 08:35AM UTC coverage: 76.66% (+0.2%) from 76.458%
416

push

github

web-flow
fourmolu (#60)

179 of 191 new or added lines in 14 files covered. (93.72%)

10 existing lines in 4 files now uncovered.

3948 of 5150 relevant lines covered (76.66%)

1.45 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

74.38
/src/Constrained/Base.hs
1
{-# LANGUAGE AllowAmbiguousTypes #-}
2
{-# LANGUAGE ConstraintKinds #-}
3
{-# LANGUAGE DataKinds #-}
4
{-# LANGUAGE DefaultSignatures #-}
5
{-# LANGUAGE FlexibleContexts #-}
6
{-# LANGUAGE FlexibleInstances #-}
7
{-# LANGUAGE FunctionalDependencies #-}
8
{-# LANGUAGE GADTs #-}
9
{-# LANGUAGE LambdaCase #-}
10
{-# LANGUAGE OverloadedStrings #-}
11
{-# LANGUAGE PatternSynonyms #-}
12
{-# LANGUAGE ScopedTypeVariables #-}
13
{-# LANGUAGE StandaloneDeriving #-}
14
{-# LANGUAGE TypeApplications #-}
15
{-# LANGUAGE TypeFamilies #-}
16
{-# LANGUAGE TypeOperators #-}
17
{-# LANGUAGE UndecidableInstances #-}
18
{-# LANGUAGE UndecidableSuperClasses #-}
19
{-# LANGUAGE ViewPatterns #-}
20

21
-- | This module contains the most basic parts the implementation. Essentially
22
--   everything to define Specification, HasSpec, HasSimpleRep, Term, Pred, and the Syntax,
23
--   Semantics, and Logic class. It also has a few HasSpec, HasSimpleRep, and Logic
24
--   instances for basic types needed to define the default types and methods of HasSpec.
25
--   It also supplies Eq, Pretty, and Show instances on the syntax (Term, Pred, Binder etc.)
26
--   because many functions require these instances. It exports functions that define the
27
--   user interface to the domain embedded language (constrained, forall, exists etc.).
28
--   And, by design, nothing more.
29
module Constrained.Base (
30
  -- * Implementing logic propagation
31
  Logic (..),
32
  pattern (:<:),
33
  pattern (:>:),
34
  pattern Unary,
35
  Ctx (..),
36
  toCtx,
37
  flipCtx,
38
  fromListCtx,
39
  ctxHasSpec,
40

41
  -- * Useful function symbols and patterns for building custom rewrite rules
42
  fromGeneric_,
43
  toGeneric_,
44
  pattern ToGeneric,
45
  pattern FromGeneric,
46

47
  -- * Syntax for building specifications
48
  constrained,
49
  notMemberSpec,
50
  notEqualSpec,
51
  typeSpec,
52
  addToErrorSpec,
53
  memberSpec,
54
  fromSimpleRepSpec,
55
  toSimpleRepSpec,
56
  explainSpec,
57

58
  -- * Instantiated types and helper patterns
59
  Term,
60
  Specification,
61
  Pred,
62
  Binder,
63
  pattern TypeSpec,
64
  pattern GenHint,
65

66
  -- * Constraints and classes
67
  HasSpec (..),
68
  HasGenHint (..),
69
  Forallable,
70
  AppRequires,
71
  GenericallyInstantiated,
72
  GenericRequires,
73

74
  -- * Building `Pred`, `Specification`, `Term` etc.
75
  bind,
76
  name,
77

78
  -- * TODO: documentme
79
  propagateSpec,
80
  appFun,
81
  errorLikeMessage,
82
  isErrorLike,
83
  BinaryShow (..),
84
  toPred,
85
  forAllToList,
86
  IsPred,
87
  equalSpec,
88
  appTerm,
89
  HOLE (..),
90
  fromForAllSpec,
91
  Fun (..),
92
  BaseW (..),
93
  Deps,
94
) where
95

96
import Constrained.AbstractSyntax
97
import Constrained.Core
98
import Constrained.DependencyInjection
99
import Constrained.FunctionSymbol
100
import Constrained.GenT
101
import Constrained.Generic
102
import Constrained.List hiding (toList)
103
import Constrained.TypeErrors
104
import Data.Foldable (
105
  toList,
106
 )
107
import Data.Kind (Constraint, Type)
108
import qualified Data.List.NonEmpty as NE
109
import Data.Orphans ()
110
import Data.Semigroup (Max (..), getMax)
111
import Data.Typeable
112
import GHC.Stack
113
import Prettyprinter hiding (cat)
114
import Test.QuickCheck (arbitrary, shrink)
115

116
newtype TypeSpecF a = TypeSpecF (TypeSpec a)
117

118
instance Show (TypeSpec a) => Show (TypeSpecF a) where
1✔
119
  show (TypeSpecF ts) = show ts
2✔
120

121
newtype HintF a = HintF (Hint a)
122

123
instance Show (Hint a) => Show (HintF a) where
×
124
  show (HintF h) = show h
×
125

126
data Deps
127

128
instance Dependencies Deps where
129
  type HasSpecD Deps = HasSpec
130
  type TypeSpecD Deps = TypeSpecF
131
  type LogicD Deps = Logic
132
  type ForallableD Deps = Forallable
133
  type HasGenHintD Deps = HasGenHint
134
  type HintD Deps = HintF
135

136
-- | Binders instantiated with the correct `HasSpec` etc. classes
137
type Binder = BinderD Deps
138

139
-- | All the constraints needed for application in the first order term languge
140
type AppRequires t as b = AppRequiresD Deps t as b
141

142
-- | Predicates over `Term`s
143
type Pred = PredD Deps
144

145
-- | First-order language of variables, literals, and application
146
type Term = TermD Deps
147

148
-- | Specifications for generators instantiated with the `HasSpec` et al actual
149
-- classes
150
type Specification = SpecificationD Deps
151

152
-- | Pattern match out a `TypeSpec` and the can't-"set" - avoids some tedious
153
-- pitfalls related to the `Deps` and `Dependencies` trick
154
pattern TypeSpec :: () => HasSpec a => TypeSpec a -> [a] -> Specification a
155
pattern TypeSpec ts cant = TypeSpecD (TypeSpecF ts) cant
2✔
156

157
{-# COMPLETE ExplainSpec, MemberSpec, ErrorSpec, SuspendedSpec, TypeSpec, TrueSpec #-}
158

159
-- | Build a specifiation from just a `TypeSpec`, useful internal function when
160
-- writing `Logic` instances
161
typeSpec :: HasSpec a => TypeSpec a -> Specification a
162
typeSpec ts = TypeSpec ts mempty
2✔
163

164
-- | Pattern match out a `Hint` and the `Term` it applies to - avoids some
165
-- tedious pitfalls related to the `Deps` and `Dependencies` trick
166
pattern GenHint :: () => HasGenHint a => Hint a -> Term a -> Pred
167
pattern GenHint h t = GenHintD (HintF h) t
2✔
168

169
{-# COMPLETE
170
  ElemPred
171
  , Monitor
172
  , And
173
  , Exists
174
  , Subst
175
  , Let
176
  , Assert
177
  , Reifies
178
  , DependsOn
179
  , ForAll
180
  , Case
181
  , When
182
  , GenHint
183
  , TruePred
184
  , FalsePred
185
  , Explain
186
  #-}
187

188
-- ====================================================================
189

190
-- A First-order typed logic has 4 components
191
--     1. Terms        (Variables (x), Constants (5), and Applications (F x 5)
192
--        Applications, apply a function symbol to a list of arguments: (FunctionSymbol term1 .. termN)
193
--     2. Predicates   (Ordered, Odd, ...)
194
--     3. Connectives  (And, Or, Not, =>, ...)
195
--     4. Quantifiers  (Forall, Exists)
196
--
197
-- The Syntax, Semantics, and Logic classes implement new function symbols in
198
-- the first order logic. Note that a function symbol is first order
199
-- data, that uniquely identifies a higher order function. The three classes
200
-- supply varying levels of functionality, relating to the Syntax, Semantics, and
201
-- Logical operations of the function symbol.
202

203
-- | Logical operations are one that support reasoning about how a function symbol
204
--   relates to logical properties, that we call Specification's
205
class (Typeable t, Semantics t, Syntax t) => Logic t where
206
  {-# MINIMAL propagate | (propagateTypeSpec, propagateMemberSpec) #-}
207

208
  propagateTypeSpec ::
209
    (AppRequires t as b, HasSpec a) =>
210
    t as b ->
211
    ListCtx Value as (HOLE a) ->
212
    TypeSpec b ->
213
    [b] ->
214
    Specification a
215
  propagateTypeSpec f ctx ts cant = propagate f ctx (TypeSpec ts cant)
×
216

217
  propagateMemberSpec ::
218
    (AppRequires t as b, HasSpec a) =>
219
    t as b ->
220
    ListCtx Value as (HOLE a) ->
221
    NonEmpty b ->
222
    Specification a
223
  propagateMemberSpec f ctx xs = propagate f ctx (MemberSpec xs)
×
224

225
  propagate ::
226
    (AppRequires t as b, HasSpec a) =>
227
    t as b ->
228
    ListCtx Value as (HOLE a) ->
229
    Specification b ->
230
    Specification a
231
  propagate f ctx (ExplainSpec es s) = explainSpec es (propagate f ctx s)
2✔
232
  propagate _ _ TrueSpec = TrueSpec
2✔
233
  propagate _ _ (ErrorSpec es) = ErrorSpec es
1✔
234
  propagate f ctx (SuspendedSpec v ps) = constrained $ \v' -> Let (App f (fromListCtx ctx v')) (v :-> ps) :: Pred
2✔
235
  propagate f ctx (TypeSpec ts cant) = propagateTypeSpec f ctx ts cant
2✔
236
  propagate f ctx (MemberSpec xs) = propagateMemberSpec f ctx xs
2✔
237

238
  rewriteRules ::
239
    (TypeList dom, Typeable dom, HasSpec rng, All HasSpec dom) =>
240
    t dom rng ->
241
    List Term dom ->
242
    Evidence (AppRequires t dom rng) ->
243
    Maybe (Term rng)
244
  rewriteRules _ _ _ = Nothing
2✔
245

246
  mapTypeSpec ::
247
    forall a b.
248
    (HasSpec a, HasSpec b) =>
249
    t '[a] b ->
250
    TypeSpec a ->
251
    Specification b
252
  mapTypeSpec _ts _spec = TrueSpec
×
253

254
  saturate :: t dom Bool -> List Term dom -> [Pred]
255
  saturate _symbol _ = []
2✔
256

257
-- | This is where the logical properties of a function symbol are applied to transform one spec into another
258
-- Note if there is a bunch of functions nested together, like (sizeOf_ (elems_ (snd_ x)))
259
-- we propagate each of those nested function symbols over the current spec, one at a time.
260
-- The result of this propagation is then made the current spec in the recusive calls to 'propagateSpec'
261
propagateSpec ::
262
  forall v a.
263
  HasSpec v =>
264
  Specification a ->
265
  Ctx v a ->
266
  Specification v
267
propagateSpec spec = \case
2✔
268
  CtxHOLE -> spec
2✔
269
  CtxApp f (ListCtx pre c suf)
270
    | Evidence <- ctxHasSpec c -> propagateSpec (propagate f (ListCtx pre HOLE suf) spec) c
2✔
271

272
ctxHasSpec :: Ctx v a -> Evidence (HasSpec a)
273
ctxHasSpec CtxHOLE = Evidence
2✔
274
ctxHasSpec CtxApp {} = Evidence
2✔
275

276
-- | Contexts for Terms, basically a term with a _single_ HOLE
277
-- instead of a variable. This is used to traverse the defining
278
-- constraints for a variable and turn them into a spec. Each
279
-- subterm `f vs Ctx vs'` for lists of values `vs` and `vs'`
280
-- gets given to the `propagateSpecFun` for `f` as  `(f vs HOLE vs')`.
281
data Ctx v a where
282
  -- | A single hole of type `v`. Note ctxHOLE is a nullary constructor, where the `a` type index is the same as the `v` type index.
283
  CtxHOLE ::
284
    HasSpec v =>
285
    Ctx v v
286
  -- | The application `f vs Ctx vs'`
287
  CtxApp ::
288
    ( AppRequires fn as b
289
    , HasSpec b
290
    , TypeList as
291
    , Typeable as
292
    , All HasSpec as
293
    , Logic fn
294
    ) =>
295
    fn as b ->
296
    -- This is basically a `List` where
297
    -- everything is `Value` except for
298
    -- one entry which is `Ctx fn v`.
299
    ListCtx Value as (Ctx v) ->
300
    Ctx v b
301

302
-- | This is used together with `ListCtx` to form
303
-- just the arguments to `f vs Ctx vs'` - replacing
304
-- `Ctx` with `HOLE`, to get a `ListCtx Value as (HOLE a)` which then can be used as an input to `propagate`.
305
data HOLE a b where
306
  HOLE :: HOLE a a
307

308
-- | Try to convert a `Term` to a single-hole context - works only if the `Var`
309
-- is the _only_ variable in the term _and_ it appears only once in the `Term`.
310
toCtx ::
311
  forall m v a.
312
  ( Typeable v
313
  , Show v
314
  , MonadGenError m
315
  , HasCallStack
316
  ) =>
317
  Var v ->
318
  Term a ->
319
  m (Ctx v a)
320
toCtx v = go
2✔
321
  where
322
    go :: forall b. Term b -> m (Ctx v b)
323
    go (Lit i) =
2✔
324
      fatalErrorNE $
×
325
        NE.fromList
×
326
          [ "toCtx applied to literal: (Lit " ++ show i ++ ")"
×
327
          , "A context is always constructed from an (App f xs) term."
×
328
          ]
329
    go (App f as) = CtxApp f <$> toCtxList v as
2✔
330
    go (V v')
331
      | Just Refl <- eqVar v v' = pure $ CtxHOLE
2✔
332
      | otherwise =
×
333
          fatalErrorNE $
×
334
            NE.fromList
×
335
              [ "A context is always constructed from an (App f xs) term,"
×
336
              , "with a single occurence of the variable " ++ show v ++ "@(" ++ show (typeOf v) ++ ")"
×
337
              , "Instead we found an unknown variable " ++ show v' ++ "@(" ++ show (typeOf v') ++ ")"
×
338
              ]
339

340
-- | `toCtx` lifted to a `List` of `Term`s
341
toCtxList ::
342
  forall m v as.
343
  (Show v, Typeable v, MonadGenError m, HasCallStack) =>
344
  Var v ->
345
  List Term as ->
346
  m (ListCtx Value as (Ctx v))
347
toCtxList v xs = prefix xs
2✔
348
  where
349
    prefix :: forall as'. HasCallStack => List Term as' -> m (ListCtx Value as' (Ctx v))
350
    prefix Nil = fatalError ("toCtxList without hole, for variable " ++ show v)
1✔
351
    prefix (Lit l :> ts) = do
2✔
352
      ctx <- prefix ts
2✔
353
      pure $ Value l :! ctx
2✔
354
    prefix (t :> ts) = do
2✔
355
      hole <- toCtx v t
2✔
356
      suf <- suffix ts
2✔
357
      pure $ hole :? suf
2✔
358

359
    suffix :: forall as'. List Term as' -> m (List Value as')
360
    suffix Nil = pure Nil
2✔
361
    suffix (Lit l :> ts) = (Value l :>) <$> suffix ts
2✔
362
    suffix (_ :> _) = fatalErrorNE $ NE.fromList ["toCtxList with too many holes, for variable " ++ show v]
×
363

364
-- | A Convenient pattern for singleton contexts
365
pattern Unary :: HOLE a' a -> ListCtx f '[a] (HOLE a')
366
pattern Unary h = NilCtx h
2✔
367

368
{-# COMPLETE Unary #-}
369

370
-- | Convenient patterns for binary contexts (the arrow :<: points towards the hole)
371
pattern (:<:) :: (Typeable b, Show b) => HOLE c a -> b -> ListCtx Value '[a, b] (HOLE c)
372
pattern h :<: a = h :? Value a :> Nil
2✔
373

374
-- | Convenient patterns for binary contexts (the arrow :>: points towards the hole)
375
pattern (:>:) :: (Typeable a, Show a) => a -> HOLE c b -> ListCtx Value '[a, b] (HOLE c)
376
pattern a :>: h = Value a :! NilCtx h
1✔
377

378
{-# COMPLETE (:<:), (:>:) #-}
379

380
-- | Flip a binary context around
381
flipCtx ::
382
  (Typeable a, Show a, Typeable b, Show b) =>
383
  ListCtx Value '[a, b] (HOLE c) -> ListCtx Value '[b, a] (HOLE c)
384
flipCtx (HOLE :<: x) = x :>: HOLE
1✔
385
flipCtx (x :>: HOLE) = HOLE :<: x
2✔
386

387
-- | From a ListCtx, build a (List Term as), to which the function symbol can be applied.
388
fromListCtx :: All HasSpec as => ListCtx Value as (HOLE a) -> Term a -> List Term as
389
fromListCtx ctx t = fillListCtx (mapListCtxC @HasSpec (\(Value a) -> Lit a) ctx) (\HOLE -> t)
2✔
390

391
-- =================================================================
392
-- The class (HasSpec a) tells us what operations type 'a' must
393
-- support to add it to the constraint solver and generator
394
-- Writing HasSpec instances gives the system the power to grow
395
-- Don't be afraid of all the methods. Most have default implementations.
396
-- =================================================================
397

398
-- | A type where the `HasSpec` instance has been instantiated via the `SimpleRep` with
399
-- constraints that give good type errors
400
type GenericallyInstantiated a =
401
  ( AssertComputes
402
      (SimpleRep a)
403
      ( Text "Trying to use a generic instantiation of "
404
          :<>: ShowType a
405
          :<>: Text ", likely in a HasSpec instance."
406
          :$$: Text
407
                 "However, the type has no definition of SimpleRep, likely because of a missing instance of HasSimpleRep."
408
      )
409
  , HasSimpleRep a
410
  , HasSpec (SimpleRep a)
411
  , TypeSpec a ~ TypeSpec (SimpleRep a)
412
  )
413

414
-- | `Eq` and `Show` for `TypeSpec` with additional constraints to ensure good type errors
415
type TypeSpecEqShow a =
416
  ( AssertComputes
417
      (TypeSpec a)
418
      ( Text "Can't compute "
419
          :<>: ShowType (TypeSpec a)
420
          :$$: Text "Either because of a missing definition of TypeSpec or a missing instance of HasSimpleRep."
421
      )
422
  , Show (TypeSpec a)
423
  , Typeable (TypeSpec a)
424
  )
425

426
{- NOTE: type errors in constrained-generators
427
    It's easy to make a mistake like this:
428
      data Bad = Bad | Worse deriving (Eq, Show)
429
      instance HasSpec Bad
430
    Missing that this requires an instance of HasSimpleRep for Bad to work.
431
    The two `AssertComputes` uses above are here to give you better error messages when you make this mistake,
432
    e.g. giving you something like this:
433
      src/Constrained/Examples/Basic.hs:327:10: error: [GHC-64725]
434
          • Can't compute TypeSpec (SimpleRep Bad)
435
            Either because of a missing definition of TypeSpec or a missing instance of HasSimpleRep.
436
          • In the instance declaration for ‘HasSpec Bad’
437
          |
438
      327 | instance HasSpec Bad
439
          |          ^^^^^^^^^^^
440

441
      src/Constrained/Examples/Basic.hs:327:10: error: [GHC-64725]
442
          • Trying to use a generic instantiation of Bad, likely in a HasSpec instance.
443
            However, the type has no definition of SimpleRep, likely because of a missing instance of HasSimpleRep.
444
          • In the expression: Constrained.Base.$dmemptySpec @(Bad)
445
            In an equation for ‘emptySpec’:
446
                emptySpec = Constrained.Base.$dmemptySpec @(Bad)
447
            In the instance declaration for ‘HasSpec Bad’
448
          |
449
      327 | instance HasSpec Bad
450
          |          ^^^^^^^^^^^
451
-}
452

453
-- | Class for talking about types that we can write `Specification`s about
454
class
455
  ( Typeable a
456
  , Eq a
457
  , Show a
458
  , TypeSpecEqShow a
459
  ) =>
460
  HasSpec a
461
  where
462
  -- | The `TypeSpec a` is the type-specific `Specification a`.
463
  type TypeSpec a
464

465
  type TypeSpec a = TypeSpec (SimpleRep a)
466

467
  -- `TypeSpec` behaves sort-of like a monoid with a neutral
468
  -- element `emptySpec` and a `combineSpec` for combining
469
  -- two `TypeSpec a`. However, in order to provide flexibilty
470
  -- `combineSpec` takes two `TypeSpec` and constucts a `Specification`. This
471
  -- avoids e.g. having to have a separate implementation of `ErrorSpec`
472
  -- and `MemberSpec` in `TypeSpec`.
473

474
  -- | Trivial `TypeSpec` that admits anything
475
  emptySpec :: TypeSpec a
476

477
  -- | Conjunction of two `TypeSpec`s
478
  combineSpec :: TypeSpec a -> TypeSpec a -> Specification a
479

480
  -- | Generate a value that satisfies the `TypeSpec`.
481
  -- The key property for this generator is soundness:
482
  --  ∀ a ∈ genFromTypeSpec spec. a `conformsTo` spec
483
  genFromTypeSpec :: (HasCallStack, MonadGenError m) => TypeSpec a -> GenT m a
484

485
  -- | Check conformance to the spec.
486
  conformsTo :: HasCallStack => a -> TypeSpec a -> Bool
487

488
  -- | Shrink an `a` with the aide of a `TypeSpec`
489
  shrinkWithTypeSpec :: TypeSpec a -> a -> [a]
490

491
  -- | Try to make an `a` conform to `TypeSpec` with minimal changes. When
492
  -- `fixupWithSpec ts a` returns `Just a'`, it should be the case that
493
  -- `conformsTo a' ts`. There are no constraints in the `Nothing` case. A
494
  -- non-trivial implementation of this function is important for shrinking.
495
  fixupWithTypeSpec :: TypeSpec a -> a -> Maybe a
496

497
  -- | Convert a spec to predicates:
498
  -- The key property here is:
499
  --   ∀ a. a `conformsTo` spec == a `conformsTo` constrained (\t -> toPreds t spec)
500
  toPreds :: Term a -> TypeSpec a -> Pred
501

502
  -- | Compute an upper and lower bound on the number of solutions genFromTypeSpec might return
503
  cardinalTypeSpec :: TypeSpec a -> Specification Integer
504

505
  -- | A bound on the number of solutions `genFromTypeSpec TrueSpec` can produce.
506
  --   For a type with finite elements, we can get a much more accurate
507
  --   answer than TrueSpec
508
  cardinalTrueSpec :: Specification Integer
509
  cardinalTrueSpec = TrueSpec
2✔
510

511
  -- Each instance can decide if a TypeSpec has an Error, and what String
512
  -- to pass to ErrorSpec to create an ErrorSpec value. Particulary
513
  -- useful for type Sum and Prod. The default instance uses guardTypeSpec,
514
  -- which also has a default value, and if that defualt value is used, typeSpecHasError will
515
  -- return Nothing. Both 'typeSpecHasError' and 'guardTypeSpec' can be set individually.
516
  -- If you're only writing one of these non default values, give it to 'guardTypeSpec'
517
  typeSpecHasError :: TypeSpec a -> Maybe (NE.NonEmpty String)
518
  typeSpecHasError tspec = case guardTypeSpec @a [] tspec of
1✔
519
    ErrorSpec msgs -> Just msgs
1✔
520
    _ -> Nothing
2✔
521

522
  -- Some binary TypeSpecs, which nest to the right
523
  -- e.g. something like this (X a (TypeSpec (X b (TypeSpec (X c w))))))
524
  -- An would look better in Vertical mode as (X [a,b,c] m).
525
  -- This lets each HasSpec instance decide. Particulary useful for type Sum and Prod
526
  alternateShow :: TypeSpec a -> BinaryShow
527
  alternateShow _ = NonBinary
×
528

529
  -- | For some types (especially finite ones) there may be much better ways to construct
530
  --   a Specification than the default method of just adding a large 'bad' list to TypSpec. This
531
  --   function allows each HasSpec instance to decide.
532
  typeSpecOpt :: TypeSpec a -> [a] -> Specification a
533
  typeSpecOpt tySpec bad = TypeSpec tySpec bad
2✔
534

535
  -- | This can be used to detect self inconsistencies in a (TypeSpec t)
536
  --   Note this is similar to 'typeSpecHasError', and the default
537
  --   value for 'typeSpecHasError' is written in terms of 'guardTypeSpec'
538
  --   Both 'typeSpecHasError' and 'guardTypeSpec' can be set individually.
539
  guardTypeSpec :: [String] -> TypeSpec a -> Specification a
540
  guardTypeSpec _ ty = typeSpec ty
1✔
541

542
  -- | Prerequisites for the instance that are sometimes necessary
543
  -- when working with e.g. `Specification`s or functions in the universe.
544
  type Prerequisites a :: Constraint
545

546
  type Prerequisites a = ()
547

548
  -- | Materialize the `Prerequisites` dictionary. It should not be necessary to
549
  -- implement this function manually.
550
  prerequisites :: Evidence (Prerequisites a)
551
  default prerequisites :: Prerequisites a => Evidence (Prerequisites a)
552
  prerequisites = Evidence
2✔
553

554
  {- NOTE: Below follows default implementations for the functions in this
555
     class based on Generics.  They are meant to provide an implementation of
556
     `HasSpec a` when `HasSimpleRep a` and `HasSpec (SimpleRep a)`. For example,
557
     for a newtype wrapper like `newtype Foo = Foo Word64` we can define `SimpleRep
558
     Foo = Word64` with the requisite instance for `HasSimpleRep` (all of which
559
     is derived from `Generic Foo`) and the instance for `HasSpec Foo` is
560
     essentially the same as the instance for `Word64`. This is achieved by
561
     ensuring that `TypeSpec Foo = TypeSpec Word64` (c.f. the default
562
     implementation of `TypeSpec` above). To this end, the implementations
563
     below simply convert the relevant things between `SimpleRep a` and `a`.
564
     For example, in the implementation of `combineSpec s s'` we treat `s` and
565
     `s'` (which have type `TypeSpec a`) as `TypeSpec (SimpleRep a)`,
566
     combine them, and go from the resulting `Specification (SimpleRep a)` to `Specification
567
     a` using `fromSimpleRepSpec`.
568
   -}
569

570
  default emptySpec :: GenericallyInstantiated a => TypeSpec a
571
  emptySpec = emptySpec @(SimpleRep a)
2✔
572

573
  default combineSpec ::
574
    GenericallyInstantiated a =>
575
    TypeSpec a ->
576
    TypeSpec a ->
577
    Specification a
578
  combineSpec s s' = fromSimpleRepSpec $ combineSpec @(SimpleRep a) s s'
2✔
579

580
  default genFromTypeSpec ::
581
    (GenericallyInstantiated a, HasCallStack, MonadGenError m) =>
582
    TypeSpec a ->
583
    GenT m a
584
  genFromTypeSpec s = fromSimpleRep <$> genFromTypeSpec s
2✔
585

586
  default conformsTo ::
587
    (GenericallyInstantiated a, HasCallStack) =>
588
    a ->
589
    TypeSpec a ->
590
    Bool
591
  a `conformsTo` s = conformsTo (toSimpleRep a) s
2✔
592

593
  default toPreds ::
594
    GenericallyInstantiated a =>
595
    Term a ->
596
    TypeSpec a ->
597
    Pred
598
  toPreds v s = toPreds (toGeneric_ v) s
2✔
599

600
  default shrinkWithTypeSpec ::
601
    GenericallyInstantiated a =>
602
    TypeSpec a ->
603
    a ->
604
    [a]
605
  shrinkWithTypeSpec spec a = map fromSimpleRep $ shrinkWithTypeSpec spec (toSimpleRep a)
2✔
606

607
  default fixupWithTypeSpec ::
608
    GenericallyInstantiated a =>
609
    TypeSpec a ->
610
    a ->
611
    Maybe a
612
  fixupWithTypeSpec spec a = fromSimpleRep <$> fixupWithTypeSpec spec (toSimpleRep a)
2✔
613

614
  default cardinalTypeSpec ::
615
    GenericallyInstantiated a =>
616
    TypeSpec a ->
617
    Specification Integer
618
  cardinalTypeSpec = cardinalTypeSpec @(SimpleRep a)
2✔
619

620
------------------------------------------------------------------------
621
-- Some instances of HasSpec
622
------------------------------------------------------------------------
623

624
-- | NOTE: this instance means we have to use `ifElse`, `whenTrue`, and `whenFalse` instead
625
-- of `caseOn` for `Bool`
626
instance HasSpec Bool where
×
627
  type TypeSpec Bool = ()
628
  emptySpec = ()
×
629
  combineSpec _ _ = typeSpec ()
1✔
630
  genFromTypeSpec _ = pureGen arbitrary
2✔
631
  cardinalTypeSpec _ = equalSpec 2
2✔
632
  cardinalTrueSpec = equalSpec 2
2✔
633
  shrinkWithTypeSpec _ = shrink
2✔
634
  fixupWithTypeSpec _ = Just
×
635
  conformsTo _ _ = True
2✔
636
  toPreds _ _ = TruePred
2✔
637

638
instance HasSpec () where
×
639
  type TypeSpec () = ()
640
  emptySpec = ()
×
641
  combineSpec _ _ = typeSpec ()
×
642
  _ `conformsTo` _ = True
2✔
643
  shrinkWithTypeSpec _ _ = []
2✔
644
  fixupWithTypeSpec _ _ = pure ()
×
645
  genFromTypeSpec _ = pure ()
2✔
646
  toPreds _ _ = TruePred
2✔
647
  cardinalTypeSpec _ = MemberSpec (pure 1)
×
648
  cardinalTrueSpec = equalSpec 1
1✔
649
  typeSpecOpt _ [] = TrueSpec
2✔
650
  typeSpecOpt _ (_ : _) = ErrorSpec (pure "Non null 'cant' set in typeSpecOpt @()")
×
651

652
-- ===================================================================
653
-- toGeneric and fromGeneric as Function Symbols
654
-- That means they can be used inside (Term a)
655
-- ===================================================================
656

657
-- | The things you need to know to work with the generics which translates things
658
-- into their SimpleRep, made of Sum and Prod
659
type GenericRequires a =
660
  ( HasSpec a -- This gives Show, Eq, and Typeable instances
661
  , GenericallyInstantiated a
662
  )
663

664
-- | The constructors of BaseW, are first order data (i.e Function Symbols) that describe functions.
665
-- The Base functions are just the functions neccessary to define Specification, and the classes
666
-- HasSimpleRep, HasSpec, Syntax, Semantics, and Logic. We call BaseW a 'witness type', and use
667
-- the convention that all witness types (and their constructors) have "W" as thrit last character.
668
data BaseW (dom :: [Type]) (rng :: Type) where
669
  ToGenericW :: GenericRequires a => BaseW '[a] (SimpleRep a)
670
  FromGenericW :: GenericRequires a => BaseW '[SimpleRep a] a
671

672
deriving instance Eq (BaseW dom rng)
×
673

674
instance Show (BaseW d r) where
×
675
  show ToGenericW = "toSimpleRep"
2✔
676
  show FromGenericW = "fromSimpleRep"
2✔
677

NEW
678
instance Syntax BaseW
×
679

680
instance Semantics BaseW where
681
  semantics FromGenericW = fromSimpleRep
2✔
682
  semantics ToGenericW = toSimpleRep
2✔
683

684
-- -- ============== ToGenericW Logic instance
685

686
instance Logic BaseW where
1✔
687
  propagateTypeSpec ToGenericW (Unary HOLE) s cant = TypeSpec s (fromSimpleRep <$> cant)
2✔
688
  propagateTypeSpec FromGenericW (Unary HOLE) s cant = TypeSpec s (toSimpleRep <$> cant)
2✔
689

690
  propagateMemberSpec ToGenericW (Unary HOLE) es = MemberSpec (fmap fromSimpleRep es)
2✔
691
  propagateMemberSpec FromGenericW (Unary HOLE) es = MemberSpec (fmap toSimpleRep es)
2✔
692

693
  mapTypeSpec ToGenericW ts = typeSpec ts
2✔
694
  mapTypeSpec FromGenericW ts = typeSpec ts
2✔
695

696
  rewriteRules ToGenericW (FromGeneric x :> Nil) Evidence = Just x
2✔
697
  rewriteRules (FromGenericW :: BaseW dom rng) (ToGeneric (x :: Term a) :> Nil) Evidence
698
    | Just Refl <- eqT @rng @a = Just x
2✔
699
  rewriteRules _ _ _ = Nothing
2✔
700

701
-- | Convert an @a@ to a @`SimpleRep` a@
702
toGeneric_ ::
703
  forall a.
704
  GenericRequires a =>
705
  Term a ->
706
  Term (SimpleRep a)
707
toGeneric_ = appTerm ToGenericW
2✔
708

709
-- | Convert an @`SimpleRep` a@ to an @a@
710
fromGeneric_ ::
711
  forall a.
712
  (GenericRequires a, AppRequires BaseW '[SimpleRep a] a) =>
713
  Term (SimpleRep a) ->
714
  Term a
715
fromGeneric_ = appTerm FromGenericW
2✔
716

717
-- ====================================================================
718
-- Generic Transformers
719
-- Using Generics to transform from ordinary (Specifications a) to
720
-- Specifications over 'a's SimpleRep (Specification (SimpleRep a))
721
-- ====================================================================
722

723
-- | Convert a `Specification` for a @`SimpleRep` a@ to one for @a@
724
fromSimpleRepSpec ::
725
  GenericRequires a =>
726
  Specification (SimpleRep a) ->
727
  Specification a
728
fromSimpleRepSpec = \case
2✔
729
  ExplainSpec es s -> explainSpec es (fromSimpleRepSpec s)
×
730
  TrueSpec -> TrueSpec
×
731
  ErrorSpec e -> ErrorSpec e
1✔
732
  TypeSpec s'' cant -> TypeSpec s'' $ map fromSimpleRep cant
1✔
733
  MemberSpec elems -> MemberSpec $ NE.nub (fmap fromSimpleRep elems)
×
734
  SuspendedSpec x p ->
735
    constrained $ \x' ->
×
736
      Let (toGeneric_ x') (x :-> p) :: Pred
×
737

738
-- | Convert a @`Specification` a@ to one for @`SimpleRep` a@
739
toSimpleRepSpec ::
740
  forall a.
741
  GenericRequires a =>
742
  Specification a ->
743
  Specification (SimpleRep a)
744
toSimpleRepSpec = \case
×
745
  ExplainSpec es s -> explainSpec es (toSimpleRepSpec s)
×
746
  TrueSpec -> TrueSpec
×
747
  ErrorSpec e -> ErrorSpec e
×
748
  TypeSpec s'' cant -> TypeSpec s'' $ map toSimpleRep cant
×
749
  MemberSpec elems -> MemberSpec $ NE.nub $ fmap toSimpleRep elems
×
750
  SuspendedSpec x p ->
751
    constrained $ \x' ->
×
752
      Let (fromGeneric_ x') (x :-> p) :: Pred
×
753

754
-- =====================================================================
755
-- Now the supporting operations and types.
756
-- =====================================================================
757

758
-- | Used to show binary operators like SumSpec and PairSpec
759
data BinaryShow where
760
  BinaryShow :: forall a. String -> [Doc a] -> BinaryShow
761
  NonBinary :: BinaryShow
762

763
-- =================================================
764
-- Term
765

766
-- | Like 'appSym' but builds functions over terms, rather that just one App term.
767
appTerm ::
768
  forall t ds r.
769
  AppRequires t ds r =>
770
  t ds r ->
771
  FunTy (MapList Term ds) (Term r)
772
appTerm sym = curryList @ds (App @Deps @t @ds @r sym)
2✔
773

774
-- | Give a `Term` a `String` name-hint _if_ the `Term` is a variable
775
name :: String -> Term a -> Term a
776
name nh (V (Var i _)) = V (Var i nh)
2✔
777
name _ _ = error "applying name to non-var thing! Shame on you!"
×
778

779
-- | Create a `Binder` with a fresh variable, used in e.g. `constrained`
780
bind :: (HasSpec a, IsPred p) => (Term a -> p) -> Binder a
781
bind bodyf = newv :-> bodyPred
2✔
782
  where
783
    bodyPred = toPred body
2✔
784
    newv = Var (nextVar bodyPred) "v"
2✔
785
    body = bodyf (V newv)
2✔
786

787
    nextVar q = 1 + bound q
2✔
788

789
    boundBinder :: Binder a -> Int
790
    boundBinder (x :-> p) = max (nameOf x) (bound p)
2✔
791

792
    bound (ElemPred _ _ _) = -1
2✔
793
    bound (Explain _ p) = bound p
2✔
794
    bound (Subst x _ p) = max (nameOf x) (bound p)
2✔
795
    bound (And ps) = maximum $ (-1) : map bound ps -- (-1) as the default to get 0 as `nextVar p`
2✔
796
    bound (Exists _ b) = boundBinder b
2✔
797
    bound (Let _ b) = boundBinder b
2✔
798
    bound (ForAll _ b) = boundBinder b
2✔
799
    bound (Case _ cs) = getMax $ foldMapList (Max . boundBinder . thing) cs
2✔
800
    bound (When _ p) = bound p
2✔
801
    bound Reifies {} = -1
2✔
802
    bound GenHintD {} = -1
2✔
803
    bound Assert {} = -1
2✔
804
    bound DependsOn {} = -1
2✔
805
    bound TruePred = -1
2✔
806
    bound FalsePred {} = -1
2✔
807
    bound Monitor {} = -1
2✔
808

809
-- ==================================================
810
-- Pred
811

812
-- | A collection @t@ with elements of type @e@ where the `forAll` syntax will
813
-- work
814
class Forallable t e | t -> e where
815
  -- | Lift the `Specification` for the elements to the collection
816
  fromForAllSpec ::
817
    (HasSpec t, HasSpec e) => Specification e -> Specification t
818
  default fromForAllSpec ::
819
    ( HasSpec e
820
    , Forallable (SimpleRep t) e
821
    , GenericRequires t
822
    ) =>
823
    Specification e ->
824
    Specification t
825
  fromForAllSpec es = fromSimpleRepSpec $ fromForAllSpec @(SimpleRep t) @e es
2✔
826

827
  -- | Get the underlying items in the collection
828
  forAllToList :: t -> [e]
829
  default forAllToList ::
830
    ( HasSimpleRep t
831
    , Forallable (SimpleRep t) e
832
    ) =>
833
    t ->
834
    [e]
835
  forAllToList t = forAllToList (toSimpleRep t)
2✔
836

837
-- ===========================================
838
-- IsPred
839

840
-- | Something from which we can construct a `Pred`, useful for providing
841
-- flexible syntax for `constrained` and friends.
842
class Show p => IsPred p where
843
  -- | Convert to a `Pred`
844
  toPred :: p -> Pred
845

846
instance IsPred Pred where
847
  toPred (Assert (Lit False)) = FalsePred (pure "toPred(Lit False)")
1✔
848
  toPred (Assert (Lit True)) = TruePred
2✔
849
  toPred (Explain xs p) = Explain xs (toPred p)
2✔
850
  toPred (And ps) = And (map toPred ps)
2✔
851
  toPred x = x
2✔
852

853
instance IsPred p => IsPred [p] where
854
  toPred xs = And (map toPred xs)
2✔
855

856
instance IsPred Bool where
857
  toPred True = TruePred
2✔
858
  toPred False = FalsePred (pure "toPred False")
1✔
859

860
instance IsPred (Term Bool) where
861
  toPred (Lit b) = toPred b
1✔
862
  toPred term = Assert term
2✔
863

864
-- ============================================================
865
-- Simple Widely used operations on Specification
866

867
-- | return a MemberSpec or ans ErrorSpec depending on if 'xs' is null or not
868
memberSpec :: Foldable f => f a -> NE.NonEmpty String -> Specification a
869
memberSpec (toList -> xs) messages =
2✔
870
  case NE.nonEmpty xs of
2✔
871
    Nothing -> ErrorSpec messages
1✔
872
    Just ys -> MemberSpec ys
2✔
873

874
-- | Attach an explanation to a specification in order to track issues with satisfiability
875
explainSpec :: [String] -> Specification a -> Specification a
876
explainSpec [] x = x
1✔
877
explainSpec es (ExplainSpec es' spec) = ExplainSpec (es ++ es') spec
1✔
878
explainSpec es spec = ExplainSpec es spec
2✔
879

880
-- | A "discrete" specification satisfied by exactly one element
881
equalSpec :: a -> Specification a
882
equalSpec = MemberSpec . pure
2✔
883

884
-- | Anything but this
885
notEqualSpec :: forall a. HasSpec a => a -> Specification a
886
notEqualSpec = TypeSpec (emptySpec @a) . pure
2✔
887

888
-- | Anything but these
889
notMemberSpec :: forall a f. (HasSpec a, Foldable f) => f a -> Specification a
890
notMemberSpec = typeSpecOpt (emptySpec @a) . toList
2✔
891

892
-- | Build a `Specification` using predicates, e.g.
893
-- > constrained $ \ x -> assert $ x `elem_` lit [1..10 :: Int]
894
constrained ::
895
  forall a p.
896
  (IsPred p, HasSpec a) =>
897
  (Term a -> p) ->
898
  Specification a
899
constrained body =
2✔
900
  let x :-> p = bind body
2✔
901
   in SuspendedSpec x p
2✔
902

903
-- | Sound but not complete check for empty `Specification`s
904
isErrorLike :: forall a. Specification a -> Bool
905
isErrorLike (ExplainSpec _ s) = isErrorLike s
2✔
906
isErrorLike ErrorSpec {} = True
2✔
907
isErrorLike (TypeSpec x _) =
908
  case typeSpecHasError @a x of
2✔
909
    Nothing -> False
2✔
910
    Just _ -> True
2✔
911
isErrorLike _ = False
2✔
912

913
-- | Get the error message of an `isErrorLike` `Specification`
914
errorLikeMessage :: forall a. Specification a -> NE.NonEmpty String
915
errorLikeMessage (ErrorSpec es) = es
×
916
errorLikeMessage (TypeSpec x _) =
917
  case typeSpecHasError @a x of
×
918
    Nothing -> pure ("Bad call to errorLikeMessage case 1, not guarded by isErrorLike")
×
919
    Just xs -> xs
×
920
errorLikeMessage _ = pure ("Bad call to errorLikeMessage, case 2, not guarded by isErrorLike")
×
921

922
-- | Add the explanations, if it's an ErrorSpec, else drop them
923
addToErrorSpec :: NE.NonEmpty String -> Specification a -> Specification a
924
addToErrorSpec es (ExplainSpec [] x) = addToErrorSpec es x
1✔
925
addToErrorSpec es (ExplainSpec es2 x) = ExplainSpec es2 (addToErrorSpec es x)
×
926
addToErrorSpec es (ErrorSpec es') = ErrorSpec (es <> es')
1✔
927
addToErrorSpec _ s = s
2✔
928

929
------------------------------------------------------------------------
930
-- Pretty and Show instances
931
------------------------------------------------------------------------
932

933
-- | The Fun type encapuslates a Logic instance and symbol universe type to
934
-- hide everything but the domain and range. This is a way to pass around
935
-- functions without pain. Usefull in the ListFoldy implementaion that deals
936
-- with higher order functions.
937
data Fun dom rng where
938
  Fun ::
939
    forall t dom rng.
940
    AppRequires t dom rng =>
941
    t dom rng ->
942
    Fun dom rng
943

944
instance Show (Fun dom r) where
×
945
  show (Fun (f :: t dom rng)) = "(Fun " ++ show f ++ ")"
2✔
946

947
-- | Apply a single-argument `Fun` to a `Term`
948
appFun :: Fun '[x] b -> Term x -> Term b
949
appFun (Fun f) x = App f (x :> Nil)
2✔
950

951
sameFun :: Fun d1 r1 -> Fun d2 r2 -> Bool
952
sameFun (Fun f) (Fun g) = case cast f of
2✔
953
  Just f' -> f' == g
2✔
954
  Nothing -> False
×
955

956
instance Eq (Fun d r) where
×
957
  (==) = sameFun
2✔
958

959
-- | Pattern-match on an application of `fromGeneric_`, useful for writing
960
-- custom rewrite rules to help the solver
961
pattern FromGeneric ::
962
  forall rng.
963
  () =>
964
  forall a.
965
  (rng ~ a, GenericRequires a, HasSpec a, AppRequires BaseW '[SimpleRep a] rng) =>
966
  Term (SimpleRep a) ->
967
  Term rng
968
pattern FromGeneric x <-
969
  (App (getWitness -> Just FromGenericW) (x :> Nil))
2✔
970

971
-- | Pattern-match on an application of `toGeneric_`, useful for writing custom
972
-- rewrite rules to help the solver
973
pattern ToGeneric ::
974
  forall rng.
975
  () =>
976
  forall a.
977
  (rng ~ SimpleRep a, GenericRequires a, HasSpec a, AppRequires BaseW '[a] rng) =>
978
  Term a ->
979
  Term rng
980
pattern ToGeneric x <- (App (getWitness -> Just ToGenericW) (x :> Nil))
2✔
981

982
-- | Hints are things that only affect generation, and not validation. For instance, parameters to
983
--   control distribution of generated values.
984
class (HasSpec a, Show (Hint a)) => HasGenHint a where
985
  type Hint a
986
  giveHint :: Hint a -> Specification a
STATUS · Troubleshooting · Open an Issue · Sales · Support · CAREERS · ENTERPRISE · START FREE · SCHEDULE DEMO
ANNOUNCEMENTS · TWITTER · TOS & SLA · Supported CI Services · What's a CI service? · Automated Testing

© 2026 Coveralls, Inc