{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

-- The pattern completeness checker is much weaker before ghc-9.0. Rather than introducing redundant
-- cases and turning off the overlap check in newer ghc versions we disable the check for old
-- versions.
#if __GLASGOW_HASKELL__ < 900
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
#endif

-- | This module contains most of the implementation
-- of the framework.
--
-- NOTE: This is a very big module. Splitting it up would
-- be a nice thing to do but it's not very easy. The problem
-- is that a lot of the things in here depend on each other
-- via a cycle like `Pred` depends on `Term` which depend on
-- `HasSpec` which depends on `Specification` and `Generic` and `Specification`
-- depends in turn on `Pred` and so on.
module Constrained.Base where

import Control.Applicative
import Control.Arrow (first)
import Control.Exception (SomeException, catch)
import Control.Monad
import Control.Monad.Identity
import Control.Monad.Writer (Writer, runWriter, tell)
import Data.Foldable
import Data.Kind
import Data.List (intersect, isPrefixOf, isSuffixOf, nub, partition, (\\))
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe
import Data.Monoid qualified as Monoid
import Data.Semigroup (Any (..), Max (..), getAll, getMax, sconcat)
import Data.Semigroup qualified as Semigroup
import Data.Set (Set)
import Data.Set qualified as Set
import Data.String
import Data.Typeable
import Data.Word
import GHC.Generics
import GHC.Int
import GHC.Natural
import GHC.Real
import GHC.Stack
import GHC.TypeLits
import Prettyprinter
import System.IO.Unsafe
import System.Random
import System.Random.Stateful
import Test.QuickCheck hiding (Args, Fun, forAll)
import Test.QuickCheck.Gen
import Test.QuickCheck.Random

import Constrained.Core
import Constrained.Env
import Constrained.GenT
import Constrained.Graph hiding (dependency, irreflexiveDependencyOn, noDependencies)
import Constrained.Graph qualified as Graph
import Constrained.List
import Constrained.Univ
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.List.NonEmpty qualified as NE

{- NOTE [High level overview of generation from predicates]:

-- The overall strategy ---------------------------------------------------

The strategy for generating things from `Pred`s is relatively straightforward
and relies on one key fact: any constraint that has only one free variable `x`
and where `x` occurs only once can be turned into a `Specification` for `x`.

We say that such constraints _define_ `x` and given a set of constraints `ps`
and a variable `x` we can split `ps` into the constraints that define `x` and
any constraints that don't. We can then generate a value from `x` by computing
a spec for each defining constraint in `ps` and using the `Semigroup` structure
of `Specification`s to combine them and give them to `genFromSpecT`. Once we obtain a
value for `x` we can substitute this value in all other constraints and pick
another variable to solve.

For example, given the following constraints on integers `x` and `y`

  x < 10
  3 <= x
  y < x

we see that `x < 10` and `3 <= x` are defining constraints for `x` and there
are no definining constraints for `y`. We compute a `Specification` for `x` for each
constraint, in this case `x < 10` turns into something like `(-∞,10)` and
`3 <= x` turns into `[3, ∞)`. We combine the specs to form `[3, 10)` from which we
can generate a value, e.g. 4 (chosen by fair dice roll). We then substitute
`[x := 4]` in the remaining constraints and obtain `y < 4`, giving us a defining
constraint for `y`.

-- How to pick the variable order -----------------------------------------

At this point it should be relatively clear that the order we pick for the
variables matters a great deal. If we choose to generate `y` before `x` in our
example we will have no defining constraints for `y` and so we pick a value for
it freely. But that renders `x` unsolveable if `y > 9` - which will result in
the generator failing to generate a value (one could consider backtracking, but
that is very computationally expensive so _relying_ on it would probably not be
wise).

Computing a good choice of variable order that leaves the least room for error
is obviously undecidable and difficult and we choose instead an explicit
syntax-directed variable order. Specifically, variable dependency in terms is
_left-to-right_, meaning that the variables in `x + y < z` will be solved in
the order `z -> y -> x`. On top of that there is a constraint `dependsOn y x`
that allows you to overwrite the order of two variables. Consequently, the
following constraints will be solved in the order `z -> x -> y`:

  x + y < z
  y `dependsOn` x

A consequence of this is that it is possible to form dependency loops by
specifying multiple constraints, e.g. in:

  x < y
  y < x + 10

However, this situation can be addressed by the introduction of `dependsOn` to
settle the order.  It is worth noting that the choice of order in `dependsOn`
is important as it affects the solveability of the constraints (as we saw
above). We leave the choice of `dependsOn` in the example below as an exercise
for the reader.

  x < y
  y < x + 10
  0 < x
  ? `dependsOn` ?

-- The total definition requirement ---------------------------------------

For the sake of efficiency we require that all constraints are dispatched as
definining constraints for a variable before we begin solving. We call this the
total definition requirement. This requirement is necessary because a set of
constraints with left over constraints are unlikely to be solveable.

Consider the following example for `p :: (Int, Int)`

fst p < snd p

in which there is no defining constraint for `p`, which would lead us to
compute the spec `mempty` for `p` during solving - meaning we would pick an
arbitrary `p` that is irrespective of the constraints. This is problematic as
the probability of picking `p = (x, y)` such that `x < y` is roughly `1/2`, as
you add more constraints things get much worse.

The principal problem above is that information that is present in the
constraints is lost, which would force us to rely on a `suchThat` approach to
generation - which will become very slow as constraint systems grow.

-- Let binders ------------------------------------------------------------

A solution to the total definition requirement is to introduce more variables.
We can rewrite the problematic `fst p < snd p` example below as:

fst p = x
snd p = y
x < y

The dependency graph for these constraints will be the following:

x `dependsOn` y
p `dependsOn` x

This configuration is solveable, one picks `y` first, then picks `x < y`
and finally constructs `p = (x, y)`.

Note that (1) we introduced more variables than were initially in the
constraints - these need to be bound somewhere - and (2) the order of
`fst p = x` is important - `p` depends on `x` and not the other way
around.

To do both of these things at the same time we introduce the `letBind` construct
to the language:

letBind tm $ \ x -> preds

Which is semantically equivalent to:

exists $ \ x ->
  tm == x
  preds

-- Reifies ----------------------------------------------------------------

Sometimes it's important to be able to perform complex calculations on data
to obtain values that further constrain later variables. For this purpose
the language contains the the `reify` construct:

reify :: IsPred p fn
      => Term fn a
      -> (a -> b)
      -> (Term fn b -> p)
      -> Pred fn

The important thing about `reify` is that because everything in the term
being reified needs to be solved before the body can be solved, all
variables in the body depend on the term being reified.

-}

------------------------------------------------------------------------
-- Terms and Predicates
------------------------------------------------------------------------

-- | Typed first order terms with function symbols from `fn`.
data Term (fn :: [Type] -> Type -> Type) a where
  App ::
    ( Typeable as
    , TypeList as
    , All (HasSpec fn) as
    , HasSpec fn b
    , BaseUniverse fn
    ) =>
    fn as b ->
    List (Term fn) as ->
    Term fn b
  Lit ::
    Show a =>
    a ->
    Term fn a
  V ::
    HasSpec fn a =>
    Var a ->
    Term fn a

instance HasSpec fn a => Eq (Term fn a) where
  V Var a
x == :: Term fn a -> Term fn a -> Bool
== V Var a
x' = Var a
x forall a. Eq a => a -> a -> Bool
== Var a
x'
  Lit a
a == Lit a
b = a
a forall a. Eq a => a -> a -> Bool
== a
b
  App (fn as a
f :: fn as b) List (Term fn) as
ts == App (fn as a
f' :: fn as' b') List (Term fn) as
ts'
    | Just as :~: as
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @as @as'
    , fn as a
f forall a. Eq a => a -> a -> Bool
== fn as a
f' =
        forall {k} (c :: k -> Constraint) (as :: [k]) (f :: k -> *)
       (g :: k -> *).
All c as =>
(forall (a :: k). c a => f a -> g a) -> List f as -> List g as
mapListC @(HasSpec fn) (forall (fn :: [*] -> * -> *) a (f :: * -> *).
HasSpec fn a =>
f a -> WithHasSpec fn f a
WithHasSpec @fn) List (Term fn) as
ts
          forall a. Eq a => a -> a -> Bool
== forall {k} (c :: k -> Constraint) (as :: [k]) (f :: k -> *)
       (g :: k -> *).
All c as =>
(forall (a :: k). c a => f a -> g a) -> List f as -> List g as
mapListC @(HasSpec fn) (forall (fn :: [*] -> * -> *) a (f :: * -> *).
HasSpec fn a =>
f a -> WithHasSpec fn f a
WithHasSpec @fn) List (Term fn) as
ts'
  Term fn a
_ == Term fn a
_ = Bool
False

-- NOTE: Fourmolu made me do this - it happily breaks the code unless you
-- make this a standalone type synonym.
type HasSpecImpliesEq fn a f = HasSpec fn a => Eq (f a) :: Constraint
deriving instance HasSpecImpliesEq fn a f => Eq (WithHasSpec fn f a)

instance (Ord a, Show a, Typeable a, HasSpec fn (Set a)) => Semigroup (Term fn (Set a)) where
  <> :: Term fn (Set a) -> Term fn (Set a) -> Term fn (Set a)
(<>) = forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app (forall (fn :: [*] -> * -> *) a.
(Member (SetFn fn) fn, Ord a, Show a, Typeable a) =>
fn '[Set a, Set a] (Set a)
unionFn @fn @a)

instance (Ord a, Show a, Typeable a, HasSpec fn (Set a)) => Monoid (Term fn (Set a)) where
  mempty :: Term fn (Set a)
mempty = forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit forall a. Monoid a => a
mempty

data Binder fn a where
  (:->) ::
    HasSpec fn a =>
    Var a ->
    Pred fn ->
    Binder fn a

deriving instance Show (Binder fn a)

data Pred (fn :: [Type] -> Type -> Type) where
  Monitor :: ((forall a. Term fn a -> a) -> Property -> Property) -> Pred fn
  Block ::
    [Pred fn] ->
    Pred fn
  Exists ::
    -- | Constructive recovery function for checking
    -- existential quantification
    ((forall b. Term fn b -> b) -> GE a) ->
    Binder fn a ->
    Pred fn
  Subst ::
    HasSpec fn a =>
    Var a ->
    Term fn a ->
    Pred fn ->
    Pred fn
  Let ::
    Term fn a ->
    Binder fn a ->
    Pred fn
  Assert ::
    BaseUniverse fn =>
    Term fn Bool ->
    Pred fn
  Reifies ::
    ( HasSpec fn a
    , HasSpec fn b
    ) =>
    -- | This depends on the `a` term
    Term fn b ->
    Term fn a ->
    -- | Recover a useable value from the `a` term.
    (a -> b) ->
    Pred fn
  -- TODO: there is good cause for not limiting this to `Term fn a` and `Term fn b`.
  -- However, changing it requires re-working quite a lot of code.
  DependsOn ::
    ( HasSpec fn a
    , HasSpec fn b
    ) =>
    Term fn a ->
    Term fn b ->
    Pred fn
  ForAll ::
    ( Forallable t a
    , HasSpec fn t
    , HasSpec fn a
    ) =>
    Term fn t ->
    Binder fn a ->
    Pred fn
  Case ::
    HasSpec fn (SumOver as) =>
    Term fn (SumOver as) ->
    -- | Each branch of the type is bound with
    -- only one variable because `as` are types.
    -- Constructors with multiple arguments are
    -- encoded with `ProdOver` (c.f. `Constrained.Univ`).
    List (Weighted (Binder fn)) as ->
    Pred fn
  -- monadic-style `when` - if the first argument is False the second
  -- doesn't apply.
  When ::
    HasSpec fn Bool =>
    Term fn Bool ->
    Pred fn ->
    Pred fn
  GenHint ::
    HasGenHint fn a =>
    Hint a ->
    Term fn a ->
    Pred fn
  TruePred :: Pred fn
  FalsePred :: NE.NonEmpty String -> Pred fn
  Explain :: NE.NonEmpty String -> Pred fn -> Pred fn

falsePred1 :: String -> Pred fn
falsePred1 :: forall (fn :: [*] -> * -> *). [Char] -> Pred fn
falsePred1 [Char]
s = forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn
FalsePred (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
s)

data Weighted f a = Weighted {forall (f :: * -> *) a. Weighted f a -> Maybe Int
weight :: Maybe Int, forall (f :: * -> *) a. Weighted f a -> f a
thing :: f a}
  deriving (forall a b. a -> Weighted f b -> Weighted f a
forall a b. (a -> b) -> Weighted f a -> Weighted f b
forall (f :: * -> *) a b.
Functor f =>
a -> Weighted f b -> Weighted f a
forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> Weighted f a -> Weighted f b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Weighted f b -> Weighted f a
$c<$ :: forall (f :: * -> *) a b.
Functor f =>
a -> Weighted f b -> Weighted f a
fmap :: forall a b. (a -> b) -> Weighted f a -> Weighted f b
$cfmap :: forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> Weighted f a -> Weighted f b
Functor, forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall {f :: * -> *}. Traversable f => Functor (Weighted f)
forall {f :: * -> *}. Traversable f => Foldable (Weighted f)
forall (f :: * -> *) (m :: * -> *) a.
(Traversable f, Monad m) =>
Weighted f (m a) -> m (Weighted f a)
forall (f :: * -> *) (f :: * -> *) a.
(Traversable f, Applicative f) =>
Weighted f (f a) -> f (Weighted f a)
forall (f :: * -> *) (m :: * -> *) a b.
(Traversable f, Monad m) =>
(a -> m b) -> Weighted f a -> m (Weighted f b)
forall (f :: * -> *) (f :: * -> *) a b.
(Traversable f, Applicative f) =>
(a -> f b) -> Weighted f a -> f (Weighted f b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Weighted f a -> f (Weighted f b)
sequence :: forall (m :: * -> *) a.
Monad m =>
Weighted f (m a) -> m (Weighted f a)
$csequence :: forall (f :: * -> *) (m :: * -> *) a.
(Traversable f, Monad m) =>
Weighted f (m a) -> m (Weighted f a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Weighted f a -> m (Weighted f b)
$cmapM :: forall (f :: * -> *) (m :: * -> *) a b.
(Traversable f, Monad m) =>
(a -> m b) -> Weighted f a -> m (Weighted f b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Weighted f (f a) -> f (Weighted f a)
$csequenceA :: forall (f :: * -> *) (f :: * -> *) a.
(Traversable f, Applicative f) =>
Weighted f (f a) -> f (Weighted f a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Weighted f a -> f (Weighted f b)
$ctraverse :: forall (f :: * -> *) (f :: * -> *) a b.
(Traversable f, Applicative f) =>
(a -> f b) -> Weighted f a -> f (Weighted f b)
Traversable, forall a. Weighted f a -> Bool
forall m a. Monoid m => (a -> m) -> Weighted f a -> m
forall a b. (a -> b -> b) -> b -> Weighted f a -> b
forall (f :: * -> *) a.
(Foldable f, Eq a) =>
a -> Weighted f a -> Bool
forall (f :: * -> *) a. (Foldable f, Num a) => Weighted f a -> a
forall (f :: * -> *) a. (Foldable f, Ord a) => Weighted f a -> a
forall (f :: * -> *) m. (Foldable f, Monoid m) => Weighted f m -> m
forall (f :: * -> *) a. Foldable f => Weighted f a -> Bool
forall (f :: * -> *) a. Foldable f => Weighted f a -> Int
forall (f :: * -> *) a. Foldable f => Weighted f a -> [a]
forall (f :: * -> *) a.
Foldable f =>
(a -> a -> a) -> Weighted f a -> a
forall (f :: * -> *) m a.
(Foldable f, Monoid m) =>
(a -> m) -> Weighted f a -> m
forall (f :: * -> *) b a.
Foldable f =>
(b -> a -> b) -> b -> Weighted f a -> b
forall (f :: * -> *) a b.
Foldable f =>
(a -> b -> b) -> b -> Weighted f a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => Weighted f a -> a
$cproduct :: forall (f :: * -> *) a. (Foldable f, Num a) => Weighted f a -> a
sum :: forall a. Num a => Weighted f a -> a
$csum :: forall (f :: * -> *) a. (Foldable f, Num a) => Weighted f a -> a
minimum :: forall a. Ord a => Weighted f a -> a
$cminimum :: forall (f :: * -> *) a. (Foldable f, Ord a) => Weighted f a -> a
maximum :: forall a. Ord a => Weighted f a -> a
$cmaximum :: forall (f :: * -> *) a. (Foldable f, Ord a) => Weighted f a -> a
elem :: forall a. Eq a => a -> Weighted f a -> Bool
$celem :: forall (f :: * -> *) a.
(Foldable f, Eq a) =>
a -> Weighted f a -> Bool
length :: forall a. Weighted f a -> Int
$clength :: forall (f :: * -> *) a. Foldable f => Weighted f a -> Int
null :: forall a. Weighted f a -> Bool
$cnull :: forall (f :: * -> *) a. Foldable f => Weighted f a -> Bool
toList :: forall a. Weighted f a -> [a]
$ctoList :: forall (f :: * -> *) a. Foldable f => Weighted f a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Weighted f a -> a
$cfoldl1 :: forall (f :: * -> *) a.
Foldable f =>
(a -> a -> a) -> Weighted f a -> a
foldr1 :: forall a. (a -> a -> a) -> Weighted f a -> a
$cfoldr1 :: forall (f :: * -> *) a.
Foldable f =>
(a -> a -> a) -> Weighted f a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Weighted f a -> b
$cfoldl' :: forall (f :: * -> *) b a.
Foldable f =>
(b -> a -> b) -> b -> Weighted f a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Weighted f a -> b
$cfoldl :: forall (f :: * -> *) b a.
Foldable f =>
(b -> a -> b) -> b -> Weighted f a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Weighted f a -> b
$cfoldr' :: forall (f :: * -> *) a b.
Foldable f =>
(a -> b -> b) -> b -> Weighted f a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Weighted f a -> b
$cfoldr :: forall (f :: * -> *) a b.
Foldable f =>
(a -> b -> b) -> b -> Weighted f a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Weighted f a -> m
$cfoldMap' :: forall (f :: * -> *) m a.
(Foldable f, Monoid m) =>
(a -> m) -> Weighted f a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Weighted f a -> m
$cfoldMap :: forall (f :: * -> *) m a.
(Foldable f, Monoid m) =>
(a -> m) -> Weighted f a -> m
fold :: forall m. Monoid m => Weighted f m -> m
$cfold :: forall (f :: * -> *) m. (Foldable f, Monoid m) => Weighted f m -> m
Foldable)

mapWeighted :: (f a -> g b) -> Weighted f a -> Weighted g b
mapWeighted :: forall (f :: * -> *) a (g :: * -> *) b.
(f a -> g b) -> Weighted f a -> Weighted g b
mapWeighted f a -> g b
f (Weighted Maybe Int
w f a
t) = forall (f :: * -> *) a. Maybe Int -> f a -> Weighted f a
Weighted Maybe Int
w (f a -> g b
f f a
t)

traverseWeighted :: Applicative m => (f a -> m (g a)) -> Weighted f a -> m (Weighted g a)
traverseWeighted :: forall (m :: * -> *) (f :: * -> *) a (g :: * -> *).
Applicative m =>
(f a -> m (g a)) -> Weighted f a -> m (Weighted g a)
traverseWeighted f a -> m (g a)
f (Weighted Maybe Int
w f a
t) = forall (f :: * -> *) a. Maybe Int -> f a -> Weighted f a
Weighted Maybe Int
w forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a -> m (g a)
f f a
t

instance BaseUniverse fn => Semigroup (Pred fn) where
  FalsePred NonEmpty [Char]
xs <> :: Pred fn -> Pred fn -> Pred fn
<> FalsePred NonEmpty [Char]
ys = forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn
FalsePred (NonEmpty [Char]
xs forall a. Semigroup a => a -> a -> a
<> NonEmpty [Char]
ys)
  FalsePred NonEmpty [Char]
es <> Pred fn
_ = forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn
FalsePred NonEmpty [Char]
es
  Pred fn
_ <> FalsePred NonEmpty [Char]
es = forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn
FalsePred NonEmpty [Char]
es
  Pred fn
TruePred <> Pred fn
p = Pred fn
p
  Pred fn
p <> Pred fn
TruePred = Pred fn
p
  Pred fn
p <> Pred fn
p' = forall (fn :: [*] -> * -> *). [Pred fn] -> Pred fn
Block (forall {fn :: [*] -> * -> *}. Pred fn -> [Pred fn]
unpackPred Pred fn
p forall a. [a] -> [a] -> [a]
++ forall {fn :: [*] -> * -> *}. Pred fn -> [Pred fn]
unpackPred Pred fn
p')
    where
      unpackPred :: Pred fn -> [Pred fn]
unpackPred (Block [Pred fn]
ps) = [Pred fn]
ps
      unpackPred Pred fn
p = [Pred fn
p]

instance BaseUniverse fn => Monoid (Pred fn) where
  mempty :: Pred fn
mempty = forall (fn :: [*] -> * -> *). Pred fn
TruePred

-- | Contexts for Terms, basically a term with a _single_ HOLE
-- instead of a variable. This is used to traverse the defining
-- constraints for a variable and turn them into a spec. Each
-- subterm `f vs Ctx vs'` for lists of values `vs` and `vs'`
-- gets given to the `propagateSpecFun` for `f` as
-- `f vs HOLE vs'`.
data Ctx (fn :: [Type] -> Type -> Type) v a where
  -- | A single hole of type `v`
  CtxHOLE ::
    HasSpec fn v =>
    Ctx fn v v
  -- | The application `f vs Ctx vs'`
  CtxApp ::
    ( HasSpec fn b
    , TypeList as
    , Typeable as
    , All (HasSpec fn) as
    ) =>
    fn as b ->
    -- This is basically a `List` where
    -- everything is `Value` except for
    -- one entry which is `Ctx fn v`.
    ListCtx Value as (Ctx fn v) ->
    Ctx fn v b

-- | This is used together with `ListCtx` to form
-- just the arguments to `f vs Ctx vs'` - replacing
-- `Ctx` with `HOLE` - to provide to `propagateSpecFun`.
data HOLE a b where
  HOLE :: HOLE a a

toCtx ::
  forall m fn v a.
  ( BaseUniverse fn
  , Typeable v
  , MonadGenError m
  , HasCallStack
  , HasSpec fn a
  , HasSpec fn v
  ) =>
  Var v ->
  Term fn a ->
  m (Ctx fn v a)
toCtx :: forall (m :: * -> *) (fn :: [*] -> * -> *) v a.
(BaseUniverse fn, Typeable v, MonadGenError m, HasCallStack,
 HasSpec fn a, HasSpec fn v) =>
Var v -> Term fn a -> m (Ctx fn v a)
toCtx Var v
v Term fn a
t
  | forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf (forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Name fn
Name Var v
v) Term fn a
t forall a. Ord a => a -> a -> Bool
> Int
1 =
      forall (m :: * -> *) a. MonadGenError m => [Char] -> m a
fatalError1 ([Char]
"Can't build a single-hole context for variable " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Var v
v forall a. [a] -> [a] -> [a]
++ [Char]
" in term " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Term fn a
t)
  | Bool
otherwise = forall b. Term fn b -> m (Ctx fn v b)
go Term fn a
t
  where
    go :: forall b. Term fn b -> m (Ctx fn v b)
    go :: forall b. Term fn b -> m (Ctx fn v b)
go (Lit b
i) = forall (m :: * -> *) a. MonadGenError m => [Char] -> m a
fatalError1 ([Char]
"toCtx has literal: (Lit " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show b
i forall a. [a] -> [a] -> [a]
++ [Char]
")")
    go (App fn as b
f List (Term fn) as
as) = forall (fn :: [*] -> * -> *) b (a :: [*]) v.
(HasSpec fn b, TypeList a, Typeable a, All (HasSpec fn) a) =>
fn a b -> ListCtx Value a (Ctx fn v) -> Ctx fn v b
CtxApp fn as b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) (fn :: [*] -> * -> *) v (as :: [*]).
(BaseUniverse fn, All (HasSpec fn) as, HasSpec fn v, Typeable v,
 MonadGenError m, HasCallStack) =>
Var v -> List (Term fn) as -> m (ListCtx Value as (Ctx fn v))
toCtxList Var v
v List (Term fn) as
as
    go (V Var b
v')
      | Just v :~: b
Refl <- forall a a'.
(Typeable a, Typeable a') =>
Var a -> Var a' -> Maybe (a :~: a')
eqVar Var v
v Var b
v' = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) v. HasSpec fn v => Ctx fn v v
CtxHOLE
      | Bool
otherwise =
          forall (m :: * -> *) a. MonadGenError m => [Char] -> m a
fatalError1
            ( [Char]
"toCtx "
                forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Var v
v
                forall a. [a] -> [a] -> [a]
++ [Char]
"@("
                forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a. Typeable a => a -> TypeRep
typeOf Var v
v)
                forall a. [a] -> [a] -> [a]
++ [Char]
") (V "
                forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Var b
v'
                forall a. [a] -> [a] -> [a]
++ [Char]
"@("
                forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a. Typeable a => a -> TypeRep
typeOf Var b
v')
                forall a. [a] -> [a] -> [a]
++ [Char]
"))"
            )

toCtxList ::
  forall m fn v as.
  (BaseUniverse fn, All (HasSpec fn) as, HasSpec fn v, Typeable v, MonadGenError m, HasCallStack) =>
  Var v ->
  List (Term fn) as ->
  m (ListCtx Value as (Ctx fn v))
toCtxList :: forall (m :: * -> *) (fn :: [*] -> * -> *) v (as :: [*]).
(BaseUniverse fn, All (HasSpec fn) as, HasSpec fn v, Typeable v,
 MonadGenError m, HasCallStack) =>
Var v -> List (Term fn) as -> m (ListCtx Value as (Ctx fn v))
toCtxList Var v
v = forall (as' :: [*]).
(HasCallStack, All (HasSpec fn) as') =>
List (Term fn) as' -> m (ListCtx Value as' (Ctx fn v))
prefix
  where
    prefix ::
      forall as'.
      (HasCallStack, All (HasSpec fn) as') =>
      List (Term fn) as' ->
      m (ListCtx Value as' (Ctx fn v))
    prefix :: forall (as' :: [*]).
(HasCallStack, All (HasSpec fn) as') =>
List (Term fn) as' -> m (ListCtx Value as' (Ctx fn v))
prefix List (Term fn) as'
Nil = forall (m :: * -> *) a. MonadGenError m => [Char] -> m a
fatalError1 [Char]
"toCtxList without hole"
    prefix (Lit a
l :> List (Term fn) as1
ts) = do
      ListCtx Value as1 (Ctx fn v)
ctx <- forall (as' :: [*]).
(HasCallStack, All (HasSpec fn) as') =>
List (Term fn) as' -> m (ListCtx Value as' (Ctx fn v))
prefix List (Term fn) as1
ts
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Value a
Value a
l forall (f :: * -> *) a (as1 :: [*]) (c :: * -> *).
f a -> ListCtx f as1 c -> ListCtx f (a : as1) c
:! ListCtx Value as1 (Ctx fn v)
ctx
    prefix (Term fn a
t :> List (Term fn) as1
ts) = do
      Ctx fn v a
hole <- forall (m :: * -> *) (fn :: [*] -> * -> *) v a.
(BaseUniverse fn, Typeable v, MonadGenError m, HasCallStack,
 HasSpec fn a, HasSpec fn v) =>
Var v -> Term fn a -> m (Ctx fn v a)
toCtx Var v
v Term fn a
t
      List Value as1
suf <- forall (as' :: [*]). List (Term fn) as' -> m (List Value as')
suffix List (Term fn) as1
ts
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Ctx fn v a
hole forall (c :: * -> *) a (f :: * -> *) (as1 :: [*]).
c a -> List f as1 -> ListCtx f (a : as1) c
:? List Value as1
suf

    suffix :: forall as'. List (Term fn) as' -> m (List Value as')
    suffix :: forall (as' :: [*]). List (Term fn) as' -> m (List Value as')
suffix List (Term fn) as'
Nil = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall {k} (f :: k -> *). List f '[]
Nil
    suffix (Lit a
l :> List (Term fn) as1
ts) = (forall a. Show a => a -> Value a
Value a
l forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (as' :: [*]). List (Term fn) as' -> m (List Value as')
suffix List (Term fn) as1
ts
    suffix (Term fn a
_ :> List (Term fn) as1
_) = forall (m :: * -> *) a. MonadGenError m => [Char] -> m a
fatalError1 [Char]
"toCtxList with too many holes"

------------------------------------------------------------------------
-- Semantics of `Term` and `Pred`
------------------------------------------------------------------------

runTerm :: MonadGenError m => Env -> Term fn a -> m a
runTerm :: forall (m :: * -> *) (fn :: [*] -> * -> *) a.
MonadGenError m =>
Env -> Term fn a -> m a
runTerm Env
env = \case
  Lit a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
  V Var a
v -> forall a (m :: * -> *).
(Typeable a, MonadGenError m) =>
Env -> Var a -> m a
findEnv Env
env Var a
v
  App fn as a
f List (Term fn) as
ts -> do
    List Identity as
vs <- forall {k} (m :: * -> *) (f :: k -> *) (g :: k -> *) (as :: [k]).
Applicative m =>
(forall (a :: k). f a -> m (g a)) -> List f as -> m (List g as)
mapMList (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) (fn :: [*] -> * -> *) a.
MonadGenError m =>
Env -> Term fn a -> m a
runTerm Env
env) List (Term fn) as
ts
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (ts :: [*]) (f :: * -> *) r.
TypeList ts =>
(forall a. f a -> a) -> FunTy ts r -> List f ts -> r
uncurryList_ forall a. Identity a -> a
runIdentity (forall (fn :: [*] -> * -> *) (as :: [*]) b.
FunctionLike fn =>
fn as b -> FunTy as b
sem fn as a
f) List Identity as
vs

-- | Collect the 'monitor' calls from a specification instantiated to the given value. Typically,
--
--   >>> quickCheck $ forAll (genFromSpec spec) $ \ x -> monitorSpec spec x $ ...
monitorSpec :: (FunctionLike fn, Testable p) => Specification fn a -> a -> p -> Property
monitorSpec :: forall (fn :: [*] -> * -> *) p a.
(FunctionLike fn, Testable p) =>
Specification fn a -> a -> p -> Property
monitorSpec (SuspendedSpec Var a
x Pred fn
p) a
a =
  forall a. GE a -> a
errorGE (forall (fn :: [*] -> * -> *) (m :: * -> *).
(FunctionLike fn, MonadGenError m) =>
Env -> Pred fn -> m (Property -> Property)
monitorPred (forall a. (Typeable a, Show a) => Var a -> a -> Env
singletonEnv Var a
x a
a) Pred fn
p) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall prop. Testable prop => prop -> Property
property
monitorSpec Specification fn a
_ a
_ = forall prop. Testable prop => prop -> Property
property

monitorPred ::
  forall fn m. (FunctionLike fn, MonadGenError m) => Env -> Pred fn -> m (Property -> Property)
monitorPred :: forall (fn :: [*] -> * -> *) (m :: * -> *).
(FunctionLike fn, MonadGenError m) =>
Env -> Pred fn -> m (Property -> Property)
monitorPred Env
env = \case
  Monitor (forall a. Term fn a -> a) -> Property -> Property
m -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ((forall a. Term fn a -> a) -> Property -> Property
m forall a b. (a -> b) -> a -> b
$ forall a. GE a -> a
errorGE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadGenError m => [Char] -> m a -> m a
explain1 [Char]
"monitorPred: Monitor" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) (fn :: [*] -> * -> *) a.
MonadGenError m =>
Env -> Term fn a -> m a
runTerm Env
env)
  Subst Var a
x Term fn a
t Pred fn
p -> forall (fn :: [*] -> * -> *) (m :: * -> *).
(FunctionLike fn, MonadGenError m) =>
Env -> Pred fn -> m (Property -> Property)
monitorPred Env
env forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> Pred fn -> Pred fn
substitutePred Var a
x Term fn a
t Pred fn
p
  Assert {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. a -> a
id
  GenHint {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. a -> a
id
  Reifies {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. a -> a
id
  ForAll Term fn t
t (Var a
x :-> Pred fn
p) -> do
    t
set <- forall (m :: * -> *) (fn :: [*] -> * -> *) a.
MonadGenError m =>
Env -> Term fn a -> m a
runTerm Env
env Term fn t
t
    forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
        [ forall (fn :: [*] -> * -> *) (m :: * -> *).
(FunctionLike fn, MonadGenError m) =>
Env -> Pred fn -> m (Property -> Property)
monitorPred Env
env' Pred fn
p
        | a
v <- forall t e. Forallable t e => t -> [e]
forAllToList t
set
        , let env' :: Env
env' = forall a. (Typeable a, Show a) => Var a -> a -> Env -> Env
extendEnv Var a
x a
v Env
env
        ]
  Case Term fn (SumOver as)
t List (Weighted (Binder fn)) as
bs -> do
    SumOver as
v <- forall (m :: * -> *) (fn :: [*] -> * -> *) a.
MonadGenError m =>
Env -> Term fn a -> m a
runTerm Env
env Term fn (SumOver as)
t
    forall (as :: [*]) (fn :: [*] -> * -> *) r.
SumOver as
-> List (Binder fn) as
-> (forall a. HasSpec fn a => Var a -> a -> Pred fn -> r)
-> r
runCaseOn SumOver as
v (forall {k} (f :: k -> *) (g :: k -> *) (as :: [k]).
(forall (a :: k). f a -> g a) -> List f as -> List g as
mapList forall (f :: * -> *) a. Weighted f a -> f a
thing List (Weighted (Binder fn)) as
bs) (\Var a
x a
val Pred fn
ps -> forall (fn :: [*] -> * -> *) (m :: * -> *).
(FunctionLike fn, MonadGenError m) =>
Env -> Pred fn -> m (Property -> Property)
monitorPred (forall a. (Typeable a, Show a) => Var a -> a -> Env -> Env
extendEnv Var a
x a
val Env
env) Pred fn
ps)
  When Term fn Bool
b Pred fn
p -> do
    Bool
v <- forall (m :: * -> *) (fn :: [*] -> * -> *) a.
MonadGenError m =>
Env -> Term fn a -> m a
runTerm Env
env Term fn Bool
b
    if Bool
v then forall (fn :: [*] -> * -> *) (m :: * -> *).
(FunctionLike fn, MonadGenError m) =>
Env -> Pred fn -> m (Property -> Property)
monitorPred Env
env Pred fn
p else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. a -> a
id
  Pred fn
TruePred -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. a -> a
id
  FalsePred {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. a -> a
id
  DependsOn {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. a -> a
id
  Block [Pred fn]
ps -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (fn :: [*] -> * -> *) (m :: * -> *).
(FunctionLike fn, MonadGenError m) =>
Env -> Pred fn -> m (Property -> Property)
monitorPred Env
env) [Pred fn]
ps
  Let Term fn a
t (Var a
x :-> Pred fn
p) -> do
    a
val <- forall (m :: * -> *) (fn :: [*] -> * -> *) a.
MonadGenError m =>
Env -> Term fn a -> m a
runTerm Env
env Term fn a
t
    forall (fn :: [*] -> * -> *) (m :: * -> *).
(FunctionLike fn, MonadGenError m) =>
Env -> Pred fn -> m (Property -> Property)
monitorPred (forall a. (Typeable a, Show a) => Var a -> a -> Env -> Env
extendEnv Var a
x a
val Env
env) Pred fn
p
  Exists (forall a. Term fn a -> a) -> GE a
k (Var a
x :-> Pred fn
p) -> do
    case (forall a. Term fn a -> a) -> GE a
k (forall a. GE a -> a
errorGE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadGenError m => [Char] -> m a -> m a
explain1 [Char]
"monitorPred: Exists" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) (fn :: [*] -> * -> *) a.
MonadGenError m =>
Env -> Term fn a -> m a
runTerm Env
env) of
      Result [NonEmpty [Char]]
_ a
a -> forall (fn :: [*] -> * -> *) (m :: * -> *).
(FunctionLike fn, MonadGenError m) =>
Env -> Pred fn -> m (Property -> Property)
monitorPred (forall a. (Typeable a, Show a) => Var a -> a -> Env -> Env
extendEnv Var a
x a
a Env
env) Pred fn
p
      GE a
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. a -> a
id
  Explain NonEmpty [Char]
es Pred fn
p -> forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a -> m a
explain NonEmpty [Char]
es forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) (m :: * -> *).
(FunctionLike fn, MonadGenError m) =>
Env -> Pred fn -> m (Property -> Property)
monitorPred Env
env Pred fn
p

checkPred :: forall fn m. (FunctionLike fn, MonadGenError m) => Env -> Pred fn -> m Bool
checkPred :: forall (fn :: [*] -> * -> *) (m :: * -> *).
(FunctionLike fn, MonadGenError m) =>
Env -> Pred fn -> m Bool
checkPred Env
env = \case
  Monitor {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  Subst Var a
x Term fn a
t Pred fn
p -> forall (fn :: [*] -> * -> *) (m :: * -> *).
(FunctionLike fn, MonadGenError m) =>
Env -> Pred fn -> m Bool
checkPred Env
env forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> Pred fn -> Pred fn
substitutePred Var a
x Term fn a
t Pred fn
p
  Assert Term fn Bool
t -> forall (m :: * -> *) (fn :: [*] -> * -> *) a.
MonadGenError m =>
Env -> Term fn a -> m a
runTerm Env
env Term fn Bool
t
  GenHint {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  p :: Pred fn
p@(Reifies Term fn b
t' Term fn a
t a -> b
f) -> do
    a
val <- forall (m :: * -> *) (fn :: [*] -> * -> *) a.
MonadGenError m =>
Env -> Term fn a -> m a
runTerm Env
env Term fn a
t
    b
val' <- forall (m :: * -> *) (fn :: [*] -> * -> *) a.
MonadGenError m =>
Env -> Term fn a -> m a
runTerm Env
env Term fn b
t'
    forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a -> m a
explain (forall a. [a] -> NonEmpty a
NE.fromList [[Char]
"Reification:", [Char]
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Pred fn
p]) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> b
f a
val forall a. Eq a => a -> a -> Bool
== b
val')
  ForAll Term fn t
t (Var a
x :-> Pred fn
p) -> do
    t
set <- forall (m :: * -> *) (fn :: [*] -> * -> *) a.
MonadGenError m =>
Env -> Term fn a -> m a
runTerm Env
env Term fn t
t
    forall (t :: * -> *). Foldable t => t Bool -> Bool
and
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
        [ forall (fn :: [*] -> * -> *) (m :: * -> *).
(FunctionLike fn, MonadGenError m) =>
Env -> Pred fn -> m Bool
checkPred Env
env' Pred fn
p
        | a
v <- forall t e. Forallable t e => t -> [e]
forAllToList t
set
        , let env' :: Env
env' = forall a. (Typeable a, Show a) => Var a -> a -> Env -> Env
extendEnv Var a
x a
v Env
env
        ]
  Case Term fn (SumOver as)
t List (Weighted (Binder fn)) as
bs -> do
    SumOver as
v <- forall (m :: * -> *) (fn :: [*] -> * -> *) a.
MonadGenError m =>
Env -> Term fn a -> m a
runTerm Env
env Term fn (SumOver as)
t
    forall (as :: [*]) (fn :: [*] -> * -> *) r.
SumOver as
-> List (Binder fn) as
-> (forall a. HasSpec fn a => Var a -> a -> Pred fn -> r)
-> r
runCaseOn SumOver as
v (forall {k} (f :: k -> *) (g :: k -> *) (as :: [k]).
(forall (a :: k). f a -> g a) -> List f as -> List g as
mapList forall (f :: * -> *) a. Weighted f a -> f a
thing List (Weighted (Binder fn)) as
bs) (\Var a
x a
val Pred fn
ps -> forall (fn :: [*] -> * -> *) (m :: * -> *).
(FunctionLike fn, MonadGenError m) =>
Env -> Pred fn -> m Bool
checkPred (forall a. (Typeable a, Show a) => Var a -> a -> Env -> Env
extendEnv Var a
x a
val Env
env) Pred fn
ps)
  When Term fn Bool
bt Pred fn
p -> do
    Bool
b <- forall (m :: * -> *) (fn :: [*] -> * -> *) a.
MonadGenError m =>
Env -> Term fn a -> m a
runTerm Env
env Term fn Bool
bt
    if Bool
b then forall (fn :: [*] -> * -> *) (m :: * -> *).
(FunctionLike fn, MonadGenError m) =>
Env -> Pred fn -> m Bool
checkPred Env
env Pred fn
p else forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  Pred fn
TruePred -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  FalsePred NonEmpty [Char]
es -> forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a -> m a
explain NonEmpty [Char]
es forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  DependsOn {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  Block [Pred fn]
ps -> forall (m :: * -> *) (t :: * -> *) (fn :: [*] -> * -> *).
(MonadGenError m, Traversable t, FunctionLike fn) =>
Env -> t (Pred fn) -> m Bool
checkPreds Env
env [Pred fn]
ps
  Let Term fn a
t (Var a
x :-> Pred fn
p) -> do
    a
val <- forall (m :: * -> *) (fn :: [*] -> * -> *) a.
MonadGenError m =>
Env -> Term fn a -> m a
runTerm Env
env Term fn a
t
    forall (fn :: [*] -> * -> *) (m :: * -> *).
(FunctionLike fn, MonadGenError m) =>
Env -> Pred fn -> m Bool
checkPred (forall a. (Typeable a, Show a) => Var a -> a -> Env -> Env
extendEnv Var a
x a
val Env
env) Pred fn
p
  Exists (forall b. Term fn b -> b) -> GE a
k (Var a
x :-> Pred fn
p) -> do
    a
a <- forall (m :: * -> *) r. MonadGenError m => GE r -> m r
runGE forall a b. (a -> b) -> a -> b
$ (forall b. Term fn b -> b) -> GE a
k (forall a. GE a -> a
errorGE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadGenError m => [Char] -> m a -> m a
explain1 [Char]
"checkPred: Exists" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) (fn :: [*] -> * -> *) a.
MonadGenError m =>
Env -> Term fn a -> m a
runTerm Env
env)
    forall (fn :: [*] -> * -> *) (m :: * -> *).
(FunctionLike fn, MonadGenError m) =>
Env -> Pred fn -> m Bool
checkPred (forall a. (Typeable a, Show a) => Var a -> a -> Env -> Env
extendEnv Var a
x a
a Env
env) Pred fn
p
  Explain NonEmpty [Char]
es Pred fn
p -> forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a -> m a
explain NonEmpty [Char]
es forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) (m :: * -> *).
(FunctionLike fn, MonadGenError m) =>
Env -> Pred fn -> m Bool
checkPred Env
env Pred fn
p

checkPreds :: (MonadGenError m, Traversable t, FunctionLike fn) => Env -> t (Pred fn) -> m Bool
checkPreds :: forall (m :: * -> *) (t :: * -> *) (fn :: [*] -> * -> *).
(MonadGenError m, Traversable t, FunctionLike fn) =>
Env -> t (Pred fn) -> m Bool
checkPreds Env
env t (Pred fn)
ps = forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (fn :: [*] -> * -> *) (m :: * -> *).
(FunctionLike fn, MonadGenError m) =>
Env -> Pred fn -> m Bool
checkPred Env
env) t (Pred fn)
ps

checkPredPure :: FunctionLike fn => Env -> Pred fn -> Bool
checkPredPure :: forall (fn :: [*] -> * -> *).
FunctionLike fn =>
Env -> Pred fn -> Bool
checkPredPure Env
env Pred fn
p = forall a. (NonEmpty [Char] -> a) -> GE a -> a
fromGE (forall a b. a -> b -> a
const Bool
False) forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) (m :: * -> *).
(FunctionLike fn, MonadGenError m) =>
Env -> Pred fn -> m Bool
checkPred Env
env Pred fn
p

runCaseOn ::
  SumOver as ->
  List (Binder fn) as ->
  (forall a. HasSpec fn a => Var a -> a -> Pred fn -> r) ->
  r
runCaseOn :: forall (as :: [*]) (fn :: [*] -> * -> *) r.
SumOver as
-> List (Binder fn) as
-> (forall a. HasSpec fn a => Var a -> a -> Pred fn -> r)
-> r
runCaseOn SumOver as
_ List (Binder fn) as
Nil forall a. HasSpec fn a => Var a -> a -> Pred fn -> r
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"The impossible happened in runCaseOn"
runCaseOn SumOver as
a ((Var a
x :-> Pred fn
ps) :> List (Binder fn) as1
Nil) forall a. HasSpec fn a => Var a -> a -> Pred fn -> r
f = forall a. HasSpec fn a => Var a -> a -> Pred fn -> r
f Var a
x SumOver as
a Pred fn
ps
runCaseOn SumOver as
s ((Var a
x :-> Pred fn
ps) :> bs :: List (Binder fn) as1
bs@(Binder fn a
_ :> List (Binder fn) as1
_)) forall a. HasSpec fn a => Var a -> a -> Pred fn -> r
f = case SumOver as
s of
  SumLeft a
a -> forall a. HasSpec fn a => Var a -> a -> Pred fn -> r
f Var a
x a
a Pred fn
ps
  SumRight SumOver (a : as1)
a -> forall (as :: [*]) (fn :: [*] -> * -> *) r.
SumOver as
-> List (Binder fn) as
-> (forall a. HasSpec fn a => Var a -> a -> Pred fn -> r)
-> r
runCaseOn SumOver (a : as1)
a List (Binder fn) as1
bs forall a. HasSpec fn a => Var a -> a -> Pred fn -> r
f

------------------------------------------------------------------------
-- Specs
------------------------------------------------------------------------

-- NOTE: in the future one might consider using sets when a type
-- has `Ord` here. Beware, this means that one needs to have a check
-- for instances of Ord at runtime!
type OrdSet a = [a]

-- | A `Specification fn a` denotes a set of `a`s
data Specification fn a where
  -- | Explain a Specification
  ExplainSpec :: [String] -> Specification fn a -> Specification fn a
  -- | Elements of a known set
  MemberSpec ::
    -- | It must be an element of this OrdSet (List). Try hard not to put duplicates in the List.
    NE.NonEmpty a ->
    Specification fn a
  -- | The empty set
  ErrorSpec ::
    NE.NonEmpty String ->
    Specification fn a
  -- | The set described by some predicates
  -- over the bound variable.
  --
  -- TODO: possibly we want to use a `Binder` here
  SuspendedSpec ::
    HasSpec fn a =>
    -- | This variable ranges over values denoted by
    -- the spec
    Var a ->
    -- | And the variable is subject to these constraints
    Pred fn ->
    Specification fn a
  -- | A type-specific spec
  TypeSpec ::
    HasSpec fn a =>
    TypeSpec fn a ->
    -- | It can't be any of the elements of this set
    OrdSet a ->
    Specification fn a
  -- | Anything
  TrueSpec :: Specification fn a

explainSpecOpt :: [String] -> Specification fn a -> Specification fn a
explainSpecOpt :: forall (fn :: [*] -> * -> *) a.
[[Char]] -> Specification fn a -> Specification fn a
explainSpecOpt [] Specification fn a
x = Specification fn a
x
explainSpecOpt [[Char]]
es1 (ExplainSpec [[Char]]
es2 Specification fn a
x) = forall (fn :: [*] -> * -> *) a.
[[Char]] -> Specification fn a -> Specification fn a
explainSpecOpt ([[Char]]
es1 forall a. [a] -> [a] -> [a]
++ [[Char]]
es2) Specification fn a
x
explainSpecOpt [[Char]]
es Specification fn a
spec = forall (fn :: [*] -> * -> *) a.
[[Char]] -> Specification fn a -> Specification fn a
ExplainSpec [[Char]]
es Specification fn a
spec

-- | return a MemberSpec or ans ErrorSpec depending on if 'xs' the null list or not
memberSpecList :: [a] -> NE.NonEmpty String -> Specification fn a
memberSpecList :: forall a (fn :: [*] -> * -> *).
[a] -> NonEmpty [Char] -> Specification fn a
memberSpecList [a]
xs NonEmpty [Char]
messages =
  case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [a]
xs of
    Maybe (NonEmpty a)
Nothing -> forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec NonEmpty [Char]
messages
    Just NonEmpty a
ys -> forall a (fn :: [*] -> * -> *). NonEmpty a -> Specification fn a
MemberSpec NonEmpty a
ys

instance Arbitrary a => Arbitrary (NE.NonEmpty a) where
  arbitrary :: Gen (NonEmpty a)
arbitrary = do
    NonEmpty [a]
xs <- forall a. Arbitrary a => Gen a
arbitrary
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. [a] -> NonEmpty a
NE.fromList [a]
xs)

instance HasSpec fn a => Semigroup (Specification fn a) where
  ExplainSpec [[Char]]
es Specification fn a
x <> :: Specification fn a -> Specification fn a -> Specification fn a
<> Specification fn a
y = forall (fn :: [*] -> * -> *) a.
[[Char]] -> Specification fn a -> Specification fn a
explainSpecOpt [[Char]]
es (Specification fn a
x forall a. Semigroup a => a -> a -> a
<> Specification fn a
y)
  Specification fn a
x <> ExplainSpec [[Char]]
es Specification fn a
y = forall (fn :: [*] -> * -> *) a.
[[Char]] -> Specification fn a -> Specification fn a
explainSpecOpt [[Char]]
es (Specification fn a
x forall a. Semigroup a => a -> a -> a
<> Specification fn a
y)
  Specification fn a
TrueSpec <> Specification fn a
s = Specification fn a
s
  Specification fn a
s <> Specification fn a
TrueSpec = Specification fn a
s
  ErrorSpec NonEmpty [Char]
e <> ErrorSpec NonEmpty [Char]
e' =
    forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec
      ( NonEmpty [Char]
e
          forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
"------ spec <> spec ------ @" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy @a)))
          forall a. Semigroup a => a -> a -> a
<> NonEmpty [Char]
e'
      )
  ErrorSpec NonEmpty [Char]
e <> Specification fn a
_ = forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec NonEmpty [Char]
e
  Specification fn a
_ <> ErrorSpec NonEmpty [Char]
e = forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec NonEmpty [Char]
e
  MemberSpec NonEmpty a
as <> MemberSpec NonEmpty a
as' =
    forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a -> Specification fn a
addToErrorSpec
      ( forall a. [a] -> NonEmpty a
NE.fromList
          [[Char]
"Intersecting: ", [Char]
"  MemberSpec " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a. NonEmpty a -> [a]
NE.toList NonEmpty a
as), [Char]
"  MemberSpec " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a. NonEmpty a -> [a]
NE.toList NonEmpty a
as')]
      )
      ( forall a (fn :: [*] -> * -> *).
[a] -> NonEmpty [Char] -> Specification fn a
memberSpecList
          (forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a] -> [a]
intersect (forall a. NonEmpty a -> [a]
NE.toList NonEmpty a
as) (forall a. NonEmpty a -> [a]
NE.toList NonEmpty a
as'))
          (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"Empty intersection")
      )
  ms :: Specification fn a
ms@(MemberSpec NonEmpty a
as) <> ts :: Specification fn a
ts@TypeSpec {} =
    forall a (fn :: [*] -> * -> *).
[a] -> NonEmpty [Char] -> Specification fn a
memberSpecList
      (forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> NonEmpty a -> [a]
NE.filter (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
`conformsToSpec` Specification fn a
ts) NonEmpty a
as)
      ( forall a. [a] -> NonEmpty a
NE.fromList
          [ [Char]
"The two " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy @a)) forall a. [a] -> [a] -> [a]
++ [Char]
" Specifications are inconsistent."
          , [Char]
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn a
ms
          , [Char]
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn a
ts
          ]
      )
  TypeSpec TypeSpec fn a
s [a]
cant <> MemberSpec NonEmpty a
as = forall a (fn :: [*] -> * -> *). NonEmpty a -> Specification fn a
MemberSpec NonEmpty a
as forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> OrdSet a -> Specification fn a
TypeSpec TypeSpec fn a
s [a]
cant
  SuspendedSpec Var a
v Pred fn
p <> SuspendedSpec Var a
v' Pred fn
p' = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Specification fn a
SuspendedSpec Var a
v (Pred fn
p forall a. Semigroup a => a -> a -> a
<> forall a x. (Rename a, Typeable x) => Var x -> Var x -> a -> a
rename Var a
v' Var a
v Pred fn
p')
  SuspendedSpec Var a
v Pred fn
ps <> Specification fn a
s = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Specification fn a
SuspendedSpec Var a
v (Pred fn
ps forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Specification fn a -> Pred fn
satisfies (forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Term fn a
V Var a
v) Specification fn a
s)
  Specification fn a
s <> SuspendedSpec Var a
v Pred fn
ps = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Specification fn a
SuspendedSpec Var a
v (Pred fn
ps forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Specification fn a -> Pred fn
satisfies (forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Term fn a
V Var a
v) Specification fn a
s)
  TypeSpec TypeSpec fn a
s [a]
cant <> TypeSpec TypeSpec fn a
s' [a]
cant' = case forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> TypeSpec fn a -> Specification fn a
combineSpec TypeSpec fn a
s TypeSpec fn a
s' of
    -- NOTE: This might look like an unnecessary case, but doing
    -- it like this avoids looping.
    TypeSpec TypeSpec fn a
s'' [a]
cant'' -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> OrdSet a -> Specification fn a
TypeSpec TypeSpec fn a
s'' ([a]
cant forall a. Semigroup a => a -> a -> a
<> [a]
cant' forall a. Semigroup a => a -> a -> a
<> [a]
cant'')
    Specification fn a
s'' -> Specification fn a
s'' forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a (f :: * -> *).
(HasSpec fn a, Foldable f) =>
f a -> Specification fn a
notMemberSpec ([a]
cant forall a. Semigroup a => a -> a -> a
<> [a]
cant')

instance HasSpec fn a => Monoid (Specification fn a) where
  mempty :: Specification fn a
mempty = forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec

instance (HasSpec fn a, Arbitrary (TypeSpec fn a)) => Arbitrary (Specification fn a) where
  arbitrary :: Gen (Specification fn a)
arbitrary = do
    Specification fn a
baseSpec <-
      forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
        [ (Int
1, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec)
        ,
          ( Int
7
          , do
              [a]
zs <- forall a. Eq a => [a] -> [a]
nub forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Gen a -> Gen [a]
listOf1 (forall (fn :: [*] -> * -> *) a.
(HasCallStack, HasSpec fn a) =>
Specification fn a -> Gen a
genFromSpec @fn forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec)
              forall (f :: * -> *) a. Applicative f => a -> f a
pure
                ( forall a (fn :: [*] -> * -> *).
[a] -> NonEmpty [Char] -> Specification fn a
memberSpecList
                    [a]
zs
                    ( forall a. [a] -> NonEmpty a
NE.fromList
                        [ [Char]
"In (Arbitrary Specification) this should never happen"
                        , [Char]
"listOf1 generates empty list."
                        ]
                    )
                )
          )
        , (Int
10, forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary)
        ,
          ( Int
1
          , do
              Int
len <- forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
5)
              forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> OrdSet a -> Specification fn a
TypeSpec forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Int -> Gen a -> Gen [a]
vectorOf Int
len (forall (fn :: [*] -> * -> *) a.
(HasCallStack, HasSpec fn a) =>
Specification fn a -> Gen a
genFromSpec @fn forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec)
          )
        , (Int
1, forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary)
        , -- Recurse to make sure we apply the tricks for generating suspended specs multiple times
          (Int
1, forall a. Arbitrary a => Gen a
arbitrary)
        ]
    -- TODO: we probably want smarter ways of generating constraints
    forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
      [ (Int
1, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a (fn :: [*] -> * -> *) p.
(IsPred p fn, HasSpec fn a) =>
(Term fn a -> p) -> Specification fn a
constrained forall a b. (a -> b) -> a -> b
$ \Term fn a
x -> Term fn a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Specification fn a -> Pred fn
`satisfies` Specification fn a
baseSpec)
      , (Int
1, forall (fn :: [*] -> * -> *) a.
[[Char]] -> Specification fn a -> Specification fn a
ExplainSpec [[Char]
"Arbitrary"] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary)
      ,
        ( Int
1
        , forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a (fn :: [*] -> * -> *) p.
(IsPred p fn, HasSpec fn a) =>
(Term fn a -> p) -> Specification fn a
constrained forall a b. (a -> b) -> a -> b
$ \Term fn a
x -> forall a p (fn :: [*] -> * -> *).
(HasSpec fn a, IsPred p fn) =>
((forall b. Term fn b -> b) -> GE a) -> (Term fn a -> p) -> Pred fn
exists (\forall b. Term fn b -> b
eval -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b. Term fn b -> b
eval Term fn a
x) forall a b. (a -> b) -> a -> b
$ \Term fn a
y ->
            [ forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
p -> Pred fn
assert forall a b. (a -> b) -> a -> b
$ Term fn a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Term fn a -> Term fn Bool
==. Term fn a
y
            , Term fn a
y forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Specification fn a -> Pred fn
`satisfies` Specification fn a
baseSpec
            ]
        )
      , (Int
1, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a (fn :: [*] -> * -> *) p.
(IsPred p fn, HasSpec fn a) =>
(Term fn a -> p) -> Specification fn a
constrained forall a b. (a -> b) -> a -> b
$ \Term fn a
x -> forall (fn :: [*] -> * -> *) a p.
(HasSpec fn a, IsPred p fn) =>
Term fn a -> (Term fn a -> p) -> Pred fn
letBind Term fn a
x forall a b. (a -> b) -> a -> b
$ \Term fn a
y -> Term fn a
y forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Specification fn a -> Pred fn
`satisfies` Specification fn a
baseSpec)
      ,
        ( Int
1
        , forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a (fn :: [*] -> * -> *) p.
(IsPred p fn, HasSpec fn a) =>
(Term fn a -> p) -> Specification fn a
constrained forall a b. (a -> b) -> a -> b
$ \Term fn a
x -> forall a p (fn :: [*] -> * -> *).
(HasSpec fn a, IsPred p fn) =>
((forall b. Term fn b -> b) -> GE a) -> (Term fn a -> p) -> Pred fn
exists (\forall b. Term fn b -> b
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True) forall a b. (a -> b) -> a -> b
$ \Term fn Bool
b ->
            forall (fn :: [*] -> * -> *) p q.
(BaseUniverse fn, IsPred p fn, IsPred q fn) =>
Term fn Bool -> p -> q -> Pred fn
ifElse Term fn Bool
b (Term fn a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Specification fn a -> Pred fn
`satisfies` Specification fn a
baseSpec) (Term fn a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Specification fn a -> Pred fn
`satisfies` Specification fn a
baseSpec)
        )
      ,
        ( Int
1
        , forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a (fn :: [*] -> * -> *) p.
(IsPred p fn, HasSpec fn a) =>
(Term fn a -> p) -> Specification fn a
constrained forall a b. (a -> b) -> a -> b
$ \Term fn a
x -> forall a p (fn :: [*] -> * -> *).
(HasSpec fn a, IsPred p fn) =>
((forall b. Term fn b -> b) -> GE a) -> (Term fn a -> p) -> Pred fn
exists (\forall b. Term fn b -> b
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True) forall a b. (a -> b) -> a -> b
$ \Term fn Bool
b ->
            [ forall (fn :: [*] -> * -> *) p q.
(BaseUniverse fn, IsPred p fn, IsPred q fn) =>
Term fn Bool -> p -> q -> Pred fn
ifElse Term fn Bool
b Bool
True (Term fn a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Specification fn a -> Pred fn
`satisfies` Specification fn a
baseSpec)
            , Term fn a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Specification fn a -> Pred fn
`satisfies` Specification fn a
baseSpec
            ]
        )
      ,
        ( Int
1
        , forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a (fn :: [*] -> * -> *) p.
(IsPred p fn, HasSpec fn a) =>
(Term fn a -> p) -> Specification fn a
constrained forall a b. (a -> b) -> a -> b
$ \Term fn a
x -> forall a p (fn :: [*] -> * -> *).
(HasSpec fn a, IsPred p fn) =>
((forall b. Term fn b -> b) -> GE a) -> (Term fn a -> p) -> Pred fn
exists (\forall b. Term fn b -> b
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False) forall a b. (a -> b) -> a -> b
$ \Term fn Bool
b ->
            [ forall (fn :: [*] -> * -> *) p q.
(BaseUniverse fn, IsPred p fn, IsPred q fn) =>
Term fn Bool -> p -> q -> Pred fn
ifElse Term fn Bool
b (Term fn a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Specification fn a -> Pred fn
`satisfies` Specification fn a
baseSpec) Bool
True
            , Term fn a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Specification fn a -> Pred fn
`satisfies` Specification fn a
baseSpec
            ]
        )
      ,
        ( Int
1
        , forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a (fn :: [*] -> * -> *) p.
(IsPred p fn, HasSpec fn a) =>
(Term fn a -> p) -> Specification fn a
constrained forall a b. (a -> b) -> a -> b
$ \Term fn a
x -> forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn -> Pred fn
explanation (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"its very subtle, you won't get it.") forall a b. (a -> b) -> a -> b
$ Term fn a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Specification fn a -> Pred fn
`satisfies` Specification fn a
baseSpec
        )
      , (Int
10, forall (f :: * -> *) a. Applicative f => a -> f a
pure Specification fn a
baseSpec)
      ]

  shrink :: Specification fn a -> [Specification fn a]
shrink (ExplainSpec [[Char]]
es Specification fn a
x) =
    forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec
      forall a. a -> [a] -> [a]
: forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
"shrink (ExplainSpec msg spec)"))
      forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall (fn :: [*] -> * -> *) a.
[[Char]] -> Specification fn a -> Specification fn a
ExplainSpec [[Char]]
es) (forall a. Arbitrary a => a -> [a]
shrink Specification fn a
x)
  shrink Specification fn a
TrueSpec = []
  shrink (MemberSpec NonEmpty a
ys) = forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec forall a. a -> [a] -> [a]
: forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {a} {fn :: [*] -> * -> *}.
Eq a =>
[a] -> Maybe (Specification fn a)
mem (forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn a -> a -> [a]
shrinkWithSpec @fn forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec) (forall a. NonEmpty a -> [a]
NE.toList NonEmpty a
ys))
    where
      mem :: [a] -> Maybe (Specification fn a)
mem [a]
xs =
        case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty (forall a. Eq a => [a] -> [a]
nub [a]
xs) of
          Maybe (NonEmpty a)
Nothing -> forall a. Maybe a
Nothing
          Just NonEmpty a
as -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a (fn :: [*] -> * -> *). NonEmpty a -> Specification fn a
MemberSpec NonEmpty a
as
  shrink (TypeSpec TypeSpec fn a
ts [a]
cant)
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
cant =
        forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec forall a. a -> [a] -> [a]
: forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"From shrinking TypeSpec with null cant") forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec (forall a. Arbitrary a => a -> [a]
shrink TypeSpec fn a
ts)
    | Bool
otherwise =
        [forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec, forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"From shrinking TypeSpec"), forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec TypeSpec fn a
ts]
          forall a. [a] -> [a] -> [a]
++ ( case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty (forall a. Eq a => [a] -> [a]
nub [a]
cant) of
                Maybe (NonEmpty a)
Nothing -> []
                Just NonEmpty a
as -> [forall a (fn :: [*] -> * -> *). NonEmpty a -> Specification fn a
MemberSpec NonEmpty a
as]
             )
          forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec (forall a. Arbitrary a => a -> [a]
shrink TypeSpec fn a
ts)
          forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> OrdSet a -> Specification fn a
TypeSpec TypeSpec fn a
ts) (forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn a -> a -> [a]
shrinkWithSpec @fn forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec) [a]
cant)
  shrink (SuspendedSpec Var a
x Pred fn
p) =
    [forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec, forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"From shrinking SuspendedSpec")]
      forall a. [a] -> [a] -> [a]
++ [ Specification fn a
s
         | Result [NonEmpty [Char]]
_ Specification fn a
s <- [forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, HasCallStack) =>
Var a -> Pred fn -> GE (Specification fn a)
computeSpec Var a
x Pred fn
p]
         , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a. Specification fn a -> Bool
isSuspendedSpec Specification fn a
s
         ]
      forall a. [a] -> [a] -> [a]
++ [forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Specification fn a
SuspendedSpec Var a
x Pred fn
p' | Pred fn
p' <- forall {fn :: [*] -> * -> *}. Pred fn -> [Pred fn]
shrinkPred Pred fn
p]
  shrink ErrorSpec {} = [forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec]

shrinkPred :: Pred fn -> [Pred fn]
shrinkPred :: forall {fn :: [*] -> * -> *}. Pred fn -> [Pred fn]
shrinkPred (Block [Pred fn]
ps) = forall (fn :: [*] -> * -> *). Pred fn
TruePred forall a. a -> [a] -> [a]
: forall (fn :: [*] -> * -> *). [Char] -> Pred fn
falsePred1 [Char]
"shrink block" forall a. a -> [a] -> [a]
: [Pred fn]
ps forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall (fn :: [*] -> * -> *). [Pred fn] -> Pred fn
Block (forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList forall {fn :: [*] -> * -> *}. Pred fn -> [Pred fn]
shrinkPred [Pred fn]
ps)
shrinkPred (Assert Term fn Bool
t) =
  [forall (fn :: [*] -> * -> *). Pred fn
TruePred, forall (fn :: [*] -> * -> *). [Char] -> Pred fn
falsePred1 [Char]
"shrink assert", forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Term fn Bool -> Pred fn
Assert Term fn Bool
t]
shrinkPred (Explain NonEmpty [Char]
_ Pred fn
p) = forall (fn :: [*] -> * -> *). Pred fn
TruePred forall a. a -> [a] -> [a]
: forall (fn :: [*] -> * -> *). [Char] -> Pred fn
falsePred1 [Char]
"shrink explain" forall a. a -> [a] -> [a]
: [Pred fn
p]
shrinkPred (When Term fn Bool
b Pred fn
p) = forall (fn :: [*] -> * -> *). Pred fn
TruePred forall a. a -> [a] -> [a]
: forall (fn :: [*] -> * -> *). [Char] -> Pred fn
falsePred1 [Char]
"shrink when" forall a. a -> [a] -> [a]
: Pred fn
p forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall (fn :: [*] -> * -> *).
HasSpec fn Bool =>
Term fn Bool -> Pred fn -> Pred fn
When Term fn Bool
b) (forall {fn :: [*] -> * -> *}. Pred fn -> [Pred fn]
shrinkPred Pred fn
p)
-- NOTE: You can't shrink `Exists` because it might make the `Env -> a` invalid!
-- e.g. you start with
-- `constrained $ \ x -> exists (\eval -> pure $ eval x) $ \ y -> [ x ==. y, 10 <. y ]`
-- and shrink it to
-- `constrained $ \ x -> exists (\eval -> pure $ eval x) $ \ y -> [ 10 <. y ]`
-- and suddenly the thing you're generating is BS w.r.t the checking!
shrinkPred Exists {} = [forall (fn :: [*] -> * -> *). Pred fn
TruePred, forall (fn :: [*] -> * -> *). [Char] -> Pred fn
falsePred1 [Char]
"shrink exists"]
shrinkPred (Subst Var a
x Term fn a
t Pred fn
p) = forall {fn :: [*] -> * -> *}. Pred fn -> [Pred fn]
shrinkPred forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> Pred fn -> Pred fn
substitutePred Var a
x Term fn a
t Pred fn
p
shrinkPred GenHint {} = [forall (fn :: [*] -> * -> *). Pred fn
TruePred, forall (fn :: [*] -> * -> *). [Char] -> Pred fn
falsePred1 [Char]
"shrink hint"]
shrinkPred Monitor {} = [forall (fn :: [*] -> * -> *). Pred fn
TruePred, forall (fn :: [*] -> * -> *). [Char] -> Pred fn
falsePred1 [Char]
"shrink monitor"]
shrinkPred DependsOn {} = [forall (fn :: [*] -> * -> *). Pred fn
TruePred, forall (fn :: [*] -> * -> *). [Char] -> Pred fn
falsePred1 [Char]
"shrink depends"]
-- TODO: fixme
shrinkPred Case {} = [forall (fn :: [*] -> * -> *). Pred fn
TruePred, forall (fn :: [*] -> * -> *). [Char] -> Pred fn
falsePred1 [Char]
"shrink case"]
shrinkPred (Let Term fn a
t (Var a
x :-> Pred fn
p)) = forall (fn :: [*] -> * -> *) a. Term fn a -> Binder fn a -> Pred fn
Let Term fn a
t forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Binder fn a
:->) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {fn :: [*] -> * -> *}. Pred fn -> [Pred fn]
shrinkPred Pred fn
p
shrinkPred Pred fn
_ = []

isSuspendedSpec :: Specification fn a -> Bool
isSuspendedSpec :: forall (fn :: [*] -> * -> *) a. Specification fn a -> Bool
isSuspendedSpec (ExplainSpec [[Char]]
_ Specification fn a
x) = forall (fn :: [*] -> * -> *) a. Specification fn a -> Bool
isSuspendedSpec Specification fn a
x
isSuspendedSpec SuspendedSpec {} = Bool
True
isSuspendedSpec Specification fn a
_ = Bool
False

equalSpec :: a -> Specification fn a
equalSpec :: forall a (fn :: [*] -> * -> *). a -> Specification fn a
equalSpec = forall a (fn :: [*] -> * -> *). NonEmpty a -> Specification fn a
MemberSpec forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure

notEqualSpec :: forall fn a. HasSpec fn a => a -> Specification fn a
notEqualSpec :: forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a
notEqualSpec = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> OrdSet a -> Specification fn a
TypeSpec (forall (fn :: [*] -> * -> *) a. HasSpec fn a => TypeSpec fn a
emptySpec @fn @a) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure

notMemberSpec :: forall fn a f. (HasSpec fn a, Foldable f) => f a -> Specification fn a
notMemberSpec :: forall (fn :: [*] -> * -> *) a (f :: * -> *).
(HasSpec fn a, Foldable f) =>
f a -> Specification fn a
notMemberSpec = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> OrdSet a -> Specification fn a
typeSpecOpt (forall (fn :: [*] -> * -> *) a. HasSpec fn a => TypeSpec fn a
emptySpec @fn @a) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

typeSpec :: HasSpec fn a => TypeSpec fn a -> Specification fn a
typeSpec :: forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec TypeSpec fn a
ts = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> OrdSet a -> Specification fn a
TypeSpec TypeSpec fn a
ts forall a. Monoid a => a
mempty

-- Used to show binary operators like SumSpec and PairSpec
data BinaryShow where
  BinaryShow :: forall a. String -> [Doc a] -> BinaryShow
  NonBinary :: BinaryShow

-- The HasSpec Class ------------------------------------------------------

-- | This class provides the interface that allows you to extend the language
-- to handle a new type. In the case of types that have a generic representation
-- (via `HasSimpleRep`) that already has an instance of `HasSpec` it is sufficient
-- to provide an empty instance. However, for types that are used together with
-- specific functions in the function universe `fn` it may be necessary to provide
-- a specific implementation of `HasSpec`. This is typically necessary when the `TypeSpec`
-- for the generic representation does not permit an implementation of `propagateSpecFun`
-- for some function.
--
-- The basic types provided in the language, `Set`, `[]`, `Map`, `Int`, `Word64`,
-- `(,)`, `Either`, etc. have instances of this class (technically `(,)` and `Either` have
-- instances derived from the instances for their generic `Prod` and `Sum` implementations).
class
  ( Typeable a
  , Eq a
  , Show a
  , Show (TypeSpec fn a)
  , BaseUniverse fn
  ) =>
  HasSpec fn a
  where
  -- | The `TypeSpec fn a` is the type-specific `Specification fn a`.
  type TypeSpec (fn :: [Type] -> Type -> Type) a

  type TypeSpec fn a = TypeSpec fn (SimpleRep a)

  -- `TypeSpec` behaves sort-of like a monoid with a neutral
  -- enement `emptySpec` and a `combineSpec` for combining
  -- two `TypeSpec fn a`. However, in order to provide flexibilty
  -- `combineSpec` takes two `TypeSpec` and provide a `Specification`. This
  -- avoids e.g. having to have a separate implementation of `ErrorSpec`
  -- and `MemberSpec` in `TypeSpec`.

  emptySpec :: TypeSpec fn a
  combineSpec :: TypeSpec fn a -> TypeSpec fn a -> Specification fn a

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

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

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

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

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

  -- | A bound on the number of solutions `genFromTypeSpec TrueSpec` can produce.
  --   For a type with finite elements, we can get a much more accurate
  --   answer than TrueSpec
  cardinalTrueSpec :: Specification fn Integer
  cardinalTrueSpec = forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec

  -- Each instance can decide if a TypeSpec has an Error, and what String
  -- to pass to ErrorSpec to create an ErrorSpec value. Particulary
  -- useful for type Sum and Prod
  typeSpecHasError :: TypeSpec fn a -> Maybe (NE.NonEmpty String)
  typeSpecHasError TypeSpec fn a
_ = forall a. Maybe a
Nothing

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

  monadConformsTo :: a -> TypeSpec fn a -> Writer [String] Bool
  monadConformsTo a
x TypeSpec fn a
spec =
    if forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, HasCallStack) =>
a -> TypeSpec fn a -> Bool
conformsTo @fn @a a
x TypeSpec fn a
spec
      then forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      else forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [[Char]
"Fails by " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show TypeSpec fn a
spec] forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

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

  -- | This can be used to detect self inconsistencies in a (TypeSpec fn t)
  guardTypeSpec :: [String] -> TypeSpec fn a -> Specification fn a
  guardTypeSpec [[Char]]
_ TypeSpec fn a
ty = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec TypeSpec fn a
ty

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

  type Prerequisites fn a = ()

  -- | Materialize the `Prerequisites` dictionary. It should not be necessary to
  -- implement this function manually.
  prerequisites :: Evidence (Prerequisites fn a)
  default prerequisites :: Prerequisites fn a => Evidence (Prerequisites fn a)
  prerequisites = forall (c :: Constraint). c => Evidence c
Evidence

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

  default emptySpec ::
    (HasSpec fn (SimpleRep a), TypeSpec fn a ~ TypeSpec fn (SimpleRep a)) => TypeSpec fn a
  emptySpec = forall (fn :: [*] -> * -> *) a. HasSpec fn a => TypeSpec fn a
emptySpec @fn @(SimpleRep a)

  default combineSpec ::
    ( HasSimpleRep a
    , HasSpec fn (SimpleRep a)
    , TypeSpec fn a ~ TypeSpec fn (SimpleRep a)
    ) =>
    TypeSpec fn a ->
    TypeSpec fn a ->
    Specification fn a
  combineSpec TypeSpec fn a
s TypeSpec fn a
s' = forall a (fn :: [*] -> * -> *).
(HasSpec fn a, HasSimpleRep a,
 TypeSpec fn a ~ TypeSpec fn (SimpleRep a)) =>
Specification fn (SimpleRep a) -> Specification fn a
fromSimpleRepSpec forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> TypeSpec fn a -> Specification fn a
combineSpec @fn @(SimpleRep a) TypeSpec fn a
s TypeSpec fn a
s'

  default genFromTypeSpec ::
    ( HasSimpleRep a
    , HasSpec fn (SimpleRep a)
    , TypeSpec fn a ~ TypeSpec fn (SimpleRep a)
    ) =>
    (HasCallStack, MonadGenError m) =>
    TypeSpec fn a ->
    GenT m a
  genFromTypeSpec TypeSpec fn a
s = forall a. HasSimpleRep a => SimpleRep a -> a
fromSimpleRep forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (fn :: [*] -> * -> *) a (m :: * -> *).
(HasSpec fn a, HasCallStack, MonadGenError m) =>
TypeSpec fn a -> GenT m a
genFromTypeSpec @fn TypeSpec fn a
s

  default conformsTo ::
    ( HasSimpleRep a
    , HasSpec fn (SimpleRep a)
    , TypeSpec fn a ~ TypeSpec fn (SimpleRep a)
    ) =>
    HasCallStack =>
    a ->
    TypeSpec fn a ->
    Bool
  a
a `conformsTo` TypeSpec fn a
s = forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, HasCallStack) =>
a -> TypeSpec fn a -> Bool
conformsTo @fn (forall a. HasSimpleRep a => a -> SimpleRep a
toSimpleRep a
a) TypeSpec fn a
s

  default toPreds ::
    ( HasSpec fn (SimpleRep a)
    , TypeSpec fn a ~ TypeSpec fn (SimpleRep a)
    , HasSimpleRep a
    ) =>
    Term fn a ->
    TypeSpec fn a ->
    Pred fn
  toPreds Term fn a
v TypeSpec fn a
s = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> TypeSpec fn a -> Pred fn
toPreds (forall a (fn :: [*] -> * -> *).
(HasSpec fn a, HasSpec fn (SimpleRep a), HasSimpleRep a,
 TypeSpec fn a ~ TypeSpec fn (SimpleRep a)) =>
Term fn a -> Term fn (SimpleRep a)
toGeneric_ Term fn a
v) TypeSpec fn a
s

  default shrinkWithTypeSpec ::
    ( HasSpec fn (SimpleRep a)
    , TypeSpec fn a ~ TypeSpec fn (SimpleRep a)
    , HasSimpleRep a
    ) =>
    TypeSpec fn a ->
    a ->
    [a]
  shrinkWithTypeSpec TypeSpec fn a
spec a
a = forall a b. (a -> b) -> [a] -> [b]
map forall a. HasSimpleRep a => SimpleRep a -> a
fromSimpleRep forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> a -> [a]
shrinkWithTypeSpec @fn TypeSpec fn a
spec (forall a. HasSimpleRep a => a -> SimpleRep a
toSimpleRep a
a)

  default cardinalTypeSpec ::
    (HasSpec fn (SimpleRep a), TypeSpec fn a ~ TypeSpec fn (SimpleRep a)) =>
    TypeSpec fn a ->
    Specification fn Integer
  cardinalTypeSpec = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn Integer
cardinalTypeSpec @fn @(SimpleRep a)

data WithHasSpec fn f a where
  WithHasSpec :: HasSpec fn a => f a -> WithHasSpec fn f a

-- The Forallable class ---------------------------------------------------

class Forallable t e | t -> e where
  fromForAllSpec ::
    (HasSpec fn t, HasSpec fn e, BaseUniverse fn) => Specification fn e -> Specification fn t
  default fromForAllSpec ::
    ( HasSpec fn t
    , HasSpec fn e
    , HasSimpleRep t
    , TypeSpec fn t ~ TypeSpec fn (SimpleRep t)
    , Forallable (SimpleRep t) e
    , HasSpec fn (SimpleRep t)
    ) =>
    Specification fn e ->
    Specification fn t
  fromForAllSpec Specification fn e
es = forall a (fn :: [*] -> * -> *).
(HasSpec fn a, HasSimpleRep a,
 TypeSpec fn a ~ TypeSpec fn (SimpleRep a)) =>
Specification fn (SimpleRep a) -> Specification fn a
fromSimpleRepSpec forall a b. (a -> b) -> a -> b
$ forall t e (fn :: [*] -> * -> *).
(Forallable t e, HasSpec fn t, HasSpec fn e, BaseUniverse fn) =>
Specification fn e -> Specification fn t
fromForAllSpec @(SimpleRep t) @e Specification fn e
es

  forAllToList :: t -> [e]
  default forAllToList ::
    ( HasSimpleRep t
    , Forallable (SimpleRep t) e
    ) =>
    t ->
    [e]
  forAllToList t
t = forall t e. Forallable t e => t -> [e]
forAllToList (forall a. HasSimpleRep a => a -> SimpleRep a
toSimpleRep t
t)

-- The HasGenHint class ---------------------------------------------------

-- | Hints are things that only affect generation, and not validation. For instance, parameters to
--   control distribution of generated values.
class (HasSpec fn a, Show (Hint a)) => HasGenHint fn a where
  type Hint a
  giveHint :: Hint a -> Specification fn a

-- Semantics of specs -----------------------------------------------------

{-
conformsToSpecM ::
  forall fn a m. (HasSpec fn a, MonadGenError m, Alternative m) => a -> Specification fn a -> m ()
conformsToSpecM _ TrueSpec = pure ()
conformsToSpecM a (MemberSpec as) = explain1 (show a ++ " not an element of " ++ show as) $ guard $ elem a as
conformsToSpecM a (TypeSpec s cant) = guard $ notElem a cant && conformsTo @fn a s
conformsToSpecM a (SuspendedSpec v ps) = guard =<< checkPred (singletonEnv v a) ps
conformsToSpecM _ (ErrorSpec es) = explain es $ guard False
-}

conformsToSpecM ::
  forall fn a m. (HasSpec fn a, MonadGenError m) => a -> Specification fn a -> m ()
conformsToSpecM :: forall (fn :: [*] -> * -> *) a (m :: * -> *).
(HasSpec fn a, MonadGenError m) =>
a -> Specification fn a -> m ()
conformsToSpecM a
a (ExplainSpec [] Specification fn a
s) = forall (fn :: [*] -> * -> *) a (m :: * -> *).
(HasSpec fn a, MonadGenError m) =>
a -> Specification fn a -> m ()
conformsToSpecM a
a Specification fn a
s
conformsToSpecM a
a (ExplainSpec ([Char]
x : [[Char]]
xs) Specification fn a
s) = forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a -> m a
explain ([Char]
x forall a. a -> [a] -> NonEmpty a
:| [[Char]]
xs) (forall (fn :: [*] -> * -> *) a (m :: * -> *).
(HasSpec fn a, MonadGenError m) =>
a -> Specification fn a -> m ()
conformsToSpecM a
a Specification fn a
s)
conformsToSpecM a
_ Specification fn a
TrueSpec = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
conformsToSpecM a
a (MemberSpec NonEmpty a
as) =
  if forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem a
a NonEmpty a
as
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    else
      forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
fatalError
        ( forall a. [a] -> NonEmpty a
NE.fromList
            [[Char]
"conformsToSpecM MemberSpec case", [Char]
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
a, [Char]
"  not an element of", [Char]
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show NonEmpty a
as, [Char]
""]
        )
conformsToSpecM a
a spec :: Specification fn a
spec@(TypeSpec TypeSpec fn a
s OrdSet a
cant) =
  if forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem a
a OrdSet a
cant Bool -> Bool -> Bool
&& forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, HasCallStack) =>
a -> TypeSpec fn a -> Bool
conformsTo @fn a
a TypeSpec fn a
s
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    else
      forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
fatalError
        ( forall a. [a] -> NonEmpty a
NE.fromList
            [[Char]
"conformsToSpecM TypeSpec case", [Char]
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
a, [Char]
"  (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn a
spec forall a. [a] -> [a] -> [a]
++ [Char]
")", [Char]
"fails", [Char]
""]
        )
conformsToSpecM a
a spec :: Specification fn a
spec@(SuspendedSpec Var a
v Pred fn
ps) = do
  Bool
ans <- forall (fn :: [*] -> * -> *) (m :: * -> *).
(FunctionLike fn, MonadGenError m) =>
Env -> Pred fn -> m Bool
checkPred (forall a. (Typeable a, Show a) => Var a -> a -> Env
singletonEnv Var a
v a
a) Pred fn
ps
  if Bool
ans
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    else
      forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
fatalError
        ( forall a. [a] -> NonEmpty a
NE.fromList
            [ [Char]
"conformsToSpecM SuspendedSpec case on var " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Var a
v
            , [Char]
"\n " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
a
            , [Char]
"\n  (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn a
spec forall a. [a] -> [a] -> [a]
++ [Char]
")"
            , [Char]
"fails"
            , [Char]
""
            ]
        )
conformsToSpecM a
_ (ErrorSpec NonEmpty [Char]
es) = forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
fatalError ([Char]
"conformsToSpecM ErrorSpec case" forall a. a -> NonEmpty a -> NonEmpty a
NE.<| NonEmpty [Char]
es)

conformsToSpecProp :: forall fn a. HasSpec fn a => a -> Specification fn a -> Property
conformsToSpecProp :: forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Property
conformsToSpecProp a
a Specification fn a
s = forall p. Testable p => GE p -> Property
fromGEProp forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a (m :: * -> *).
(HasSpec fn a, MonadGenError m) =>
a -> Specification fn a -> m ()
conformsToSpecM a
a (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn a -> Specification fn a
simplifySpec Specification fn a
s)

conformsToSpec :: forall fn a. HasSpec fn a => a -> Specification fn a -> Bool
conformsToSpec :: forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
conformsToSpec a
a Specification fn a
s = forall a. GE a -> Bool
isOk forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a (m :: * -> *).
(HasSpec fn a, MonadGenError m) =>
a -> Specification fn a -> m ()
conformsToSpecM a
a Specification fn a
s

satisfies :: forall fn a. HasSpec fn a => Term fn a -> Specification fn a -> Pred fn
satisfies :: forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Specification fn a -> Pred fn
satisfies Term fn a
e (ExplainSpec [] Specification fn a
s) = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Specification fn a -> Pred fn
satisfies Term fn a
e Specification fn a
s
satisfies Term fn a
e (ExplainSpec ([Char]
x : [[Char]]
xs) Specification fn a
s) = forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn -> Pred fn
Explain ([Char]
x forall a. a -> [a] -> NonEmpty a
:| [[Char]]
xs) forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Specification fn a -> Pred fn
satisfies Term fn a
e Specification fn a
s
satisfies Term fn a
_ Specification fn a
TrueSpec = forall (fn :: [*] -> * -> *). Pred fn
TruePred
satisfies Term fn a
e (MemberSpec NonEmpty a
nonempty) = forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn -> Pred fn
Explain (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Show a => a -> [Char]
show Term fn a
e forall a. [a] -> [a] -> [a]
++ [Char]
" `elem` " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [a]
as)) forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Term fn Bool -> Pred fn
Assert forall a b. (a -> b) -> a -> b
$ forall a (fn :: [*] -> * -> *).
HasSpec fn a =>
Term fn a -> Term fn [a] -> Term fn Bool
elem_ Term fn a
e (forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit [a]
as)
  where
    as :: [a]
as = forall a. NonEmpty a -> [a]
NE.toList NonEmpty a
nonempty
satisfies Term fn a
t (SuspendedSpec Var a
x Pred fn
p) = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> Pred fn -> Pred fn
Subst Var a
x Term fn a
t Pred fn
p
satisfies Term fn a
e (TypeSpec TypeSpec fn a
s [a]
cant)
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
cant = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> TypeSpec fn a -> Pred fn
toPreds Term fn a
e TypeSpec fn a
s
  | Bool
otherwise =
      forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn -> Pred fn
Explain (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Show a => a -> [Char]
show Term fn a
e forall a. [a] -> [a] -> [a]
++ [Char]
" `notElem` " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [a]
cant)) (forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Term fn Bool -> Pred fn
Assert (forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Term fn Bool -> Term fn Bool
not_ (forall a (fn :: [*] -> * -> *).
HasSpec fn a =>
Term fn a -> Term fn [a] -> Term fn Bool
elem_ Term fn a
e forall a b. (a -> b) -> a -> b
$ forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit [a]
cant)))
        forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> TypeSpec fn a -> Pred fn
toPreds Term fn a
e TypeSpec fn a
s
satisfies Term fn a
_ (ErrorSpec NonEmpty [Char]
e) = forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn
FalsePred NonEmpty [Char]
e

------------------------------------------------------------------------
-- Generating things
------------------------------------------------------------------------

-- Generating things from specs -------------------------------------------

-- | Generate a value that satisfies the spec. This function can fail if the
-- spec is inconsistent, there is a dependency error, or if the underlying
-- generators are not flexible enough.
genFromSpecT ::
  forall fn a m. (HasCallStack, HasSpec fn a, MonadGenError m) => Specification fn a -> GenT m a
genFromSpecT :: forall (fn :: [*] -> * -> *) a (m :: * -> *).
(HasCallStack, HasSpec fn a, MonadGenError m) =>
Specification fn a -> GenT m a
genFromSpecT (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn a -> Specification fn a
simplifySpec -> Specification fn a
spec) = case Specification fn a
spec of
  ExplainSpec [] Specification fn a
s -> forall (fn :: [*] -> * -> *) a (m :: * -> *).
(HasCallStack, HasSpec fn a, MonadGenError m) =>
Specification fn a -> GenT m a
genFromSpecT Specification fn a
s
  ExplainSpec [[Char]]
es Specification fn a
s -> forall (m :: * -> *) a.
MonadGenError m =>
[[Char]] -> GenT GE a -> GenT m a
push [[Char]]
es (forall (fn :: [*] -> * -> *) a (m :: * -> *).
(HasCallStack, HasSpec fn a, MonadGenError m) =>
Specification fn a -> GenT m a
genFromSpecT Specification fn a
s)
  MemberSpec NonEmpty a
as -> forall (m :: * -> *) a. MonadGenError m => [Char] -> m a -> m a
explain1 ([Char]
"genFromSpecT on spec" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn a
spec) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Applicative m => Gen a -> GenT m a
pureGen (forall a. HasCallStack => [a] -> Gen a
elements (forall a. NonEmpty a -> [a]
NE.toList NonEmpty a
as))
  Specification fn a
TrueSpec -> forall (fn :: [*] -> * -> *) a (m :: * -> *).
(HasCallStack, HasSpec fn a, MonadGenError m) =>
Specification fn a -> GenT m a
genFromSpecT @fn (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a. HasSpec fn a => TypeSpec fn a
emptySpec @fn @a)
  SuspendedSpec Var a
x Pred fn
p
    -- NOTE: If `x` isn't free in `p` we still have to try to generate things
    -- from `p` to make sure `p` is sat and then we can throw it away. A better
    -- approach would be to only do this in the case where we don't know if `p`
    -- is sat. The proper way to implement such a sat check is to remove
    -- sat-but-unnecessary variables in the optimiser.
    | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Name fn
Name Var a
x forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
`appearsIn` Pred fn
p -> do
        !Env
_ <- forall (fn :: [*] -> * -> *) (m :: * -> *).
(MonadGenError m, BaseUniverse fn) =>
Env -> Pred fn -> GenT m Env
genFromPreds forall a. Monoid a => a
mempty Pred fn
p
        forall (fn :: [*] -> * -> *) a (m :: * -> *).
(HasCallStack, HasSpec fn a, MonadGenError m) =>
Specification fn a -> GenT m a
genFromSpecT @fn forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec
    | Bool
otherwise -> do
        Env
env <- forall (fn :: [*] -> * -> *) (m :: * -> *).
(MonadGenError m, BaseUniverse fn) =>
Env -> Pred fn -> GenT m Env
genFromPreds forall a. Monoid a => a
mempty Pred fn
p
        forall a (m :: * -> *).
(Typeable a, MonadGenError m) =>
Env -> Var a -> m a
findEnv Env
env Var a
x
  TypeSpec TypeSpec fn a
s OrdSet a
cant -> do
    GenMode
mode <- forall (m :: * -> *). Applicative m => GenT m GenMode
getMode
    forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a -> m a
explain
      ( forall a. [a] -> NonEmpty a
NE.fromList
          [ [Char]
"genFromSpecT at type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep OrdSet a
cant)
          , [Char]
"    " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn a
spec
          , [Char]
"  with mode " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show GenMode
mode
          , [Char]
"  cant set {" forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unlines (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> [Char]
show OrdSet a
cant) forall a. [a] -> [a] -> [a]
++ [Char]
"}"
          ]
      )
      forall a b. (a -> b) -> a -> b
$
      -- TODO: we could consider giving `cant` as an argument to `genFromTypeSpec` if this
      -- starts giving us trouble.
      forall (fn :: [*] -> * -> *) a (m :: * -> *).
(HasSpec fn a, HasCallStack, MonadGenError m) =>
TypeSpec fn a -> GenT m a
genFromTypeSpec @fn TypeSpec fn a
s forall (m :: * -> *) a.
MonadGenError m =>
GenT m a -> (a -> Bool) -> GenT m a
`suchThatT` (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` OrdSet a
cant)
  ErrorSpec NonEmpty [Char]
e -> forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
genError NonEmpty [Char]
e

shrinkWithSpec :: forall fn a. HasSpec fn a => Specification fn a -> a -> [a]
-- TODO: possibly allow for ignoring the `conformsToSpec` check in the `TypeSpec`
-- case when you know what you're doing
shrinkWithSpec :: forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn a -> a -> [a]
shrinkWithSpec (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn a -> Specification fn a
simplifySpec -> Specification fn a
spec) a
a = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
`conformsToSpec` Specification fn a
spec) forall a b. (a -> b) -> a -> b
$ case Specification fn a
spec of
  ExplainSpec [[Char]]
_ Specification fn a
s -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn a -> a -> [a]
shrinkWithSpec Specification fn a
s a
a
  -- TODO: filter on can't if we have a known to be sound shrinker
  TypeSpec TypeSpec fn a
s [a]
_ -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> a -> [a]
shrinkWithTypeSpec @fn TypeSpec fn a
s a
a
  -- TODO: The better way of doing this is to compute the dependency graph,
  -- shrink one variable at a time, and fixup the rest of the variables
  SuspendedSpec {} -> a -> [a]
shr a
a
  MemberSpec {} -> a -> [a]
shr a
a
  Specification fn a
TrueSpec -> a -> [a]
shr a
a
  ErrorSpec {} -> []
  where
    shr :: a -> [a]
shr = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> a -> [a]
shrinkWithTypeSpec @fn (forall (fn :: [*] -> * -> *) a. HasSpec fn a => TypeSpec fn a
emptySpec @fn @a)

shrinkFromPreds :: HasSpec fn a => Pred fn -> Var a -> a -> [a]
shrinkFromPreds :: forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Pred fn -> Var a -> a -> [a]
shrinkFromPreds Pred fn
p
  | Result [NonEmpty [Char]]
_ SolverPlan fn
plan <- forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Pred fn -> GE (SolverPlan fn)
prepareLinearization Pred fn
p = \Var a
x a
a -> forall a. GE [a] -> [a]
listFromGE forall a b. (a -> b) -> a -> b
$ do
      -- NOTE: we do this to e.g. guard against bad construction functions in Exists
      Bool
xaGood <- forall (fn :: [*] -> * -> *) (m :: * -> *).
(FunctionLike fn, MonadGenError m) =>
Env -> Pred fn -> m Bool
checkPred (forall a. (Typeable a, Show a) => Var a -> a -> Env
singletonEnv Var a
x a
a) Pred fn
p
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
xaGood forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. MonadGenError m => [Char] -> m a
fatalError1 [Char]
"Trying to shrink a bad value, don't do that!"
      -- Get an `env` for the original value
      Env
initialEnv <- forall (fn :: [*] -> * -> *). Env -> Pred fn -> GE Env
envFromPred (forall a. (Typeable a, Show a) => Var a -> a -> Env
singletonEnv Var a
x a
a) Pred fn
p
      forall (m :: * -> *) a. Monad m => a -> m a
return
        [ a
a'
        | -- Shrink the initialEnv
        Env
env' <- forall (fn :: [*] -> * -> *). Env -> SolverPlan fn -> [Env]
shrinkEnvFromPlan Env
initialEnv SolverPlan fn
plan
        , -- Get the value of the constrained variable `x` in the shrunk env
        Just a
a' <- [forall a. Typeable a => Env -> Var a -> Maybe a
lookupEnv Env
env' Var a
x]
        , -- NOTE: this is necessary because it's possible that changing
        -- a particular value in the env during shrinking might not result
        -- in the value of `x` changing and there is no better way to know than
        -- to do this.
        a
a' forall a. Eq a => a -> a -> Bool
/= a
a
        ]
  | Bool
otherwise = forall a. HasCallStack => [Char] -> a
error [Char]
"Bad pred"

-- Start with a valid Env for the plan and try to shrink it
shrinkEnvFromPlan :: Env -> SolverPlan fn -> [Env]
shrinkEnvFromPlan :: forall (fn :: [*] -> * -> *). Env -> SolverPlan fn -> [Env]
shrinkEnvFromPlan Env
initialEnv SolverPlan {[SolverStage fn]
Graph (Name fn)
solverDependencies :: forall (fn :: [*] -> * -> *). SolverPlan fn -> Graph (Name fn)
solverPlan :: forall (fn :: [*] -> * -> *). SolverPlan fn -> [SolverStage fn]
solverDependencies :: Graph (Name fn)
solverPlan :: [SolverStage fn]
..} = Env -> [SolverStage fn] -> [Env]
go forall a. Monoid a => a
mempty [SolverStage fn]
solverPlan
  where
    go :: Env -> [SolverStage fn] -> [Env]
go Env
_ [] = [] -- In this case we decided to keep every variable the same so nothing to return
    go Env
env ((forall (fn :: [*] -> * -> *).
Env -> SolverStage fn -> SolverStage fn
substStage Env
env -> SolverStage {[Pred fn]
Var a
Specification fn a
stageSpec :: ()
stagePreds :: forall (fn :: [*] -> * -> *). SolverStage fn -> [Pred fn]
stageVar :: ()
stageSpec :: Specification fn a
stagePreds :: [Pred fn]
stageVar :: Var a
..}) : [SolverStage fn]
plan) = do
      Just a
a <- [forall a. Typeable a => Env -> Var a -> Maybe a
lookupEnv Env
initialEnv Var a
stageVar]
      -- Two cases:
      --  - either we shrink this value and try to fixup every value later on in the plan or
      [ Env
env' forall a. Semigroup a => a -> a -> a
<> Env
fixedEnv
        | a
a' <- forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn a -> a -> [a]
shrinkWithSpec Specification fn a
stageSpec a
a
        , let env' :: Env
env' = forall a. (Typeable a, Show a) => Var a -> a -> Env -> Env
extendEnv Var a
stageVar a
a' Env
env
        , Just Env
fixedEnv <- [Env -> [SolverStage fn] -> Maybe Env
fixupPlan Env
env' [SolverStage fn]
plan]
        ]
        --  - we keep this value the way it is and try to shrink some later value
        forall a. [a] -> [a] -> [a]
++ Env -> [SolverStage fn] -> [Env]
go (forall a. (Typeable a, Show a) => Var a -> a -> Env -> Env
extendEnv Var a
stageVar a
a Env
env) [SolverStage fn]
plan

    -- Fix the rest of the plan given an environment `env` for the plan so far
    fixupPlan :: Env -> [SolverStage fn] -> Maybe Env
fixupPlan Env
env [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure Env
env
    fixupPlan Env
env ((forall (fn :: [*] -> * -> *).
Env -> SolverStage fn -> SolverStage fn
substStage Env
env -> SolverStage {[Pred fn]
Var a
Specification fn a
stageSpec :: Specification fn a
stagePreds :: [Pred fn]
stageVar :: Var a
stageSpec :: ()
stagePreds :: forall (fn :: [*] -> * -> *). SolverStage fn -> [Pred fn]
stageVar :: ()
..}) : [SolverStage fn]
plan) =
      case forall a. Typeable a => Env -> Var a -> Maybe a
lookupEnv Env
initialEnv Var a
stageVar forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn a -> a -> Maybe a
fixupWithSpec Specification fn a
stageSpec of
        Maybe a
Nothing -> forall a. Maybe a
Nothing
        Just a
a -> Env -> [SolverStage fn] -> Maybe Env
fixupPlan (forall a. (Typeable a, Show a) => Var a -> a -> Env -> Env
extendEnv Var a
stageVar a
a Env
env) [SolverStage fn]
plan

-- Try to fix a value w.r.t a specification
fixupWithSpec :: forall fn a. HasSpec fn a => Specification fn a -> a -> Maybe a
fixupWithSpec :: forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn a -> a -> Maybe a
fixupWithSpec Specification fn a
spec a
a
  | a
a forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
`conformsToSpec` Specification fn a
spec = forall a. a -> Maybe a
Just a
a
  | Bool
otherwise = case Specification fn a
spec of
      MemberSpec (a
a :| [a]
_) -> forall a. a -> Maybe a
Just a
a
      Specification fn a
_ -> forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
`conformsToSpec` Specification fn a
spec) (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn a -> a -> [a]
shrinkWithSpec @fn forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec a
a)

-- Construct an environment for all variables that show up on the top level
-- (i.e. ones bound in `let` and `exists`) from an environment for all the free
-- variables in the pred. The environment you get out of this function is
-- _bigger_ than the environment you put in. From
-- ```
-- let y = x + 1 in let z = y + 1 in foo x y z
-- ```
-- and an environment with `{x -> 1}` you would get `{x -> 1, y -> 2, z -> 3}`
-- out.
envFromPred :: Env -> Pred fn -> GE Env
envFromPred :: forall (fn :: [*] -> * -> *). Env -> Pred fn -> GE Env
envFromPred Env
env Pred fn
p = case Pred fn
p of
  -- NOTE: these don't bind anything
  Assert {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Env
env
  DependsOn {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Env
env
  Monitor {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Env
env
  TruePred {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Env
env
  FalsePred {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Env
env
  GenHint {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Env
env
  -- NOTE: this is ok because the variables either come from an `Exists`, a `Let`, or from
  -- the top level
  Reifies {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Env
env
  -- NOTE: variables in here shouldn't escape to the top level
  ForAll {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Env
env
  Case {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Env
env
  -- These can introduce binders that show up in the plan
  When Term fn Bool
_ Pred fn
p -> forall (fn :: [*] -> * -> *). Env -> Pred fn -> GE Env
envFromPred Env
env Pred fn
p
  Subst Var a
x Term fn a
a Pred fn
p -> forall (fn :: [*] -> * -> *). Env -> Pred fn -> GE Env
envFromPred Env
env (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> Pred fn -> Pred fn
substitutePred Var a
x Term fn a
a Pred fn
p)
  Let Term fn a
t (Var a
x :-> Pred fn
p) -> do
    a
v <- forall (m :: * -> *) (fn :: [*] -> * -> *) a.
MonadGenError m =>
Env -> Term fn a -> m a
runTerm Env
env Term fn a
t
    forall (fn :: [*] -> * -> *). Env -> Pred fn -> GE Env
envFromPred (forall a. (Typeable a, Show a) => Var a -> a -> Env -> Env
extendEnv Var a
x a
v Env
env) Pred fn
p
  Explain NonEmpty [Char]
_ Pred fn
p -> forall (fn :: [*] -> * -> *). Env -> Pred fn -> GE Env
envFromPred Env
env Pred fn
p
  Exists (forall b. Term fn b -> b) -> GE a
c (Var a
x :-> Pred fn
p) -> do
    a
v <- (forall b. Term fn b -> b) -> GE a
c (forall a. GE a -> a
errorGE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadGenError m => [Char] -> m a -> m a
explain1 [Char]
"envFromPred: Exists" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) (fn :: [*] -> * -> *) a.
MonadGenError m =>
Env -> Term fn a -> m a
runTerm Env
env)
    forall (fn :: [*] -> * -> *). Env -> Pred fn -> GE Env
envFromPred (forall a. (Typeable a, Show a) => Var a -> a -> Env -> Env
extendEnv Var a
x a
v Env
env) Pred fn
p
  Block [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Env
env
  Block (Pred fn
p : [Pred fn]
ps) -> do
    Env
env' <- forall (fn :: [*] -> * -> *). Env -> Pred fn -> GE Env
envFromPred Env
env Pred fn
p
    forall (fn :: [*] -> * -> *). Env -> Pred fn -> GE Env
envFromPred Env
env' (forall (fn :: [*] -> * -> *). [Pred fn] -> Pred fn
Block [Pred fn]
ps)

-- | A version of `genFromSpecT` that simply errors if the generator fails
genFromSpec :: forall fn a. (HasCallStack, HasSpec fn a) => Specification fn a -> Gen a
genFromSpec :: forall (fn :: [*] -> * -> *) a.
(HasCallStack, HasSpec fn a) =>
Specification fn a -> Gen a
genFromSpec Specification fn a
spec = do
  GE a
res <- forall (m :: * -> *) a. GenT m a -> Gen (m a)
strictGen forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadGenError m => [Char] -> m a -> m a
explain1 [Char]
"Calling genFromSpec" forall a b. (a -> b) -> a -> b
$ do
    a
r <- forall (fn :: [*] -> * -> *) a (m :: * -> *).
(HasCallStack, HasSpec fn a, MonadGenError m) =>
Specification fn a -> GenT m a
genFromSpecT Specification fn a
spec
    forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$
      a
r seq :: forall a b. a -> b -> b
`seq`
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
e :: SomeException) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
fatalError (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show SomeException
e))
  forall a. GE a -> a
errorGE forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. Applicative f => a -> f a
pure GE a
res

-- | A version of `genFromSpecT` that takes a seed and a size and gives you a result
genFromSpecWithSeed ::
  forall fn a. (HasCallStack, HasSpec fn a) => Int -> Int -> Specification fn a -> a
genFromSpecWithSeed :: forall (fn :: [*] -> * -> *) a.
(HasCallStack, HasSpec fn a) =>
Int -> Int -> Specification fn a -> a
genFromSpecWithSeed Int
seed Int
size Specification fn a
spec = forall a. Gen a -> QCGen -> Int -> a
unGen (forall (fn :: [*] -> * -> *) a.
(HasCallStack, HasSpec fn a) =>
Specification fn a -> Gen a
genFromSpec Specification fn a
spec) (Int -> QCGen
mkQCGen Int
seed) Int
size

genInverse ::
  ( MonadGenError m
  , HasSpec fn a
  , Show b
  , Functions fn fn
  , HasSpec fn b
  ) =>
  fn '[a] b ->
  Specification fn a ->
  b ->
  GenT m a
genInverse :: forall (m :: * -> *) (fn :: [*] -> * -> *) a b.
(MonadGenError m, HasSpec fn a, Show b, Functions fn fn,
 HasSpec fn b) =>
fn '[a] b -> Specification fn a -> b -> GenT m a
genInverse fn '[a] b
f Specification fn a
argS b
x =
  let argSpec' :: Specification fn a
argSpec' = Specification fn a
argS forall a. Semigroup a => a -> a -> a
<> forall (f :: [*] -> * -> *) (fn :: [*] -> * -> *) (as :: [*]) a b.
(Functions f fn, TypeList as, Typeable as, HasSpec fn a,
 HasSpec fn b, All (HasSpec fn) as) =>
f as b
-> ListCtx Value as (HOLE a)
-> Specification fn b
-> Specification fn a
propagateSpecFun fn '[a] b
f (forall (c :: * -> *) a (f :: * -> *). c a -> ListCtx f '[a] c
NilCtx forall a. HOLE a a
HOLE) (forall a (fn :: [*] -> * -> *). a -> Specification fn a
equalSpec b
x)
   in forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a -> m a
explain
        ( forall a. [a] -> NonEmpty a
NE.fromList
            [ [Char]
"genInverse"
            , [Char]
"  f = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show fn '[a] b
f
            , forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ Doc Any
"  argS =" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Specification fn a
argS
            , [Char]
"  x = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show b
x
            , forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ Doc Any
"  argSpec' =" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Specification fn a
argSpec'
            ]
        )
        forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a (m :: * -> *).
(HasCallStack, HasSpec fn a, MonadGenError m) =>
Specification fn a -> GenT m a
genFromSpecT Specification fn a
argSpec'

-- Generating things from predicates --------------------------------------

-- | Flatten nested `Let`, `Exists`, and `Block` in a `Pred fn`. `Let` and
-- `Exists` bound variables become free in the result.
flattenPred :: forall fn. BaseUniverse fn => Pred fn -> [Pred fn]
flattenPred :: forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Pred fn -> [Pred fn]
flattenPred Pred fn
pIn = Set Int -> [Pred fn] -> [Pred fn]
go (forall (fn :: [*] -> * -> *) t. HasVariables fn t => t -> Set Int
freeVarNames Pred fn
pIn) [Pred fn
pIn]
  where
    go :: Set Int -> [Pred fn] -> [Pred fn]
go Set Int
_ [] = []
    go Set Int
fvs (Pred fn
p : [Pred fn]
ps) = case Pred fn
p of
      Block [Pred fn]
ps' -> Set Int -> [Pred fn] -> [Pred fn]
go Set Int
fvs ([Pred fn]
ps' forall a. [a] -> [a] -> [a]
++ [Pred fn]
ps)
      -- NOTE: the order of the arguments to `==.` here are important.
      -- The whole point of `Let` is that it allows us to solve all of `t`
      -- before we solve the variables in `t`.
      Let Term fn a
t Binder fn a
b -> forall a.
Set Int
-> Binder fn a
-> [Pred fn]
-> (HasSpec fn a => Var a -> [Pred fn] -> [Pred fn])
-> [Pred fn]
goBinder Set Int
fvs Binder fn a
b [Pred fn]
ps (\Var a
x -> (forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
p -> Pred fn
assert (Term fn a
t forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Term fn a -> Term fn Bool
==. forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Term fn a
V Var a
x) forall a. a -> [a] -> [a]
:))
      Exists (forall b. Term fn b -> b) -> GE a
_ Binder fn a
b -> forall a.
Set Int
-> Binder fn a
-> [Pred fn]
-> (HasSpec fn a => Var a -> [Pred fn] -> [Pred fn])
-> [Pred fn]
goBinder Set Int
fvs Binder fn a
b [Pred fn]
ps (forall a b. a -> b -> a
const forall a. a -> a
id)
      When Term fn Bool
b Pred fn
p -> forall a b. (a -> b) -> [a] -> [b]
map (forall (fn :: [*] -> * -> *).
HasSpec fn Bool =>
Term fn Bool -> Pred fn -> Pred fn
When Term fn Bool
b) (Set Int -> [Pred fn] -> [Pred fn]
go Set Int
fvs [Pred fn
p]) forall a. [a] -> [a] -> [a]
++ Set Int -> [Pred fn] -> [Pred fn]
go Set Int
fvs [Pred fn]
ps
      Explain NonEmpty [Char]
es Pred fn
p -> forall a b. (a -> b) -> [a] -> [b]
map (forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn -> Pred fn
explanation NonEmpty [Char]
es) (Set Int -> [Pred fn] -> [Pred fn]
go Set Int
fvs [Pred fn
p]) forall a. [a] -> [a] -> [a]
++ Set Int -> [Pred fn] -> [Pred fn]
go Set Int
fvs [Pred fn]
ps
      Pred fn
_ -> Pred fn
p forall a. a -> [a] -> [a]
: Set Int -> [Pred fn] -> [Pred fn]
go Set Int
fvs [Pred fn]
ps

    goBinder ::
      Set Int ->
      Binder fn a ->
      [Pred fn] ->
      (HasSpec fn a => Var a -> [Pred fn] -> [Pred fn]) ->
      [Pred fn]
    goBinder :: forall a.
Set Int
-> Binder fn a
-> [Pred fn]
-> (HasSpec fn a => Var a -> [Pred fn] -> [Pred fn])
-> [Pred fn]
goBinder Set Int
fvs (Var a
x :-> Pred fn
p) [Pred fn]
ps HasSpec fn a => Var a -> [Pred fn] -> [Pred fn]
k = HasSpec fn a => Var a -> [Pred fn] -> [Pred fn]
k Var a
x' forall a b. (a -> b) -> a -> b
$ Set Int -> [Pred fn] -> [Pred fn]
go (forall a. Ord a => a -> Set a -> Set a
Set.insert (forall a. Var a -> Int
nameOf Var a
x') Set Int
fvs) (Pred fn
p' forall a. a -> [a] -> [a]
: [Pred fn]
ps)
      where
        (Var a
x', Pred fn
p') = forall a t.
(Typeable a, Rename t) =>
Var a -> t -> Set Int -> (Var a, t)
freshen Var a
x Pred fn
p Set Int
fvs

computeDependencies :: Pred fn -> DependGraph fn
computeDependencies :: forall (fn :: [*] -> * -> *). Pred fn -> DependGraph fn
computeDependencies = \case
  Monitor {} -> forall a. Monoid a => a
mempty
  Subst Var a
x Term fn a
t Pred fn
p -> forall (fn :: [*] -> * -> *). Pred fn -> DependGraph fn
computeDependencies (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> Pred fn -> Pred fn
substitutePred Var a
x Term fn a
t Pred fn
p)
  Assert Term fn Bool
t -> forall (fn :: [*] -> * -> *) a. Term fn a -> DependGraph fn
computeTermDependencies Term fn Bool
t
  Reifies Term fn b
t' Term fn a
t a -> b
_ -> Term fn b
t' forall (fn :: [*] -> * -> *) t t'.
(HasVariables fn t, HasVariables fn t') =>
t -> t' -> DependGraph fn
`irreflexiveDependencyOn` Term fn a
t
  ForAll Term fn t
set Binder fn a
b ->
    let innerG :: DependGraph fn
innerG = forall (fn :: [*] -> * -> *) a. Binder fn a -> DependGraph fn
computeBinderDependencies Binder fn a
b
     in DependGraph fn
innerG forall a. Semigroup a => a -> a -> a
<> Term fn t
set forall (fn :: [*] -> * -> *) t t'.
(HasVariables fn t, HasVariables fn t') =>
t -> t' -> DependGraph fn
`irreflexiveDependencyOn` forall node. Graph node -> Set node
nodes DependGraph fn
innerG
  Term fn a
x `DependsOn` Term fn b
y -> Term fn a
x forall (fn :: [*] -> * -> *) t t'.
(HasVariables fn t, HasVariables fn t') =>
t -> t' -> DependGraph fn
`irreflexiveDependencyOn` Term fn b
y
  Case Term fn (SumOver as)
t List (Weighted (Binder fn)) as
bs ->
    let innerG :: DependGraph fn
innerG = forall {k} b (f :: k -> *) (as :: [k]).
Monoid b =>
(forall (a :: k). f a -> b) -> List f as -> b
foldMapList (forall (fn :: [*] -> * -> *) a. Binder fn a -> DependGraph fn
computeBinderDependencies forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Weighted f a -> f a
thing) List (Weighted (Binder fn)) as
bs
     in DependGraph fn
innerG forall a. Semigroup a => a -> a -> a
<> Term fn (SumOver as)
t forall (fn :: [*] -> * -> *) t t'.
(HasVariables fn t, HasVariables fn t') =>
t -> t' -> DependGraph fn
`irreflexiveDependencyOn` forall node. Graph node -> Set node
nodes DependGraph fn
innerG
  When Term fn Bool
b Pred fn
p ->
    let pG :: DependGraph fn
pG = forall (fn :: [*] -> * -> *). Pred fn -> DependGraph fn
computeDependencies Pred fn
p
        oG :: DependGraph fn
oG = forall node. Graph node -> Set node
nodes DependGraph fn
pG forall (fn :: [*] -> * -> *) t t'.
(HasVariables fn t, HasVariables fn t') =>
t -> t' -> DependGraph fn
`irreflexiveDependencyOn` Term fn Bool
b
     in DependGraph fn
oG forall a. Semigroup a => a -> a -> a
<> DependGraph fn
pG
  Pred fn
TruePred -> forall a. Monoid a => a
mempty
  FalsePred {} -> forall a. Monoid a => a
mempty
  Block [Pred fn]
ps -> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall (fn :: [*] -> * -> *). Pred fn -> DependGraph fn
computeDependencies [Pred fn]
ps
  Exists (forall b. Term fn b -> b) -> GE a
_ Binder fn a
b -> forall (fn :: [*] -> * -> *) a. Binder fn a -> DependGraph fn
computeBinderDependencies Binder fn a
b
  Let Term fn a
t Binder fn a
b -> forall (fn :: [*] -> * -> *) t.
HasVariables fn t =>
t -> DependGraph fn
noDependencies Term fn a
t forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a. Binder fn a -> DependGraph fn
computeBinderDependencies Binder fn a
b
  GenHint Hint a
_ Term fn a
t -> forall (fn :: [*] -> * -> *) t.
HasVariables fn t =>
t -> DependGraph fn
noDependencies Term fn a
t
  Explain NonEmpty [Char]
_ Pred fn
p -> forall (fn :: [*] -> * -> *). Pred fn -> DependGraph fn
computeDependencies Pred fn
p

data SolverStage fn where
  SolverStage ::
    HasSpec fn a =>
    { ()
stageVar :: Var a
    , forall (fn :: [*] -> * -> *). SolverStage fn -> [Pred fn]
stagePreds :: [Pred fn]
    , ()
stageSpec :: Specification fn a
    } ->
    SolverStage fn

instance Pretty (SolverStage fn) where
  pretty :: forall ann. SolverStage fn -> Doc ann
pretty SolverStage {[Pred fn]
Var a
Specification fn a
stageSpec :: Specification fn a
stagePreds :: [Pred fn]
stageVar :: Var a
stageSpec :: ()
stagePreds :: forall (fn :: [*] -> * -> *). SolverStage fn -> [Pred fn]
stageVar :: ()
..} =
    forall a ann. Show a => a -> Doc ann
viaShow Var a
stageVar
      forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"<-"
        forall ann. Doc ann -> Doc ann -> Doc ann
/> forall ann. [Doc ann] -> Doc ann
vsep'
          ( [forall a ann. Pretty a => a -> Doc ann
pretty Specification fn a
stageSpec | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a. Specification fn a -> Bool
isTrueSpec Specification fn a
stageSpec]
              forall a. [a] -> [a] -> [a]
++ [Doc ann
"---" | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pred fn]
stagePreds, Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a. Specification fn a -> Bool
isTrueSpec Specification fn a
stageSpec]
              forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a ann. Pretty a => a -> Doc ann
pretty [Pred fn]
stagePreds
          )

data SolverPlan fn = SolverPlan
  { forall (fn :: [*] -> * -> *). SolverPlan fn -> [SolverStage fn]
solverPlan :: [SolverStage fn]
  , forall (fn :: [*] -> * -> *). SolverPlan fn -> Graph (Name fn)
solverDependencies :: Graph (Name fn)
  }

instance Pretty (SolverPlan fn) where
  pretty :: forall ann. SolverPlan fn -> Doc ann
pretty SolverPlan {[SolverStage fn]
Graph (Name fn)
solverDependencies :: Graph (Name fn)
solverPlan :: [SolverStage fn]
solverDependencies :: forall (fn :: [*] -> * -> *). SolverPlan fn -> Graph (Name fn)
solverPlan :: forall (fn :: [*] -> * -> *). SolverPlan fn -> [SolverStage fn]
..} =
    Doc ann
"\nSolverPlan"
      forall ann. Doc ann -> Doc ann -> Doc ann
/> forall ann. [Doc ann] -> Doc ann
vsep'
        [ -- "\nDependencies:" /> pretty solverDependencies, -- Might be usefull someday
          Doc ann
"\nLinearization:" forall ann. Doc ann -> Doc ann -> Doc ann
/> forall (fn :: [*] -> * -> *) ann. [SolverStage fn] -> Doc ann
prettyLinear [SolverStage fn]
solverPlan
        ]

isTrueSpec :: Specification fn a -> Bool
isTrueSpec :: forall (fn :: [*] -> * -> *) a. Specification fn a -> Bool
isTrueSpec Specification fn a
TrueSpec = Bool
True
isTrueSpec Specification fn a
_ = Bool
False

prettyLinear :: [SolverStage fn] -> Doc ann
prettyLinear :: forall (fn :: [*] -> * -> *) ann. [SolverStage fn] -> Doc ann
prettyLinear = forall ann. [Doc ann] -> Doc ann
vsep' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a ann. Pretty a => a -> Doc ann
pretty

-- | Linearize a predicate, turning it into a list of variables to solve and
-- their defining constraints such that each variable can be solved independently.
prepareLinearization ::
  forall fn. BaseUniverse fn => Pred fn -> GE (SolverPlan fn)
prepareLinearization :: forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Pred fn -> GE (SolverPlan fn)
prepareLinearization Pred fn
p = do
  let preds :: [Pred fn]
preds = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {fn :: [*] -> * -> *}. Pred fn -> [Pred fn]
saturatePred forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Pred fn -> [Pred fn]
flattenPred Pred fn
p
      hints :: Hints fn
hints = forall (fn :: [*] -> * -> *). [Pred fn] -> Hints fn
computeHints [Pred fn]
preds
      graph :: Hints fn
graph = forall node. Ord node => Graph node -> Graph node
transitiveClosure forall a b. (a -> b) -> a -> b
$ Hints fn
hints forall a. Semigroup a => a -> a -> a
<> forall (f :: [*] -> * -> *). Hints f -> Hints f -> Hints f
respecting Hints fn
hints (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall (fn :: [*] -> * -> *). Pred fn -> DependGraph fn
computeDependencies [Pred fn]
preds)
  [SolverStage fn]
plan <-
    forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a -> m a
explain
      ( forall a. [a] -> NonEmpty a
NE.fromList
          [ [Char]
"Linearizing"
          , forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ Doc Any
"  preds: " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty [Pred fn]
preds
          , forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ Doc Any
"  graph: " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Hints fn
graph
          ]
      )
      forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (fn :: [*] -> * -> *).
(MonadGenError m, BaseUniverse fn) =>
[Pred fn] -> DependGraph fn -> m [SolverStage fn]
linearize [Pred fn]
preds Hints fn
graph
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *). SolverPlan fn -> SolverPlan fn
backPropagation forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *).
[SolverStage fn] -> Graph (Name fn) -> SolverPlan fn
SolverPlan [SolverStage fn]
plan Hints fn
graph

-- TODO: generalize this to make it more flexible and extensible
--
-- The idea here is that we turn constraints into _extra_ constraints. C.f. the
-- `mapIsJust` example in `Constrained.Examples.Map`:

--    mapIsJust :: Specification BaseFn (Int, Int)
--    mapIsJust = constrained' $ \ [var| x |] [var| y |] ->
--      assert $ cJust_ x ==. lookup_ y (lit $ Map.fromList [(z, z) | z <- [100 .. 102]])

-- Without this code the example wouldn't work because `y` is completely unconstrained during
-- generation. With this code we essentially rewrite occurences of `cJust_ A == B` to
-- `[cJust A == B, case B of Nothing -> False; Just _ -> True]` to add extra information
-- about the variables in `B`. Consequently, `y` in the example above is
-- constrained to `MemberSpec [100 .. 102]` in the plan.
saturatePred :: forall fn. Pred fn -> [Pred fn]
saturatePred :: forall {fn :: [*] -> * -> *}. Pred fn -> [Pred fn]
saturatePred Pred fn
p =
  Pred fn
p -- <--- if there is an Explain, it is still on 'p' here
    forall a. a -> [a] -> [a]
: case Pred fn
p of
      Explain NonEmpty [Char]
_es Pred fn
x -> forall {fn :: [*] -> * -> *}. Pred fn -> [Pred fn]
saturatePred Pred fn
x -- Note that the Explain is still on the original 'p', so it is not lost
      Assert (Eql (FromG (SLeft Term fn b
_)) Term fn a
t) ->
        [forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> TypeSpec fn a -> Pred fn
toPreds Term fn a
t (forall (fn :: [*] -> * -> *) a b.
Maybe (Int, Int)
-> Specification fn a -> Specification fn b -> SumSpec fn a b
SumSpec forall a. Maybe a
Nothing forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec (forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"saturatePred")))]
      Assert (Eql (FromG (SRight Term fn c
_)) Term fn a
t) ->
        [forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> TypeSpec fn a -> Pred fn
toPreds Term fn a
t (forall (fn :: [*] -> * -> *) a b.
Maybe (Int, Int)
-> Specification fn a -> Specification fn b -> SumSpec fn a b
SumSpec forall a. Maybe a
Nothing (forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"saturatePred")) forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec)]
      -- TODO: e.g. `elem (pair x y) (lit zs) -> elem x (lit $ map fst zs)` etc.
      Pred fn
_ -> []

-- | Does nothing if the variable is not in the plan already.
mergeSolverStage :: SolverStage fn -> [SolverStage fn] -> [SolverStage fn]
mergeSolverStage :: forall (fn :: [*] -> * -> *).
SolverStage fn -> [SolverStage fn] -> [SolverStage fn]
mergeSolverStage (SolverStage Var a
x [Pred fn]
ps Specification fn a
spec) [SolverStage fn]
plan =
  [ case forall a a'.
(Typeable a, Typeable a') =>
Var a -> Var a' -> Maybe (a :~: a')
eqVar Var a
x Var a
y of
      Just a :~: a
Refl ->
        forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> [Pred fn] -> Specification fn a -> SolverStage fn
SolverStage
          Var a
y
          ([Pred fn]
ps forall a. [a] -> [a] -> [a]
++ [Pred fn]
ps')
          ( forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a -> Specification fn a
addToErrorSpec
              ( forall a. [a] -> NonEmpty a
NE.fromList
                  ( [ [Char]
"Solving var " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Var a
x forall a. [a] -> [a] -> [a]
++ [Char]
" fails."
                    , [Char]
"Merging the Specs"
                    , [Char]
"   1. " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn a
spec
                    , [Char]
"   2. " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn a
spec'
                    ]
                  )
              )
              (Specification fn a
spec forall a. Semigroup a => a -> a -> a
<> Specification fn a
spec')
          )
      Maybe (a :~: a)
Nothing -> SolverStage fn
stage
  | stage :: SolverStage fn
stage@(SolverStage Var a
y [Pred fn]
ps' Specification fn a
spec') <- [SolverStage fn]
plan
  ]

-- | Push as much information we can backwards through the plan.
backPropagation :: forall fn. SolverPlan fn -> SolverPlan fn
backPropagation :: forall (fn :: [*] -> * -> *). SolverPlan fn -> SolverPlan fn
backPropagation (SolverPlan [SolverStage fn]
plan Graph (Name fn)
graph) = forall (fn :: [*] -> * -> *).
[SolverStage fn] -> Graph (Name fn) -> SolverPlan fn
SolverPlan ([SolverStage fn] -> [SolverStage fn] -> [SolverStage fn]
go [] (forall a. [a] -> [a]
reverse [SolverStage fn]
plan)) Graph (Name fn)
graph
  where
    go :: [SolverStage fn] -> [SolverStage fn] -> [SolverStage fn]
go [SolverStage fn]
acc [] = [SolverStage fn]
acc
    go [SolverStage fn]
acc (s :: SolverStage fn
s@(SolverStage (Var a
x :: Var a) [Pred fn]
ps Specification fn a
spec) : [SolverStage fn]
plan) = [SolverStage fn] -> [SolverStage fn] -> [SolverStage fn]
go (SolverStage fn
s forall a. a -> [a] -> [a]
: [SolverStage fn]
acc) [SolverStage fn]
plan'
      where
        newStages :: [SolverStage fn]
newStages = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Specification fn a -> Pred fn -> [SolverStage fn]
newStage Specification fn a
spec) [Pred fn]
ps
        plan' :: [SolverStage fn]
plan' = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall (fn :: [*] -> * -> *).
SolverStage fn -> [SolverStage fn] -> [SolverStage fn]
mergeSolverStage [SolverStage fn]
plan [SolverStage fn]
newStages

        newStage :: Specification fn a -> Pred fn -> [SolverStage fn]
newStage Specification fn a
spec (Assert (Eql (V Var a
x') Term fn a
t)) =
          forall b.
HasSpec fn b =>
Specification fn a -> Var b -> Term fn b -> [SolverStage fn]
termVarEqCases Specification fn a
spec Var a
x' Term fn a
t
        newStage Specification fn a
spec (Assert (Eql Term fn a
t (V Var a
x'))) =
          forall b.
HasSpec fn b =>
Specification fn a -> Var b -> Term fn b -> [SolverStage fn]
termVarEqCases Specification fn a
spec Var a
x' Term fn a
t
        newStage Specification fn a
_ Pred fn
_ = []

        termVarEqCases :: HasSpec fn b => Specification fn a -> Var b -> Term fn b -> [SolverStage fn]
        termVarEqCases :: forall b.
HasSpec fn b =>
Specification fn a -> Var b -> Term fn b -> [SolverStage fn]
termVarEqCases (MemberSpec NonEmpty a
vs) Var b
x' Term fn b
t
          | forall a. a -> Set a
Set.singleton (forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Name fn
Name Var a
x) forall a. Eq a => a -> a -> Bool
== forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet Term fn b
t =
              [forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> [Pred fn] -> Specification fn a -> SolverStage fn
SolverStage Var b
x' [] forall a b. (a -> b) -> a -> b
$ forall a (fn :: [*] -> * -> *). NonEmpty a -> Specification fn a
MemberSpec (forall a. Eq a => NonEmpty a -> NonEmpty a
NE.nub (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
v -> forall a. GE a -> a
errorGE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (fn :: [*] -> * -> *) a.
MonadGenError m =>
Env -> Term fn a -> m a
runTerm (forall a. (Typeable a, Show a) => Var a -> a -> Env
singletonEnv Var a
x a
v) Term fn b
t) NonEmpty a
vs))]
        termVarEqCases Specification fn a
spec Var b
x' Term fn b
t
          | Just a :~: b
Refl <- forall a a'.
(Typeable a, Typeable a') =>
Var a -> Var a' -> Maybe (a :~: a')
eqVar Var a
x Var b
x'
          , [Name Var a
y] <- forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet Term fn b
t
          , Result [NonEmpty [Char]]
_ Ctx fn a b
ctx <- forall (m :: * -> *) (fn :: [*] -> * -> *) v a.
(BaseUniverse fn, Typeable v, MonadGenError m, HasCallStack,
 HasSpec fn a, HasSpec fn v) =>
Var v -> Term fn a -> m (Ctx fn v a)
toCtx Var a
y Term fn b
t =
              [forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> [Pred fn] -> Specification fn a -> SolverStage fn
SolverStage Var a
y [] (forall (fn :: [*] -> * -> *) v a.
HasSpec fn v =>
Specification fn a -> Ctx fn v a -> Specification fn v
propagateSpec Specification fn a
spec Ctx fn a b
ctx)]
        termVarEqCases Specification fn a
_ Var b
_ Term fn b
_ = []

pattern Eql :: forall fn. () => forall a. HasSpec fn a => Term fn a -> Term fn a -> Term fn Bool
pattern $mEql :: forall {r} {fn :: [*] -> * -> *}.
Term fn Bool
-> (forall {a}. HasSpec fn a => Term fn a -> Term fn a -> r)
-> ((# #) -> r)
-> r
Eql a b <- App (extractFn @(EqFn fn) -> Just Equal) (a :> b :> Nil)

pattern FromG ::
  forall fn a.
  () =>
  (HasSpec fn a, HasSimpleRep a, TypeSpec fn a ~ TypeSpec fn (SimpleRep a)) =>
  Term fn (SimpleRep a) ->
  Term fn a
pattern $mFromG :: forall {r} {fn :: [*] -> * -> *} {a}.
Term fn a
-> ((HasSpec fn a, HasSimpleRep a,
     TypeSpec fn a ~ TypeSpec fn (SimpleRep a)) =>
    Term fn (SimpleRep a) -> r)
-> ((# #) -> r)
-> r
FromG a <- App (extractFn @(GenericsFn fn) -> Just FromGeneric) (a :> Nil)

pattern SLeft ::
  forall fn a. () => forall b c. (HasSpec fn b, a ~ Sum b c) => Term fn b -> Term fn a
pattern $mSLeft :: forall {r} {fn :: [*] -> * -> *} {a}.
Term fn a
-> (forall {b} {c}. (HasSpec fn b, a ~ Sum b c) => Term fn b -> r)
-> ((# #) -> r)
-> r
SLeft a <- App (extractFn @(SumFn fn) -> Just InjLeft) (a :> Nil)

pattern SRight ::
  forall fn a. () => forall b c. (HasSpec fn c, a ~ Sum b c) => Term fn c -> Term fn a
pattern $mSRight :: forall {r} {fn :: [*] -> * -> *} {a}.
Term fn a
-> (forall {b} {c}. (HasSpec fn c, a ~ Sum b c) => Term fn c -> r)
-> ((# #) -> r)
-> r
SRight a <- App (extractFn @(SumFn fn) -> Just InjRight) (a :> Nil)

-- ====================================================
-- Term patterns on function symbols on Sets, Lists
-- they are used in this
-- instance HasSpec fn a => Pretty (WithPrec (Term fn a)) where ...
-- Which uses: short :: forall a x. (Show a, Typeable a) => [a] -> Doc x
-- To elide large arguments to terms such as (subset_ x (lit y))
-- If 'y' is large, it will be elided.

pattern SubsetPat ::
  forall fn a.
  () =>
  forall b.
  (Ord b, HasSpec fn (Set b), Show b, Typeable b, a ~ Bool) =>
  Term fn (Set b) -> Term fn (Set b) -> Term fn a
pattern $mSubsetPat :: forall {r} {fn :: [*] -> * -> *} {a}.
Term fn a
-> (forall {b}.
    (Ord b, HasSpec fn (Set b), Show b, Typeable b, a ~ Bool) =>
    Term fn (Set b) -> Term fn (Set b) -> r)
-> ((# #) -> r)
-> r
SubsetPat a b <- App (extractFn @(SetFn fn) -> Just Subset) (a :> b :> Nil)

pattern DisjointPat ::
  forall fn a.
  () =>
  forall b.
  (Ord b, HasSpec fn (Set b), Show b, Typeable b, a ~ Bool) =>
  Term fn (Set b) -> Term fn (Set b) -> Term fn a
pattern $mDisjointPat :: forall {r} {fn :: [*] -> * -> *} {a}.
Term fn a
-> (forall {b}.
    (Ord b, HasSpec fn (Set b), Show b, Typeable b, a ~ Bool) =>
    Term fn (Set b) -> Term fn (Set b) -> r)
-> ((# #) -> r)
-> r
DisjointPat a b <- App (extractFn @(SetFn fn) -> Just Disjoint) (a :> b :> Nil)

pattern UnionPat ::
  forall fn a.
  () =>
  forall b.
  (Ord b, HasSpec fn (Set b), Show b, Typeable b, a ~ Set b) =>
  Term fn (Set b) -> Term fn (Set b) -> Term fn a
pattern $mUnionPat :: forall {r} {fn :: [*] -> * -> *} {a}.
Term fn a
-> (forall {b}.
    (Ord b, HasSpec fn (Set b), Show b, Typeable b, a ~ Set b) =>
    Term fn (Set b) -> Term fn (Set b) -> r)
-> ((# #) -> r)
-> r
UnionPat a b <- App (extractFn @(SetFn fn) -> Just Union) (a :> b :> Nil)

pattern MemberPat ::
  forall fn a.
  () =>
  forall b.
  (HasSpec fn b, HasSpec fn (Set b), Show b, Typeable b, a ~ Bool) =>
  Term fn b -> Term fn (Set b) -> Term fn a
pattern $mMemberPat :: forall {r} {fn :: [*] -> * -> *} {a}.
Term fn a
-> (forall {b}.
    (HasSpec fn b, HasSpec fn (Set b), Show b, Typeable b, a ~ Bool) =>
    Term fn b -> Term fn (Set b) -> r)
-> ((# #) -> r)
-> r
MemberPat a b <- App (extractFn @(SetFn fn) -> Just Member) (a :> b :> Nil)

pattern ElemPat ::
  forall fn a.
  () =>
  forall b.
  (HasSpec fn b, HasSpec fn [b], Show b, Typeable b, a ~ Bool) =>
  Term fn b -> Term fn [b] -> Term fn a
pattern $mElemPat :: forall {r} {fn :: [*] -> * -> *} {a}.
Term fn a
-> (forall {b}.
    (HasSpec fn b, HasSpec fn [b], Show b, Typeable b, a ~ Bool) =>
    Term fn b -> Term fn [b] -> r)
-> ((# #) -> r)
-> r
ElemPat a b <- App (extractFn @(SetFn fn) -> Just Elem) (a :> b :> Nil)

pattern AppendPat ::
  forall fn a.
  () =>
  forall b.
  (HasSpec fn [b], Show b, Typeable b, a ~ [b]) => Term fn [b] -> Term fn [b] -> Term fn a
pattern $mAppendPat :: forall {r} {fn :: [*] -> * -> *} {a}.
Term fn a
-> (forall {b}.
    (HasSpec fn [b], Show b, Typeable b, a ~ [b]) =>
    Term fn [b] -> Term fn [b] -> r)
-> ((# #) -> r)
-> r
AppendPat a b <- App (extractFn @(ListFn fn) -> Just AppendFn) (a :> b :> Nil)

short :: forall a x. (Show a, Typeable a) => [a] -> Doc x
short :: forall a x. (Show a, Typeable a) => [a] -> Doc x
short [] = Doc x
"[]"
short [a
x] =
  let raw :: [Char]
raw = forall a. Show a => a -> [Char]
show a
x
      refined :: [Char]
refined = if forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
raw forall a. Ord a => a -> a -> Bool
<= Int
20 then [Char]
raw else forall a. Int -> [a] -> [a]
take Int
20 [Char]
raw forall a. [a] -> [a] -> [a]
++ [Char]
" ... "
   in Doc x
"[" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a. IsString a => [Char] -> a
fromString [Char]
refined forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc x
"]"
short [a]
xs = Doc x
"([" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs) forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc x
"elements ...] @" forall a. Semigroup a => a -> a -> a
<> forall a ann. Show a => a -> Doc ann
viaShow (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy @a)) forall a. Semigroup a => a -> a -> a
<> Doc x
")"

prettyPlan :: HasSpec fn a => Specification fn a -> Doc ann
prettyPlan :: forall (fn :: [*] -> * -> *) a ann.
HasSpec fn a =>
Specification fn a -> Doc ann
prettyPlan (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn a -> Specification fn a
simplifySpec -> Specification fn a
spec)
  | SuspendedSpec Var a
_ Pred fn
p <- Specification fn a
spec
  , Result [NonEmpty [Char]]
_ SolverPlan fn
plan <- forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Pred fn -> GE (SolverPlan fn)
prepareLinearization Pred fn
p =
      forall ann. [Doc ann] -> Doc ann
vsep'
        [ Doc ann
"Simplified spec:" forall ann. Doc ann -> Doc ann -> Doc ann
/> forall a ann. Pretty a => a -> Doc ann
pretty Specification fn a
spec
        , forall a ann. Pretty a => a -> Doc ann
pretty SolverPlan fn
plan
        ]
  | Bool
otherwise = Doc ann
"Simplfied spec:" forall ann. Doc ann -> Doc ann -> Doc ann
/> forall a ann. Pretty a => a -> Doc ann
pretty Specification fn a
spec

printPlan :: HasSpec fn a => Specification fn a -> IO ()
printPlan :: forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn a -> IO ()
printPlan = forall a. Show a => a -> IO ()
print forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fn :: [*] -> * -> *) a ann.
HasSpec fn a =>
Specification fn a -> Doc ann
prettyPlan

isEmptyPlan :: SolverPlan fn -> Bool
isEmptyPlan :: forall (fn :: [*] -> * -> *). SolverPlan fn -> Bool
isEmptyPlan (SolverPlan [SolverStage fn]
plan Graph (Name fn)
_) = forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SolverStage fn]
plan

stepPlan :: MonadGenError m => Env -> SolverPlan fn -> GenT m (Env, SolverPlan fn)
stepPlan :: forall (m :: * -> *) (fn :: [*] -> * -> *).
MonadGenError m =>
Env -> SolverPlan fn -> GenT m (Env, SolverPlan fn)
stepPlan Env
env plan :: SolverPlan fn
plan@(SolverPlan [] Graph (Name fn)
_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Env
env, SolverPlan fn
plan)
stepPlan Env
env (SolverPlan (SolverStage Var a
x [Pred fn]
ps Specification fn a
spec : [SolverStage fn]
pl) Graph (Name fn)
gr) = do
  (Specification fn a
spec', [Specification fn a]
specs) <- forall (m :: * -> *) r. MonadGenError m => GE r -> m r
runGE
    forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadGenError m => [Char] -> m a -> m a
explain1
      ( forall a. Show a => a -> [Char]
show
          ( Doc Any
"Computing specs for variable "
              forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Var a
x forall ann. Doc ann -> Doc ann -> Doc ann
/> forall ann. [Doc ann] -> Doc ann
vsep' (forall a b. (a -> b) -> [a] -> [b]
map forall a ann. Pretty a => a -> Doc ann
pretty [Pred fn]
ps)
          )
      )
    forall a b. (a -> b) -> a -> b
$ do
      [Specification fn a]
ispecs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, HasCallStack) =>
Var a -> Pred fn -> GE (Specification fn a)
computeSpec Var a
x) [Pred fn]
ps
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [Specification fn a]
ispecs, [Specification fn a]
ispecs)
  a
val <-
    forall (fn :: [*] -> * -> *) a (m :: * -> *).
(HasCallStack, HasSpec fn a, MonadGenError m) =>
Specification fn a -> GenT m a
genFromSpecT
      ( forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a -> Specification fn a
addToErrorSpec
          ( forall a. [a] -> NonEmpty a
NE.fromList
              ( ( [Char]
"\nStepPlan for variable: "
                    forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Var a
x
                    forall a. [a] -> [a] -> [a]
++ [Char]
" fails to produce Specification, probably overconstrained."
                )
                  forall a. a -> [a] -> [a]
: ([Char]
"Original spec " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn a
spec)
                  forall a. a -> [a] -> [a]
: [Char]
"Predicates"
                  forall a. a -> [a] -> [a]
: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
                    (\Pred fn
pred Specification fn a
spec -> [Char]
"  pred " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Pred fn
pred forall a. [a] -> [a] -> [a]
++ [Char]
" -> " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn a
spec)
                    [Pred fn]
ps
                    [Specification fn a]
specs
              )
          )
          (Specification fn a
spec forall a. Semigroup a => a -> a -> a
<> Specification fn a
spec')
      )
  let env1 :: Env
env1 = forall a. (Typeable a, Show a) => Var a -> a -> Env -> Env
extendEnv Var a
x a
val Env
env
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Env
env1, forall (fn :: [*] -> * -> *). SolverPlan fn -> SolverPlan fn
backPropagation forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *).
[SolverStage fn] -> Graph (Name fn) -> SolverPlan fn
SolverPlan (forall (fn :: [*] -> * -> *).
Env -> SolverStage fn -> SolverStage fn
substStage Env
env1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SolverStage fn]
pl) (forall node. Ord node => node -> Graph node -> Graph node
deleteNode (forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Name fn
Name Var a
x) Graph (Name fn)
gr))

substStage :: Env -> SolverStage fn -> SolverStage fn
substStage :: forall (fn :: [*] -> * -> *).
Env -> SolverStage fn -> SolverStage fn
substStage Env
env (SolverStage Var a
y [Pred fn]
ps Specification fn a
spec) = forall (fn :: [*] -> * -> *). SolverStage fn -> SolverStage fn
normalizeSolverStage forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> [Pred fn] -> Specification fn a -> SolverStage fn
SolverStage Var a
y (forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Env -> Pred fn -> Pred fn
substPred Env
env forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pred fn]
ps) Specification fn a
spec

-- | Generate a satisfying `Env` for a `p : Pred fn`. The `Env` contains values for
-- all the free variables in `flattenPred p`.
genFromPreds :: forall fn m. (MonadGenError m, BaseUniverse fn) => Env -> Pred fn -> GenT m Env
-- TODO: remove this once optimisePred does a proper fixpoint computation
genFromPreds :: forall (fn :: [*] -> * -> *) (m :: * -> *).
(MonadGenError m, BaseUniverse fn) =>
Env -> Pred fn -> GenT m Env
genFromPreds Env
env0 (forall (fn :: [*] -> * -> *). BaseUniverse fn => Pred fn -> Pred fn
optimisePred forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fn :: [*] -> * -> *). BaseUniverse fn => Pred fn -> Pred fn
optimisePred -> Pred fn
preds) =
  {- explain1 (show $ "genFromPreds fails\nPreds are:" /> pretty preds) -} do
    -- NOTE: this is just lazy enough that the work of flattening,
    -- computing dependencies, and linearizing is memoized in
    -- properties that use `genFromPreds`.
    SolverPlan fn
plan <- forall (m :: * -> *) r. MonadGenError m => GE r -> m r
runGE forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Pred fn -> GE (SolverPlan fn)
prepareLinearization @fn Pred fn
preds
    MonadGenError m => Env -> SolverPlan fn -> GenT m Env
go Env
env0 SolverPlan fn
plan
  where
    go :: MonadGenError m => Env -> SolverPlan fn -> GenT m Env
    go :: MonadGenError m => Env -> SolverPlan fn -> GenT m Env
go Env
env SolverPlan fn
plan | forall (fn :: [*] -> * -> *). SolverPlan fn -> Bool
isEmptyPlan SolverPlan fn
plan = forall (f :: * -> *) a. Applicative f => a -> f a
pure Env
env
    go Env
env SolverPlan fn
plan = do
      (Env
env', SolverPlan fn
plan') <-
        forall (m :: * -> *) a. MonadGenError m => [Char] -> m a -> m a
explain1 (forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ Doc Any
"Stepping the plan:" forall ann. Doc ann -> Doc ann -> Doc ann
/> forall ann. [Doc ann] -> Doc ann
vsep [forall a ann. Pretty a => a -> Doc ann
pretty SolverPlan fn
plan, forall a ann. Pretty a => a -> Doc ann
pretty Env
env]) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (fn :: [*] -> * -> *).
MonadGenError m =>
Env -> SolverPlan fn -> GenT m (Env, SolverPlan fn)
stepPlan Env
env SolverPlan fn
plan
      MonadGenError m => Env -> SolverPlan fn -> GenT m Env
go Env
env' SolverPlan fn
plan'

-- TODO: here we can compute both the explicit hints (i.e. constraints that
-- define the order of two variables) and any whole-program smarts.
computeHints :: forall fn. [Pred fn] -> Hints fn
computeHints :: forall (fn :: [*] -> * -> *). [Pred fn] -> Hints fn
computeHints [Pred fn]
ps =
  forall node. Ord node => Graph node -> Graph node
transitiveClosure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [Term fn a
x forall (fn :: [*] -> * -> *) t t'.
(HasVariables fn t, HasVariables fn t') =>
t -> t' -> DependGraph fn
`irreflexiveDependencyOn` Term fn b
y | DependsOn Term fn a
x Term fn b
y <- [Pred fn]
ps]

computeBinderDependencies :: Binder fn a -> DependGraph fn
computeBinderDependencies :: forall (fn :: [*] -> * -> *) a. Binder fn a -> DependGraph fn
computeBinderDependencies (Var a
x :-> Pred fn
p) =
  forall node. Ord node => node -> Graph node -> Graph node
deleteNode (forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Name fn
Name Var a
x) forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *). Pred fn -> DependGraph fn
computeDependencies Pred fn
p

computeTermDependencies :: Term fn a -> DependGraph fn
computeTermDependencies :: forall (fn :: [*] -> * -> *) a. Term fn a -> DependGraph fn
computeTermDependencies = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fn :: [*] -> * -> *) a.
Term fn a -> (DependGraph fn, Set (Name fn))
computeTermDependencies'

computeTermDependencies' :: Term fn a -> (DependGraph fn, Set (Name fn))
computeTermDependencies' :: forall (fn :: [*] -> * -> *) a.
Term fn a -> (DependGraph fn, Set (Name fn))
computeTermDependencies' (App fn as a
_ List (Term fn) as
args) = forall (fn :: [*] -> * -> *) (as :: [*]).
List (Term fn) as -> (DependGraph fn, Set (Name fn))
go List (Term fn) as
args
  where
    go :: List (Term fn) as -> (DependGraph fn, Set (Name fn))
    go :: forall (fn :: [*] -> * -> *) (as :: [*]).
List (Term fn) as -> (DependGraph fn, Set (Name fn))
go List (Term fn) as
Nil = (forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty)
    go (Term fn a
t :> List (Term fn) as1
ts) =
      let (DependGraph fn
gr, Set (Name fn)
ngr) = forall (fn :: [*] -> * -> *) (as :: [*]).
List (Term fn) as -> (DependGraph fn, Set (Name fn))
go List (Term fn) as1
ts
          (DependGraph fn
tgr, Set (Name fn)
ntgr) = forall (fn :: [*] -> * -> *) a.
Term fn a -> (DependGraph fn, Set (Name fn))
computeTermDependencies' Term fn a
t
       in (Set (Name fn)
ntgr forall (fn :: [*] -> * -> *) t t'.
(HasVariables fn t, HasVariables fn t') =>
t -> t' -> DependGraph fn
`irreflexiveDependencyOn` Set (Name fn)
ngr forall a. Semigroup a => a -> a -> a
<> DependGraph fn
tgr forall a. Semigroup a => a -> a -> a
<> DependGraph fn
gr, Set (Name fn)
ngr forall a. Semigroup a => a -> a -> a
<> Set (Name fn)
ntgr)
computeTermDependencies' Lit {} = (forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty)
computeTermDependencies' (V Var a
x) = (forall (fn :: [*] -> * -> *) t.
HasVariables fn t =>
t -> DependGraph fn
noDependencies (forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Name fn
Name Var a
x), forall a. a -> Set a
Set.singleton (forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Name fn
Name Var a
x))

-- Consider: A + B = C + D
-- We want to fail if A and B are independent.
-- Consider: A + B = A + C, A <- B
-- Here we want to consider this constraint defining for A
linearize ::
  (MonadGenError m, BaseUniverse fn) => [Pred fn] -> DependGraph fn -> m [SolverStage fn]
linearize :: forall (m :: * -> *) (fn :: [*] -> * -> *).
(MonadGenError m, BaseUniverse fn) =>
[Pred fn] -> DependGraph fn -> m [SolverStage fn]
linearize [Pred fn]
preds DependGraph fn
graph = do
  [Name fn]
sorted <- case forall node. Ord node => Graph node -> Either [node] [node]
topsort DependGraph fn
graph of
    Left [Name fn]
cycle ->
      forall (m :: * -> *) a. MonadGenError m => [Char] -> m a
fatalError1
        ( forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$
            Doc Any
"linearize: Dependency cycle in graph:"
              forall ann. Doc ann -> Doc ann -> Doc ann
/> forall ann. [Doc ann] -> Doc ann
vsep'
                [ Doc Any
"cycle:" forall ann. Doc ann -> Doc ann -> Doc ann
/> forall a ann. Pretty a => a -> Doc ann
pretty [Name fn]
cycle
                , Doc Any
"graph:" forall ann. Doc ann -> Doc ann -> Doc ann
/> forall a ann. Pretty a => a -> Doc ann
pretty DependGraph fn
graph
                ]
        )
    Right [Name fn]
sorted -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Name fn]
sorted
  [Name fn] -> [(Set (Name fn), Pred fn)] -> m [SolverStage fn]
go [Name fn]
sorted [(forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet Pred fn
ps, Pred fn
ps) | Pred fn
ps <- forall a. (a -> Bool) -> [a] -> [a]
filter forall {fn :: [*] -> * -> *}. Pred fn -> Bool
isRelevantPred [Pred fn]
preds]
  where
    isRelevantPred :: Pred fn -> Bool
isRelevantPred Pred fn
TruePred = Bool
False
    isRelevantPred DependsOn {} = Bool
False
    isRelevantPred (Assert (Lit Bool
True)) = Bool
False
    isRelevantPred Pred fn
_ = Bool
True

    go :: [Name fn] -> [(Set (Name fn), Pred fn)] -> m [SolverStage fn]
go [] [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    go [] [(Set (Name fn), Pred fn)]
ps
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a b. (a, b) -> a
fst [(Set (Name fn), Pred fn)]
ps =
          case forall (fn :: [*] -> * -> *).
FunctionLike fn =>
NonEmpty [Char] -> Env -> [Pred fn] -> Maybe (NonEmpty [Char])
checkPredsE (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"Linearizing fails") forall a. Monoid a => a
mempty (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Set (Name fn), Pred fn)]
ps) of
            Maybe (NonEmpty [Char])
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
            Just NonEmpty [Char]
msgs -> forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
genError NonEmpty [Char]
msgs
      | Bool
otherwise =
          forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
fatalError forall a b. (a -> b) -> a -> b
$
            forall a. [a] -> NonEmpty a
NE.fromList
              [ [Char]
"Dependency error in `linearize`: "
              , forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall ann. Int -> Doc ann -> Doc ann
indent Int
2 forall a b. (a -> b) -> a -> b
$ Doc Any
"graph: " forall ann. Doc ann -> Doc ann -> Doc ann
/> forall a ann. Pretty a => a -> Doc ann
pretty DependGraph fn
graph
              , forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$
                  forall ann. Int -> Doc ann -> Doc ann
indent Int
2 forall a b. (a -> b) -> a -> b
$
                    Doc Any
"the following left-over constraints are not defining constraints for a unique variable:"
                      forall ann. Doc ann -> Doc ann -> Doc ann
/> forall ann. [Doc ann] -> Doc ann
vsep' (forall a b. (a -> b) -> [a] -> [b]
map (forall a ann. Pretty a => a -> Doc ann
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Set (Name fn), Pred fn)]
ps)
              ]
    go (n :: Name fn
n@(Name Var a
x) : [Name fn]
ns) [(Set (Name fn), Pred fn)]
ps = do
      let ([(Set (Name fn), Pred fn)]
nps, [(Set (Name fn), Pred fn)]
ops) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Name fn -> Set (Name fn) -> Bool
isLastVariable Name fn
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Set (Name fn), Pred fn)]
ps
      (forall (fn :: [*] -> * -> *). SolverStage fn -> SolverStage fn
normalizeSolverStage (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> [Pred fn] -> Specification fn a -> SolverStage fn
SolverStage Var a
x (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Set (Name fn), Pred fn)]
nps) forall a. Monoid a => a
mempty) forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name fn] -> [(Set (Name fn), Pred fn)] -> m [SolverStage fn]
go [Name fn]
ns [(Set (Name fn), Pred fn)]
ops

    isLastVariable :: Name fn -> Set (Name fn) -> Bool
isLastVariable Name fn
n Set (Name fn)
set = Name fn
n forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (Name fn)
set Bool -> Bool -> Bool
&& forall (f :: [*] -> * -> *).
Name f -> Set (Name f) -> DependGraph f -> Bool
solvableFrom Name fn
n (forall a. Ord a => a -> Set a -> Set a
Set.delete Name fn
n Set (Name fn)
set) DependGraph fn
graph

normalizeSolverStage :: SolverStage fn -> SolverStage fn
normalizeSolverStage :: forall (fn :: [*] -> * -> *). SolverStage fn -> SolverStage fn
normalizeSolverStage (SolverStage Var a
x [Pred fn]
ps Specification fn a
spec) = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> [Pred fn] -> Specification fn a -> SolverStage fn
SolverStage Var a
x [Pred fn]
ps'' (Specification fn a
spec forall a. Semigroup a => a -> a -> a
<> Specification fn a
spec')
  where
    ([Pred fn]
ps', [Pred fn]
ps'') = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((Int
1 forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Int
Set.size forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet) [Pred fn]
ps
    spec' :: Specification fn a
spec' = forall (fn :: [*] -> * -> *) a.
(HasCallStack, HasSpec fn a) =>
GE (Specification fn a) -> Specification fn a
fromGESpec forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, HasCallStack) =>
Var a -> Pred fn -> GE (Specification fn a)
computeSpec Var a
x (forall (fn :: [*] -> * -> *). [Pred fn] -> Pred fn
Block [Pred fn]
ps')

------------------------------------------------------------------------
-- Computing specs
------------------------------------------------------------------------

fromGESpec :: (HasCallStack, HasSpec fn a) => GE (Specification fn a) -> Specification fn a
fromGESpec :: forall (fn :: [*] -> * -> *) a.
(HasCallStack, HasSpec fn a) =>
GE (Specification fn a) -> Specification fn a
fromGESpec GE (Specification fn a)
ge = case GE (Specification fn a)
ge of
  Result [] Specification fn a
s -> Specification fn a
s
  Result [NonEmpty [Char]]
es Specification fn a
s -> forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a -> Specification fn a
addToErrorSpec (forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall a. Semigroup a => a -> a -> a
(<>) [NonEmpty [Char]]
es) Specification fn a
s
  GE (Specification fn a)
_ -> forall a. (NonEmpty [Char] -> a) -> GE a -> a
fromGE forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec GE (Specification fn a)
ge

-- | Add the explanations, if it's an ErrorSpec, else drop them
addToErrorSpec :: NE.NonEmpty String -> Specification fn a -> Specification fn a
addToErrorSpec :: forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a -> Specification fn a
addToErrorSpec NonEmpty [Char]
es (ExplainSpec [] Specification fn a
x) = forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a -> Specification fn a
addToErrorSpec NonEmpty [Char]
es Specification fn a
x
addToErrorSpec NonEmpty [Char]
es (ExplainSpec [[Char]]
es2 Specification fn a
x) = forall (fn :: [*] -> * -> *) a.
[[Char]] -> Specification fn a -> Specification fn a
ExplainSpec [[Char]]
es2 (forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a -> Specification fn a
addToErrorSpec NonEmpty [Char]
es Specification fn a
x)
addToErrorSpec NonEmpty [Char]
es (ErrorSpec NonEmpty [Char]
es') = forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec (NonEmpty [Char]
es forall a. Semigroup a => a -> a -> a
<> NonEmpty [Char]
es')
addToErrorSpec NonEmpty [Char]
_ Specification fn a
s = Specification fn a
s

regularize :: HasVariables fn t => Var a -> t -> Var a
regularize :: forall (fn :: [*] -> * -> *) t a.
HasVariables fn t =>
Var a -> t -> Var a
regularize Var a
v t
t =
  case [forall a. Var a -> [Char]
nameHint Var a
v' | Name Var a
v' <- forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet t
t, forall a. Var a -> Int
nameOf Var a
v' forall a. Eq a => a -> a -> Bool
== forall a. Var a -> Int
nameOf Var a
v, forall a. Var a -> [Char]
nameHint Var a
v' forall a. Eq a => a -> a -> Bool
/= [Char]
"v"] of
    [] -> Var a
v
    [Char]
nh : [[Char]]
_ -> Var a
v {nameHint :: [Char]
nameHint = [Char]
nh}

regularizeBinder :: Binder fn a -> Binder fn a
regularizeBinder :: forall (fn :: [*] -> * -> *) a. Binder fn a -> Binder fn a
regularizeBinder (Var a
x :-> Pred fn
p) = Var a
x' forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Binder fn a
:-> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> Pred fn -> Pred fn
substitutePred Var a
x (forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Term fn a
V Var a
x') (forall (fn :: [*] -> * -> *). Pred fn -> Pred fn
regularizeNamesPred Pred fn
p)
  where
    x' :: Var a
x' = forall (fn :: [*] -> * -> *) t a.
HasVariables fn t =>
Var a -> t -> Var a
regularize Var a
x Pred fn
p

regularizeNamesPred :: Pred fn -> Pred fn
regularizeNamesPred :: forall (fn :: [*] -> * -> *). Pred fn -> Pred fn
regularizeNamesPred Pred fn
p = case Pred fn
p of
  Monitor {} -> Pred fn
p
  Block [Pred fn]
ps -> forall (fn :: [*] -> * -> *). [Pred fn] -> Pred fn
Block forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (fn :: [*] -> * -> *). Pred fn -> Pred fn
regularizeNamesPred [Pred fn]
ps
  Exists (forall b. Term fn b -> b) -> GE a
k Binder fn a
b -> forall (fn :: [*] -> * -> *) a.
((forall b. Term fn b -> b) -> GE a) -> Binder fn a -> Pred fn
Exists (forall b. Term fn b -> b) -> GE a
k (forall (fn :: [*] -> * -> *) a. Binder fn a -> Binder fn a
regularizeBinder Binder fn a
b)
  Subst Var a
v Term fn a
t Pred fn
p -> forall (fn :: [*] -> * -> *). Pred fn -> Pred fn
regularizeNamesPred (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> Pred fn -> Pred fn
substitutePred Var a
v Term fn a
t Pred fn
p)
  Let Term fn a
t Binder fn a
b -> forall (fn :: [*] -> * -> *) a. Term fn a -> Binder fn a -> Pred fn
Let Term fn a
t (forall (fn :: [*] -> * -> *) a. Binder fn a -> Binder fn a
regularizeBinder Binder fn a
b)
  Assert {} -> Pred fn
p
  Reifies {} -> Pred fn
p
  DependsOn {} -> Pred fn
p
  ForAll Term fn t
t Binder fn a
b -> forall a b (fn :: [*] -> * -> *).
(Forallable a b, HasSpec fn a, HasSpec fn b) =>
Term fn a -> Binder fn b -> Pred fn
ForAll Term fn t
t (forall (fn :: [*] -> * -> *) a. Binder fn a -> Binder fn a
regularizeBinder Binder fn a
b)
  Case Term fn (SumOver as)
t List (Weighted (Binder fn)) as
bs -> forall (fn :: [*] -> * -> *) (a :: [*]).
HasSpec fn (SumOver a) =>
Term fn (SumOver a) -> List (Weighted (Binder fn)) a -> Pred fn
Case Term fn (SumOver as)
t (forall {k} (f :: k -> *) (g :: k -> *) (as :: [k]).
(forall (a :: k). f a -> g a) -> List f as -> List g as
mapList (forall (f :: * -> *) a (g :: * -> *) b.
(f a -> g b) -> Weighted f a -> Weighted g b
mapWeighted forall (fn :: [*] -> * -> *) a. Binder fn a -> Binder fn a
regularizeBinder) List (Weighted (Binder fn)) as
bs)
  When Term fn Bool
b Pred fn
p' -> forall (fn :: [*] -> * -> *).
HasSpec fn Bool =>
Term fn Bool -> Pred fn -> Pred fn
When Term fn Bool
b (forall (fn :: [*] -> * -> *). Pred fn -> Pred fn
regularizeNamesPred Pred fn
p')
  GenHint {} -> Pred fn
p
  TruePred {} -> Pred fn
p
  FalsePred {} -> Pred fn
p
  Explain NonEmpty [Char]
es Pred fn
p' -> forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn -> Pred fn
Explain NonEmpty [Char]
es (forall (fn :: [*] -> * -> *). Pred fn -> Pred fn
regularizeNamesPred Pred fn
p')

regularizeNames :: Specification fn a -> Specification fn a
regularizeNames :: forall (fn :: [*] -> * -> *) a.
Specification fn a -> Specification fn a
regularizeNames (ExplainSpec [[Char]]
es Specification fn a
x) = forall (fn :: [*] -> * -> *) a.
[[Char]] -> Specification fn a -> Specification fn a
explainSpecOpt [[Char]]
es (forall (fn :: [*] -> * -> *) a.
Specification fn a -> Specification fn a
regularizeNames Specification fn a
x)
regularizeNames (SuspendedSpec Var a
x Pred fn
p) =
  forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Specification fn a
SuspendedSpec Var a
x' Pred fn
p'
  where
    Var a
x' :-> Pred fn
p' = forall (fn :: [*] -> * -> *) a. Binder fn a -> Binder fn a
regularizeBinder (Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Binder fn a
:-> Pred fn
p)
regularizeNames Specification fn a
spec = Specification fn a
spec

simplifySpec :: HasSpec fn a => Specification fn a -> Specification fn a
simplifySpec :: forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn a -> Specification fn a
simplifySpec Specification fn a
spec = case forall (fn :: [*] -> * -> *) a.
Specification fn a -> Specification fn a
regularizeNames Specification fn a
spec of
  SuspendedSpec Var a
x Pred fn
p ->
    let optP :: Pred fn
optP = forall (fn :: [*] -> * -> *). BaseUniverse fn => Pred fn -> Pred fn
optimisePred Pred fn
p
     in forall (fn :: [*] -> * -> *) a.
(HasCallStack, HasSpec fn a) =>
GE (Specification fn a) -> Specification fn a
fromGESpec forall a b. (a -> b) -> a -> b
$
          forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a -> m a
explain
            (forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
"\nWhile calling simplifySpec on var " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Var a
x))
            (forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, HasCallStack) =>
Var a -> Pred fn -> GE (Specification fn a)
computeSpecSimplified Var a
x Pred fn
optP)
  MemberSpec NonEmpty a
xs -> forall a (fn :: [*] -> * -> *). NonEmpty a -> Specification fn a
MemberSpec NonEmpty a
xs
  ErrorSpec NonEmpty [Char]
es -> forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec NonEmpty [Char]
es
  TypeSpec TypeSpec fn a
ts OrdSet a
cant -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> OrdSet a -> Specification fn a
TypeSpec TypeSpec fn a
ts OrdSet a
cant
  Specification fn a
TrueSpec -> forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec
  ExplainSpec [[Char]]
es Specification fn a
s -> forall (fn :: [*] -> * -> *) a.
[[Char]] -> Specification fn a -> Specification fn a
explainSpecOpt [[Char]]
es (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn a -> Specification fn a
simplifySpec Specification fn a
s)

-- | Precondition: the `Pred fn` defines the `Var a`
--
-- Runs in `GE` in order for us to have detailed context on failure.
computeSpecSimplified ::
  forall fn a. (HasSpec fn a, HasCallStack) => Var a -> Pred fn -> GE (Specification fn a)
computeSpecSimplified :: forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, HasCallStack) =>
Var a -> Pred fn -> GE (Specification fn a)
computeSpecSimplified Var a
x Pred fn
p = forall {fn :: [*] -> * -> *} {a}.
HasSpec fn a =>
GE (Specification fn a) -> GE (Specification fn a)
localGESpec forall a b. (a -> b) -> a -> b
$ case Pred fn
p of
  Monitor {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
  GenHint Hint a
h Term fn a
t -> forall (fn :: [*] -> * -> *) v a.
HasSpec fn v =>
Specification fn a -> Ctx fn v a -> Specification fn v
propagateSpec (forall (fn :: [*] -> * -> *) a.
HasGenHint fn a =>
Hint a -> Specification fn a
giveHint Hint a
h) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) (fn :: [*] -> * -> *) v a.
(BaseUniverse fn, Typeable v, MonadGenError m, HasCallStack,
 HasSpec fn a, HasSpec fn v) =>
Var v -> Term fn a -> m (Ctx fn v a)
toCtx Var a
x Term fn a
t -- NOTE: this implies you do need to actually propagate hints, e.g. propagate depth control in a `tail` or `cdr` like function
  Subst Var a
x' Term fn a
t Pred fn
p' -> forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, HasCallStack) =>
Var a -> Pred fn -> GE (Specification fn a)
computeSpec Var a
x (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> Pred fn -> Pred fn
substitutePred Var a
x' Term fn a
t Pred fn
p') -- NOTE: this is impossible as it should have gone away already
  Pred fn
TruePred -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
  FalsePred NonEmpty [Char]
es -> forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
genError NonEmpty [Char]
es
  Block [Pred fn]
ps -> do
    Specification fn a
spec <- forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, HasCallStack) =>
Var a -> Pred fn -> GE (Specification fn a)
computeSpecSimplified Var a
x) [Pred fn]
ps
    case Specification fn a
spec of
      ExplainSpec [[Char]]
es (SuspendedSpec Var a
y Pred fn
ps') -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
[[Char]] -> Specification fn a -> Specification fn a
explainSpecOpt [[Char]]
es (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Specification fn a
SuspendedSpec Var a
y forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *). BaseUniverse fn => Pred fn -> Pred fn
simplifyPred Pred fn
ps')
      SuspendedSpec Var a
y Pred fn
ps' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Specification fn a
SuspendedSpec Var a
y forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *). BaseUniverse fn => Pred fn -> Pred fn
simplifyPred Pred fn
ps'
      Specification fn a
s -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Specification fn a
s
  Let Term fn a
t Binder fn a
b -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Specification fn a
SuspendedSpec Var a
x (forall (fn :: [*] -> * -> *) a. Term fn a -> Binder fn a -> Pred fn
Let Term fn a
t Binder fn a
b)
  Exists (forall b. Term fn b -> b) -> GE a
k Binder fn a
b -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Specification fn a
SuspendedSpec Var a
x (forall (fn :: [*] -> * -> *) a.
((forall b. Term fn b -> b) -> GE a) -> Binder fn a -> Pred fn
Exists (forall b. Term fn b -> b) -> GE a
k Binder fn a
b)
  Assert (Lit Bool
True) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
  Assert (Lit Bool
False) -> forall (m :: * -> *) a. MonadGenError m => [Char] -> m a
genError1 (forall a. Show a => a -> [Char]
show Pred fn
p)
  Assert (ElemPat Term fn b
_ (Lit [])) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Show a => a -> [Char]
show Pred fn
p)))
  Assert (ElemPat Term fn b
t (Lit [b]
xs)) -> forall (fn :: [*] -> * -> *) v a.
HasSpec fn v =>
Specification fn a -> Ctx fn v a -> Specification fn v
propagateSpec (forall a (fn :: [*] -> * -> *). NonEmpty a -> Specification fn a
MemberSpec (forall a. [a] -> NonEmpty a
NE.fromList [b]
xs)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) (fn :: [*] -> * -> *) v a.
(BaseUniverse fn, Typeable v, MonadGenError m, HasCallStack,
 HasSpec fn a, HasSpec fn v) =>
Var v -> Term fn a -> m (Ctx fn v a)
toCtx Var a
x Term fn b
t
  Assert Term fn Bool
t -> forall (fn :: [*] -> * -> *) v a.
HasSpec fn v =>
Specification fn a -> Ctx fn v a -> Specification fn v
propagateSpec (forall a (fn :: [*] -> * -> *). a -> Specification fn a
equalSpec Bool
True) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) (fn :: [*] -> * -> *) v a.
(BaseUniverse fn, Typeable v, MonadGenError m, HasCallStack,
 HasSpec fn a, HasSpec fn v) =>
Var v -> Term fn a -> m (Ctx fn v a)
toCtx Var a
x Term fn Bool
t
  ForAll (Lit t
s) Binder fn a
b -> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\a
val -> forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, HasCallStack) =>
Var a -> Pred fn -> GE (Specification fn a)
computeSpec Var a
x forall a b. (a -> b) -> a -> b
$ forall a (fn :: [*] -> * -> *). a -> Binder fn a -> Pred fn
unBind a
val Binder fn a
b) (forall t e. Forallable t e => t -> [e]
forAllToList t
s)
  ForAll Term fn t
t Binder fn a
b -> do
    Specification fn a
bSpec <- forall (fn :: [*] -> * -> *) a.
Binder fn a -> GE (Specification fn a)
computeSpecBinderSimplified Binder fn a
b
    forall (fn :: [*] -> * -> *) v a.
HasSpec fn v =>
Specification fn a -> Ctx fn v a -> Specification fn v
propagateSpec (forall t e (fn :: [*] -> * -> *).
(Forallable t e, HasSpec fn t, HasSpec fn e, BaseUniverse fn) =>
Specification fn e -> Specification fn t
fromForAllSpec Specification fn a
bSpec) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) (fn :: [*] -> * -> *) v a.
(BaseUniverse fn, Typeable v, MonadGenError m, HasCallStack,
 HasSpec fn a, HasSpec fn v) =>
Var v -> Term fn a -> m (Ctx fn v a)
toCtx Var a
x Term fn t
t
  Case (Lit SumOver as
val) List (Weighted (Binder fn)) as
bs -> forall (as :: [*]) (fn :: [*] -> * -> *) r.
SumOver as
-> List (Binder fn) as
-> (forall a. HasSpec fn a => Var a -> a -> Pred fn -> r)
-> r
runCaseOn SumOver as
val (forall {k} (f :: k -> *) (g :: k -> *) (as :: [k]).
(forall (a :: k). f a -> g a) -> List f as -> List g as
mapList forall (f :: * -> *) a. Weighted f a -> f a
thing List (Weighted (Binder fn)) as
bs) forall a b. (a -> b) -> a -> b
$ \Var a
va a
vaVal Pred fn
psa -> forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, HasCallStack) =>
Var a -> Pred fn -> GE (Specification fn a)
computeSpec Var a
x (forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Env -> Pred fn -> Pred fn
substPred (forall a. (Typeable a, Show a) => Var a -> a -> Env
singletonEnv Var a
va a
vaVal) Pred fn
psa)
  Case Term fn (SumOver as)
t List (Weighted (Binder fn)) as
branches -> do
    List (Weighted (Specification fn)) as
branchSpecs <- forall {k} (m :: * -> *) (f :: k -> *) (g :: k -> *) (as :: [k]).
Applicative m =>
(forall (a :: k). f a -> m (g a)) -> List f as -> m (List g as)
mapMList (forall (m :: * -> *) (f :: * -> *) a (g :: * -> *).
Applicative m =>
(f a -> m (g a)) -> Weighted f a -> m (Weighted g a)
traverseWeighted forall (fn :: [*] -> * -> *) a.
Binder fn a -> GE (Specification fn a)
computeSpecBinderSimplified) List (Weighted (Binder fn)) as
branches
    forall (fn :: [*] -> * -> *) v a.
HasSpec fn v =>
Specification fn a -> Ctx fn v a -> Specification fn v
propagateSpec (forall (fn :: [*] -> * -> *) (as :: [*]).
HasSpec fn (SumOver as) =>
Maybe [Char]
-> List (Weighted (Specification fn)) as
-> Specification fn (SumOver as)
caseSpec (forall a. a -> Maybe a
Just (forall a. Show a => a -> [Char]
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy @a)))) List (Weighted (Specification fn)) as
branchSpecs) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) (fn :: [*] -> * -> *) v a.
(BaseUniverse fn, Typeable v, MonadGenError m, HasCallStack,
 HasSpec fn a, HasSpec fn v) =>
Var v -> Term fn a -> m (Ctx fn v a)
toCtx Var a
x Term fn (SumOver as)
t
  When (Lit Bool
b) Pred fn
tp -> if Bool
b then forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, HasCallStack) =>
Var a -> Pred fn -> GE (Specification fn a)
computeSpecSimplified Var a
x Pred fn
tp else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec
  -- This shouldn't happen a lot of the time because when the body is trivial we mostly get rid of the `When` entirely
  When {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Specification fn a
SuspendedSpec Var a
x Pred fn
p
  Reifies (Lit b
a) (Lit a
val) a -> b
f
    | a -> b
f a
val forall a. Eq a => a -> a -> Bool
== b
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec
    | Bool
otherwise ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
          forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec (forall a. [a] -> NonEmpty a
NE.fromList [[Char]
"Value does not reify to literal: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
val forall a. [a] -> [a] -> [a]
++ [Char]
" -/> " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show b
a])
  Reifies Term fn b
t' (Lit a
val) a -> b
f ->
    forall (fn :: [*] -> * -> *) v a.
HasSpec fn v =>
Specification fn a -> Ctx fn v a -> Specification fn v
propagateSpec (forall a (fn :: [*] -> * -> *). a -> Specification fn a
equalSpec (a -> b
f a
val)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) (fn :: [*] -> * -> *) v a.
(BaseUniverse fn, Typeable v, MonadGenError m, HasCallStack,
 HasSpec fn a, HasSpec fn v) =>
Var v -> Term fn a -> m (Ctx fn v a)
toCtx Var a
x Term fn b
t'
  Reifies Lit {} Term fn a
_ a -> b
_ ->
    forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
fatalError forall a b. (a -> b) -> a -> b
$ forall a. [a] -> NonEmpty a
NE.fromList [[Char]
"Dependency error in computeSpec: Reifies", [Char]
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Pred fn
p]
  Explain NonEmpty [Char]
es Pred fn
p -> do
    -- In case things crash in here we want the explanation
    Specification fn a
s <- forall a. [[Char]] -> GE a -> GE a
pushGE (forall a. NonEmpty a -> [a]
NE.toList NonEmpty [Char]
es) (forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, HasCallStack) =>
Var a -> Pred fn -> GE (Specification fn a)
computeSpecSimplified Var a
x Pred fn
p)
    -- This is because while we do want to propagate `explanation`s into `SuspendedSpec`
    -- we probably don't want to propagate the full "currently simplifying xyz" explanation.
    case Specification fn a
s of
      SuspendedSpec Var a
x Pred fn
p -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Specification fn a
SuspendedSpec Var a
x (forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn -> Pred fn
explanation NonEmpty [Char]
es Pred fn
p)
      Specification fn a
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a -> Specification fn a
addToErrorSpec NonEmpty [Char]
es Specification fn a
s
  -- Impossible cases that should be ruled out by the dependency analysis and linearizer
  DependsOn {} ->
    forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
fatalError forall a b. (a -> b) -> a -> b
$
      forall a. [a] -> NonEmpty a
NE.fromList
        [[Char]
"The impossible happened in computeSpec: DependsOn", [Char]
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Var a
x, forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (forall a ann. Pretty a => a -> Doc ann
pretty Pred fn
p)]
  Reifies {} ->
    forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
fatalError forall a b. (a -> b) -> a -> b
$
      forall a. [a] -> NonEmpty a
NE.fromList
        [[Char]
"The impossible happened in computeSpec: Reifies", [Char]
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Var a
x, forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (forall a ann. Pretty a => a -> Doc ann
pretty Pred fn
p)]
  where
    -- We want `genError` to turn into `ErrorSpec` and we want `FatalError` to turn into `FatalError`
    localGESpec :: GE (Specification fn a) -> GE (Specification fn a)
localGESpec ge :: GE (Specification fn a)
ge@FatalError {} = GE (Specification fn a)
ge
    localGESpec GE (Specification fn a)
ge = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
(HasCallStack, HasSpec fn a) =>
GE (Specification fn a) -> Specification fn a
fromGESpec GE (Specification fn a)
ge

-- | Precondition: the `Pred fn` defines the `Var a`.
--
-- Runs in `GE` in order for us to have detailed context on failure.
computeSpec ::
  forall fn a. (HasSpec fn a, HasCallStack) => Var a -> Pred fn -> GE (Specification fn a)
computeSpec :: forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, HasCallStack) =>
Var a -> Pred fn -> GE (Specification fn a)
computeSpec Var a
x Pred fn
p = forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, HasCallStack) =>
Var a -> Pred fn -> GE (Specification fn a)
computeSpecSimplified Var a
x (forall (fn :: [*] -> * -> *). BaseUniverse fn => Pred fn -> Pred fn
simplifyPred Pred fn
p)

computeSpecBinder :: Binder fn a -> GE (Specification fn a)
computeSpecBinder :: forall (fn :: [*] -> * -> *) a.
Binder fn a -> GE (Specification fn a)
computeSpecBinder (Var a
x :-> Pred fn
p) = forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, HasCallStack) =>
Var a -> Pred fn -> GE (Specification fn a)
computeSpec Var a
x Pred fn
p

computeSpecBinderSimplified :: Binder fn a -> GE (Specification fn a)
computeSpecBinderSimplified :: forall (fn :: [*] -> * -> *) a.
Binder fn a -> GE (Specification fn a)
computeSpecBinderSimplified (Var a
x :-> Pred fn
p) = forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, HasCallStack) =>
Var a -> Pred fn -> GE (Specification fn a)
computeSpecSimplified Var a
x Pred fn
p

-- | Turn a list of branches into a SumSpec. If all the branches fail return an ErrorSpec.
caseSpec ::
  forall fn as.
  HasSpec fn (SumOver as) =>
  Maybe String ->
  List (Weighted (Specification fn)) as ->
  Specification fn (SumOver as)
caseSpec :: forall (fn :: [*] -> * -> *) (as :: [*]).
HasSpec fn (SumOver as) =>
Maybe [Char]
-> List (Weighted (Specification fn)) as
-> Specification fn (SumOver as)
caseSpec Maybe [Char]
tString List (Weighted (Specification fn)) as
ss
  | forall (as :: [*]). List (Weighted (Specification fn)) as -> Bool
allBranchesFail List (Weighted (Specification fn)) as
ss =
      forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec
        ( forall a. [a] -> NonEmpty a
NE.fromList
            [ [Char]
"When simplifying SumSpec, all branches in a caseOn" forall a. [a] -> [a] -> [a]
++ Maybe [Char] -> [Char]
sumType Maybe [Char]
tString forall a. [a] -> [a] -> [a]
++ [Char]
" simplify to False."
            , forall a. Show a => a -> [Char]
show Specification fn (SumOver as)
spec
            ]
        )
  | Bool
True = Specification fn (SumOver as)
spec
  where
    spec :: Specification fn (SumOver as)
spec = forall (fn :: [*] -> * -> *) (as :: [*]).
HasSpec fn (SumOver as) =>
Maybe [Char]
-> List (Weighted (Specification fn)) as
-> Specification fn (SumOver as)
loop Maybe [Char]
tString List (Weighted (Specification fn)) as
ss

    allBranchesFail :: forall as. List (Weighted (Specification fn)) as -> Bool
    allBranchesFail :: forall (as :: [*]). List (Weighted (Specification fn)) as -> Bool
allBranchesFail List (Weighted (Specification fn)) as
Nil = forall a. HasCallStack => [Char] -> a
error [Char]
"The impossible happened in allBranchesFail"
    allBranchesFail (Weighted Maybe Int
_ Specification fn a
s :> List (Weighted (Specification fn)) as1
Nil) = forall (fn :: [*] -> * -> *) a. Specification fn a -> Bool
isErrorLike Specification fn a
s
    allBranchesFail (Weighted Maybe Int
_ Specification fn a
s :> ss :: List (Weighted (Specification fn)) as1
ss@(Weighted (Specification fn) a
_ :> List (Weighted (Specification fn)) as1
_)) = forall (fn :: [*] -> * -> *) a. Specification fn a -> Bool
isErrorLike Specification fn a
s Bool -> Bool -> Bool
&& forall (as :: [*]). List (Weighted (Specification fn)) as -> Bool
allBranchesFail List (Weighted (Specification fn)) as1
ss

    loop ::
      forall fn as.
      HasSpec fn (SumOver as) =>
      Maybe String -> List (Weighted (Specification fn)) as -> Specification fn (SumOver as)
    loop :: forall (fn :: [*] -> * -> *) (as :: [*]).
HasSpec fn (SumOver as) =>
Maybe [Char]
-> List (Weighted (Specification fn)) as
-> Specification fn (SumOver as)
loop Maybe [Char]
_ List (Weighted (Specification fn)) as
Nil = forall a. HasCallStack => [Char] -> a
error [Char]
"The impossible happened in caseSpec"
    loop Maybe [Char]
_ (Weighted (Specification fn) a
s :> List (Weighted (Specification fn)) as1
Nil) = forall (f :: * -> *) a. Weighted f a -> f a
thing Weighted (Specification fn) a
s
    loop Maybe [Char]
mTypeString (Weighted (Specification fn) a
s :> ss :: List (Weighted (Specification fn)) as1
ss@(Weighted (Specification fn) a
_ :> List (Weighted (Specification fn)) as1
_))
      | Evidence (Prerequisites fn (SumOver as))
Evidence <- forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Evidence (Prerequisites fn a)
prerequisites @fn @(SumOver as) =
          (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a b.
Maybe [Char]
-> Maybe (Int, Int)
-> Specification fn a
-> Specification fn b
-> SumSpec fn a b
SumSpecRaw Maybe [Char]
mTypeString Maybe (Int, Int)
theWeights (forall (f :: * -> *) a. Weighted f a -> f a
thing Weighted (Specification fn) a
s) (forall (fn :: [*] -> * -> *) (as :: [*]).
HasSpec fn (SumOver as) =>
Maybe [Char]
-> List (Weighted (Specification fn)) as
-> Specification fn (SumOver as)
loop forall a. Maybe a
Nothing List (Weighted (Specification fn)) as1
ss))
      where
        theWeights :: Maybe (Int, Int)
theWeights =
          case (forall (f :: * -> *) a. Weighted f a -> Maybe Int
weight Weighted (Specification fn) a
s, forall (f :: * -> *) (as :: [*]). List (Weighted f) as -> Maybe Int
totalWeight List (Weighted (Specification fn)) as1
ss) of
            (Maybe Int
Nothing, Maybe Int
Nothing) -> forall a. Maybe a
Nothing
            (Maybe Int
a, Maybe Int
b) -> forall a. a -> Maybe a
Just (forall a. a -> Maybe a -> a
fromMaybe Int
1 Maybe Int
a, forall a. a -> Maybe a -> a
fromMaybe (forall {k} (f :: k -> *) (as :: [k]). List f as -> Int
lengthList List (Weighted (Specification fn)) as1
ss) Maybe Int
b)

totalWeight :: List (Weighted f) as -> Maybe Int
totalWeight :: forall (f :: * -> *) (as :: [*]). List (Weighted f) as -> Maybe Int
totalWeight = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Sum a -> a
Semigroup.getSum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} b (f :: k -> *) (as :: [k]).
Monoid b =>
(forall (a :: k). f a -> b) -> List f as -> b
foldMapList (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Sum a
Semigroup.Sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Weighted f a -> Maybe Int
weight)

propagateSpec ::
  forall fn v a.
  HasSpec fn v =>
  Specification fn a ->
  Ctx fn v a ->
  Specification fn v
propagateSpec :: forall (fn :: [*] -> * -> *) v a.
HasSpec fn v =>
Specification fn a -> Ctx fn v a -> Specification fn v
propagateSpec Specification fn a
spec = \case
  Ctx fn v a
CtxHOLE -> Specification fn a
spec
  CtxApp fn as a
f (ListCtx List Value as
pre Ctx fn v a
c List Value as'
suf)
    | Evidence (HasSpec fn a)
Evidence <- forall (fn :: [*] -> * -> *) v a.
Ctx fn v a -> Evidence (HasSpec fn a)
ctxHasSpec Ctx fn v a
c -> forall (fn :: [*] -> * -> *) v a.
HasSpec fn v =>
Specification fn a -> Ctx fn v a -> Specification fn v
propagateSpec (forall (f :: [*] -> * -> *) (fn :: [*] -> * -> *) (as :: [*]) a b.
(Functions f fn, TypeList as, Typeable as, HasSpec fn a,
 HasSpec fn b, All (HasSpec fn) as) =>
f as b
-> ListCtx Value as (HOLE a)
-> Specification fn b
-> Specification fn a
propagateSpecFun fn as a
f (forall (as'' :: [*]) (f :: * -> *) (c :: * -> *) (as :: [*]) a
       (as' :: [*]).
(as'' ~ Append as (a : as')) =>
List f as -> c a -> List f as' -> ListCtx f as'' c
ListCtx List Value as
pre forall a. HOLE a a
HOLE List Value as'
suf) Specification fn a
spec) Ctx fn v a
c

ctxHasSpec :: Ctx fn v a -> Evidence (HasSpec fn a)
ctxHasSpec :: forall (fn :: [*] -> * -> *) v a.
Ctx fn v a -> Evidence (HasSpec fn a)
ctxHasSpec Ctx fn v a
CtxHOLE = forall (c :: Constraint). c => Evidence c
Evidence
ctxHasSpec CtxApp {} = forall (c :: Constraint). c => Evidence c
Evidence

class
  ( forall as b. Show (f as b)
  , forall as b. Eq (f as b)
  , Typeable f
  , FunctionLike f
  ) =>
  Functions f fn
  where
  propagateSpecFun ::
    ( TypeList as
    , Typeable as
    , HasSpec fn a
    , HasSpec fn b
    , All (HasSpec fn) as
    ) =>
    f as b ->
    ListCtx Value as (HOLE a) ->
    Specification fn b ->
    Specification fn a

  rewriteRules ::
    ( TypeList as
    , Typeable as
    , HasSpec fn b
    , All (HasSpec fn) as
    ) =>
    f as b ->
    List (Term fn) as ->
    Maybe (Term fn b)
  rewriteRules f as b
_ List (Term fn) as
_ = forall a. Maybe a
Nothing

  mapTypeSpec ::
    ( HasSpec fn a
    , HasSpec fn b
    ) =>
    f '[a] b ->
    TypeSpec fn a ->
    Specification fn b

mapSpec ::
  forall fn a b.
  ( HasSpec fn a
  , HasSpec fn b
  ) =>
  fn '[a] b ->
  Specification fn a ->
  Specification fn b
mapSpec :: forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, HasSpec fn b) =>
fn '[a] b -> Specification fn a -> Specification fn b
mapSpec fn '[a] b
f (ExplainSpec [[Char]]
es Specification fn a
s) = forall (fn :: [*] -> * -> *) a.
[[Char]] -> Specification fn a -> Specification fn a
explainSpecOpt [[Char]]
es (forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, HasSpec fn b) =>
fn '[a] b -> Specification fn a -> Specification fn b
mapSpec fn '[a] b
f Specification fn a
s)
mapSpec fn '[a] b
f Specification fn a
TrueSpec = forall (f :: [*] -> * -> *) (fn :: [*] -> * -> *) a b.
(Functions f fn, HasSpec fn a, HasSpec fn b) =>
f '[a] b -> TypeSpec fn a -> Specification fn b
mapTypeSpec fn '[a] b
f (forall (fn :: [*] -> * -> *) a. HasSpec fn a => TypeSpec fn a
emptySpec @fn @a)
mapSpec fn '[a] b
_ (ErrorSpec NonEmpty [Char]
err) = forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec NonEmpty [Char]
err
mapSpec fn '[a] b
f (MemberSpec NonEmpty a
as) = forall a (fn :: [*] -> * -> *). NonEmpty a -> Specification fn a
MemberSpec forall a b. (a -> b) -> a -> b
$ forall a. Eq a => NonEmpty a -> NonEmpty a
NE.nub forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (fn :: [*] -> * -> *) (as :: [*]) b.
FunctionLike fn =>
fn as b -> FunTy as b
sem fn '[a] b
f) NonEmpty a
as
mapSpec fn '[a] b
f (SuspendedSpec Var a
x Pred fn
p) =
  forall a (fn :: [*] -> * -> *) p.
(IsPred p fn, HasSpec fn a) =>
(Term fn a -> p) -> Specification fn a
constrained forall a b. (a -> b) -> a -> b
$ \Term fn b
x' ->
    forall (fn :: [*] -> * -> *) a.
((forall b. Term fn b -> b) -> GE a) -> Binder fn a -> Pred fn
Exists (\forall b. Term fn b -> b
_ -> forall (m :: * -> *) a. MonadGenError m => [Char] -> m a
fatalError1 [Char]
"mapSpec") (Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Binder fn a
:-> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
p -> Pred fn
assert forall a b. (a -> b) -> a -> b
$ Term fn b
x' forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Term fn a -> Term fn Bool
==. forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app fn '[a] b
f (forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Term fn a
V Var a
x), Pred fn
p])
mapSpec fn '[a] b
f (TypeSpec TypeSpec fn a
ts OrdSet a
cant) = forall (f :: [*] -> * -> *) (fn :: [*] -> * -> *) a b.
(Functions f fn, HasSpec fn a, HasSpec fn b) =>
f '[a] b -> TypeSpec fn a -> Specification fn b
mapTypeSpec fn '[a] b
f TypeSpec fn a
ts forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a (f :: * -> *).
(HasSpec fn a, Foldable f) =>
f a -> Specification fn a
notMemberSpec (forall a b. (a -> b) -> [a] -> [b]
map (forall (fn :: [*] -> * -> *) (as :: [*]) b.
FunctionLike fn =>
fn as b -> FunTy as b
sem fn '[a] b
f) OrdSet a
cant)

-- | If the `Specification fn Bool` doesn't constrain the boolean you will get a `TrueSpec` out.
caseBoolSpec ::
  HasSpec fn a => Specification fn Bool -> (Bool -> Specification fn a) -> Specification fn a
caseBoolSpec :: forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn Bool
-> (Bool -> Specification fn a) -> Specification fn a
caseBoolSpec Specification fn Bool
spec Bool -> Specification fn a
cont = case forall {fn :: [*] -> * -> *}.
(Functions fn fn,
 IsMember (EqFn fn) fn (FromJust (MPath (EqFn fn) fn)),
 IsMember (SetFn fn) fn (FromJust (MPath (SetFn fn) fn)),
 IsMember (BoolFn fn) fn (FromJust (MPath (BoolFn fn) fn)),
 IsMember (PairFn fn) fn (FromJust (MPath (PairFn fn) fn)),
 IsMember (IntFn fn) fn (FromJust (MPath (IntFn fn) fn)),
 IsMember (OrdFn fn) fn (FromJust (MPath (OrdFn fn) fn)),
 IsMember (GenericsFn fn) fn (FromJust (MPath (GenericsFn fn) fn)),
 IsMember (ListFn fn) fn (FromJust (MPath (ListFn fn) fn)),
 IsMember (SumFn fn) fn (FromJust (MPath (SumFn fn) fn)),
 IsMember (MapFn fn) fn (FromJust (MPath (MapFn fn) fn)),
 IsMember (FunFn fn) fn (FromJust (MPath (FunFn fn) fn)),
 IsMember (SizeFn fn) fn (FromJust (MPath (SizeFn fn) fn))) =>
Specification fn Bool -> [Bool]
possibleValues Specification fn Bool
spec of
  [] -> forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec (forall a. [a] -> NonEmpty a
NE.fromList [[Char]
"No possible values in caseBoolSpec"])
  [Bool
b] -> Bool -> Specification fn a
cont Bool
b
  [Bool]
_ -> forall a. Monoid a => a
mempty
  where
    possibleValues :: Specification fn Bool -> [Bool]
possibleValues Specification fn Bool
s = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
conformsToSpec (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn a -> Specification fn a
simplifySpec Specification fn Bool
s)) [Bool
True, Bool
False]

isErrorLike :: forall fn a. Specification fn a -> Bool
isErrorLike :: forall (fn :: [*] -> * -> *) a. Specification fn a -> Bool
isErrorLike (ExplainSpec [[Char]]
_ Specification fn a
s) = forall (fn :: [*] -> * -> *) a. Specification fn a -> Bool
isErrorLike Specification fn a
s
isErrorLike ErrorSpec {} = Bool
True
isErrorLike (TypeSpec TypeSpec fn a
x OrdSet a
_) =
  case forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Maybe (NonEmpty [Char])
typeSpecHasError @fn @a TypeSpec fn a
x of
    Maybe (NonEmpty [Char])
Nothing -> Bool
False
    Just NonEmpty [Char]
_ -> Bool
True
isErrorLike Specification fn a
_ = Bool
False

errorLikeMessage :: forall fn a. Specification fn a -> NE.NonEmpty String
errorLikeMessage :: forall (fn :: [*] -> * -> *) a.
Specification fn a -> NonEmpty [Char]
errorLikeMessage (ErrorSpec NonEmpty [Char]
es) = NonEmpty [Char]
es
errorLikeMessage (TypeSpec TypeSpec fn a
x OrdSet a
_) =
  case forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Maybe (NonEmpty [Char])
typeSpecHasError @fn @a TypeSpec fn a
x of
    Maybe (NonEmpty [Char])
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
"Bad call to errorLikeMessage case 1, not guarded by isErrorLike")
    Just NonEmpty [Char]
xs -> NonEmpty [Char]
xs
errorLikeMessage Specification fn a
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
"Bad call to errorLikeMessage, case 2, not guarded by isErrorLike")

------------------------------------------------------------------------
-- Dependency Graphs
------------------------------------------------------------------------

type DependGraph fn = Graph.Graph (Name fn)

dependency :: HasVariables fn t => Name fn -> t -> DependGraph fn
dependency :: forall (fn :: [*] -> * -> *) t.
HasVariables fn t =>
Name fn -> t -> DependGraph fn
dependency Name fn
x (forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet -> Set (Name fn)
xs) = forall node. Ord node => node -> Set node -> Graph node
Graph.dependency Name fn
x Set (Name fn)
xs

irreflexiveDependencyOn ::
  forall fn t t'. (HasVariables fn t, HasVariables fn t') => t -> t' -> DependGraph fn
irreflexiveDependencyOn :: forall (fn :: [*] -> * -> *) t t'.
(HasVariables fn t, HasVariables fn t') =>
t -> t' -> DependGraph fn
irreflexiveDependencyOn (forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet -> Set (Name fn)
xs) (forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet -> Set (Name fn)
ys) = forall node. Ord node => Set node -> Set node -> Graph node
Graph.irreflexiveDependencyOn Set (Name fn)
xs Set (Name fn)
ys

noDependencies :: HasVariables fn t => t -> DependGraph fn
noDependencies :: forall (fn :: [*] -> * -> *) t.
HasVariables fn t =>
t -> DependGraph fn
noDependencies (forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet -> Set (Name fn)
xs) = forall node. Ord node => Set node -> Graph node
Graph.noDependencies Set (Name fn)
xs

type Hints fn = DependGraph fn

respecting :: Hints f -> DependGraph f -> DependGraph f
respecting :: forall (f :: [*] -> * -> *). Hints f -> Hints f -> Hints f
respecting Hints f
hints Hints f
g = Hints f
g forall node. Ord node => Graph node -> Graph node -> Graph node
`subtractGraph` forall node. Graph node -> Graph node
opGraph Hints f
hints

solvableFrom :: Name f -> Set (Name f) -> DependGraph f -> Bool
solvableFrom :: forall (f :: [*] -> * -> *).
Name f -> Set (Name f) -> DependGraph f -> Bool
solvableFrom Name f
x Set (Name f)
s DependGraph f
g =
  let less :: Set (Name f)
less = forall node. Ord node => node -> Graph node -> Set node
dependencies Name f
x DependGraph f
g
   in Set (Name f)
s forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set (Name f)
less Bool -> Bool -> Bool
&& Bool -> Bool
not (Name f
x forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (Name f)
less)

------------------------------------------------------------------------
-- Free variables and variable names
------------------------------------------------------------------------

freeVarNames :: forall fn t. HasVariables fn t => t -> Set Int
freeVarNames :: forall (fn :: [*] -> * -> *) t. HasVariables fn t => t -> Set Int
freeVarNames = forall a b. (a -> b) -> Set a -> Set b
Set.mapMonotonic (\(Name Var a
v) -> forall a. Var a -> Int
nameOf Var a
v) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet

data Name fn where
  Name :: HasSpec fn a => Var a -> Name fn

deriving instance Show (Name fn)

instance Eq (Name fn) where
  Name Var a
v == :: Name fn -> Name fn -> Bool
== Name Var a
v' = forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ forall a a'.
(Typeable a, Typeable a') =>
Var a -> Var a' -> Maybe (a :~: a')
eqVar Var a
v Var a
v'

instance Ord (Name fn) where
  compare :: Name fn -> Name fn -> Ordering
compare (Name Var a
v) (Name Var a
v') = forall a. Ord a => a -> a -> Ordering
compare (forall a. Var a -> Int
nameOf Var a
v, forall a. Typeable a => a -> TypeRep
typeOf Var a
v) (forall a. Var a -> Int
nameOf Var a
v', forall a. Typeable a => a -> TypeRep
typeOf Var a
v')

newtype FreeVars fn = FreeVars {forall (fn :: [*] -> * -> *). FreeVars fn -> Map (Name fn) Int
unFreeVars :: Map (Name fn) Int}
  deriving (Int -> FreeVars fn -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
forall (fn :: [*] -> * -> *). Int -> FreeVars fn -> ShowS
forall (fn :: [*] -> * -> *). [FreeVars fn] -> ShowS
forall (fn :: [*] -> * -> *). FreeVars fn -> [Char]
showList :: [FreeVars fn] -> ShowS
$cshowList :: forall (fn :: [*] -> * -> *). [FreeVars fn] -> ShowS
show :: FreeVars fn -> [Char]
$cshow :: forall (fn :: [*] -> * -> *). FreeVars fn -> [Char]
showsPrec :: Int -> FreeVars fn -> ShowS
$cshowsPrec :: forall (fn :: [*] -> * -> *). Int -> FreeVars fn -> ShowS
Show)

restrictedTo :: FreeVars fn -> Set (Name fn) -> FreeVars fn
restrictedTo :: forall (fn :: [*] -> * -> *).
FreeVars fn -> Set (Name fn) -> FreeVars fn
restrictedTo (FreeVars Map (Name fn) Int
m) Set (Name fn)
nms = forall (fn :: [*] -> * -> *). Map (Name fn) Int -> FreeVars fn
FreeVars forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map (Name fn) Int
m Set (Name fn)
nms

memberOf :: Name fn -> FreeVars fn -> Bool
memberOf :: forall (fn :: [*] -> * -> *). Name fn -> FreeVars fn -> Bool
memberOf Name fn
n (FreeVars Map (Name fn) Int
m) = forall k a. Ord k => k -> Map k a -> Bool
Map.member Name fn
n Map (Name fn) Int
m

count :: Name fn -> FreeVars fn -> Int
count :: forall (fn :: [*] -> * -> *). Name fn -> FreeVars fn -> Int
count Name fn
n (FreeVars Map (Name fn) Int
m) = forall a. a -> Maybe a -> a
fromMaybe Int
0 forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name fn
n Map (Name fn) Int
m

instance Semigroup (FreeVars fn) where
  FreeVars Map (Name fn) Int
fv <> :: FreeVars fn -> FreeVars fn -> FreeVars fn
<> FreeVars Map (Name fn) Int
fv' = forall (fn :: [*] -> * -> *). Map (Name fn) Int -> FreeVars fn
FreeVars forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Num a => a -> a -> a
(+) Map (Name fn) Int
fv Map (Name fn) Int
fv'

instance Monoid (FreeVars fn) where
  mempty :: FreeVars fn
mempty = forall (fn :: [*] -> * -> *). Map (Name fn) Int -> FreeVars fn
FreeVars forall a. Monoid a => a
mempty

freeVar :: Name fn -> FreeVars fn
freeVar :: forall (fn :: [*] -> * -> *). Name fn -> FreeVars fn
freeVar Name fn
n = forall (fn :: [*] -> * -> *). Name fn -> Int -> FreeVars fn
singleton Name fn
n Int
1

singleton :: Name fn -> Int -> FreeVars fn
singleton :: forall (fn :: [*] -> * -> *). Name fn -> Int -> FreeVars fn
singleton Name fn
n Int
k = forall (fn :: [*] -> * -> *). Map (Name fn) Int -> FreeVars fn
FreeVars forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton Name fn
n Int
k

without :: Foldable t => FreeVars fn -> t (Name fn) -> FreeVars fn
without :: forall (t :: * -> *) (fn :: [*] -> * -> *).
Foldable t =>
FreeVars fn -> t (Name fn) -> FreeVars fn
without (FreeVars Map (Name fn) Int
m) t (Name fn)
remove = forall (fn :: [*] -> * -> *). Map (Name fn) Int -> FreeVars fn
FreeVars forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Map (Name fn) Int
m (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t (Name fn)
remove)

class HasVariables fn a | a -> fn where
  freeVars :: a -> FreeVars fn
  freeVarSet :: a -> Set (Name fn)
  freeVarSet = forall k a. Map k a -> Set k
Map.keysSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fn :: [*] -> * -> *). FreeVars fn -> Map (Name fn) Int
unFreeVars forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars
  countOf :: Name fn -> a -> Int
  countOf Name fn
n = forall (fn :: [*] -> * -> *). Name fn -> FreeVars fn -> Int
count Name fn
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars
  appearsIn :: Name fn -> a -> Bool
  appearsIn Name fn
n = (forall a. Ord a => a -> a -> Bool
> Int
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fn :: [*] -> * -> *). Name fn -> FreeVars fn -> Int
count Name fn
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars

instance (HasVariables f a, HasVariables f b) => HasVariables f (a, b) where
  freeVars :: (a, b) -> FreeVars f
freeVars (a
a, b
b) = forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars a
a forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars b
b
  freeVarSet :: (a, b) -> Set (Name f)
freeVarSet (a
a, b
b) = forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet a
a forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet b
b
  countOf :: Name f -> (a, b) -> Int
countOf Name f
n (a
a, b
b) = forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf Name f
n a
a forall a. Num a => a -> a -> a
+ forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf Name f
n b
b
  appearsIn :: Name f -> (a, b) -> Bool
appearsIn Name f
n (a
a, b
b) = forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
appearsIn Name f
n a
a Bool -> Bool -> Bool
|| forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
appearsIn Name f
n b
b

instance HasVariables fn (List (Term fn) as) where
  freeVars :: List (Term fn) as -> FreeVars fn
freeVars List (Term fn) as
Nil = forall a. Monoid a => a
mempty
  freeVars (Term fn a
x :> List (Term fn) as1
xs) = forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars Term fn a
x forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars List (Term fn) as1
xs
  freeVarSet :: List (Term fn) as -> Set (Name fn)
freeVarSet List (Term fn) as
Nil = forall a. Monoid a => a
mempty
  freeVarSet (Term fn a
x :> List (Term fn) as1
xs) = forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet Term fn a
x forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet List (Term fn) as1
xs
  countOf :: Name fn -> List (Term fn) as -> Int
countOf Name fn
_ List (Term fn) as
Nil = Int
0
  countOf Name fn
n (Term fn a
x :> List (Term fn) as1
xs) = forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf Name fn
n Term fn a
x forall a. Num a => a -> a -> a
+ forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf Name fn
n List (Term fn) as1
xs
  appearsIn :: Name fn -> List (Term fn) as -> Bool
appearsIn Name fn
_ List (Term fn) as
Nil = Bool
False
  appearsIn Name fn
n (Term fn a
x :> List (Term fn) as1
xs) = forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
appearsIn Name fn
n Term fn a
x Bool -> Bool -> Bool
|| forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
appearsIn Name fn
n List (Term fn) as1
xs

instance HasVariables f (Name f) where
  freeVars :: Name f -> FreeVars f
freeVars = forall (fn :: [*] -> * -> *). Name fn -> FreeVars fn
freeVar
  freeVarSet :: Name f -> Set (Name f)
freeVarSet = forall a. a -> Set a
Set.singleton
  countOf :: Name f -> Name f -> Int
countOf Name f
n Name f
n'
    | Name f
n forall a. Eq a => a -> a -> Bool
== Name f
n' = Int
1
    | Bool
otherwise = Int
0
  appearsIn :: Name f -> Name f -> Bool
appearsIn Name f
n Name f
n' = Name f
n forall a. Eq a => a -> a -> Bool
== Name f
n'

instance HasVariables fn (Term fn a) where
  freeVars :: Term fn a -> FreeVars fn
freeVars = \case
    Lit {} -> forall a. Monoid a => a
mempty
    V Var a
x -> forall (fn :: [*] -> * -> *). Name fn -> FreeVars fn
freeVar (forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Name fn
Name Var a
x)
    App fn as a
_ List (Term fn) as
ts -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars List (Term fn) as
ts
  freeVarSet :: Term fn a -> Set (Name fn)
freeVarSet = \case
    Lit {} -> forall a. Monoid a => a
mempty
    V Var a
x -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet (forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Name fn
Name Var a
x)
    App fn as a
_ List (Term fn) as
ts -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet List (Term fn) as
ts
  countOf :: Name fn -> Term fn a -> Int
countOf Name fn
n = \case
    Lit {} -> Int
0
    V Var a
x -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf Name fn
n (forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Name fn
Name Var a
x)
    App fn as a
_ List (Term fn) as
ts -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf Name fn
n List (Term fn) as
ts
  appearsIn :: Name fn -> Term fn a -> Bool
appearsIn Name fn
n = \case
    Lit {} -> Bool
False
    V Var a
x -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
appearsIn Name fn
n (forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Name fn
Name Var a
x)
    App fn as a
_ List (Term fn) as
ts -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
appearsIn Name fn
n List (Term fn) as
ts

instance HasVariables fn (Pred fn) where
  freeVars :: Pred fn -> FreeVars fn
freeVars = \case
    GenHint Hint a
_ Term fn a
t -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars Term fn a
t
    Subst Var a
x Term fn a
t Pred fn
p -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars Term fn a
t forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars Pred fn
p forall (t :: * -> *) (fn :: [*] -> * -> *).
Foldable t =>
FreeVars fn -> t (Name fn) -> FreeVars fn
`without` [forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Name fn
Name Var a
x]
    Block [Pred fn]
ps -> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars [Pred fn]
ps
    Let Term fn a
t Binder fn a
b -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars Term fn a
t forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars Binder fn a
b
    Exists (forall b. Term fn b -> b) -> GE a
_ Binder fn a
b -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars Binder fn a
b
    Assert Term fn Bool
t -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars Term fn Bool
t
    Reifies Term fn b
t' Term fn a
t a -> b
_ -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars Term fn b
t' forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars Term fn a
t
    DependsOn Term fn a
x Term fn b
y -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars Term fn a
x forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars Term fn b
y
    ForAll Term fn t
set Binder fn a
b -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars Term fn t
set forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars Binder fn a
b
    Case Term fn (SumOver as)
t List (Weighted (Binder fn)) as
bs -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars Term fn (SumOver as)
t forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars List (Weighted (Binder fn)) as
bs
    When Term fn Bool
b Pred fn
p -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars Term fn Bool
b forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars Pred fn
p
    Pred fn
TruePred -> forall a. Monoid a => a
mempty
    FalsePred NonEmpty [Char]
_ -> forall a. Monoid a => a
mempty
    Monitor {} -> forall a. Monoid a => a
mempty
    Explain NonEmpty [Char]
_ Pred fn
p -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars Pred fn
p
  freeVarSet :: Pred fn -> Set (Name fn)
freeVarSet = \case
    GenHint Hint a
_ Term fn a
t -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet Term fn a
t
    Subst Var a
x Term fn a
t Pred fn
p -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet Term fn a
t forall a. Semigroup a => a -> a -> a
<> forall a. Ord a => a -> Set a -> Set a
Set.delete (forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Name fn
Name Var a
x) (forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet Pred fn
p)
    Block [Pred fn]
ps -> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet [Pred fn]
ps
    Let Term fn a
t Binder fn a
b -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet Term fn a
t forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet Binder fn a
b
    Exists (forall b. Term fn b -> b) -> GE a
_ Binder fn a
b -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet Binder fn a
b
    Assert Term fn Bool
t -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet Term fn Bool
t
    Reifies Term fn b
t' Term fn a
t a -> b
_ -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet Term fn b
t' forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet Term fn a
t
    DependsOn Term fn a
x Term fn b
y -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet Term fn a
x forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet Term fn b
y
    ForAll Term fn t
set Binder fn a
b -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet Term fn t
set forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet Binder fn a
b
    Case Term fn (SumOver as)
t List (Weighted (Binder fn)) as
bs -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet Term fn (SumOver as)
t forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet List (Weighted (Binder fn)) as
bs
    When Term fn Bool
b Pred fn
p -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet Term fn Bool
b forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet Pred fn
p
    Explain NonEmpty [Char]
_ Pred fn
p -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet Pred fn
p
    Pred fn
TruePred -> forall a. Monoid a => a
mempty
    FalsePred NonEmpty [Char]
_ -> forall a. Monoid a => a
mempty
    Monitor {} -> forall a. Monoid a => a
mempty
  countOf :: Name fn -> Pred fn -> Int
countOf Name fn
n = \case
    GenHint Hint a
_ Term fn a
t -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf Name fn
n Term fn a
t
    Subst Var a
x Term fn a
t Pred fn
p
      | Name fn
n forall a. Eq a => a -> a -> Bool
== forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Name fn
Name Var a
x -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf Name fn
n Term fn a
t
      | Bool
otherwise -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf Name fn
n Term fn a
t forall a. Num a => a -> a -> a
+ forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf Name fn
n Pred fn
p
    Block [Pred fn]
ps -> forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf Name fn
n) [Pred fn]
ps
    Let Term fn a
t Binder fn a
b -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf Name fn
n Term fn a
t forall a. Num a => a -> a -> a
+ forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf Name fn
n Binder fn a
b
    Exists (forall b. Term fn b -> b) -> GE a
_ Binder fn a
b -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf Name fn
n Binder fn a
b
    Assert Term fn Bool
t -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf Name fn
n Term fn Bool
t
    Reifies Term fn b
t' Term fn a
t a -> b
_ -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf Name fn
n Term fn b
t' forall a. Num a => a -> a -> a
+ forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf Name fn
n Term fn a
t
    DependsOn Term fn a
x Term fn b
y -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf Name fn
n Term fn a
x forall a. Num a => a -> a -> a
+ forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf Name fn
n Term fn b
y
    ForAll Term fn t
set Binder fn a
b -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf Name fn
n Term fn t
set forall a. Num a => a -> a -> a
+ forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf Name fn
n Binder fn a
b
    Case Term fn (SumOver as)
t List (Weighted (Binder fn)) as
bs -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf Name fn
n Term fn (SumOver as)
t forall a. Num a => a -> a -> a
+ forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf Name fn
n List (Weighted (Binder fn)) as
bs
    When Term fn Bool
b Pred fn
p -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf Name fn
n Term fn Bool
b forall a. Num a => a -> a -> a
+ forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf Name fn
n Pred fn
p
    Explain NonEmpty [Char]
_ Pred fn
p -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf Name fn
n Pred fn
p
    Pred fn
TruePred -> Int
0
    FalsePred NonEmpty [Char]
_ -> Int
0
    Monitor {} -> Int
0
  appearsIn :: Name fn -> Pred fn -> Bool
appearsIn Name fn
n = \case
    GenHint Hint a
_ Term fn a
t -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
appearsIn Name fn
n Term fn a
t
    Subst Var a
x Term fn a
t Pred fn
p
      | Name fn
n forall a. Eq a => a -> a -> Bool
== forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Name fn
Name Var a
x -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
appearsIn Name fn
n Term fn a
t
      | Bool
otherwise -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
appearsIn Name fn
n Term fn a
t Bool -> Bool -> Bool
|| forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
appearsIn Name fn
n Pred fn
p
    Block [Pred fn]
ps -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
appearsIn Name fn
n) [Pred fn]
ps
    Let Term fn a
t Binder fn a
b -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
appearsIn Name fn
n Term fn a
t Bool -> Bool -> Bool
|| forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
appearsIn Name fn
n Binder fn a
b
    Exists (forall b. Term fn b -> b) -> GE a
_ Binder fn a
b -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
appearsIn Name fn
n Binder fn a
b
    Assert Term fn Bool
t -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
appearsIn Name fn
n Term fn Bool
t
    Reifies Term fn b
t' Term fn a
t a -> b
_ -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
appearsIn Name fn
n Term fn b
t' Bool -> Bool -> Bool
|| forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
appearsIn Name fn
n Term fn a
t
    DependsOn Term fn a
x Term fn b
y -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
appearsIn Name fn
n Term fn a
x Bool -> Bool -> Bool
|| forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
appearsIn Name fn
n Term fn b
y
    ForAll Term fn t
set Binder fn a
b -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
appearsIn Name fn
n Term fn t
set Bool -> Bool -> Bool
|| forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
appearsIn Name fn
n Binder fn a
b
    Case Term fn (SumOver as)
t List (Weighted (Binder fn)) as
bs -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
appearsIn Name fn
n Term fn (SumOver as)
t Bool -> Bool -> Bool
|| forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
appearsIn Name fn
n List (Weighted (Binder fn)) as
bs
    When Term fn Bool
b Pred fn
p -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
appearsIn Name fn
n Term fn Bool
b Bool -> Bool -> Bool
|| forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
appearsIn Name fn
n Pred fn
p
    Explain NonEmpty [Char]
_ Pred fn
p -> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
appearsIn Name fn
n Pred fn
p
    Pred fn
TruePred -> Bool
False
    FalsePred NonEmpty [Char]
_ -> Bool
False
    Monitor {} -> Bool
False

instance HasVariables fn (Binder fn a) where
  freeVars :: Binder fn a -> FreeVars fn
freeVars (Var a
x :-> Pred fn
p) = forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars Pred fn
p forall (t :: * -> *) (fn :: [*] -> * -> *).
Foldable t =>
FreeVars fn -> t (Name fn) -> FreeVars fn
`without` [forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Name fn
Name Var a
x]
  freeVarSet :: Binder fn a -> Set (Name fn)
freeVarSet (Var a
x :-> Pred fn
p) = forall a. Ord a => a -> Set a -> Set a
Set.delete (forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Name fn
Name Var a
x) (forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet Pred fn
p)
  countOf :: Name fn -> Binder fn a -> Int
countOf Name fn
n (Var a
x :-> Pred fn
p)
    | forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Name fn
Name Var a
x forall a. Eq a => a -> a -> Bool
== Name fn
n = Int
0
    | Bool
otherwise = forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf Name fn
n Pred fn
p
  appearsIn :: Name fn -> Binder fn a -> Bool
appearsIn Name fn
n (Var a
x :-> Pred fn
p)
    | forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Name fn
Name Var a
x forall a. Eq a => a -> a -> Bool
== Name fn
n = Bool
False
    | Bool
otherwise = forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
appearsIn Name fn
n Pred fn
p

instance HasVariables fn (f a) => HasVariables fn (Weighted f a) where
  freeVars :: Weighted f a -> FreeVars fn
freeVars = forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Weighted f a -> f a
thing
  freeVarSet :: Weighted f a -> Set (Name fn)
freeVarSet = forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Weighted f a -> f a
thing
  countOf :: Name fn -> Weighted f a -> Int
countOf Name fn
n = forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf Name fn
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Weighted f a -> f a
thing
  appearsIn :: Name fn -> Weighted f a -> Bool
appearsIn Name fn
n = forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
appearsIn Name fn
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Weighted f a -> f a
thing

instance HasVariables fn (List (Weighted (Binder fn)) as) where
  freeVars :: List (Weighted (Binder fn)) as -> FreeVars fn
freeVars List (Weighted (Binder fn)) as
Nil = forall a. Monoid a => a
mempty
  freeVars (Weighted (Binder fn) a
a :> List (Weighted (Binder fn)) as1
as) = forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars Weighted (Binder fn) a
a forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars List (Weighted (Binder fn)) as1
as
  freeVarSet :: List (Weighted (Binder fn)) as -> Set (Name fn)
freeVarSet List (Weighted (Binder fn)) as
Nil = forall a. Monoid a => a
mempty
  freeVarSet (Weighted (Binder fn) a
a :> List (Weighted (Binder fn)) as1
as) = forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet Weighted (Binder fn) a
a forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet List (Weighted (Binder fn)) as1
as
  countOf :: Name fn -> List (Weighted (Binder fn)) as -> Int
countOf Name fn
_ List (Weighted (Binder fn)) as
Nil = Int
0
  countOf Name fn
n (Weighted (Binder fn) a
x :> List (Weighted (Binder fn)) as1
xs) = forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf Name fn
n Weighted (Binder fn) a
x forall a. Num a => a -> a -> a
+ forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf Name fn
n List (Weighted (Binder fn)) as1
xs
  appearsIn :: Name fn -> List (Weighted (Binder fn)) as -> Bool
appearsIn Name fn
_ List (Weighted (Binder fn)) as
Nil = Bool
False
  appearsIn Name fn
n (Weighted (Binder fn) a
x :> List (Weighted (Binder fn)) as1
xs) = forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
appearsIn Name fn
n Weighted (Binder fn) a
x Bool -> Bool -> Bool
|| forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
appearsIn Name fn
n List (Weighted (Binder fn)) as1
xs

instance {-# OVERLAPPABLE #-} (Foldable t, HasVariables f a) => HasVariables f (t a) where
  freeVars :: t a -> FreeVars f
freeVars = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars
  freeVarSet :: t a -> Set (Name f)
freeVarSet = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet
  countOf :: Name f -> t a -> Int
countOf Name f
n = forall a. Sum a -> a
Monoid.getSum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. a -> Sum a
Monoid.Sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf Name f
n)
  appearsIn :: Name f -> t a -> Bool
appearsIn Name f
n = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
appearsIn Name f
n)

instance HasVariables f a => HasVariables f (Set a) where
  freeVars :: Set a -> FreeVars f
freeVars = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars
  freeVarSet :: Set a -> Set (Name f)
freeVarSet = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet
  countOf :: Name f -> Set a -> Int
countOf Name f
n = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf Name f
n)
  appearsIn :: Name f -> Set a -> Bool
appearsIn Name f
n = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
appearsIn Name f
n)

------------------------------------------------------------------------
-- Substitutions
------------------------------------------------------------------------

type Subst fn = [SubstEntry fn]

data SubstEntry fn where
  (:=) :: HasSpec fn a => Var a -> Term fn a -> SubstEntry fn

backwardsSubstitution :: forall fn a. HasSpec fn a => Subst fn -> Term fn a -> Term fn a
backwardsSubstitution :: forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Subst fn -> Term fn a -> Term fn a
backwardsSubstitution Subst fn
sub Term fn a
t =
  case Subst fn -> Term fn a -> Maybe (Var a)
findMatch Subst fn
sub Term fn a
t of
    -- TODO: what about multiple matches??
    Just Var a
x -> forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Term fn a
V Var a
x
    Maybe (Var a)
Nothing -> case Term fn a
t of
      Lit a
a -> forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit a
a
      V Var a
x -> forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Term fn a
V Var a
x
      App fn as a
f List (Term fn) as
ts -> forall (a :: [*]) (fn :: [*] -> * -> *) b.
(Typeable a, TypeList a, All (HasSpec fn) a, HasSpec fn b,
 BaseUniverse fn) =>
fn a b -> List (Term fn) a -> Term fn b
App fn as a
f (forall {k} (c :: k -> Constraint) (as :: [k]) (f :: k -> *)
       (g :: k -> *).
All c as =>
(forall (a :: k). c a => f a -> g a) -> List f as -> List g as
mapListC @(HasSpec fn) (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Subst fn -> Term fn a -> Term fn a
backwardsSubstitution Subst fn
sub) List (Term fn) as
ts)
  where
    findMatch :: Subst fn -> Term fn a -> Maybe (Var a)
    findMatch :: Subst fn -> Term fn a -> Maybe (Var a)
findMatch [] Term fn a
_ = forall a. Maybe a
Nothing
    findMatch (Var a
x := Term fn a
t' : Subst fn
sub) Term fn a
t
      | forall (fn :: [*] -> * -> *) a b. Term fn a -> Term fn b -> Bool
fastInequality Term fn a
t Term fn a
t' = Subst fn -> Term fn a -> Maybe (Var a)
findMatch Subst fn
sub Term fn a
t
      | Just (Var a
x', Term fn a
t'') <- forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast (Var a
x, Term fn a
t')
      , Term fn a
t forall a. Eq a => a -> a -> Bool
== Term fn a
t'' =
          forall a. a -> Maybe a
Just Var a
x'
      | Bool
otherwise = Subst fn -> Term fn a -> Maybe (Var a)
findMatch Subst fn
sub Term fn a
t

-- | Sound but not complete inequality on terms
fastInequality :: Term fn a -> Term fn b -> Bool
fastInequality :: forall (fn :: [*] -> * -> *) a b. Term fn a -> Term fn b -> Bool
fastInequality (V (Var Int
i [Char]
_)) (V (Var Int
j [Char]
_)) = Int
i forall a. Eq a => a -> a -> Bool
/= Int
j
fastInequality Lit {} Lit {} = Bool
False
fastInequality (App fn as a
_ List (Term fn) as
as) (App fn as b
_ List (Term fn) as
bs) = forall (fn :: [*] -> * -> *) (as :: [*]) (bs :: [*]).
List (Term fn) as -> List (Term fn) bs -> Bool
go List (Term fn) as
as List (Term fn) as
bs
  where
    go :: List (Term fn) as -> List (Term fn) bs -> Bool
    go :: forall (fn :: [*] -> * -> *) (as :: [*]) (bs :: [*]).
List (Term fn) as -> List (Term fn) bs -> Bool
go List (Term fn) as
Nil List (Term fn) bs
Nil = Bool
False
    go (Term fn a
a :> List (Term fn) as1
as) (Term fn a
b :> List (Term fn) as1
bs) = forall (fn :: [*] -> * -> *) a b. Term fn a -> Term fn b -> Bool
fastInequality Term fn a
a Term fn a
b Bool -> Bool -> Bool
|| forall (fn :: [*] -> * -> *) (as :: [*]) (bs :: [*]).
List (Term fn) as -> List (Term fn) bs -> Bool
go List (Term fn) as1
as List (Term fn) as1
bs
    go List (Term fn) as
_ List (Term fn) bs
_ = Bool
True
fastInequality Term fn a
_ Term fn b
_ = Bool
True

substituteTerm :: forall fn a. Subst fn -> Term fn a -> Term fn a
substituteTerm :: forall (fn :: [*] -> * -> *) a. Subst fn -> Term fn a -> Term fn a
substituteTerm Subst fn
sub = \case
  Lit a
a -> forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit a
a
  V Var a
x -> HasSpec fn a => Subst fn -> Var a -> Term fn a
substVar Subst fn
sub Var a
x
  App fn as a
f (forall {k} (f :: k -> *) (g :: k -> *) (as :: [k]).
(forall (a :: k). f a -> g a) -> List f as -> List g as
mapList (forall (fn :: [*] -> * -> *) a. Subst fn -> Term fn a -> Term fn a
substituteTerm Subst fn
sub) -> List (Term fn) as
ts) ->
    case forall (fn :: [*] -> * -> *) (as :: [*]).
List (Term fn) as -> Maybe (List Value as)
fromLits List (Term fn) as
ts of
      Just List Value as
vs -> forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit (forall (ts :: [*]) (f :: * -> *) r.
TypeList ts =>
(forall a. f a -> a) -> FunTy ts r -> List f ts -> r
uncurryList_ forall a. Value a -> a
unValue (forall (fn :: [*] -> * -> *) (as :: [*]) b.
FunctionLike fn =>
fn as b -> FunTy as b
sem fn as a
f) List Value as
vs)
      Maybe (List Value as)
_ -> forall (a :: [*]) (fn :: [*] -> * -> *) b.
(Typeable a, TypeList a, All (HasSpec fn) a, HasSpec fn b,
 BaseUniverse fn) =>
fn a b -> List (Term fn) a -> Term fn b
App fn as a
f List (Term fn) as
ts
  where
    substVar :: HasSpec fn a => Subst fn -> Var a -> Term fn a
    substVar :: HasSpec fn a => Subst fn -> Var a -> Term fn a
substVar [] Var a
x = forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Term fn a
V Var a
x
    substVar (Var a
y := Term fn a
t : Subst fn
sub) Var a
x
      | Just a :~: a
Refl <- forall a a'.
(Typeable a, Typeable a') =>
Var a -> Var a' -> Maybe (a :~: a')
eqVar Var a
x Var a
y = Term fn a
t
      | Bool
otherwise = HasSpec fn a => Subst fn -> Var a -> Term fn a
substVar Subst fn
sub Var a
x

substituteTerm' :: forall fn a. Subst fn -> Term fn a -> Writer Any (Term fn a)
substituteTerm' :: forall (fn :: [*] -> * -> *) a.
Subst fn -> Term fn a -> Writer Any (Term fn a)
substituteTerm' Subst fn
sub = \case
  Lit a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit a
a
  V Var a
x -> HasSpec fn a => Subst fn -> Var a -> Writer Any (Term fn a)
substVar Subst fn
sub Var a
x
  App fn as a
f List (Term fn) as
ts ->
    forall (a :: [*]) (fn :: [*] -> * -> *) b.
(Typeable a, TypeList a, All (HasSpec fn) a, HasSpec fn b,
 BaseUniverse fn) =>
fn a b -> List (Term fn) a -> Term fn b
App fn as a
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (m :: * -> *) (f :: k -> *) (g :: k -> *) (as :: [k]).
Applicative m =>
(forall (a :: k). f a -> m (g a)) -> List f as -> m (List g as)
mapMList (forall (fn :: [*] -> * -> *) a.
Subst fn -> Term fn a -> Writer Any (Term fn a)
substituteTerm' Subst fn
sub) List (Term fn) as
ts
  where
    substVar :: HasSpec fn a => Subst fn -> Var a -> Writer Any (Term fn a)
    substVar :: HasSpec fn a => Subst fn -> Var a -> Writer Any (Term fn a)
substVar [] Var a
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Term fn a
V Var a
x
    substVar (Var a
y := Term fn a
t : Subst fn
sub) Var a
x
      | Just a :~: a
Refl <- forall a a'.
(Typeable a, Typeable a') =>
Var a -> Var a' -> Maybe (a :~: a')
eqVar Var a
x Var a
y = Term fn a
t forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Bool -> Any
Any Bool
True)
      | Bool
otherwise = HasSpec fn a => Subst fn -> Var a -> Writer Any (Term fn a)
substVar Subst fn
sub Var a
x

substituteBinder :: HasSpec fn a => Var a -> Term fn a -> Binder fn b -> Binder fn b
substituteBinder :: forall (fn :: [*] -> * -> *) a b.
HasSpec fn a =>
Var a -> Term fn a -> Binder fn b -> Binder fn b
substituteBinder Var a
x Term fn a
tm (Var b
y :-> Pred fn
p) = Var b
y' forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Binder fn a
:-> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> Pred fn -> Pred fn
substitutePred Var a
x Term fn a
tm Pred fn
p'
  where
    (Var b
y', Pred fn
p') =
      forall a t.
(Typeable a, Rename t) =>
Var a -> t -> Set Int -> (Var a, t)
freshen Var b
y Pred fn
p (forall a. a -> Set a
Set.singleton (forall a. Var a -> Int
nameOf Var a
x) forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) t. HasVariables fn t => t -> Set Int
freeVarNames Term fn a
tm forall a. Semigroup a => a -> a -> a
<> forall a. Ord a => a -> Set a -> Set a
Set.delete (forall a. Var a -> Int
nameOf Var b
y) (forall (fn :: [*] -> * -> *) t. HasVariables fn t => t -> Set Int
freeVarNames Pred fn
p))

substitutePred :: HasSpec fn a => Var a -> Term fn a -> Pred fn -> Pred fn
substitutePred :: forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> Pred fn -> Pred fn
substitutePred Var a
x Term fn a
tm = \case
  GenHint Hint a
h Term fn a
t -> forall (fn :: [*] -> * -> *) a.
HasGenHint fn a =>
Hint a -> Term fn a -> Pred fn
GenHint Hint a
h (forall (fn :: [*] -> * -> *) a. Subst fn -> Term fn a -> Term fn a
substituteTerm [Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> SubstEntry fn
:= Term fn a
tm] Term fn a
t)
  Subst Var a
x' Term fn a
t Pred fn
p -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> Pred fn -> Pred fn
substitutePred Var a
x Term fn a
tm forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> Pred fn -> Pred fn
substitutePred Var a
x' Term fn a
t Pred fn
p
  Assert Term fn Bool
t -> forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Term fn Bool -> Pred fn
Assert (forall (fn :: [*] -> * -> *) a. Subst fn -> Term fn a -> Term fn a
substituteTerm [Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> SubstEntry fn
:= Term fn a
tm] Term fn Bool
t)
  Block [Pred fn]
ps -> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> Pred fn -> Pred fn
substitutePred Var a
x Term fn a
tm forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pred fn]
ps)
  Exists (forall b. Term fn b -> b) -> GE a
k Binder fn a
b -> forall (fn :: [*] -> * -> *) a.
((forall b. Term fn b -> b) -> GE a) -> Binder fn a -> Pred fn
Exists (\forall b. Term fn b -> b
eval -> (forall b. Term fn b -> b) -> GE a
k (forall b. Term fn b -> b
eval forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fn :: [*] -> * -> *) a. Subst fn -> Term fn a -> Term fn a
substituteTerm [Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> SubstEntry fn
:= Term fn a
tm])) (forall (fn :: [*] -> * -> *) a b.
HasSpec fn a =>
Var a -> Term fn a -> Binder fn b -> Binder fn b
substituteBinder Var a
x Term fn a
tm Binder fn a
b)
  Let Term fn a
t Binder fn a
b -> forall (fn :: [*] -> * -> *) a. Term fn a -> Binder fn a -> Pred fn
Let (forall (fn :: [*] -> * -> *) a. Subst fn -> Term fn a -> Term fn a
substituteTerm [Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> SubstEntry fn
:= Term fn a
tm] Term fn a
t) (forall (fn :: [*] -> * -> *) a b.
HasSpec fn a =>
Var a -> Term fn a -> Binder fn b -> Binder fn b
substituteBinder Var a
x Term fn a
tm Binder fn a
b)
  ForAll Term fn t
t Binder fn a
b -> forall a b (fn :: [*] -> * -> *).
(Forallable a b, HasSpec fn a, HasSpec fn b) =>
Term fn a -> Binder fn b -> Pred fn
ForAll (forall (fn :: [*] -> * -> *) a. Subst fn -> Term fn a -> Term fn a
substituteTerm [Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> SubstEntry fn
:= Term fn a
tm] Term fn t
t) (forall (fn :: [*] -> * -> *) a b.
HasSpec fn a =>
Var a -> Term fn a -> Binder fn b -> Binder fn b
substituteBinder Var a
x Term fn a
tm Binder fn a
b)
  Case Term fn (SumOver as)
t List (Weighted (Binder fn)) as
bs -> forall (fn :: [*] -> * -> *) (a :: [*]).
HasSpec fn (SumOver a) =>
Term fn (SumOver a) -> List (Weighted (Binder fn)) a -> Pred fn
Case (forall (fn :: [*] -> * -> *) a. Subst fn -> Term fn a -> Term fn a
substituteTerm [Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> SubstEntry fn
:= Term fn a
tm] Term fn (SumOver as)
t) (forall {k} (f :: k -> *) (g :: k -> *) (as :: [k]).
(forall (a :: k). f a -> g a) -> List f as -> List g as
mapList (forall (f :: * -> *) a (g :: * -> *) b.
(f a -> g b) -> Weighted f a -> Weighted g b
mapWeighted forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a b.
HasSpec fn a =>
Var a -> Term fn a -> Binder fn b -> Binder fn b
substituteBinder Var a
x Term fn a
tm) List (Weighted (Binder fn)) as
bs)
  When Term fn Bool
b Pred fn
p -> forall (fn :: [*] -> * -> *).
HasSpec fn Bool =>
Term fn Bool -> Pred fn -> Pred fn
When (forall (fn :: [*] -> * -> *) a. Subst fn -> Term fn a -> Term fn a
substituteTerm [Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> SubstEntry fn
:= Term fn a
tm] Term fn Bool
b) (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> Pred fn -> Pred fn
substitutePred Var a
x Term fn a
tm Pred fn
p)
  Reifies Term fn b
t' Term fn a
t a -> b
f -> forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, HasSpec fn b) =>
Term fn b -> Term fn a -> (a -> b) -> Pred fn
Reifies (forall (fn :: [*] -> * -> *) a. Subst fn -> Term fn a -> Term fn a
substituteTerm [Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> SubstEntry fn
:= Term fn a
tm] Term fn b
t') (forall (fn :: [*] -> * -> *) a. Subst fn -> Term fn a -> Term fn a
substituteTerm [Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> SubstEntry fn
:= Term fn a
tm] Term fn a
t) a -> b
f
  DependsOn Term fn a
t Term fn b
t' -> forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, HasSpec fn b) =>
Term fn a -> Term fn b -> Pred fn
DependsOn (forall (fn :: [*] -> * -> *) a. Subst fn -> Term fn a -> Term fn a
substituteTerm [Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> SubstEntry fn
:= Term fn a
tm] Term fn a
t) (forall (fn :: [*] -> * -> *) a. Subst fn -> Term fn a -> Term fn a
substituteTerm [Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> SubstEntry fn
:= Term fn a
tm] Term fn b
t')
  Pred fn
TruePred -> forall (fn :: [*] -> * -> *). Pred fn
TruePred
  FalsePred NonEmpty [Char]
es -> forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn
FalsePred NonEmpty [Char]
es
  Monitor (forall b. Term fn b -> b) -> Property -> Property
m -> forall (fn :: [*] -> * -> *).
((forall a. Term fn a -> a) -> Property -> Property) -> Pred fn
Monitor (\forall b. Term fn b -> b
eval -> (forall b. Term fn b -> b) -> Property -> Property
m (forall b. Term fn b -> b
eval forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fn :: [*] -> * -> *) a. Subst fn -> Term fn a -> Term fn a
substituteTerm [Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> SubstEntry fn
:= Term fn a
tm]))
  Explain NonEmpty [Char]
es Pred fn
p -> forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn -> Pred fn
Explain NonEmpty [Char]
es forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> Pred fn -> Pred fn
substitutePred Var a
x Term fn a
tm Pred fn
p

instance Rename (Name f) where
  rename :: forall x. Typeable x => Var x -> Var x -> Name f -> Name f
rename Var x
v Var x
v' (Name Var a
v'') = forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Name fn
Name forall a b. (a -> b) -> a -> b
$ forall a x. (Rename a, Typeable x) => Var x -> Var x -> a -> a
rename Var x
v Var x
v' Var a
v''

instance Rename (Term fn a) where
  rename :: forall x. Typeable x => Var x -> Var x -> Term fn a -> Term fn a
rename Var x
v Var x
v'
    | Var x
v forall a. Eq a => a -> a -> Bool
== Var x
v' = forall a. a -> a
id
    | Bool
otherwise = \case
        Lit a
l -> forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit a
l
        V Var a
v'' -> forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Term fn a
V (forall a x. (Rename a, Typeable x) => Var x -> Var x -> a -> a
rename Var x
v Var x
v' Var a
v'')
        App fn as a
f List (Term fn) as
a -> forall (a :: [*]) (fn :: [*] -> * -> *) b.
(Typeable a, TypeList a, All (HasSpec fn) a, HasSpec fn b,
 BaseUniverse fn) =>
fn a b -> List (Term fn) a -> Term fn b
App fn as a
f (forall a x. (Rename a, Typeable x) => Var x -> Var x -> a -> a
rename Var x
v Var x
v' List (Term fn) as
a)

instance Rename (Pred fn) where
  rename :: forall x. Typeable x => Var x -> Var x -> Pred fn -> Pred fn
rename Var x
v Var x
v'
    | Var x
v forall a. Eq a => a -> a -> Bool
== Var x
v' = forall a. a -> a
id
    | Bool
otherwise = \case
        GenHint Hint a
h Term fn a
t -> forall (fn :: [*] -> * -> *) a.
HasGenHint fn a =>
Hint a -> Term fn a -> Pred fn
GenHint Hint a
h (forall a x. (Rename a, Typeable x) => Var x -> Var x -> a -> a
rename Var x
v Var x
v' Term fn a
t)
        Subst Var a
x Term fn a
t Pred fn
p -> forall a x. (Rename a, Typeable x) => Var x -> Var x -> a -> a
rename Var x
v Var x
v' forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> Pred fn -> Pred fn
substitutePred Var a
x Term fn a
t Pred fn
p
        Block [Pred fn]
ps -> forall (fn :: [*] -> * -> *). [Pred fn] -> Pred fn
Block (forall a x. (Rename a, Typeable x) => Var x -> Var x -> a -> a
rename Var x
v Var x
v' [Pred fn]
ps)
        Exists (forall b. Term fn b -> b) -> GE a
k Binder fn a
b -> forall (fn :: [*] -> * -> *) a.
((forall b. Term fn b -> b) -> GE a) -> Binder fn a -> Pred fn
Exists (\forall b. Term fn b -> b
eval -> (forall b. Term fn b -> b) -> GE a
k forall a b. (a -> b) -> a -> b
$ forall b. Term fn b -> b
eval forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. (Rename a, Typeable x) => Var x -> Var x -> a -> a
rename Var x
v Var x
v') (forall a x. (Rename a, Typeable x) => Var x -> Var x -> a -> a
rename Var x
v Var x
v' Binder fn a
b)
        Let Term fn a
t Binder fn a
b -> forall (fn :: [*] -> * -> *) a. Term fn a -> Binder fn a -> Pred fn
Let (forall a x. (Rename a, Typeable x) => Var x -> Var x -> a -> a
rename Var x
v Var x
v' Term fn a
t) (forall a x. (Rename a, Typeable x) => Var x -> Var x -> a -> a
rename Var x
v Var x
v' Binder fn a
b)
        Reifies Term fn b
t' Term fn a
t a -> b
f -> forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, HasSpec fn b) =>
Term fn b -> Term fn a -> (a -> b) -> Pred fn
Reifies (forall a x. (Rename a, Typeable x) => Var x -> Var x -> a -> a
rename Var x
v Var x
v' Term fn b
t') (forall a x. (Rename a, Typeable x) => Var x -> Var x -> a -> a
rename Var x
v Var x
v' Term fn a
t) a -> b
f
        Assert Term fn Bool
t -> forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Term fn Bool -> Pred fn
Assert (forall a x. (Rename a, Typeable x) => Var x -> Var x -> a -> a
rename Var x
v Var x
v' Term fn Bool
t)
        DependsOn Term fn a
x Term fn b
y -> forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, HasSpec fn b) =>
Term fn a -> Term fn b -> Pred fn
DependsOn (forall a x. (Rename a, Typeable x) => Var x -> Var x -> a -> a
rename Var x
v Var x
v' Term fn a
x) (forall a x. (Rename a, Typeable x) => Var x -> Var x -> a -> a
rename Var x
v Var x
v' Term fn b
y)
        ForAll Term fn t
set Binder fn a
b -> forall a b (fn :: [*] -> * -> *).
(Forallable a b, HasSpec fn a, HasSpec fn b) =>
Term fn a -> Binder fn b -> Pred fn
ForAll (forall a x. (Rename a, Typeable x) => Var x -> Var x -> a -> a
rename Var x
v Var x
v' Term fn t
set) (forall a x. (Rename a, Typeable x) => Var x -> Var x -> a -> a
rename Var x
v Var x
v' Binder fn a
b)
        Case Term fn (SumOver as)
t List (Weighted (Binder fn)) as
bs -> forall (fn :: [*] -> * -> *) (a :: [*]).
HasSpec fn (SumOver a) =>
Term fn (SumOver a) -> List (Weighted (Binder fn)) a -> Pred fn
Case (forall a x. (Rename a, Typeable x) => Var x -> Var x -> a -> a
rename Var x
v Var x
v' Term fn (SumOver as)
t) (forall a x. (Rename a, Typeable x) => Var x -> Var x -> a -> a
rename Var x
v Var x
v' List (Weighted (Binder fn)) as
bs)
        When Term fn Bool
b Pred fn
p -> forall (fn :: [*] -> * -> *).
HasSpec fn Bool =>
Term fn Bool -> Pred fn -> Pred fn
When (forall a x. (Rename a, Typeable x) => Var x -> Var x -> a -> a
rename Var x
v Var x
v' Term fn Bool
b) (forall a x. (Rename a, Typeable x) => Var x -> Var x -> a -> a
rename Var x
v Var x
v' Pred fn
p)
        Pred fn
TruePred -> forall (fn :: [*] -> * -> *). Pred fn
TruePred
        FalsePred NonEmpty [Char]
es -> forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn
FalsePred NonEmpty [Char]
es
        Monitor (forall b. Term fn b -> b) -> Property -> Property
m -> forall (fn :: [*] -> * -> *).
((forall a. Term fn a -> a) -> Property -> Property) -> Pred fn
Monitor (forall b. Term fn b -> b) -> Property -> Property
m
        Explain NonEmpty [Char]
es Pred fn
p -> forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn -> Pred fn
Explain NonEmpty [Char]
es (forall a x. (Rename a, Typeable x) => Var x -> Var x -> a -> a
rename Var x
v Var x
v' Pred fn
p)

instance Rename (Binder fn a) where
  rename :: forall x.
Typeable x =>
Var x -> Var x -> Binder fn a -> Binder fn a
rename Var x
v Var x
v' (Var a
va :-> Pred fn
psa) = Var a
va' forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Binder fn a
:-> forall a x. (Rename a, Typeable x) => Var x -> Var x -> a -> a
rename Var x
v Var x
v' Pred fn
psa'
    where
      (Var a
va', Pred fn
psa') = forall a t.
(Typeable a, Rename t) =>
Var a -> t -> Set Int -> (Var a, t)
freshen Var a
va Pred fn
psa (forall a. Ord a => [a] -> Set a
Set.fromList [forall a. Var a -> Int
nameOf Var x
v, forall a. Var a -> Int
nameOf Var x
v'] forall a. Semigroup a => a -> a -> a
<> forall a. Ord a => a -> Set a -> Set a
Set.delete (forall a. Var a -> Int
nameOf Var a
va) (forall (fn :: [*] -> * -> *) t. HasVariables fn t => t -> Set Int
freeVarNames Pred fn
psa))

instance Rename (f a) => Rename (Weighted f a) where
  rename :: forall x.
Typeable x =>
Var x -> Var x -> Weighted f a -> Weighted f a
rename Var x
v Var x
v' (Weighted Maybe Int
w f a
t) = forall (f :: * -> *) a. Maybe Int -> f a -> Weighted f a
Weighted Maybe Int
w (forall a x. (Rename a, Typeable x) => Var x -> Var x -> a -> a
rename Var x
v Var x
v' f a
t)

substTerm :: Env -> Term fn a -> Term fn a
substTerm :: forall (fn :: [*] -> * -> *) a. Env -> Term fn a -> Term fn a
substTerm Env
env = \case
  Lit a
a -> forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit a
a
  V Var a
v
    | Just a
a <- forall a. Typeable a => Env -> Var a -> Maybe a
lookupEnv Env
env Var a
v -> forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit a
a
    | Bool
otherwise -> forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Term fn a
V Var a
v
  App fn as a
f (forall {k} (f :: k -> *) (g :: k -> *) (as :: [k]).
(forall (a :: k). f a -> g a) -> List f as -> List g as
mapList (forall (fn :: [*] -> * -> *) a. Env -> Term fn a -> Term fn a
substTerm Env
env) -> List (Term fn) as
ts) ->
    case forall (fn :: [*] -> * -> *) (as :: [*]).
List (Term fn) as -> Maybe (List Value as)
fromLits List (Term fn) as
ts of
      Just List Value as
vs -> forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit (forall (ts :: [*]) (f :: * -> *) r.
TypeList ts =>
(forall a. f a -> a) -> FunTy ts r -> List f ts -> r
uncurryList_ forall a. Value a -> a
unValue (forall (fn :: [*] -> * -> *) (as :: [*]) b.
FunctionLike fn =>
fn as b -> FunTy as b
sem fn as a
f) List Value as
vs)
      Maybe (List Value as)
_ -> forall (a :: [*]) (fn :: [*] -> * -> *) b.
(Typeable a, TypeList a, All (HasSpec fn) a, HasSpec fn b,
 BaseUniverse fn) =>
fn a b -> List (Term fn) a -> Term fn b
App fn as a
f List (Term fn) as
ts

substBinder :: Env -> Binder fn a -> Binder fn a
substBinder :: forall (fn :: [*] -> * -> *) a. Env -> Binder fn a -> Binder fn a
substBinder Env
env (Var a
x :-> Pred fn
p) = Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Binder fn a
:-> forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Env -> Pred fn -> Pred fn
substPred (forall a. Var a -> Env -> Env
removeVar Var a
x Env
env) Pred fn
p

substPred :: BaseUniverse fn => Env -> Pred fn -> Pred fn
substPred :: forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Env -> Pred fn -> Pred fn
substPred Env
env = \case
  GenHint Hint a
h Term fn a
t -> forall (fn :: [*] -> * -> *) a.
HasGenHint fn a =>
Hint a -> Term fn a -> Pred fn
GenHint Hint a
h (forall (fn :: [*] -> * -> *) a. Env -> Term fn a -> Term fn a
substTerm Env
env Term fn a
t)
  Subst Var a
x Term fn a
t Pred fn
p -> forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Env -> Pred fn -> Pred fn
substPred Env
env forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> Pred fn -> Pred fn
substitutePred Var a
x Term fn a
t Pred fn
p
  Assert Term fn Bool
t -> forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Term fn Bool -> Pred fn
Assert (forall (fn :: [*] -> * -> *) a. Env -> Term fn a -> Term fn a
substTerm Env
env Term fn Bool
t)
  Reifies Term fn b
t' Term fn a
t a -> b
f -> forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, HasSpec fn b) =>
Term fn b -> Term fn a -> (a -> b) -> Pred fn
Reifies (forall (fn :: [*] -> * -> *) a. Env -> Term fn a -> Term fn a
substTerm Env
env Term fn b
t') (forall (fn :: [*] -> * -> *) a. Env -> Term fn a -> Term fn a
substTerm Env
env Term fn a
t) a -> b
f
  ForAll Term fn t
set Binder fn a
b -> forall a b (fn :: [*] -> * -> *).
(Forallable a b, HasSpec fn a, HasSpec fn b) =>
Term fn a -> Binder fn b -> Pred fn
ForAll (forall (fn :: [*] -> * -> *) a. Env -> Term fn a -> Term fn a
substTerm Env
env Term fn t
set) (forall (fn :: [*] -> * -> *) a. Env -> Binder fn a -> Binder fn a
substBinder Env
env Binder fn a
b)
  Case Term fn (SumOver as)
t List (Weighted (Binder fn)) as
bs -> forall (fn :: [*] -> * -> *) (a :: [*]).
HasSpec fn (SumOver a) =>
Term fn (SumOver a) -> List (Weighted (Binder fn)) a -> Pred fn
Case (forall (fn :: [*] -> * -> *) a. Env -> Term fn a -> Term fn a
substTerm Env
env Term fn (SumOver as)
t) (forall {k} (f :: k -> *) (g :: k -> *) (as :: [k]).
(forall (a :: k). f a -> g a) -> List f as -> List g as
mapList (forall (f :: * -> *) a (g :: * -> *) b.
(f a -> g b) -> Weighted f a -> Weighted g b
mapWeighted forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a. Env -> Binder fn a -> Binder fn a
substBinder Env
env) List (Weighted (Binder fn)) as
bs)
  When Term fn Bool
b Pred fn
p -> forall (fn :: [*] -> * -> *).
HasSpec fn Bool =>
Term fn Bool -> Pred fn -> Pred fn
When (forall (fn :: [*] -> * -> *) a. Env -> Term fn a -> Term fn a
substTerm Env
env Term fn Bool
b) (forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Env -> Pred fn -> Pred fn
substPred Env
env Pred fn
p)
  DependsOn Term fn a
x Term fn b
y -> forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, HasSpec fn b) =>
Term fn a -> Term fn b -> Pred fn
DependsOn (forall (fn :: [*] -> * -> *) a. Env -> Term fn a -> Term fn a
substTerm Env
env Term fn a
x) (forall (fn :: [*] -> * -> *) a. Env -> Term fn a -> Term fn a
substTerm Env
env Term fn b
y)
  Pred fn
TruePred -> forall (fn :: [*] -> * -> *). Pred fn
TruePred
  FalsePred NonEmpty [Char]
es -> forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn
FalsePred NonEmpty [Char]
es
  Block [Pred fn]
ps -> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Env -> Pred fn -> Pred fn
substPred Env
env forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pred fn]
ps)
  Exists (forall b. Term fn b -> b) -> GE a
k Binder fn a
b -> forall (fn :: [*] -> * -> *) a.
((forall b. Term fn b -> b) -> GE a) -> Binder fn a -> Pred fn
Exists (\forall b. Term fn b -> b
eval -> (forall b. Term fn b -> b) -> GE a
k forall a b. (a -> b) -> a -> b
$ forall b. Term fn b -> b
eval forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fn :: [*] -> * -> *) a. Env -> Term fn a -> Term fn a
substTerm Env
env) (forall (fn :: [*] -> * -> *) a. Env -> Binder fn a -> Binder fn a
substBinder Env
env Binder fn a
b)
  Let Term fn a
t Binder fn a
b -> forall (fn :: [*] -> * -> *) a. Term fn a -> Binder fn a -> Pred fn
Let (forall (fn :: [*] -> * -> *) a. Env -> Term fn a -> Term fn a
substTerm Env
env Term fn a
t) (forall (fn :: [*] -> * -> *) a. Env -> Binder fn a -> Binder fn a
substBinder Env
env Binder fn a
b)
  Monitor (forall b. Term fn b -> b) -> Property -> Property
m -> forall (fn :: [*] -> * -> *).
((forall a. Term fn a -> a) -> Property -> Property) -> Pred fn
Monitor (forall b. Term fn b -> b) -> Property -> Property
m
  Explain NonEmpty [Char]
es Pred fn
p -> forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn -> Pred fn
Explain NonEmpty [Char]
es forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Env -> Pred fn -> Pred fn
substPred Env
env Pred fn
p

unBind :: a -> Binder fn a -> Pred fn
unBind :: forall a (fn :: [*] -> * -> *). a -> Binder fn a -> Pred fn
unBind a
a (Var a
x :-> Pred fn
p) = forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Env -> Pred fn -> Pred fn
substPred (forall a. (Typeable a, Show a) => Var a -> a -> Env
singletonEnv Var a
x a
a) Pred fn
p

------------------------------------------------------------------------
-- Rewrite rules and simplification
------------------------------------------------------------------------

-- Simplification for preds and terms -------------------------------------

simplifyTerm :: forall fn a. BaseUniverse fn => Term fn a -> Term fn a
simplifyTerm :: forall (fn :: [*] -> * -> *) a.
BaseUniverse fn =>
Term fn a -> Term fn a
simplifyTerm = \case
  V Var a
v -> forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Term fn a
V Var a
v
  Lit a
l -> forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit a
l
  App fn as a
f (forall {k} (f :: k -> *) (g :: k -> *) (as :: [k]).
(forall (a :: k). f a -> g a) -> List f as -> List g as
mapList forall (fn :: [*] -> * -> *) a.
BaseUniverse fn =>
Term fn a -> Term fn a
simplifyTerm -> List (Term fn) as
ts)
    | Just List Value as
vs <- forall (fn :: [*] -> * -> *) (as :: [*]).
List (Term fn) as -> Maybe (List Value as)
fromLits List (Term fn) as
ts -> forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit forall a b. (a -> b) -> a -> b
$ forall (ts :: [*]) (f :: * -> *) r.
TypeList ts =>
(forall a. f a -> a) -> FunTy ts r -> List f ts -> r
uncurryList_ forall a. Value a -> a
unValue (forall (fn :: [*] -> * -> *) (as :: [*]) b.
FunctionLike fn =>
fn as b -> FunTy as b
sem fn as a
f) List Value as
vs
    | Just Term fn a
t <- forall (f :: [*] -> * -> *) (fn :: [*] -> * -> *) (as :: [*]) b.
(Functions f fn, TypeList as, Typeable as, HasSpec fn b,
 All (HasSpec fn) as) =>
f as b -> List (Term fn) as -> Maybe (Term fn b)
rewriteRules fn as a
f List (Term fn) as
ts -> forall (fn :: [*] -> * -> *) a.
BaseUniverse fn =>
Term fn a -> Term fn a
simplifyTerm Term fn a
t
    | Bool
otherwise -> forall (a :: [*]) (fn :: [*] -> * -> *) b.
(Typeable a, TypeList a, All (HasSpec fn) a, HasSpec fn b,
 BaseUniverse fn) =>
fn a b -> List (Term fn) a -> Term fn b
App fn as a
f List (Term fn) as
ts

fromLits :: List (Term fn) as -> Maybe (List Value as)
fromLits :: forall (fn :: [*] -> * -> *) (as :: [*]).
List (Term fn) as -> Maybe (List Value as)
fromLits = forall {k} (m :: * -> *) (f :: k -> *) (g :: k -> *) (as :: [k]).
Applicative m =>
(forall (a :: k). f a -> m (g a)) -> List f as -> m (List g as)
mapMList forall (fn :: [*] -> * -> *) a. Term fn a -> Maybe (Value a)
fromLit

fromLit :: Term fn a -> Maybe (Value a)
fromLit :: forall (fn :: [*] -> * -> *) a. Term fn a -> Maybe (Value a)
fromLit (Lit a
l) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Value a
Value a
l
fromLit Term fn a
_ = forall a. Maybe a
Nothing

isLit :: Term fn a -> Bool
isLit :: forall (fn :: [*] -> * -> *) a. Term fn a -> Bool
isLit = forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fn :: [*] -> * -> *) a. Term fn a -> Maybe (Value a)
fromLit

simplifyPred :: forall fn. BaseUniverse fn => Pred fn -> Pred fn
simplifyPred :: forall (fn :: [*] -> * -> *). BaseUniverse fn => Pred fn -> Pred fn
simplifyPred = \case
  -- If the term simplifies away to a literal, that means there is no
  -- more generation to do so we can get rid of `GenHint`
  GenHint Hint a
h Term fn a
t -> case forall (fn :: [*] -> * -> *) a.
BaseUniverse fn =>
Term fn a -> Term fn a
simplifyTerm Term fn a
t of
    Lit {} -> forall (fn :: [*] -> * -> *). Pred fn
TruePred
    Term fn a
t' -> forall (fn :: [*] -> * -> *) a.
HasGenHint fn a =>
Hint a -> Term fn a -> Pred fn
GenHint Hint a
h Term fn a
t'
  Subst Var a
x Term fn a
t Pred fn
p -> forall (fn :: [*] -> * -> *). BaseUniverse fn => Pred fn -> Pred fn
simplifyPred forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> Pred fn -> Pred fn
substitutePred Var a
x Term fn a
t Pred fn
p
  Assert Term fn Bool
t -> forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Term fn Bool -> Pred fn
Assert forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
BaseUniverse fn =>
Term fn a -> Term fn a
simplifyTerm Term fn Bool
t
  Reifies Term fn b
t' Term fn a
t a -> b
f -> case forall (fn :: [*] -> * -> *) a.
BaseUniverse fn =>
Term fn a -> Term fn a
simplifyTerm Term fn a
t of
    Lit a
a -> forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
p -> Pred fn
assert forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
BaseUniverse fn =>
Term fn a -> Term fn a
simplifyTerm Term fn b
t' forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Term fn a -> Term fn Bool
==. forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit (a -> b
f a
a)
    Term fn a
t'' -> forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, HasSpec fn b) =>
Term fn b -> Term fn a -> (a -> b) -> Pred fn
Reifies (forall (fn :: [*] -> * -> *) a.
BaseUniverse fn =>
Term fn a -> Term fn a
simplifyTerm Term fn b
t') Term fn a
t'' a -> b
f
  ForAll Term fn t
set Binder fn a
b -> case forall (fn :: [*] -> * -> *) a.
BaseUniverse fn =>
Term fn a -> Term fn a
simplifyTerm Term fn t
set of
    Lit t
as -> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a (fn :: [*] -> * -> *). a -> Binder fn a -> Pred fn
`unBind` Binder fn a
b) (forall t e. Forallable t e => t -> [e]
forAllToList t
as)
    App (forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fnU as b -> Maybe (fn as b)
extractFn @(SetFn fn) @fn -> Just SetFn fn as t
Union) (Term fn a
xs :> Term fn a
ys :> List (Term fn) as1
Nil) ->
      let b' :: Binder fn a
b' = forall (fn :: [*] -> * -> *) a. Binder fn a -> Binder fn a
simplifyBinder Binder fn a
b
       in forall a b (fn :: [*] -> * -> *).
(Forallable a b, HasSpec fn a, HasSpec fn b) =>
Term fn a -> Binder fn b -> Pred fn
mkForAll Term fn a
xs Binder fn a
b' forall a. Semigroup a => a -> a -> a
<> forall a b (fn :: [*] -> * -> *).
(Forallable a b, HasSpec fn a, HasSpec fn b) =>
Term fn a -> Binder fn b -> Pred fn
mkForAll Term fn a
ys Binder fn a
b'
    Term fn t
set' -> case forall (fn :: [*] -> * -> *) a. Binder fn a -> Binder fn a
simplifyBinder Binder fn a
b of
      Var a
_ :-> Pred fn
TruePred -> forall (fn :: [*] -> * -> *). Pred fn
TruePred
      Binder fn a
b' -> forall a b (fn :: [*] -> * -> *).
(Forallable a b, HasSpec fn a, HasSpec fn b) =>
Term fn a -> Binder fn b -> Pred fn
ForAll Term fn t
set' Binder fn a
b'
  DependsOn Term fn a
_ Lit {} -> forall (fn :: [*] -> * -> *). Pred fn
TruePred
  DependsOn Lit {} Term fn b
_ -> forall (fn :: [*] -> * -> *). Pred fn
TruePred
  DependsOn Term fn a
x Term fn b
y -> forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, HasSpec fn b) =>
Term fn a -> Term fn b -> Pred fn
DependsOn Term fn a
x Term fn b
y
  Case Term fn (SumOver as)
t List (Weighted (Binder fn)) as
bs -> forall (fn :: [*] -> * -> *) (a :: [*]).
HasSpec fn (SumOver a) =>
Term fn (SumOver a) -> List (Weighted (Binder fn)) a -> Pred fn
mkCase (forall (fn :: [*] -> * -> *) a.
BaseUniverse fn =>
Term fn a -> Term fn a
simplifyTerm Term fn (SumOver as)
t) (forall {k} (f :: k -> *) (g :: k -> *) (as :: [k]).
(forall (a :: k). f a -> g a) -> List f as -> List g as
mapList (forall (f :: * -> *) a (g :: * -> *) b.
(f a -> g b) -> Weighted f a -> Weighted g b
mapWeighted forall (fn :: [*] -> * -> *) a. Binder fn a -> Binder fn a
simplifyBinder) List (Weighted (Binder fn)) as
bs)
  When Term fn Bool
b Pred fn
p -> forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
Term fn Bool -> p -> Pred fn
whenTrue (forall (fn :: [*] -> * -> *) a.
BaseUniverse fn =>
Term fn a -> Term fn a
simplifyTerm Term fn Bool
b) (forall (fn :: [*] -> * -> *). BaseUniverse fn => Pred fn -> Pred fn
simplifyPred Pred fn
p)
  Pred fn
TruePred -> forall (fn :: [*] -> * -> *). Pred fn
TruePred
  FalsePred NonEmpty [Char]
es -> forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn
FalsePred NonEmpty [Char]
es
  Block [Pred fn]
ps -> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
[Pred fn] -> [Pred fn]
simplifyPreds [Pred fn]
ps)
  Let Term fn a
t Binder fn a
b -> case forall (fn :: [*] -> * -> *) a.
BaseUniverse fn =>
Term fn a -> Term fn a
simplifyTerm Term fn a
t of
    t' :: Term fn a
t'@App {} -> forall (fn :: [*] -> * -> *) a. Term fn a -> Binder fn a -> Pred fn
Let Term fn a
t' (forall (fn :: [*] -> * -> *) a. Binder fn a -> Binder fn a
simplifyBinder Binder fn a
b)
    -- Variable or literal
    Term fn a
t' | Var a
x :-> Pred fn
p <- Binder fn a
b -> forall (fn :: [*] -> * -> *). BaseUniverse fn => Pred fn -> Pred fn
simplifyPred forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> Pred fn -> Pred fn
substitutePred Var a
x Term fn a
t' Pred fn
p
  Exists (forall b. Term fn b -> b) -> GE a
k Binder fn a
b -> case forall (fn :: [*] -> * -> *) a. Binder fn a -> Binder fn a
simplifyBinder Binder fn a
b of
    Var a
_ :-> Pred fn
TruePred -> forall (fn :: [*] -> * -> *). Pred fn
TruePred
    -- This is to get rid of exisentials like:
    -- `constrained $ \ x -> exists $ \ y -> [x ==. y, y + 2 <. 10]`
    Var a
x :-> Pred fn
p | Just Term fn a
t <- forall (fn :: [*] -> * -> *) a.
(BaseUniverse fn, Typeable a) =>
Var a -> Pred fn -> Maybe (Term fn a)
pinnedBy Var a
x Pred fn
p -> forall (fn :: [*] -> * -> *). BaseUniverse fn => Pred fn -> Pred fn
simplifyPred forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> Pred fn -> Pred fn
substitutePred Var a
x Term fn a
t Pred fn
p
    Binder fn a
b' -> forall (fn :: [*] -> * -> *) a.
((forall b. Term fn b -> b) -> GE a) -> Binder fn a -> Pred fn
Exists (forall b. Term fn b -> b) -> GE a
k Binder fn a
b'
  Monitor {} -> forall (fn :: [*] -> * -> *). Pred fn
TruePred
  -- TODO: This is a bit questionable. On the one hand we could get rid of `Explain` here
  -- and just return `simplifyPred p` but doing so risks missing explanations when things
  -- do go wrong.
  Explain NonEmpty [Char]
es Pred fn
p -> forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn -> Pred fn
explanation NonEmpty [Char]
es forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *). BaseUniverse fn => Pred fn -> Pred fn
simplifyPred Pred fn
p

simplifyPreds :: BaseUniverse fn => [Pred fn] -> [Pred fn]
simplifyPreds :: forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
[Pred fn] -> [Pred fn]
simplifyPreds = forall {fn :: [*] -> * -> *}. [Pred fn] -> [Pred fn] -> [Pred fn]
go [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall (fn :: [*] -> * -> *). BaseUniverse fn => Pred fn -> Pred fn
simplifyPred
  where
    go :: [Pred fn] -> [Pred fn] -> [Pred fn]
go [Pred fn]
acc [] = forall a. [a] -> [a]
reverse [Pred fn]
acc
    go [Pred fn]
_ (FalsePred NonEmpty [Char]
err : [Pred fn]
_) = [forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn
FalsePred NonEmpty [Char]
err]
    go [Pred fn]
acc (Pred fn
TruePred : [Pred fn]
ps) = [Pred fn] -> [Pred fn] -> [Pred fn]
go [Pred fn]
acc [Pred fn]
ps
    go [Pred fn]
acc (Pred fn
p : [Pred fn]
ps) = [Pred fn] -> [Pred fn] -> [Pred fn]
go (Pred fn
p forall a. a -> [a] -> [a]
: [Pred fn]
acc) [Pred fn]
ps

simplifyBinder :: Binder fn a -> Binder fn a
simplifyBinder :: forall (fn :: [*] -> * -> *) a. Binder fn a -> Binder fn a
simplifyBinder (Var a
x :-> Pred fn
p) = Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Binder fn a
:-> forall (fn :: [*] -> * -> *). BaseUniverse fn => Pred fn -> Pred fn
simplifyPred Pred fn
p

-- Arcane magic -----------------------------------------------------------

-- | Is the variable x pinned to some free term in p? (free term
-- meaning that all the variables in the term are free in p).
--
-- TODO: complete this with more cases!
pinnedBy :: forall fn a. (BaseUniverse fn, Typeable a) => Var a -> Pred fn -> Maybe (Term fn a)
pinnedBy :: forall (fn :: [*] -> * -> *) a.
(BaseUniverse fn, Typeable a) =>
Var a -> Pred fn -> Maybe (Term fn a)
pinnedBy Var a
x (Assert (App (forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fnU as b -> Maybe (fn as b)
extractFn @(EqFn fn) @fn -> Just EqFn fn as Bool
Equal) (Term fn a
t :> Term fn a
t' :> List (Term fn) as1
Nil)))
  | V Var a
x' <- Term fn a
t, Just a :~: a
Refl <- forall a a'.
(Typeable a, Typeable a') =>
Var a -> Var a' -> Maybe (a :~: a')
eqVar Var a
x Var a
x' = forall a. a -> Maybe a
Just Term fn a
t'
  | V Var a
x' <- Term fn a
t', Just a :~: a
Refl <- forall a a'.
(Typeable a, Typeable a') =>
Var a -> Var a' -> Maybe (a :~: a')
eqVar Var a
x Var a
x' = forall a. a -> Maybe a
Just Term fn a
t
pinnedBy Var a
x (Block [Pred fn]
ps) = forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (fn :: [*] -> * -> *) a.
(BaseUniverse fn, Typeable a) =>
Var a -> Pred fn -> Maybe (Term fn a)
pinnedBy Var a
x) [Pred fn]
ps
pinnedBy Var a
_ Pred fn
_ = forall a. Maybe a
Nothing

-- TODO: it might be necessary to run aggressiveInlining again after the let floating etc.
optimisePred :: BaseUniverse fn => Pred fn -> Pred fn
optimisePred :: forall (fn :: [*] -> * -> *). BaseUniverse fn => Pred fn -> Pred fn
optimisePred Pred fn
p =
  forall (fn :: [*] -> * -> *). BaseUniverse fn => Pred fn -> Pred fn
simplifyPred
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fn :: [*] -> * -> *). BaseUniverse fn => Pred fn -> Pred fn
letSubexpressionElimination
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fn :: [*] -> * -> *). BaseUniverse fn => Pred fn -> Pred fn
letFloating
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fn :: [*] -> * -> *). BaseUniverse fn => Pred fn -> Pred fn
aggressiveInlining
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fn :: [*] -> * -> *). BaseUniverse fn => Pred fn -> Pred fn
simplifyPred
    forall a b. (a -> b) -> a -> b
$ Pred fn
p

-- Common subexpression elimination but only on terms that are already let-bound.
letSubexpressionElimination :: BaseUniverse fn => Pred fn -> Pred fn
letSubexpressionElimination :: forall (fn :: [*] -> * -> *). BaseUniverse fn => Pred fn -> Pred fn
letSubexpressionElimination = forall {fn :: [*] -> * -> *}. Subst fn -> Pred fn -> Pred fn
go []
  where
    adjustSub :: Var a -> [SubstEntry fn] -> [SubstEntry fn]
adjustSub Var a
x [SubstEntry fn]
sub =
      [ Var a
x' forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> SubstEntry fn
:= Term fn a
t
      | Var a
x' := Term fn a
t <- [SubstEntry fn]
sub
      , forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ forall a a'.
(Typeable a, Typeable a') =>
Var a -> Var a' -> Maybe (a :~: a')
eqVar Var a
x Var a
x'
      , -- TODO: possibly freshen the binder where
      -- `x` appears instead?
      Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Name fn
Name Var a
x forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
`appearsIn` Term fn a
t
      ]

    goBinder :: Subst fn -> Binder fn a -> Binder fn a
    goBinder :: forall (fn :: [*] -> * -> *) a.
Subst fn -> Binder fn a -> Binder fn a
goBinder Subst fn
sub (Var a
x :-> Pred fn
p) = Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Binder fn a
:-> forall {fn :: [*] -> * -> *}. Subst fn -> Pred fn -> Pred fn
go (forall {a} {fn :: [*] -> * -> *}.
HasSpec fn a =>
Var a -> [SubstEntry fn] -> [SubstEntry fn]
adjustSub Var a
x Subst fn
sub) Pred fn
p

    go :: Subst fn -> Pred fn -> Pred fn
go Subst fn
sub = \case
      GenHint Hint a
h Term fn a
t -> forall (fn :: [*] -> * -> *) a.
HasGenHint fn a =>
Hint a -> Term fn a -> Pred fn
GenHint Hint a
h (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Subst fn -> Term fn a -> Term fn a
backwardsSubstitution Subst fn
sub Term fn a
t)
      Block [Pred fn]
ps -> forall (fn :: [*] -> * -> *). [Pred fn] -> Pred fn
Block (Subst fn -> Pred fn -> Pred fn
go Subst fn
sub forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pred fn]
ps)
      Let Term fn a
t (Var a
x :-> Pred fn
p) -> forall (fn :: [*] -> * -> *) a. Term fn a -> Binder fn a -> Pred fn
Let Term fn a
t' (Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Binder fn a
:-> Subst fn -> Pred fn -> Pred fn
go (Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> SubstEntry fn
:= Term fn a
t' forall a. a -> [a] -> [a]
: Subst fn
sub') Pred fn
p)
        where
          t' :: Term fn a
t' = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Subst fn -> Term fn a -> Term fn a
backwardsSubstitution Subst fn
sub Term fn a
t
          sub' :: Subst fn
sub' = forall {a} {fn :: [*] -> * -> *}.
HasSpec fn a =>
Var a -> [SubstEntry fn] -> [SubstEntry fn]
adjustSub Var a
x Subst fn
sub
      Exists (forall b. Term fn b -> b) -> GE a
k Binder fn a
b -> forall (fn :: [*] -> * -> *) a.
((forall b. Term fn b -> b) -> GE a) -> Binder fn a -> Pred fn
Exists (forall b. Term fn b -> b) -> GE a
k (forall (fn :: [*] -> * -> *) a.
Subst fn -> Binder fn a -> Binder fn a
goBinder Subst fn
sub Binder fn a
b)
      Subst Var a
x Term fn a
t Pred fn
p -> Subst fn -> Pred fn -> Pred fn
go Subst fn
sub (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> Pred fn -> Pred fn
substitutePred Var a
x Term fn a
t Pred fn
p)
      Assert Term fn Bool
t -> forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Term fn Bool -> Pred fn
Assert (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Subst fn -> Term fn a -> Term fn a
backwardsSubstitution Subst fn
sub Term fn Bool
t)
      Reifies Term fn b
t' Term fn a
t a -> b
f -> forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, HasSpec fn b) =>
Term fn b -> Term fn a -> (a -> b) -> Pred fn
Reifies (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Subst fn -> Term fn a -> Term fn a
backwardsSubstitution Subst fn
sub Term fn b
t') (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Subst fn -> Term fn a -> Term fn a
backwardsSubstitution Subst fn
sub Term fn a
t) a -> b
f
      -- NOTE: this is a tricky case. One possible thing to do here is to keep the old `DependsOn t t'`
      -- and have the new DependsOn if `backwardsSubstitution` changed something. With this semantics you
      -- risk running into unintuitive behaviour if you have something like:
      -- ```
      -- let x = y + z in
      --  {y + z `dependsOn` w
      --   assert $ w <. y + 2
      --   ...}
      -- ```
      -- This will be rewritten as:
      -- ```
      -- let x = y + z in
      --  {z `dependsOn` w
      --   assert $ w <. y + 2
      --   ...}
      -- ```
      -- which changes the dependency order of `w` and `y`. However, fixing
      -- this behaviour in turn makes it more difficult to detect when
      -- variables are no longer used after being substituted away - which
      -- blocks some other optimizations. As we strongly encourage users not to
      -- use `letBind` in their own code most users will never encounter this issue
      -- so the tradeoff is probably worth it.
      DependsOn Term fn a
t Term fn b
t' -> forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, HasSpec fn b) =>
Term fn a -> Term fn b -> Pred fn
DependsOn (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Subst fn -> Term fn a -> Term fn a
backwardsSubstitution Subst fn
sub Term fn a
t) (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Subst fn -> Term fn a -> Term fn a
backwardsSubstitution Subst fn
sub Term fn b
t')
      ForAll Term fn t
t Binder fn a
b -> forall a b (fn :: [*] -> * -> *).
(Forallable a b, HasSpec fn a, HasSpec fn b) =>
Term fn a -> Binder fn b -> Pred fn
ForAll (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Subst fn -> Term fn a -> Term fn a
backwardsSubstitution Subst fn
sub Term fn t
t) (forall (fn :: [*] -> * -> *) a.
Subst fn -> Binder fn a -> Binder fn a
goBinder Subst fn
sub Binder fn a
b)
      Case Term fn (SumOver as)
t List (Weighted (Binder fn)) as
bs -> forall (fn :: [*] -> * -> *) (a :: [*]).
HasSpec fn (SumOver a) =>
Term fn (SumOver a) -> List (Weighted (Binder fn)) a -> Pred fn
Case (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Subst fn -> Term fn a -> Term fn a
backwardsSubstitution Subst fn
sub Term fn (SumOver as)
t) (forall {k} (f :: k -> *) (g :: k -> *) (as :: [k]).
(forall (a :: k). f a -> g a) -> List f as -> List g as
mapList (forall (f :: * -> *) a (g :: * -> *) b.
(f a -> g b) -> Weighted f a -> Weighted g b
mapWeighted forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
Subst fn -> Binder fn a -> Binder fn a
goBinder Subst fn
sub) List (Weighted (Binder fn)) as
bs)
      When Term fn Bool
b Pred fn
p -> forall (fn :: [*] -> * -> *).
HasSpec fn Bool =>
Term fn Bool -> Pred fn -> Pred fn
When (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Subst fn -> Term fn a -> Term fn a
backwardsSubstitution Subst fn
sub Term fn Bool
b) (Subst fn -> Pred fn -> Pred fn
go Subst fn
sub Pred fn
p)
      Pred fn
TruePred -> forall (fn :: [*] -> * -> *). Pred fn
TruePred
      FalsePred NonEmpty [Char]
es -> forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn
FalsePred NonEmpty [Char]
es
      Monitor (forall b. Term fn b -> b) -> Property -> Property
m -> forall (fn :: [*] -> * -> *).
((forall a. Term fn a -> a) -> Property -> Property) -> Pred fn
Monitor (forall b. Term fn b -> b) -> Property -> Property
m
      Explain NonEmpty [Char]
es Pred fn
p -> forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn -> Pred fn
Explain NonEmpty [Char]
es forall a b. (a -> b) -> a -> b
$ Subst fn -> Pred fn -> Pred fn
go Subst fn
sub Pred fn
p

-- TODO: this can probably be cleaned up and generalized along with generalizing
-- to make sure we float lets in some missing cases.
letFloating :: BaseUniverse fn => Pred fn -> Pred fn
letFloating :: forall (fn :: [*] -> * -> *). BaseUniverse fn => Pred fn -> Pred fn
letFloating = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {fn :: [*] -> * -> *}.
(Functions fn fn,
 IsMember (EqFn fn) fn (FromJust (MPath (EqFn fn) fn)),
 IsMember (SetFn fn) fn (FromJust (MPath (SetFn fn) fn)),
 IsMember (BoolFn fn) fn (FromJust (MPath (BoolFn fn) fn)),
 IsMember (PairFn fn) fn (FromJust (MPath (PairFn fn) fn)),
 IsMember (IntFn fn) fn (FromJust (MPath (IntFn fn) fn)),
 IsMember (OrdFn fn) fn (FromJust (MPath (OrdFn fn) fn)),
 IsMember (GenericsFn fn) fn (FromJust (MPath (GenericsFn fn) fn)),
 IsMember (ListFn fn) fn (FromJust (MPath (ListFn fn) fn)),
 IsMember (SumFn fn) fn (FromJust (MPath (SumFn fn) fn)),
 IsMember (MapFn fn) fn (FromJust (MPath (MapFn fn) fn)),
 IsMember (FunFn fn) fn (FromJust (MPath (FunFn fn) fn)),
 IsMember (SizeFn fn) fn (FromJust (MPath (SizeFn fn) fn))) =>
[Pred fn] -> Pred fn -> [Pred fn]
go []
  where
    goBlock :: [Pred fn] -> [Pred fn] -> [Pred fn]
goBlock [Pred fn]
ctx [Pred fn]
ps = forall {fn :: [*] -> * -> *}.
Set Int -> [Pred fn] -> [Pred fn] -> [Pred fn]
goBlock' (forall (fn :: [*] -> * -> *) t. HasVariables fn t => t -> Set Int
freeVarNames [Pred fn]
ctx forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) t. HasVariables fn t => t -> Set Int
freeVarNames [Pred fn]
ps) [Pred fn]
ctx [Pred fn]
ps

    goBlock' :: Set Int -> [Pred fn] -> [Pred fn] -> [Pred fn]
goBlock' Set Int
_ [Pred fn]
ctx [] = [Pred fn]
ctx
    goBlock' Set Int
fvs [Pred fn]
ctx (Let Term fn a
t (Var a
x :-> Pred fn
p) : [Pred fn]
ps) =
      -- We can do `goBlock'` here because we've already done let floating
      -- on the inner `p`
      [forall (fn :: [*] -> * -> *) a. Term fn a -> Binder fn a -> Pred fn
Let Term fn a
t (Var a
x' forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Binder fn a
:-> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Set Int -> [Pred fn] -> [Pred fn] -> [Pred fn]
goBlock' (forall a. Ord a => a -> Set a -> Set a
Set.insert (forall a. Var a -> Int
nameOf Var a
x') Set Int
fvs) [Pred fn]
ctx (Pred fn
p' forall a. a -> [a] -> [a]
: [Pred fn]
ps)))]
      where
        (Var a
x', Pred fn
p') = forall a t.
(Typeable a, Rename t) =>
Var a -> t -> Set Int -> (Var a, t)
freshen Var a
x Pred fn
p Set Int
fvs
    goBlock' Set Int
fvs [Pred fn]
ctx (Block [Pred fn]
ps : [Pred fn]
ps') = Set Int -> [Pred fn] -> [Pred fn] -> [Pred fn]
goBlock' Set Int
fvs [Pred fn]
ctx ([Pred fn]
ps forall a. [a] -> [a] -> [a]
++ [Pred fn]
ps')
    goBlock' Set Int
fvs [Pred fn]
ctx (Pred fn
p : [Pred fn]
ps) = Set Int -> [Pred fn] -> [Pred fn] -> [Pred fn]
goBlock' Set Int
fvs (Pred fn
p forall a. a -> [a] -> [a]
: [Pred fn]
ctx) [Pred fn]
ps

    goExists ::
      HasSpec fn a =>
      [Pred fn] ->
      (Binder fn a -> Pred fn) ->
      Var a ->
      Pred fn ->
      [Pred fn]
    goExists :: forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
[Pred fn]
-> (Binder fn a -> Pred fn) -> Var a -> Pred fn -> [Pred fn]
goExists [Pred fn]
ctx Binder fn a -> Pred fn
ex Var a
x (Let Term fn a
t (Var a
y :-> Pred fn
p))
      | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Name fn
Name Var a
x forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
`appearsIn` Term fn a
t =
          let (Var a
y', Pred fn
p') = forall a t.
(Typeable a, Rename t) =>
Var a -> t -> Set Int -> (Var a, t)
freshen Var a
y Pred fn
p (forall a. Ord a => a -> Set a -> Set a
Set.insert (forall a. Var a -> Int
nameOf Var a
x) forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) t. HasVariables fn t => t -> Set Int
freeVarNames Pred fn
p forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) t. HasVariables fn t => t -> Set Int
freeVarNames Term fn a
t)
           in forall {fn :: [*] -> * -> *}.
(Functions fn fn,
 IsMember (EqFn fn) fn (FromJust (MPath (EqFn fn) fn)),
 IsMember (SetFn fn) fn (FromJust (MPath (SetFn fn) fn)),
 IsMember (BoolFn fn) fn (FromJust (MPath (BoolFn fn) fn)),
 IsMember (PairFn fn) fn (FromJust (MPath (PairFn fn) fn)),
 IsMember (IntFn fn) fn (FromJust (MPath (IntFn fn) fn)),
 IsMember (OrdFn fn) fn (FromJust (MPath (OrdFn fn) fn)),
 IsMember (GenericsFn fn) fn (FromJust (MPath (GenericsFn fn) fn)),
 IsMember (ListFn fn) fn (FromJust (MPath (ListFn fn) fn)),
 IsMember (SumFn fn) fn (FromJust (MPath (SumFn fn) fn)),
 IsMember (MapFn fn) fn (FromJust (MPath (MapFn fn) fn)),
 IsMember (FunFn fn) fn (FromJust (MPath (FunFn fn) fn)),
 IsMember (SizeFn fn) fn (FromJust (MPath (SizeFn fn) fn))) =>
[Pred fn] -> Pred fn -> [Pred fn]
go [Pred fn]
ctx (forall (fn :: [*] -> * -> *) a. Term fn a -> Binder fn a -> Pred fn
Let Term fn a
t (Var a
y' forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Binder fn a
:-> Binder fn a -> Pred fn
ex (Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Binder fn a
:-> Pred fn
p')))
    goExists [Pred fn]
ctx Binder fn a -> Pred fn
ex Var a
x Pred fn
p = Binder fn a -> Pred fn
ex (Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Binder fn a
:-> Pred fn
p) forall a. a -> [a] -> [a]
: [Pred fn]
ctx

    pushExplain :: NonEmpty [Char] -> Pred fn -> Pred fn
pushExplain NonEmpty [Char]
es (Let Term fn a
t (Var a
x :-> Pred fn
p)) = forall (fn :: [*] -> * -> *) a. Term fn a -> Binder fn a -> Pred fn
Let Term fn a
t (Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Binder fn a
:-> NonEmpty [Char] -> Pred fn -> Pred fn
pushExplain NonEmpty [Char]
es Pred fn
p)
    pushExplain NonEmpty [Char]
es (Block [Pred fn]
ps) = forall (fn :: [*] -> * -> *). [Pred fn] -> Pred fn
Block (NonEmpty [Char] -> Pred fn -> Pred fn
pushExplain NonEmpty [Char]
es forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pred fn]
ps)
    pushExplain NonEmpty [Char]
es (Exists (forall b. Term fn b -> b) -> GE a
k (Var a
x :-> Pred fn
p)) =
      forall (fn :: [*] -> * -> *) a.
((forall b. Term fn b -> b) -> GE a) -> Binder fn a -> Pred fn
Exists (forall (fn :: [*] -> * -> *) a.
((forall b. Term fn b -> b) -> GE a)
-> (forall b. Term fn b -> b) -> GE a
explainSemantics (forall b. Term fn b -> b) -> GE a
k) (Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Binder fn a
:-> NonEmpty [Char] -> Pred fn -> Pred fn
pushExplain NonEmpty [Char]
es Pred fn
p)
      where
        -- TODO: Unfortunately this is necessary on ghc 8.10.7
        explainSemantics ::
          forall fn a.
          ((forall b. Term fn b -> b) -> GE a) ->
          (forall b. Term fn b -> b) ->
          GE a
        explainSemantics :: forall (fn :: [*] -> * -> *) a.
((forall b. Term fn b -> b) -> GE a)
-> (forall b. Term fn b -> b) -> GE a
explainSemantics (forall b. Term fn b -> b) -> GE a
k forall b. Term fn b -> b
env = forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a -> m a
explain NonEmpty [Char]
es forall a b. (a -> b) -> a -> b
$ (forall b. Term fn b -> b) -> GE a
k forall b. Term fn b -> b
env
    -- TODO: possibly one wants to have a `Term` level explanation in case
    -- the `b` propagates to ErrorSpec for some reason?
    pushExplain NonEmpty [Char]
es (When Term fn Bool
b Pred fn
p) = forall (fn :: [*] -> * -> *).
HasSpec fn Bool =>
Term fn Bool -> Pred fn -> Pred fn
When Term fn Bool
b (NonEmpty [Char] -> Pred fn -> Pred fn
pushExplain NonEmpty [Char]
es Pred fn
p)
    pushExplain NonEmpty [Char]
es Pred fn
p = forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn -> Pred fn
explanation NonEmpty [Char]
es Pred fn
p

    go :: [Pred fn] -> Pred fn -> [Pred fn]
go [Pred fn]
ctx = \case
      Block [Pred fn]
ps0 -> forall {fn :: [*] -> * -> *}. [Pred fn] -> [Pred fn] -> [Pred fn]
goBlock [Pred fn]
ctx (forall a b. (a -> b) -> [a] -> [b]
map forall (fn :: [*] -> * -> *). BaseUniverse fn => Pred fn -> Pred fn
letFloating [Pred fn]
ps0)
      Let Term fn a
t (Var a
x :-> Pred fn
p) -> forall {fn :: [*] -> * -> *}. [Pred fn] -> [Pred fn] -> [Pred fn]
goBlock [Pred fn]
ctx [forall (fn :: [*] -> * -> *) a. Term fn a -> Binder fn a -> Pred fn
Let Term fn a
t (Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Binder fn a
:-> forall (fn :: [*] -> * -> *). BaseUniverse fn => Pred fn -> Pred fn
letFloating Pred fn
p)]
      Exists (forall b. Term fn b -> b) -> GE a
k (Var a
x :-> Pred fn
p) -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
[Pred fn]
-> (Binder fn a -> Pred fn) -> Var a -> Pred fn -> [Pred fn]
goExists [Pred fn]
ctx (forall (fn :: [*] -> * -> *) a.
((forall b. Term fn b -> b) -> GE a) -> Binder fn a -> Pred fn
Exists (forall b. Term fn b -> b) -> GE a
k) Var a
x (forall (fn :: [*] -> * -> *). BaseUniverse fn => Pred fn -> Pred fn
letFloating Pred fn
p)
      Subst Var a
x Term fn a
t Pred fn
p -> [Pred fn] -> Pred fn -> [Pred fn]
go [Pred fn]
ctx (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> Pred fn -> Pred fn
substitutePred Var a
x Term fn a
t Pred fn
p)
      Reifies Term fn b
t' Term fn a
t a -> b
f -> forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, HasSpec fn b) =>
Term fn b -> Term fn a -> (a -> b) -> Pred fn
Reifies Term fn b
t' Term fn a
t a -> b
f forall a. a -> [a] -> [a]
: [Pred fn]
ctx
      Explain NonEmpty [Char]
es Pred fn
p -> forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn -> Pred fn
pushExplain NonEmpty [Char]
es Pred fn
p forall a. a -> [a] -> [a]
: [Pred fn]
ctx
      -- TODO: float let through forall if possible
      ForAll Term fn t
t (Var a
x :-> Pred fn
p) -> forall a b (fn :: [*] -> * -> *).
(Forallable a b, HasSpec fn a, HasSpec fn b) =>
Term fn a -> Binder fn b -> Pred fn
ForAll Term fn t
t (Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Binder fn a
:-> forall (fn :: [*] -> * -> *). BaseUniverse fn => Pred fn -> Pred fn
letFloating Pred fn
p) forall a. a -> [a] -> [a]
: [Pred fn]
ctx
      -- TODO: float let through the cases if possible
      Case Term fn (SumOver as)
t List (Weighted (Binder fn)) as
bs -> forall (fn :: [*] -> * -> *) (a :: [*]).
HasSpec fn (SumOver a) =>
Term fn (SumOver a) -> List (Weighted (Binder fn)) a -> Pred fn
Case Term fn (SumOver as)
t (forall {k} (f :: k -> *) (g :: k -> *) (as :: [k]).
(forall (a :: k). f a -> g a) -> List f as -> List g as
mapList (forall (f :: * -> *) a (g :: * -> *) b.
(f a -> g b) -> Weighted f a -> Weighted g b
mapWeighted (\(Var a
x :-> Pred fn
p) -> Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Binder fn a
:-> forall (fn :: [*] -> * -> *). BaseUniverse fn => Pred fn -> Pred fn
letFloating Pred fn
p)) List (Weighted (Binder fn)) as
bs) forall a. a -> [a] -> [a]
: [Pred fn]
ctx
      -- TODO: float let through if possible
      When Term fn Bool
b Pred fn
p -> forall (fn :: [*] -> * -> *).
HasSpec fn Bool =>
Term fn Bool -> Pred fn -> Pred fn
When Term fn Bool
b (forall (fn :: [*] -> * -> *). BaseUniverse fn => Pred fn -> Pred fn
letFloating Pred fn
p) forall a. a -> [a] -> [a]
: [Pred fn]
ctx
      -- Boring cases
      Assert Term fn Bool
t -> forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Term fn Bool -> Pred fn
Assert Term fn Bool
t forall a. a -> [a] -> [a]
: [Pred fn]
ctx
      GenHint Hint a
h Term fn a
t -> forall (fn :: [*] -> * -> *) a.
HasGenHint fn a =>
Hint a -> Term fn a -> Pred fn
GenHint Hint a
h Term fn a
t forall a. a -> [a] -> [a]
: [Pred fn]
ctx
      DependsOn Term fn a
t Term fn b
t' -> forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, HasSpec fn b) =>
Term fn a -> Term fn b -> Pred fn
DependsOn Term fn a
t Term fn b
t' forall a. a -> [a] -> [a]
: [Pred fn]
ctx
      Pred fn
TruePred -> forall (fn :: [*] -> * -> *). Pred fn
TruePred forall a. a -> [a] -> [a]
: [Pred fn]
ctx
      FalsePred NonEmpty [Char]
es -> forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn
FalsePred NonEmpty [Char]
es forall a. a -> [a] -> [a]
: [Pred fn]
ctx
      Monitor (forall b. Term fn b -> b) -> Property -> Property
m -> forall (fn :: [*] -> * -> *).
((forall a. Term fn a -> a) -> Property -> Property) -> Pred fn
Monitor (forall b. Term fn b -> b) -> Property -> Property
m forall a. a -> [a] -> [a]
: [Pred fn]
ctx

aggressiveInlining :: BaseUniverse fn => Pred fn -> Pred fn
aggressiveInlining :: forall (fn :: [*] -> * -> *). BaseUniverse fn => Pred fn -> Pred fn
aggressiveInlining Pred fn
p
  | Bool
inlined = forall (fn :: [*] -> * -> *). BaseUniverse fn => Pred fn -> Pred fn
aggressiveInlining Pred fn
pInlined
  | Bool
otherwise = Pred fn
p
  where
    (Pred fn
pInlined, Any Bool
inlined) = forall w a. Writer w a -> (a, w)
runWriter forall a b. (a -> b) -> a -> b
$ forall {fn :: [*] -> * -> *}.
(Functions fn fn,
 IsMember (EqFn fn) fn (FromJust (MPath (EqFn fn) fn)),
 IsMember (SetFn fn) fn (FromJust (MPath (SetFn fn) fn)),
 IsMember (BoolFn fn) fn (FromJust (MPath (BoolFn fn) fn)),
 IsMember (PairFn fn) fn (FromJust (MPath (PairFn fn) fn)),
 IsMember (IntFn fn) fn (FromJust (MPath (IntFn fn) fn)),
 IsMember (OrdFn fn) fn (FromJust (MPath (OrdFn fn) fn)),
 IsMember (GenericsFn fn) fn (FromJust (MPath (GenericsFn fn) fn)),
 IsMember (ListFn fn) fn (FromJust (MPath (ListFn fn) fn)),
 IsMember (SumFn fn) fn (FromJust (MPath (SumFn fn) fn)),
 IsMember (MapFn fn) fn (FromJust (MPath (MapFn fn) fn)),
 IsMember (FunFn fn) fn (FromJust (MPath (FunFn fn) fn)),
 IsMember (SizeFn fn) fn (FromJust (MPath (SizeFn fn) fn))) =>
FreeVars fn
-> Subst fn -> Pred fn -> WriterT Any Identity (Pred fn)
go (forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> FreeVars fn
freeVars Pred fn
p) [] Pred fn
p

    underBinder :: FreeVars fn -> Var a -> p -> FreeVars fn
underBinder FreeVars fn
fvs Var a
x p
p = FreeVars fn
fvs forall (t :: * -> *) (fn :: [*] -> * -> *).
Foldable t =>
FreeVars fn -> t (Name fn) -> FreeVars fn
`without` [forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Name fn
Name Var a
x] forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *). Name fn -> Int -> FreeVars fn
singleton (forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Name fn
Name Var a
x) (forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Int
countOf (forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Name fn
Name Var a
x) p
p)

    underBinderSub :: [SubstEntry fn] -> Var a -> [SubstEntry fn]
underBinderSub [SubstEntry fn]
sub Var a
x =
      [ Var a
x' forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> SubstEntry fn
:= Term fn a
t
      | Var a
x' := Term fn a
t <- [SubstEntry fn]
sub
      , forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ forall a a'.
(Typeable a, Typeable a') =>
Var a -> Var a' -> Maybe (a :~: a')
eqVar Var a
x Var a
x'
      ]

    -- NOTE: this is safe because we only use the `Subst` when it results in a literal so there
    -- is no risk of variable capture.
    goBinder :: FreeVars fn -> Subst fn -> Binder fn a -> Writer Any (Binder fn a)
    goBinder :: forall (fn :: [*] -> * -> *) a.
FreeVars fn -> Subst fn -> Binder fn a -> Writer Any (Binder fn a)
goBinder FreeVars fn
fvs Subst fn
sub (Var a
x :-> Pred fn
p) = (Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Binder fn a
:->) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {fn :: [*] -> * -> *}.
(Functions fn fn,
 IsMember (EqFn fn) fn (FromJust (MPath (EqFn fn) fn)),
 IsMember (SetFn fn) fn (FromJust (MPath (SetFn fn) fn)),
 IsMember (BoolFn fn) fn (FromJust (MPath (BoolFn fn) fn)),
 IsMember (PairFn fn) fn (FromJust (MPath (PairFn fn) fn)),
 IsMember (IntFn fn) fn (FromJust (MPath (IntFn fn) fn)),
 IsMember (OrdFn fn) fn (FromJust (MPath (OrdFn fn) fn)),
 IsMember (GenericsFn fn) fn (FromJust (MPath (GenericsFn fn) fn)),
 IsMember (ListFn fn) fn (FromJust (MPath (ListFn fn) fn)),
 IsMember (SumFn fn) fn (FromJust (MPath (SumFn fn) fn)),
 IsMember (MapFn fn) fn (FromJust (MPath (MapFn fn) fn)),
 IsMember (FunFn fn) fn (FromJust (MPath (FunFn fn) fn)),
 IsMember (SizeFn fn) fn (FromJust (MPath (SizeFn fn) fn))) =>
FreeVars fn
-> Subst fn -> Pred fn -> WriterT Any Identity (Pred fn)
go (forall {fn :: [*] -> * -> *} {p} {fn :: [*] -> * -> *} {a}.
(HasVariables fn p, HasSpec fn a, HasSpec fn a) =>
FreeVars fn -> Var a -> p -> FreeVars fn
underBinder FreeVars fn
fvs Var a
x Pred fn
p) (forall {a} {fn :: [*] -> * -> *}.
Typeable a =>
[SubstEntry fn] -> Var a -> [SubstEntry fn]
underBinderSub Subst fn
sub Var a
x) Pred fn
p

    -- Check that the name `n` is only ever used as the only variable
    -- in the expressions where it appears. This ensures that it doesn't
    -- interact with anything.
    onlyUsedUniquely :: Name fn -> Pred fn -> Bool
onlyUsedUniquely Name fn
n Pred fn
p = case Pred fn
p of
      Assert Term fn Bool
t
        | Name fn
n forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
`appearsIn` Term fn Bool
t -> forall a. Set a -> Int
Set.size (forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet Term fn Bool
t) forall a. Eq a => a -> a -> Bool
== Int
1
        | Bool
otherwise -> Bool
True
      Block [Pred fn]
ps -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Name fn -> Pred fn -> Bool
onlyUsedUniquely Name fn
n) [Pred fn]
ps
      -- TODO: we can (and should) probably add a bunch of cases to this.
      Pred fn
_ -> Bool
False

    go :: FreeVars fn
-> Subst fn -> Pred fn -> WriterT Any Identity (Pred fn)
go FreeVars fn
fvs Subst fn
sub Pred fn
p = case Pred fn
p of
      Subst Var a
x Term fn a
t Pred fn
p -> FreeVars fn
-> Subst fn -> Pred fn -> WriterT Any Identity (Pred fn)
go FreeVars fn
fvs Subst fn
sub (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> Pred fn -> Pred fn
substitutePred Var a
x Term fn a
t Pred fn
p)
      Reifies Term fn b
t' Term fn a
t a -> b
f
        | Bool -> Bool
not (forall (fn :: [*] -> * -> *) a. Term fn a -> Bool
isLit Term fn a
t)
        , Lit a
a <- forall (fn :: [*] -> * -> *) a.
BaseUniverse fn =>
Subst fn -> Term fn a -> Term fn a
substituteAndSimplifyTerm Subst fn
sub Term fn a
t -> do
            forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, HasSpec fn b) =>
Term fn b -> Term fn a -> (a -> b) -> Pred fn
Reifies Term fn b
t' (forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit a
a) a -> b
f
        | Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, HasSpec fn b) =>
Term fn b -> Term fn a -> (a -> b) -> Pred fn
Reifies Term fn b
t' Term fn a
t a -> b
f
      ForAll Term fn t
set Binder fn a
b
        | Bool -> Bool
not (forall (fn :: [*] -> * -> *) a. Term fn a -> Bool
isLit Term fn t
set)
        , Lit t
a <- forall (fn :: [*] -> * -> *) a.
BaseUniverse fn =>
Subst fn -> Term fn a -> Term fn a
substituteAndSimplifyTerm Subst fn
sub Term fn t
set -> do
            forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a (fn :: [*] -> * -> *). a -> Binder fn a -> Pred fn
`unBind` Binder fn a
b) (forall t e. Forallable t e => t -> [e]
forAllToList t
a)
        | Bool
otherwise -> forall a b (fn :: [*] -> * -> *).
(Forallable a b, HasSpec fn a, HasSpec fn b) =>
Term fn a -> Binder fn b -> Pred fn
ForAll Term fn t
set forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (fn :: [*] -> * -> *) a.
FreeVars fn -> Subst fn -> Binder fn a -> Writer Any (Binder fn a)
goBinder FreeVars fn
fvs Subst fn
sub Binder fn a
b
      Case Term fn (SumOver as)
t List (Weighted (Binder fn)) as
bs
        | Bool -> Bool
not (forall (fn :: [*] -> * -> *) a. Term fn a -> Bool
isLit Term fn (SumOver as)
t)
        , Lit SumOver as
a <- forall (fn :: [*] -> * -> *) a.
BaseUniverse fn =>
Subst fn -> Term fn a -> Term fn a
substituteAndSimplifyTerm Subst fn
sub Term fn (SumOver as)
t -> do
            forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (as :: [*]) (fn :: [*] -> * -> *) r.
SumOver as
-> List (Binder fn) as
-> (forall a. HasSpec fn a => Var a -> a -> Pred fn -> r)
-> r
runCaseOn SumOver as
a (forall {k} (f :: k -> *) (g :: k -> *) (as :: [k]).
(forall (a :: k). f a -> g a) -> List f as -> List g as
mapList forall (f :: * -> *) a. Weighted f a -> f a
thing List (Weighted (Binder fn)) as
bs) forall a b. (a -> b) -> a -> b
$ \Var a
x a
v Pred fn
p -> forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Env -> Pred fn -> Pred fn
substPred (forall a. (Typeable a, Show a) => Var a -> a -> Env
singletonEnv Var a
x a
v) Pred fn
p
        | (Weighted Maybe Int
w (Var a
x :-> Pred fn
p) :> List (Weighted (Binder fn)) as1
Nil) <- List (Weighted (Binder fn)) as
bs -> do
            let t' :: Term fn (SumOver as)
t' = forall (fn :: [*] -> * -> *) a.
BaseUniverse fn =>
Subst fn -> Term fn a -> Term fn a
substituteAndSimplifyTerm Subst fn
sub Term fn (SumOver as)
t
            Pred fn
p' <- FreeVars fn
-> Subst fn -> Pred fn -> WriterT Any Identity (Pred fn)
go (forall {fn :: [*] -> * -> *} {p} {fn :: [*] -> * -> *} {a}.
(HasVariables fn p, HasSpec fn a, HasSpec fn a) =>
FreeVars fn -> Var a -> p -> FreeVars fn
underBinder FreeVars fn
fvs Var a
x Pred fn
p) (Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> SubstEntry fn
:= Term fn (SumOver as)
t' forall a. a -> [a] -> [a]
: Subst fn
sub) Pred fn
p
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) (a :: [*]).
HasSpec fn (SumOver a) =>
Term fn (SumOver a) -> List (Weighted (Binder fn)) a -> Pred fn
Case Term fn (SumOver as)
t (forall (f :: * -> *) a. Maybe Int -> f a -> Weighted f a
Weighted Maybe Int
w (Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Binder fn a
:-> Pred fn
p') forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> forall {k} (f :: k -> *). List f '[]
Nil)
        | Bool
otherwise -> forall (fn :: [*] -> * -> *) (a :: [*]).
HasSpec fn (SumOver a) =>
Term fn (SumOver a) -> List (Weighted (Binder fn)) a -> Pred fn
Case Term fn (SumOver as)
t forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (m :: * -> *) (f :: k -> *) (g :: k -> *) (as :: [k]).
Applicative m =>
(forall (a :: k). f a -> m (g a)) -> List f as -> m (List g as)
mapMList (forall (m :: * -> *) (f :: * -> *) a (g :: * -> *).
Applicative m =>
(f a -> m (g a)) -> Weighted f a -> m (Weighted g a)
traverseWeighted forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
FreeVars fn -> Subst fn -> Binder fn a -> Writer Any (Binder fn a)
goBinder FreeVars fn
fvs Subst fn
sub) List (Weighted (Binder fn)) as
bs
      When Term fn Bool
b Pred fn
tp
        | Bool -> Bool
not (forall (fn :: [*] -> * -> *) a. Term fn a -> Bool
isLit Term fn Bool
b)
        , Lit Bool
a <- forall (fn :: [*] -> * -> *) a.
BaseUniverse fn =>
Subst fn -> Term fn a -> Term fn a
substituteAndSimplifyTerm Subst fn
sub Term fn Bool
b -> do
            forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if Bool
a then Pred fn
tp else forall (fn :: [*] -> * -> *). Pred fn
TruePred
        | Bool
otherwise -> forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
Term fn Bool -> p -> Pred fn
whenTrue Term fn Bool
b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FreeVars fn
-> Subst fn -> Pred fn -> WriterT Any Identity (Pred fn)
go FreeVars fn
fvs Subst fn
sub Pred fn
tp
      Let Term fn a
t (Var a
x :-> Pred fn
p)
        | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Name fn
n -> forall (fn :: [*] -> * -> *). Name fn -> FreeVars fn -> Int
count Name fn
n FreeVars fn
fvs forall a. Ord a => a -> a -> Bool
<= Int
1) (forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
a -> Set (Name fn)
freeVarSet Term fn a
t) -> do
            forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> Pred fn -> Pred fn
substitutePred Var a
x Term fn a
t Pred fn
p
        | forall (fn :: [*] -> * -> *). Name fn -> Pred fn -> Bool
onlyUsedUniquely (forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Name fn
Name Var a
x) Pred fn
p -> do
            forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> Pred fn -> Pred fn
substitutePred Var a
x Term fn a
t Pred fn
p
        | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Name fn
Name Var a
x forall (fn :: [*] -> * -> *) a.
HasVariables fn a =>
Name fn -> a -> Bool
`appearsIn` Pred fn
p -> do
            forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
            forall (f :: * -> *) a. Applicative f => a -> f a
pure Pred fn
p
        | Bool -> Bool
not (forall (fn :: [*] -> * -> *) a. Term fn a -> Bool
isLit Term fn a
t)
        , Lit a
a <- forall (fn :: [*] -> * -> *) a.
BaseUniverse fn =>
Subst fn -> Term fn a -> Term fn a
substituteAndSimplifyTerm Subst fn
sub Term fn a
t -> do
            forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a (fn :: [*] -> * -> *). a -> Binder fn a -> Pred fn
unBind a
a (Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Binder fn a
:-> Pred fn
p)
        | Bool
otherwise -> forall (fn :: [*] -> * -> *) a. Term fn a -> Binder fn a -> Pred fn
Let Term fn a
t forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Binder fn a
:->) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FreeVars fn
-> Subst fn -> Pred fn -> WriterT Any Identity (Pred fn)
go (forall {fn :: [*] -> * -> *} {p} {fn :: [*] -> * -> *} {a}.
(HasVariables fn p, HasSpec fn a, HasSpec fn a) =>
FreeVars fn -> Var a -> p -> FreeVars fn
underBinder FreeVars fn
fvs Var a
x Pred fn
p) (Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> SubstEntry fn
:= Term fn a
t forall a. a -> [a] -> [a]
: Subst fn
sub) Pred fn
p
      Exists (forall b. Term fn b -> b) -> GE a
k Binder fn a
b -> forall (fn :: [*] -> * -> *) a.
((forall b. Term fn b -> b) -> GE a) -> Binder fn a -> Pred fn
Exists (forall b. Term fn b -> b) -> GE a
k forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (fn :: [*] -> * -> *) a.
FreeVars fn -> Subst fn -> Binder fn a -> Writer Any (Binder fn a)
goBinder FreeVars fn
fvs Subst fn
sub Binder fn a
b
      Block [Pred fn]
ps -> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (FreeVars fn
-> Subst fn -> Pred fn -> WriterT Any Identity (Pred fn)
go FreeVars fn
fvs Subst fn
sub) [Pred fn]
ps
      Assert Term fn Bool
t
        | Bool -> Bool
not (forall (fn :: [*] -> * -> *) a. Term fn a -> Bool
isLit Term fn Bool
t)
        , Lit Bool
b <- forall (fn :: [*] -> * -> *) a.
BaseUniverse fn =>
Subst fn -> Term fn a -> Term fn a
substituteAndSimplifyTerm Subst fn
sub Term fn Bool
t -> do
            forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall p (fn :: [*] -> * -> *).
(PredLike p, BaseUniverse fn, UnivConstr p fn) =>
[[Char]] -> p -> Pred fn
toPredExplain [] Bool
b
        | Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Pred fn
p
      -- If the term turns into a literal, there is no more generation to do here
      -- so we can ignore the `GenHint`
      GenHint Hint a
_ Term fn a
t
        | Bool -> Bool
not (forall (fn :: [*] -> * -> *) a. Term fn a -> Bool
isLit Term fn a
t)
        , Lit {} <- forall (fn :: [*] -> * -> *) a.
BaseUniverse fn =>
Subst fn -> Term fn a -> Term fn a
substituteAndSimplifyTerm Subst fn
sub Term fn a
t -> do
            forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (fn :: [*] -> * -> *). Pred fn
TruePred
        | Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Pred fn
p
      DependsOn Term fn a
t Term fn b
t'
        | Bool -> Bool
not (forall (fn :: [*] -> * -> *) a. Term fn a -> Bool
isLit Term fn a
t)
        , Lit {} <- forall (fn :: [*] -> * -> *) a.
BaseUniverse fn =>
Subst fn -> Term fn a -> Term fn a
substituteAndSimplifyTerm Subst fn
sub Term fn a
t -> do
            forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *). Pred fn
TruePred
        | Bool -> Bool
not (forall (fn :: [*] -> * -> *) a. Term fn a -> Bool
isLit Term fn b
t')
        , Lit {} <- forall (fn :: [*] -> * -> *) a.
BaseUniverse fn =>
Subst fn -> Term fn a -> Term fn a
substituteAndSimplifyTerm Subst fn
sub Term fn b
t' -> do
            forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *). Pred fn
TruePred
        | Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Pred fn
p
      Pred fn
TruePred -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Pred fn
p
      FalsePred {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Pred fn
p
      Monitor {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Pred fn
p
      Explain NonEmpty [Char]
es Pred fn
p -> forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn -> Pred fn
Explain NonEmpty [Char]
es forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FreeVars fn
-> Subst fn -> Pred fn -> WriterT Any Identity (Pred fn)
go FreeVars fn
fvs Subst fn
sub Pred fn
p

-- | Apply a substitution and simplify the resulting term if the substitution changed the
-- term.
substituteAndSimplifyTerm :: BaseUniverse fn => Subst fn -> Term fn a -> Term fn a
substituteAndSimplifyTerm :: forall (fn :: [*] -> * -> *) a.
BaseUniverse fn =>
Subst fn -> Term fn a -> Term fn a
substituteAndSimplifyTerm Subst fn
sub Term fn a
t =
  case forall w a. Writer w a -> (a, w)
runWriter forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
Subst fn -> Term fn a -> Writer Any (Term fn a)
substituteTerm' Subst fn
sub Term fn a
t of
    (Term fn a
t', Any Bool
b)
      | Bool
b -> forall (fn :: [*] -> * -> *) a.
BaseUniverse fn =>
Term fn a -> Term fn a
simplifyTerm Term fn a
t'
      | Bool
otherwise -> Term fn a
t'

------------------------------------------------------------------------
-- Generics
------------------------------------------------------------------------

{-
`HasSimpleRep` and `GenericsFn` are meant to allow you to express that a
type is isomorphic to some other type that has a `HasSpec` instance.

The trick is that the default instance of `HasSpec fn a` assumes
`HasSimpleRep a` and defines `TypeSpec fn a = TypeSpec fn (SimpleRep a)`.

From this it's possible to work with things of type `a` in constraints by
treating them like things of type `SimpleRep a`. This allows us to do case
matching etc. on `a` when `SimpleRep a` is a `Sum` type, for example.

Or alternatively it allows us to treat `a` as a newtype over `SimpleRep a`
when using `match`.

-}

class HasSimpleRep a where
  type SimpleRep a
  type TheSop a :: [Type]
  toSimpleRep :: a -> SimpleRep a
  fromSimpleRep :: SimpleRep a -> a

  type TheSop a = SOPOf (Rep a)
  type SimpleRep a = SOP (TheSop a)

  default toSimpleRep ::
    ( Generic a
    , SimpleGeneric (Rep a)
    , SimpleRep a ~ SimplifyRep (Rep a)
    ) =>
    a ->
    SimpleRep a
  toSimpleRep = forall (rep :: * -> *) p.
SimpleGeneric rep =>
rep p -> SimplifyRep rep
toSimpleRep' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from

  default fromSimpleRep ::
    ( Generic a
    , SimpleGeneric (Rep a)
    , SimpleRep a ~ SimplifyRep (Rep a)
    ) =>
    SimpleRep a ->
    a
  fromSimpleRep = forall a x. Generic a => Rep a x -> a
to forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rep :: * -> *) p.
SimpleGeneric rep =>
SimplifyRep rep -> rep p
fromSimpleRep'

type family SimplifyRep f where
  SimplifyRep f = SOP (SOPOf f)

toGenericFn ::
  forall fn a.
  ( HasSpec fn (SimpleRep a)
  , TypeSpec fn a ~ TypeSpec fn (SimpleRep a)
  , HasSimpleRep a
  ) =>
  fn '[a] (SimpleRep a)
toGenericFn :: forall (fn :: [*] -> * -> *) a.
(HasSpec fn (SimpleRep a),
 TypeSpec fn a ~ TypeSpec fn (SimpleRep a), HasSimpleRep a) =>
fn '[a] (SimpleRep a)
toGenericFn = forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fn as b -> fnU as b
injectFn forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
(HasSpec fn (SimpleRep a),
 TypeSpec fn a ~ TypeSpec fn (SimpleRep a), HasSimpleRep a) =>
GenericsFn fn '[a] (SimpleRep a)
ToGeneric @fn

fromGenericFn ::
  forall fn a.
  ( HasSpec fn (SimpleRep a)
  , TypeSpec fn a ~ TypeSpec fn (SimpleRep a)
  , HasSimpleRep a
  ) =>
  fn '[SimpleRep a] a
fromGenericFn :: forall (fn :: [*] -> * -> *) a.
(HasSpec fn (SimpleRep a),
 TypeSpec fn a ~ TypeSpec fn (SimpleRep a), HasSimpleRep a) =>
fn '[SimpleRep a] a
fromGenericFn = forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fn as b -> fnU as b
injectFn forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
(HasSpec fn (SimpleRep a),
 TypeSpec fn a ~ TypeSpec fn (SimpleRep a), HasSimpleRep a) =>
GenericsFn fn '[SimpleRep a] a
FromGeneric @fn

data GenericsFn fn args res where
  ToGeneric ::
    ( HasSpec fn (SimpleRep a)
    , TypeSpec fn a ~ TypeSpec fn (SimpleRep a)
    , HasSimpleRep a
    ) =>
    GenericsFn fn '[a] (SimpleRep a)
  FromGeneric ::
    ( HasSpec fn (SimpleRep a)
    , TypeSpec fn a ~ TypeSpec fn (SimpleRep a)
    , HasSimpleRep a
    ) =>
    GenericsFn fn '[SimpleRep a] a

deriving instance Show (GenericsFn fn as b)
deriving instance Eq (GenericsFn fn args res)

fromSimpleRepSpec ::
  forall a fn.
  (HasSpec fn a, HasSimpleRep a, TypeSpec fn a ~ TypeSpec fn (SimpleRep a)) =>
  Specification fn (SimpleRep a) ->
  Specification fn a
fromSimpleRepSpec :: forall a (fn :: [*] -> * -> *).
(HasSpec fn a, HasSimpleRep a,
 TypeSpec fn a ~ TypeSpec fn (SimpleRep a)) =>
Specification fn (SimpleRep a) -> Specification fn a
fromSimpleRepSpec = \case
  ExplainSpec [[Char]]
es Specification fn (SimpleRep a)
s -> forall (fn :: [*] -> * -> *) a.
[[Char]] -> Specification fn a -> Specification fn a
explainSpecOpt [[Char]]
es (forall a (fn :: [*] -> * -> *).
(HasSpec fn a, HasSimpleRep a,
 TypeSpec fn a ~ TypeSpec fn (SimpleRep a)) =>
Specification fn (SimpleRep a) -> Specification fn a
fromSimpleRepSpec Specification fn (SimpleRep a)
s)
  Specification fn (SimpleRep a)
TrueSpec -> forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec
  ErrorSpec NonEmpty [Char]
e -> forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec NonEmpty [Char]
e
  TypeSpec TypeSpec fn (SimpleRep a)
s'' OrdSet (SimpleRep a)
cant -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> OrdSet a -> Specification fn a
TypeSpec TypeSpec fn (SimpleRep a)
s'' forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. HasSimpleRep a => SimpleRep a -> a
fromSimpleRep OrdSet (SimpleRep a)
cant
  MemberSpec NonEmpty (SimpleRep a)
elems -> forall a (fn :: [*] -> * -> *). NonEmpty a -> Specification fn a
MemberSpec forall a b. (a -> b) -> a -> b
$ forall a. Eq a => NonEmpty a -> NonEmpty a
NE.nub (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. HasSimpleRep a => SimpleRep a -> a
fromSimpleRep NonEmpty (SimpleRep a)
elems)
  SuspendedSpec Var (SimpleRep a)
x Pred fn
p ->
    forall a (fn :: [*] -> * -> *) p.
(IsPred p fn, HasSpec fn a) =>
(Term fn a -> p) -> Specification fn a
constrained forall a b. (a -> b) -> a -> b
$ \Term fn a
x' ->
      forall (fn :: [*] -> * -> *) a. Term fn a -> Binder fn a -> Pred fn
Let (forall a (fn :: [*] -> * -> *).
(HasSpec fn a, HasSpec fn (SimpleRep a), HasSimpleRep a,
 TypeSpec fn a ~ TypeSpec fn (SimpleRep a)) =>
Term fn a -> Term fn (SimpleRep a)
toGeneric_ Term fn a
x') (Var (SimpleRep a)
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Binder fn a
:-> Pred fn
p)

toSimpleRepSpec ::
  forall a fn.
  (HasSpec fn a, HasSpec fn (SimpleRep a), HasSimpleRep a, TypeSpec fn a ~ TypeSpec fn (SimpleRep a)) =>
  Specification fn a ->
  Specification fn (SimpleRep a)
toSimpleRepSpec :: forall a (fn :: [*] -> * -> *).
(HasSpec fn a, HasSpec fn (SimpleRep a), HasSimpleRep a,
 TypeSpec fn a ~ TypeSpec fn (SimpleRep a)) =>
Specification fn a -> Specification fn (SimpleRep a)
toSimpleRepSpec = \case
  ExplainSpec [[Char]]
es Specification fn a
s -> forall (fn :: [*] -> * -> *) a.
[[Char]] -> Specification fn a -> Specification fn a
explainSpecOpt [[Char]]
es (forall a (fn :: [*] -> * -> *).
(HasSpec fn a, HasSpec fn (SimpleRep a), HasSimpleRep a,
 TypeSpec fn a ~ TypeSpec fn (SimpleRep a)) =>
Specification fn a -> Specification fn (SimpleRep a)
toSimpleRepSpec Specification fn a
s)
  Specification fn a
TrueSpec -> forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec
  ErrorSpec NonEmpty [Char]
e -> forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec NonEmpty [Char]
e
  TypeSpec TypeSpec fn a
s'' OrdSet a
cant -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> OrdSet a -> Specification fn a
TypeSpec TypeSpec fn a
s'' forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. HasSimpleRep a => a -> SimpleRep a
toSimpleRep OrdSet a
cant
  MemberSpec NonEmpty a
elems -> forall a (fn :: [*] -> * -> *). NonEmpty a -> Specification fn a
MemberSpec forall a b. (a -> b) -> a -> b
$ forall a. Eq a => NonEmpty a -> NonEmpty a
NE.nub forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. HasSimpleRep a => a -> SimpleRep a
toSimpleRep NonEmpty a
elems
  SuspendedSpec Var a
x Pred fn
p ->
    forall a (fn :: [*] -> * -> *) p.
(IsPred p fn, HasSpec fn a) =>
(Term fn a -> p) -> Specification fn a
constrained forall a b. (a -> b) -> a -> b
$ \Term fn (SimpleRep a)
x' ->
      forall (fn :: [*] -> * -> *) a. Term fn a -> Binder fn a -> Pred fn
Let (forall a (fn :: [*] -> * -> *).
(HasSpec fn a, HasSpec fn (SimpleRep a), HasSimpleRep a,
 TypeSpec fn a ~ TypeSpec fn (SimpleRep a)) =>
Term fn (SimpleRep a) -> Term fn a
fromGeneric_ Term fn (SimpleRep a)
x') (Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Binder fn a
:-> Pred fn
p)

{- This part of the code base is responsible for implementing the conversion
   from a `Generic` type to a `Sum` over `Prod` representation that automatically
   gives you an instance of `HasSpec`. The user has three options for building their
   own instances of `HasSpec`, either they hand-roll an instance, they go with the
   entirely `Generic` instance, or they provide their own `SimpleRep` for their type.

   The latter may be appropriate when the type is an optimized representation:

   ```
   newtype Foo = Foo { unFoo :: MemoBytes ActualFoo }

   instance HasSimpleRep Foo where
     type SimpleRep Foo = ActualFoo
     toSimpleRep = unMemoBytes . unFoo
     fromSimpleRep = Foo . memoBytes
   ```

   This would then allow for `Foo` to be treated as a simple `newtype` over `ActualFoo`
   in constraints:

   ```
   fooSpec :: Specification fn Foo
   fooSpec = constrained $ \ foo ->
     match foo $ \ actualFoo -> ...
   ```
-}

-- Building a SOP type (Sum Of Prod) --------------------------------------

-- | A constructor name with the types of its arguments
data (c :: Symbol) ::: (ts :: [Type])

-- | Turn a `Rep` into a list that flattens the sum
-- structre and gives the constructors names:
--   Maybe Int -> '["Nothing" ::: '[()], "Just" ::: '[Int]]
--   Either Int Bool -> '["Left" ::: '[Int], "Right" ::: '[Bool]]
--   data Foo = Foo Int Bool | Bar Double -> '["Foo" ::: '[Int, Bool], "Bar" ::: '[Double]]
type family SOPOf f where
  SOPOf (D1 _ f) = SOPOf f
  SOPOf (f :+: g) = Append (SOPOf f) (SOPOf g)
  SOPOf (C1 ('MetaCons constr _ _) f) = '[constr ::: Constr f]

-- | Flatten a single constructor
type family Constr f where
  -- TODO: Here we should put in the selector names
  -- so that they can be re-used to create selectors more
  -- easily than the current disgusting `Fst . Snd . Snd . Snd ...`
  -- method.
  Constr (S1 _ f) = Constr f
  Constr (K1 _ k) = '[k]
  Constr U1 = '[()]
  Constr (f :*: g) = Append (Constr f) (Constr g)

-- | Turn a list from `SOPOf` into a `Sum` over
-- `Prod` representation.
type family SOP constrs where
  SOP '[c ::: prod] = ProdOver prod
  SOP ((c ::: prod) : constrs) = Sum (ProdOver prod) (SOP constrs)

-- Constructing a SOP -----------------------------------------------------

type family ConstrOf c sop where
  ConstrOf c (c ::: constr : sop) = constr
  ConstrOf c (_ : sop) = ConstrOf c sop

class Inject c constrs r where
  inject' :: (SOP constrs -> r) -> FunTy (ConstrOf c constrs) r

instance TypeList prod => Inject c '[c ::: prod] r where
  inject' :: (SOP '[c ::: prod] -> r) -> FunTy (ConstrOf c '[c ::: prod]) r
inject' SOP '[c ::: prod] -> r
k = forall (ts :: [*]) (f :: * -> *) r.
TypeList ts =>
(forall a. a -> f a) -> (List f ts -> r) -> FunTy ts r
curryList_ @prod forall a. a -> Identity a
Identity (forall (as :: [*]) r. (ProdOver as -> r) -> List Identity as -> r
listToProd SOP '[c ::: prod] -> r
k)

instance TypeList prod => Inject c ((c ::: prod) : prod' : constrs) r where
  inject' :: (SOP ((c ::: prod) : prod' : constrs) -> r)
-> FunTy (ConstrOf c ((c ::: prod) : prod' : constrs)) r
inject' SOP ((c ::: prod) : prod' : constrs) -> r
k = forall (ts :: [*]) (f :: * -> *) r.
TypeList ts =>
(forall a. a -> f a) -> (List f ts -> r) -> FunTy ts r
curryList_ @prod forall a. a -> Identity a
Identity (forall (as :: [*]) r. (ProdOver as -> r) -> List Identity as -> r
listToProd (SOP ((c ::: prod) : prod' : constrs) -> r
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Sum a b
SumLeft @_ @(SOP (prod' : constrs))))

instance
  {-# OVERLAPPABLE #-}
  ( FunTy (ConstrOf c ((c' ::: prod) : con : constrs)) r ~ FunTy (ConstrOf c (con : constrs)) r
  , -- \^ An unfortunately roundabout way of saying `c !~ c'`
    Inject c (con : constrs) r
  ) =>
  Inject c ((c' ::: prod) : con : constrs) r
  where
  inject' :: (SOP ((c' ::: prod) : con : constrs) -> r)
-> FunTy (ConstrOf c ((c' ::: prod) : con : constrs)) r
inject' SOP ((c' ::: prod) : con : constrs) -> r
k = forall (c :: Symbol) (constrs :: [*]) r.
Inject c constrs r =>
(SOP constrs -> r) -> FunTy (ConstrOf c constrs) r
inject' @c @(con : constrs) (SOP ((c' ::: prod) : con : constrs) -> r
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Sum a b
SumRight)

inject ::
  forall c constrs. Inject c constrs (SOP constrs) => FunTy (ConstrOf c constrs) (SOP constrs)
inject :: forall (c :: Symbol) (constrs :: [*]).
Inject c constrs (SOP constrs) =>
FunTy (ConstrOf c constrs) (SOP constrs)
inject = forall (c :: Symbol) (constrs :: [*]) r.
Inject c constrs r =>
(SOP constrs -> r) -> FunTy (ConstrOf c constrs) r
inject' @c @constrs forall a. a -> a
id

-- Deconstructing a SOP ---------------------------------------------------

-- | An `ALG constrs r` is a function that takes a way to turn every
-- constructor into an `r`:
-- ```
-- ALG (SOPOf (Rep (Either Int Bool))) r = (Int -> r) -> (Bool -> r) -> r
-- ```
type family ALG constrs r where
  ALG '[c ::: prod] r = FunTy prod r -> r
  ALG ((c ::: prod) : constrs) r = FunTy prod r -> ALG constrs r

class SOPLike constrs r where
  -- | Run a `SOP`
  algebra :: SOP constrs -> ALG constrs r

  -- | Ignore everything in the `SOP`
  consts :: r -> ALG constrs r

instance TypeList prod => SOPLike '[c ::: prod] r where
  algebra :: SOP '[c ::: prod] -> ALG '[c ::: prod] r
algebra SOP '[c ::: prod]
prod FunTy prod r
f = forall (ts :: [*]) (f :: * -> *) r.
TypeList ts =>
(forall a. f a -> a) -> FunTy ts r -> List f ts -> r
uncurryList_ @prod forall a. Identity a -> a
runIdentity FunTy prod r
f forall a b. (a -> b) -> a -> b
$ forall (as :: [*]). TypeList as => ProdOver as -> List Identity as
prodToList SOP '[c ::: prod]
prod
  consts :: r -> ALG '[c ::: prod] r
consts r
r FunTy prod r
_ = r
r

instance (TypeList prod, SOPLike (con : cases) r) => SOPLike ((c ::: prod) : con : cases) r where
  algebra :: SOP ((c ::: prod) : con : cases)
-> ALG ((c ::: prod) : con : cases) r
algebra (SumLeft ProdOver prod
prod) FunTy prod r
f = forall (constrs :: [*]) r. SOPLike constrs r => r -> ALG constrs r
consts @(con : cases) @r (forall (constrs :: [*]) r.
SOPLike constrs r =>
SOP constrs -> ALG constrs r
algebra @'[c ::: prod] ProdOver prod
prod FunTy prod r
f)
  algebra (SumRight SOP (con : cases)
rest) FunTy prod r
_ = forall (constrs :: [*]) r.
SOPLike constrs r =>
SOP constrs -> ALG constrs r
algebra @(con : cases) @r SOP (con : cases)
rest

  consts :: r -> ALG ((c ::: prod) : con : cases) r
consts r
r FunTy prod r
_ = forall (constrs :: [*]) r. SOPLike constrs r => r -> ALG constrs r
consts @(con : cases) r
r

-- The individual constructor level ---------------------------------------

class SimpleConstructor rep where
  toSimpleCon' :: rep p -> ProdOver (Constr rep)
  fromSimpleCon' :: ProdOver (Constr rep) -> rep p

instance
  ( SimpleConstructor f
  , SimpleConstructor g
  , TypeList (Constr f)
  , TypeList (Constr g)
  ) =>
  SimpleConstructor (f :*: g)
  where
  toSimpleCon' :: forall p. (:*:) f g p -> ProdOver (Constr (f :*: g))
toSimpleCon' (f p
a :*: g p
b) = forall (xs :: [*]) (ys :: [*]).
(TypeList xs, TypeList ys) =>
ProdOver xs -> ProdOver ys -> ProdOver (Append xs ys)
appendProd @(Constr f) @(Constr g) (forall (rep :: * -> *) p.
SimpleConstructor rep =>
rep p -> ProdOver (Constr rep)
toSimpleCon' f p
a) (forall (rep :: * -> *) p.
SimpleConstructor rep =>
rep p -> ProdOver (Constr rep)
toSimpleCon' g p
b)
  fromSimpleCon' :: forall p. ProdOver (Constr (f :*: g)) -> (:*:) f g p
fromSimpleCon' ProdOver (Constr (f :*: g))
constr =
    let Prod ProdOver (Constr f)
a ProdOver (Constr g)
b = forall (xs :: [*]) (ys :: [*]).
(TypeList xs, TypeList ys) =>
ProdOver (Append xs ys) -> Prod (ProdOver xs) (ProdOver ys)
splitProd @(Constr f) @(Constr g) ProdOver (Constr (f :*: g))
constr
     in (forall (rep :: * -> *) p.
SimpleConstructor rep =>
ProdOver (Constr rep) -> rep p
fromSimpleCon' ProdOver (Constr f)
a forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall (rep :: * -> *) p.
SimpleConstructor rep =>
ProdOver (Constr rep) -> rep p
fromSimpleCon' ProdOver (Constr g)
b)

instance SimpleConstructor f => SimpleConstructor (S1 s f) where
  toSimpleCon' :: forall p. S1 s f p -> ProdOver (Constr (S1 s f))
toSimpleCon' (M1 f p
f) = forall (rep :: * -> *) p.
SimpleConstructor rep =>
rep p -> ProdOver (Constr rep)
toSimpleCon' f p
f
  fromSimpleCon' :: forall p. ProdOver (Constr (S1 s f)) -> S1 s f p
fromSimpleCon' ProdOver (Constr (S1 s f))
a = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (forall (rep :: * -> *) p.
SimpleConstructor rep =>
ProdOver (Constr rep) -> rep p
fromSimpleCon' ProdOver (Constr (S1 s f))
a)

instance SimpleConstructor (K1 i k) where
  toSimpleCon' :: forall p. K1 i k p -> ProdOver (Constr (K1 i k))
toSimpleCon' (K1 k
k) = k
k
  fromSimpleCon' :: forall p. ProdOver (Constr (K1 i k)) -> K1 i k p
fromSimpleCon' ProdOver (Constr (K1 i k))
k = forall k i c (p :: k). c -> K1 i c p
K1 ProdOver (Constr (K1 i k))
k

instance SimpleConstructor U1 where
  toSimpleCon' :: forall p. U1 p -> ProdOver (Constr U1)
toSimpleCon' U1 p
U1 = ()
  fromSimpleCon' :: forall p. ProdOver (Constr U1) -> U1 p
fromSimpleCon' ProdOver (Constr U1)
_ = forall k (p :: k). U1 p
U1

-- The sum type level -----------------------------------------------------

-- | Construct and deconstruct cases in a `SOP`
class SopList xs ys where
  injectSOPLeft :: SOP xs -> SOP (Append xs ys)
  injectSOPRight :: SOP ys -> SOP (Append xs ys)
  caseSOP :: SOP (Append xs ys) -> Sum (SOP xs) (SOP ys)

instance SopList '[c ::: x] (y : ys) where
  injectSOPLeft :: SOP '[c ::: x] -> SOP (Append '[c ::: x] (y : ys))
injectSOPLeft = forall a b. a -> Sum a b
SumLeft
  injectSOPRight :: SOP (y : ys) -> SOP (Append '[c ::: x] (y : ys))
injectSOPRight = forall a b. b -> Sum a b
SumRight
  caseSOP :: SOP (Append '[c ::: x] (y : ys))
-> Sum (SOP '[c ::: x]) (SOP (y : ys))
caseSOP = forall a. a -> a
id

instance SopList (x' : xs) (y : ys) => SopList (c ::: x : x' : xs) (y : ys) where
  injectSOPLeft :: SOP ((c ::: x) : x' : xs)
-> SOP (Append ((c ::: x) : x' : xs) (y : ys))
injectSOPLeft (SumLeft ProdOver x
a) = forall a b. a -> Sum a b
SumLeft ProdOver x
a
  injectSOPLeft (SumRight SOP (x' : xs)
b) = forall a b. b -> Sum a b
SumRight (forall (xs :: [*]) (ys :: [*]).
SopList xs ys =>
SOP xs -> SOP (Append xs ys)
injectSOPLeft @(x' : xs) @(y : ys) SOP (x' : xs)
b)

  injectSOPRight :: SOP (y : ys) -> SOP (Append ((c ::: x) : x' : xs) (y : ys))
injectSOPRight SOP (y : ys)
a = forall a b. b -> Sum a b
SumRight (forall (xs :: [*]) (ys :: [*]).
SopList xs ys =>
SOP ys -> SOP (Append xs ys)
injectSOPRight @(x' : xs) @(y : ys) SOP (y : ys)
a)

  caseSOP :: SOP (Append ((c ::: x) : x' : xs) (y : ys))
-> Sum (SOP ((c ::: x) : x' : xs)) (SOP (y : ys))
caseSOP (SumLeft ProdOver x
a) = forall a b. a -> Sum a b
SumLeft (forall a b. a -> Sum a b
SumLeft ProdOver x
a)
  caseSOP (SumRight SOP (x' : Append xs (y : ys))
b) = case forall (xs :: [*]) (ys :: [*]).
SopList xs ys =>
SOP (Append xs ys) -> Sum (SOP xs) (SOP ys)
caseSOP @(x' : xs) @(y : ys) SOP (x' : Append xs (y : ys))
b of
    SumLeft SOP (x' : xs)
b' -> forall a b. a -> Sum a b
SumLeft (forall a b. b -> Sum a b
SumRight SOP (x' : xs)
b')
    SumRight SOP (y : ys)
b' -> forall a b. b -> Sum a b
SumRight SOP (y : ys)
b'

class SimpleGeneric rep where
  toSimpleRep' :: rep p -> SimplifyRep rep
  fromSimpleRep' :: SimplifyRep rep -> rep p

instance SimpleGeneric f => SimpleGeneric (D1 d f) where
  toSimpleRep' :: forall p. D1 d f p -> SimplifyRep (D1 d f)
toSimpleRep' (M1 f p
f) = forall (rep :: * -> *) p.
SimpleGeneric rep =>
rep p -> SimplifyRep rep
toSimpleRep' f p
f
  fromSimpleRep' :: forall p. SimplifyRep (D1 d f) -> D1 d f p
fromSimpleRep' SimplifyRep (D1 d f)
a = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (forall (rep :: * -> *) p.
SimpleGeneric rep =>
SimplifyRep rep -> rep p
fromSimpleRep' SimplifyRep (D1 d f)
a)

instance
  ( SimpleGeneric f
  , SimpleGeneric g
  , SopList (SOPOf f) (SOPOf g)
  ) =>
  SimpleGeneric (f :+: g)
  where
  toSimpleRep' :: forall p. (:+:) f g p -> SimplifyRep (f :+: g)
toSimpleRep' (L1 f p
f) = forall (xs :: [*]) (ys :: [*]).
SopList xs ys =>
SOP xs -> SOP (Append xs ys)
injectSOPLeft @(SOPOf f) @(SOPOf g) forall a b. (a -> b) -> a -> b
$ forall (rep :: * -> *) p.
SimpleGeneric rep =>
rep p -> SimplifyRep rep
toSimpleRep' f p
f
  toSimpleRep' (R1 g p
g) = forall (xs :: [*]) (ys :: [*]).
SopList xs ys =>
SOP ys -> SOP (Append xs ys)
injectSOPRight @(SOPOf f) @(SOPOf g) forall a b. (a -> b) -> a -> b
$ forall (rep :: * -> *) p.
SimpleGeneric rep =>
rep p -> SimplifyRep rep
toSimpleRep' g p
g
  fromSimpleRep' :: forall p. SimplifyRep (f :+: g) -> (:+:) f g p
fromSimpleRep' SimplifyRep (f :+: g)
sop =
    case forall (xs :: [*]) (ys :: [*]).
SopList xs ys =>
SOP (Append xs ys) -> Sum (SOP xs) (SOP ys)
caseSOP @(SOPOf f) @(SOPOf g) SimplifyRep (f :+: g)
sop of
      SumLeft SOP (SOPOf f)
l -> forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (forall (rep :: * -> *) p.
SimpleGeneric rep =>
SimplifyRep rep -> rep p
fromSimpleRep' SOP (SOPOf f)
l)
      SumRight SOP (SOPOf g)
r -> forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (forall (rep :: * -> *) p.
SimpleGeneric rep =>
SimplifyRep rep -> rep p
fromSimpleRep' SOP (SOPOf g)
r)

instance SimpleConstructor f => SimpleGeneric (C1 ('MetaCons c a b) f) where
  toSimpleRep' :: forall p.
C1 ('MetaCons c a b) f p -> SimplifyRep (C1 ('MetaCons c a b) f)
toSimpleRep' (M1 f p
f) = forall (rep :: * -> *) p.
SimpleConstructor rep =>
rep p -> ProdOver (Constr rep)
toSimpleCon' f p
f
  fromSimpleRep' :: forall p.
SimplifyRep (C1 ('MetaCons c a b) f) -> C1 ('MetaCons c a b) f p
fromSimpleRep' SimplifyRep (C1 ('MetaCons c a b) f)
a = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (forall (rep :: * -> *) p.
SimpleConstructor rep =>
ProdOver (Constr rep) -> rep p
fromSimpleCon' SimplifyRep (C1 ('MetaCons c a b) f)
a)

------------------------------------------------------------------------
-- Sums and folds
------------------------------------------------------------------------

class HasSpec fn a => Foldy fn a where
  genList ::
    (BaseUniverse fn, MonadGenError m) => Specification fn a -> Specification fn a -> GenT m [a]
  theAddFn :: fn '[a, a] a
  theZero :: a

adds :: forall fn a. Foldy fn a => [a] -> a
adds :: forall (fn :: [*] -> * -> *) a. Foldy fn a => [a] -> a
adds = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall (fn :: [*] -> * -> *) (as :: [*]) b.
FunctionLike fn =>
fn as b -> FunTy as b
sem forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a. Foldy fn a => fn '[a, a] a
theAddFn @fn) (forall (fn :: [*] -> * -> *) a. Foldy fn a => a
theZero @fn)

data FoldSpec (fn :: [Type] -> Type -> Type) a where
  NoFold :: FoldSpec fn a
  FoldSpec ::
    forall b fn a.
    ( HasSpec fn a
    , HasSpec fn b
    , Foldy fn b
    , Member (ListFn fn) fn
    , BaseUniverse fn
    ) =>
    fn '[a] b ->
    Specification fn b ->
    FoldSpec fn a

instance {-# OVERLAPPABLE #-} (Arbitrary a, Arbitrary (TypeSpec fn a), Foldy fn a, BaseUniverse fn) => Arbitrary (FoldSpec fn a) where
  arbitrary :: Gen (FoldSpec fn a)
arbitrary = forall a. HasCallStack => [Gen a] -> Gen a
oneof [forall a (fn :: [*] -> * -> *) a.
(HasSpec fn a, HasSpec fn a, Foldy fn a, Member (ListFn fn) fn,
 BaseUniverse fn) =>
fn '[a] a -> Specification fn a -> FoldSpec fn a
FoldSpec forall (fn :: [*] -> * -> *) a. Member (FunFn fn) fn => fn '[a] a
idFn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (fn :: [*] -> * -> *) a. FoldSpec fn a
NoFold]
  shrink :: FoldSpec fn a -> [FoldSpec fn a]
shrink FoldSpec fn a
NoFold = []
  shrink (FoldSpec (forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fnU as b -> Maybe (fn as b)
extractFn @(FunFn fn) @fn -> Just FunFn fn '[a] b
Id) Specification fn b
spec) = forall a (fn :: [*] -> * -> *) a.
(HasSpec fn a, HasSpec fn a, Foldy fn a, Member (ListFn fn) fn,
 BaseUniverse fn) =>
fn '[a] a -> Specification fn a -> FoldSpec fn a
FoldSpec forall (fn :: [*] -> * -> *) a. Member (FunFn fn) fn => fn '[a] a
idFn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => a -> [a]
shrink Specification fn b
spec
  shrink FoldSpec {} = [forall (fn :: [*] -> * -> *) a. FoldSpec fn a
NoFold]

preMapFoldSpec :: HasSpec fn a => fn '[a] b -> FoldSpec fn b -> FoldSpec fn a
preMapFoldSpec :: forall (fn :: [*] -> * -> *) a b.
HasSpec fn a =>
fn '[a] b -> FoldSpec fn b -> FoldSpec fn a
preMapFoldSpec fn '[a] b
_ FoldSpec fn b
NoFold = forall (fn :: [*] -> * -> *) a. FoldSpec fn a
NoFold
preMapFoldSpec fn '[a] b
f (FoldSpec fn '[b] b
g Specification fn b
s) = forall a (fn :: [*] -> * -> *) a.
(HasSpec fn a, HasSpec fn a, Foldy fn a, Member (ListFn fn) fn,
 BaseUniverse fn) =>
fn '[a] a -> Specification fn a -> FoldSpec fn a
FoldSpec (forall (fn :: [*] -> * -> *) b a c.
(Member (FunFn fn) fn, HasSpec fn b, Show (fn '[a] b),
 Show (fn '[b] c), Eq (fn '[a] b), Eq (fn '[b] c)) =>
fn '[b] c -> fn '[a] b -> fn '[a] c
composeFn fn '[b] b
g fn '[a] b
f) Specification fn b
s

combineFoldSpec :: FoldSpec fn a -> FoldSpec fn a -> Either [String] (FoldSpec fn a)
combineFoldSpec :: forall (fn :: [*] -> * -> *) a.
FoldSpec fn a -> FoldSpec fn a -> Either [[Char]] (FoldSpec fn a)
combineFoldSpec FoldSpec fn a
NoFold FoldSpec fn a
s = forall (f :: * -> *) a. Applicative f => a -> f a
pure FoldSpec fn a
s
combineFoldSpec FoldSpec fn a
s FoldSpec fn a
NoFold = forall (f :: * -> *) a. Applicative f => a -> f a
pure FoldSpec fn a
s
combineFoldSpec (FoldSpec (fn '[a] b
f :: fn as b) Specification fn b
s) (FoldSpec (fn '[a] b
f' :: fn' as' b') Specification fn b
s')
  | Just b :~: b
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @b @b'
  , Just fn :~: fn
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @fn @fn'
  , fn '[a] b
f forall a. Eq a => a -> a -> Bool
== fn '[a] b
f' =
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a (fn :: [*] -> * -> *) a.
(HasSpec fn a, HasSpec fn a, Foldy fn a, Member (ListFn fn) fn,
 BaseUniverse fn) =>
fn '[a] a -> Specification fn a -> FoldSpec fn a
FoldSpec fn '[a] b
f (Specification fn b
s forall a. Semigroup a => a -> a -> a
<> Specification fn b
s')
  | Bool
otherwise =
      forall a b. a -> Either a b
Left [[Char]
"Can't combine fold specs on different functions", [Char]
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show fn '[a] b
f, [Char]
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show fn '[a] b
f']

conformsToFoldSpec :: forall fn a. [a] -> FoldSpec fn a -> Bool
conformsToFoldSpec :: forall (fn :: [*] -> * -> *) a. [a] -> FoldSpec fn a -> Bool
conformsToFoldSpec [a]
_ FoldSpec fn a
NoFold = Bool
True
conformsToFoldSpec [a]
xs (FoldSpec fn '[a] b
f Specification fn b
s) = forall (fn :: [*] -> * -> *) a. Foldy fn a => [a] -> a
adds @fn (forall a b. (a -> b) -> [a] -> [b]
map (forall (fn :: [*] -> * -> *) (as :: [*]) b.
FunctionLike fn =>
fn as b -> FunTy as b
sem fn '[a] b
f) [a]
xs) forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
`conformsToSpec` Specification fn b
s

toPredsFoldSpec :: forall fn a. BaseUniverse fn => Term fn [a] -> FoldSpec fn a -> Pred fn
toPredsFoldSpec :: forall (fn :: [*] -> * -> *) a.
BaseUniverse fn =>
Term fn [a] -> FoldSpec fn a -> Pred fn
toPredsFoldSpec Term fn [a]
_ FoldSpec fn a
NoFold = forall (fn :: [*] -> * -> *). Pred fn
TruePred
toPredsFoldSpec Term fn [a]
x (FoldSpec fn '[a] b
fn Specification fn b
sspec) =
  forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Specification fn a -> Pred fn
satisfies (forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app (forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, Foldy fn b, Show (fn '[a] b), Eq (fn '[a] b)) =>
fn '[a] b -> fn '[[a]] b
foldMapFn fn '[a] b
fn) Term fn [a]
x) Specification fn b
sspec

-- | Note: potentially infinite list
enumerateInterval :: (Enum a, Num a, Ord a, MaybeBounded a) => NumSpec fn a -> [a]
enumerateInterval :: forall a (fn :: [*] -> * -> *).
(Enum a, Num a, Ord a, MaybeBounded a) =>
NumSpec fn a -> [a]
enumerateInterval (NumSpecInterval Maybe a
lo Maybe a
hi) =
  case (Maybe a
lo forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. MaybeBounded a => Maybe a
lowerBound, Maybe a
hi forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. MaybeBounded a => Maybe a
upperBound) of
    (Maybe a
Nothing, Maybe a
Nothing) -> forall a. [a] -> [a] -> [a]
interleave [a
0 ..] [-a
1, -a
2 ..]
    (Maybe a
Nothing, Just a
b) -> [a
b, a
b forall a. Num a => a -> a -> a
- a
1 ..]
    (Just a
a, Maybe a
Nothing) -> [a
a ..]
    (Just a
a, Just a
b) -> [a
a .. a
b]
  where
    interleave :: [a] -> [a] -> [a]
interleave [] [a]
ys = [a]
ys
    interleave (a
x : [a]
xs) [a]
ys = a
x forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
interleave [a]
ys [a]
xs

isEmptyNumSpec ::
  (TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a, MaybeBounded a) => Specification fn a -> Bool
isEmptyNumSpec :: forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Bool
isEmptyNumSpec = \case
  ExplainSpec [[Char]]
_ Specification fn a
s -> forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Bool
isEmptyNumSpec Specification fn a
s
  ErrorSpec {} -> Bool
True
  Specification fn a
TrueSpec -> Bool
False
  MemberSpec NonEmpty a
_ -> Bool
False -- MemberSpec always has at least one element (NE.NonEmpty)
  SuspendedSpec {} -> Bool
False
  TypeSpec TypeSpec fn a
i OrdSet a
cant -> forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ forall a (fn :: [*] -> * -> *).
(Enum a, Num a, Ord a, MaybeBounded a) =>
NumSpec fn a -> [a]
enumerateInterval TypeSpec fn a
i forall a. Eq a => [a] -> [a] -> [a]
\\ OrdSet a
cant

knownUpperBound ::
  (TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a, MaybeBounded a) =>
  Specification fn a ->
  Maybe a
knownUpperBound :: forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownUpperBound (ExplainSpec [[Char]]
_ Specification fn a
s) = forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownUpperBound Specification fn a
s
knownUpperBound Specification fn a
TrueSpec = forall a. MaybeBounded a => Maybe a
upperBound
knownUpperBound (MemberSpec NonEmpty a
as) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum NonEmpty a
as
knownUpperBound ErrorSpec {} = forall a. Maybe a
Nothing
knownUpperBound SuspendedSpec {} = forall a. MaybeBounded a => Maybe a
upperBound
knownUpperBound (TypeSpec (NumSpecInterval Maybe a
lo Maybe a
hi) OrdSet a
cant) = Maybe a -> Maybe a -> Maybe a
upper (Maybe a
lo forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. MaybeBounded a => Maybe a
lowerBound) (Maybe a
hi forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. MaybeBounded a => Maybe a
upperBound)
  where
    upper :: Maybe a -> Maybe a -> Maybe a
upper Maybe a
_ Maybe a
Nothing = forall a. Maybe a
Nothing
    upper Maybe a
Nothing (Just a
b) = forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ [a
b, a
b forall a. Num a => a -> a -> a
- a
1 ..] forall a. Eq a => [a] -> [a] -> [a]
\\ OrdSet a
cant
    upper (Just a
a) (Just a
b)
      | a
a forall a. Eq a => a -> a -> Bool
== a
b = a
a forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (f :: * -> *). Alternative f => Bool -> f ()
guard (a
a forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` OrdSet a
cant)
      | Bool
otherwise = forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ [a
b, a
b forall a. Num a => a -> a -> a
- a
1 .. a
a] forall a. Eq a => [a] -> [a] -> [a]
\\ OrdSet a
cant

knownLowerBound ::
  (TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a, MaybeBounded a) =>
  Specification fn a ->
  Maybe a
knownLowerBound :: forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownLowerBound (ExplainSpec [[Char]]
_ Specification fn a
s) = forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownLowerBound Specification fn a
s
knownLowerBound Specification fn a
TrueSpec = forall a. MaybeBounded a => Maybe a
lowerBound
knownLowerBound (MemberSpec NonEmpty a
as) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum NonEmpty a
as
knownLowerBound ErrorSpec {} = forall a. Maybe a
Nothing
knownLowerBound SuspendedSpec {} = forall a. MaybeBounded a => Maybe a
lowerBound
knownLowerBound (TypeSpec (NumSpecInterval Maybe a
lo Maybe a
hi) OrdSet a
cant) =
  Maybe a -> Maybe a -> Maybe a
lower (Maybe a
lo forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. MaybeBounded a => Maybe a
lowerBound) (Maybe a
hi forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. MaybeBounded a => Maybe a
upperBound)
  where
    lower :: Maybe a -> Maybe a -> Maybe a
lower Maybe a
Nothing Maybe a
_ = forall a. Maybe a
Nothing
    lower (Just a
a) Maybe a
Nothing = forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ [a
a, a
a forall a. Num a => a -> a -> a
+ a
1 ..] forall a. Eq a => [a] -> [a] -> [a]
\\ OrdSet a
cant
    lower (Just a
a) (Just a
b)
      | a
a forall a. Eq a => a -> a -> Bool
== a
b = a
a forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (f :: * -> *). Alternative f => Bool -> f ()
guard (a
a forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` OrdSet a
cant)
      | Bool
otherwise = forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ [a
a, a
a forall a. Num a => a -> a -> a
+ a
1 .. a
b] forall a. Eq a => [a] -> [a] -> [a]
\\ OrdSet a
cant

narrowByFuelAndSize ::
  forall a fn.
  ( BaseUniverse fn
  , TypeSpec fn a ~ NumSpec fn a
  , HasSpec fn a
  , Arbitrary a
  , Integral a
  , Ord a
  , Random a
  , MaybeBounded a
  ) =>
  -- | Fuel
  a ->
  -- | Integer
  Int ->
  (Specification fn a, Specification fn a) ->
  (Specification fn a, Specification fn a)
narrowByFuelAndSize :: forall a (fn :: [*] -> * -> *).
(BaseUniverse fn, TypeSpec fn a ~ NumSpec fn a, HasSpec fn a,
 Arbitrary a, Integral a, Ord a, Random a, MaybeBounded a) =>
a
-> Int
-> (Specification fn a, Specification fn a)
-> (Specification fn a, Specification fn a)
narrowByFuelAndSize a
fuel Int
size (Specification fn a, Specification fn a)
specs =
  Int
-> (Specification fn a, Specification fn a)
-> (Specification fn a, Specification fn a)
loop (Int
100 :: Int) ((Specification fn a, Specification fn a)
-> (Specification fn a, Specification fn a)
onlyOnceTransformations forall a b. (a -> b) -> a -> b
$ forall a (fn :: [*] -> * -> *).
(BaseUniverse fn, TypeSpec fn a ~ NumSpec fn a, HasSpec fn a,
 Arbitrary a, Integral a, Ord a, Random a, MaybeBounded a) =>
(Specification fn a, Specification fn a)
-> (Specification fn a, Specification fn a)
narrowFoldSpecs (Specification fn a, Specification fn a)
specs)
  where
    loop :: Int
-> (Specification fn a, Specification fn a)
-> (Specification fn a, Specification fn a)
loop Int
0 (Specification fn a, Specification fn a)
specs =
      forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$
        [[Char]] -> [Char]
unlines
          [ [Char]
"narrowByFuelAndSize loops:"
          , [Char]
"  fuel = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
fuel
          , [Char]
"  size = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
size
          , [Char]
"  specs = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Specification fn a, Specification fn a)
specs
          , [Char]
"  narrowFoldSpecs spec = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a (fn :: [*] -> * -> *).
(BaseUniverse fn, TypeSpec fn a ~ NumSpec fn a, HasSpec fn a,
 Arbitrary a, Integral a, Ord a, Random a, MaybeBounded a) =>
(Specification fn a, Specification fn a)
-> (Specification fn a, Specification fn a)
narrowFoldSpecs (Specification fn a, Specification fn a)
specs)
          , [Char]
"  go (narrowFoldSpecs specs) = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ((Specification fn a, Specification fn a)
-> Maybe (Specification fn a, Specification fn a)
go (forall a (fn :: [*] -> * -> *).
(BaseUniverse fn, TypeSpec fn a ~ NumSpec fn a, HasSpec fn a,
 Arbitrary a, Integral a, Ord a, Random a, MaybeBounded a) =>
(Specification fn a, Specification fn a)
-> (Specification fn a, Specification fn a)
narrowFoldSpecs (Specification fn a, Specification fn a)
specs))
          ]
    loop Int
n (Specification fn a, Specification fn a)
specs = case (Specification fn a, Specification fn a)
-> Maybe (Specification fn a, Specification fn a)
go (Specification fn a, Specification fn a)
specs of
      Maybe (Specification fn a, Specification fn a)
Nothing -> (Specification fn a, Specification fn a)
specs
      Just (Specification fn a, Specification fn a)
specs' -> Int
-> (Specification fn a, Specification fn a)
-> (Specification fn a, Specification fn a)
loop (Int
n forall a. Num a => a -> a -> a
- Int
1) (forall a (fn :: [*] -> * -> *).
(BaseUniverse fn, TypeSpec fn a ~ NumSpec fn a, HasSpec fn a,
 Arbitrary a, Integral a, Ord a, Random a, MaybeBounded a) =>
(Specification fn a, Specification fn a)
-> (Specification fn a, Specification fn a)
narrowFoldSpecs (Specification fn a, Specification fn a)
specs')

    -- Transformations only applied once. It's annoying to check if you're
    -- going to change the spec with these so easier to just make sure you only apply
    -- these once
    onlyOnceTransformations :: (Specification fn a, Specification fn a)
-> (Specification fn a, Specification fn a)
onlyOnceTransformations (Specification fn a
elemS, Specification fn a
foldS)
      | a
fuel forall a. Eq a => a -> a -> Bool
== a
1 = (Specification fn a
elemS forall a. Semigroup a => a -> a -> a
<> Specification fn a
foldS, Specification fn a
foldS)
      | Bool
otherwise = (Specification fn a
elemS, Specification fn a
foldS)

    canReach :: t -> t -> t -> Bool
canReach t
_ t
0 t
s = t
s forall a. Eq a => a -> a -> Bool
== t
0
    canReach t
e t
fuel t
s
      -- You can reach it in one step
      | t
s forall a. Ord a => a -> a -> Bool
<= t
e = t
0 forall a. Ord a => a -> a -> Bool
< t
fuel
      | Bool
otherwise = t -> t -> t -> Bool
canReach t
e (t
fuel forall a. Num a => a -> a -> a
- t
1) (t
s forall a. Num a => a -> a -> a
- t
e)

    -- Precondition:
    --   a is negative
    --   the type has more negative numbers than positive ones
    safeNegate :: p -> p
safeNegate p
a
      | Just p
u <- forall a. MaybeBounded a => Maybe a
upperBound
      , p
a forall a. Ord a => a -> a -> Bool
< forall a. Num a => a -> a
negate p
u =
          p
u
      | Bool
otherwise = forall a. Num a => a -> a
negate p
a

    divCeil :: p -> p -> p
divCeil p
a p
b
      | p
b forall a. Num a => a -> a -> a
* p
d forall a. Ord a => a -> a -> Bool
< p
a = p
d forall a. Num a => a -> a -> a
+ p
1
      | Bool
otherwise = p
d
      where
        d :: p
d = p
a forall a. Integral a => a -> a -> a
`div` p
b

    go :: (Specification fn a, Specification fn a)
-> Maybe (Specification fn a, Specification fn a)
go (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn a -> Specification fn a
simplifySpec -> Specification fn a
elemS, forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn a -> Specification fn a
simplifySpec -> Specification fn a
foldS)
      -- There is nothing we can do
      | a
fuel forall a. Eq a => a -> a -> Bool
== a
0 = forall a. Maybe a
Nothing
      | ErrorSpec {} <- Specification fn a
elemS = forall a. Maybe a
Nothing
      | ErrorSpec {} <- Specification fn a
foldS = forall a. Maybe a
Nothing
      -- Give up as early as possible
      | Just a
0 <- forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownUpperBound Specification fn a
elemS
      , Just a
0 <- forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownLowerBound Specification fn a
elemS
      , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ a
0 forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
`conformsToSpec` Specification fn a
foldS =
          forall a. a -> Maybe a
Just (forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec (forall a. [a] -> NonEmpty a
NE.fromList [[Char]
"only 0 left"]), Specification fn a
foldS)
      -- Make sure we try to generate the smallest possible list
      -- that gives you the right result - don't put a bunch of zeroes in
      -- a _small_ (size 0) list.
      | Int
size forall a. Eq a => a -> a -> Bool
== Int
0
      , a
0 forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
`conformsToSpec` Specification fn a
elemS =
          forall a. a -> Maybe a
Just (Specification fn a
elemS forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a
notEqualSpec a
0, Specification fn a
foldS)
      -- Member specs with non-zero elements, TODO: explain
      | MemberSpec NonEmpty a
ys <- Specification fn a
elemS
      , let xs :: [a]
xs = forall a. NonEmpty a -> [a]
NE.toList NonEmpty a
ys
      , Just a
u <- forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownUpperBound Specification fn a
foldS
      , forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a
0 forall a. Ord a => a -> a -> Bool
<=) [a]
xs
      , forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (a
0 forall a. Ord a => a -> a -> Bool
<) [a]
xs
      , let xMinP :: a
xMinP = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (a
0 forall a. Ord a => a -> a -> Bool
<) [a]
xs
            possible :: a -> Bool
possible a
x = a
x forall a. Eq a => a -> a -> Bool
== a
u Bool -> Bool -> Bool
|| a
xMinP forall a. Ord a => a -> a -> Bool
<= a
u forall a. Num a => a -> a -> a
- a
x
            xs' :: [a]
xs' = forall a. (a -> Bool) -> [a] -> [a]
filter a -> Bool
possible [a]
xs
      , [a]
xs' forall a. Eq a => a -> a -> Bool
/= [a]
xs =
          forall a. a -> Maybe a
Just (forall a (fn :: [*] -> * -> *).
[a] -> NonEmpty [Char] -> Specification fn a
memberSpecList (forall a. Ord a => [a] -> [a]
nubOrd [a]
xs') (forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
"None of " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [a]
xs forall a. [a] -> [a] -> [a]
++ [Char]
" are possible")), Specification fn a
foldS)
      -- The lower bound on the number of elements is too low
      | Just a
e <- forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownLowerBound Specification fn a
elemS
      , a
e forall a. Ord a => a -> a -> Bool
> a
0
      , Just a
s <- forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownLowerBound Specification fn a
foldS
      , a
s forall a. Ord a => a -> a -> Bool
> a
0
      , let c :: a
c = forall a. Integral a => a -> a -> a
divCeil a
s a
fuel
      , a
e forall a. Ord a => a -> a -> Bool
< a
c =
          forall a. a -> Maybe a
Just (Specification fn a
elemS forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
geqSpec @fn a
c, Specification fn a
foldS)
      -- The upper bound on the number of elements is too high
      | Just a
e <- forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownUpperBound Specification fn a
elemS
      , a
e forall a. Ord a => a -> a -> Bool
< a
0
      , Just a
s <- forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownUpperBound Specification fn a
foldS
      , a
s forall a. Ord a => a -> a -> Bool
< a
0
      , let c :: a
c = forall a. Integral a => a -> a -> a
divCeil (forall {p}. (MaybeBounded p, Ord p, Num p) => p -> p
safeNegate a
s) a
fuel
      , forall a. Num a => a -> a
negate a
c forall a. Ord a => a -> a -> Bool
< a
e
      , forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (a
c forall a. Ord a => a -> a -> Bool
<) (forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownUpperBound Specification fn a
elemS) =
          forall a. a -> Maybe a
Just (Specification fn a
elemS forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
leqSpec @fn a
c, Specification fn a
foldS)
      -- It's time to stop generating negative numbers
      | Just a
s <- forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownLowerBound Specification fn a
foldS
      , a
s forall a. Ord a => a -> a -> Bool
> a
0
      , Just a
e <- forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownUpperBound Specification fn a
elemS
      , a
e forall a. Ord a => a -> a -> Bool
> a
0
      , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall {t} {t}. (Num t, Num t, Ord t, Ord t) => t -> t -> t -> Bool
canReach a
e (a
fuel forall a. Integral a => a -> a -> a
`div` a
2 forall a. Num a => a -> a -> a
+ a
1) a
s
      , forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (forall a. Ord a => a -> a -> Bool
<= a
0) (forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownLowerBound Specification fn a
elemS) =
          forall a. a -> Maybe a
Just (Specification fn a
elemS forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
gtSpec @fn a
0, Specification fn a
foldS)
      -- It's time to stop generating positive numbers
      | Just a
s <- forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownUpperBound Specification fn a
foldS
      , a
s forall a. Ord a => a -> a -> Bool
< a
0
      , Just a
e <- forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownLowerBound Specification fn a
elemS
      , a
e forall a. Ord a => a -> a -> Bool
< a
0
      , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall {t} {t}. (Num t, Num t, Ord t, Ord t) => t -> t -> t -> Bool
canReach (forall {p}. (MaybeBounded p, Ord p, Num p) => p -> p
safeNegate a
e) (a
fuel forall a. Integral a => a -> a -> a
`div` a
2 forall a. Num a => a -> a -> a
+ a
1) (forall {p}. (MaybeBounded p, Ord p, Num p) => p -> p
safeNegate a
s)
      , forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (a
0 forall a. Ord a => a -> a -> Bool
<=) (forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownUpperBound Specification fn a
elemS) =
          forall a. a -> Maybe a
Just (Specification fn a
elemS forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
ltSpec @fn a
0, Specification fn a
foldS)
      -- There is nothing we need to do
      | Bool
otherwise = forall a. Maybe a
Nothing

narrowFoldSpecs ::
  forall a fn.
  ( BaseUniverse fn
  , TypeSpec fn a ~ NumSpec fn a
  , HasSpec fn a
  , Arbitrary a
  , Integral a
  , Ord a
  , Random a
  , MaybeBounded a
  ) =>
  (Specification fn a, Specification fn a) ->
  (Specification fn a, Specification fn a)
narrowFoldSpecs :: forall a (fn :: [*] -> * -> *).
(BaseUniverse fn, TypeSpec fn a ~ NumSpec fn a, HasSpec fn a,
 Arbitrary a, Integral a, Ord a, Random a, MaybeBounded a) =>
(Specification fn a, Specification fn a)
-> (Specification fn a, Specification fn a)
narrowFoldSpecs (Specification fn a, Specification fn a)
specs = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Specification fn a, Specification fn a)
specs forall a (fn :: [*] -> * -> *).
(BaseUniverse fn, TypeSpec fn a ~ NumSpec fn a, HasSpec fn a,
 Arbitrary a, Integral a, Ord a, Random a, MaybeBounded a) =>
(Specification fn a, Specification fn a)
-> (Specification fn a, Specification fn a)
narrowFoldSpecs (forall {fn :: [*] -> * -> *} {a} {fn :: [*] -> * -> *}.
(TypeSpec fn a ~ NumSpec fn a, TypeSpec fn a ~ NumSpec fn a,
 HasSpec fn a, HasSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
(Specification fn a, Specification fn a)
-> Maybe (Specification fn a, Specification fn a)
go (Specification fn a, Specification fn a)
specs)
  where
    -- Note: make sure there is some progress when returning Just or this will loop forever
    go :: (Specification fn a, Specification fn a)
-> Maybe (Specification fn a, Specification fn a)
go (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn a -> Specification fn a
simplifySpec -> Specification fn a
elemS, forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn a -> Specification fn a
simplifySpec -> Specification fn a
foldS) = case (Specification fn a
elemS, Specification fn a
foldS) of
      -- Empty foldSpec
      (Specification fn a
_, ErrorSpec {}) -> forall a. Maybe a
Nothing
      (Specification fn a, Specification fn a)
_ | forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Bool
isEmptyNumSpec Specification fn a
foldS -> forall a. a -> Maybe a
Just (Specification fn a
elemS, forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec (forall a. [a] -> NonEmpty a
NE.fromList [[Char]
"Empty foldSpec:", forall a. Show a => a -> [Char]
show Specification fn a
foldS]))
      -- Empty elemSpec
      (ErrorSpec {}, MemberSpec NonEmpty a
ys) | forall a. NonEmpty a -> [a]
NE.toList NonEmpty a
ys forall a. Eq a => a -> a -> Bool
== [a
0] -> forall a. Maybe a
Nothing
      (ErrorSpec {}, Specification fn a
_)
        | a
0 forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
`conformsToSpec` Specification fn a
foldS -> forall a. a -> Maybe a
Just (Specification fn a
elemS, forall a (fn :: [*] -> * -> *). NonEmpty a -> Specification fn a
MemberSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure a
0))
        | Bool
otherwise ->
            forall a. a -> Maybe a
Just
              ( Specification fn a
elemS
              , forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec forall a b. (a -> b) -> a -> b
$
                  forall a. [a] -> NonEmpty a
NE.fromList
                    [ [Char]
"Empty elemSpec and non-zero foldSpec"
                    , forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall ann. Int -> Doc ann -> Doc ann
indent Int
2 forall a b. (a -> b) -> a -> b
$ Doc Any
"elemSpec =" forall ann. Doc ann -> Doc ann -> Doc ann
/> forall a ann. Pretty a => a -> Doc ann
pretty Specification fn a
elemS
                    , forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall ann. Int -> Doc ann -> Doc ann
indent Int
2 forall a b. (a -> b) -> a -> b
$ Doc Any
"foldSpec =" forall ann. Doc ann -> Doc ann -> Doc ann
/> forall a ann. Pretty a => a -> Doc ann
pretty Specification fn a
foldS
                    ]
              )
      -- We can reduce the size of the `elemS` interval when it is
      -- `[l, u]` or `[l, ∞)` given that `0 <= l` and we have
      -- an upper bound on the sum - we can't pick things bigger than the
      -- upper bound.
      (Specification fn a, Specification fn a)
_
        | Just a
lo <- forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownLowerBound Specification fn a
elemS
        , a
0 forall a. Ord a => a -> a -> Bool
<= a
lo
        , Just a
hi <- forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownUpperBound Specification fn a
foldS
        , -- Check that we will actually be making the set smaller
          forall a. a -> Maybe a -> a
fromMaybe Bool
True ((a
hi forall a. Ord a => a -> a -> Bool
<) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownUpperBound Specification fn a
elemS) ->
            forall a. a -> Maybe a
Just (Specification fn a
elemS forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec (forall (fn :: [*] -> * -> *) n. Maybe n -> Maybe n -> NumSpec fn n
NumSpecInterval (forall a. a -> Maybe a
Just a
lo) (forall a. a -> Maybe a
Just a
hi)), Specification fn a
foldS)
      -- We can reduce the size of the foldS set by bumping the lower bound when
      -- there is a positive lower bound on the elemS, we can't generate things smaller
      -- than the lower bound on `elemS`.
      (Specification fn a, Specification fn a)
_
        | Just a
lo <- forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownLowerBound Specification fn a
elemS
        , a
0 forall a. Ord a => a -> a -> Bool
<= a
lo
        , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ a
0 forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
`conformsToSpec` Specification fn a
foldS
        , -- Check that we will actually be making the set smaller
          forall a. a -> Maybe a -> a
fromMaybe Bool
True ((a
lo forall a. Ord a => a -> a -> Bool
>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownLowerBound Specification fn a
foldS) ->
            forall a. a -> Maybe a
Just (Specification fn a
elemS, Specification fn a
foldS forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec (forall (fn :: [*] -> * -> *) n. Maybe n -> Maybe n -> NumSpec fn n
NumSpecInterval (forall a. a -> Maybe a
Just a
lo) forall a. Maybe a
Nothing))
      -- NOTE: this is far from sufficient, but it's good enough of an approximation
      -- to avoid the worst failures.
      (Specification fn a, Specification fn a)
_
        | Just a
lo <- forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownLowerBound Specification fn a
elemS
        , Just a
loS <- forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownLowerBound Specification fn a
foldS
        , Just a
hi <- forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownUpperBound Specification fn a
elemS
        , Just a
hiS <- forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownUpperBound Specification fn a
foldS
        , a
hi forall a. Ord a => a -> a -> Bool
< a
loS
        , a
lo forall a. Ord a => a -> a -> Bool
> a
hiS forall a. Num a => a -> a -> a
- a
lo ->
            forall a. a -> Maybe a
Just
              ( forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec forall a b. (a -> b) -> a -> b
$ forall a. [a] -> NonEmpty a
NE.fromList [[Char]
"Can't solve diophantine equation"]
              , forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec forall a b. (a -> b) -> a -> b
$ forall a. [a] -> NonEmpty a
NE.fromList [[Char]
"Can't solve diophantine equation"]
              )
      (Specification fn a, Specification fn a)
_ -> forall a. Maybe a
Nothing

genNumList ::
  forall a fn m.
  ( BaseUniverse fn
  , MonadGenError m
  , TypeSpec fn a ~ NumSpec fn a
  , HasSpec fn a
  , Arbitrary a
  , Integral a
  , Ord a
  , Random a
  , MaybeBounded a
  , Foldy fn a
  ) =>
  Specification fn a ->
  Specification fn a ->
  GenT m [a]
genNumList :: forall a (fn :: [*] -> * -> *) (m :: * -> *).
(BaseUniverse fn, MonadGenError m, TypeSpec fn a ~ NumSpec fn a,
 HasSpec fn a, Arbitrary a, Integral a, Ord a, Random a,
 MaybeBounded a, Foldy fn a) =>
Specification fn a -> Specification fn a -> GenT m [a]
genNumList Specification fn a
elemSIn Specification fn a
foldSIn = do
  let extraElemConstraints :: Specification fn a
extraElemConstraints
        | Just a
l <- forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownLowerBound Specification fn a
elemSIn
        , a
0 forall a. Ord a => a -> a -> Bool
<= a
l
        , Just a
u <- forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownUpperBound Specification fn a
foldSIn =
            forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
leqSpec a
u
        | Bool
otherwise = forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec
      elemSIn' :: Specification fn a
elemSIn' = Specification fn a
elemSIn forall a. Semigroup a => a -> a -> a
<> Specification fn a
extraElemConstraints
  Specification fn a
normElemS <- Specification fn a -> GenT m (Specification fn a)
normalize Specification fn a
elemSIn'
  Specification fn a
normFoldS <- Specification fn a -> GenT m (Specification fn a)
normalize Specification fn a
foldSIn
  let narrowedSpecs :: (Specification fn a, Specification fn a)
narrowedSpecs = forall a (fn :: [*] -> * -> *).
(BaseUniverse fn, TypeSpec fn a ~ NumSpec fn a, HasSpec fn a,
 Arbitrary a, Integral a, Ord a, Random a, MaybeBounded a) =>
(Specification fn a, Specification fn a)
-> (Specification fn a, Specification fn a)
narrowFoldSpecs (Specification fn a
normElemS, Specification fn a
normFoldS)
  forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a -> m a
explain
    ( forall a. [a] -> NonEmpty a
NE.fromList
        [ [Char]
"Can't generate list of ints with fold constraint"
        , [Char]
"  elemSpec = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn a
elemSIn
        , [Char]
"  normElemSpec = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn a
normElemS
        , [Char]
"  foldSpec = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn a
foldSIn
        ]
    )
    forall a b. (a -> b) -> a -> b
$ forall (m' :: * -> *).
MonadGenError m' =>
(Specification fn a, Specification fn a)
-> Int -> [a] -> GenT m' [a]
gen (Specification fn a, Specification fn a)
narrowedSpecs Int
50 [] forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Applicative m => Gen a -> GenT m a
pureGen forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Gen [a]
shuffle
  where
    normalize :: Specification fn a -> GenT m (Specification fn a)
normalize (ExplainSpec [[Char]]
es Specification fn a
x) = forall (fn :: [*] -> * -> *) a.
[[Char]] -> Specification fn a -> Specification fn a
explainSpecOpt [[Char]]
es forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Specification fn a -> GenT m (Specification fn a)
normalize Specification fn a
x
    normalize spec :: Specification fn a
spec@SuspendedSpec {} = do
      Int
sz <- forall (m :: * -> *). Monad m => GenT m Int
sizeT
      Specification fn a
spec' <- forall {t} {m :: * -> *} {fn :: [*] -> * -> *} {a}
       {fn :: [*] -> * -> *}.
(Num t, MonadGenError m, HasSpec fn a, Ord a, Eq t) =>
Int
-> t -> Set a -> Specification fn a -> GenT m (Specification fn a)
buildMemberSpec Int
sz (Int
100 :: Int) forall a. Monoid a => a
mempty Specification fn a
spec
      Specification fn a -> GenT m (Specification fn a)
normalize forall a b. (a -> b) -> a -> b
$ Specification fn a
spec'
    normalize Specification fn a
spec =
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
geqSpec @fn) forall a. MaybeBounded a => Maybe a
lowerBound
          forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
leqSpec @fn) forall a. MaybeBounded a => Maybe a
upperBound
          forall a. Semigroup a => a -> a -> a
<> Specification fn a
spec

    buildMemberSpec :: Int
-> t -> Set a -> Specification fn a -> GenT m (Specification fn a)
buildMemberSpec Int
_ t
0 Set a
es Specification fn a
_ =
      forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( forall a (fn :: [*] -> * -> *).
[a] -> NonEmpty [Char] -> Specification fn a
memberSpecList
            (forall a. Set a -> [a]
Set.toList Set a
es)
            (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"In genNumList, in buildMemberSpec 'es' is the empty list, can't make a MemberSpec from that")
        )
    buildMemberSpec Int
sz t
fuel Set a
es Specification fn a
spec = do
      Maybe a
me <- forall (m :: * -> *) a. (Int -> Int) -> GenT m a -> GenT m a
scaleT (forall a b. a -> b -> a
const Int
sz) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadGenError m =>
GenT GE a -> GenT m (Maybe a)
tryGenT (forall (fn :: [*] -> * -> *) a (m :: * -> *).
(HasCallStack, HasSpec fn a, MonadGenError m) =>
Specification fn a -> GenT m a
genFromSpecT Specification fn a
spec)
      let sz' :: Int
sz'
            | Int
sz forall a. Ord a => a -> a -> Bool
> Int
100 = Int
sz
            | forall a. Maybe a -> Bool
isNothing Maybe a
me = Int
2 forall a. Num a => a -> a -> a
* Int
sz forall a. Num a => a -> a -> a
+ Int
1
            | Just a
e <- Maybe a
me, forall a. Ord a => a -> Set a -> Bool
Set.member a
e Set a
es = Int
2 forall a. Num a => a -> a -> a
* Int
sz forall a. Num a => a -> a -> a
+ Int
1
            | Bool
otherwise = Int
sz
      Int
-> t -> Set a -> Specification fn a -> GenT m (Specification fn a)
buildMemberSpec
        Int
sz'
        (t
fuel forall a. Num a => a -> a -> a
- t
1)
        (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set a
es (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Ord a => a -> Set a -> Set a
Set.insert Set a
es) Maybe a
me)
        Specification fn a
spec

    gen ::
      forall m'. MonadGenError m' => (Specification fn a, Specification fn a) -> Int -> [a] -> GenT m' [a]
    gen :: forall (m' :: * -> *).
MonadGenError m' =>
(Specification fn a, Specification fn a)
-> Int -> [a] -> GenT m' [a]
gen (Specification fn a
elemS, Specification fn a
foldS) Int
fuel [a]
lst
      | Int
fuel forall a. Ord a => a -> a -> Bool
<= Int
0
      , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ a
0 forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
`conformsToSpec` Specification fn a
foldS =
          forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
genError forall a b. (a -> b) -> a -> b
$
            forall a. [a] -> NonEmpty a
NE.fromList
              [ [Char]
"Ran out of fuel in genNumList"
              , [Char]
"  elemSpec =" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn a
elemSIn
              , [Char]
"  foldSpec = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn a
foldSIn
              , [Char]
"  lst = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a. [a] -> [a]
reverse [a]
lst)
              ]
      | ErrorSpec NonEmpty [Char]
err <- Specification fn a
foldS = forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
genError NonEmpty [Char]
err
      | ErrorSpec {} <- Specification fn a
elemS = forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
lst -- At this point we know that foldS admits 0 (also this should be redundant)
      | a
0 forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
`conformsToSpec` Specification fn a
foldS = forall (m :: * -> *) a. MonadGenError m => [GenT GE a] -> GenT m a
oneofT [forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
lst, forall (m'' :: * -> *). MonadGenError m'' => GenT m'' [a]
nonemptyList @GE] -- TODO: distribution
      | Bool
otherwise = forall (m'' :: * -> *). MonadGenError m'' => GenT m'' [a]
nonemptyList
      where
        isUnsat :: (Specification fn a, Specification fn a) -> Bool
isUnsat (Specification fn a
elemS, Specification fn a
foldS) = forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Bool
isEmptyNumSpec Specification fn a
foldS Bool -> Bool -> Bool
|| Bool -> Bool
not (a
0 forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
`conformsToSpec` Specification fn a
foldS) Bool -> Bool -> Bool
&& forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Bool
isEmptyNumSpec Specification fn a
elemS
        nonemptyList :: forall m''. MonadGenError m'' => GenT m'' [a]
        nonemptyList :: forall (m'' :: * -> *). MonadGenError m'' => GenT m'' [a]
nonemptyList = do
          (a
x, (Specification fn a, Specification fn a)
specs') <-
            forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a -> m a
explain
              ( forall a. [a] -> NonEmpty a
NE.fromList
                  [ [Char]
"Generating an element:"
                  , [Char]
"  elemS = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn a
elemS
                  , [Char]
"  foldS = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn a
foldS
                  , [Char]
"  fuel  = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
fuel
                  , [Char]
"  lst   = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a. [a] -> [a]
reverse [a]
lst)
                  ]
              )
              forall a b. (a -> b) -> a -> b
$ do
                Int
sz <- forall (m :: * -> *). Monad m => GenT m Int
sizeT
                a
x <- forall (fn :: [*] -> * -> *) a (m :: * -> *).
(HasCallStack, HasSpec fn a, MonadGenError m) =>
Specification fn a -> GenT m a
genFromSpecT Specification fn a
elemS
                let foldS' :: Specification fn a
foldS' = forall (f :: [*] -> * -> *) (fn :: [*] -> * -> *) (as :: [*]) a b.
(Functions f fn, TypeList as, Typeable as, HasSpec fn a,
 HasSpec fn b, All (HasSpec fn) as) =>
f as b
-> ListCtx Value as (HOLE a)
-> Specification fn b
-> Specification fn a
propagateSpecFun (forall (fn :: [*] -> * -> *) a. Foldy fn a => fn '[a, a] a
theAddFn @fn) (forall a. HOLE a a
HOLE forall (c :: * -> *) a (f :: * -> *) (as1 :: [*]).
c a -> List f as1 -> ListCtx f (a : as1) c
:? forall a. Show a => a -> Value a
Value a
x forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> forall {k} (f :: k -> *). List f '[]
Nil) Specification fn a
foldS
                    specs' :: (Specification fn a, Specification fn a)
specs' = forall a (fn :: [*] -> * -> *).
(BaseUniverse fn, TypeSpec fn a ~ NumSpec fn a, HasSpec fn a,
 Arbitrary a, Integral a, Ord a, Random a, MaybeBounded a) =>
a
-> Int
-> (Specification fn a, Specification fn a)
-> (Specification fn a, Specification fn a)
narrowByFuelAndSize (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
fuel forall a. Num a => a -> a -> a
- Int
1) Int
sz (Specification fn a
elemS, Specification fn a
foldS')
                forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
x, (Specification fn a, Specification fn a)
specs')
                forall (m :: * -> *) a.
MonadGenError m =>
GenT m a -> (a -> Bool) -> GenT m a
`suchThatT` Bool -> Bool
not
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {fn :: [*] -> * -> *} {a} {fn :: [*] -> * -> *} {a}.
(TypeSpec fn a ~ NumSpec fn a, TypeSpec fn a ~ NumSpec fn a,
 HasSpec fn a, Ord a, Ord a, Enum a, Enum a, Num a, Num a,
 MaybeBounded a, MaybeBounded a) =>
(Specification fn a, Specification fn a) -> Bool
isUnsat
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd
          forall (m' :: * -> *).
MonadGenError m' =>
(Specification fn a, Specification fn a)
-> Int -> [a] -> GenT m' [a]
gen (Specification fn a, Specification fn a)
specs' (Int
fuel forall a. Num a => a -> a -> a
- Int
1) (a
x forall a. a -> [a] -> [a]
: [a]
lst)

instance BaseUniverse fn => Foldy fn Int where
  genList :: forall (m :: * -> *).
(BaseUniverse fn, MonadGenError m) =>
Specification fn Int -> Specification fn Int -> GenT m [Int]
genList = forall a (fn :: [*] -> * -> *) (m :: * -> *).
(BaseUniverse fn, MonadGenError m, TypeSpec fn a ~ NumSpec fn a,
 HasSpec fn a, Arbitrary a, Integral a, Ord a, Random a,
 MaybeBounded a, Foldy fn a) =>
Specification fn a -> Specification fn a -> GenT m [a]
genNumList
  theAddFn :: fn '[Int, Int] Int
theAddFn = forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fn as b -> fnU as b
injectFn (forall (fn :: [*] -> * -> *) a. NumLike fn a => IntFn fn '[a, a] a
Add @fn)
  theZero :: Int
theZero = Int
0

instance BaseUniverse fn => Foldy fn Integer where
  genList :: forall (m :: * -> *).
(BaseUniverse fn, MonadGenError m) =>
Specification fn Integer
-> Specification fn Integer -> GenT m [Integer]
genList = forall a (fn :: [*] -> * -> *) (m :: * -> *).
(BaseUniverse fn, MonadGenError m, TypeSpec fn a ~ NumSpec fn a,
 HasSpec fn a, Arbitrary a, Integral a, Ord a, Random a,
 MaybeBounded a, Foldy fn a) =>
Specification fn a -> Specification fn a -> GenT m [a]
genNumList
  theAddFn :: fn '[Integer, Integer] Integer
theAddFn = forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fn as b -> fnU as b
injectFn (forall (fn :: [*] -> * -> *) a. NumLike fn a => IntFn fn '[a, a] a
Add @fn)
  theZero :: Integer
theZero = Integer
0

instance BaseUniverse fn => Foldy fn Int8 where
  genList :: forall (m :: * -> *).
(BaseUniverse fn, MonadGenError m) =>
Specification fn Int8 -> Specification fn Int8 -> GenT m [Int8]
genList = forall a (fn :: [*] -> * -> *) (m :: * -> *).
(BaseUniverse fn, MonadGenError m, TypeSpec fn a ~ NumSpec fn a,
 HasSpec fn a, Arbitrary a, Integral a, Ord a, Random a,
 MaybeBounded a, Foldy fn a) =>
Specification fn a -> Specification fn a -> GenT m [a]
genNumList
  theAddFn :: fn '[Int8, Int8] Int8
theAddFn = forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fn as b -> fnU as b
injectFn (forall (fn :: [*] -> * -> *) a. NumLike fn a => IntFn fn '[a, a] a
Add @fn)
  theZero :: Int8
theZero = Int8
0

instance BaseUniverse fn => Foldy fn Int16 where
  genList :: forall (m :: * -> *).
(BaseUniverse fn, MonadGenError m) =>
Specification fn Int16 -> Specification fn Int16 -> GenT m [Int16]
genList = forall a (fn :: [*] -> * -> *) (m :: * -> *).
(BaseUniverse fn, MonadGenError m, TypeSpec fn a ~ NumSpec fn a,
 HasSpec fn a, Arbitrary a, Integral a, Ord a, Random a,
 MaybeBounded a, Foldy fn a) =>
Specification fn a -> Specification fn a -> GenT m [a]
genNumList
  theAddFn :: fn '[Int16, Int16] Int16
theAddFn = forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fn as b -> fnU as b
injectFn (forall (fn :: [*] -> * -> *) a. NumLike fn a => IntFn fn '[a, a] a
Add @fn)
  theZero :: Int16
theZero = Int16
0

instance BaseUniverse fn => Foldy fn Int32 where
  genList :: forall (m :: * -> *).
(BaseUniverse fn, MonadGenError m) =>
Specification fn Int32 -> Specification fn Int32 -> GenT m [Int32]
genList = forall a (fn :: [*] -> * -> *) (m :: * -> *).
(BaseUniverse fn, MonadGenError m, TypeSpec fn a ~ NumSpec fn a,
 HasSpec fn a, Arbitrary a, Integral a, Ord a, Random a,
 MaybeBounded a, Foldy fn a) =>
Specification fn a -> Specification fn a -> GenT m [a]
genNumList
  theAddFn :: fn '[Int32, Int32] Int32
theAddFn = forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fn as b -> fnU as b
injectFn (forall (fn :: [*] -> * -> *) a. NumLike fn a => IntFn fn '[a, a] a
Add @fn)
  theZero :: Int32
theZero = Int32
0

instance BaseUniverse fn => Foldy fn Int64 where
  genList :: forall (m :: * -> *).
(BaseUniverse fn, MonadGenError m) =>
Specification fn Int64 -> Specification fn Int64 -> GenT m [Int64]
genList = forall a (fn :: [*] -> * -> *) (m :: * -> *).
(BaseUniverse fn, MonadGenError m, TypeSpec fn a ~ NumSpec fn a,
 HasSpec fn a, Arbitrary a, Integral a, Ord a, Random a,
 MaybeBounded a, Foldy fn a) =>
Specification fn a -> Specification fn a -> GenT m [a]
genNumList
  theAddFn :: fn '[Int64, Int64] Int64
theAddFn = forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fn as b -> fnU as b
injectFn (forall (fn :: [*] -> * -> *) a. NumLike fn a => IntFn fn '[a, a] a
Add @fn)
  theZero :: Int64
theZero = Int64
0

instance BaseUniverse fn => Foldy fn Word8 where
  genList :: forall (m :: * -> *).
(BaseUniverse fn, MonadGenError m) =>
Specification fn Word8 -> Specification fn Word8 -> GenT m [Word8]
genList = forall a (fn :: [*] -> * -> *) (m :: * -> *).
(BaseUniverse fn, MonadGenError m, TypeSpec fn a ~ NumSpec fn a,
 HasSpec fn a, Arbitrary a, Integral a, Ord a, Random a,
 MaybeBounded a, Foldy fn a) =>
Specification fn a -> Specification fn a -> GenT m [a]
genNumList
  theAddFn :: fn '[Word8, Word8] Word8
theAddFn = forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fn as b -> fnU as b
injectFn (forall (fn :: [*] -> * -> *) a. NumLike fn a => IntFn fn '[a, a] a
Add @fn)
  theZero :: Word8
theZero = Word8
0

instance BaseUniverse fn => Foldy fn Word16 where
  genList :: forall (m :: * -> *).
(BaseUniverse fn, MonadGenError m) =>
Specification fn Word16
-> Specification fn Word16 -> GenT m [Word16]
genList = forall a (fn :: [*] -> * -> *) (m :: * -> *).
(BaseUniverse fn, MonadGenError m, TypeSpec fn a ~ NumSpec fn a,
 HasSpec fn a, Arbitrary a, Integral a, Ord a, Random a,
 MaybeBounded a, Foldy fn a) =>
Specification fn a -> Specification fn a -> GenT m [a]
genNumList
  theAddFn :: fn '[Word16, Word16] Word16
theAddFn = forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fn as b -> fnU as b
injectFn (forall (fn :: [*] -> * -> *) a. NumLike fn a => IntFn fn '[a, a] a
Add @fn)
  theZero :: Word16
theZero = Word16
0

instance BaseUniverse fn => Foldy fn Word32 where
  genList :: forall (m :: * -> *).
(BaseUniverse fn, MonadGenError m) =>
Specification fn Word32
-> Specification fn Word32 -> GenT m [Word32]
genList = forall a (fn :: [*] -> * -> *) (m :: * -> *).
(BaseUniverse fn, MonadGenError m, TypeSpec fn a ~ NumSpec fn a,
 HasSpec fn a, Arbitrary a, Integral a, Ord a, Random a,
 MaybeBounded a, Foldy fn a) =>
Specification fn a -> Specification fn a -> GenT m [a]
genNumList
  theAddFn :: fn '[Word32, Word32] Word32
theAddFn = forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fn as b -> fnU as b
injectFn (forall (fn :: [*] -> * -> *) a. NumLike fn a => IntFn fn '[a, a] a
Add @fn)
  theZero :: Word32
theZero = Word32
0

instance BaseUniverse fn => Foldy fn Word64 where
  genList :: forall (m :: * -> *).
(BaseUniverse fn, MonadGenError m) =>
Specification fn Word64
-> Specification fn Word64 -> GenT m [Word64]
genList = forall a (fn :: [*] -> * -> *) (m :: * -> *).
(BaseUniverse fn, MonadGenError m, TypeSpec fn a ~ NumSpec fn a,
 HasSpec fn a, Arbitrary a, Integral a, Ord a, Random a,
 MaybeBounded a, Foldy fn a) =>
Specification fn a -> Specification fn a -> GenT m [a]
genNumList
  theAddFn :: fn '[Word64, Word64] Word64
theAddFn = forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fn as b -> fnU as b
injectFn (forall (fn :: [*] -> * -> *) a. NumLike fn a => IntFn fn '[a, a] a
Add @fn)
  theZero :: Word64
theZero = Word64
0

instance BaseUniverse fn => Foldy fn Natural where
  genList :: forall (m :: * -> *).
(BaseUniverse fn, MonadGenError m) =>
Specification fn Natural
-> Specification fn Natural -> GenT m [Natural]
genList = forall a (fn :: [*] -> * -> *) (m :: * -> *).
(BaseUniverse fn, MonadGenError m, TypeSpec fn a ~ NumSpec fn a,
 HasSpec fn a, Arbitrary a, Integral a, Ord a, Random a,
 MaybeBounded a, Foldy fn a) =>
Specification fn a -> Specification fn a -> GenT m [a]
genNumList
  theAddFn :: fn '[Natural, Natural] Natural
theAddFn = forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fn as b -> fnU as b
injectFn (forall (fn :: [*] -> * -> *) a. NumLike fn a => IntFn fn '[a, a] a
Add @fn)
  theZero :: Natural
theZero = Natural
0

genFromFold ::
  forall m fn a b.
  ( MonadGenError m
  , Foldy fn b
  , HasSpec fn a
  ) =>
  [a] ->
  Specification fn Integer ->
  Specification fn a ->
  fn '[a] b ->
  Specification fn b ->
  GenT m [a]
genFromFold :: forall (m :: * -> *) (fn :: [*] -> * -> *) a b.
(MonadGenError m, Foldy fn b, HasSpec fn a) =>
[a]
-> Specification fn Integer
-> Specification fn a
-> fn '[a] b
-> Specification fn b
-> GenT m [a]
genFromFold (forall a. Eq a => [a] -> [a]
nub -> [a]
must) (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn a -> Specification fn a
simplifySpec -> Specification fn Integer
size) Specification fn a
elemS fn '[a] b
fn Specification fn b
foldS =
  forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a -> m a
explain
    ( forall a. [a] -> NonEmpty a
NE.fromList
        [ [Char]
"while calling genFromFold"
        , [Char]
"  must  = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [a]
must
        , [Char]
"  size  = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn Integer
size
        , [Char]
"  elemS = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn a
elemS
        , [Char]
"  fn    = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show fn '[a] b
fn
        , [Char]
"  foldS = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn b
foldS
        ]
    )
    forall a b. (a -> b) -> a -> b
$ do
      let elemS' :: Specification fn b
elemS' = forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, HasSpec fn b) =>
fn '[a] b -> Specification fn a -> Specification fn b
mapSpec fn '[a] b
fn Specification fn a
elemS
          mustVal :: b
mustVal = forall (fn :: [*] -> * -> *) a. Foldy fn a => [a] -> a
adds @fn (forall a b. (a -> b) -> [a] -> [b]
map (forall (fn :: [*] -> * -> *) (as :: [*]) b.
FunctionLike fn =>
fn as b -> FunTy as b
sem fn '[a] b
fn) [a]
must)
          foldS' :: Specification fn b
foldS' = forall (f :: [*] -> * -> *) (fn :: [*] -> * -> *) (as :: [*]) a b.
(Functions f fn, TypeList as, Typeable as, HasSpec fn a,
 HasSpec fn b, All (HasSpec fn) as) =>
f as b
-> ListCtx Value as (HOLE a)
-> Specification fn b
-> Specification fn a
propagateSpecFun (forall (fn :: [*] -> * -> *) a. Foldy fn a => fn '[a, a] a
theAddFn @fn) (forall a. HOLE a a
HOLE forall (c :: * -> *) a (f :: * -> *) (as1 :: [*]).
c a -> List f as1 -> ListCtx f (a : as1) c
:? forall a. Show a => a -> Value a
Value b
mustVal forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> forall {k} (f :: k -> *). List f '[]
Nil) Specification fn b
foldS
          sizeSpec' :: Specification fn Integer
sizeSpec' = forall (f :: [*] -> * -> *) (fn :: [*] -> * -> *) (as :: [*]) a b.
(Functions f fn, TypeList as, Typeable as, HasSpec fn a,
 HasSpec fn b, All (HasSpec fn) as) =>
f as b
-> ListCtx Value as (HOLE a)
-> Specification fn b
-> Specification fn a
propagateSpecFun (forall (fn :: [*] -> * -> *) a. NumLike fn a => fn '[a, a] a
addFn @fn) (forall a. HOLE a a
HOLE forall (c :: * -> *) a (f :: * -> *) (as1 :: [*]).
c a -> List f as1 -> ListCtx f (a : as1) c
:? forall a. Show a => a -> Value a
Value (forall (fn :: [*] -> * -> *) t. Sized fn t => t -> Integer
sizeOf [a]
must) forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> forall {k} (f :: k -> *). List f '[]
Nil) Specification fn Integer
size
      GenMode
m <- forall (m :: * -> *). Applicative m => GenT m GenMode
getMode
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (fn :: [*] -> * -> *) a. Specification fn a -> Bool
isErrorLike Specification fn Integer
sizeSpec') forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadGenError m => [Char] -> m a
genError1 [Char]
"Inconsistent size spec"
      [b]
results0 <-
        forall (m :: * -> *) a. GenMode -> GenT m a -> GenT m a
withMode GenMode
Loose forall a b. (a -> b) -> a -> b
$
          ( forall (m :: * -> *) a. GenMode -> GenT m a -> GenT m a
withMode GenMode
m forall a b. (a -> b) -> a -> b
$
              -- TODO: this is not the best solution to this problem, we need
              -- to use the size information in `genList` instead
              forall (m :: * -> *) a.
MonadGenError m =>
Int -> GenT m a -> (a -> Bool) -> GenT m a
suchThatWithTryT
                Int
10
                (forall (fn :: [*] -> * -> *) a (m :: * -> *).
(Foldy fn a, BaseUniverse fn, MonadGenError m) =>
Specification fn a -> Specification fn a -> GenT m [a]
genList (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn a -> Specification fn a
simplifySpec Specification fn b
elemS') (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn a -> Specification fn a
simplifySpec Specification fn b
foldS'))
                (\[b]
xs -> forall (fn :: [*] -> * -> *) t. Sized fn t => t -> Integer
sizeOf [b]
xs forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
`conformsToSpec` Specification fn Integer
sizeSpec')
          )
      [a]
results <-
        forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a -> m a
explain
          ( forall a. [a] -> NonEmpty a
NE.fromList
              [ [Char]
"genInverse"
              , [Char]
"  fn = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show fn '[a] b
fn
              , [Char]
"  results0 = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [b]
results0
              , forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ Doc Any
"  elemS =" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Specification fn a
elemS
              ]
          )
          forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) (fn :: [*] -> * -> *) a b.
(MonadGenError m, HasSpec fn a, Show b, Functions fn fn,
 HasSpec fn b) =>
fn '[a] b -> Specification fn a -> b -> GenT m a
genInverse fn '[a] b
fn Specification fn a
elemS) [b]
results0
      forall (m :: * -> *) a. Applicative m => Gen a -> GenT m a
pureGen forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Gen [a]
shuffle forall a b. (a -> b) -> a -> b
$ [a]
must forall a. [a] -> [a] -> [a]
++ [a]
results

------------------------------------------------------------------------
-- Instances of HasSpec
------------------------------------------------------------------------

-- () ---------------------------------------------------------------------

instance BaseUniverse fn => HasSpec fn () where
  type TypeSpec fn () = ()
  emptySpec :: TypeSpec fn ()
emptySpec = ()
  combineSpec :: TypeSpec fn () -> TypeSpec fn () -> Specification fn ()
combineSpec TypeSpec fn ()
_ TypeSpec fn ()
_ = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec ()
  ()
_ conformsTo :: HasCallStack => () -> TypeSpec fn () -> Bool
`conformsTo` TypeSpec fn ()
_ = Bool
True
  shrinkWithTypeSpec :: TypeSpec fn () -> () -> [()]
shrinkWithTypeSpec TypeSpec fn ()
_ ()
_ = []
  genFromTypeSpec :: forall (m :: * -> *).
(HasCallStack, MonadGenError m) =>
TypeSpec fn () -> GenT m ()
genFromTypeSpec TypeSpec fn ()
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  toPreds :: Term fn () -> TypeSpec fn () -> Pred fn
toPreds Term fn ()
_ TypeSpec fn ()
_ = forall (fn :: [*] -> * -> *). Pred fn
TruePred
  cardinalTypeSpec :: TypeSpec fn () -> Specification fn Integer
cardinalTypeSpec TypeSpec fn ()
_ = forall a (fn :: [*] -> * -> *). NonEmpty a -> Specification fn a
MemberSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
1)
  cardinalTrueSpec :: Specification fn Integer
cardinalTrueSpec = forall a (fn :: [*] -> * -> *). a -> Specification fn a
equalSpec Integer
1 -- there is exactly one, ()
  typeSpecOpt :: TypeSpec fn () -> [()] -> Specification fn ()
typeSpecOpt TypeSpec fn ()
_ [] = forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec
  typeSpecOpt TypeSpec fn ()
_ (()
_ : [()]
_) = forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"Non null 'cant' set in typeSpecOpt @()")

-- Bool -------------------------------------------------------------------

instance HasSimpleRep Bool
instance (BaseUniverse fn, HasSpec fn ()) => HasSpec fn Bool where
  shrinkWithTypeSpec :: TypeSpec fn Bool -> Bool -> [Bool]
shrinkWithTypeSpec TypeSpec fn Bool
_ = forall a. Arbitrary a => a -> [a]
shrink
  cardinalTypeSpec :: TypeSpec fn Bool -> Specification fn Integer
cardinalTypeSpec (SumSpec Maybe (Int, Int)
_ Specification fn ()
a Specification fn ()
b) =
    forall a (fn :: [*] -> * -> *). NonEmpty a -> Specification fn a
MemberSpec (forall a. [a] -> NonEmpty a
NE.fromList [Integer
0, Integer
1, Integer
2]) forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Specification fn Integer
-> Specification fn Integer -> Specification fn Integer
addSpecInt (forall (fn :: [*] -> * -> *) a.
(Eq a, BaseUniverse fn, HasSpec fn a) =>
Specification fn a -> Specification fn Integer
cardinality Specification fn ()
a) (forall (fn :: [*] -> * -> *) a.
(Eq a, BaseUniverse fn, HasSpec fn a) =>
Specification fn a -> Specification fn Integer
cardinality Specification fn ()
b)
  cardinalTrueSpec :: Specification fn Integer
cardinalTrueSpec = forall a (fn :: [*] -> * -> *). NonEmpty a -> Specification fn a
MemberSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
2)

-- Sum --------------------------------------------------------------------

guardSumSpec ::
  forall fn a b.
  (HasSpec fn a, HasSpec fn b, KnownNat (CountCases b)) =>
  [String] ->
  SumSpec fn a b ->
  Specification fn (Sum a b)
guardSumSpec :: forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, HasSpec fn b, KnownNat (CountCases b)) =>
[[Char]] -> SumSpec fn a b -> Specification fn (Sum a b)
guardSumSpec [[Char]]
msgs s :: SumSpec fn a b
s@(SumSpecRaw Maybe [Char]
tString Maybe (Int, Int)
_ Specification fn a
sa Specification fn b
sb)
  | forall (fn :: [*] -> * -> *) a. Specification fn a -> Bool
isErrorLike Specification fn a
sa
  , forall (fn :: [*] -> * -> *) a. Specification fn a -> Bool
isErrorLike Specification fn b
sb =
      forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec forall a b. (a -> b) -> a -> b
$
        forall a. [a] -> NonEmpty a
NE.fromList forall a b. (a -> b) -> a -> b
$
          [[Char]]
msgs forall a. [a] -> [a] -> [a]
++ [[Char]
"All branches in a caseOn" forall a. [a] -> [a] -> [a]
++ Maybe [Char] -> [Char]
sumType Maybe [Char]
tString forall a. [a] -> [a] -> [a]
++ [Char]
" simplify to False.", forall a. Show a => a -> [Char]
show SumSpec fn a b
s]
  | Bool
otherwise = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec SumSpec fn a b
s

data SumSpec fn a b
  = SumSpecRaw
      (Maybe String) -- A String which is the type of arg in (caseOn arg branch1 .. branchN)
      (Maybe (Int, Int))
      (Specification fn a)
      (Specification fn b)

pattern SumSpec ::
  (Maybe (Int, Int)) -> (Specification fn a) -> (Specification fn b) -> SumSpec fn a b
pattern $bSumSpec :: forall (fn :: [*] -> * -> *) a b.
Maybe (Int, Int)
-> Specification fn a -> Specification fn b -> SumSpec fn a b
$mSumSpec :: forall {r} {fn :: [*] -> * -> *} {a} {b}.
SumSpec fn a b
-> (Maybe (Int, Int)
    -> Specification fn a -> Specification fn b -> r)
-> ((# #) -> r)
-> r
SumSpec a b c <- SumSpecRaw _ a b c
  where
    SumSpec Maybe (Int, Int)
a Specification fn a
b Specification fn b
c = forall (fn :: [*] -> * -> *) a b.
Maybe [Char]
-> Maybe (Int, Int)
-> Specification fn a
-> Specification fn b
-> SumSpec fn a b
SumSpecRaw forall a. Maybe a
Nothing Maybe (Int, Int)
a Specification fn a
b Specification fn b
c

{-# COMPLETE SumSpec #-}
{-# COMPLETE SumSpecRaw #-}

combTypeName :: Maybe String -> Maybe String -> Maybe String
combTypeName :: Maybe [Char] -> Maybe [Char] -> Maybe [Char]
combTypeName (Just [Char]
x) (Just [Char]
y) =
  if [Char]
x forall a. Eq a => a -> a -> Bool
== [Char]
y then forall a. a -> Maybe a
Just [Char]
x else forall a. a -> Maybe a
Just ([Char]
"(" forall a. [a] -> [a] -> [a]
++ [Char]
x forall a. [a] -> [a] -> [a]
++ [Char]
" | " forall a. [a] -> [a] -> [a]
++ [Char]
y forall a. [a] -> [a] -> [a]
++ [Char]
")")
combTypeName (Just [Char]
x) Maybe [Char]
Nothing = forall a. a -> Maybe a
Just [Char]
x
combTypeName Maybe [Char]
Nothing (Just [Char]
x) = forall a. a -> Maybe a
Just [Char]
x
combTypeName Maybe [Char]
Nothing Maybe [Char]
Nothing = forall a. Maybe a
Nothing

instance (Arbitrary (Specification fn a), Arbitrary (Specification fn b)) => Arbitrary (SumSpec fn a b) where
  arbitrary :: Gen (SumSpec fn a b)
arbitrary =
    forall (fn :: [*] -> * -> *) a b.
Maybe (Int, Int)
-> Specification fn a -> Specification fn b -> SumSpec fn a b
SumSpec
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
        [ (Int
3, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing)
        , (Int
10, forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
100) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
100)))
        , (Int
1, forall a. Arbitrary a => Gen a
arbitrary)
        ]
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary
  shrink :: SumSpec fn a b -> [SumSpec fn a b]
shrink (SumSpec Maybe (Int, Int)
h Specification fn a
a Specification fn b
b) = [forall (fn :: [*] -> * -> *) a b.
Maybe (Int, Int)
-> Specification fn a -> Specification fn b -> SumSpec fn a b
SumSpec Maybe (Int, Int)
h' Specification fn a
a' Specification fn b
b' | (Maybe (Int, Int)
h', Specification fn a
a', Specification fn b
b') <- forall a. Arbitrary a => a -> [a]
shrink (Maybe (Int, Int)
h, Specification fn a
a, Specification fn b
b)]

type family CountCases a where
  CountCases (Sum a b) = 1 + CountCases b
  CountCases _ = 1

countCases :: forall a. KnownNat (CountCases a) => Int
countCases :: forall a. KnownNat (CountCases a) => Int
countCases = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (n :: Natural) (proxy :: Natural -> *).
KnownNat n =>
proxy n -> Integer
natVal @(CountCases a) forall {k} (t :: k). Proxy t
Proxy)

instance (HasSpec fn a, HasSpec fn b) => Semigroup (SumSpec fn a b) where
  SumSpecRaw Maybe [Char]
t Maybe (Int, Int)
h Specification fn a
sa Specification fn b
sb <> :: SumSpec fn a b -> SumSpec fn a b -> SumSpec fn a b
<> SumSpecRaw Maybe [Char]
t' Maybe (Int, Int)
h' Specification fn a
sa' Specification fn b
sb' =
    forall (fn :: [*] -> * -> *) a b.
Maybe [Char]
-> Maybe (Int, Int)
-> Specification fn a
-> Specification fn b
-> SumSpec fn a b
SumSpecRaw (Maybe [Char] -> Maybe [Char] -> Maybe [Char]
combTypeName Maybe [Char]
t Maybe [Char]
t') (forall a. (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a
unionWithMaybe forall {a} {b}. (Num a, Num b) => (a, b) -> (a, b) -> (a, b)
mergeH Maybe (Int, Int)
h Maybe (Int, Int)
h') (Specification fn a
sa forall a. Semigroup a => a -> a -> a
<> Specification fn a
sa') (Specification fn b
sb forall a. Semigroup a => a -> a -> a
<> Specification fn b
sb')
    where
      -- TODO: think more carefully about this, now weights like 2 2 and 10 15 give more weight to 10 15
      -- than would be the case if you had 2 2 and 2 3. But on the other hand this approach is associative
      -- whereas actually averaging the ratios is not. One could keep a list. Future work.
      mergeH :: (a, b) -> (a, b) -> (a, b)
mergeH (a
fA, b
fB) (a
fA', b
fB') = (a
fA forall a. Num a => a -> a -> a
+ a
fA', b
fB forall a. Num a => a -> a -> a
+ b
fB')

instance forall fn a b. (HasSpec fn a, HasSpec fn b, KnownNat (CountCases b)) => Monoid (SumSpec fn a b) where
  mempty :: SumSpec fn a b
mempty = forall (fn :: [*] -> * -> *) a b.
Maybe (Int, Int)
-> Specification fn a -> Specification fn b -> SumSpec fn a b
SumSpec forall a. Maybe a
Nothing forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty

instance (HasSpec fn a, HasSpec fn b, KnownNat (CountCases b)) => HasSpec fn (Sum a b) where
  type TypeSpec fn (Sum a b) = SumSpec fn a b

  type Prerequisites fn (Sum a b) = (HasSpec fn a, HasSpec fn b)

  emptySpec :: TypeSpec fn (Sum a b)
emptySpec = forall a. Monoid a => a
mempty

  combineSpec :: TypeSpec fn (Sum a b)
-> TypeSpec fn (Sum a b) -> Specification fn (Sum a b)
combineSpec TypeSpec fn (Sum a b)
s TypeSpec fn (Sum a b)
s' = forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, HasSpec fn b, KnownNat (CountCases b)) =>
[[Char]] -> SumSpec fn a b -> Specification fn (Sum a b)
guardSumSpec [[Char]
"When combining SumSpecs", [Char]
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show TypeSpec fn (Sum a b)
s, [Char]
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show TypeSpec fn (Sum a b)
s'] (TypeSpec fn (Sum a b)
s forall a. Semigroup a => a -> a -> a
<> TypeSpec fn (Sum a b)
s')

  conformsTo :: HasCallStack => Sum a b -> TypeSpec fn (Sum a b) -> Bool
conformsTo (SumLeft a
a) (SumSpec Maybe (Int, Int)
_ Specification fn a
sa Specification fn b
_) = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
conformsToSpec a
a Specification fn a
sa
  conformsTo (SumRight b
b) (SumSpec Maybe (Int, Int)
_ Specification fn a
_ Specification fn b
sb) = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
conformsToSpec b
b Specification fn b
sb

  genFromTypeSpec :: forall (m :: * -> *).
(HasCallStack, MonadGenError m) =>
TypeSpec fn (Sum a b) -> GenT m (Sum a b)
genFromTypeSpec (SumSpec Maybe (Int, Int)
h Specification fn a
sa Specification fn b
sb)
    | Bool
emptyA, Bool
emptyB = forall (m :: * -> *) a. MonadGenError m => [Char] -> m a
genError1 ([Char]
"genFromTypeSpec @SumSpec: empty")
    | Bool
emptyA = forall a b. b -> Sum a b
SumRight forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (fn :: [*] -> * -> *) a (m :: * -> *).
(HasCallStack, HasSpec fn a, MonadGenError m) =>
Specification fn a -> GenT m a
genFromSpecT Specification fn b
sb
    | Bool
emptyB = forall a b. a -> Sum a b
SumLeft forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (fn :: [*] -> * -> *) a (m :: * -> *).
(HasCallStack, HasSpec fn a, MonadGenError m) =>
Specification fn a -> GenT m a
genFromSpecT Specification fn a
sa
    | Int
fA forall a. Eq a => a -> a -> Bool
== Int
0, Int
fB forall a. Eq a => a -> a -> Bool
== Int
0 = forall (m :: * -> *) a. MonadGenError m => [Char] -> m a
genError1 ([Char]
"All frequencies 0")
    | Bool
otherwise =
        forall (m :: * -> *) a.
MonadGenError m =>
[(Int, GenT GE a)] -> GenT m a
frequencyT
          [ (Int
fA, forall a b. a -> Sum a b
SumLeft forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (fn :: [*] -> * -> *) a (m :: * -> *).
(HasCallStack, HasSpec fn a, MonadGenError m) =>
Specification fn a -> GenT m a
genFromSpecT Specification fn a
sa)
          , (Int
fB, forall a b. b -> Sum a b
SumRight forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (fn :: [*] -> * -> *) a (m :: * -> *).
(HasCallStack, HasSpec fn a, MonadGenError m) =>
Specification fn a -> GenT m a
genFromSpecT Specification fn b
sb)
          ]
    where
      (forall a. Ord a => a -> a -> a
max Int
0 -> Int
fA, forall a. Ord a => a -> a -> a
max Int
0 -> Int
fB) = forall a. a -> Maybe a -> a
fromMaybe (Int
1, forall a. KnownNat (CountCases a) => Int
countCases @b) Maybe (Int, Int)
h
      emptyA :: Bool
emptyA = forall (fn :: [*] -> * -> *) a. Specification fn a -> Bool
isErrorLike Specification fn a
sa
      emptyB :: Bool
emptyB = forall (fn :: [*] -> * -> *) a. Specification fn a -> Bool
isErrorLike Specification fn b
sb

  shrinkWithTypeSpec :: TypeSpec fn (Sum a b) -> Sum a b -> [Sum a b]
shrinkWithTypeSpec (SumSpec Maybe (Int, Int)
_ Specification fn a
sa Specification fn b
_) (SumLeft a
a) = forall a b. a -> Sum a b
SumLeft forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn a -> a -> [a]
shrinkWithSpec Specification fn a
sa a
a
  shrinkWithTypeSpec (SumSpec Maybe (Int, Int)
_ Specification fn a
_ Specification fn b
sb) (SumRight b
b) = forall a b. b -> Sum a b
SumRight forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn a -> a -> [a]
shrinkWithSpec Specification fn b
sb b
b

  toPreds :: Term fn (Sum a b) -> TypeSpec fn (Sum a b) -> Pred fn
toPreds Term fn (Sum a b)
ct (SumSpec Maybe (Int, Int)
h Specification fn a
sa Specification fn b
sb) =
    forall (fn :: [*] -> * -> *) (a :: [*]).
HasSpec fn (SumOver a) =>
Term fn (SumOver a) -> List (Weighted (Binder fn)) a -> Pred fn
Case
      Term fn (Sum a b)
ct
      ( (forall (f :: * -> *) a. Maybe Int -> f a -> Weighted f a
Weighted (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Int, Int)
h) forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a p.
(HasSpec fn a, IsPred p fn) =>
(Term fn a -> p) -> Binder fn a
bind forall a b. (a -> b) -> a -> b
$ \Term fn a
a -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Specification fn a -> Pred fn
satisfies Term fn a
a Specification fn a
sa)
          forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> (forall (f :: * -> *) a. Maybe Int -> f a -> Weighted f a
Weighted (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Int, Int)
h) forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a p.
(HasSpec fn a, IsPred p fn) =>
(Term fn a -> p) -> Binder fn a
bind forall a b. (a -> b) -> a -> b
$ \Term fn b
b -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Specification fn a -> Pred fn
satisfies Term fn b
b Specification fn b
sb)
          forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> forall {k} (f :: k -> *). List f '[]
Nil
      )

  cardinalTypeSpec :: TypeSpec fn (Sum a b) -> Specification fn Integer
cardinalTypeSpec (SumSpec Maybe (Int, Int)
_ Specification fn a
leftspec Specification fn b
rightspec) = forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Specification fn Integer
-> Specification fn Integer -> Specification fn Integer
addSpecInt (forall (fn :: [*] -> * -> *) a.
(Eq a, BaseUniverse fn, HasSpec fn a) =>
Specification fn a -> Specification fn Integer
cardinality Specification fn a
leftspec) (forall (fn :: [*] -> * -> *) a.
(Eq a, BaseUniverse fn, HasSpec fn a) =>
Specification fn a -> Specification fn Integer
cardinality Specification fn b
rightspec)

  typeSpecHasError :: TypeSpec fn (Sum a b) -> Maybe (NonEmpty [Char])
typeSpecHasError (SumSpec Maybe (Int, Int)
_ Specification fn a
x Specification fn b
y) =
    case (forall (fn :: [*] -> * -> *) a. Specification fn a -> Bool
isErrorLike Specification fn a
x, forall (fn :: [*] -> * -> *) a. Specification fn a -> Bool
isErrorLike Specification fn b
y) of
      (Bool
True, Bool
True) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (forall (fn :: [*] -> * -> *) a.
Specification fn a -> NonEmpty [Char]
errorLikeMessage Specification fn a
x forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
Specification fn a -> NonEmpty [Char]
errorLikeMessage Specification fn b
y)
      (Bool, Bool)
_ -> forall a. Maybe a
Nothing

  alternateShow :: TypeSpec fn (Sum a b) -> BinaryShow
alternateShow (SumSpec Maybe (Int, Int)
h Specification fn a
left right :: Specification fn b
right@(TypeSpec TypeSpec fn b
r [])) =
    case forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> BinaryShow
alternateShow @fn @b TypeSpec fn b
r of
      (BinaryShow [Char]
"SumSpec" [Doc a]
ps) -> forall a. [Char] -> [Doc a] -> BinaryShow
BinaryShow [Char]
"SumSpec" (Doc a
"|" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a. Maybe (Int, Int) -> Doc a
sumWeightL Maybe (Int, Int)
h forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow Specification fn a
left forall a. a -> [a] -> [a]
: [Doc a]
ps)
      (BinaryShow [Char]
"Cartesian" [Doc a]
ps) ->
        forall a. [Char] -> [Doc a] -> BinaryShow
BinaryShow [Char]
"SumSpec" (Doc a
"|" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a. Maybe (Int, Int) -> Doc a
sumWeightL Maybe (Int, Int)
h forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow Specification fn a
left forall a. a -> [a] -> [a]
: [forall ann. Doc ann -> Doc ann
parens (Doc a
"Cartesian" forall ann. Doc ann -> Doc ann -> Doc ann
/> forall ann. [Doc ann] -> Doc ann
vsep [Doc a]
ps)])
      BinaryShow
_ ->
        forall a. [Char] -> [Doc a] -> BinaryShow
BinaryShow [Char]
"SumSpec" [Doc Any
"|" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a. Maybe (Int, Int) -> Doc a
sumWeightL Maybe (Int, Int)
h forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow Specification fn a
left, Doc Any
"|" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a. Maybe (Int, Int) -> Doc a
sumWeightR Maybe (Int, Int)
h forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow Specification fn b
right]
  alternateShow (SumSpec Maybe (Int, Int)
h Specification fn a
left Specification fn b
right) =
    forall a. [Char] -> [Doc a] -> BinaryShow
BinaryShow [Char]
"SumSpec" [Doc Any
"|" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a. Maybe (Int, Int) -> Doc a
sumWeightL Maybe (Int, Int)
h forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow Specification fn a
left, Doc Any
"|" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a. Maybe (Int, Int) -> Doc a
sumWeightR Maybe (Int, Int)
h forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow Specification fn b
right]

sumType :: (Maybe String) -> String
sumType :: Maybe [Char] -> [Char]
sumType Maybe [Char]
Nothing = [Char]
""
sumType (Just [Char]
x) = [Char]
" type=" forall a. [a] -> [a] -> [a]
++ [Char]
x

sumWeightL, sumWeightR :: Maybe (Int, Int) -> Doc a
sumWeightL :: forall a. Maybe (Int, Int) -> Doc a
sumWeightL Maybe (Int, Int)
Nothing = Doc a
"1"
sumWeightL (Just (Int
x, Int
_)) = forall a. IsString a => [Char] -> a
fromString (forall a. Show a => a -> [Char]
show Int
x)
sumWeightR :: forall a. Maybe (Int, Int) -> Doc a
sumWeightR Maybe (Int, Int)
Nothing = Doc a
"1"
sumWeightR (Just (Int
_, Int
x)) = forall a. IsString a => [Char] -> a
fromString (forall a. Show a => a -> [Char]
show Int
x)

instance (KnownNat (CountCases b), HasSpec fn a, HasSpec fn b) => Show (SumSpec fn a b) where
  show :: SumSpec fn a b -> [Char]
show sumspec :: SumSpec fn a b
sumspec@(SumSpecRaw Maybe [Char]
tstring Maybe (Int, Int)
hint Specification fn a
l Specification fn b
r) = case forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> BinaryShow
alternateShow @fn @(Sum a b) SumSpec fn a b
sumspec of
    (BinaryShow [Char]
_ [Doc a]
ps) -> forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall ann. Doc ann -> Doc ann
parens (forall a. IsString a => [Char] -> a
fromString ([Char]
"SumSpec" forall a. [a] -> [a] -> [a]
++ Maybe [Char] -> [Char]
sumType Maybe [Char]
tstring) forall ann. Doc ann -> Doc ann -> Doc ann
/> forall ann. [Doc ann] -> Doc ann
vsep [Doc a]
ps)
    BinaryShow
NonBinary ->
      [Char]
"(SumSpec"
        forall a. [a] -> [a] -> [a]
++ Maybe [Char] -> [Char]
sumType Maybe [Char]
tstring
        forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a. Maybe (Int, Int) -> Doc a
sumWeightL Maybe (Int, Int)
hint)
        forall a. [a] -> [a] -> [a]
++ [Char]
" ("
        forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn a
l
        forall a. [a] -> [a] -> [a]
++ [Char]
") "
        forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a. Maybe (Int, Int) -> Doc a
sumWeightR Maybe (Int, Int)
hint)
        forall a. [a] -> [a] -> [a]
++ [Char]
" ("
        forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn b
r
        forall a. [a] -> [a] -> [a]
++ [Char]
"))"

-- Sets -------------------------------------------------------------------

data SetSpec fn a = SetSpec (Set a) (Specification fn a) (Specification fn Integer)

instance (BaseUniverse fn, Ord a, Arbitrary (Specification fn a), Arbitrary a) => Arbitrary (SetSpec fn a) where
  arbitrary :: Gen (SetSpec fn a)
arbitrary = forall (fn :: [*] -> * -> *) a.
Set a
-> Specification fn a -> Specification fn Integer -> SetSpec fn a
SetSpec forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary
  shrink :: SetSpec fn a -> [SetSpec fn a]
shrink (SetSpec Set a
a Specification fn a
b Specification fn Integer
c) = [forall (fn :: [*] -> * -> *) a.
Set a
-> Specification fn a -> Specification fn Integer -> SetSpec fn a
SetSpec Set a
a' Specification fn a
b' Specification fn Integer
c' | (Set a
a', Specification fn a
b', Specification fn Integer
c') <- forall a. Arbitrary a => a -> [a]
shrink (Set a
a, Specification fn a
b, Specification fn Integer
c)]

-- TODO: consider improving this
instance Arbitrary (FoldSpec fn (Set a)) where
  arbitrary :: Gen (FoldSpec fn (Set a))
arbitrary = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (fn :: [*] -> * -> *) a. FoldSpec fn a
NoFold

instance (Ord a, HasSpec fn a) => Semigroup (SetSpec fn a) where
  SetSpec Set a
must Specification fn a
es Specification fn Integer
size <> :: SetSpec fn a -> SetSpec fn a -> SetSpec fn a
<> SetSpec Set a
must' Specification fn a
es' Specification fn Integer
size' =
    forall (fn :: [*] -> * -> *) a.
Set a
-> Specification fn a -> Specification fn Integer -> SetSpec fn a
SetSpec (Set a
must forall a. Semigroup a => a -> a -> a
<> Set a
must') (Specification fn a
es forall a. Semigroup a => a -> a -> a
<> Specification fn a
es') (Specification fn Integer
size forall a. Semigroup a => a -> a -> a
<> Specification fn Integer
size')

instance (Ord a, HasSpec fn a) => Monoid (SetSpec fn a) where
  mempty :: SetSpec fn a
mempty = forall (fn :: [*] -> * -> *) a.
Set a
-> Specification fn a -> Specification fn Integer -> SetSpec fn a
SetSpec forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec

guardSetSpec :: (HasSpec fn a, Ord a) => [String] -> SetSpec fn a -> Specification fn (Set a)
guardSetSpec :: forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, Ord a) =>
[[Char]] -> SetSpec fn a -> Specification fn (Set a)
guardSetSpec [[Char]]
es (SetSpec Set a
must Specification fn a
elem ((forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
geqSpec Integer
0) -> Specification fn Integer
size))
  | Just Integer
u <- forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownUpperBound Specification fn Integer
size
  , Integer
u forall a. Ord a => a -> a -> Bool
< Integer
0 =
      forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec (([Char]
"guardSetSpec: negative size " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Integer
u) forall a. a -> [a] -> NonEmpty a
:| [[Char]]
es)
  | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
`conformsToSpec` Specification fn a
elem) Set a
must) =
      forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec (([Char]
"Some 'must' items do not conform to 'element' spec: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn a
elem) forall a. a -> [a] -> NonEmpty a
:| [[Char]]
es)
  | forall (fn :: [*] -> * -> *) a. Specification fn a -> Bool
isErrorLike Specification fn Integer
size = forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec ([Char]
"guardSetSpec: error in size" forall a. a -> [a] -> NonEmpty a
:| [[Char]]
es)
  | forall (fn :: [*] -> * -> *) a. Specification fn a -> Bool
isErrorLike (forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
geqSpec (forall (fn :: [*] -> * -> *) t. Sized fn t => t -> Integer
sizeOf Set a
must) forall a. Semigroup a => a -> a -> a
<> Specification fn Integer
size) =
      forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec forall a b. (a -> b) -> a -> b
$
        ([Char]
"Must set size " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall (fn :: [*] -> * -> *) t. Sized fn t => t -> Integer
sizeOf Set a
must) forall a. [a] -> [a] -> [a]
++ [Char]
", is inconsistent with SetSpec size" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn Integer
size) forall a. a -> [a] -> NonEmpty a
:| [[Char]]
es
  | forall (fn :: [*] -> * -> *) a. Specification fn a -> Bool
isErrorLike (forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Specification fn Integer -> Specification fn Integer
maxSpec (forall (fn :: [*] -> * -> *) a.
(Eq a, BaseUniverse fn, HasSpec fn a) =>
Specification fn a -> Specification fn Integer
cardinality Specification fn a
elem) forall a. Semigroup a => a -> a -> a
<> Specification fn Integer
size) =
      forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec forall a b. (a -> b) -> a -> b
$
        forall a. [a] -> NonEmpty a
NE.fromList forall a b. (a -> b) -> a -> b
$
          [ [Char]
"Cardinality of SetSpec elemSpec (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Specification fn a
elem) forall a. [a] -> [a] -> [a]
++ [Char]
") = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Specification fn Integer -> Specification fn Integer
maxSpec (forall (fn :: [*] -> * -> *) a.
(Eq a, BaseUniverse fn, HasSpec fn a) =>
Specification fn a -> Specification fn Integer
cardinality Specification fn a
elem))
          , [Char]
"   This is inconsistent with SetSpec size (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn Integer
size forall a. [a] -> [a] -> [a]
++ [Char]
")"
          ]
            forall a. [a] -> [a] -> [a]
++ [[Char]]
es
  | Bool
otherwise = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec (forall (fn :: [*] -> * -> *) a.
Set a
-> Specification fn a -> Specification fn Integer -> SetSpec fn a
SetSpec Set a
must Specification fn a
elem Specification fn Integer
size)

instance (Ord a, HasSpec fn a) => HasSpec fn (Set a) where
  type TypeSpec fn (Set a) = SetSpec fn a

  type Prerequisites fn (Set a) = HasSpec fn a

  emptySpec :: TypeSpec fn (Set a)
emptySpec = forall a. Monoid a => a
mempty

  combineSpec :: TypeSpec fn (Set a)
-> TypeSpec fn (Set a) -> Specification fn (Set a)
combineSpec TypeSpec fn (Set a)
s TypeSpec fn (Set a)
s' = forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, Ord a) =>
[[Char]] -> SetSpec fn a -> Specification fn (Set a)
guardSetSpec [[Char]
"While combining 2 SetSpecs", [Char]
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show TypeSpec fn (Set a)
s, [Char]
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show TypeSpec fn (Set a)
s'] (TypeSpec fn (Set a)
s forall a. Semigroup a => a -> a -> a
<> TypeSpec fn (Set a)
s')

  conformsTo :: HasCallStack => Set a -> TypeSpec fn (Set a) -> Bool
conformsTo Set a
s (SetSpec Set a
must Specification fn a
es Specification fn Integer
size) =
    forall (t :: * -> *). Foldable t => t Bool -> Bool
and
      [ forall (fn :: [*] -> * -> *) t. Sized fn t => t -> Integer
sizeOf Set a
s forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
`conformsToSpec` Specification fn Integer
size
      , Set a
must forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set a
s
      , forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
`conformsToSpec` Specification fn a
es) Set a
s
      ]

  genFromTypeSpec :: forall (m :: * -> *).
(HasCallStack, MonadGenError m) =>
TypeSpec fn (Set a) -> GenT m (Set a)
genFromTypeSpec (SetSpec Set a
must Specification fn a
e Specification fn Integer
_)
    | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
`conformsToSpec` Specification fn a
e)) Set a
must =
        forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
genError
          ( forall a. [a] -> NonEmpty a
NE.fromList
              [ [Char]
"Failed to generate set"
              , [Char]
"Some element in the must set does not conform to the elem specification"
              , [Char]
"Unconforming elements from the must set:"
              , [[Char]] -> [Char]
unlines (forall a b. (a -> b) -> [a] -> [b]
map (\a
x -> [Char]
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
x) (forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
`conformsToSpec` Specification fn a
e)) (forall a. Set a -> [a]
Set.toList Set a
must)))
              , [Char]
"Element Specifcation"
              , [Char]
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn a
e
              ]
          )
  -- Special case when elemS is a MemberSpec.
  -- Just union 'must' with enough elements of 'xs' to meet  'szSpec'
  genFromTypeSpec (SetSpec Set a
must (ExplainSpec [] Specification fn a
elemspec) Specification fn Integer
szSpec) =
    forall (fn :: [*] -> * -> *) a (m :: * -> *).
(HasSpec fn a, HasCallStack, MonadGenError m) =>
TypeSpec fn a -> GenT m a
genFromTypeSpec (forall (fn :: [*] -> * -> *) a.
Set a
-> Specification fn a -> Specification fn Integer -> SetSpec fn a
SetSpec Set a
must Specification fn a
elemspec Specification fn Integer
szSpec)
  genFromTypeSpec (SetSpec Set a
must (ExplainSpec ([Char]
e : [[Char]]
es) Specification fn a
elemspec) Specification fn Integer
szSpec) =
    forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a -> m a
explain ([Char]
e forall a. a -> [a] -> NonEmpty a
:| [[Char]]
es) forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a (m :: * -> *).
(HasSpec fn a, HasCallStack, MonadGenError m) =>
TypeSpec fn a -> GenT m a
genFromTypeSpec (forall (fn :: [*] -> * -> *) a.
Set a
-> Specification fn a -> Specification fn Integer -> SetSpec fn a
SetSpec Set a
must Specification fn a
elemspec Specification fn Integer
szSpec)
  genFromTypeSpec (SetSpec Set a
must elemS :: Specification fn a
elemS@(MemberSpec NonEmpty a
xs) Specification fn Integer
szSpec) = do
    let szSpec' :: Specification fn Integer
szSpec' = Specification fn Integer
szSpec forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
geqSpec @fn (forall (fn :: [*] -> * -> *) t. Sized fn t => t -> Integer
sizeOf Set a
must) forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Specification fn Integer -> Specification fn Integer
maxSpec (forall (fn :: [*] -> * -> *) a.
(Eq a, BaseUniverse fn, HasSpec fn a) =>
Specification fn a -> Specification fn Integer
cardinality Specification fn a
elemS)
    [a]
choices <- forall (m :: * -> *) a. Applicative m => Gen a -> GenT m a
pureGen forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Gen [a]
shuffle (forall a. NonEmpty a -> [a]
NE.toList NonEmpty a
xs forall a. Eq a => [a] -> [a] -> [a]
\\ forall a. Set a -> [a]
Set.toList Set a
must)
    Int
size <- forall a. Num a => Integer -> a
fromInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (fn :: [*] -> * -> *) a (m :: * -> *).
(HasCallStack, HasSpec fn a, MonadGenError m) =>
Specification fn a -> GenT m a
genFromSpecT Specification fn Integer
szSpec'
    let additions :: Set a
additions = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take (Int
size forall a. Num a => a -> a -> a
- forall a. Set a -> Int
Set.size Set a
must) [a]
choices
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Ord a => Set a -> Set a -> Set a
Set.union Set a
must Set a
additions)
  genFromTypeSpec (SetSpec Set a
must Specification fn a
elemS Specification fn Integer
szSpec) = do
    let szSpec' :: Specification fn Integer
szSpec' = (Specification fn Integer
szSpec forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
geqSpec @fn (forall (fn :: [*] -> * -> *) t. Sized fn t => t -> Integer
sizeOf Set a
must) forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Specification fn Integer -> Specification fn Integer
maxSpec (forall (fn :: [*] -> * -> *) a.
(Eq a, BaseUniverse fn, HasSpec fn a) =>
Specification fn a -> Specification fn Integer
cardinality Specification fn a
elemS))
    Integer
count <-
      forall (m :: * -> *) a. MonadGenError m => [Char] -> m a -> m a
explain1 ([Char]
"Choose a size for the Set to be generated") forall a b. (a -> b) -> a -> b
$
        forall (fn :: [*] -> * -> *) a (m :: * -> *).
(HasCallStack, HasSpec fn a, MonadGenError m) =>
Specification fn a -> GenT m a
genFromSpecT Specification fn Integer
szSpec'
    forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a -> m a
explain
      ( forall a. [a] -> NonEmpty a
NE.fromList
          [ [Char]
"Choose size count = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Integer
count
          , [Char]
"szSpec' = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn Integer
szSpec'
          , [Char]
"Picking items not in must = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a x. (Show a, Typeable a) => [a] -> Doc x
short (forall a. Set a -> [a]
Set.toList Set a
must))
          , [Char]
"that also meet the element test: "
          , [Char]
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn a
elemS
          ]
      )
      forall a b. (a -> b) -> a -> b
$ Int -> Integer -> Set a -> GenT m (Set a)
go Int
100 (Integer
count forall a. Num a => a -> a -> a
- forall (fn :: [*] -> * -> *) t. Sized fn t => t -> Integer
sizeOf Set a
must) Set a
must
    where
      go :: Int -> Integer -> Set a -> GenT m (Set a)
go Int
_ Integer
n Set a
s | Integer
n forall a. Ord a => a -> a -> Bool
<= Integer
0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Set a
s
      go Int
tries Integer
n Set a
s = do
        a
e <-
          forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a -> m a
explain
            ( forall a. [a] -> NonEmpty a
NE.fromList
                [ [Char]
"Generate set member:"
                , [Char]
"  number of items starting with  = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a. Set a -> Int
Set.size Set a
must)
                , [Char]
"  number of items left to pick   = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Integer
n
                , [Char]
"  number of items already picked = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a. Set a -> Int
Set.size Set a
s)
                ]
            )
            forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. GenMode -> GenT m a -> GenT m a
withMode GenMode
Strict
            forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadGenError m =>
Int -> GenT m a -> (a -> Bool) -> GenT m a
suchThatWithTryT Int
tries (forall (fn :: [*] -> * -> *) a (m :: * -> *).
(HasCallStack, HasSpec fn a, MonadGenError m) =>
Specification fn a -> GenT m a
genFromSpecT Specification fn a
elemS) (forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set a
s)

        Int -> Integer -> Set a -> GenT m (Set a)
go Int
tries (Integer
n forall a. Num a => a -> a -> a
- Integer
1) (forall a. Ord a => a -> Set a -> Set a
Set.insert a
e Set a
s)

  cardinalTypeSpec :: TypeSpec fn (Set a) -> Specification fn Integer
cardinalTypeSpec (SetSpec Set a
_ Specification fn a
es Specification fn Integer
_)
    | Just Integer
ub <- forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownUpperBound (forall (fn :: [*] -> * -> *) a.
(Eq a, BaseUniverse fn, HasSpec fn a) =>
Specification fn a -> Specification fn Integer
cardinality Specification fn a
es) = forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
leqSpec (Integer
2 forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
ub)
  cardinalTypeSpec TypeSpec fn (Set a)
_ = forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec

  cardinalTrueSpec :: Specification fn Integer
cardinalTrueSpec
    | Just Integer
ub <- forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownUpperBound forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn Integer
cardinalTrueSpec @fn @a = forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
leqSpec (Integer
2 forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
ub)
    | Bool
otherwise = forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec

  shrinkWithTypeSpec :: TypeSpec fn (Set a) -> Set a -> [Set a]
shrinkWithTypeSpec (SetSpec Set a
_ Specification fn a
es Specification fn Integer
_) Set a
as = forall a b. (a -> b) -> [a] -> [b]
map forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn a -> a -> [a]
shrinkWithSpec Specification fn a
es) (forall a. Set a -> [a]
Set.toList Set a
as)

  toPreds :: Term fn (Set a) -> TypeSpec fn (Set a) -> Pred fn
toPreds Term fn (Set a)
s (SetSpec Set a
m Specification fn a
es Specification fn Integer
size) =
    forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall a b. (a -> b) -> a -> b
$
      -- Don't include this if the must set is empty
      [ forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn -> Pred fn
Explain (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Show a => a -> [Char]
show Set a
m forall a. [a] -> [a] -> [a]
++ [Char]
" is a subset of the set.")) forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Term fn Bool -> Pred fn
Assert forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
(HasSpec fn (Set a), Ord a, Show a, Typeable a) =>
Term fn (Set a) -> Term fn (Set a) -> Term fn Bool
subset_ (forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit Set a
m) Term fn (Set a)
s
      | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Set a -> Bool
Set.null Set a
m
      ]
        forall a. [a] -> [a] -> [a]
++ [ forall t a (fn :: [*] -> * -> *) p.
(Forallable t a, HasSpec fn t, HasSpec fn a, IsPred p fn) =>
Term fn t -> (Term fn a -> p) -> Pred fn
forAll Term fn (Set a)
s (\Term fn a
e -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Specification fn a -> Pred fn
satisfies Term fn a
e Specification fn a
es)
           , forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Specification fn a -> Pred fn
satisfies (forall a (fn :: [*] -> * -> *).
(HasSpec fn (Set a), Ord a) =>
Term fn (Set a) -> Term fn Integer
size_ Term fn (Set a)
s) Specification fn Integer
size
           ]
  guardTypeSpec :: [[Char]] -> TypeSpec fn (Set a) -> Specification fn (Set a)
guardTypeSpec = forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, Ord a) =>
[[Char]] -> SetSpec fn a -> Specification fn (Set a)
guardSetSpec

instance Ord a => Forallable (Set a) a where
  fromForAllSpec :: forall (fn :: [*] -> * -> *).
(HasSpec fn (Set a), HasSpec fn a, BaseUniverse fn) =>
Specification fn a -> Specification fn (Set a)
fromForAllSpec (Specification fn a
e :: Specification fn a)
    | Evidence (Prerequisites fn (Set a))
Evidence <- forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Evidence (Prerequisites fn a)
prerequisites @fn @(Set a) = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
Set a
-> Specification fn a -> Specification fn Integer -> SetSpec fn a
SetSpec forall a. Monoid a => a
mempty Specification fn a
e forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec
  forAllToList :: Set a -> [a]
forAllToList = forall a. Set a -> [a]
Set.toList

prettySetSpec :: HasSpec fn a => SetSpec fn a -> Doc ann
prettySetSpec :: forall (fn :: [*] -> * -> *) a ann.
HasSpec fn a =>
SetSpec fn a -> Doc ann
prettySetSpec (SetSpec Set a
must Specification fn a
elem Specification fn Integer
size) =
  forall ann. Doc ann -> Doc ann
parens
    ( Doc ann
"SetSpec"
        forall ann. Doc ann -> Doc ann -> Doc ann
/> forall ann. [Doc ann] -> Doc ann
sep [Doc ann
"must=" forall a. Semigroup a => a -> a -> a
<> forall a x. (Show a, Typeable a) => [a] -> Doc x
short (forall a. Set a -> [a]
Set.toList Set a
must), Doc ann
"elem=" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Specification fn a
elem, Doc ann
"size=" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Specification fn Integer
size]
    )

instance HasSpec fn a => Show (SetSpec fn a) where
  show :: SetSpec fn a -> [Char]
show SetSpec fn a
x = forall a. Show a => a -> [Char]
show (forall (fn :: [*] -> * -> *) a ann.
HasSpec fn a =>
SetSpec fn a -> Doc ann
prettySetSpec SetSpec fn a
x)

instance BaseUniverse fn => Functions (SetFn fn) fn where
  propagateSpecFun :: forall (as :: [*]) a b.
(TypeList as, Typeable as, HasSpec fn a, HasSpec fn b,
 All (HasSpec fn) as) =>
SetFn fn as b
-> ListCtx Value as (HOLE a)
-> Specification fn b
-> Specification fn a
propagateSpecFun SetFn fn as b
fn ListCtx Value as (HOLE a)
ctx (ExplainSpec [[Char]]
es Specification fn b
s) = forall (fn :: [*] -> * -> *) a.
[[Char]] -> Specification fn a -> Specification fn a
explainSpecOpt [[Char]]
es forall a b. (a -> b) -> a -> b
$ forall (f :: [*] -> * -> *) (fn :: [*] -> * -> *) (as :: [*]) a b.
(Functions f fn, TypeList as, Typeable as, HasSpec fn a,
 HasSpec fn b, All (HasSpec fn) as) =>
f as b
-> ListCtx Value as (HOLE a)
-> Specification fn b
-> Specification fn a
propagateSpecFun SetFn fn as b
fn ListCtx Value as (HOLE a)
ctx Specification fn b
s
  propagateSpecFun SetFn fn as b
_ ListCtx Value as (HOLE a)
_ Specification fn b
TrueSpec = forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec
  propagateSpecFun SetFn fn as b
_ ListCtx Value as (HOLE a)
_ (ErrorSpec NonEmpty [Char]
err) = forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec NonEmpty [Char]
err
  propagateSpecFun SetFn fn as b
fn ListCtx Value as (HOLE a)
ctx Specification fn b
spec = case SetFn fn as b
fn of
    SetFn fn as b
_
      | SuspendedSpec Var b
x Pred fn
p <- Specification fn b
spec
      , ListCtx List Value as
pre HOLE a a
HOLE List Value as'
suf <- ListCtx Value as (HOLE a)
ctx ->
          forall a (fn :: [*] -> * -> *) p.
(IsPred p fn, HasSpec fn a) =>
(Term fn a -> p) -> Specification fn a
constrained forall a b. (a -> b) -> a -> b
$ \Term fn a
x' ->
            let args :: List (Term fn) (Append as (a : as'))
args =
                  forall {a} (f :: a -> *) (as :: [a]) (bs :: [a]).
List f as -> List f bs -> List f (Append as bs)
appendList
                    (forall {k} (f :: k -> *) (g :: k -> *) (as :: [k]).
(forall (a :: k). f a -> g a) -> List f as -> List g as
mapList (\(Value a
a) -> forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit a
a) List Value as
pre)
                    (Term fn a
x' forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> forall {k} (f :: k -> *) (g :: k -> *) (as :: [k]).
(forall (a :: k). f a -> g a) -> List f as -> List g as
mapList (\(Value a
a) -> forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit a
a) List Value as'
suf)
             in forall (fn :: [*] -> * -> *) a. Term fn a -> Binder fn a -> Pred fn
Let (forall (a :: [*]) (fn :: [*] -> * -> *) b.
(Typeable a, TypeList a, All (HasSpec fn) a, HasSpec fn b,
 BaseUniverse fn) =>
fn a b -> List (Term fn) a -> Term fn b
App (forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fn as b -> fnU as b
injectFn SetFn fn as b
fn) List (Term fn) (Append as (a : as'))
args) (Var b
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Binder fn a
:-> Pred fn
p)
    SetFn fn as b
Singleton
      | NilCtx HOLE a a
HOLE <- ListCtx Value as (HOLE a)
ctx ->
          let singletons :: [Set a] -> [Set a]
singletons = forall a. (a -> Bool) -> [a] -> [a]
filter ((Int
1 forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Int
Set.size)
           in case Specification fn b
spec of
                TypeSpec (SetSpec Set a
must Specification fn a
es Specification fn Integer
size) OrdSet b
cant
                  -- TODO: improve error message
                  | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Integer
1 forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
`conformsToSpec` Specification fn Integer
size ->
                      forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"propagateSpecFun Singleton with spec that doesn't accept 1 size set")
                  | [a
a] <- forall a. Set a -> [a]
Set.toList Set a
must
                  , a
a forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
`conformsToSpec` Specification fn a
es
                  , forall a. a -> Set a
Set.singleton a
a forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` OrdSet b
cant ->
                      forall a (fn :: [*] -> * -> *). a -> Specification fn a
equalSpec a
a
                  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set a
must -> Specification fn a
es forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a (f :: * -> *).
(HasSpec fn a, Foldable f) =>
f a -> Specification fn a
notMemberSpec (forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall a b. (a -> b) -> a -> b
$ forall {a}. [Set a] -> [Set a]
singletons OrdSet b
cant)
                  | Bool
otherwise -> forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"propagateSpecFun Singleton with `must` of size > 1")
                MemberSpec NonEmpty b
es ->
                  forall a (fn :: [*] -> * -> *).
[a] -> NonEmpty [Char] -> Specification fn a
memberSpecList
                    (forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall a b. (a -> b) -> a -> b
$ forall {a}. [Set a] -> [Set a]
singletons (forall a. NonEmpty a -> [a]
NE.toList NonEmpty b
es))
                    (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"In propagateSpecFun Singleton, the sets of size 1, in MemberSpec is empty")
    SetFn fn as b
Union
      | Value a
s :! NilCtx HOLE a (Set a)
HOLE <- ListCtx Value as (HOLE a)
ctx ->
          forall (f :: [*] -> * -> *) (fn :: [*] -> * -> *) (as :: [*]) a b.
(Functions f fn, TypeList as, Typeable as, HasSpec fn a,
 HasSpec fn b, All (HasSpec fn) as) =>
f as b
-> ListCtx Value as (HOLE a)
-> Specification fn b
-> Specification fn a
propagateSpecFun @(SetFn fn) @fn forall a (fn :: [*] -> * -> *).
(Ord a, Show a, Typeable a) =>
SetFn fn '[Set a, Set a] (Set a)
Union (forall a. HOLE a a
HOLE forall (c :: * -> *) a (f :: * -> *) (as1 :: [*]).
c a -> List f as1 -> ListCtx f (a : as1) c
:? forall a. Show a => a -> Value a
Value a
s forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> forall {k} (f :: k -> *). List f '[]
Nil) Specification fn b
spec
      | HOLE a a
HOLE :? Value (Set a
s :: Set a) :> List Value as1
Nil <- ListCtx Value as (HOLE a)
ctx
      , Evidence (Prerequisites fn (Set a))
Evidence <- forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Evidence (Prerequisites fn a)
prerequisites @fn @(Set a) ->
          case Specification fn b
spec of
            Specification fn b
_ | forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set a
s -> Specification fn b
spec
            TypeSpec (SetSpec Set a
must Specification fn a
es Specification fn Integer
size) OrdSet b
cant
              | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
`conformsToSpec` Specification fn a
es) Set a
s ->
                  forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec forall a b. (a -> b) -> a -> b
$
                    forall a. [a] -> NonEmpty a
NE.fromList
                      [ [Char]
"Elements in union argument does not conform to elem spec"
                      , [Char]
"  spec: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn a
es
                      , [Char]
"  elems: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
`conformsToSpec` Specification fn a
es)) (forall a. Set a -> [a]
Set.toList Set a
s))
                      ]
              | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null OrdSet b
cant -> forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"propagateSpecFun Union TypeSpec, not (null cant)")
              | Specification fn Integer
TrueSpec <- Specification fn Integer
size -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
Set a
-> Specification fn a -> Specification fn Integer -> SetSpec fn a
SetSpec (forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set a
must Set a
s) Specification fn a
es forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec
              | TypeSpec (NumSpecInterval Maybe Integer
mlb Maybe Integer
Nothing) [] <- Specification fn Integer
size
              , forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (forall a. Ord a => a -> a -> Bool
<= forall (fn :: [*] -> * -> *) t. Sized fn t => t -> Integer
sizeOf Set a
s) Maybe Integer
mlb ->
                  forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
Set a
-> Specification fn a -> Specification fn Integer -> SetSpec fn a
SetSpec (forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set a
must Set a
s) Specification fn a
es forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec
              | Bool
otherwise -> forall a (fn :: [*] -> * -> *) p.
(IsPred p fn, HasSpec fn a) =>
(Term fn a -> p) -> Specification fn a
constrained forall a b. (a -> b) -> a -> b
$ \Term fn a
x ->
                  forall a p (fn :: [*] -> * -> *).
(HasSpec fn a, IsPred p fn) =>
((forall b. Term fn b -> b) -> GE a) -> (Term fn a -> p) -> Pred fn
exists (\forall b. Term fn b -> b
eval -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Ord a => Set a -> Set a -> Set a
Set.intersection (forall b. Term fn b -> b
eval Term fn a
x) Set a
s) forall a b. (a -> b) -> a -> b
$ \Term fn (Set a)
overlap ->
                    forall a p (fn :: [*] -> * -> *).
(HasSpec fn a, IsPred p fn) =>
((forall b. Term fn b -> b) -> GE a) -> (Term fn a -> p) -> Pred fn
exists (\forall b. Term fn b -> b
eval -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Ord a => Set a -> Set a -> Set a
Set.difference (forall b. Term fn b -> b
eval Term fn a
x) Set a
s) forall a b. (a -> b) -> a -> b
$ \Term fn (Set a)
disjoint ->
                      [ forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
p -> Pred fn
assert forall a b. (a -> b) -> a -> b
$ Term fn (Set a)
overlap forall (fn :: [*] -> * -> *) a.
(HasSpec fn (Set a), Ord a, Show a, Typeable a) =>
Term fn (Set a) -> Term fn (Set a) -> Term fn Bool
`subset_` forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit Set a
s
                      , forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
p -> Pred fn
assert forall a b. (a -> b) -> a -> b
$ Term fn (Set a)
disjoint forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, Ord a) =>
Term fn (Set a) -> Term fn (Set a) -> Term fn Bool
`disjoint_` forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit Set a
s
                      , forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Specification fn a -> Pred fn
satisfies (forall a (fn :: [*] -> * -> *).
(HasSpec fn (Set a), Ord a) =>
Term fn (Set a) -> Term fn Integer
size_ Term fn (Set a)
disjoint forall a. Num a => a -> a -> a
+ forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit (forall (fn :: [*] -> * -> *) t. Sized fn t => t -> Integer
sizeOf Set a
s)) Specification fn Integer
size
                      , forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
p -> Pred fn
assert forall a b. (a -> b) -> a -> b
$ Term fn a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Term fn a -> Term fn Bool
==. Term fn (Set a)
overlap forall a. Semigroup a => a -> a -> a
<> Term fn (Set a)
disjoint
                      , forall t a (fn :: [*] -> * -> *) p.
(Forallable t a, HasSpec fn t, HasSpec fn a, IsPred p fn) =>
Term fn t -> (Term fn a -> p) -> Pred fn
forAll Term fn (Set a)
disjoint forall a b. (a -> b) -> a -> b
$ \Term fn a
e -> Term fn a
e forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Specification fn a -> Pred fn
`satisfies` Specification fn a
es
                      , forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
p -> Pred fn
assert forall a b. (a -> b) -> a -> b
$ forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
lit (Set a
must forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set a
s) forall (fn :: [*] -> * -> *) a.
(HasSpec fn (Set a), Ord a, Show a, Typeable a) =>
Term fn (Set a) -> Term fn (Set a) -> Term fn Bool
`subset_` Term fn (Set a)
disjoint
                      ]
            -- We only do singleton MemberSpec to avoid really bad blowup
            MemberSpec (b
e :| [])
              | Set a
s forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` b
e ->
                  forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec
                    ( forall (fn :: [*] -> * -> *) a.
Set a
-> Specification fn a -> Specification fn Integer -> SetSpec fn a
SetSpec
                        (forall a. Ord a => Set a -> Set a -> Set a
Set.difference b
e Set a
s)
                        ( forall a (fn :: [*] -> * -> *).
[a] -> NonEmpty [Char] -> Specification fn a
memberSpecList
                            (forall a. Set a -> [a]
Set.toList b
e)
                            (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"propagateSpec (union_ s HOLE) on (MemberSpec [e]) where e is the empty set")
                        )
                        forall a. Monoid a => a
mempty
                    )
            -- TODO: improve this error message
            Specification fn b
_ ->
              forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec
                ( forall a. [a] -> NonEmpty a
NE.fromList
                    [ [Char]
"propagateSpecFun (union_ s HOLE) with spec"
                    , [Char]
"s = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Set a
s
                    , [Char]
"spec = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn b
spec
                    ]
                )
    SetFn fn as b
Subset
      | HOLE a a
HOLE :? Value (Set a
s :: Set a) :> List Value as1
Nil <- ListCtx Value as (HOLE a)
ctx
      , Evidence (Prerequisites fn (Set a))
Evidence <- forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Evidence (Prerequisites fn a)
prerequisites @fn @(Set a) -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn Bool
-> (Bool -> Specification fn a) -> Specification fn a
caseBoolSpec Specification fn b
spec forall a b. (a -> b) -> a -> b
$ \case
          Bool
True ->
            case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty (forall a. Set a -> [a]
Set.toList Set a
s) of
              Maybe (NonEmpty a)
Nothing -> forall a (fn :: [*] -> * -> *). NonEmpty a -> Specification fn a
MemberSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Set a
Set.empty)
              Just NonEmpty a
slist -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
Set a
-> Specification fn a -> Specification fn Integer -> SetSpec fn a
SetSpec forall a. Monoid a => a
mempty (forall a (fn :: [*] -> * -> *). NonEmpty a -> Specification fn a
MemberSpec NonEmpty a
slist) forall a. Monoid a => a
mempty
          Bool
False -> forall a (fn :: [*] -> * -> *) p.
(IsPred p fn, HasSpec fn a) =>
(Term fn a -> p) -> Specification fn a
constrained forall a b. (a -> b) -> a -> b
$ \Term fn a
set ->
            forall a p (fn :: [*] -> * -> *).
(HasSpec fn a, IsPred p fn) =>
((forall b. Term fn b -> b) -> GE a) -> (Term fn a -> p) -> Pred fn
exists (\forall b. Term fn b -> b
eval -> forall (t :: * -> *) a. Foldable t => t a -> GE a
headGE forall a b. (a -> b) -> a -> b
$ forall a. Ord a => Set a -> Set a -> Set a
Set.difference (forall b. Term fn b -> b
eval Term fn a
set) Set a
s) forall a b. (a -> b) -> a -> b
$ \Term fn a
e ->
              [ Term fn a
set forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, HasSpec fn b) =>
Term fn a -> Term fn b -> Pred fn
`DependsOn` Term fn a
e
              , forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
p -> Pred fn
assert forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Term fn Bool -> Term fn Bool
not_ forall a b. (a -> b) -> a -> b
$ forall a (fn :: [*] -> * -> *).
(HasSpec fn a, Ord a) =>
Term fn a -> Term fn (Set a) -> Term fn Bool
member_ Term fn a
e (forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit Set a
s)
              , forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
p -> Pred fn
assert forall a b. (a -> b) -> a -> b
$ forall a (fn :: [*] -> * -> *).
(HasSpec fn a, Ord a) =>
Term fn a -> Term fn (Set a) -> Term fn Bool
member_ Term fn a
e Term fn a
set
              ]
      | Value (Set a
s :: Set a) :! NilCtx HOLE a (Set a)
HOLE <- ListCtx Value as (HOLE a)
ctx
      , Evidence (Prerequisites fn (Set a))
Evidence <- forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Evidence (Prerequisites fn a)
prerequisites @fn @(Set a) -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn Bool
-> (Bool -> Specification fn a) -> Specification fn a
caseBoolSpec Specification fn b
spec forall a b. (a -> b) -> a -> b
$ \case
          Bool
True -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
Set a
-> Specification fn a -> Specification fn Integer -> SetSpec fn a
SetSpec Set a
s forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec forall a. Monoid a => a
mempty
          Bool
False -> forall a (fn :: [*] -> * -> *) p.
(IsPred p fn, HasSpec fn a) =>
(Term fn a -> p) -> Specification fn a
constrained forall a b. (a -> b) -> a -> b
$ \Term fn a
set ->
            forall a p (fn :: [*] -> * -> *).
(HasSpec fn a, IsPred p fn) =>
((forall b. Term fn b -> b) -> GE a) -> (Term fn a -> p) -> Pred fn
exists (\forall b. Term fn b -> b
eval -> forall (t :: * -> *) a. Foldable t => t a -> GE a
headGE forall a b. (a -> b) -> a -> b
$ forall a. Ord a => Set a -> Set a -> Set a
Set.difference (forall b. Term fn b -> b
eval Term fn a
set) Set a
s) forall a b. (a -> b) -> a -> b
$ \Term fn a
e ->
              [ Term fn a
set forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, HasSpec fn b) =>
Term fn a -> Term fn b -> Pred fn
`DependsOn` Term fn a
e
              , forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
p -> Pred fn
assert forall a b. (a -> b) -> a -> b
$ forall a (fn :: [*] -> * -> *).
(HasSpec fn a, Ord a) =>
Term fn a -> Term fn (Set a) -> Term fn Bool
member_ Term fn a
e (forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit Set a
s)
              , forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
p -> Pred fn
assert forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Term fn Bool -> Term fn Bool
not_ forall a b. (a -> b) -> a -> b
$ forall a (fn :: [*] -> * -> *).
(HasSpec fn a, Ord a) =>
Term fn a -> Term fn (Set a) -> Term fn Bool
member_ Term fn a
e Term fn a
set
              ]
    SetFn fn as b
Member
      | HOLE a a
HOLE :? Value a
s :> List Value as1
Nil <- ListCtx Value as (HOLE a)
ctx -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn Bool
-> (Bool -> Specification fn a) -> Specification fn a
caseBoolSpec Specification fn b
spec forall a b. (a -> b) -> a -> b
$ \case
          Bool
True -> forall a (fn :: [*] -> * -> *).
[a] -> NonEmpty [Char] -> Specification fn a
memberSpecList (forall a. Set a -> [a]
Set.toList a
s) (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"propagateSpecFun on (Member x s) where s is Set.empty")
          Bool
False -> forall (fn :: [*] -> * -> *) a (f :: * -> *).
(HasSpec fn a, Foldable f) =>
f a -> Specification fn a
notMemberSpec a
s
      | Value a
e :! NilCtx HOLE a (Set a)
HOLE <- ListCtx Value as (HOLE a)
ctx -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn Bool
-> (Bool -> Specification fn a) -> Specification fn a
caseBoolSpec Specification fn b
spec forall a b. (a -> b) -> a -> b
$ \case
          Bool
True -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
Set a
-> Specification fn a -> Specification fn Integer -> SetSpec fn a
SetSpec (forall a. a -> Set a
Set.singleton a
e) forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
          Bool
False -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
Set a
-> Specification fn a -> Specification fn Integer -> SetSpec fn a
SetSpec forall a. Monoid a => a
mempty (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a
notEqualSpec a
e) forall a. Monoid a => a
mempty
    SetFn fn as b
Elem
      | HOLE a a
HOLE :? Value a
es :> List Value as1
Nil <- ListCtx Value as (HOLE a)
ctx -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn Bool
-> (Bool -> Specification fn a) -> Specification fn a
caseBoolSpec Specification fn b
spec forall a b. (a -> b) -> a -> b
$ \case
          Bool
True ->
            forall a (fn :: [*] -> * -> *).
[a] -> NonEmpty [Char] -> Specification fn a
memberSpecList
              (forall a. Eq a => [a] -> [a]
nub a
es)
              (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"propagateSpecFun on (elem_ x []), The empty list, [], has no solution")
          Bool
False -> forall (fn :: [*] -> * -> *) a (f :: * -> *).
(HasSpec fn a, Foldable f) =>
f a -> Specification fn a
notMemberSpec a
es
      | Value a
e :! NilCtx HOLE a [a]
HOLE <- ListCtx Value as (HOLE a)
ctx -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn Bool
-> (Bool -> Specification fn a) -> Specification fn a
caseBoolSpec Specification fn b
spec forall a b. (a -> b) -> a -> b
$ \case
          Bool
True -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
Maybe Integer
-> [a]
-> Specification fn Integer
-> Specification fn a
-> FoldSpec fn a
-> ListSpec fn a
ListSpec forall a. Maybe a
Nothing [a
e] forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall (fn :: [*] -> * -> *) a. FoldSpec fn a
NoFold
          Bool
False -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
Maybe Integer
-> [a]
-> Specification fn Integer
-> Specification fn a
-> FoldSpec fn a
-> ListSpec fn a
ListSpec forall a. Maybe a
Nothing forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a
notEqualSpec a
e) forall (fn :: [*] -> * -> *) a. FoldSpec fn a
NoFold
    SetFn fn as b
Disjoint
      | HOLE a a
HOLE :? Value (Set a
s :: Set a) :> List Value as1
Nil <- ListCtx Value as (HOLE a)
ctx ->
          forall (f :: [*] -> * -> *) (fn :: [*] -> * -> *) (as :: [*]) a b.
(Functions f fn, TypeList as, Typeable as, HasSpec fn a,
 HasSpec fn b, All (HasSpec fn) as) =>
f as b
-> ListCtx Value as (HOLE a)
-> Specification fn b
-> Specification fn a
propagateSpecFun @(SetFn fn) @fn forall a (fn :: [*] -> * -> *).
(Ord a, Show a, Typeable a) =>
SetFn fn '[Set a, Set a] Bool
Disjoint (forall a. Show a => a -> Value a
Value Set a
s forall (f :: * -> *) a (as1 :: [*]) (c :: * -> *).
f a -> ListCtx f as1 c -> ListCtx f (a : as1) c
:! forall (c :: * -> *) a (f :: * -> *). c a -> ListCtx f '[a] c
NilCtx forall a. HOLE a a
HOLE) Specification fn b
spec
      | Value (Set a
s :: Set a) :! NilCtx HOLE a (Set a)
HOLE <- ListCtx Value as (HOLE a)
ctx
      , Evidence (Prerequisites fn (Set a))
Evidence <- forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Evidence (Prerequisites fn a)
prerequisites @fn @(Set a) -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn Bool
-> (Bool -> Specification fn a) -> Specification fn a
caseBoolSpec Specification fn b
spec forall a b. (a -> b) -> a -> b
$ \case
          Bool
True -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
Set a
-> Specification fn a -> Specification fn Integer -> SetSpec fn a
SetSpec forall a. Monoid a => a
mempty (forall (fn :: [*] -> * -> *) a (f :: * -> *).
(HasSpec fn a, Foldable f) =>
f a -> Specification fn a
notMemberSpec Set a
s) forall a. Monoid a => a
mempty
          Bool
False -> forall a (fn :: [*] -> * -> *) p.
(IsPred p fn, HasSpec fn a) =>
(Term fn a -> p) -> Specification fn a
constrained forall a b. (a -> b) -> a -> b
$ \Term fn a
set ->
            forall a p (fn :: [*] -> * -> *).
(HasSpec fn a, IsPred p fn) =>
((forall b. Term fn b -> b) -> GE a) -> (Term fn a -> p) -> Pred fn
exists (\forall b. Term fn b -> b
eval -> forall (t :: * -> *) a. Foldable t => t a -> GE a
headGE (forall a. Ord a => Set a -> Set a -> Set a
Set.intersection (forall b. Term fn b -> b
eval Term fn a
set) Set a
s)) forall a b. (a -> b) -> a -> b
$ \Term fn a
e ->
              [ Term fn a
set forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, HasSpec fn b) =>
Term fn a -> Term fn b -> Pred fn
`DependsOn` Term fn a
e
              , forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
p -> Pred fn
assert forall a b. (a -> b) -> a -> b
$ forall a (fn :: [*] -> * -> *).
(HasSpec fn a, Ord a) =>
Term fn a -> Term fn (Set a) -> Term fn Bool
member_ Term fn a
e (forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit Set a
s)
              , forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
p -> Pred fn
assert forall a b. (a -> b) -> a -> b
$ forall a (fn :: [*] -> * -> *).
(HasSpec fn a, Ord a) =>
Term fn a -> Term fn (Set a) -> Term fn Bool
member_ Term fn a
e Term fn a
set
              ]
    fl :: SetFn fn as b
fl@SetFn fn as b
FromList -> case SetFn fn as b
fl of
      -- NOTE: this is a super ugly hack to get around
      -- type arguments not being bindable in ghc 8.10.7.
      -- In later ghc versions we could replace this fl... stuff
      -- with just
      --  FromList @a @_
      --    | Nil...
      --    , Evidence <- ...
      SetFn fn '[[a]] (Set a)
FromList :: SetFn fn '[[a]] (Set a)
        | NilCtx HOLE a [a]
HOLE <- ListCtx Value as (HOLE a)
ctx
        , Evidence (Prerequisites fn [a])
Evidence <- forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Evidence (Prerequisites fn a)
prerequisites @fn @[a] ->
            case Specification fn b
spec of
              MemberSpec (b
xs :| []) ->
                forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec forall a b. (a -> b) -> a -> b
$
                  forall (fn :: [*] -> * -> *) a.
Maybe Integer
-> [a]
-> Specification fn Integer
-> Specification fn a
-> FoldSpec fn a
-> ListSpec fn a
ListSpec
                    forall a. Maybe a
Nothing
                    (forall a. Set a -> [a]
Set.toList b
xs)
                    forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec
                    ( forall a (fn :: [*] -> * -> *).
[a] -> NonEmpty [Char] -> Specification fn a
memberSpecList
                        (forall a. Set a -> [a]
Set.toList b
xs)
                        (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"propagateSpec (fromList_ HOLE) on (MemberSpec xs) where the set 'xs' is empty")
                    )
                    forall (fn :: [*] -> * -> *) a. FoldSpec fn a
NoFold
              TypeSpec (SetSpec Set a
must Specification fn a
elemSpec Specification fn Integer
sizeSpec) []
                | Specification fn Integer
TrueSpec <- Specification fn Integer
sizeSpec -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
Maybe Integer
-> [a]
-> Specification fn Integer
-> Specification fn a
-> FoldSpec fn a
-> ListSpec fn a
ListSpec forall a. Maybe a
Nothing (forall a. Set a -> [a]
Set.toList Set a
must) forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec Specification fn a
elemSpec forall (fn :: [*] -> * -> *) a. FoldSpec fn a
NoFold
                | TypeSpec (NumSpecInterval (Just Integer
l) Maybe Integer
Nothing) [Integer]
cantSize <- Specification fn Integer
sizeSpec
                , Integer
l forall a. Ord a => a -> a -> Bool
<= forall (fn :: [*] -> * -> *) t. Sized fn t => t -> Integer
sizeOf Set a
must
                , forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Ord a => a -> a -> Bool
< forall (fn :: [*] -> * -> *) t. Sized fn t => t -> Integer
sizeOf Set a
must) [Integer]
cantSize ->
                    forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
Maybe Integer
-> [a]
-> Specification fn Integer
-> Specification fn a
-> FoldSpec fn a
-> ListSpec fn a
ListSpec forall a. Maybe a
Nothing (forall a. Set a -> [a]
Set.toList Set a
must) forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec Specification fn a
elemSpec forall (fn :: [*] -> * -> *) a. FoldSpec fn a
NoFold
              Specification fn b
_ ->
                -- Here we simply defer to basically generating the universe that we can
                -- draw from according to `spec` first and then fold that into the spec for the list.
                -- The tricky thing about this is that it may not play super nicely with other constraints
                -- on the list. For this reason it's important to try to find as many possible work-arounds
                -- in the above cases as possible.
                forall a (fn :: [*] -> * -> *) p.
(IsPred p fn, HasSpec fn a) =>
(Term fn a -> p) -> Specification fn a
constrained forall a b. (a -> b) -> a -> b
$ \Term fn a
xs ->
                  forall a p (fn :: [*] -> * -> *).
(HasSpec fn a, IsPred p fn) =>
((forall b. Term fn b -> b) -> GE a) -> (Term fn a -> p) -> Pred fn
exists (\forall b. Term fn b -> b
eval -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList (forall b. Term fn b -> b
eval Term fn a
xs)) forall a b. (a -> b) -> a -> b
$ \Term fn (Set a)
s ->
                    [ Term fn (Set a)
s forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Specification fn a -> Pred fn
`satisfies` Specification fn b
spec
                    , Term fn a
xs forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, HasSpec fn b) =>
Term fn a -> Term fn b -> Pred fn
`DependsOn` Term fn (Set a)
s
                    , forall t a (fn :: [*] -> * -> *) p.
(Forallable t a, HasSpec fn t, HasSpec fn a, IsPred p fn) =>
Term fn t -> (Term fn a -> p) -> Pred fn
forAll Term fn a
xs forall a b. (a -> b) -> a -> b
$ \Term fn a
e -> Term fn a
e forall a (fn :: [*] -> * -> *).
(HasSpec fn a, Ord a) =>
Term fn a -> Term fn (Set a) -> Term fn Bool
`member_` Term fn (Set a)
s
                    , forall t a (fn :: [*] -> * -> *) p.
(Forallable t a, HasSpec fn t, HasSpec fn a, IsPred p fn) =>
Term fn t -> (Term fn a -> p) -> Pred fn
forAll Term fn (Set a)
s forall a b. (a -> b) -> a -> b
$ \Term fn a
e -> Term fn a
e forall a (fn :: [*] -> * -> *).
HasSpec fn a =>
Term fn a -> Term fn [a] -> Term fn Bool
`elem_` Term fn a
xs
                    ]

  rewriteRules :: forall (as :: [*]) b.
(TypeList as, Typeable as, HasSpec fn b, All (HasSpec fn) as) =>
SetFn fn as b -> List (Term fn) as -> Maybe (Term fn b)
rewriteRules SetFn fn as b
Elem (Term fn a
_ :> Lit [] :> List (Term fn) as1
Nil) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit Bool
False
  rewriteRules SetFn fn as b
Elem (Term fn a
t :> Lit [a
a] :> List (Term fn) as1
Nil) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Term fn a
t forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Term fn a -> Term fn Bool
==. forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
lit a
a
  rewriteRules SetFn fn as b
Member (Term fn a
t :> Lit a
s :> List (Term fn) as1
Nil)
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null a
s = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit Bool
False
    | [a
a] <- forall a. Set a -> [a]
Set.toList a
s = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Term fn a
t forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Term fn a -> Term fn Bool
==. forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
lit a
a
  rewriteRules SetFn fn as b
Union (Term fn a
x :> Lit a
s :> List (Term fn) as1
Nil) | forall (t :: * -> *) a. Foldable t => t a -> Bool
null a
s = forall a. a -> Maybe a
Just Term fn a
x
  rewriteRules SetFn fn as b
Union (Lit a
s :> Term fn a
x :> List (Term fn) as1
Nil) | forall (t :: * -> *) a. Foldable t => t a -> Bool
null a
s = forall a. a -> Maybe a
Just Term fn a
x
  rewriteRules SetFn fn as b
Subset (Lit a
s :> Term fn a
_ :> List (Term fn) as1
Nil) | forall (t :: * -> *) a. Foldable t => t a -> Bool
null a
s = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit Bool
True
  rewriteRules SetFn fn as b
Subset (Term fn a
x :> Lit a
s :> List (Term fn) as1
Nil) | forall (t :: * -> *) a. Foldable t => t a -> Bool
null a
s = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Term fn a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Term fn a -> Term fn Bool
==. forall a. Monoid a => a
mempty
  rewriteRules SetFn fn as b
_ List (Term fn) as
_ = forall a. Maybe a
Nothing

  -- NOTE: this function over-approximates and returns a liberal spec.
  mapTypeSpec :: forall a b.
(HasSpec fn a, HasSpec fn b) =>
SetFn fn '[a] b -> TypeSpec fn a -> Specification fn b
mapTypeSpec SetFn fn '[a] b
f TypeSpec fn a
ts = case SetFn fn '[a] b
f of
    SetFn fn '[a] b
Singleton ->
      forall a (fn :: [*] -> * -> *) p.
(IsPred p fn, HasSpec fn a) =>
(Term fn a -> p) -> Specification fn a
constrained forall a b. (a -> b) -> a -> b
$ \Term fn b
x ->
        forall a p (fn :: [*] -> * -> *).
(HasSpec fn a, IsPred p fn) =>
(Term fn a -> p) -> Pred fn
unsafeExists forall a b. (a -> b) -> a -> b
$ \Term fn a
x' ->
          forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
p -> Pred fn
assert (Term fn b
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Term fn a -> Term fn Bool
==. forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, Ord a) =>
Term fn a -> Term fn (Set a)
singleton_ Term fn a
x') forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> TypeSpec fn a -> Pred fn
toPreds Term fn a
x' TypeSpec fn a
ts
    fl :: SetFn fn '[a] b
fl@SetFn fn '[a] b
FromList -> case SetFn fn '[a] b
fl of
      -- NOTE: this is a super ugly hack to get around
      -- type arguments not being bindable in ghc 8.10.7
      SetFn fn '[[a]] (Set a)
FromList :: SetFn fn '[[a]] (Set a)
        | Evidence (Prerequisites fn (Set a))
Evidence <- forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Evidence (Prerequisites fn a)
prerequisites @fn @(Set a) ->
            forall a (fn :: [*] -> * -> *) p.
(IsPred p fn, HasSpec fn a) =>
(Term fn a -> p) -> Specification fn a
constrained forall a b. (a -> b) -> a -> b
$ \Term fn b
x ->
              forall a p (fn :: [*] -> * -> *).
(HasSpec fn a, IsPred p fn) =>
(Term fn a -> p) -> Pred fn
unsafeExists forall a b. (a -> b) -> a -> b
$ \Term fn [a]
x' ->
                forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
p -> Pred fn
assert (Term fn b
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Term fn a -> Term fn Bool
==. forall a (fn :: [*] -> * -> *).
(HasSpec fn a, Ord a) =>
Term fn [a] -> Term fn (Set a)
fromList_ @a Term fn [a]
x') forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> TypeSpec fn a -> Pred fn
toPreds Term fn [a]
x' TypeSpec fn a
ts

-- List -------------------------------------------------------------------

data ListSpec fn a = ListSpec
  { forall (fn :: [*] -> * -> *) a. ListSpec fn a -> Maybe Integer
listSpecHint :: Maybe Integer
  , forall (fn :: [*] -> * -> *) a. ListSpec fn a -> [a]
listSpecMust :: [a]
  , forall (fn :: [*] -> * -> *) a.
ListSpec fn a -> Specification fn Integer
listSpecSize :: Specification fn Integer
  , forall (fn :: [*] -> * -> *) a. ListSpec fn a -> Specification fn a
listSpecElem :: Specification fn a
  , forall (fn :: [*] -> * -> *) a. ListSpec fn a -> FoldSpec fn a
listSpecFold :: FoldSpec fn a
  }

instance
  ( Arbitrary a
  , Arbitrary (FoldSpec fn a)
  , Arbitrary (TypeSpec fn a)
  , HasSpec fn a
  ) =>
  Arbitrary (ListSpec fn a)
  where
  arbitrary :: Gen (ListSpec fn a)
arbitrary = forall (fn :: [*] -> * -> *) a.
Maybe Integer
-> [a]
-> Specification fn Integer
-> Specification fn a
-> FoldSpec fn a
-> ListSpec fn a
ListSpec forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary
  shrink :: ListSpec fn a -> [ListSpec fn a]
shrink (ListSpec Maybe Integer
a [a]
b Specification fn Integer
c Specification fn a
d FoldSpec fn a
e) = [forall (fn :: [*] -> * -> *) a.
Maybe Integer
-> [a]
-> Specification fn Integer
-> Specification fn a
-> FoldSpec fn a
-> ListSpec fn a
ListSpec Maybe Integer
a' [a]
b' Specification fn Integer
c' Specification fn a
d' FoldSpec fn a
e' | (Maybe Integer
a', [a]
b', Specification fn Integer
c', Specification fn a
d', FoldSpec fn a
e') <- forall a. Arbitrary a => a -> [a]
shrink (Maybe Integer
a, [a]
b, Specification fn Integer
c, Specification fn a
d, FoldSpec fn a
e)]

instance HasSpec fn a => Show (FoldSpec fn a) where
  showsPrec :: Int -> FoldSpec fn a -> ShowS
showsPrec Int
d = forall a. Show a => a -> ShowS
shows forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty (WithPrec a) => Int -> a -> Doc ann
prettyPrec Int
d

instance HasSpec fn a => Pretty (WithPrec (FoldSpec fn a)) where
  pretty :: forall ann. WithPrec (FoldSpec fn a) -> Doc ann
pretty (WithPrec Int
_ FoldSpec fn a
NoFold) = Doc ann
"NoFold"
  pretty (WithPrec Int
d (FoldSpec fn '[a] b
fn Specification fn b
s)) =
    forall ann. Bool -> Doc ann -> Doc ann
parensIf (Int
d forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$
      Doc ann
"FoldSpec"
        forall ann. Doc ann -> Doc ann -> Doc ann
/> forall ann. [Doc ann] -> Doc ann
vsep'
          [ Doc ann
"fn   =" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow fn '[a] b
fn
          , Doc ann
"spec =" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Specification fn b
s
          ]

instance HasSpec fn a => Pretty (FoldSpec fn a) where
  pretty :: forall ann. FoldSpec fn a -> Doc ann
pretty = forall a ann. Pretty (WithPrec a) => Int -> a -> Doc ann
prettyPrec Int
0

instance HasSpec fn a => Show (ListSpec fn a) where
  showsPrec :: Int -> ListSpec fn a -> ShowS
showsPrec Int
d = forall a. Show a => a -> ShowS
shows forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty (WithPrec a) => Int -> a -> Doc ann
prettyPrec Int
d

instance
  HasSpec fn a =>
  Pretty (WithPrec (ListSpec fn a))
  where
  pretty :: forall ann. WithPrec (ListSpec fn a) -> Doc ann
pretty (WithPrec Int
d ListSpec fn a
s) =
    forall ann. Bool -> Doc ann -> Doc ann
parensIf (Int
d forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$
      Doc ann
"ListSpec"
        forall ann. Doc ann -> Doc ann -> Doc ann
/> forall ann. [Doc ann] -> Doc ann
vsep'
          [ Doc ann
"hint =" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow (forall (fn :: [*] -> * -> *) a. ListSpec fn a -> Maybe Integer
listSpecHint ListSpec fn a
s)
          , Doc ann
"must =" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow (forall (fn :: [*] -> * -> *) a. ListSpec fn a -> [a]
listSpecMust ListSpec fn a
s)
          , Doc ann
"size =" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall (fn :: [*] -> * -> *) a.
ListSpec fn a -> Specification fn Integer
listSpecSize ListSpec fn a
s)
          , Doc ann
"elem =" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall (fn :: [*] -> * -> *) a. ListSpec fn a -> Specification fn a
listSpecElem ListSpec fn a
s)
          , Doc ann
"fold =" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall (fn :: [*] -> * -> *) a. ListSpec fn a -> FoldSpec fn a
listSpecFold ListSpec fn a
s)
          ]

instance HasSpec fn a => Pretty (ListSpec fn a) where
  pretty :: forall ann. ListSpec fn a -> Doc ann
pretty = forall a ann. Pretty (WithPrec a) => Int -> a -> Doc ann
prettyPrec Int
0

guardListSpec :: HasSpec fn a => [String] -> ListSpec fn a -> Specification fn [a]
guardListSpec :: forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
[[Char]] -> ListSpec fn a -> Specification fn [a]
guardListSpec [[Char]]
msg l :: ListSpec fn a
l@(ListSpec Maybe Integer
_hint [a]
must Specification fn Integer
size Specification fn a
elemS FoldSpec fn a
_fold)
  | ErrorSpec NonEmpty [Char]
es <- Specification fn Integer
size = forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec forall a b. (a -> b) -> a -> b
$ (forall a. [a] -> NonEmpty a
NE.fromList ([Char]
"Error in size of ListSpec" forall a. a -> [a] -> [a]
: [[Char]]
msg)) forall a. Semigroup a => a -> a -> a
<> NonEmpty [Char]
es
  | Just Integer
u <- forall (fn :: [*] -> * -> *) a.
(TypeSpec fn a ~ NumSpec fn a, Ord a, Enum a, Num a,
 MaybeBounded a) =>
Specification fn a -> Maybe a
knownUpperBound Specification fn Integer
size
  , Integer
u forall a. Ord a => a -> a -> Bool
< Integer
0 =
      forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec forall a b. (a -> b) -> a -> b
$ forall a. [a] -> NonEmpty a
NE.fromList ([[Char]
"Negative size in guardListSpec", forall a. Show a => a -> [Char]
show Specification fn Integer
size] forall a. [a] -> [a] -> [a]
++ [[Char]]
msg)
  | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
`conformsToSpec` Specification fn a
elemS) [a]
must) =
      forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec forall a b. (a -> b) -> a -> b
$
        ( forall a. [a] -> NonEmpty a
NE.fromList
            ([[Char]
"Some items in the must list do not conform to 'element' spec.", [Char]
"   " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn a
elemS] forall a. [a] -> [a] -> [a]
++ [[Char]]
msg)
        )
  | Bool
otherwise = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec ListSpec fn a
l

instance HasSpec fn a => HasSpec fn [a] where
  type TypeSpec fn [a] = ListSpec fn a
  type Prerequisites fn [a] = HasSpec fn a
  emptySpec :: TypeSpec fn [a]
emptySpec = forall (fn :: [*] -> * -> *) a.
Maybe Integer
-> [a]
-> Specification fn Integer
-> Specification fn a
-> FoldSpec fn a
-> ListSpec fn a
ListSpec forall a. Maybe a
Nothing [] forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall (fn :: [*] -> * -> *) a. FoldSpec fn a
NoFold
  combineSpec :: TypeSpec fn [a] -> TypeSpec fn [a] -> Specification fn [a]
combineSpec l1 :: TypeSpec fn [a]
l1@(ListSpec Maybe Integer
msz [a]
must Specification fn Integer
size Specification fn a
elemS FoldSpec fn a
foldS) l2 :: TypeSpec fn [a]
l2@(ListSpec Maybe Integer
msz' [a]
must' Specification fn Integer
size' Specification fn a
elemS' FoldSpec fn a
foldS') =
    let must'' :: [a]
must'' = forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ [a]
must forall a. Semigroup a => a -> a -> a
<> [a]
must'
        elemS'' :: Specification fn a
elemS'' = Specification fn a
elemS forall a. Semigroup a => a -> a -> a
<> Specification fn a
elemS'
        size'' :: Specification fn Integer
size'' = Specification fn Integer
size forall a. Semigroup a => a -> a -> a
<> Specification fn Integer
size'
        foldeither :: Either [[Char]] (FoldSpec fn a)
foldeither = forall (fn :: [*] -> * -> *) a.
FoldSpec fn a -> FoldSpec fn a -> Either [[Char]] (FoldSpec fn a)
combineFoldSpec FoldSpec fn a
foldS FoldSpec fn a
foldS'
        msg :: [[Char]]
msg = [[Char]
"Error in combineSpec for ListSpec", [Char]
"1) " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show TypeSpec fn [a]
l1, [Char]
"2) " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show TypeSpec fn [a]
l2]
     in case Either [[Char]] (FoldSpec fn a)
foldeither of
          Left [[Char]]
foldmsg -> forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec (forall a. [a] -> NonEmpty a
NE.fromList ([[Char]]
msg forall a. [a] -> [a] -> [a]
++ [[Char]]
foldmsg))
          Right FoldSpec fn a
fold'' -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
[[Char]] -> ListSpec fn a -> Specification fn [a]
guardListSpec [[Char]]
msg forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
Maybe Integer
-> [a]
-> Specification fn Integer
-> Specification fn a
-> FoldSpec fn a
-> ListSpec fn a
ListSpec (forall a. (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a
unionWithMaybe forall a. Ord a => a -> a -> a
min Maybe Integer
msz Maybe Integer
msz') [a]
must'' Specification fn Integer
size'' Specification fn a
elemS'' FoldSpec fn a
fold''

  genFromTypeSpec :: forall (m :: * -> *).
(HasCallStack, MonadGenError m) =>
TypeSpec fn [a] -> GenT m [a]
genFromTypeSpec (ListSpec Maybe Integer
_ [a]
must Specification fn Integer
_ Specification fn a
elemS FoldSpec fn a
_)
    | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
`conformsToSpec` Specification fn a
elemS)) [a]
must =
        forall (m :: * -> *) a. MonadGenError m => [Char] -> m a
genError1 [Char]
"genTypeSpecSpec @ListSpec: must do not conform to elemS"
  genFromTypeSpec (ListSpec Maybe Integer
msz [a]
must Specification fn Integer
TrueSpec Specification fn a
elemS FoldSpec fn a
NoFold) = do
    [a]
lst <- case Maybe Integer
msz of
      Maybe Integer
Nothing -> forall (m :: * -> *) a. MonadGenError m => GenT GE a -> GenT m [a]
listOfT forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a (m :: * -> *).
(HasCallStack, HasSpec fn a, MonadGenError m) =>
Specification fn a -> GenT m a
genFromSpecT Specification fn a
elemS
      Just Integer
szHint -> do
        Integer
sz <- forall (fn :: [*] -> * -> *) (m :: * -> *).
(BaseUniverse fn, MonadGenError m) =>
Specification fn Integer -> GenT m Integer
genFromSizeSpec (forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
leqSpec @fn Integer
szHint)
        forall (m :: * -> *) a.
MonadGenError m =>
GenT GE a -> Int -> (Int -> Bool) -> GenT m [a]
listOfUntilLenT (forall (fn :: [*] -> * -> *) a (m :: * -> *).
(HasCallStack, HasSpec fn a, MonadGenError m) =>
Specification fn a -> GenT m a
genFromSpecT Specification fn a
elemS) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
sz) (forall a b. a -> b -> a
const Bool
True)
    forall (m :: * -> *) a. Applicative m => Gen a -> GenT m a
pureGen forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Gen [a]
shuffle ([a]
must forall a. [a] -> [a] -> [a]
++ [a]
lst)
  genFromTypeSpec (ListSpec Maybe Integer
msz [a]
must Specification fn Integer
szSpec Specification fn a
elemS FoldSpec fn a
NoFold) = do
    Integer
sz0 <- forall (fn :: [*] -> * -> *) (m :: * -> *).
(BaseUniverse fn, MonadGenError m) =>
Specification fn Integer -> GenT m Integer
genFromSizeSpec (Specification fn Integer
szSpec forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
geqSpec @fn (forall (fn :: [*] -> * -> *) t. Sized fn t => t -> Integer
sizeOf [a]
must) forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec (forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
leqSpec forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a
max Integer
0) Maybe Integer
msz)
    let sz :: Int
sz = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
sz0 forall a. Num a => a -> a -> a
- forall (fn :: [*] -> * -> *) t. Sized fn t => t -> Integer
sizeOf [a]
must)
    [a]
lst <-
      forall (m :: * -> *) a.
MonadGenError m =>
GenT GE a -> Int -> (Int -> Bool) -> GenT m [a]
listOfUntilLenT
        (forall (fn :: [*] -> * -> *) a (m :: * -> *).
(HasCallStack, HasSpec fn a, MonadGenError m) =>
Specification fn a -> GenT m a
genFromSpecT Specification fn a
elemS)
        Int
sz
        ((forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
`conformsToSpec` Specification fn Integer
szSpec) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
+ forall (fn :: [*] -> * -> *) t. Sized fn t => t -> Integer
sizeOf [a]
must) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral)
    forall (m :: * -> *) a. Applicative m => Gen a -> GenT m a
pureGen forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Gen [a]
shuffle ([a]
must forall a. [a] -> [a] -> [a]
++ [a]
lst)
  genFromTypeSpec (ListSpec Maybe Integer
msz [a]
must Specification fn Integer
size Specification fn a
elemS (FoldSpec fn '[a] b
f Specification fn b
foldS)) = do
    forall (m :: * -> *) (fn :: [*] -> * -> *) a b.
(MonadGenError m, Foldy fn b, HasSpec fn a) =>
[a]
-> Specification fn Integer
-> Specification fn a
-> fn '[a] b
-> Specification fn b
-> GenT m [a]
genFromFold [a]
must (Specification fn Integer
size forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
leqSpec Maybe Integer
msz) Specification fn a
elemS fn '[a] b
f Specification fn b
foldS

  shrinkWithTypeSpec :: TypeSpec fn [a] -> [a] -> [[a]]
shrinkWithTypeSpec (ListSpec Maybe Integer
_ [a]
_ Specification fn Integer
_ Specification fn a
es FoldSpec fn a
_) [a]
as =
    forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn a -> a -> [a]
shrinkWithSpec Specification fn a
es) [a]
as

  cardinalTypeSpec :: TypeSpec fn [a] -> Specification fn Integer
cardinalTypeSpec TypeSpec fn [a]
_ = forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec

  guardTypeSpec :: [[Char]] -> TypeSpec fn [a] -> Specification fn [a]
guardTypeSpec = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
[[Char]] -> ListSpec fn a -> Specification fn [a]
guardListSpec

  conformsTo :: HasCallStack => [a] -> TypeSpec fn [a] -> Bool
conformsTo [a]
xs (ListSpec Maybe Integer
_ [a]
must Specification fn Integer
size Specification fn a
elemS FoldSpec fn a
foldS) =
    forall (fn :: [*] -> * -> *) t. Sized fn t => t -> Integer
sizeOf [a]
xs forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
`conformsToSpec` Specification fn Integer
size
      Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
xs) [a]
must
      Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
`conformsToSpec` Specification fn a
elemS) [a]
xs
      Bool -> Bool -> Bool
&& [a]
xs forall (fn :: [*] -> * -> *) a. [a] -> FoldSpec fn a -> Bool
`conformsToFoldSpec` FoldSpec fn a
foldS

  toPreds :: Term fn [a] -> TypeSpec fn [a] -> Pred fn
toPreds Term fn [a]
x (ListSpec Maybe Integer
msz [a]
must Specification fn Integer
size Specification fn a
elemS FoldSpec fn a
foldS) =
    (forall t a (fn :: [*] -> * -> *) p.
(Forallable t a, HasSpec fn t, HasSpec fn a, IsPred p fn) =>
Term fn t -> (Term fn a -> p) -> Pred fn
forAll Term fn [a]
x forall a b. (a -> b) -> a -> b
$ \Term fn a
x' -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Specification fn a -> Pred fn
satisfies Term fn a
x' Specification fn a
elemS)
      forall a. Semigroup a => a -> a -> a
<> (forall t a (fn :: [*] -> * -> *) p.
(Forallable t a, HasSpec fn t, HasSpec fn a, IsPred p fn) =>
Term fn t -> (Term fn a -> p) -> Pred fn
forAll (forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
lit [a]
must) forall a b. (a -> b) -> a -> b
$ \Term fn a
x' -> forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
p -> Pred fn
assert (forall a (fn :: [*] -> * -> *).
HasSpec fn a =>
Term fn a -> Term fn [a] -> Term fn Bool
elem_ Term fn a
x' Term fn [a]
x))
      forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
BaseUniverse fn =>
Term fn [a] -> FoldSpec fn a -> Pred fn
toPredsFoldSpec Term fn [a]
x FoldSpec fn a
foldS
      forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Specification fn a -> Pred fn
satisfies (forall a (fn :: [*] -> * -> *).
(HasSpec fn a, Sized fn a) =>
Term fn a -> Term fn Integer
sizeOf_ Term fn [a]
x) Specification fn Integer
size
      forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (fn :: [*] -> * -> *). Pred fn
TruePred (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (fn :: [*] -> * -> *) a.
HasGenHint fn a =>
Hint a -> Term fn a -> Pred fn
genHint Term fn [a]
x) Maybe Integer
msz

instance HasSpec fn a => HasGenHint fn [a] where
  type Hint [a] = Integer
  giveHint :: Hint [a] -> Specification fn [a]
giveHint Hint [a]
szHint = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
Maybe Integer
-> [a]
-> Specification fn Integer
-> Specification fn a
-> FoldSpec fn a
-> ListSpec fn a
ListSpec (forall a. a -> Maybe a
Just Hint [a]
szHint) [] forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall (fn :: [*] -> * -> *) a. FoldSpec fn a
NoFold

instance Forallable [a] a where
  fromForAllSpec :: forall (fn :: [*] -> * -> *).
(HasSpec fn [a], HasSpec fn a, BaseUniverse fn) =>
Specification fn a -> Specification fn [a]
fromForAllSpec Specification fn a
es = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec (forall (fn :: [*] -> * -> *) a.
Maybe Integer
-> [a]
-> Specification fn Integer
-> Specification fn a
-> FoldSpec fn a
-> ListSpec fn a
ListSpec forall a. Maybe a
Nothing [] forall a. Monoid a => a
mempty Specification fn a
es forall (fn :: [*] -> * -> *) a. FoldSpec fn a
NoFold)
  forAllToList :: [a] -> [a]
forAllToList = forall a. a -> a
id

-- Numbers ----------------------------------------------------------------

class MaybeBounded a where
  lowerBound :: Maybe a
  upperBound :: Maybe a

  default lowerBound :: Bounded a => Maybe a
  lowerBound = forall a. a -> Maybe a
Just forall a. Bounded a => a
minBound

  default upperBound :: Bounded a => Maybe a
  upperBound = forall a. a -> Maybe a
Just forall a. Bounded a => a
maxBound

instance MaybeBounded Int
instance MaybeBounded Int64
instance MaybeBounded Int32
instance MaybeBounded Int16
instance MaybeBounded Int8
instance MaybeBounded Word64
instance MaybeBounded Word32
instance MaybeBounded Word16
instance MaybeBounded Word8

instance MaybeBounded Integer where
  lowerBound :: Maybe Integer
lowerBound = forall a. Maybe a
Nothing
  upperBound :: Maybe Integer
upperBound = forall a. Maybe a
Nothing

instance MaybeBounded (Ratio Integer) where
  lowerBound :: Maybe (Ratio Integer)
lowerBound = forall a. Maybe a
Nothing
  upperBound :: Maybe (Ratio Integer)
upperBound = forall a. Maybe a
Nothing

instance MaybeBounded Natural where
  lowerBound :: Maybe Natural
lowerBound = forall a. a -> Maybe a
Just Natural
0
  upperBound :: Maybe Natural
upperBound = forall a. Maybe a
Nothing

instance MaybeBounded Float where
  lowerBound :: Maybe Float
lowerBound = forall a. Maybe a
Nothing
  upperBound :: Maybe Float
upperBound = forall a. Maybe a
Nothing

data NumSpec (fn :: [Type] -> Type -> Type) n = NumSpecInterval (Maybe n) (Maybe n)

instance Ord n => Eq (NumSpec fn n) where
  NumSpecInterval Maybe n
ml Maybe n
mh == :: NumSpec fn n -> NumSpec fn n -> Bool
== NumSpecInterval Maybe n
ml' Maybe n
mh'
    | forall {a}. Ord a => Maybe a -> Maybe a -> Bool
isEmpty Maybe n
ml Maybe n
mh = forall {a}. Ord a => Maybe a -> Maybe a -> Bool
isEmpty Maybe n
ml' Maybe n
mh'
    | forall {a}. Ord a => Maybe a -> Maybe a -> Bool
isEmpty Maybe n
ml' Maybe n
mh' = forall {a}. Ord a => Maybe a -> Maybe a -> Bool
isEmpty Maybe n
ml Maybe n
mh
    | Bool
otherwise = Maybe n
ml forall a. Eq a => a -> a -> Bool
== Maybe n
ml' Bool -> Bool -> Bool
&& Maybe n
mh forall a. Eq a => a -> a -> Bool
== Maybe n
mh'
    where
      isEmpty :: Maybe a -> Maybe a -> Bool
isEmpty (Just a
a) (Just a
b) = a
a forall a. Ord a => a -> a -> Bool
> a
b
      isEmpty Maybe a
_ Maybe a
_ = Bool
False

instance Show n => Show (NumSpec fn n) where
  show :: NumSpec fn n -> [Char]
show (NumSpecInterval Maybe n
ml Maybe n
mu) = [Char]
lb forall a. [a] -> [a] -> [a]
++ [Char]
".." forall a. [a] -> [a] -> [a]
++ [Char]
ub
    where
      lb :: [Char]
lb = [Char]
"[" forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" forall a. Show a => a -> [Char]
show Maybe n
ml
      ub :: [Char]
ub = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" forall a. Show a => a -> [Char]
show Maybe n
mu forall a. [a] -> [a] -> [a]
++ [Char]
"]"

instance Ord n => Semigroup (NumSpec fn n) where
  NumSpecInterval Maybe n
ml Maybe n
mu <> :: NumSpec fn n -> NumSpec fn n -> NumSpec fn n
<> NumSpecInterval Maybe n
ml' Maybe n
mu' =
    forall (fn :: [*] -> * -> *) n. Maybe n -> Maybe n -> NumSpec fn n
NumSpecInterval
      (forall a. (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a
unionWithMaybe forall a. Ord a => a -> a -> a
max Maybe n
ml Maybe n
ml')
      (forall a. (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a
unionWithMaybe forall a. Ord a => a -> a -> a
min Maybe n
mu Maybe n
mu')

instance Ord n => Monoid (NumSpec fn n) where
  mempty :: NumSpec fn n
mempty = forall (fn :: [*] -> * -> *) n. Maybe n -> Maybe n -> NumSpec fn n
NumSpecInterval forall a. Maybe a
Nothing forall a. Maybe a
Nothing

instance (Arbitrary a, Ord a) => Arbitrary (NumSpec fn a) where
  arbitrary :: Gen (NumSpec fn a)
arbitrary = do
    Maybe a
m <- forall a. Arbitrary a => Gen a
arbitrary
    Maybe a
m' <- forall a. Arbitrary a => Gen a
arbitrary
    forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [(Int
10, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall {a} {fn :: [*] -> * -> *}.
Ord a =>
Maybe a -> Maybe a -> NumSpec fn a
mkLoHiInterval Maybe a
m Maybe a
m'), (Int
1, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) n. Maybe n -> Maybe n -> NumSpec fn n
NumSpecInterval Maybe a
m Maybe a
m')]
    where
      mkLoHiInterval :: Maybe a -> Maybe a -> NumSpec fn a
mkLoHiInterval (Just a
a) (Just a
b) = forall (fn :: [*] -> * -> *) n. Maybe n -> Maybe n -> NumSpec fn n
NumSpecInterval (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
min a
a a
b) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
max a
a a
b)
      mkLoHiInterval Maybe a
m Maybe a
m' = forall (fn :: [*] -> * -> *) n. Maybe n -> Maybe n -> NumSpec fn n
NumSpecInterval Maybe a
m Maybe a
m'
  shrink :: NumSpec fn a -> [NumSpec fn a]
shrink (NumSpecInterval Maybe a
m Maybe a
m') =
    forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (fn :: [*] -> * -> *) n. Maybe n -> Maybe n -> NumSpec fn n
NumSpecInterval forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => a -> [a]
shrink (Maybe a
m, Maybe a
m')

instance Arbitrary Natural where
  arbitrary :: Gen Natural
arbitrary = Word -> Natural
wordToNatural forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a
abs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
  shrink :: Natural -> [Natural]
shrink Natural
n = [Word -> Natural
wordToNatural Word
w | Word
w <- forall a. Arbitrary a => a -> [a]
shrink (Natural -> Word
naturalToWord Natural
n)]

instance Uniform Natural where
  uniformM :: forall g (m :: * -> *). StatefulGen g m => g -> m Natural
uniformM g
g = Word -> Natural
wordToNatural forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a
abs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a g (m :: * -> *). (Uniform a, StatefulGen g m) => g -> m a
uniformM g
g
instance Random Natural where
  randomR :: forall g. RandomGen g => (Natural, Natural) -> g -> (Natural, g)
randomR (Natural
lo, Natural
hi) g
g = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (forall a. Integral a => a -> Integer
toInteger Natural
lo, forall a. Integral a => a -> Integer
toInteger Natural
hi) g
g

instance Random (Ratio Integer) where
  randomR :: forall g.
RandomGen g =>
(Ratio Integer, Ratio Integer) -> g -> (Ratio Integer, g)
randomR (Ratio Integer
lo, Ratio Integer
hi) g
g =
    let (Ratio Integer
r, g
g') = forall a g. (Random a, RandomGen g) => g -> (a, g)
random g
g
     in (Ratio Integer
lo forall a. Num a => a -> a -> a
+ (Ratio Integer
hi forall a. Num a => a -> a -> a
- Ratio Integer
lo) forall a. Num a => a -> a -> a
* Ratio Integer
r, g
g')
  random :: forall g. RandomGen g => g -> (Ratio Integer, g)
random g
g =
    let (Integer
d, g
g') = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((forall a. Num a => a -> a -> a
+ Integer
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a
abs) forall a b. (a -> b) -> a -> b
$ forall a g. (Random a, RandomGen g) => g -> (a, g)
random g
g
        (Integer
n, g
g'') = forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Integer
0, Integer
d) g
g'
     in (Integer
n forall a. Integral a => a -> a -> Ratio a
% Integer
d, g
g'')

emptyNumSpec :: Ord a => NumSpec fn a
emptyNumSpec :: forall n (fn :: [*] -> * -> *). Ord n => NumSpec fn n
emptyNumSpec = forall a. Monoid a => a
mempty

guardNumSpec ::
  (Ord n, HasSpec fn n, TypeSpec fn n ~ NumSpec fn n) =>
  [String] -> NumSpec fn n -> Specification fn n
guardNumSpec :: forall n (fn :: [*] -> * -> *).
(Ord n, HasSpec fn n, TypeSpec fn n ~ NumSpec fn n) =>
[[Char]] -> NumSpec fn n -> Specification fn n
guardNumSpec [[Char]]
msg s :: NumSpec fn n
s@(NumSpecInterval (Just n
a) (Just n
b))
  | n
a forall a. Ord a => a -> a -> Bool
> n
b = forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec ([Char]
"NumSpec has low bound greater than hi bound" forall a. a -> [a] -> NonEmpty a
:| (([Char]
"   " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show NumSpec fn n
s) forall a. a -> [a] -> [a]
: [[Char]]
msg))
  | n
a forall a. Eq a => a -> a -> Bool
== n
b = forall a (fn :: [*] -> * -> *). a -> Specification fn a
equalSpec n
a
guardNumSpec [[Char]]
_ NumSpec fn n
s = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec NumSpec fn n
s

combineNumSpec ::
  (HasSpec fn n, Ord n, TypeSpec fn n ~ NumSpec fn n) =>
  NumSpec fn n ->
  NumSpec fn n ->
  Specification fn n
combineNumSpec :: forall (fn :: [*] -> * -> *) n.
(HasSpec fn n, Ord n, TypeSpec fn n ~ NumSpec fn n) =>
NumSpec fn n -> NumSpec fn n -> Specification fn n
combineNumSpec NumSpec fn n
s NumSpec fn n
s' = forall n (fn :: [*] -> * -> *).
(Ord n, HasSpec fn n, TypeSpec fn n ~ NumSpec fn n) =>
[[Char]] -> NumSpec fn n -> Specification fn n
guardNumSpec [[Char]
"when combining two NumSpecs", [Char]
"   " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show NumSpec fn n
s, [Char]
"   " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show NumSpec fn n
s'] (NumSpec fn n
s forall a. Semigroup a => a -> a -> a
<> NumSpec fn n
s')

genFromNumSpec ::
  (MonadGenError m, Show n, Random n, Ord n, Num n, MaybeBounded n) =>
  NumSpec fn n ->
  GenT m n
genFromNumSpec :: forall (m :: * -> *) n (fn :: [*] -> * -> *).
(MonadGenError m, Show n, Random n, Ord n, Num n,
 MaybeBounded n) =>
NumSpec fn n -> GenT m n
genFromNumSpec (NumSpecInterval Maybe n
ml Maybe n
mu) = do
  Int
n <- forall (m :: * -> *). Monad m => GenT m Int
sizeT
  forall (m :: * -> *) a. Applicative m => Gen a -> GenT m a
pureGen forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Random a => (a, a) -> Gen a
choose forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a.
(MonadGenError m, Ord a, Num a, Show a) =>
Maybe a -> Maybe a -> Integer -> m (a, a)
constrainInterval (Maybe n
ml forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. MaybeBounded a => Maybe a
lowerBound) (Maybe n
mu forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. MaybeBounded a => Maybe a
upperBound) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)

-- TODO: fixme (?)
shrinkWithNumSpec :: Arbitrary n => NumSpec fn n -> n -> [n]
shrinkWithNumSpec :: forall n (fn :: [*] -> * -> *).
Arbitrary n =>
NumSpec fn n -> n -> [n]
shrinkWithNumSpec NumSpec fn n
_ = forall a. Arbitrary a => a -> [a]
shrink

constrainInterval ::
  (MonadGenError m, Ord a, Num a, Show a) => Maybe a -> Maybe a -> Integer -> m (a, a)
constrainInterval :: forall (m :: * -> *) a.
(MonadGenError m, Ord a, Num a, Show a) =>
Maybe a -> Maybe a -> Integer -> m (a, a)
constrainInterval Maybe a
ml Maybe a
mu Integer
r =
  case (Maybe a
ml, Maybe a
mu) of
    (Maybe a
Nothing, Maybe a
Nothing) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (-a
r', a
r')
    (Just a
l, Maybe a
Nothing)
      | a
l forall a. Ord a => a -> a -> Bool
< a
0 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Ord a => a -> a -> a
max a
l (forall a. Num a => a -> a
negate a
r'), a
r')
      | Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
l, a
l forall a. Num a => a -> a -> a
+ a
2 forall a. Num a => a -> a -> a
* a
r')
    (Maybe a
Nothing, Just a
u)
      | a
u forall a. Ord a => a -> a -> Bool
> a
0 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Num a => a -> a
negate a
r', forall a. Ord a => a -> a -> a
min a
u a
r')
      | Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
u forall a. Num a => a -> a -> a
- a
r' forall a. Num a => a -> a -> a
- a
r', a
u)
    (Just a
l, Just a
u)
      | a
l forall a. Ord a => a -> a -> Bool
> a
u -> forall (m :: * -> *) a. MonadGenError m => [Char] -> m a
genError1 ([Char]
"bad interval: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
l forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
u)
      | a
u forall a. Ord a => a -> a -> Bool
< a
0 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall {p}. (Ord p, Num p) => p -> p -> p -> p
safeSub a
l (forall {p}. (Ord p, Num p) => p -> p -> p -> p
safeSub a
l a
u a
r') a
r', a
u)
      | a
l forall a. Ord a => a -> a -> Bool
>= a
0 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
l, forall {p}. (Ord p, Num p) => p -> p -> p -> p
safeAdd a
u (forall {p}. (Ord p, Num p) => p -> p -> p -> p
safeAdd a
u a
l a
r') a
r')
      -- TODO: this is a bit suspect if the bounds are lopsided
      | Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Ord a => a -> a -> a
max a
l (-a
r'), forall a. Ord a => a -> a -> a
min a
u a
r')
  where
    r' :: a
r' = forall a. Num a => a -> a
abs forall a b. (a -> b) -> a -> b
$ forall a. Num a => Integer -> a
fromInteger Integer
r
    safeSub :: p -> p -> p -> p
safeSub p
l p
a p
b
      | p
a forall a. Num a => a -> a -> a
- p
b forall a. Ord a => a -> a -> Bool
> p
a = p
l
      | Bool
otherwise = forall a. Ord a => a -> a -> a
max p
l (p
a forall a. Num a => a -> a -> a
- p
b)
    safeAdd :: p -> p -> p -> p
safeAdd p
u p
a p
b
      | p
a forall a. Num a => a -> a -> a
+ p
b forall a. Ord a => a -> a -> Bool
< p
a = p
u
      | Bool
otherwise = forall a. Ord a => a -> a -> a
min p
u (p
a forall a. Num a => a -> a -> a
+ p
b)

conformsToNumSpec :: Ord n => n -> NumSpec fn n -> Bool
conformsToNumSpec :: forall n (fn :: [*] -> * -> *). Ord n => n -> NumSpec fn n -> Bool
conformsToNumSpec n
i (NumSpecInterval Maybe n
ml Maybe n
mu) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (forall a. Ord a => a -> a -> Bool
<= n
i) Maybe n
ml Bool -> Bool -> Bool
&& forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (n
i forall a. Ord a => a -> a -> Bool
<=) Maybe n
mu

toPredsNumSpec ::
  ( Ord n
  , OrdLike fn n
  ) =>
  Term fn n ->
  NumSpec fn n ->
  Pred fn
toPredsNumSpec :: forall n (fn :: [*] -> * -> *).
(Ord n, OrdLike fn n) =>
Term fn n -> NumSpec fn n -> Pred fn
toPredsNumSpec Term fn n
v (NumSpecInterval Maybe n
ml Maybe n
mu) =
  forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall a b. (a -> b) -> a -> b
$
    [forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
p -> Pred fn
assert forall a b. (a -> b) -> a -> b
$ forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit n
l forall a (fn :: [*] -> * -> *).
(Ord a, OrdLike fn a) =>
Term fn a -> Term fn a -> Term fn Bool
<=. Term fn n
v | n
l <- forall a. Maybe a -> [a]
maybeToList Maybe n
ml]
      forall a. [a] -> [a] -> [a]
++ [forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
p -> Pred fn
assert forall a b. (a -> b) -> a -> b
$ Term fn n
v forall a (fn :: [*] -> * -> *).
(Ord a, OrdLike fn a) =>
Term fn a -> Term fn a -> Term fn Bool
<=. forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit n
u | n
u <- forall a. Maybe a -> [a]
maybeToList Maybe n
mu]

instance BaseUniverse fn => HasSpec fn Int where
  type TypeSpec fn Int = NumSpec fn Int
  emptySpec :: TypeSpec fn Int
emptySpec = forall n (fn :: [*] -> * -> *). Ord n => NumSpec fn n
emptyNumSpec
  combineSpec :: TypeSpec fn Int -> TypeSpec fn Int -> Specification fn Int
combineSpec = forall (fn :: [*] -> * -> *) n.
(HasSpec fn n, Ord n, TypeSpec fn n ~ NumSpec fn n) =>
NumSpec fn n -> NumSpec fn n -> Specification fn n
combineNumSpec
  genFromTypeSpec :: forall (m :: * -> *).
(HasCallStack, MonadGenError m) =>
TypeSpec fn Int -> GenT m Int
genFromTypeSpec = forall (m :: * -> *) n (fn :: [*] -> * -> *).
(MonadGenError m, Show n, Random n, Ord n, Num n,
 MaybeBounded n) =>
NumSpec fn n -> GenT m n
genFromNumSpec
  shrinkWithTypeSpec :: TypeSpec fn Int -> Int -> [Int]
shrinkWithTypeSpec = forall n (fn :: [*] -> * -> *).
Arbitrary n =>
NumSpec fn n -> n -> [n]
shrinkWithNumSpec
  conformsTo :: HasCallStack => Int -> TypeSpec fn Int -> Bool
conformsTo = forall n (fn :: [*] -> * -> *). Ord n => n -> NumSpec fn n -> Bool
conformsToNumSpec
  toPreds :: Term fn Int -> TypeSpec fn Int -> Pred fn
toPreds = forall n (fn :: [*] -> * -> *).
(Ord n, OrdLike fn n) =>
Term fn n -> NumSpec fn n -> Pred fn
toPredsNumSpec
  cardinalTypeSpec :: TypeSpec fn Int -> Specification fn Integer
cardinalTypeSpec = forall n (fn :: [*] -> * -> *).
(Integral n, Num n, MaybeBounded n) =>
NumSpec fn n -> Specification fn Integer
cardinalNumSpec
  guardTypeSpec :: [[Char]] -> TypeSpec fn Int -> Specification fn Int
guardTypeSpec = forall n (fn :: [*] -> * -> *).
(Ord n, HasSpec fn n, TypeSpec fn n ~ NumSpec fn n) =>
[[Char]] -> NumSpec fn n -> Specification fn n
guardNumSpec

instance BaseUniverse fn => HasSpec fn Integer where
  type TypeSpec fn Integer = NumSpec fn Integer
  emptySpec :: TypeSpec fn Integer
emptySpec = forall n (fn :: [*] -> * -> *). Ord n => NumSpec fn n
emptyNumSpec
  combineSpec :: TypeSpec fn Integer
-> TypeSpec fn Integer -> Specification fn Integer
combineSpec = forall (fn :: [*] -> * -> *) n.
(HasSpec fn n, Ord n, TypeSpec fn n ~ NumSpec fn n) =>
NumSpec fn n -> NumSpec fn n -> Specification fn n
combineNumSpec
  genFromTypeSpec :: forall (m :: * -> *).
(HasCallStack, MonadGenError m) =>
TypeSpec fn Integer -> GenT m Integer
genFromTypeSpec = forall (m :: * -> *) n (fn :: [*] -> * -> *).
(MonadGenError m, Show n, Random n, Ord n, Num n,
 MaybeBounded n) =>
NumSpec fn n -> GenT m n
genFromNumSpec
  shrinkWithTypeSpec :: TypeSpec fn Integer -> Integer -> [Integer]
shrinkWithTypeSpec = forall n (fn :: [*] -> * -> *).
Arbitrary n =>
NumSpec fn n -> n -> [n]
shrinkWithNumSpec
  conformsTo :: HasCallStack => Integer -> TypeSpec fn Integer -> Bool
conformsTo = forall n (fn :: [*] -> * -> *). Ord n => n -> NumSpec fn n -> Bool
conformsToNumSpec
  toPreds :: Term fn Integer -> TypeSpec fn Integer -> Pred fn
toPreds = forall n (fn :: [*] -> * -> *).
(Ord n, OrdLike fn n) =>
Term fn n -> NumSpec fn n -> Pred fn
toPredsNumSpec
  cardinalTypeSpec :: TypeSpec fn Integer -> Specification fn Integer
cardinalTypeSpec = forall n (fn :: [*] -> * -> *).
(Integral n, Num n, MaybeBounded n) =>
NumSpec fn n -> Specification fn Integer
cardinalNumSpec
  guardTypeSpec :: [[Char]] -> TypeSpec fn Integer -> Specification fn Integer
guardTypeSpec = forall n (fn :: [*] -> * -> *).
(Ord n, HasSpec fn n, TypeSpec fn n ~ NumSpec fn n) =>
[[Char]] -> NumSpec fn n -> Specification fn n
guardNumSpec

instance BaseUniverse fn => HasSpec fn (Ratio Integer) where
  type TypeSpec fn (Ratio Integer) = NumSpec fn (Ratio Integer)
  emptySpec :: TypeSpec fn (Ratio Integer)
emptySpec = forall n (fn :: [*] -> * -> *). Ord n => NumSpec fn n
emptyNumSpec
  combineSpec :: TypeSpec fn (Ratio Integer)
-> TypeSpec fn (Ratio Integer) -> Specification fn (Ratio Integer)
combineSpec = forall (fn :: [*] -> * -> *) n.
(HasSpec fn n, Ord n, TypeSpec fn n ~ NumSpec fn n) =>
NumSpec fn n -> NumSpec fn n -> Specification fn n
combineNumSpec
  genFromTypeSpec :: forall (m :: * -> *).
(HasCallStack, MonadGenError m) =>
TypeSpec fn (Ratio Integer) -> GenT m (Ratio Integer)
genFromTypeSpec = forall (m :: * -> *) n (fn :: [*] -> * -> *).
(MonadGenError m, Show n, Random n, Ord n, Num n,
 MaybeBounded n) =>
NumSpec fn n -> GenT m n
genFromNumSpec
  shrinkWithTypeSpec :: TypeSpec fn (Ratio Integer) -> Ratio Integer -> [Ratio Integer]
shrinkWithTypeSpec = forall n (fn :: [*] -> * -> *).
Arbitrary n =>
NumSpec fn n -> n -> [n]
shrinkWithNumSpec
  conformsTo :: HasCallStack =>
Ratio Integer -> TypeSpec fn (Ratio Integer) -> Bool
conformsTo = forall n (fn :: [*] -> * -> *). Ord n => n -> NumSpec fn n -> Bool
conformsToNumSpec
  toPreds :: Term fn (Ratio Integer) -> TypeSpec fn (Ratio Integer) -> Pred fn
toPreds = forall n (fn :: [*] -> * -> *).
(Ord n, OrdLike fn n) =>
Term fn n -> NumSpec fn n -> Pred fn
toPredsNumSpec
  cardinalTypeSpec :: TypeSpec fn (Ratio Integer) -> Specification fn Integer
cardinalTypeSpec TypeSpec fn (Ratio Integer)
_ = forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec
  guardTypeSpec :: [[Char]]
-> TypeSpec fn (Ratio Integer) -> Specification fn (Ratio Integer)
guardTypeSpec = forall n (fn :: [*] -> * -> *).
(Ord n, HasSpec fn n, TypeSpec fn n ~ NumSpec fn n) =>
[[Char]] -> NumSpec fn n -> Specification fn n
guardNumSpec

instance BaseUniverse fn => HasSpec fn Natural where
  type TypeSpec fn Natural = NumSpec fn Natural
  emptySpec :: TypeSpec fn Natural
emptySpec = forall n (fn :: [*] -> * -> *). Ord n => NumSpec fn n
emptyNumSpec
  combineSpec :: TypeSpec fn Natural
-> TypeSpec fn Natural -> Specification fn Natural
combineSpec = forall (fn :: [*] -> * -> *) n.
(HasSpec fn n, Ord n, TypeSpec fn n ~ NumSpec fn n) =>
NumSpec fn n -> NumSpec fn n -> Specification fn n
combineNumSpec
  genFromTypeSpec :: forall (m :: * -> *).
(HasCallStack, MonadGenError m) =>
TypeSpec fn Natural -> GenT m Natural
genFromTypeSpec = forall (m :: * -> *) n (fn :: [*] -> * -> *).
(MonadGenError m, Show n, Random n, Ord n, Num n,
 MaybeBounded n) =>
NumSpec fn n -> GenT m n
genFromNumSpec
  shrinkWithTypeSpec :: TypeSpec fn Natural -> Natural -> [Natural]
shrinkWithTypeSpec = forall n (fn :: [*] -> * -> *).
Arbitrary n =>
NumSpec fn n -> n -> [n]
shrinkWithNumSpec
  conformsTo :: HasCallStack => Natural -> TypeSpec fn Natural -> Bool
conformsTo = forall n (fn :: [*] -> * -> *). Ord n => n -> NumSpec fn n -> Bool
conformsToNumSpec
  toPreds :: Term fn Natural -> TypeSpec fn Natural -> Pred fn
toPreds = forall n (fn :: [*] -> * -> *).
(Ord n, OrdLike fn n) =>
Term fn n -> NumSpec fn n -> Pred fn
toPredsNumSpec
  cardinalTypeSpec :: TypeSpec fn Natural -> Specification fn Integer
cardinalTypeSpec (NumSpecInterval (Just Natural
lo) (Just Natural
hi)) =
    if Natural
hi forall a. Ord a => a -> a -> Bool
>= Natural
lo
      then forall a (fn :: [*] -> * -> *). NonEmpty a -> Specification fn a
MemberSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Natural @Integer (Natural
hi forall a. Num a => a -> a -> a
- Natural
lo forall a. Num a => a -> a -> a
+ Natural
1)))
      else forall a (fn :: [*] -> * -> *). NonEmpty a -> Specification fn a
MemberSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
0)
  cardinalTypeSpec (NumSpecInterval Maybe Natural
Nothing (Just Natural
hi)) =
    forall a (fn :: [*] -> * -> *). NonEmpty a -> Specification fn a
MemberSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Natural @Integer Natural
hi forall a. Num a => a -> a -> a
+ Integer
1))
  cardinalTypeSpec TypeSpec fn Natural
_ = forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec
  guardTypeSpec :: [[Char]] -> TypeSpec fn Natural -> Specification fn Natural
guardTypeSpec = forall n (fn :: [*] -> * -> *).
(Ord n, HasSpec fn n, TypeSpec fn n ~ NumSpec fn n) =>
[[Char]] -> NumSpec fn n -> Specification fn n
guardNumSpec

instance BaseUniverse fn => HasSpec fn Word8 where
  type TypeSpec fn Word8 = NumSpec fn Word8
  emptySpec :: TypeSpec fn Word8
emptySpec = forall n (fn :: [*] -> * -> *). Ord n => NumSpec fn n
emptyNumSpec
  combineSpec :: TypeSpec fn Word8 -> TypeSpec fn Word8 -> Specification fn Word8
combineSpec = forall (fn :: [*] -> * -> *) n.
(HasSpec fn n, Ord n, TypeSpec fn n ~ NumSpec fn n) =>
NumSpec fn n -> NumSpec fn n -> Specification fn n
combineNumSpec
  genFromTypeSpec :: forall (m :: * -> *).
(HasCallStack, MonadGenError m) =>
TypeSpec fn Word8 -> GenT m Word8
genFromTypeSpec = forall (m :: * -> *) n (fn :: [*] -> * -> *).
(MonadGenError m, Show n, Random n, Ord n, Num n,
 MaybeBounded n) =>
NumSpec fn n -> GenT m n
genFromNumSpec
  shrinkWithTypeSpec :: TypeSpec fn Word8 -> Word8 -> [Word8]
shrinkWithTypeSpec = forall n (fn :: [*] -> * -> *).
Arbitrary n =>
NumSpec fn n -> n -> [n]
shrinkWithNumSpec
  conformsTo :: HasCallStack => Word8 -> TypeSpec fn Word8 -> Bool
conformsTo = forall n (fn :: [*] -> * -> *). Ord n => n -> NumSpec fn n -> Bool
conformsToNumSpec
  toPreds :: Term fn Word8 -> TypeSpec fn Word8 -> Pred fn
toPreds = forall n (fn :: [*] -> * -> *).
(Ord n, OrdLike fn n) =>
Term fn n -> NumSpec fn n -> Pred fn
toPredsNumSpec
  cardinalTypeSpec :: TypeSpec fn Word8 -> Specification fn Integer
cardinalTypeSpec = forall n (fn :: [*] -> * -> *).
(Integral n, Num n, MaybeBounded n) =>
NumSpec fn n -> Specification fn Integer
cardinalNumSpec
  typeSpecOpt :: TypeSpec fn Word8 -> [Word8] -> Specification fn Word8
typeSpecOpt = forall (fn :: [*] -> * -> *) n.
(Functions fn fn, BaseUniverse fn, HasSpec fn n,
 TypeSpec fn n ~ NumSpec fn n, Bounded n, Integral n) =>
NumSpec fn n -> [n] -> Specification fn n
notInNumSpec
  guardTypeSpec :: [[Char]] -> TypeSpec fn Word8 -> Specification fn Word8
guardTypeSpec = forall n (fn :: [*] -> * -> *).
(Ord n, HasSpec fn n, TypeSpec fn n ~ NumSpec fn n) =>
[[Char]] -> NumSpec fn n -> Specification fn n
guardNumSpec

instance BaseUniverse fn => HasSpec fn Word16 where
  type TypeSpec fn Word16 = NumSpec fn Word16
  emptySpec :: TypeSpec fn Word16
emptySpec = forall n (fn :: [*] -> * -> *). Ord n => NumSpec fn n
emptyNumSpec
  combineSpec :: TypeSpec fn Word16 -> TypeSpec fn Word16 -> Specification fn Word16
combineSpec = forall (fn :: [*] -> * -> *) n.
(HasSpec fn n, Ord n, TypeSpec fn n ~ NumSpec fn n) =>
NumSpec fn n -> NumSpec fn n -> Specification fn n
combineNumSpec
  genFromTypeSpec :: forall (m :: * -> *).
(HasCallStack, MonadGenError m) =>
TypeSpec fn Word16 -> GenT m Word16
genFromTypeSpec = forall (m :: * -> *) n (fn :: [*] -> * -> *).
(MonadGenError m, Show n, Random n, Ord n, Num n,
 MaybeBounded n) =>
NumSpec fn n -> GenT m n
genFromNumSpec
  shrinkWithTypeSpec :: TypeSpec fn Word16 -> Word16 -> [Word16]
shrinkWithTypeSpec = forall n (fn :: [*] -> * -> *).
Arbitrary n =>
NumSpec fn n -> n -> [n]
shrinkWithNumSpec
  conformsTo :: HasCallStack => Word16 -> TypeSpec fn Word16 -> Bool
conformsTo = forall n (fn :: [*] -> * -> *). Ord n => n -> NumSpec fn n -> Bool
conformsToNumSpec
  toPreds :: Term fn Word16 -> TypeSpec fn Word16 -> Pred fn
toPreds = forall n (fn :: [*] -> * -> *).
(Ord n, OrdLike fn n) =>
Term fn n -> NumSpec fn n -> Pred fn
toPredsNumSpec
  cardinalTypeSpec :: TypeSpec fn Word16 -> Specification fn Integer
cardinalTypeSpec = forall n (fn :: [*] -> * -> *).
(Integral n, Num n, MaybeBounded n) =>
NumSpec fn n -> Specification fn Integer
cardinalNumSpec
  guardTypeSpec :: [[Char]] -> TypeSpec fn Word16 -> Specification fn Word16
guardTypeSpec = forall n (fn :: [*] -> * -> *).
(Ord n, HasSpec fn n, TypeSpec fn n ~ NumSpec fn n) =>
[[Char]] -> NumSpec fn n -> Specification fn n
guardNumSpec

instance BaseUniverse fn => HasSpec fn Word32 where
  type TypeSpec fn Word32 = NumSpec fn Word32
  emptySpec :: TypeSpec fn Word32
emptySpec = forall n (fn :: [*] -> * -> *). Ord n => NumSpec fn n
emptyNumSpec
  combineSpec :: TypeSpec fn Word32 -> TypeSpec fn Word32 -> Specification fn Word32
combineSpec = forall (fn :: [*] -> * -> *) n.
(HasSpec fn n, Ord n, TypeSpec fn n ~ NumSpec fn n) =>
NumSpec fn n -> NumSpec fn n -> Specification fn n
combineNumSpec
  genFromTypeSpec :: forall (m :: * -> *).
(HasCallStack, MonadGenError m) =>
TypeSpec fn Word32 -> GenT m Word32
genFromTypeSpec = forall (m :: * -> *) n (fn :: [*] -> * -> *).
(MonadGenError m, Show n, Random n, Ord n, Num n,
 MaybeBounded n) =>
NumSpec fn n -> GenT m n
genFromNumSpec
  shrinkWithTypeSpec :: TypeSpec fn Word32 -> Word32 -> [Word32]
shrinkWithTypeSpec = forall n (fn :: [*] -> * -> *).
Arbitrary n =>
NumSpec fn n -> n -> [n]
shrinkWithNumSpec
  conformsTo :: HasCallStack => Word32 -> TypeSpec fn Word32 -> Bool
conformsTo = forall n (fn :: [*] -> * -> *). Ord n => n -> NumSpec fn n -> Bool
conformsToNumSpec
  toPreds :: Term fn Word32 -> TypeSpec fn Word32 -> Pred fn
toPreds = forall n (fn :: [*] -> * -> *).
(Ord n, OrdLike fn n) =>
Term fn n -> NumSpec fn n -> Pred fn
toPredsNumSpec
  cardinalTypeSpec :: TypeSpec fn Word32 -> Specification fn Integer
cardinalTypeSpec = forall n (fn :: [*] -> * -> *).
(Integral n, Num n, MaybeBounded n) =>
NumSpec fn n -> Specification fn Integer
cardinalNumSpec
  guardTypeSpec :: [[Char]] -> TypeSpec fn Word32 -> Specification fn Word32
guardTypeSpec = forall n (fn :: [*] -> * -> *).
(Ord n, HasSpec fn n, TypeSpec fn n ~ NumSpec fn n) =>
[[Char]] -> NumSpec fn n -> Specification fn n
guardNumSpec

instance BaseUniverse fn => HasSpec fn Word64 where
  type TypeSpec fn Word64 = NumSpec fn Word64
  emptySpec :: TypeSpec fn Word64
emptySpec = forall n (fn :: [*] -> * -> *). Ord n => NumSpec fn n
emptyNumSpec
  combineSpec :: TypeSpec fn Word64 -> TypeSpec fn Word64 -> Specification fn Word64
combineSpec = forall (fn :: [*] -> * -> *) n.
(HasSpec fn n, Ord n, TypeSpec fn n ~ NumSpec fn n) =>
NumSpec fn n -> NumSpec fn n -> Specification fn n
combineNumSpec
  genFromTypeSpec :: forall (m :: * -> *).
(HasCallStack, MonadGenError m) =>
TypeSpec fn Word64 -> GenT m Word64
genFromTypeSpec = forall (m :: * -> *) n (fn :: [*] -> * -> *).
(MonadGenError m, Show n, Random n, Ord n, Num n,
 MaybeBounded n) =>
NumSpec fn n -> GenT m n
genFromNumSpec
  shrinkWithTypeSpec :: TypeSpec fn Word64 -> Word64 -> [Word64]
shrinkWithTypeSpec = forall n (fn :: [*] -> * -> *).
Arbitrary n =>
NumSpec fn n -> n -> [n]
shrinkWithNumSpec
  conformsTo :: HasCallStack => Word64 -> TypeSpec fn Word64 -> Bool
conformsTo = forall n (fn :: [*] -> * -> *). Ord n => n -> NumSpec fn n -> Bool
conformsToNumSpec
  toPreds :: Term fn Word64 -> TypeSpec fn Word64 -> Pred fn
toPreds = forall n (fn :: [*] -> * -> *).
(Ord n, OrdLike fn n) =>
Term fn n -> NumSpec fn n -> Pred fn
toPredsNumSpec
  cardinalTypeSpec :: TypeSpec fn Word64 -> Specification fn Integer
cardinalTypeSpec = forall n (fn :: [*] -> * -> *).
(Integral n, Num n, MaybeBounded n) =>
NumSpec fn n -> Specification fn Integer
cardinalNumSpec
  guardTypeSpec :: [[Char]] -> TypeSpec fn Word64 -> Specification fn Word64
guardTypeSpec = forall n (fn :: [*] -> * -> *).
(Ord n, HasSpec fn n, TypeSpec fn n ~ NumSpec fn n) =>
[[Char]] -> NumSpec fn n -> Specification fn n
guardNumSpec

instance BaseUniverse fn => HasSpec fn Int8 where
  type TypeSpec fn Int8 = NumSpec fn Int8
  emptySpec :: TypeSpec fn Int8
emptySpec = forall n (fn :: [*] -> * -> *). Ord n => NumSpec fn n
emptyNumSpec
  combineSpec :: TypeSpec fn Int8 -> TypeSpec fn Int8 -> Specification fn Int8
combineSpec = forall (fn :: [*] -> * -> *) n.
(HasSpec fn n, Ord n, TypeSpec fn n ~ NumSpec fn n) =>
NumSpec fn n -> NumSpec fn n -> Specification fn n
combineNumSpec
  genFromTypeSpec :: forall (m :: * -> *).
(HasCallStack, MonadGenError m) =>
TypeSpec fn Int8 -> GenT m Int8
genFromTypeSpec = forall (m :: * -> *) n (fn :: [*] -> * -> *).
(MonadGenError m, Show n, Random n, Ord n, Num n,
 MaybeBounded n) =>
NumSpec fn n -> GenT m n
genFromNumSpec
  shrinkWithTypeSpec :: TypeSpec fn Int8 -> Int8 -> [Int8]
shrinkWithTypeSpec = forall n (fn :: [*] -> * -> *).
Arbitrary n =>
NumSpec fn n -> n -> [n]
shrinkWithNumSpec
  conformsTo :: HasCallStack => Int8 -> TypeSpec fn Int8 -> Bool
conformsTo = forall n (fn :: [*] -> * -> *). Ord n => n -> NumSpec fn n -> Bool
conformsToNumSpec
  toPreds :: Term fn Int8 -> TypeSpec fn Int8 -> Pred fn
toPreds = forall n (fn :: [*] -> * -> *).
(Ord n, OrdLike fn n) =>
Term fn n -> NumSpec fn n -> Pred fn
toPredsNumSpec
  cardinalTypeSpec :: TypeSpec fn Int8 -> Specification fn Integer
cardinalTypeSpec = forall n (fn :: [*] -> * -> *).
(Integral n, Num n, MaybeBounded n) =>
NumSpec fn n -> Specification fn Integer
cardinalNumSpec
  guardTypeSpec :: [[Char]] -> TypeSpec fn Int8 -> Specification fn Int8
guardTypeSpec = forall n (fn :: [*] -> * -> *).
(Ord n, HasSpec fn n, TypeSpec fn n ~ NumSpec fn n) =>
[[Char]] -> NumSpec fn n -> Specification fn n
guardNumSpec

instance BaseUniverse fn => HasSpec fn Int16 where
  type TypeSpec fn Int16 = NumSpec fn Int16
  emptySpec :: TypeSpec fn Int16
emptySpec = forall n (fn :: [*] -> * -> *). Ord n => NumSpec fn n
emptyNumSpec
  combineSpec :: TypeSpec fn Int16 -> TypeSpec fn Int16 -> Specification fn Int16
combineSpec = forall (fn :: [*] -> * -> *) n.
(HasSpec fn n, Ord n, TypeSpec fn n ~ NumSpec fn n) =>
NumSpec fn n -> NumSpec fn n -> Specification fn n
combineNumSpec
  genFromTypeSpec :: forall (m :: * -> *).
(HasCallStack, MonadGenError m) =>
TypeSpec fn Int16 -> GenT m Int16
genFromTypeSpec = forall (m :: * -> *) n (fn :: [*] -> * -> *).
(MonadGenError m, Show n, Random n, Ord n, Num n,
 MaybeBounded n) =>
NumSpec fn n -> GenT m n
genFromNumSpec
  shrinkWithTypeSpec :: TypeSpec fn Int16 -> Int16 -> [Int16]
shrinkWithTypeSpec = forall n (fn :: [*] -> * -> *).
Arbitrary n =>
NumSpec fn n -> n -> [n]
shrinkWithNumSpec
  conformsTo :: HasCallStack => Int16 -> TypeSpec fn Int16 -> Bool
conformsTo = forall n (fn :: [*] -> * -> *). Ord n => n -> NumSpec fn n -> Bool
conformsToNumSpec
  toPreds :: Term fn Int16 -> TypeSpec fn Int16 -> Pred fn
toPreds = forall n (fn :: [*] -> * -> *).
(Ord n, OrdLike fn n) =>
Term fn n -> NumSpec fn n -> Pred fn
toPredsNumSpec
  cardinalTypeSpec :: TypeSpec fn Int16 -> Specification fn Integer
cardinalTypeSpec = forall n (fn :: [*] -> * -> *).
(Integral n, Num n, MaybeBounded n) =>
NumSpec fn n -> Specification fn Integer
cardinalNumSpec
  guardTypeSpec :: [[Char]] -> TypeSpec fn Int16 -> Specification fn Int16
guardTypeSpec = forall n (fn :: [*] -> * -> *).
(Ord n, HasSpec fn n, TypeSpec fn n ~ NumSpec fn n) =>
[[Char]] -> NumSpec fn n -> Specification fn n
guardNumSpec

instance BaseUniverse fn => HasSpec fn Int32 where
  type TypeSpec fn Int32 = NumSpec fn Int32
  emptySpec :: TypeSpec fn Int32
emptySpec = forall n (fn :: [*] -> * -> *). Ord n => NumSpec fn n
emptyNumSpec
  combineSpec :: TypeSpec fn Int32 -> TypeSpec fn Int32 -> Specification fn Int32
combineSpec = forall (fn :: [*] -> * -> *) n.
(HasSpec fn n, Ord n, TypeSpec fn n ~ NumSpec fn n) =>
NumSpec fn n -> NumSpec fn n -> Specification fn n
combineNumSpec
  genFromTypeSpec :: forall (m :: * -> *).
(HasCallStack, MonadGenError m) =>
TypeSpec fn Int32 -> GenT m Int32
genFromTypeSpec = forall (m :: * -> *) n (fn :: [*] -> * -> *).
(MonadGenError m, Show n, Random n, Ord n, Num n,
 MaybeBounded n) =>
NumSpec fn n -> GenT m n
genFromNumSpec
  shrinkWithTypeSpec :: TypeSpec fn Int32 -> Int32 -> [Int32]
shrinkWithTypeSpec = forall n (fn :: [*] -> * -> *).
Arbitrary n =>
NumSpec fn n -> n -> [n]
shrinkWithNumSpec
  conformsTo :: HasCallStack => Int32 -> TypeSpec fn Int32 -> Bool
conformsTo = forall n (fn :: [*] -> * -> *). Ord n => n -> NumSpec fn n -> Bool
conformsToNumSpec
  toPreds :: Term fn Int32 -> TypeSpec fn Int32 -> Pred fn
toPreds = forall n (fn :: [*] -> * -> *).
(Ord n, OrdLike fn n) =>
Term fn n -> NumSpec fn n -> Pred fn
toPredsNumSpec
  cardinalTypeSpec :: TypeSpec fn Int32 -> Specification fn Integer
cardinalTypeSpec = forall n (fn :: [*] -> * -> *).
(Integral n, Num n, MaybeBounded n) =>
NumSpec fn n -> Specification fn Integer
cardinalNumSpec
  guardTypeSpec :: [[Char]] -> TypeSpec fn Int32 -> Specification fn Int32
guardTypeSpec = forall n (fn :: [*] -> * -> *).
(Ord n, HasSpec fn n, TypeSpec fn n ~ NumSpec fn n) =>
[[Char]] -> NumSpec fn n -> Specification fn n
guardNumSpec

instance BaseUniverse fn => HasSpec fn Int64 where
  type TypeSpec fn Int64 = NumSpec fn Int64
  emptySpec :: TypeSpec fn Int64
emptySpec = forall n (fn :: [*] -> * -> *). Ord n => NumSpec fn n
emptyNumSpec
  combineSpec :: TypeSpec fn Int64 -> TypeSpec fn Int64 -> Specification fn Int64
combineSpec = forall (fn :: [*] -> * -> *) n.
(HasSpec fn n, Ord n, TypeSpec fn n ~ NumSpec fn n) =>
NumSpec fn n -> NumSpec fn n -> Specification fn n
combineNumSpec
  genFromTypeSpec :: forall (m :: * -> *).
(HasCallStack, MonadGenError m) =>
TypeSpec fn Int64 -> GenT m Int64
genFromTypeSpec = forall (m :: * -> *) n (fn :: [*] -> * -> *).
(MonadGenError m, Show n, Random n, Ord n, Num n,
 MaybeBounded n) =>
NumSpec fn n -> GenT m n
genFromNumSpec
  shrinkWithTypeSpec :: TypeSpec fn Int64 -> Int64 -> [Int64]
shrinkWithTypeSpec = forall n (fn :: [*] -> * -> *).
Arbitrary n =>
NumSpec fn n -> n -> [n]
shrinkWithNumSpec
  conformsTo :: HasCallStack => Int64 -> TypeSpec fn Int64 -> Bool
conformsTo = forall n (fn :: [*] -> * -> *). Ord n => n -> NumSpec fn n -> Bool
conformsToNumSpec
  toPreds :: Term fn Int64 -> TypeSpec fn Int64 -> Pred fn
toPreds = forall n (fn :: [*] -> * -> *).
(Ord n, OrdLike fn n) =>
Term fn n -> NumSpec fn n -> Pred fn
toPredsNumSpec
  cardinalTypeSpec :: TypeSpec fn Int64 -> Specification fn Integer
cardinalTypeSpec = forall n (fn :: [*] -> * -> *).
(Integral n, Num n, MaybeBounded n) =>
NumSpec fn n -> Specification fn Integer
cardinalNumSpec
  guardTypeSpec :: [[Char]] -> TypeSpec fn Int64 -> Specification fn Int64
guardTypeSpec = forall n (fn :: [*] -> * -> *).
(Ord n, HasSpec fn n, TypeSpec fn n ~ NumSpec fn n) =>
[[Char]] -> NumSpec fn n -> Specification fn n
guardNumSpec

instance BaseUniverse fn => HasSpec fn Float where
  type TypeSpec fn Float = NumSpec fn Float
  emptySpec :: TypeSpec fn Float
emptySpec = forall n (fn :: [*] -> * -> *). Ord n => NumSpec fn n
emptyNumSpec
  combineSpec :: TypeSpec fn Float -> TypeSpec fn Float -> Specification fn Float
combineSpec = forall (fn :: [*] -> * -> *) n.
(HasSpec fn n, Ord n, TypeSpec fn n ~ NumSpec fn n) =>
NumSpec fn n -> NumSpec fn n -> Specification fn n
combineNumSpec
  genFromTypeSpec :: forall (m :: * -> *).
(HasCallStack, MonadGenError m) =>
TypeSpec fn Float -> GenT m Float
genFromTypeSpec = forall (m :: * -> *) n (fn :: [*] -> * -> *).
(MonadGenError m, Show n, Random n, Ord n, Num n,
 MaybeBounded n) =>
NumSpec fn n -> GenT m n
genFromNumSpec
  shrinkWithTypeSpec :: TypeSpec fn Float -> Float -> [Float]
shrinkWithTypeSpec = forall n (fn :: [*] -> * -> *).
Arbitrary n =>
NumSpec fn n -> n -> [n]
shrinkWithNumSpec
  conformsTo :: HasCallStack => Float -> TypeSpec fn Float -> Bool
conformsTo = forall n (fn :: [*] -> * -> *). Ord n => n -> NumSpec fn n -> Bool
conformsToNumSpec
  toPreds :: Term fn Float -> TypeSpec fn Float -> Pred fn
toPreds = forall n (fn :: [*] -> * -> *).
(Ord n, OrdLike fn n) =>
Term fn n -> NumSpec fn n -> Pred fn
toPredsNumSpec
  cardinalTypeSpec :: TypeSpec fn Float -> Specification fn Integer
cardinalTypeSpec TypeSpec fn Float
_ = forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec
  guardTypeSpec :: [[Char]] -> TypeSpec fn Float -> Specification fn Float
guardTypeSpec = forall n (fn :: [*] -> * -> *).
(Ord n, HasSpec fn n, TypeSpec fn n ~ NumSpec fn n) =>
[[Char]] -> NumSpec fn n -> Specification fn n
guardNumSpec

-----------------------------------------------------------------------------------
-- The Base Function universe defines operations on TypeSpec defined in the Base.
-- See module  Test.Cardano.Ledger.Constrained.V2.Conway for a Universe
-- that is an extension of the Base Universe.
-----------------------------------------------------------------------------------

type BaseFns =
  '[EqFn, SetFn, BoolFn, PairFn, IntFn, OrdFn, GenericsFn, ListFn, SumFn, MapFn, FunFn, SizeFn]
type BaseFn = Fix (OneofL BaseFns)

-- | A minimal Universe contains functions for a bunch of different things.
type BaseUniverse fn =
  ( Functions fn fn
  , Member (EqFn fn) fn
  , Member (SetFn fn) fn
  , Member (BoolFn fn) fn
  , Member (PairFn fn) fn
  , Member (IntFn fn) fn
  , Member (OrdFn fn) fn
  , Member (GenericsFn fn) fn
  , Member (ListFn fn) fn
  , Member (SumFn fn) fn
  , Member (MapFn fn) fn
  , Member (FunFn fn) fn
  , Member (SizeFn fn) fn
  )

-- Higher order functions -------------------------------------------------

idFn :: forall fn a. Member (FunFn fn) fn => fn '[a] a
idFn :: forall (fn :: [*] -> * -> *) a. Member (FunFn fn) fn => fn '[a] a
idFn = forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fn as b -> fnU as b
injectFn forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a. FunFn fn '[a] a
Id @fn

composeFn ::
  ( Member (FunFn fn) fn
  , HasSpec fn b
  , Show (fn '[a] b)
  , Show (fn '[b] c)
  , Eq (fn '[a] b)
  , Eq (fn '[b] c)
  ) =>
  fn '[b] c ->
  fn '[a] b ->
  fn '[a] c
composeFn :: forall (fn :: [*] -> * -> *) b a c.
(Member (FunFn fn) fn, HasSpec fn b, Show (fn '[a] b),
 Show (fn '[b] c), Eq (fn '[a] b), Eq (fn '[b] c)) =>
fn '[b] c -> fn '[a] b -> fn '[a] c
composeFn fn '[b] c
f fn '[a] b
g = forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fn as b -> fnU as b
injectFn forall a b. (a -> b) -> a -> b
$ forall a (fn :: [*] -> * -> *) b c.
(Typeable a, HasSpec fn a, Show (fn '[b] a), Show (fn '[a] c),
 Eq (fn '[b] a), Eq (fn '[a] c)) =>
fn '[a] c -> fn '[b] a -> FunFn fn '[b] c
Compose fn '[b] c
f fn '[a] b
g

flip_ ::
  forall fn a b c.
  ( Member (FunFn fn) fn
  , Typeable a
  , Typeable b
  , HasSpec fn a
  , HasSpec fn b
  , HasSpec fn c
  ) =>
  (Term fn a -> Term fn b -> Term fn c) ->
  Term fn b ->
  Term fn a ->
  Term fn c
flip_ :: forall (fn :: [*] -> * -> *) a b c.
(Member (FunFn fn) fn, Typeable a, Typeable b, HasSpec fn a,
 HasSpec fn b, HasSpec fn c) =>
(Term fn a -> Term fn b -> Term fn c)
-> Term fn b -> Term fn a -> Term fn c
flip_ Term fn a -> Term fn b -> Term fn c
f =
  forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app (forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fn as b -> fnU as b
injectFn @(FunFn fn) @fn (forall (fn :: [*] -> * -> *) a b c.
(Show (fn '[a, b] c), Eq (fn '[a, b] c), HasSpec fn a,
 HasSpec fn b) =>
fn '[a, b] c -> FunFn fn '[b, a] c
Flip fn '[a, b] c
f'))
  where
    x :: Var a
x = forall a. Int -> [Char] -> Var a
Var (-Int
1) [Char]
"v" :: Var a
    y :: Var b
y = forall a. Int -> [Char] -> Var a
Var (-Int
2) [Char]
"v" :: Var b
    f' :: fn '[a, b] c
f' = case Term fn a -> Term fn b -> Term fn c
f (forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Term fn a
V Var a
x) (forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Term fn a
V Var b
y) of
      App fn as c
fn (V Var a
x' :> V Var a
y' :> List (Term fn) as1
Nil)
        | Just a :~: a
Refl <- forall a a'.
(Typeable a, Typeable a') =>
Var a -> Var a' -> Maybe (a :~: a')
eqVar Var a
x Var a
x'
        , Just b :~: a
Refl <- forall a a'.
(Typeable a, Typeable a') =>
Var a -> Var a' -> Maybe (a :~: a')
eqVar Var b
y Var a
y' ->
            fn as c
fn
      Term fn c
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"Malformed function in flip_"

data FunFn fn args res where
  Id :: FunFn fn '[a] a
  Compose ::
    ( Typeable b
    , HasSpec fn b
    , Show (fn '[a] b)
    , Show (fn '[b] c)
    , Eq (fn '[a] b)
    , Eq (fn '[b] c)
    ) =>
    fn '[b] c ->
    fn '[a] b ->
    FunFn fn '[a] c
  Flip ::
    ( Show (fn '[a, b] c)
    , Eq (fn '[a, b] c)
    , HasSpec fn a
    , HasSpec fn b
    ) =>
    fn '[a, b] c ->
    FunFn fn '[b, a] c

deriving instance Show (FunFn fn args res)

instance Typeable fn => Eq (FunFn fn args res) where
  Compose (fn '[b] res
f :: fn '[b] c) fn '[a] b
f' == :: FunFn fn args res -> FunFn fn args res -> Bool
== Compose (fn '[b] res
g :: fn '[b'] c') fn '[a] b
g'
    | Just b :~: b
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @b @b' = fn '[b] res
f forall a. Eq a => a -> a -> Bool
== fn '[b] res
g Bool -> Bool -> Bool
&& fn '[a] b
f' forall a. Eq a => a -> a -> Bool
== fn '[a] b
g'
  Compose {} == FunFn fn args res
_ = Bool
False
  FunFn fn args res
Id == FunFn fn args res
Id = Bool
True
  FunFn fn args res
Id == FunFn fn args res
_ = Bool
False
  Flip (fn '[a, b] res
f :: fn '[a, b] c) == Flip (fn '[a, b] res
g :: fn '[a', b'] c')
    | Just a :~: a
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @a @a'
    , Just b :~: b
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @b @b' =
        fn '[a, b] res
f forall a. Eq a => a -> a -> Bool
== fn '[a, b] res
g
  Flip {} == FunFn fn args res
_ = Bool
False

instance FunctionLike fn => FunctionLike (FunFn fn) where
  sem :: forall (as :: [*]) b. FunFn fn as b -> FunTy as b
sem = \case
    FunFn fn as b
Id -> forall a. a -> a
id
    Compose fn '[b] b
f fn '[a] b
g -> forall (fn :: [*] -> * -> *) (as :: [*]) b.
FunctionLike fn =>
fn as b -> FunTy as b
sem fn '[b] b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fn :: [*] -> * -> *) (as :: [*]) b.
FunctionLike fn =>
fn as b -> FunTy as b
sem fn '[a] b
g
    Flip fn '[a, b] b
f -> forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (fn :: [*] -> * -> *) (as :: [*]) b.
FunctionLike fn =>
fn as b -> FunTy as b
sem fn '[a, b] b
f)

instance (BaseUniverse fn, Member (FunFn fn) fn) => Functions (FunFn fn) fn where
  propagateSpecFun :: forall (as :: [*]) a b.
(TypeList as, Typeable as, HasSpec fn a, HasSpec fn b,
 All (HasSpec fn) as) =>
FunFn fn as b
-> ListCtx Value as (HOLE a)
-> Specification fn b
-> Specification fn a
propagateSpecFun FunFn fn as b
_ ListCtx Value as (HOLE a)
_ (ErrorSpec NonEmpty [Char]
err) = forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec NonEmpty [Char]
err
  propagateSpecFun FunFn fn as b
fn ListCtx Value as (HOLE a)
ctx Specification fn b
spec = case FunFn fn as b
fn of
    FunFn fn as b
Id | NilCtx HOLE a b
HOLE <- ListCtx Value as (HOLE a)
ctx -> Specification fn b
spec
    Compose fn '[b] b
f fn '[a] b
g | NilCtx HOLE a a
HOLE <- ListCtx Value as (HOLE a)
ctx -> forall (f :: [*] -> * -> *) (fn :: [*] -> * -> *) (as :: [*]) a b.
(Functions f fn, TypeList as, Typeable as, HasSpec fn a,
 HasSpec fn b, All (HasSpec fn) as) =>
f as b
-> ListCtx Value as (HOLE a)
-> Specification fn b
-> Specification fn a
propagateSpecFun fn '[a] b
g (forall (c :: * -> *) a (f :: * -> *). c a -> ListCtx f '[a] c
NilCtx forall a. HOLE a a
HOLE) forall a b. (a -> b) -> a -> b
$ forall (f :: [*] -> * -> *) (fn :: [*] -> * -> *) (as :: [*]) a b.
(Functions f fn, TypeList as, Typeable as, HasSpec fn a,
 HasSpec fn b, All (HasSpec fn) as) =>
f as b
-> ListCtx Value as (HOLE a)
-> Specification fn b
-> Specification fn a
propagateSpecFun fn '[b] b
f (forall (c :: * -> *) a (f :: * -> *). c a -> ListCtx f '[a] c
NilCtx forall a. HOLE a a
HOLE) Specification fn b
spec
    Flip fn '[a, b] b
f
      | HOLE a a
HOLE :? Value a
v :> List Value as1
Nil <- ListCtx Value as (HOLE a)
ctx -> forall (f :: [*] -> * -> *) (fn :: [*] -> * -> *) (as :: [*]) a b.
(Functions f fn, TypeList as, Typeable as, HasSpec fn a,
 HasSpec fn b, All (HasSpec fn) as) =>
f as b
-> ListCtx Value as (HOLE a)
-> Specification fn b
-> Specification fn a
propagateSpecFun fn '[a, b] b
f (Value a
v forall (f :: * -> *) a (as1 :: [*]) (c :: * -> *).
f a -> ListCtx f as1 c -> ListCtx f (a : as1) c
:! forall (c :: * -> *) a (f :: * -> *). c a -> ListCtx f '[a] c
NilCtx forall a. HOLE a a
HOLE) Specification fn b
spec
      | Value a
v :! NilCtx HOLE a a
HOLE <- ListCtx Value as (HOLE a)
ctx -> forall (f :: [*] -> * -> *) (fn :: [*] -> * -> *) (as :: [*]) a b.
(Functions f fn, TypeList as, Typeable as, HasSpec fn a,
 HasSpec fn b, All (HasSpec fn) as) =>
f as b
-> ListCtx Value as (HOLE a)
-> Specification fn b
-> Specification fn a
propagateSpecFun fn '[a, b] b
f (forall a. HOLE a a
HOLE forall (c :: * -> *) a (f :: * -> *) (as1 :: [*]).
c a -> List f as1 -> ListCtx f (a : as1) c
:? Value a
v forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> forall {k} (f :: k -> *). List f '[]
Nil) Specification fn b
spec

  -- NOTE: this function over-approximates and returns a liberal spec.
  mapTypeSpec :: forall a b.
(HasSpec fn a, HasSpec fn b) =>
FunFn fn '[a] b -> TypeSpec fn a -> Specification fn b
mapTypeSpec FunFn fn '[a] b
f TypeSpec fn a
ts = case FunFn fn '[a] b
f of
    FunFn fn '[a] b
Id -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec TypeSpec fn a
ts
    Compose fn '[b] b
g fn '[a] b
h -> forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, HasSpec fn b) =>
fn '[a] b -> Specification fn a -> Specification fn b
mapSpec fn '[b] b
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, HasSpec fn b) =>
fn '[a] b -> Specification fn a -> Specification fn b
mapSpec fn '[a] b
h forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec TypeSpec fn a
ts

  rewriteRules :: forall (as :: [*]) b.
(TypeList as, Typeable as, HasSpec fn b, All (HasSpec fn) as) =>
FunFn fn as b -> List (Term fn) as -> Maybe (Term fn b)
rewriteRules FunFn fn as b
Id (Term fn a
x :> List (Term fn) as1
Nil) = forall a. a -> Maybe a
Just Term fn a
x
  rewriteRules (Compose fn '[b] b
f fn '[a] b
g) (Term fn a
x :> List (Term fn) as1
Nil) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app fn '[b] b
f (forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app fn '[a] b
g Term fn a
x)
  -- TODO: this is a bit crippled by the fact that we forget any other rewrite
  -- rules that we had for `f`. That's something we'll have to think about.
  rewriteRules (Flip fn '[a, b] b
f) (a :: Term fn a
a@Lit {} :> Term fn a
b :> List (Term fn) as1
Nil) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app fn '[a, b] b
f Term fn a
b Term fn a
a
  rewriteRules (Flip fn '[a, b] b
f) (Term fn a
a :> b :: Term fn a
b@Lit {} :> List (Term fn) as1
Nil) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app fn '[a, b] b
f Term fn a
b Term fn a
a
  rewriteRules Flip {} List (Term fn) as
_ = forall a. Maybe a
Nothing

-- Ord functions ----------------------------------------------------------

lessOrEqualFn :: forall fn a. (Ord a, OrdLike fn a) => fn '[a, a] Bool
lessOrEqualFn :: forall (fn :: [*] -> * -> *) a.
(Ord a, OrdLike fn a) =>
fn '[a, a] Bool
lessOrEqualFn = forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fn as b -> fnU as b
injectFn (forall a (fn :: [*] -> * -> *).
(Ord a, OrdLike fn a) =>
OrdFn fn '[a, a] Bool
LessOrEqual @_ @fn)

lessFn :: forall fn a. (Ord a, OrdLike fn a) => fn '[a, a] Bool
lessFn :: forall (fn :: [*] -> * -> *) a.
(Ord a, OrdLike fn a) =>
fn '[a, a] Bool
lessFn = forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fn as b -> fnU as b
injectFn (forall a (fn :: [*] -> * -> *).
(Ord a, OrdLike fn a) =>
OrdFn fn '[a, a] Bool
Less @_ @fn)

data OrdFn (fn :: [Type] -> Type -> Type) as b where
  LessOrEqual :: (Ord a, OrdLike fn a) => OrdFn fn '[a, a] Bool
  Less :: (Ord a, OrdLike fn a) => OrdFn fn '[a, a] Bool

class HasSpec fn a => OrdLike fn a where
  leqSpec :: a -> Specification fn a
  default leqSpec ::
    ( TypeSpec fn a ~ TypeSpec fn (SimpleRep a)
    , HasSimpleRep a
    , OrdLike fn (SimpleRep a)
    ) =>
    a ->
    Specification fn a
  leqSpec = forall a (fn :: [*] -> * -> *).
(HasSpec fn a, HasSimpleRep a,
 TypeSpec fn a ~ TypeSpec fn (SimpleRep a)) =>
Specification fn (SimpleRep a) -> Specification fn a
fromSimpleRepSpec forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
leqSpec @fn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasSimpleRep a => a -> SimpleRep a
toSimpleRep

  ltSpec :: a -> Specification fn a
  default ltSpec ::
    ( TypeSpec fn a ~ TypeSpec fn (SimpleRep a)
    , HasSimpleRep a
    , OrdLike fn (SimpleRep a)
    ) =>
    a ->
    Specification fn a
  ltSpec = forall a (fn :: [*] -> * -> *).
(HasSpec fn a, HasSimpleRep a,
 TypeSpec fn a ~ TypeSpec fn (SimpleRep a)) =>
Specification fn (SimpleRep a) -> Specification fn a
fromSimpleRepSpec forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
ltSpec @fn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasSimpleRep a => a -> SimpleRep a
toSimpleRep

  geqSpec :: a -> Specification fn a
  default geqSpec ::
    ( TypeSpec fn a ~ TypeSpec fn (SimpleRep a)
    , HasSimpleRep a
    , OrdLike fn (SimpleRep a)
    ) =>
    a ->
    Specification fn a
  geqSpec = forall a (fn :: [*] -> * -> *).
(HasSpec fn a, HasSimpleRep a,
 TypeSpec fn a ~ TypeSpec fn (SimpleRep a)) =>
Specification fn (SimpleRep a) -> Specification fn a
fromSimpleRepSpec forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
geqSpec @fn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasSimpleRep a => a -> SimpleRep a
toSimpleRep

  gtSpec :: a -> Specification fn a
  default gtSpec ::
    ( TypeSpec fn a ~ TypeSpec fn (SimpleRep a)
    , HasSimpleRep a
    , OrdLike fn (SimpleRep a)
    ) =>
    a ->
    Specification fn a
  gtSpec = forall a (fn :: [*] -> * -> *).
(HasSpec fn a, HasSimpleRep a,
 TypeSpec fn a ~ TypeSpec fn (SimpleRep a)) =>
Specification fn (SimpleRep a) -> Specification fn a
fromSimpleRepSpec forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
gtSpec @fn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasSimpleRep a => a -> SimpleRep a
toSimpleRep

instance {-# OVERLAPPABLE #-} (HasSpec fn a, MaybeBounded a, Num a, TypeSpec fn a ~ NumSpec fn a) => OrdLike fn a where
  leqSpec :: a -> Specification fn a
leqSpec a
l = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) n. Maybe n -> Maybe n -> NumSpec fn n
NumSpecInterval forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just a
l)
  ltSpec :: a -> Specification fn a
ltSpec a
l
    | Just a
b <- forall a. MaybeBounded a => Maybe a
lowerBound
    , a
l forall a. Eq a => a -> a -> Bool
== a
b =
        forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
"ltSpec @" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a. Typeable a => a -> TypeRep
typeOf a
l) forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
l))
    | Bool
otherwise = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) n. Maybe n -> Maybe n -> NumSpec fn n
NumSpecInterval forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just (a
l forall a. Num a => a -> a -> a
- a
1))
  geqSpec :: a -> Specification fn a
geqSpec a
l = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) n. Maybe n -> Maybe n -> NumSpec fn n
NumSpecInterval (forall a. a -> Maybe a
Just a
l) forall a. Maybe a
Nothing
  gtSpec :: a -> Specification fn a
gtSpec a
l
    | Just a
b <- forall a. MaybeBounded a => Maybe a
upperBound
    , a
l forall a. Eq a => a -> a -> Bool
== a
b =
        forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
"gtSpec @" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a. Typeable a => a -> TypeRep
typeOf a
l) forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
l))
    | Bool
otherwise = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) n. Maybe n -> Maybe n -> NumSpec fn n
NumSpecInterval (forall a. a -> Maybe a
Just (a
l forall a. Num a => a -> a -> a
+ a
1)) forall a. Maybe a
Nothing

deriving instance Eq (OrdFn fn as b)
deriving instance Show (OrdFn fn as b)

instance FunctionLike (OrdFn fn) where
  sem :: forall (as :: [*]) b. OrdFn fn as b -> FunTy as b
sem OrdFn fn as b
LessOrEqual = forall a. Ord a => a -> a -> Bool
(<=)
  sem OrdFn fn as b
Less = forall a. Ord a => a -> a -> Bool
(<)

instance BaseUniverse fn => Functions (OrdFn fn) fn where
  propagateSpecFun :: forall (as :: [*]) a b.
(TypeList as, Typeable as, HasSpec fn a, HasSpec fn b,
 All (HasSpec fn) as) =>
OrdFn fn as b
-> ListCtx Value as (HOLE a)
-> Specification fn b
-> Specification fn a
propagateSpecFun OrdFn fn as b
fn ListCtx Value as (HOLE a)
ctx (ExplainSpec [[Char]]
es Specification fn b
s) = forall (fn :: [*] -> * -> *) a.
[[Char]] -> Specification fn a -> Specification fn a
explainSpecOpt [[Char]]
es forall a b. (a -> b) -> a -> b
$ forall (f :: [*] -> * -> *) (fn :: [*] -> * -> *) (as :: [*]) a b.
(Functions f fn, TypeList as, Typeable as, HasSpec fn a,
 HasSpec fn b, All (HasSpec fn) as) =>
f as b
-> ListCtx Value as (HOLE a)
-> Specification fn b
-> Specification fn a
propagateSpecFun OrdFn fn as b
fn ListCtx Value as (HOLE a)
ctx Specification fn b
s
  propagateSpecFun OrdFn fn as b
_ ListCtx Value as (HOLE a)
_ Specification fn b
TrueSpec = forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec
  propagateSpecFun OrdFn fn as b
_ ListCtx Value as (HOLE a)
_ (ErrorSpec NonEmpty [Char]
err) = forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec NonEmpty [Char]
err
  propagateSpecFun OrdFn fn as b
fn (ListCtx List Value as
pre HOLE a a
HOLE List Value as'
suf) (SuspendedSpec Var b
x Pred fn
p) =
    forall a (fn :: [*] -> * -> *) p.
(IsPred p fn, HasSpec fn a) =>
(Term fn a -> p) -> Specification fn a
constrained forall a b. (a -> b) -> a -> b
$ \Term fn a
x' ->
      let args :: List (Term fn) (Append as (a : as'))
args = forall {a} (f :: a -> *) (as :: [a]) (bs :: [a]).
List f as -> List f bs -> List f (Append as bs)
appendList (forall {k} (f :: k -> *) (g :: k -> *) (as :: [k]).
(forall (a :: k). f a -> g a) -> List f as -> List g as
mapList (\(Value a
a) -> forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit a
a) List Value as
pre) (Term fn a
x' forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> forall {k} (f :: k -> *) (g :: k -> *) (as :: [k]).
(forall (a :: k). f a -> g a) -> List f as -> List g as
mapList (\(Value a
a) -> forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit a
a) List Value as'
suf)
       in forall (fn :: [*] -> * -> *) a. Term fn a -> Binder fn a -> Pred fn
Let (forall (a :: [*]) (fn :: [*] -> * -> *) b.
(Typeable a, TypeList a, All (HasSpec fn) a, HasSpec fn b,
 BaseUniverse fn) =>
fn a b -> List (Term fn) a -> Term fn b
App (forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fn as b -> fnU as b
injectFn OrdFn fn as b
fn) List (Term fn) (Append as (a : as'))
args) (Var b
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Binder fn a
:-> Pred fn
p)
  propagateSpecFun OrdFn fn as b
LessOrEqual ListCtx Value as (HOLE a)
ctx Specification fn b
spec
    | HOLE a a
HOLE :? Value a
l :> List Value as1
Nil <- ListCtx Value as (HOLE a)
ctx = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn Bool
-> (Bool -> Specification fn a) -> Specification fn a
caseBoolSpec Specification fn b
spec forall a b. (a -> b) -> a -> b
$ \case
        Bool
True -> forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
leqSpec @fn a
l
        Bool
False -> forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
gtSpec @fn a
l
    | Value a
l :! NilCtx HOLE a a
HOLE <- ListCtx Value as (HOLE a)
ctx = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn Bool
-> (Bool -> Specification fn a) -> Specification fn a
caseBoolSpec Specification fn b
spec forall a b. (a -> b) -> a -> b
$ \case
        Bool
True -> forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
geqSpec @fn a
l
        Bool
False -> forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
ltSpec @fn a
l
  propagateSpecFun OrdFn fn as b
Less ListCtx Value as (HOLE a)
ctx Specification fn b
spec
    | HOLE a a
HOLE :? Value a
l :> List Value as1
Nil <- ListCtx Value as (HOLE a)
ctx = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn Bool
-> (Bool -> Specification fn a) -> Specification fn a
caseBoolSpec Specification fn b
spec forall a b. (a -> b) -> a -> b
$ \case
        Bool
True -> forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
ltSpec @fn a
l
        Bool
False -> forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
geqSpec @fn a
l
    | Value a
l :! NilCtx HOLE a a
HOLE <- ListCtx Value as (HOLE a)
ctx = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn Bool
-> (Bool -> Specification fn a) -> Specification fn a
caseBoolSpec Specification fn b
spec forall a b. (a -> b) -> a -> b
$ \case
        Bool
True -> forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
gtSpec @fn a
l
        Bool
False -> forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
leqSpec @fn a
l

  mapTypeSpec :: forall a b.
(HasSpec fn a, HasSpec fn b) =>
OrdFn fn '[a] b -> TypeSpec fn a -> Specification fn b
mapTypeSpec = forall a. HasCallStack => [Char] -> a
error [Char]
"No cases"

-- List functions ---------------------------------------------------------

data ListFn fn args res where
  FoldMap ::
    ( HasSpec fn a
    , Foldy fn b
    , Show (fn '[a] b)
    , Eq (fn '[a] b)
    ) =>
    fn '[a] b ->
    ListFn fn '[[a]] b
  SingletonList :: ListFn fn '[a] [a]
  AppendFn :: (Typeable a, Show a) => ListFn fn '[[a], [a]] [a]

deriving instance Show (ListFn fn args res)

instance Typeable fn => Eq (ListFn fn args res) where
  FoldMap fn '[a] res
f == :: ListFn fn args res -> ListFn fn args res -> Bool
== FoldMap fn '[a] res
g = forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast fn '[a] res
f forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just fn '[a] res
g
  ListFn fn args res
SingletonList == ListFn fn args res
SingletonList = Bool
True
  ListFn fn args res
SingletonList == ListFn fn args res
_ = Bool
False
  ListFn fn args res
_ == ListFn fn args res
SingletonList = Bool
False
  ListFn fn args res
AppendFn == ListFn fn args res
AppendFn = Bool
True

instance FunctionLike fn => FunctionLike (ListFn fn) where
  sem :: forall (as :: [*]) b. ListFn fn as b -> FunTy as b
sem = \case
    FoldMap fn '[a] b
f -> forall (fn :: [*] -> * -> *) a. Foldy fn a => [a] -> a
adds @fn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (fn :: [*] -> * -> *) (as :: [*]) b.
FunctionLike fn =>
fn as b -> FunTy as b
sem fn '[a] b
f)
    ListFn fn as b
SingletonList -> (forall a. a -> [a] -> [a]
: [])
    ListFn fn as b
AppendFn -> forall a. [a] -> [a] -> [a]
(++)

instance BaseUniverse fn => Functions (ListFn fn) fn where
  propagateSpecFun :: forall (as :: [*]) a b.
(TypeList as, Typeable as, HasSpec fn a, HasSpec fn b,
 All (HasSpec fn) as) =>
ListFn fn as b
-> ListCtx Value as (HOLE a)
-> Specification fn b
-> Specification fn a
propagateSpecFun ListFn fn as b
_ ListCtx Value as (HOLE a)
_ (ErrorSpec NonEmpty [Char]
err) = forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec NonEmpty [Char]
err
  propagateSpecFun ListFn fn as b
fn ListCtx Value as (HOLE a)
ctx (ExplainSpec [[Char]]
es Specification fn b
s) = forall (fn :: [*] -> * -> *) a.
[[Char]] -> Specification fn a -> Specification fn a
explainSpecOpt [[Char]]
es forall a b. (a -> b) -> a -> b
$ forall (f :: [*] -> * -> *) (fn :: [*] -> * -> *) (as :: [*]) a b.
(Functions f fn, TypeList as, Typeable as, HasSpec fn a,
 HasSpec fn b, All (HasSpec fn) as) =>
f as b
-> ListCtx Value as (HOLE a)
-> Specification fn b
-> Specification fn a
propagateSpecFun ListFn fn as b
fn ListCtx Value as (HOLE a)
ctx Specification fn b
s
  propagateSpecFun ListFn fn as b
fn ListCtx Value as (HOLE a)
ctx Specification fn b
spec = case ListFn fn as b
fn of
    ListFn fn as b
_
      | SuspendedSpec Var b
x Pred fn
p <- Specification fn b
spec
      , ListCtx List Value as
pre HOLE a a
HOLE List Value as'
suf <- ListCtx Value as (HOLE a)
ctx ->
          forall a (fn :: [*] -> * -> *) p.
(IsPred p fn, HasSpec fn a) =>
(Term fn a -> p) -> Specification fn a
constrained forall a b. (a -> b) -> a -> b
$ \Term fn a
v' ->
            let args :: List (Term fn) (Append as (a : as'))
args = forall {a} (f :: a -> *) (as :: [a]) (bs :: [a]).
List f as -> List f bs -> List f (Append as bs)
appendList (forall {k} (f :: k -> *) (g :: k -> *) (as :: [k]).
(forall (a :: k). f a -> g a) -> List f as -> List g as
mapList (\(Value a
a) -> forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit a
a) List Value as
pre) (Term fn a
v' forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> forall {k} (f :: k -> *) (g :: k -> *) (as :: [k]).
(forall (a :: k). f a -> g a) -> List f as -> List g as
mapList (\(Value a
a) -> forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit a
a) List Value as'
suf)
             in forall (fn :: [*] -> * -> *) a. Term fn a -> Binder fn a -> Pred fn
Let (forall (a :: [*]) (fn :: [*] -> * -> *) b.
(Typeable a, TypeList a, All (HasSpec fn) a, HasSpec fn b,
 BaseUniverse fn) =>
fn a b -> List (Term fn) a -> Term fn b
App (forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fn as b -> fnU as b
injectFn ListFn fn as b
fn) List (Term fn) (Append as (a : as'))
args) (Var b
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Binder fn a
:-> Pred fn
p)
    FoldMap fn '[a] b
f | NilCtx HOLE a [a]
HOLE <- ListCtx Value as (HOLE a)
ctx -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec (forall (fn :: [*] -> * -> *) a.
Maybe Integer
-> [a]
-> Specification fn Integer
-> Specification fn a
-> FoldSpec fn a
-> ListSpec fn a
ListSpec forall a. Maybe a
Nothing [] forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec forall a b. (a -> b) -> a -> b
$ forall a (fn :: [*] -> * -> *) a.
(HasSpec fn a, HasSpec fn a, Foldy fn a, Member (ListFn fn) fn,
 BaseUniverse fn) =>
fn '[a] a -> Specification fn a -> FoldSpec fn a
FoldSpec fn '[a] b
f Specification fn b
spec)
    ListFn fn as b
SingletonList | NilCtx HOLE a a
HOLE <- ListCtx Value as (HOLE a)
ctx -> case Specification fn b
spec of
      Specification fn b
TrueSpec -> forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec
      MemberSpec NonEmpty b
xss ->
        forall a (fn :: [*] -> * -> *).
[a] -> NonEmpty [Char] -> Specification fn a
memberSpecList
          [a
a | [a
a] <- forall a. NonEmpty a -> [a]
NE.toList NonEmpty b
xss]
          (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"PropagateSpec SingletonList with MemberSpec which has no lists of length 1")
      TypeSpec (ListSpec Maybe Integer
_ [a]
m Specification fn Integer
sz Specification fn a
e FoldSpec fn a
f) OrdSet b
cant
        | forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
m forall a. Ord a => a -> a -> Bool
> Int
1 ->
            forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec forall a b. (a -> b) -> a -> b
$
              forall a. [a] -> NonEmpty a
NE.fromList
                [ [Char]
"Too many required elements for SingletonList: "
                , [Char]
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [a]
m
                ]
        | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Integer
1 forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
`conformsToSpec` Specification fn Integer
sz ->
            forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Char]
"Size spec requires too many elements for SingletonList: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn Integer
sz
        | bad :: [a]
bad@(a
_ : [a]
_) <- forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
`conformsToSpec` Specification fn a
e)) [a]
m ->
            forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec forall a b. (a -> b) -> a -> b
$
              forall a. [a] -> NonEmpty a
NE.fromList
                [ [Char]
"The following elements of the must spec do not conforms to the elem spec:"
                , forall a. Show a => a -> [Char]
show [a]
bad
                ]
        -- There is precisely one required element in the final list, so the argument to singletonList_ has to
        -- be that element and we have to respect the cant and fold specs
        | [a
a] <- [a]
m -> forall a (fn :: [*] -> * -> *). a -> Specification fn a
equalSpec a
a forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a (f :: * -> *).
(HasSpec fn a, Foldable f) =>
f a -> Specification fn a
notMemberSpec [a
a | [a
a] <- OrdSet b
cant] forall a. Semigroup a => a -> a -> a
<> forall {fn :: [*] -> * -> *} {a}.
FoldSpec fn a -> Specification fn a
reverseFoldSpec FoldSpec fn a
f
        -- We have to respect the elem-spec, the can't spec, and the fold spec.
        | Bool
otherwise -> Specification fn a
e forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a (f :: * -> *).
(HasSpec fn a, Foldable f) =>
f a -> Specification fn a
notMemberSpec [a
a | [a
a] <- OrdSet b
cant] forall a. Semigroup a => a -> a -> a
<> forall {fn :: [*] -> * -> *} {a}.
FoldSpec fn a -> Specification fn a
reverseFoldSpec FoldSpec fn a
f
        where
          reverseFoldSpec :: FoldSpec fn a -> Specification fn a
reverseFoldSpec FoldSpec fn a
NoFold = forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec
          -- The single element list has to sum to something that obeys spec, i.e. `conformsToSpec (f a) spec`
          reverseFoldSpec (FoldSpec fn '[a] b
fn Specification fn b
spec) = forall (f :: [*] -> * -> *) (fn :: [*] -> * -> *) (as :: [*]) a b.
(Functions f fn, TypeList as, Typeable as, HasSpec fn a,
 HasSpec fn b, All (HasSpec fn) as) =>
f as b
-> ListCtx Value as (HOLE a)
-> Specification fn b
-> Specification fn a
propagateSpecFun fn '[a] b
fn (forall (c :: * -> *) a (f :: * -> *). c a -> ListCtx f '[a] c
NilCtx forall a. HOLE a a
HOLE) Specification fn b
spec
    ListFn fn as b
AppendFn -> case Specification fn b
spec of
      Specification fn b
TrueSpec -> forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec
      MemberSpec NonEmpty b
xss
        | HOLE a a
HOLE :? Value ([a]
ys :: [a]) :> List Value as1
Nil <- ListCtx Value as (HOLE a)
ctx
        , Evidence (Prerequisites fn [a])
Evidence <- forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Evidence (Prerequisites fn a)
prerequisites @fn @[a] ->
            -- Only keep the prefixes of the elements of xss that can
            -- give you the correct resulting list
            forall a (fn :: [*] -> * -> *).
[a] -> NonEmpty [Char] -> Specification fn a
memberSpecList
              (forall {a}. Eq a => [a] -> [[a]] -> [[a]]
suffixedBy [a]
ys (forall a. NonEmpty a -> [a]
NE.toList NonEmpty b
xss))
              ( forall a. [a] -> NonEmpty a
NE.fromList
                  [ [Char]
"propagateSpecFun (append HOLE ys) with (MemberSpec xss)"
                  , [Char]
"there are no elements in xss with suffix ys"
                  ]
              )
        | Value ([a]
ys :: [a]) :! NilCtx HOLE a [a]
HOLE <- ListCtx Value as (HOLE a)
ctx
        , Evidence (Prerequisites fn [a])
Evidence <- forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Evidence (Prerequisites fn a)
prerequisites @fn @[a] ->
            -- Only keep the suffixes of the elements of xss that can
            -- give you the correct resulting list
            forall a (fn :: [*] -> * -> *).
[a] -> NonEmpty [Char] -> Specification fn a
memberSpecList
              (forall {a}. Eq a => [a] -> [[a]] -> [[a]]
prefixedBy [a]
ys (forall a. NonEmpty a -> [a]
NE.toList NonEmpty b
xss))
              ( forall a. [a] -> NonEmpty a
NE.fromList
                  [ [Char]
"propagateSpecFun (append ys HOLE) with (MemberSpec xss)"
                  , [Char]
"there are no elements in xss with prefix ys"
                  ]
              )
      TypeSpec ts :: TypeSpec fn b
ts@ListSpec {listSpecElem :: forall (fn :: [*] -> * -> *) a. ListSpec fn a -> Specification fn a
listSpecElem = Specification fn a
e} OrdSet b
cant
        | HOLE a a
HOLE :? Value ([a]
ys :: [a]) :> List Value as1
Nil <- ListCtx Value as (HOLE a)
ctx
        , Evidence (Prerequisites fn [a])
Evidence <- forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Evidence (Prerequisites fn a)
prerequisites @fn @[a]
        , forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
`conformsToSpec` Specification fn a
e) [a]
ys ->
            forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> OrdSet a -> Specification fn a
TypeSpec (forall {a} {fn :: [*] -> * -> *}.
(Eq a, Functions fn fn,
 IsMember (EqFn fn) fn (FromJust (MPath (EqFn fn) fn)),
 IsMember (SetFn fn) fn (FromJust (MPath (SetFn fn) fn)),
 IsMember (BoolFn fn) fn (FromJust (MPath (BoolFn fn) fn)),
 IsMember (PairFn fn) fn (FromJust (MPath (PairFn fn) fn)),
 IsMember (IntFn fn) fn (FromJust (MPath (IntFn fn) fn)),
 IsMember (OrdFn fn) fn (FromJust (MPath (OrdFn fn) fn)),
 IsMember (GenericsFn fn) fn (FromJust (MPath (GenericsFn fn) fn)),
 IsMember (ListFn fn) fn (FromJust (MPath (ListFn fn) fn)),
 IsMember (SumFn fn) fn (FromJust (MPath (SumFn fn) fn)),
 IsMember (MapFn fn) fn (FromJust (MPath (MapFn fn) fn)),
 IsMember (FunFn fn) fn (FromJust (MPath (FunFn fn) fn)),
 IsMember (SizeFn fn) fn (FromJust (MPath (SizeFn fn) fn)),
 Show a) =>
[a] -> ListSpec fn a -> ListSpec fn a
alreadyHave [a]
ys TypeSpec fn b
ts) (forall {a}. Eq a => [a] -> [[a]] -> [[a]]
suffixedBy [a]
ys OrdSet b
cant)
        | Value ([a]
ys :: [a]) :! NilCtx HOLE a [a]
HOLE <- ListCtx Value as (HOLE a)
ctx
        , Evidence (Prerequisites fn [a])
Evidence <- forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Evidence (Prerequisites fn a)
prerequisites @fn @[a]
        , forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
`conformsToSpec` Specification fn a
e) [a]
ys ->
            forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> OrdSet a -> Specification fn a
TypeSpec (forall {a} {fn :: [*] -> * -> *}.
(Eq a, Functions fn fn,
 IsMember (EqFn fn) fn (FromJust (MPath (EqFn fn) fn)),
 IsMember (SetFn fn) fn (FromJust (MPath (SetFn fn) fn)),
 IsMember (BoolFn fn) fn (FromJust (MPath (BoolFn fn) fn)),
 IsMember (PairFn fn) fn (FromJust (MPath (PairFn fn) fn)),
 IsMember (IntFn fn) fn (FromJust (MPath (IntFn fn) fn)),
 IsMember (OrdFn fn) fn (FromJust (MPath (OrdFn fn) fn)),
 IsMember (GenericsFn fn) fn (FromJust (MPath (GenericsFn fn) fn)),
 IsMember (ListFn fn) fn (FromJust (MPath (ListFn fn) fn)),
 IsMember (SumFn fn) fn (FromJust (MPath (SumFn fn) fn)),
 IsMember (MapFn fn) fn (FromJust (MPath (MapFn fn) fn)),
 IsMember (FunFn fn) fn (FromJust (MPath (FunFn fn) fn)),
 IsMember (SizeFn fn) fn (FromJust (MPath (SizeFn fn) fn)),
 Show a) =>
[a] -> ListSpec fn a -> ListSpec fn a
alreadyHave [a]
ys TypeSpec fn b
ts) (forall {a}. Eq a => [a] -> [[a]] -> [[a]]
prefixedBy [a]
ys OrdSet b
cant)
      Specification fn b
_ -> forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"The spec given to propagateSpecFun AppendSpec is inconsistent!"
      where
        prefixedBy :: [a] -> [[a]] -> [[a]]
prefixedBy [a]
ys [[a]]
xss = [forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ys) [a]
xs | [a]
xs <- [[a]]
xss, [a]
ys forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [a]
xs]
        suffixedBy :: [a] -> [[a]] -> [[a]]
suffixedBy [a]
ys [[a]]
xss = [forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ys) [a]
xs | [a]
xs <- [[a]]
xss, [a]
ys forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [a]
xs]

        alreadyHave :: [a] -> ListSpec fn a -> ListSpec fn a
alreadyHave [a]
ys (ListSpec Maybe Integer
h [a]
m Specification fn Integer
sz Specification fn a
e FoldSpec fn a
f) =
          forall (fn :: [*] -> * -> *) a.
Maybe Integer
-> [a]
-> Specification fn Integer
-> Specification fn a
-> FoldSpec fn a
-> ListSpec fn a
ListSpec
            -- Reduce the hint
            (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Num a => a -> a -> a
subtract (forall (fn :: [*] -> * -> *) t. Sized fn t => t -> Integer
sizeOf [a]
ys)) Maybe Integer
h)
            -- The things in `ys` have already been added to the list, no need to
            -- require them too
            ([a]
m forall a. Eq a => [a] -> [a] -> [a]
\\ [a]
ys)
            -- Reduce the required size
            (forall a (fn :: [*] -> * -> *) p.
(IsPred p fn, HasSpec fn a) =>
(Term fn a -> p) -> Specification fn a
constrained forall a b. (a -> b) -> a -> b
$ \Term fn Integer
x -> (Term fn Integer
x forall a. Num a => a -> a -> a
+ forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
lit (forall (fn :: [*] -> * -> *) t. Sized fn t => t -> Integer
sizeOf [a]
ys)) forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Specification fn a -> Pred fn
`satisfies` Specification fn Integer
sz)
            -- Nothing changes about what's a correct element
            Specification fn a
e
            -- we have fewer things to sum now
            (forall {a} {fn :: [*] -> * -> *}.
Show [a] =>
[a] -> FoldSpec fn a -> FoldSpec fn a
alreadyHaveFold [a]
ys FoldSpec fn a
f)

        alreadyHaveFold :: [a] -> FoldSpec fn a -> FoldSpec fn a
alreadyHaveFold [a]
_ FoldSpec fn a
NoFold = forall (fn :: [*] -> * -> *) a. FoldSpec fn a
NoFold
        alreadyHaveFold [a]
ys (FoldSpec fn '[a] b
fn Specification fn b
spec) = forall a (fn :: [*] -> * -> *) a.
(HasSpec fn a, HasSpec fn a, Foldy fn a, Member (ListFn fn) fn,
 BaseUniverse fn) =>
fn '[a] a -> Specification fn a -> FoldSpec fn a
FoldSpec fn '[a] b
fn (forall a (fn :: [*] -> * -> *) p.
(IsPred p fn, HasSpec fn a) =>
(Term fn a -> p) -> Specification fn a
constrained forall a b. (a -> b) -> a -> b
$ \Term fn b
s -> forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app forall (fn :: [*] -> * -> *) a. Foldy fn a => fn '[a, a] a
theAddFn Term fn b
s (forall (fn :: [*] -> * -> *) a b.
(BaseUniverse fn, Foldy fn b, HasSpec fn a) =>
(Term fn a -> Term fn b) -> Term fn [a] -> Term fn b
foldMap_ (forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app fn '[a] b
fn) (forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
lit [a]
ys)) forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Specification fn a -> Pred fn
`satisfies` Specification fn b
spec)

  -- NOTE: this function over-approximates and returns a liberal spec.
  mapTypeSpec :: forall a b.
(HasSpec fn a, HasSpec fn b) =>
ListFn fn '[a] b -> TypeSpec fn a -> Specification fn b
mapTypeSpec ListFn fn '[a] b
f TypeSpec fn a
ts = case ListFn fn '[a] b
f of
    FoldMap fn '[a] b
g ->
      forall a (fn :: [*] -> * -> *) p.
(IsPred p fn, HasSpec fn a) =>
(Term fn a -> p) -> Specification fn a
constrained forall a b. (a -> b) -> a -> b
$ \Term fn b
x ->
        forall a p (fn :: [*] -> * -> *).
(HasSpec fn a, IsPred p fn) =>
(Term fn a -> p) -> Pred fn
unsafeExists forall a b. (a -> b) -> a -> b
$ \Term fn [a]
x' ->
          forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
p -> Pred fn
assert (Term fn b
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Term fn a -> Term fn Bool
==. forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app (forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, Foldy fn b, Show (fn '[a] b), Eq (fn '[a] b)) =>
fn '[a] b -> fn '[[a]] b
foldMapFn fn '[a] b
g) Term fn [a]
x') forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> TypeSpec fn a -> Pred fn
toPreds Term fn [a]
x' TypeSpec fn a
ts
    ListFn fn '[a] b
SingletonList -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec (forall (fn :: [*] -> * -> *) a.
Maybe Integer
-> [a]
-> Specification fn Integer
-> Specification fn a
-> FoldSpec fn a
-> ListSpec fn a
ListSpec forall a. Maybe a
Nothing [] (forall a (fn :: [*] -> * -> *). a -> Specification fn a
equalSpec Integer
1) (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec TypeSpec fn a
ts) forall (fn :: [*] -> * -> *) a. FoldSpec fn a
NoFold)

foldMapFn ::
  forall fn a b.
  ( HasSpec fn a
  , Foldy fn b
  , Show (fn '[a] b)
  , Eq (fn '[a] b)
  ) =>
  fn '[a] b ->
  fn '[[a]] b
foldMapFn :: forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, Foldy fn b, Show (fn '[a] b), Eq (fn '[a] b)) =>
fn '[a] b -> fn '[[a]] b
foldMapFn fn '[a] b
f = forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fn as b -> fnU as b
injectFn forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, Foldy fn b, Show (fn '[a] b), Eq (fn '[a] b)) =>
fn '[a] b -> ListFn fn '[[a]] b
FoldMap @fn fn '[a] b
f

singletonListFn :: forall fn a. HasSpec fn a => fn '[a] [a]
singletonListFn :: forall (fn :: [*] -> * -> *) a. HasSpec fn a => fn '[a] [a]
singletonListFn = forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fn as b -> fnU as b
injectFn forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a. ListFn fn '[a] [a]
SingletonList @fn

appendFn :: forall fn a. (HasSpec fn a, Show a, Typeable a) => fn '[[a], [a]] [a]
appendFn :: forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, Show a, Typeable a) =>
fn '[[a], [a]] [a]
appendFn = forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fn as b -> fnU as b
injectFn forall a b. (a -> b) -> a -> b
$ forall a (fn :: [*] -> * -> *).
(Typeable a, Show a) =>
ListFn fn '[[a], [a]] [a]
AppendFn @a @fn

-- Number functions -------------------------------------------------------

addFn :: forall fn a. NumLike fn a => fn '[a, a] a
addFn :: forall (fn :: [*] -> * -> *) a. NumLike fn a => fn '[a, a] a
addFn = forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fn as b -> fnU as b
injectFn (forall (fn :: [*] -> * -> *) a. NumLike fn a => IntFn fn '[a, a] a
Add @fn)

negateFn :: forall fn a. NumLike fn a => fn '[a] a
negateFn :: forall (fn :: [*] -> * -> *) a. NumLike fn a => fn '[a] a
negateFn = forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fn as b -> fnU as b
injectFn (forall (fn :: [*] -> * -> *) a. NumLike fn a => IntFn fn '[a] a
Negate @fn)

data IntFn (fn :: [Type] -> Type -> Type) as b where
  Add :: NumLike fn a => IntFn fn '[a, a] a
  Negate :: NumLike fn a => IntFn fn '[a] a

deriving instance Eq (IntFn fn as b)
deriving instance Show (IntFn fn as b)

instance FunctionLike (IntFn fn) where
  sem :: forall (as :: [*]) b. IntFn fn as b -> FunTy as b
sem IntFn fn as b
Add = forall a. Num a => a -> a -> a
(+)
  sem IntFn fn as b
Negate = forall a. Num a => a -> a
negate

class (Num a, HasSpec fn a) => NumLike fn a where
  subtractSpec :: a -> TypeSpec fn a -> Specification fn a
  default subtractSpec ::
    ( TypeSpec fn a ~ TypeSpec fn (SimpleRep a)
    , HasSimpleRep a
    , NumLike fn (SimpleRep a)
    ) =>
    a ->
    TypeSpec fn a ->
    Specification fn a
  subtractSpec a
a TypeSpec fn a
ts = forall a (fn :: [*] -> * -> *).
(HasSpec fn a, HasSimpleRep a,
 TypeSpec fn a ~ TypeSpec fn (SimpleRep a)) =>
Specification fn (SimpleRep a) -> Specification fn a
fromSimpleRepSpec forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
NumLike fn a =>
a -> TypeSpec fn a -> Specification fn a
subtractSpec @fn (forall a. HasSimpleRep a => a -> SimpleRep a
toSimpleRep a
a) TypeSpec fn a
ts

  negateSpec :: TypeSpec fn a -> Specification fn a
  default negateSpec ::
    ( TypeSpec fn a ~ TypeSpec fn (SimpleRep a)
    , HasSimpleRep a
    , NumLike fn (SimpleRep a)
    ) =>
    TypeSpec fn a ->
    Specification fn a
  negateSpec = forall a (fn :: [*] -> * -> *).
(HasSpec fn a, HasSimpleRep a,
 TypeSpec fn a ~ TypeSpec fn (SimpleRep a)) =>
Specification fn (SimpleRep a) -> Specification fn a
fromSimpleRepSpec forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fn :: [*] -> * -> *) a.
NumLike fn a =>
TypeSpec fn a -> Specification fn a
negateSpec @fn @(SimpleRep a)

  safeSubtract :: a -> a -> Maybe a
  default safeSubtract ::
    (HasSimpleRep a, NumLike fn (SimpleRep a)) =>
    a ->
    a ->
    Maybe a
  safeSubtract a
a a
b = forall a. HasSimpleRep a => SimpleRep a -> a
fromSimpleRep forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (fn :: [*] -> * -> *) a. NumLike fn a => a -> a -> Maybe a
safeSubtract @fn @(SimpleRep a) (forall a. HasSimpleRep a => a -> SimpleRep a
toSimpleRep a
a) (forall a. HasSimpleRep a => a -> SimpleRep a
toSimpleRep a
b)

instance NumLike fn a => Num (Term fn a) where
  + :: Term fn a -> Term fn a -> Term fn a
(+) = forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app forall (fn :: [*] -> * -> *) a. NumLike fn a => fn '[a, a] a
addFn
  negate :: Term fn a -> Term fn a
negate = forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app forall (fn :: [*] -> * -> *) a. NumLike fn a => fn '[a] a
negateFn
  fromInteger :: Integer -> Term fn a
fromInteger = forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Integer -> a
fromInteger
  * :: Term fn a -> Term fn a -> Term fn a
(*) = forall a. HasCallStack => [Char] -> a
error [Char]
"(*) not implemented for Term Fn Int"
  abs :: Term fn a -> Term fn a
abs = forall a. HasCallStack => [Char] -> a
error [Char]
"abs not implemented for Term Fn Int"
  signum :: Term fn a -> Term fn a
signum = forall a. HasCallStack => [Char] -> a
error [Char]
"signum not implemented for Term Fn Int"

instance {-# OVERLAPPABLE #-} (HasSpec fn a, Ord a, Num a, TypeSpec fn a ~ NumSpec fn a, MaybeBounded a) => NumLike fn a where
  subtractSpec :: a -> TypeSpec fn a -> Specification fn a
subtractSpec a
a ts :: TypeSpec fn a
ts@(NumSpecInterval Maybe a
ml Maybe a
mu)
    | Just a
u <- Maybe a
mu
    , a
a forall a. Ord a => a -> a -> Bool
> a
0
    , Maybe a
Nothing <- forall (fn :: [*] -> * -> *) a. NumLike fn a => a -> a -> Maybe a
safeSubtract @fn a
a a
u =
        forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec forall a b. (a -> b) -> a -> b
$
          forall a. [a] -> NonEmpty a
NE.fromList
            [ [Char]
"Underflow in subtractSpec (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a. Typeable a => a -> TypeRep
typeOf a
a) forall a. [a] -> [a] -> [a]
++ [Char]
"):"
            , [Char]
"  a = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
a
            , [Char]
"  ts = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show TypeSpec fn a
ts
            ]
    | Just a
l <- Maybe a
ml
    , a
a forall a. Ord a => a -> a -> Bool
< a
0
    , Maybe a
Nothing <- forall (fn :: [*] -> * -> *) a. NumLike fn a => a -> a -> Maybe a
safeSubtract @fn a
a a
l =
        forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec forall a b. (a -> b) -> a -> b
$
          forall a. [a] -> NonEmpty a
NE.fromList
            [ [Char]
"Overflow in subtractSpec (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a. Typeable a => a -> TypeRep
typeOf a
a) forall a. [a] -> [a] -> [a]
++ [Char]
"):"
            , [Char]
"  a = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
a
            , [Char]
"  ts = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show TypeSpec fn a
ts
            ]
    | Bool
otherwise = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) n. Maybe n -> Maybe n -> NumSpec fn n
NumSpecInterval (a -> a -> a
safeSub a
a forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
ml) (a -> a -> a
safeSub a
a forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
mu)
    where
      safeSub :: a -> a -> a
      safeSub :: a -> a -> a
safeSub a
a a
x
        | Just a
r <- forall (fn :: [*] -> * -> *) a. NumLike fn a => a -> a -> Maybe a
safeSubtract @fn a
a a
x = a
r
        | a
a forall a. Ord a => a -> a -> Bool
< a
0 = forall a. HasCallStack => Maybe a -> a
fromJust forall a. MaybeBounded a => Maybe a
upperBound
        | Bool
otherwise = forall a. HasCallStack => Maybe a -> a
fromJust forall a. MaybeBounded a => Maybe a
lowerBound
  negateSpec :: TypeSpec fn a -> Specification fn a
negateSpec (NumSpecInterval Maybe a
ml Maybe a
mu) = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) n. Maybe n -> Maybe n -> NumSpec fn n
NumSpecInterval (forall a. Num a => a -> a
negate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
mu) (forall a. Num a => a -> a
negate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
ml)

  safeSubtract :: a -> a -> Maybe a
safeSubtract a
a a
x
    | a
a forall a. Ord a => a -> a -> Bool
> a
0
    , Just a
lb <- forall a. MaybeBounded a => Maybe a
lowerBound
    , a
lb forall a. Num a => a -> a -> a
+ a
a forall a. Ord a => a -> a -> Bool
> a
x =
        forall a. Maybe a
Nothing
    | a
a forall a. Ord a => a -> a -> Bool
< a
0
    , Just a
ub <- forall a. MaybeBounded a => Maybe a
upperBound
    , a
ub forall a. Num a => a -> a -> a
+ a
a forall a. Ord a => a -> a -> Bool
< a
x =
        forall a. Maybe a
Nothing
    | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ a
x forall a. Num a => a -> a -> a
- a
a

instance BaseUniverse fn => Functions (IntFn fn) fn where
  propagateSpecFun :: forall (as :: [*]) a b.
(TypeList as, Typeable as, HasSpec fn a, HasSpec fn b,
 All (HasSpec fn) as) =>
IntFn fn as b
-> ListCtx Value as (HOLE a)
-> Specification fn b
-> Specification fn a
propagateSpecFun IntFn fn as b
_ ListCtx Value as (HOLE a)
_ Specification fn b
TrueSpec = forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec
  propagateSpecFun IntFn fn as b
fn ListCtx Value as (HOLE a)
ctx (ExplainSpec [[Char]]
es Specification fn b
s) = forall (fn :: [*] -> * -> *) a.
[[Char]] -> Specification fn a -> Specification fn a
explainSpecOpt [[Char]]
es forall a b. (a -> b) -> a -> b
$ forall (f :: [*] -> * -> *) (fn :: [*] -> * -> *) (as :: [*]) a b.
(Functions f fn, TypeList as, Typeable as, HasSpec fn a,
 HasSpec fn b, All (HasSpec fn) as) =>
f as b
-> ListCtx Value as (HOLE a)
-> Specification fn b
-> Specification fn a
propagateSpecFun IntFn fn as b
fn ListCtx Value as (HOLE a)
ctx Specification fn b
s
  propagateSpecFun IntFn fn as b
_ ListCtx Value as (HOLE a)
_ (ErrorSpec NonEmpty [Char]
err) = forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec NonEmpty [Char]
err
  propagateSpecFun IntFn fn as b
fn (ListCtx List Value as
pre HOLE a a
HOLE List Value as'
suf) (SuspendedSpec Var b
x Pred fn
p) =
    forall a (fn :: [*] -> * -> *) p.
(IsPred p fn, HasSpec fn a) =>
(Term fn a -> p) -> Specification fn a
constrained forall a b. (a -> b) -> a -> b
$ \Term fn a
x' ->
      let args :: List (Term fn) (Append as (a : as'))
args = forall {a} (f :: a -> *) (as :: [a]) (bs :: [a]).
List f as -> List f bs -> List f (Append as bs)
appendList (forall {k} (f :: k -> *) (g :: k -> *) (as :: [k]).
(forall (a :: k). f a -> g a) -> List f as -> List g as
mapList (\(Value a
a) -> forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit a
a) List Value as
pre) (Term fn a
x' forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> forall {k} (f :: k -> *) (g :: k -> *) (as :: [k]).
(forall (a :: k). f a -> g a) -> List f as -> List g as
mapList (\(Value a
a) -> forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit a
a) List Value as'
suf)
       in forall (fn :: [*] -> * -> *) a. Term fn a -> Binder fn a -> Pred fn
Let (forall (a :: [*]) (fn :: [*] -> * -> *) b.
(Typeable a, TypeList a, All (HasSpec fn) a, HasSpec fn b,
 BaseUniverse fn) =>
fn a b -> List (Term fn) a -> Term fn b
App (forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fn as b -> fnU as b
injectFn IntFn fn as b
fn) List (Term fn) (Append as (a : as'))
args) (Var b
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Binder fn a
:-> Pred fn
p)
  propagateSpecFun IntFn fn as b
Add ListCtx Value as (HOLE a)
ctx Specification fn b
spec
    | Value a
i :! NilCtx HOLE a b
HOLE <- ListCtx Value as (HOLE a)
ctx = forall (f :: [*] -> * -> *) (fn :: [*] -> * -> *) (as :: [*]) a b.
(Functions f fn, TypeList as, Typeable as, HasSpec fn a,
 HasSpec fn b, All (HasSpec fn) as) =>
f as b
-> ListCtx Value as (HOLE a)
-> Specification fn b
-> Specification fn a
propagateSpecFun @(IntFn fn) @fn forall (fn :: [*] -> * -> *) a. NumLike fn a => IntFn fn '[a, a] a
Add (forall a. HOLE a a
HOLE forall (c :: * -> *) a (f :: * -> *) (as1 :: [*]).
c a -> List f as1 -> ListCtx f (a : as1) c
:? forall a. Show a => a -> Value a
Value a
i forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> forall {k} (f :: k -> *). List f '[]
Nil) Specification fn b
spec
    | HOLE a a
HOLE :? Value a
i :> List Value as1
Nil <- ListCtx Value as (HOLE a)
ctx =
        case Specification fn b
spec of
          TypeSpec TypeSpec fn b
ts OrdSet b
cant ->
            forall (fn :: [*] -> * -> *) a.
NumLike fn a =>
a -> TypeSpec fn a -> Specification fn a
subtractSpec @fn a
i TypeSpec fn b
ts forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a (f :: * -> *).
(HasSpec fn a, Foldable f) =>
f a -> Specification fn a
notMemberSpec (forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (fn :: [*] -> * -> *) a. NumLike fn a => a -> a -> Maybe a
safeSubtract @fn a
i) OrdSet b
cant)
          MemberSpec NonEmpty b
es ->
            forall a (fn :: [*] -> * -> *).
[a] -> NonEmpty [Char] -> Specification fn a
memberSpecList
              (forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall (fn :: [*] -> * -> *) a. NumLike fn a => a -> a -> Maybe a
safeSubtract @fn a
i) (forall a. NonEmpty a -> [a]
NE.toList NonEmpty b
es))
              ( forall a. [a] -> NonEmpty a
NE.fromList
                  [ [Char]
"propagateSpecFn on (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
i forall a. [a] -> [a] -> [a]
++ [Char]
" +. HOLE)"
                  , [Char]
"The Spec is a MemberSpec = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn b
spec
                  , [Char]
"We can't safely subtract " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
i forall a. [a] -> [a] -> [a]
++ [Char]
" from any choice in the MemberSpec."
                  ]
              )
  propagateSpecFun IntFn fn as b
Negate (NilCtx HOLE a b
HOLE) Specification fn b
spec = case Specification fn b
spec of
    TypeSpec TypeSpec fn b
ts (OrdSet b
cant :: OrdSet a) ->
      forall (fn :: [*] -> * -> *) a.
NumLike fn a =>
TypeSpec fn a -> Specification fn a
negateSpec @fn @a TypeSpec fn b
ts forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a (f :: * -> *).
(HasSpec fn a, Foldable f) =>
f a -> Specification fn a
notMemberSpec (forall a b. (a -> b) -> [a] -> [b]
map forall a. Num a => a -> a
negate OrdSet b
cant)
    MemberSpec NonEmpty b
es -> forall a (fn :: [*] -> * -> *). NonEmpty a -> Specification fn a
MemberSpec forall a b. (a -> b) -> a -> b
$ forall a. Eq a => NonEmpty a -> NonEmpty a
NE.nub forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Num a => a -> a
negate NonEmpty b
es

  mapTypeSpec :: forall a b.
(HasSpec fn a, HasSpec fn b) =>
IntFn fn '[a] b -> TypeSpec fn a -> Specification fn b
mapTypeSpec IntFn fn '[a] b
Negate (TypeSpec fn b
ts :: TypeSpec fn a) =
    forall (fn :: [*] -> * -> *) a.
NumLike fn a =>
TypeSpec fn a -> Specification fn a
negateSpec @fn @a TypeSpec fn b
ts

------------------------------------------------------------------------
-- Syntax
------------------------------------------------------------------------

-- Functions on terms -----------------------------------------------------

toGeneric_ ::
  forall a fn.
  ( HasSpec fn a
  , HasSpec fn (SimpleRep a)
  , HasSimpleRep a
  , TypeSpec fn a ~ TypeSpec fn (SimpleRep a)
  ) =>
  Term fn a ->
  Term fn (SimpleRep a)
toGeneric_ :: forall a (fn :: [*] -> * -> *).
(HasSpec fn a, HasSpec fn (SimpleRep a), HasSimpleRep a,
 TypeSpec fn a ~ TypeSpec fn (SimpleRep a)) =>
Term fn a -> Term fn (SimpleRep a)
toGeneric_ = forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app forall (fn :: [*] -> * -> *) a.
(HasSpec fn (SimpleRep a),
 TypeSpec fn a ~ TypeSpec fn (SimpleRep a), HasSimpleRep a) =>
fn '[a] (SimpleRep a)
toGenericFn

fromGeneric_ ::
  forall a fn.
  ( HasSpec fn a
  , HasSpec fn (SimpleRep a)
  , HasSimpleRep a
  , TypeSpec fn a ~ TypeSpec fn (SimpleRep a)
  ) =>
  Term fn (SimpleRep a) ->
  Term fn a
fromGeneric_ :: forall a (fn :: [*] -> * -> *).
(HasSpec fn a, HasSpec fn (SimpleRep a), HasSimpleRep a,
 TypeSpec fn a ~ TypeSpec fn (SimpleRep a)) =>
Term fn (SimpleRep a) -> Term fn a
fromGeneric_ = forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app forall (fn :: [*] -> * -> *) a.
(HasSpec fn (SimpleRep a),
 TypeSpec fn a ~ TypeSpec fn (SimpleRep a), HasSimpleRep a) =>
fn '[SimpleRep a] a
fromGenericFn

not_ ::
  BaseUniverse fn =>
  Term fn Bool ->
  Term fn Bool
not_ :: forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Term fn Bool -> Term fn Bool
not_ = forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app forall (fn :: [*] -> * -> *).
Member (BoolFn fn) fn =>
fn '[Bool] Bool
notFn

infixr 2 ||.
(||.) ::
  BaseUniverse fn =>
  Term fn Bool ->
  Term fn Bool ->
  Term fn Bool
||. :: forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Term fn Bool -> Term fn Bool -> Term fn Bool
(||.) = forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app forall (fn :: [*] -> * -> *).
Member (BoolFn fn) fn =>
fn '[Bool, Bool] Bool
orFn

infix 4 `elem_`
elem_ ::
  forall a fn.
  HasSpec fn a =>
  Term fn a ->
  Term fn [a] ->
  Term fn Bool
elem_ :: forall a (fn :: [*] -> * -> *).
HasSpec fn a =>
Term fn a -> Term fn [a] -> Term fn Bool
elem_ = forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app forall (fn :: [*] -> * -> *) a.
(Member (SetFn fn) fn, Eq a, Show a, Typeable a) =>
fn '[a, [a]] Bool
elemFn

member_ ::
  forall a fn.
  ( HasSpec fn a
  , Ord a
  ) =>
  Term fn a ->
  Term fn (Set a) ->
  Term fn Bool
member_ :: forall a (fn :: [*] -> * -> *).
(HasSpec fn a, Ord a) =>
Term fn a -> Term fn (Set a) -> Term fn Bool
member_ = forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app forall (fn :: [*] -> * -> *) a.
(Member (SetFn fn) fn, Ord a, Show a, Typeable a) =>
fn '[a, Set a] Bool
memberFn

subset_ ::
  (HasSpec fn (Set a), Ord a, Show a, Typeable a) =>
  Term fn (Set a) ->
  Term fn (Set a) ->
  Term fn Bool
subset_ :: forall (fn :: [*] -> * -> *) a.
(HasSpec fn (Set a), Ord a, Show a, Typeable a) =>
Term fn (Set a) -> Term fn (Set a) -> Term fn Bool
subset_ = forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app forall (fn :: [*] -> * -> *) a.
(Member (SetFn fn) fn, Ord a, Show a, Typeable a) =>
fn '[Set a, Set a] Bool
subsetFn

disjoint_ ::
  ( HasSpec fn a
  , Ord a
  ) =>
  Term fn (Set a) ->
  Term fn (Set a) ->
  Term fn Bool
disjoint_ :: forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, Ord a) =>
Term fn (Set a) -> Term fn (Set a) -> Term fn Bool
disjoint_ = forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app forall (fn :: [*] -> * -> *) a.
(Member (SetFn fn) fn, Ord a, Show a, Typeable a) =>
fn '[Set a, Set a] Bool
disjointFn

singleton_ ::
  ( HasSpec fn a
  , Ord a
  ) =>
  Term fn a ->
  Term fn (Set a)
singleton_ :: forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, Ord a) =>
Term fn a -> Term fn (Set a)
singleton_ = forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app forall (fn :: [*] -> * -> *) a.
(Member (SetFn fn) fn, Ord a) =>
fn '[a] (Set a)
singletonFn

union_ ::
  forall a fn.
  ( HasSpec fn a
  , Ord a
  ) =>
  Term fn (Set a) ->
  Term fn (Set a) ->
  Term fn (Set a)
union_ :: forall a (fn :: [*] -> * -> *).
(HasSpec fn a, Ord a) =>
Term fn (Set a) -> Term fn (Set a) -> Term fn (Set a)
union_ = forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app forall (fn :: [*] -> * -> *) a.
(Member (SetFn fn) fn, Ord a, Show a, Typeable a) =>
fn '[Set a, Set a] (Set a)
unionFn

fromList_ ::
  forall a fn.
  ( HasSpec fn a
  , Ord a
  ) =>
  Term fn [a] ->
  Term fn (Set a)
fromList_ :: forall a (fn :: [*] -> * -> *).
(HasSpec fn a, Ord a) =>
Term fn [a] -> Term fn (Set a)
fromList_ = forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app forall (fn :: [*] -> * -> *) a.
(Member (SetFn fn) fn, Ord a) =>
fn '[[a]] (Set a)
fromListFn

sizeOf_ ::
  forall a fn.
  (HasSpec fn a, Sized fn a) =>
  Term fn a ->
  Term fn Integer
sizeOf_ :: forall a (fn :: [*] -> * -> *).
(HasSpec fn a, Sized fn a) =>
Term fn a -> Term fn Integer
sizeOf_ = forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, Member (SizeFn fn) fn, Sized fn a) =>
fn '[a] Integer
sizeOfFn

-- | special instance of sizeOf (for Sets) for backward compatibility
size_ ::
  forall a fn.
  (HasSpec fn (Set a), Ord a) =>
  Term fn (Set a) ->
  Term fn Integer
size_ :: forall a (fn :: [*] -> * -> *).
(HasSpec fn (Set a), Ord a) =>
Term fn (Set a) -> Term fn Integer
size_ = forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, Member (SizeFn fn) fn, Sized fn a) =>
fn '[a] Integer
sizeOfFn

-- | special instance of sizeOf (for Lists) for backward compatibility
length_ ::
  forall a fn.
  HasSpec fn [a] =>
  Term fn [a] ->
  Term fn Integer
length_ :: forall a (fn :: [*] -> * -> *).
HasSpec fn [a] =>
Term fn [a] -> Term fn Integer
length_ = forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, Member (SizeFn fn) fn, Sized fn a) =>
fn '[a] Integer
sizeOfFn

null_ :: (HasSpec fn a, Sized fn a) => Term fn a -> Term fn Bool
null_ :: forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, Sized fn a) =>
Term fn a -> Term fn Bool
null_ Term fn a
xs = forall a (fn :: [*] -> * -> *).
(HasSpec fn a, Sized fn a) =>
Term fn a -> Term fn Integer
sizeOf_ Term fn a
xs forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Term fn a -> Term fn Bool
==. Term fn Integer
0

-- #####

infix 4 <=., >=., >., <., ==., /=.

(<=.) ::
  ( Ord a
  , OrdLike fn a
  ) =>
  Term fn a ->
  Term fn a ->
  Term fn Bool
<=. :: forall a (fn :: [*] -> * -> *).
(Ord a, OrdLike fn a) =>
Term fn a -> Term fn a -> Term fn Bool
(<=.) = forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app forall (fn :: [*] -> * -> *) a.
(Ord a, OrdLike fn a) =>
fn '[a, a] Bool
lessOrEqualFn

(>=.) ::
  ( Ord a
  , OrdLike fn a
  ) =>
  Term fn a ->
  Term fn a ->
  Term fn Bool
>=. :: forall a (fn :: [*] -> * -> *).
(Ord a, OrdLike fn a) =>
Term fn a -> Term fn a -> Term fn Bool
(>=.) = forall (fn :: [*] -> * -> *) a b c.
(Member (FunFn fn) fn, Typeable a, Typeable b, HasSpec fn a,
 HasSpec fn b, HasSpec fn c) =>
(Term fn a -> Term fn b -> Term fn c)
-> Term fn b -> Term fn a -> Term fn c
flip_ forall a (fn :: [*] -> * -> *).
(Ord a, OrdLike fn a) =>
Term fn a -> Term fn a -> Term fn Bool
(<=.)

(<.) ::
  ( Ord a
  , OrdLike fn a
  ) =>
  Term fn a ->
  Term fn a ->
  Term fn Bool
<. :: forall a (fn :: [*] -> * -> *).
(Ord a, OrdLike fn a) =>
Term fn a -> Term fn a -> Term fn Bool
(<.) = forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app forall (fn :: [*] -> * -> *) a.
(Ord a, OrdLike fn a) =>
fn '[a, a] Bool
lessFn

(>.) ::
  ( Ord a
  , OrdLike fn a
  ) =>
  Term fn a ->
  Term fn a ->
  Term fn Bool
>. :: forall a (fn :: [*] -> * -> *).
(Ord a, OrdLike fn a) =>
Term fn a -> Term fn a -> Term fn Bool
(>.) = forall (fn :: [*] -> * -> *) a b c.
(Member (FunFn fn) fn, Typeable a, Typeable b, HasSpec fn a,
 HasSpec fn b, HasSpec fn c) =>
(Term fn a -> Term fn b -> Term fn c)
-> Term fn b -> Term fn a -> Term fn c
flip_ forall a (fn :: [*] -> * -> *).
(Ord a, OrdLike fn a) =>
Term fn a -> Term fn a -> Term fn Bool
(<.)

(==.) ::
  HasSpec fn a =>
  Term fn a ->
  Term fn a ->
  Term fn Bool
==. :: forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Term fn a -> Term fn Bool
(==.) = forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app forall (fn :: [*] -> * -> *) a.
(Eq a, Member (EqFn fn) fn) =>
fn '[a, a] Bool
equalFn

(/=.) ::
  HasSpec fn a =>
  Term fn a ->
  Term fn a ->
  Term fn Bool
Term fn a
a /=. :: forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Term fn a -> Term fn Bool
/=. Term fn a
b = forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Term fn Bool -> Term fn Bool
not_ (Term fn a
a forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Term fn a -> Term fn Bool
==. Term fn a
b)

sum_ ::
  ( BaseUniverse fn
  , Member (FunFn fn) fn
  , Foldy fn a
  ) =>
  Term fn [a] ->
  Term fn a
sum_ :: forall (fn :: [*] -> * -> *) a.
(BaseUniverse fn, Member (FunFn fn) fn, Foldy fn a) =>
Term fn [a] -> Term fn a
sum_ = forall (fn :: [*] -> * -> *) a b.
(BaseUniverse fn, Foldy fn b, HasSpec fn a) =>
(Term fn a -> Term fn b) -> Term fn [a] -> Term fn b
foldMap_ forall a. a -> a
id

foldMap_ ::
  forall fn a b.
  ( BaseUniverse fn
  , Foldy fn b
  , HasSpec fn a
  ) =>
  (Term fn a -> Term fn b) ->
  Term fn [a] ->
  Term fn b
foldMap_ :: forall (fn :: [*] -> * -> *) a b.
(BaseUniverse fn, Foldy fn b, HasSpec fn a) =>
(Term fn a -> Term fn b) -> Term fn [a] -> Term fn b
foldMap_ Term fn a -> Term fn b
f = forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, Foldy fn b, Show (fn '[a] b), Eq (fn '[a] b)) =>
fn '[a] b -> fn '[[a]] b
foldMapFn forall a b. (a -> b) -> a -> b
$ forall b. HasCallStack => Term fn b -> fn '[a] b
toFn forall a b. (a -> b) -> a -> b
$ Term fn a -> Term fn b
f (forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Term fn a
V Var a
v)
  where
    v :: Var a
v = forall a. Int -> [Char] -> Var a
Var (-Int
1) [Char]
"v" :: Var a
    -- Turn `f (V v) = fn (gn (hn v))` into `composeFn fn (composeFn gn hn)`
    toFn :: forall b. HasCallStack => Term fn b -> fn '[a] b
    toFn :: forall b. HasCallStack => Term fn b -> fn '[a] b
toFn (App fn as b
fn (V Var a
v' :> List (Term fn) as1
Nil)) | Just a :~: a
Refl <- forall a a'.
(Typeable a, Typeable a') =>
Var a -> Var a' -> Maybe (a :~: a')
eqVar Var a
v Var a
v' = fn as b
fn
    toFn (App fn as b
fn (Term fn a
t :> List (Term fn) as1
Nil)) = forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fn as b -> fnU as b
injectFn forall a b. (a -> b) -> a -> b
$ forall a (fn :: [*] -> * -> *) b c.
(Typeable a, HasSpec fn a, Show (fn '[b] a), Show (fn '[a] c),
 Eq (fn '[b] a), Eq (fn '[a] c)) =>
fn '[a] c -> fn '[b] a -> FunFn fn '[b] c
Compose fn as b
fn (forall b. HasCallStack => Term fn b -> fn '[a] b
toFn Term fn a
t)
    toFn (V Var b
v') | Just a :~: b
Refl <- forall a a'.
(Typeable a, Typeable a') =>
Var a -> Var a' -> Maybe (a :~: a')
eqVar Var a
v Var b
v' = forall (fn :: [*] -> * -> *) a. Member (FunFn fn) fn => fn '[a] a
idFn
    toFn Term fn b
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"foldMap_ has not been given a function of the form \\ x -> f (g ... (h x))"

infixr 5 ++.
(++.) :: HasSpec fn a => Term fn [a] -> Term fn [a] -> Term fn [a]
++. :: forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn [a] -> Term fn [a] -> Term fn [a]
(++.) = forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, Show a, Typeable a) =>
fn '[[a], [a]] [a]
appendFn

singletonList_ :: HasSpec fn a => Term fn a -> Term fn [a]
singletonList_ :: forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Term fn [a]
singletonList_ = forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app forall (fn :: [*] -> * -> *) a. HasSpec fn a => fn '[a] [a]
singletonListFn

-- Language constructs ----------------------------------------------------

constrained ::
  forall a fn p.
  (IsPred p fn, HasSpec fn a) =>
  (Term fn a -> p) ->
  Specification fn a
constrained :: forall a (fn :: [*] -> * -> *) p.
(IsPred p fn, HasSpec fn a) =>
(Term fn a -> p) -> Specification fn a
constrained Term fn a -> p
body =
  let Var a
x :-> Pred fn
p = forall (fn :: [*] -> * -> *) a p.
(HasSpec fn a, IsPred p fn) =>
(Term fn a -> p) -> Binder fn a
bind Term fn a -> p
body
   in forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Specification fn a
SuspendedSpec Var a
x Pred fn
p

assertExplain ::
  (BaseUniverse fn, IsPred p fn) =>
  NE.NonEmpty String ->
  p ->
  Pred fn
assertExplain :: forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
NonEmpty [Char] -> p -> Pred fn
assertExplain NonEmpty [Char]
nes p
p = forall p (fn :: [*] -> * -> *).
(PredLike p, BaseUniverse fn, UnivConstr p fn) =>
[[Char]] -> p -> Pred fn
toPredExplain (forall a. NonEmpty a -> [a]
NE.toList NonEmpty [Char]
nes) p
p

assert ::
  (BaseUniverse fn, IsPred p fn) =>
  p ->
  Pred fn
assert :: forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
p -> Pred fn
assert p
p = forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, PredLike p, UnivConstr p fn) =>
p -> Pred fn
toPred p
p

forAll ::
  ( Forallable t a
  , HasSpec fn t
  , HasSpec fn a
  , IsPred p fn
  ) =>
  Term fn t ->
  (Term fn a -> p) ->
  Pred fn
forAll :: forall t a (fn :: [*] -> * -> *) p.
(Forallable t a, HasSpec fn t, HasSpec fn a, IsPred p fn) =>
Term fn t -> (Term fn a -> p) -> Pred fn
forAll Term fn t
tm = forall a b (fn :: [*] -> * -> *).
(Forallable a b, HasSpec fn a, HasSpec fn b) =>
Term fn a -> Binder fn b -> Pred fn
mkForAll Term fn t
tm forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fn :: [*] -> * -> *) a p.
(HasSpec fn a, IsPred p fn) =>
(Term fn a -> p) -> Binder fn a
bind

mkForAll ::
  ( Forallable t a
  , HasSpec fn t
  , HasSpec fn a
  ) =>
  Term fn t ->
  Binder fn a ->
  Pred fn
mkForAll :: forall a b (fn :: [*] -> * -> *).
(Forallable a b, HasSpec fn a, HasSpec fn b) =>
Term fn a -> Binder fn b -> Pred fn
mkForAll (Lit (forall t e. Forallable t e => t -> [e]
forAllToList -> [])) Binder fn a
_ = forall (fn :: [*] -> * -> *). Pred fn
TruePred
mkForAll Term fn t
_ (Var a
_ :-> Pred fn
TruePred) = forall (fn :: [*] -> * -> *). Pred fn
TruePred
mkForAll Term fn t
tm Binder fn a
binder = forall a b (fn :: [*] -> * -> *).
(Forallable a b, HasSpec fn a, HasSpec fn b) =>
Term fn a -> Binder fn b -> Pred fn
ForAll Term fn t
tm Binder fn a
binder

exists ::
  forall a p fn.
  (HasSpec fn a, IsPred p fn) =>
  ((forall b. Term fn b -> b) -> GE a) ->
  (Term fn a -> p) ->
  Pred fn
exists :: forall a p (fn :: [*] -> * -> *).
(HasSpec fn a, IsPred p fn) =>
((forall b. Term fn b -> b) -> GE a) -> (Term fn a -> p) -> Pred fn
exists (forall b. Term fn b -> b) -> GE a
sem Term fn a -> p
k =
  forall (fn :: [*] -> * -> *) a.
((forall b. Term fn b -> b) -> GE a) -> Binder fn a -> Pred fn
Exists (forall b. Term fn b -> b) -> GE a
sem forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a p.
(HasSpec fn a, IsPred p fn) =>
(Term fn a -> p) -> Binder fn a
bind Term fn a -> p
k

unsafeExists ::
  forall a p fn.
  (HasSpec fn a, IsPred p fn) =>
  (Term fn a -> p) ->
  Pred fn
unsafeExists :: forall a p (fn :: [*] -> * -> *).
(HasSpec fn a, IsPred p fn) =>
(Term fn a -> p) -> Pred fn
unsafeExists = forall a p (fn :: [*] -> * -> *).
(HasSpec fn a, IsPred p fn) =>
((forall b. Term fn b -> b) -> GE a) -> (Term fn a -> p) -> Pred fn
exists (\forall b. Term fn b -> b
_ -> forall (m :: * -> *) a. MonadGenError m => [Char] -> m a
fatalError1 [Char]
"unsafeExists")

letBind ::
  ( HasSpec fn a
  , IsPred p fn
  ) =>
  Term fn a ->
  (Term fn a -> p) ->
  Pred fn
letBind :: forall (fn :: [*] -> * -> *) a p.
(HasSpec fn a, IsPred p fn) =>
Term fn a -> (Term fn a -> p) -> Pred fn
letBind tm :: Term fn a
tm@V {} Term fn a -> p
body = forall p (fn :: [*] -> * -> *).
(PredLike p, BaseUniverse fn, UnivConstr p fn) =>
[[Char]] -> p -> Pred fn
toPredExplain [] forall a b. (a -> b) -> a -> b
$ Term fn a -> p
body Term fn a
tm
letBind Term fn a
tm Term fn a -> p
body = forall (fn :: [*] -> * -> *) a. Term fn a -> Binder fn a -> Pred fn
Let Term fn a
tm (forall (fn :: [*] -> * -> *) a p.
(HasSpec fn a, IsPred p fn) =>
(Term fn a -> p) -> Binder fn a
bind Term fn a -> p
body)

reify ::
  ( HasSpec fn a
  , HasSpec fn b
  , IsPred p fn
  ) =>
  Term fn a ->
  (a -> b) ->
  (Term fn b -> p) ->
  Pred fn
reify :: forall (fn :: [*] -> * -> *) a b p.
(HasSpec fn a, HasSpec fn b, IsPred p fn) =>
Term fn a -> (a -> b) -> (Term fn b -> p) -> Pred fn
reify Term fn a
t a -> b
f Term fn b -> p
body =
  forall a p (fn :: [*] -> * -> *).
(HasSpec fn a, IsPred p fn) =>
((forall b. Term fn b -> b) -> GE a) -> (Term fn a -> p) -> Pred fn
exists (\forall b. Term fn b -> b
eval -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ a -> b
f (forall b. Term fn b -> b
eval Term fn a
t)) forall a b. (a -> b) -> a -> b
$ \Term fn b
x ->
    [ forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, HasSpec fn b) =>
Term fn b -> Term fn a -> (a -> b) -> Pred fn
reifies Term fn b
x Term fn a
t a -> b
f
    , forall p (fn :: [*] -> * -> *).
(PredLike p, BaseUniverse fn, UnivConstr p fn) =>
[[Char]] -> p -> Pred fn
toPredExplain (forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
"reifies " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Term fn b
x)) forall a b. (a -> b) -> a -> b
$ Term fn b -> p
body Term fn b
x
    ]

-- | Wrap an 'Explain' around a Pred, unless there is a simpler form.
explanation :: NE.NonEmpty String -> Pred fn -> Pred fn
explanation :: forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn -> Pred fn
explanation NonEmpty [Char]
_ p :: Pred fn
p@DependsOn {} = Pred fn
p
explanation NonEmpty [Char]
_ Pred fn
TruePred = forall (fn :: [*] -> * -> *). Pred fn
TruePred
explanation NonEmpty [Char]
es (FalsePred NonEmpty [Char]
es') = forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn
FalsePred (NonEmpty [Char]
es forall a. Semigroup a => a -> a -> a
<> NonEmpty [Char]
es')
explanation NonEmpty [Char]
es (Assert Term fn Bool
t) = forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn -> Pred fn
Explain NonEmpty [Char]
es forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Term fn Bool -> Pred fn
Assert Term fn Bool
t
explanation NonEmpty [Char]
es Pred fn
p = forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn -> Pred fn
Explain NonEmpty [Char]
es Pred fn
p

-- | Add QuickCheck monitoring (e.g. 'Test.QuickCheck.collect' or 'Test.QuickCheck.counterexample')
--   to a predicate. To use the monitoring in a property call 'monitorSpec' on the 'Specification'
--   containing the monitoring and a value generated from the specification.
monitor :: ((forall a. Term fn a -> a) -> Property -> Property) -> Pred fn
monitor :: forall (fn :: [*] -> * -> *).
((forall a. Term fn a -> a) -> Property -> Property) -> Pred fn
monitor = forall (fn :: [*] -> * -> *).
((forall a. Term fn a -> a) -> Property -> Property) -> Pred fn
Monitor

assertReified :: HasSpec fn a => Term fn a -> (a -> Bool) -> Pred fn
-- Note, it is necessary to introduce the extra variable from the `exists` here
-- to make things like `assertRealMultiple` work, if you don't have it then the
-- `reifies` isn't a defining constraint for anything any more.
assertReified :: forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> (a -> Bool) -> Pred fn
assertReified Term fn a
t a -> Bool
f =
  forall (fn :: [*] -> * -> *) a b p.
(HasSpec fn a, HasSpec fn b, IsPred p fn) =>
Term fn a -> (a -> b) -> (Term fn b -> p) -> Pred fn
reify Term fn a
t a -> Bool
f forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
p -> Pred fn
assert

reifies :: (HasSpec fn a, HasSpec fn b) => Term fn b -> Term fn a -> (a -> b) -> Pred fn
reifies :: forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, HasSpec fn b) =>
Term fn b -> Term fn a -> (a -> b) -> Pred fn
reifies = forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, HasSpec fn b) =>
Term fn b -> Term fn a -> (a -> b) -> Pred fn
Reifies

dependsOn :: (HasSpec fn a, HasSpec fn b) => Term fn a -> Term fn b -> Pred fn
dependsOn :: forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, HasSpec fn b) =>
Term fn a -> Term fn b -> Pred fn
dependsOn = forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, HasSpec fn b) =>
Term fn a -> Term fn b -> Pred fn
DependsOn

lit :: Show a => a -> Term fn a
lit :: forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
lit = forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit

ifElse :: (BaseUniverse fn, IsPred p fn, IsPred q fn) => Term fn Bool -> p -> q -> Pred fn
ifElse :: forall (fn :: [*] -> * -> *) p q.
(BaseUniverse fn, IsPred p fn, IsPred q fn) =>
Term fn Bool -> p -> q -> Pred fn
ifElse Term fn Bool
b p
p q
q = forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
Term fn Bool -> p -> Pred fn
whenTrue Term fn Bool
b p
p forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
Term fn Bool -> p -> Pred fn
whenTrue (forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Term fn Bool -> Term fn Bool
not_ Term fn Bool
b) q
q

whenTrue :: forall fn p. (BaseUniverse fn, IsPred p fn) => Term fn Bool -> p -> Pred fn
whenTrue :: forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
Term fn Bool -> p -> Pred fn
whenTrue (Lit Bool
True) (forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, PredLike p, UnivConstr p fn) =>
p -> Pred fn
toPred @fn -> Pred fn
p) = Pred fn
p
whenTrue (Lit Bool
False) p
_ = forall (fn :: [*] -> * -> *). Pred fn
TruePred
whenTrue Term fn Bool
b (forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, PredLike p, UnivConstr p fn) =>
p -> Pred fn
toPred @fn -> FalsePred {}) = forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
p -> Pred fn
assert @fn (forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Term fn Bool -> Term fn Bool
not_ Term fn Bool
b)
whenTrue Term fn Bool
_ (forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, PredLike p, UnivConstr p fn) =>
p -> Pred fn
toPred @fn -> Pred fn
TruePred) = forall (fn :: [*] -> * -> *). Pred fn
TruePred @fn
whenTrue Term fn Bool
b (forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, PredLike p, UnivConstr p fn) =>
p -> Pred fn
toPred @fn -> Pred fn
p) = forall (fn :: [*] -> * -> *).
HasSpec fn Bool =>
Term fn Bool -> Pred fn -> Pred fn
When @fn Term fn Bool
b Pred fn
p

genHint :: forall fn t. HasGenHint fn t => Hint t -> Term fn t -> Pred fn
genHint :: forall (fn :: [*] -> * -> *) a.
HasGenHint fn a =>
Hint a -> Term fn a -> Pred fn
genHint = forall (fn :: [*] -> * -> *) a.
HasGenHint fn a =>
Hint a -> Term fn a -> Pred fn
GenHint

-- Internals --------------------------------------------------------------

app ::
  ( HasSpec fn b
  , Typeable as
  , TypeList as
  , All (HasSpec fn) as
  ) =>
  fn as b ->
  FunTy (MapList (Term fn) as) (Term fn b)
app :: forall (fn :: [*] -> * -> *) b (as :: [*]).
(HasSpec fn b, Typeable as, TypeList as, All (HasSpec fn) as) =>
fn as b -> FunTy (MapList (Term fn) as) (Term fn b)
app fn as b
fn = forall (ts :: [*]) (f :: * -> *) r.
TypeList ts =>
(List f ts -> r) -> FunTy (MapList f ts) r
curryList (forall (a :: [*]) (fn :: [*] -> * -> *) b.
(Typeable a, TypeList a, All (HasSpec fn) a, HasSpec fn b,
 BaseUniverse fn) =>
fn a b -> List (Term fn) a -> Term fn b
App fn as b
fn)

name :: String -> Term fn a -> Term fn a
name :: forall (fn :: [*] -> * -> *) a. [Char] -> Term fn a -> Term fn a
name [Char]
nh (V (Var Int
i [Char]
_)) = forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Term fn a
V (forall a. Int -> [Char] -> Var a
Var Int
i [Char]
nh)
name [Char]
_ Term fn a
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"applying name to non-var thing! Shame on you!"

-- | Give a Term a nameHint, if its a Var, and doesn't already have one,
--  otherwise return the Term unchanged.
named :: String -> Term fn a -> Term fn a
named :: forall (fn :: [*] -> * -> *) a. [Char] -> Term fn a -> Term fn a
named [Char]
nh t :: Term fn a
t@(V (Var Int
i [Char]
x)) = if [Char]
x forall a. Eq a => a -> a -> Bool
/= [Char]
"v" then Term fn a
t else forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Term fn a
V (forall a. Int -> [Char] -> Var a
Var Int
i [Char]
nh)
named [Char]
_ Term fn a
t = Term fn a
t

bind :: (HasSpec fn a, IsPred p fn) => (Term fn a -> p) -> Binder fn a
bind :: forall (fn :: [*] -> * -> *) a p.
(HasSpec fn a, IsPred p fn) =>
(Term fn a -> p) -> Binder fn a
bind Term fn a -> p
bodyf = Var a
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Binder fn a
:-> Pred fn
p
  where
    p :: Pred fn
p = forall p (fn :: [*] -> * -> *).
(PredLike p, BaseUniverse fn, UnivConstr p fn) =>
[[Char]] -> p -> Pred fn
toPredExplain [] forall a b. (a -> b) -> a -> b
$ p
body
    x :: Var a
x = forall a. Int -> [Char] -> Var a
Var (forall {fn :: [*] -> * -> *}. Pred fn -> Int
nextVar Pred fn
p) [Char]
"v"
    body :: p
body = Term fn a -> p
bodyf (forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Term fn a
V Var a
x)

    nextVar :: Pred fn -> Int
nextVar Pred fn
p = Int
1 forall a. Num a => a -> a -> a
+ forall {fn :: [*] -> * -> *}. Pred fn -> Int
bound Pred fn
p

    boundBinder :: Binder fn a -> Int
    boundBinder :: forall (fn :: [*] -> * -> *) a. Binder fn a -> Int
boundBinder (Var a
x :-> Pred fn
p) = forall a. Ord a => a -> a -> a
max (forall a. Var a -> Int
nameOf Var a
x) (forall {fn :: [*] -> * -> *}. Pred fn -> Int
bound Pred fn
p)

    bound :: Pred fn -> Int
bound (Explain NonEmpty [Char]
_ Pred fn
p) = Pred fn -> Int
bound Pred fn
p
    bound (Subst Var a
x Term fn a
_ Pred fn
p) = forall a. Ord a => a -> a -> a
max (forall a. Var a -> Int
nameOf Var a
x) (Pred fn -> Int
bound Pred fn
p)
    bound (Block [Pred fn]
ps) = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ (-Int
1) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Pred fn -> Int
bound [Pred fn]
ps -- (-1) as the default to get 0 as `nextVar p`
    bound (Exists (forall b. Term fn b -> b) -> GE a
_ Binder fn a
b) = forall (fn :: [*] -> * -> *) a. Binder fn a -> Int
boundBinder Binder fn a
b
    bound (Let Term fn a
_ Binder fn a
b) = forall (fn :: [*] -> * -> *) a. Binder fn a -> Int
boundBinder Binder fn a
b
    bound (ForAll Term fn t
_ Binder fn a
b) = forall (fn :: [*] -> * -> *) a. Binder fn a -> Int
boundBinder Binder fn a
b
    bound (Case Term fn (SumOver as)
_ List (Weighted (Binder fn)) as
cs) = forall a. Max a -> a
getMax forall a b. (a -> b) -> a -> b
$ forall {k} b (f :: k -> *) (as :: [k]).
Monoid b =>
(forall (a :: k). f a -> b) -> List f as -> b
foldMapList (forall a. a -> Max a
Max forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fn :: [*] -> * -> *) a. Binder fn a -> Int
boundBinder forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Weighted f a -> f a
thing) List (Weighted (Binder fn)) as
cs
    bound (When Term fn Bool
_ Pred fn
p) = Pred fn -> Int
bound Pred fn
p
    bound Reifies {} = -Int
1
    bound GenHint {} = -Int
1
    bound Assert {} = -Int
1
    bound DependsOn {} = -Int
1
    bound Pred fn
TruePred = -Int
1
    bound FalsePred {} = -Int
1
    bound Monitor {} = -Int
1

mkCase ::
  HasSpec fn (SumOver as) => Term fn (SumOver as) -> List (Weighted (Binder fn)) as -> Pred fn
mkCase :: forall (fn :: [*] -> * -> *) (a :: [*]).
HasSpec fn (SumOver a) =>
Term fn (SumOver a) -> List (Weighted (Binder fn)) a -> Pred fn
mkCase Term fn (SumOver as)
tm List (Weighted (Binder fn)) as
cs
  | Weighted Maybe Int
_ (Var a
x :-> Pred fn
p) :> List (Weighted (Binder fn)) as1
Nil <- List (Weighted (Binder fn)) as
cs = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> Pred fn -> Pred fn
Subst Var a
x Term fn (SumOver as)
tm Pred fn
p
  -- TODO: all equal maybe?
  | All -> Bool
getAll forall a b. (a -> b) -> a -> b
$ forall {k} b (f :: k -> *) (as :: [k]).
Monoid b =>
(forall (a :: k). f a -> b) -> List f as -> b
foldMapList forall {fn :: [*] -> * -> *} {a}. Weighted (Binder fn) a -> All
isTrueBinder List (Weighted (Binder fn)) as
cs = forall (fn :: [*] -> * -> *). Pred fn
TruePred
  | All -> Bool
getAll forall a b. (a -> b) -> a -> b
$ forall {k} b (f :: k -> *) (as :: [k]).
Monoid b =>
(forall (a :: k). f a -> b) -> List f as -> b
foldMapList (forall {fn :: [*] -> * -> *} {a}. Binder fn a -> All
isFalseBinder forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Weighted f a -> f a
thing) List (Weighted (Binder fn)) as
cs = forall (fn :: [*] -> * -> *). [Char] -> Pred fn
falsePred1 [Char]
"mkCase on all False"
  | Lit SumOver as
a <- Term fn (SumOver as)
tm = forall (as :: [*]) (fn :: [*] -> * -> *) r.
SumOver as
-> List (Binder fn) as
-> (forall a. HasSpec fn a => Var a -> a -> Pred fn -> r)
-> r
runCaseOn SumOver as
a (forall {k} (f :: k -> *) (g :: k -> *) (as :: [k]).
(forall (a :: k). f a -> g a) -> List f as -> List g as
mapList forall (f :: * -> *) a. Weighted f a -> f a
thing List (Weighted (Binder fn)) as
cs) (\Var a
x a
val Pred fn
p -> forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Env -> Pred fn -> Pred fn
substPred (forall a. (Typeable a, Show a) => Var a -> a -> Env
singletonEnv Var a
x a
val) Pred fn
p)
  | Bool
otherwise = forall (fn :: [*] -> * -> *) (a :: [*]).
HasSpec fn (SumOver a) =>
Term fn (SumOver a) -> List (Weighted (Binder fn)) a -> Pred fn
Case Term fn (SumOver as)
tm List (Weighted (Binder fn)) as
cs
  where
    isTrueBinder :: Weighted (Binder fn) a -> All
isTrueBinder (Weighted Maybe Int
Nothing (Var a
_ :-> Pred fn
TruePred)) = Bool -> All
Semigroup.All Bool
True
    isTrueBinder Weighted (Binder fn) a
_ = Bool -> All
Semigroup.All Bool
False

    isFalseBinder :: Binder fn a -> All
isFalseBinder (Var a
_ :-> FalsePred {}) = Bool -> All
Semigroup.All Bool
True
    isFalseBinder Binder fn a
_ = Bool -> All
Semigroup.All Bool
False

-- Liberal syntax for what is a predicate ---------------------------------

type IsPred p fn = (PredLike p, UnivConstr p fn)

class Show p => PredLike p where
  type UnivConstr p (fn :: [Type] -> Type -> Type) :: Constraint
  toPredExplain :: (BaseUniverse fn, UnivConstr p fn) => [String] -> p -> Pred fn

toPred :: forall fn p. (BaseUniverse fn, PredLike p, UnivConstr p fn) => p -> Pred fn
toPred :: forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, PredLike p, UnivConstr p fn) =>
p -> Pred fn
toPred = forall p (fn :: [*] -> * -> *).
(PredLike p, BaseUniverse fn, UnivConstr p fn) =>
[[Char]] -> p -> Pred fn
toPredExplain []

instance PredLike (Pred fn) where
  type UnivConstr (Pred fn) fn' = fn ~ fn'
  toPredExplain :: forall (fn :: [*] -> * -> *).
(BaseUniverse fn, UnivConstr (Pred fn) fn) =>
[[Char]] -> Pred fn -> Pred fn
toPredExplain [] (Assert (Lit Bool
False)) = forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn
FalsePred (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"toPred(Lit False)")
  toPredExplain ([Char]
x : [[Char]]
xs) (Assert (Lit Bool
False)) = forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn
FalsePred ([Char]
x forall a. a -> [a] -> NonEmpty a
:| [[Char]]
xs)
  toPredExplain [[Char]]
_ (Assert (Lit Bool
True)) = forall (fn :: [*] -> * -> *). Pred fn
TruePred
  toPredExplain [] (Assert Term fn Bool
x) = forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Term fn Bool -> Pred fn
Assert Term fn Bool
x
  toPredExplain ([Char]
x : [[Char]]
xs) (Assert Term fn Bool
exp) = forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn -> Pred fn
Explain ([Char]
x forall a. a -> [a] -> NonEmpty a
:| [[Char]]
xs) (forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Term fn Bool -> Pred fn
Assert Term fn Bool
exp)
  toPredExplain [] (FalsePred NonEmpty [Char]
nes') = forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn
FalsePred NonEmpty [Char]
nes'
  toPredExplain ([Char]
x : [[Char]]
xs) (FalsePred NonEmpty [Char]
nes') = forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn
FalsePred (([Char]
x forall a. a -> [a] -> NonEmpty a
:| [[Char]]
xs) forall a. Semigroup a => a -> a -> a
<> NonEmpty [Char]
nes')
  toPredExplain [] (Explain NonEmpty [Char]
nes' Pred fn
x) = forall p (fn :: [*] -> * -> *).
(PredLike p, BaseUniverse fn, UnivConstr p fn) =>
[[Char]] -> p -> Pred fn
toPredExplain (forall a. NonEmpty a -> [a]
NE.toList NonEmpty [Char]
nes') Pred fn
x
  toPredExplain ([Char]
x : [[Char]]
xs) (Explain NonEmpty [Char]
nes' Pred fn
exp) = forall p (fn :: [*] -> * -> *).
(PredLike p, BaseUniverse fn, UnivConstr p fn) =>
[[Char]] -> p -> Pred fn
toPredExplain (([Char]
x forall a. a -> [a] -> [a]
: [[Char]]
xs) forall a. [a] -> [a] -> [a]
++ forall a. NonEmpty a -> [a]
NE.toList NonEmpty [Char]
nes') Pred fn
exp
  toPredExplain [] (Block [Pred fn]
x) = forall (fn :: [*] -> * -> *). [Pred fn] -> Pred fn
Block [Pred fn]
x
  toPredExplain ([Char]
x : [[Char]]
xs) (Block [Pred fn]
ys) = forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn -> Pred fn
Explain ([Char]
x forall a. a -> [a] -> NonEmpty a
:| [[Char]]
xs) forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *). [Pred fn] -> Pred fn
Block [Pred fn]
ys
  toPredExplain [] Pred fn
p = Pred fn
p
  toPredExplain ([Char]
x : [[Char]]
xs) Pred fn
p = forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn -> Pred fn
Explain ([Char]
x forall a. a -> [a] -> NonEmpty a
:| [[Char]]
xs) Pred fn
p

instance (UnivConstr p fn, Show p, PredLike p) => PredLike [p] where
  type UnivConstr [p] fn = UnivConstr p fn
  toPredExplain :: forall (fn :: [*] -> * -> *).
(BaseUniverse fn, UnivConstr [p] fn) =>
[[Char]] -> [p] -> Pred fn
toPredExplain [] [p]
xs = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (forall a b. (a -> b) -> [a] -> [b]
map forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, PredLike p, UnivConstr p fn) =>
p -> Pred fn
toPred [p]
xs)
  toPredExplain [[Char]]
es [p]
xs = forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn -> Pred fn
Explain (forall a. [a] -> NonEmpty a
NE.fromList [[Char]]
es) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (forall a b. (a -> b) -> [a] -> [b]
map forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, PredLike p, UnivConstr p fn) =>
p -> Pred fn
toPred [p]
xs)

instance PredLike Bool where
  type UnivConstr Bool fn = ()
  toPredExplain :: forall (fn :: [*] -> * -> *).
(BaseUniverse fn, UnivConstr Bool fn) =>
[[Char]] -> Bool -> Pred fn
toPredExplain [[Char]]
_ Bool
True = forall (fn :: [*] -> * -> *). Pred fn
TruePred
  toPredExplain [] Bool
False = forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn
FalsePred (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"toPred False")
  toPredExplain [[Char]]
es Bool
False = forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn
FalsePred (forall a. [a] -> NonEmpty a
NE.fromList [[Char]]
es)

instance BaseUniverse fn => PredLike (Term fn Bool) where
  type UnivConstr (Term fn Bool) fn' = fn ~ fn'
  toPredExplain :: forall (fn :: [*] -> * -> *).
(BaseUniverse fn, UnivConstr (Term fn Bool) fn) =>
[[Char]] -> Term fn Bool -> Pred fn
toPredExplain [[Char]]
es (Lit Bool
b) = forall p (fn :: [*] -> * -> *).
(PredLike p, BaseUniverse fn, UnivConstr p fn) =>
[[Char]] -> p -> Pred fn
toPredExplain [[Char]]
es Bool
b
  toPredExplain [] Term fn Bool
tm = forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Term fn Bool -> Pred fn
Assert Term fn Bool
tm
  toPredExplain [[Char]]
es Term fn Bool
tm = forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn -> Pred fn
Explain (forall a. [a] -> NonEmpty a
NE.fromList [[Char]]
es) (forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Term fn Bool -> Pred fn
Assert Term fn Bool
tm)

------------------------------------------------------------------------
-- Pretty printing
------------------------------------------------------------------------

data WithPrec a = WithPrec Int a

parensIf :: Bool -> Doc ann -> Doc ann
parensIf :: forall ann. Bool -> Doc ann -> Doc ann
parensIf Bool
True = forall ann. Doc ann -> Doc ann
parens
parensIf Bool
False = forall a. a -> a
id

prettyPrec :: Pretty (WithPrec a) => Int -> a -> Doc ann
prettyPrec :: forall a ann. Pretty (WithPrec a) => Int -> a -> Doc ann
prettyPrec Int
p = forall a ann. Pretty a => a -> Doc ann
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> a -> WithPrec a
WithPrec Int
p

ppList ::
  forall fn f as ann.
  All (HasSpec fn) as =>
  (forall a. HasSpec fn a => f a -> Doc ann) ->
  List f as ->
  [Doc ann]
ppList :: forall (fn :: [*] -> * -> *) (f :: * -> *) (as :: [*]) ann.
All (HasSpec fn) as =>
(forall a. HasSpec fn a => f a -> Doc ann)
-> List f as -> [Doc ann]
ppList forall a. HasSpec fn a => f a -> Doc ann
_ List f as
Nil = []
ppList forall a. HasSpec fn a => f a -> Doc ann
pp (f a
a :> List f as1
as) = forall a. HasSpec fn a => f a -> Doc ann
pp f a
a forall a. a -> [a] -> [a]
: forall (fn :: [*] -> * -> *) (f :: * -> *) (as :: [*]) ann.
All (HasSpec fn) as =>
(forall a. HasSpec fn a => f a -> Doc ann)
-> List f as -> [Doc ann]
ppList @fn forall a. HasSpec fn a => f a -> Doc ann
pp List f as1
as

ppList_ :: forall f as ann. (forall a. f a -> Doc ann) -> List f as -> [Doc ann]
ppList_ :: forall (f :: * -> *) (as :: [*]) ann.
(forall a. f a -> Doc ann) -> List f as -> [Doc ann]
ppList_ forall a. f a -> Doc ann
_ List f as
Nil = []
ppList_ forall a. f a -> Doc ann
pp (f a
a :> List f as1
as) = forall a. f a -> Doc ann
pp f a
a forall a. a -> [a] -> [a]
: forall (f :: * -> *) (as :: [*]) ann.
(forall a. f a -> Doc ann) -> List f as -> [Doc ann]
ppList_ forall a. f a -> Doc ann
pp List f as1
as

instance HasSpec fn a => Pretty (WithPrec (Term fn a)) where
  pretty :: forall ann. WithPrec (Term fn a) -> Doc ann
pretty (WithPrec Int
p Term fn a
t) = case Term fn a
t of
    Lit a
n -> forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ forall a. Show a => Int -> a -> ShowS
showsPrec Int
p a
n [Char]
""
    V Var a
x -> forall a ann. Show a => a -> Doc ann
viaShow Var a
x
    -- These pattern matches, using patterns SubsetPat, DisjointPat, ...
    -- elide large literal terms, to make the error messages easier to follow.
    SubsetPat (Lit Set b
n) Term fn (Set b)
y -> forall ann. Bool -> Doc ann -> Doc ann
parensIf (Int
p forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$ Doc ann
"subset_" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a x. (Show a, Typeable a) => [a] -> Doc x
short (forall a. Set a -> [a]
Set.toList Set b
n) forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty (WithPrec a) => Int -> a -> Doc ann
prettyPrec Int
10 Term fn (Set b)
y
    SubsetPat Term fn (Set b)
y (Lit Set b
n) -> forall ann. Bool -> Doc ann -> Doc ann
parensIf (Int
p forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$ Doc ann
"subset_" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty (WithPrec a) => Int -> a -> Doc ann
prettyPrec Int
10 Term fn (Set b)
y forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a x. (Show a, Typeable a) => [a] -> Doc x
short (forall a. Set a -> [a]
Set.toList Set b
n)
    DisjointPat (Lit Set b
n) Term fn (Set b)
y -> forall ann. Bool -> Doc ann -> Doc ann
parensIf (Int
p forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$ Doc ann
"disjoint_" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a x. (Show a, Typeable a) => [a] -> Doc x
short (forall a. Set a -> [a]
Set.toList Set b
n) forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty (WithPrec a) => Int -> a -> Doc ann
prettyPrec Int
10 Term fn (Set b)
y
    DisjointPat Term fn (Set b)
y (Lit Set b
n) -> forall ann. Bool -> Doc ann -> Doc ann
parensIf (Int
p forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$ Doc ann
"disjoint_" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty (WithPrec a) => Int -> a -> Doc ann
prettyPrec Int
10 Term fn (Set b)
y forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a x. (Show a, Typeable a) => [a] -> Doc x
short (forall a. Set a -> [a]
Set.toList Set b
n)
    UnionPat (Lit Set b
n) Term fn (Set b)
y -> forall ann. Bool -> Doc ann -> Doc ann
parensIf (Int
p forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$ Doc ann
"union_" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a x. (Show a, Typeable a) => [a] -> Doc x
short (forall a. Set a -> [a]
Set.toList Set b
n) forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty (WithPrec a) => Int -> a -> Doc ann
prettyPrec Int
10 Term fn (Set b)
y
    UnionPat Term fn (Set b)
y (Lit Set b
n) -> forall ann. Bool -> Doc ann -> Doc ann
parensIf (Int
p forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$ Doc ann
"union_" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty (WithPrec a) => Int -> a -> Doc ann
prettyPrec Int
10 Term fn (Set b)
y forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a x. (Show a, Typeable a) => [a] -> Doc x
short (forall a. Set a -> [a]
Set.toList Set b
n)
    MemberPat Term fn b
y (Lit Set b
n) -> forall ann. Bool -> Doc ann -> Doc ann
parensIf (Int
p forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$ Doc ann
"member_" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty (WithPrec a) => Int -> a -> Doc ann
prettyPrec Int
10 Term fn b
y forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a x. (Show a, Typeable a) => [a] -> Doc x
short (forall a. Set a -> [a]
Set.toList Set b
n)
    ElemPat Term fn b
y (Lit [b]
n) -> forall ann. Bool -> Doc ann -> Doc ann
parensIf (Int
p forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$ Doc ann
"elem_" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty (WithPrec a) => Int -> a -> Doc ann
prettyPrec Int
10 Term fn b
y forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a x. (Show a, Typeable a) => [a] -> Doc x
short [b]
n
    AppendPat (Lit [b]
n) Term fn [b]
y -> forall ann. Bool -> Doc ann -> Doc ann
parensIf (Int
p forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$ Doc ann
"append_" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a x. (Show a, Typeable a) => [a] -> Doc x
short [b]
n forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty (WithPrec a) => Int -> a -> Doc ann
prettyPrec Int
10 Term fn [b]
y
    AppendPat Term fn [b]
y (Lit [b]
n) -> forall ann. Bool -> Doc ann -> Doc ann
parensIf (Int
p forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$ Doc ann
"append_" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty (WithPrec a) => Int -> a -> Doc ann
prettyPrec Int
10 Term fn [b]
y forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a x. (Show a, Typeable a) => [a] -> Doc x
short [b]
n
    App fn as a
f List (Term fn) as
Nil -> forall a ann. Show a => a -> Doc ann
viaShow fn as a
f
    App fn as a
f List (Term fn) as
as
      | Just EqFn fn as a
Equal <- forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fnU as b -> Maybe (fn as b)
extractFn @(EqFn fn) fn as a
f
      , Term fn a
a :> Term fn a
b :> List (Term fn) as1
_ <- List (Term fn) as
as ->
          forall ann. Bool -> Doc ann -> Doc ann
parensIf (Int
p forall a. Ord a => a -> a -> Bool
> Int
9) forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty (WithPrec a) => Int -> a -> Doc ann
prettyPrec Int
10 Term fn a
a forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"==." forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty (WithPrec a) => Int -> a -> Doc ann
prettyPrec Int
10 Term fn a
b
      | Just GenericsFn fn as a
ToGeneric <- forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fnU as b -> Maybe (fn as b)
extractFn @(GenericsFn fn) fn as a
f
      , Term fn a
a :> List (Term fn) as1
_ <- List (Term fn) as
as ->
          forall a ann. Pretty (WithPrec a) => Int -> a -> Doc ann
prettyPrec Int
p Term fn a
a
      | Just GenericsFn fn as a
FromGeneric <- forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fnU as b -> Maybe (fn as b)
extractFn @(GenericsFn fn) fn as a
f
      , Term fn a
a :> List (Term fn) as1
_ <- List (Term fn) as
as ->
          forall a ann. Pretty (WithPrec a) => Int -> a -> Doc ann
prettyPrec Int
p Term fn a
a
      | Bool
otherwise -> forall ann. Bool -> Doc ann -> Doc ann
parensIf (Int
p forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$ forall a ann. Show a => a -> Doc ann
viaShow fn as a
f forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
align (forall ann. [Doc ann] -> Doc ann
fillSep (forall (fn :: [*] -> * -> *) (f :: * -> *) (as :: [*]) ann.
All (HasSpec fn) as =>
(forall a. HasSpec fn a => f a -> Doc ann)
-> List f as -> [Doc ann]
ppList @fn (forall a ann. Pretty (WithPrec a) => Int -> a -> Doc ann
prettyPrec Int
11) List (Term fn) as
as))

instance HasSpec fn a => Pretty (Term fn a) where
  pretty :: forall ann. Term fn a -> Doc ann
pretty = forall a ann. Pretty (WithPrec a) => Int -> a -> Doc ann
prettyPrec Int
0

vsep' :: [Doc ann] -> Doc ann
vsep' :: forall ann. [Doc ann] -> Doc ann
vsep' = forall ann. Doc ann -> Doc ann
align forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate forall ann. Doc ann
hardline

(/>) :: Doc ann -> Doc ann -> Doc ann
Doc ann
h /> :: forall ann. Doc ann -> Doc ann -> Doc ann
/> Doc ann
cont = forall ann. Int -> Doc ann -> Doc ann
hang Int
2 forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
sep [Doc ann
h, forall ann. Doc ann -> Doc ann
align Doc ann
cont]

infixl 5 />

instance Pretty (Pred fn) where
  pretty :: forall ann. Pred fn -> Doc ann
pretty = \case
    Exists (forall b. Term fn b -> b) -> GE a
_ (Var a
x :-> Pred fn
p) -> forall ann. Doc ann -> Doc ann
align forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
sep [Doc ann
"exists" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow Var a
x forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"in", forall a ann. Pretty a => a -> Doc ann
pretty Pred fn
p]
    Let Term fn a
t (Var a
x :-> Pred fn
p) -> forall ann. Doc ann -> Doc ann
align forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
sep [Doc ann
"let" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow Var a
x forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"=" forall ann. Doc ann -> Doc ann -> Doc ann
/> forall a ann. Pretty a => a -> Doc ann
pretty Term fn a
t forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"in", forall a ann. Pretty a => a -> Doc ann
pretty Pred fn
p]
    Block [Pred fn]
ps -> forall ann. Doc ann -> Doc ann
braces forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
vsep' forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a ann. Pretty a => a -> Doc ann
pretty [Pred fn]
ps
    Assert Term fn Bool
t -> Doc ann
"assert $" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Term fn Bool
t
    Reifies Term fn b
t' Term fn a
t a -> b
_ -> Doc ann
"reifies" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Int -> a -> WithPrec a
WithPrec Int
11 Term fn b
t') forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Int -> a -> WithPrec a
WithPrec Int
11 Term fn a
t)
    DependsOn Term fn a
a Term fn b
b -> forall a ann. Pretty a => a -> Doc ann
pretty Term fn a
a forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"<-" forall ann. Doc ann -> Doc ann -> Doc ann
/> forall a ann. Pretty a => a -> Doc ann
pretty Term fn b
b
    ForAll Term fn t
t (Var a
x :-> Pred fn
p) -> Doc ann
"forall" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow Var a
x forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"in" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Term fn t
t forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"$" forall ann. Doc ann -> Doc ann -> Doc ann
/> forall a ann. Pretty a => a -> Doc ann
pretty Pred fn
p
    Case Term fn (SumOver as)
t List (Weighted (Binder fn)) as
bs -> Doc ann
"case" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Term fn (SumOver as)
t forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"of" forall ann. Doc ann -> Doc ann -> Doc ann
/> forall ann. [Doc ann] -> Doc ann
vsep' (forall (f :: * -> *) (as :: [*]) ann.
(forall a. f a -> Doc ann) -> List f as -> [Doc ann]
ppList_ forall a ann. Pretty a => a -> Doc ann
pretty List (Weighted (Binder fn)) as
bs)
    When Term fn Bool
b Pred fn
p -> Doc ann
"whenTrue" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Int -> a -> WithPrec a
WithPrec Int
11 Term fn Bool
b) forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"$" forall ann. Doc ann -> Doc ann -> Doc ann
/> forall a ann. Pretty a => a -> Doc ann
pretty Pred fn
p
    Subst Var a
x Term fn a
t Pred fn
p -> Doc ann
"[" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Term fn a
t forall a. Semigroup a => a -> a -> a
<> Doc ann
"/" forall a. Semigroup a => a -> a -> a
<> forall a ann. Show a => a -> Doc ann
viaShow Var a
x forall a. Semigroup a => a -> a -> a
<> Doc ann
"]" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Pred fn
p
    GenHint Hint a
h Term fn a
t -> Doc ann
"genHint" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a. IsString a => [Char] -> a
fromString (forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Hint a
h [Char]
"") forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"$" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Term fn a
t
    Pred fn
TruePred -> Doc ann
"True"
    FalsePred {} -> Doc ann
"False"
    Monitor {} -> Doc ann
"monitor"
    Explain NonEmpty [Char]
es Pred fn
p -> Doc ann
"ExplainPred" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow (forall a. NonEmpty a -> [a]
NE.toList NonEmpty [Char]
es) forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"$" forall ann. Doc ann -> Doc ann -> Doc ann
/> forall a ann. Pretty a => a -> Doc ann
pretty Pred fn
p

-- TODO: make nicer
instance Pretty (f a) => Pretty (Weighted f a) where
  pretty :: forall ann. Weighted f a -> Doc ann
pretty (Weighted Maybe Int
Nothing f a
t) = forall a ann. Pretty a => a -> Doc ann
pretty f a
t
  pretty (Weighted (Just Int
w) f a
t) = forall a ann. Show a => a -> Doc ann
viaShow Int
w forall a. Semigroup a => a -> a -> a
<> Doc ann
"~" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty f a
t

instance Pretty (Binder fn a) where
  pretty :: forall ann. Binder fn a -> Doc ann
pretty (Var a
x :-> Pred fn
p) = forall a ann. Show a => a -> Doc ann
viaShow Var a
x forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"->" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Pred fn
p

instance HasSpec fn a => Show (Term fn a) where
  showsPrec :: Int -> Term fn a -> ShowS
showsPrec Int
p Term fn a
t = forall a. Show a => a -> ShowS
shows forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Int -> a -> WithPrec a
WithPrec Int
p Term fn a
t)

instance Show (Pred fn) where
  show :: Pred fn -> [Char]
show = forall a. Show a => a -> [Char]
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty

instance HasSpec fn a => Pretty (WithPrec (Specification fn a)) where
  pretty :: forall ann. WithPrec (Specification fn a) -> Doc ann
pretty (WithPrec Int
d Specification fn a
s) = case Specification fn a
s of
    ExplainSpec [[Char]]
es Specification fn a
s -> Doc ann
"ExplainSpec" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow [[Char]]
es forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"$" forall ann. Doc ann -> Doc ann -> Doc ann
/> forall a ann. Pretty a => a -> Doc ann
pretty Specification fn a
s
    ErrorSpec NonEmpty [Char]
es -> Doc ann
"ErrorSpec" forall ann. Doc ann -> Doc ann -> Doc ann
/> forall ann. [Doc ann] -> Doc ann
vsep' (forall a b. (a -> b) -> [a] -> [b]
map forall a. IsString a => [Char] -> a
fromString (forall a. NonEmpty a -> [a]
NE.toList NonEmpty [Char]
es))
    Specification fn a
TrueSpec -> forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ [Char]
"TrueSpec @(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy @a)) forall a. [a] -> [a] -> [a]
++ [Char]
")"
    MemberSpec NonEmpty a
xs -> Doc ann
"MemberSpec" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a x. (Show a, Typeable a) => [a] -> Doc x
short (forall a. NonEmpty a -> [a]
NE.toList NonEmpty a
xs)
    SuspendedSpec Var a
x Pred fn
p -> forall ann. Bool -> Doc ann -> Doc ann
parensIf (Int
d forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$ Doc ann
"constrained $ \\" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow Var a
x forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"->" forall ann. Doc ann -> Doc ann -> Doc ann
/> forall a ann. Pretty a => a -> Doc ann
pretty Pred fn
p
    -- TODO: require pretty for `TypeSpec` to make this much nicer
    TypeSpec TypeSpec fn a
ts OrdSet a
cant ->
      forall ann. Bool -> Doc ann -> Doc ann
parensIf (Int
d forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$
        Doc ann
"TypeSpec"
          forall ann. Doc ann -> Doc ann -> Doc ann
/> forall ann. [Doc ann] -> Doc ann
vsep
            [ forall a. IsString a => [Char] -> a
fromString (forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 TypeSpec fn a
ts [Char]
"")
            , forall a ann. Show a => a -> Doc ann
viaShow OrdSet a
cant
            ]

instance HasSpec fn a => Pretty (Specification fn a) where
  pretty :: forall ann. Specification fn a -> Doc ann
pretty = forall a ann. Pretty a => a -> Doc ann
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> a -> WithPrec a
WithPrec Int
0

instance HasSpec fn a => Show (Specification fn a) where
  showsPrec :: Int -> Specification fn a -> ShowS
showsPrec Int
d = forall a. Show a => a -> ShowS
shows forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> a -> WithPrec a
WithPrec Int
d

instance Pretty (Var a) where
  pretty :: forall ann. Var a -> Doc ann
pretty = forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show

instance Pretty (Name fn) where
  pretty :: forall ann. Name fn -> Doc ann
pretty (Name Var a
v) = forall a ann. Pretty a => a -> Doc ann
pretty Var a
v

-- ======================================================================
-- Size and its 'generic' operations over Sized types.
-- ======================================================================

-- type Size = Integer

-- | Because Sizes should always be >= 0, We provide this alternate generator
--   that can be used to replace (genFromSpecT @Integer), to ensure this important property
genFromSizeSpec :: (BaseUniverse fn, MonadGenError m) => Specification fn Integer -> GenT m Integer
genFromSizeSpec :: forall (fn :: [*] -> * -> *) (m :: * -> *).
(BaseUniverse fn, MonadGenError m) =>
Specification fn Integer -> GenT m Integer
genFromSizeSpec Specification fn Integer
integerSpec = forall (fn :: [*] -> * -> *) a (m :: * -> *).
(HasCallStack, HasSpec fn a, MonadGenError m) =>
Specification fn a -> GenT m a
genFromSpecT (Specification fn Integer
integerSpec forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
geqSpec Integer
0)

data SizeFn (fn :: [Type] -> Type -> Type) as b where
  SizeOf :: forall fn a. (Sized fn a, HasSpec fn a) => SizeFn fn '[a] Integer

deriving instance Eq (SizeFn fn as b)
deriving instance Show (SizeFn fn as b)

instance FunctionLike (SizeFn fn) where
  sem :: forall (as :: [*]) b. SizeFn fn as b -> FunTy as b
sem SizeFn fn as b
SizeOf = forall (fn :: [*] -> * -> *) t. Sized fn t => t -> Integer
sizeOf @fn -- From the Sized class

sizeOfFn :: forall fn a. (HasSpec fn a, Member (SizeFn fn) fn, Sized fn a) => fn '[a] Integer
sizeOfFn :: forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, Member (SizeFn fn) fn, Sized fn a) =>
fn '[a] Integer
sizeOfFn = forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fn as b -> fnU as b
injectFn forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
(Sized fn a, HasSpec fn a) =>
SizeFn fn '[a] Integer
SizeOf @fn @a

-- Operations on Size (specified in SizeFn) by the Functions instance

instance (BaseUniverse fn, HasSpec fn Integer) => Functions (SizeFn fn) fn where
  propagateSpecFun :: forall (as :: [*]) a b.
(TypeList as, Typeable as, HasSpec fn a, HasSpec fn b,
 All (HasSpec fn) as) =>
SizeFn fn as b
-> ListCtx Value as (HOLE a)
-> Specification fn b
-> Specification fn a
propagateSpecFun SizeFn fn as b
_ ListCtx Value as (HOLE a)
_ Specification fn b
TrueSpec = forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec
  propagateSpecFun SizeFn fn as b
fn ListCtx Value as (HOLE a)
ctx (ExplainSpec [[Char]]
es Specification fn b
s) = forall (fn :: [*] -> * -> *) a.
[[Char]] -> Specification fn a -> Specification fn a
explainSpecOpt [[Char]]
es forall a b. (a -> b) -> a -> b
$ forall (f :: [*] -> * -> *) (fn :: [*] -> * -> *) (as :: [*]) a b.
(Functions f fn, TypeList as, Typeable as, HasSpec fn a,
 HasSpec fn b, All (HasSpec fn) as) =>
f as b
-> ListCtx Value as (HOLE a)
-> Specification fn b
-> Specification fn a
propagateSpecFun SizeFn fn as b
fn ListCtx Value as (HOLE a)
ctx Specification fn b
s
  propagateSpecFun SizeFn fn as b
_ ListCtx Value as (HOLE a)
_ (ErrorSpec NonEmpty [Char]
err) = forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec NonEmpty [Char]
err
  propagateSpecFun SizeFn fn as b
fn (ListCtx List Value as
pre HOLE a a
HOLE List Value as'
suf) (SuspendedSpec Var b
x Pred fn
p) =
    forall a (fn :: [*] -> * -> *) p.
(IsPred p fn, HasSpec fn a) =>
(Term fn a -> p) -> Specification fn a
constrained forall a b. (a -> b) -> a -> b
$ \Term fn a
x' ->
      let args :: List (Term fn) (Append as (a : as'))
args = forall {a} (f :: a -> *) (as :: [a]) (bs :: [a]).
List f as -> List f bs -> List f (Append as bs)
appendList (forall {k} (f :: k -> *) (g :: k -> *) (as :: [k]).
(forall (a :: k). f a -> g a) -> List f as -> List g as
mapList (\(Value a
a) -> forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit a
a) List Value as
pre) (Term fn a
x' forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> forall {k} (f :: k -> *) (g :: k -> *) (as :: [k]).
(forall (a :: k). f a -> g a) -> List f as -> List g as
mapList (\(Value a
a) -> forall a (fn :: [*] -> * -> *). Show a => a -> Term fn a
Lit a
a) List Value as'
suf)
       in forall (fn :: [*] -> * -> *) a. Term fn a -> Binder fn a -> Pred fn
Let (forall (a :: [*]) (fn :: [*] -> * -> *) b.
(Typeable a, TypeList a, All (HasSpec fn) a, HasSpec fn b,
 BaseUniverse fn) =>
fn a b -> List (Term fn) a -> Term fn b
App (forall (fn :: [*] -> * -> *) (fnU :: [*] -> * -> *) (as :: [*]) b.
Member fn fnU =>
fn as b -> fnU as b
injectFn SizeFn fn as b
fn) List (Term fn) (Append as (a : as'))
args) (Var b
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Binder fn a
:-> Pred fn
p)
  -- TODO: there is a bug here! Need to account for the `cant` set!
  propagateSpecFun SizeFn fn as b
SizeOf (NilCtx HOLE a a
HOLE) (TypeSpec TypeSpec fn b
x OrdSet b
cant) = forall (fn :: [*] -> * -> *) t.
(Sized fn t, HasSpec fn t) =>
SizeSpec fn -> [Integer] -> Specification fn t
liftSizeSpec TypeSpec fn b
x OrdSet b
cant
  propagateSpecFun SizeFn fn as b
SizeOf (NilCtx HOLE a a
HOLE) (MemberSpec NonEmpty b
xs) = forall (fn :: [*] -> * -> *) t.
(Sized fn t, HasSpec fn t) =>
[Integer] -> Specification fn t
liftMemberSpec (forall a. NonEmpty a -> [a]
NE.toList NonEmpty b
xs)

  mapTypeSpec :: forall a b.
(HasSpec fn a, HasSpec fn b) =>
SizeFn fn '[a] b -> TypeSpec fn a -> Specification fn b
mapTypeSpec SizeFn fn '[a] b
f TypeSpec fn a
ts = forall (fn :: [*] -> * -> *) a b (f :: [*] -> * -> *).
(f ~ SizeFn fn) =>
f '[a] b -> TypeSpec fn a -> Specification fn b
mapTypeSpecSize SizeFn fn '[a] b
f TypeSpec fn a
ts

mapTypeSpecSize :: forall fn a b f. f ~ SizeFn fn => f '[a] b -> TypeSpec fn a -> Specification fn b
mapTypeSpecSize :: forall (fn :: [*] -> * -> *) a b (f :: [*] -> * -> *).
(f ~ SizeFn fn) =>
f '[a] b -> TypeSpec fn a -> Specification fn b
mapTypeSpecSize f '[a] b
f TypeSpec fn a
ts = case f '[a] b
f of
  f '[a] b
SizeFn fn '[a] b
SizeOf ->
    forall a (fn :: [*] -> * -> *) p.
(IsPred p fn, HasSpec fn a) =>
(Term fn a -> p) -> Specification fn a
constrained forall a b. (a -> b) -> a -> b
$ \Term fn b
x ->
      forall a p (fn :: [*] -> * -> *).
(HasSpec fn a, IsPred p fn) =>
(Term fn a -> p) -> Pred fn
unsafeExists forall a b. (a -> b) -> a -> b
$ \Term fn a
x' ->
        forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
p -> Pred fn
assert (Term fn b
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Term fn a -> Term fn Bool
==. forall a (fn :: [*] -> * -> *).
(HasSpec fn a, Sized fn a) =>
Term fn a -> Term fn Integer
sizeOf_ Term fn a
x') forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> TypeSpec fn a -> Pred fn
toPreds @fn @a Term fn a
x' TypeSpec fn a
ts

-- ======================================
type SizeSpec fn = NumSpec fn Integer

rangeSize :: Integer -> Integer -> SizeSpec fn
rangeSize :: forall (fn :: [*] -> * -> *). Integer -> Integer -> SizeSpec fn
rangeSize Integer
a Integer
b | Integer
a forall a. Ord a => a -> a -> Bool
< Integer
0 Bool -> Bool -> Bool
|| Integer
b forall a. Ord a => a -> a -> Bool
< Integer
0 = forall a. HasCallStack => [Char] -> a
error ([Char]
"Negative Int in call to rangeSize: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Integer
a forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Integer
b)
rangeSize Integer
a Integer
b = forall (fn :: [*] -> * -> *) n. Maybe n -> Maybe n -> NumSpec fn n
NumSpecInterval (forall a. a -> Maybe a
Just Integer
a) (forall a. a -> Maybe a
Just Integer
b)

-- | The widest interval whose largest element is admitted by the original spec
maxSpec :: BaseUniverse fn => Specification fn Integer -> Specification fn Integer
maxSpec :: forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Specification fn Integer -> Specification fn Integer
maxSpec (ExplainSpec [[Char]]
es Specification fn Integer
s) = forall (fn :: [*] -> * -> *) a.
[[Char]] -> Specification fn a -> Specification fn a
explainSpecOpt [[Char]]
es (forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Specification fn Integer -> Specification fn Integer
maxSpec Specification fn Integer
s)
maxSpec Specification fn Integer
TrueSpec = forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec
maxSpec s :: Specification fn Integer
s@(SuspendedSpec Var Integer
_ Pred fn
_) =
  forall a (fn :: [*] -> * -> *) p.
(IsPred p fn, HasSpec fn a) =>
(Term fn a -> p) -> Specification fn a
constrained forall a b. (a -> b) -> a -> b
$ \Term fn Integer
x -> forall a p (fn :: [*] -> * -> *).
(HasSpec fn a, IsPred p fn) =>
(Term fn a -> p) -> Pred fn
unsafeExists forall a b. (a -> b) -> a -> b
$ \Term fn Integer
y -> [Term fn Integer
y forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Specification fn a -> Pred fn
`satisfies` Specification fn Integer
s, forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn -> Pred fn
Explain (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"maxSpec on SuspendedSpec") forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Term fn Bool -> Pred fn
Assert (Term fn Integer
x forall a (fn :: [*] -> * -> *).
(Ord a, OrdLike fn a) =>
Term fn a -> Term fn a -> Term fn Bool
<=. Term fn Integer
y)]
maxSpec (ErrorSpec NonEmpty [Char]
xs) = forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec NonEmpty [Char]
xs
maxSpec (MemberSpec NonEmpty Integer
xs) = forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
leqSpec (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum NonEmpty Integer
xs)
maxSpec (TypeSpec (NumSpecInterval Maybe Integer
_ Maybe Integer
hi) [Integer]
bad) = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> OrdSet a -> Specification fn a
TypeSpec (forall (fn :: [*] -> * -> *) n. Maybe n -> Maybe n -> NumSpec fn n
NumSpecInterval forall a. Maybe a
Nothing Maybe Integer
hi) [Integer]
bad

-- ================
-- Sized
-- ================

class Sized fn t where
  sizeOf :: t -> Integer
  default sizeOf :: (HasSimpleRep t, Sized fn (SimpleRep t)) => t -> Integer
  sizeOf = forall (fn :: [*] -> * -> *) t. Sized fn t => t -> Integer
sizeOf @fn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasSimpleRep a => a -> SimpleRep a
toSimpleRep

  liftSizeSpec :: HasSpec fn t => SizeSpec fn -> [Integer] -> Specification fn t
  default liftSizeSpec ::
    ( HasSpec fn t
    , HasSimpleRep t
    , Sized fn (SimpleRep t)
    , HasSpec fn (SimpleRep t)
    , TypeSpec fn t ~ TypeSpec fn (SimpleRep t)
    ) =>
    SizeSpec fn -> [Integer] -> Specification fn t
  liftSizeSpec SizeSpec fn
sz [Integer]
cant = forall a (fn :: [*] -> * -> *).
(HasSpec fn a, HasSimpleRep a,
 TypeSpec fn a ~ TypeSpec fn (SimpleRep a)) =>
Specification fn (SimpleRep a) -> Specification fn a
fromSimpleRepSpec forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) t.
(Sized fn t, HasSpec fn t) =>
SizeSpec fn -> [Integer] -> Specification fn t
liftSizeSpec SizeSpec fn
sz [Integer]
cant

  liftMemberSpec :: HasSpec fn t => OrdSet Integer -> Specification fn t
  default liftMemberSpec ::
    ( HasSpec fn t
    , HasSpec fn (SimpleRep t)
    , HasSimpleRep t
    , Sized fn (SimpleRep t)
    , TypeSpec fn t ~ TypeSpec fn (SimpleRep t)
    ) =>
    OrdSet Integer -> Specification fn t
  liftMemberSpec = forall a (fn :: [*] -> * -> *).
(HasSpec fn a, HasSimpleRep a,
 TypeSpec fn a ~ TypeSpec fn (SimpleRep a)) =>
Specification fn (SimpleRep a) -> Specification fn a
fromSimpleRepSpec forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fn :: [*] -> * -> *) t.
(Sized fn t, HasSpec fn t) =>
[Integer] -> Specification fn t
liftMemberSpec

  sizeOfTypeSpec :: HasSpec fn t => TypeSpec fn t -> Specification fn Integer
  default sizeOfTypeSpec ::
    ( HasSpec fn t
    , HasSpec fn (SimpleRep t)
    , HasSimpleRep t
    , Sized fn (SimpleRep t)
    , TypeSpec fn t ~ TypeSpec fn (SimpleRep t)
    ) =>
    TypeSpec fn t -> Specification fn Integer
  sizeOfTypeSpec = forall (fn :: [*] -> * -> *) t.
(Sized fn t, HasSpec fn t) =>
TypeSpec fn t -> Specification fn Integer
sizeOfTypeSpec @fn @(SimpleRep t)

instance Ord a => Sized fn (Set.Set a) where
  sizeOf :: Set a -> Integer
sizeOf = forall a. Integral a => a -> Integer
toInteger forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Int
Set.size
  liftSizeSpec :: HasSpec fn (Set a) =>
SizeSpec fn -> [Integer] -> Specification fn (Set a)
liftSizeSpec SizeSpec fn
spec [Integer]
cant = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec (forall (fn :: [*] -> * -> *) a.
Set a
-> Specification fn a -> Specification fn Integer -> SetSpec fn a
SetSpec forall a. Monoid a => a
mempty forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> OrdSet a -> Specification fn a
TypeSpec SizeSpec fn
spec [Integer]
cant))
  liftMemberSpec :: HasSpec fn (Set a) => [Integer] -> Specification fn (Set a)
liftMemberSpec [Integer]
xs = case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Integer]
xs of
    Maybe (NonEmpty Integer)
Nothing -> forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
"In liftMemberSpec for the (Sized Set) instance, xs is the empty list"))
    Just NonEmpty Integer
zs -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec (forall (fn :: [*] -> * -> *) a.
Set a
-> Specification fn a -> Specification fn Integer -> SetSpec fn a
SetSpec forall a. Monoid a => a
mempty forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec (forall a (fn :: [*] -> * -> *). NonEmpty a -> Specification fn a
MemberSpec NonEmpty Integer
zs))
  sizeOfTypeSpec :: HasSpec fn (Set a) =>
TypeSpec fn (Set a) -> Specification fn Integer
sizeOfTypeSpec (SetSpec Set a
must Specification fn a
_ Specification fn Integer
sz) = Specification fn Integer
sz forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
geqSpec (forall (fn :: [*] -> * -> *) t. Sized fn t => t -> Integer
sizeOf Set a
must)

instance Sized fn [a] where
  sizeOf :: [a] -> Integer
sizeOf = forall a. Integral a => a -> Integer
toInteger forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length
  liftSizeSpec :: HasSpec fn [a] => SizeSpec fn -> [Integer] -> Specification fn [a]
liftSizeSpec SizeSpec fn
spec [Integer]
cant = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec (forall (fn :: [*] -> * -> *) a.
Maybe Integer
-> [a]
-> Specification fn Integer
-> Specification fn a
-> FoldSpec fn a
-> ListSpec fn a
ListSpec forall a. Maybe a
Nothing forall a. Monoid a => a
mempty (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> OrdSet a -> Specification fn a
TypeSpec SizeSpec fn
spec [Integer]
cant) forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec forall (fn :: [*] -> * -> *) a. FoldSpec fn a
NoFold)
  liftMemberSpec :: HasSpec fn [a] => [Integer] -> Specification fn [a]
liftMemberSpec [Integer]
xs = case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Integer]
xs of
    Maybe (NonEmpty Integer)
Nothing -> forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
"In liftMemberSpec for (Sized List) instance, xs is the empty list"))
    Just NonEmpty Integer
zs -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec (forall (fn :: [*] -> * -> *) a.
Maybe Integer
-> [a]
-> Specification fn Integer
-> Specification fn a
-> FoldSpec fn a
-> ListSpec fn a
ListSpec forall a. Maybe a
Nothing forall a. Monoid a => a
mempty (forall a (fn :: [*] -> * -> *). NonEmpty a -> Specification fn a
MemberSpec NonEmpty Integer
zs) forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec forall (fn :: [*] -> * -> *) a. FoldSpec fn a
NoFold)
  sizeOfTypeSpec :: HasSpec fn [a] => TypeSpec fn [a] -> Specification fn Integer
sizeOfTypeSpec (ListSpec Maybe Integer
_ [a]
_ Specification fn Integer
_ ErrorSpec {} FoldSpec fn a
_) = forall a (fn :: [*] -> * -> *). a -> Specification fn a
equalSpec Integer
0
  sizeOfTypeSpec (ListSpec Maybe Integer
_ [a]
must Specification fn Integer
sizespec Specification fn a
_ FoldSpec fn a
_) = Specification fn Integer
sizespec forall a. Semigroup a => a -> a -> a
<> forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
geqSpec (forall (fn :: [*] -> * -> *) t. Sized fn t => t -> Integer
sizeOf [a]
must)

-- How to constrain the size of any type, with a Sized instance
hasSize :: (HasSpec fn t, Sized fn t) => SizeSpec fn -> Specification fn t
hasSize :: forall (fn :: [*] -> * -> *) t.
(HasSpec fn t, Sized fn t) =>
SizeSpec fn -> Specification fn t
hasSize SizeSpec fn
sz = forall (fn :: [*] -> * -> *) t.
(Sized fn t, HasSpec fn t) =>
SizeSpec fn -> [Integer] -> Specification fn t
liftSizeSpec SizeSpec fn
sz []

-- ==================================================================================
-- (NumSpec fn Integer) can support interval arithmetic, so we can make a (Num (NumSpec fn Integer)) instance
-- Given operator ☉, then (a,b) ☉ (c,d) = (minimum s, maximum s) where s = [a ☉ c, a ☉ d, b ☉ c, b ☉ d]
-- There are simpler rules for (+) and (-), but for (*) we need to use the general rule.

guardEmpty :: Maybe Integer -> Maybe Integer -> NumSpec fn Integer -> NumSpec fn Integer
guardEmpty :: forall (fn :: [*] -> * -> *).
Maybe Integer
-> Maybe Integer -> NumSpec fn Integer -> NumSpec fn Integer
guardEmpty (Just Integer
a) (Just Integer
b) NumSpec fn Integer
s
  | Integer
a forall a. Ord a => a -> a -> Bool
<= Integer
b = NumSpec fn Integer
s
  | Bool
otherwise = forall (fn :: [*] -> * -> *) n. Maybe n -> Maybe n -> NumSpec fn n
NumSpecInterval (forall a. a -> Maybe a
Just Integer
1) (forall a. a -> Maybe a
Just Integer
0)
guardEmpty Maybe Integer
_ Maybe Integer
_ NumSpec fn Integer
s = NumSpec fn Integer
s

addNumSpec :: NumSpec fn Integer -> NumSpec fn Integer -> NumSpec fn Integer
addNumSpec :: forall (fn :: [*] -> * -> *).
NumSpec fn Integer -> NumSpec fn Integer -> NumSpec fn Integer
addNumSpec (NumSpecInterval Maybe Integer
x Maybe Integer
y) (NumSpecInterval Maybe Integer
a Maybe Integer
b) =
  forall (fn :: [*] -> * -> *).
Maybe Integer
-> Maybe Integer -> NumSpec fn Integer -> NumSpec fn Integer
guardEmpty Maybe Integer
x Maybe Integer
y forall a b. (a -> b) -> a -> b
$
    forall (fn :: [*] -> * -> *).
Maybe Integer
-> Maybe Integer -> NumSpec fn Integer -> NumSpec fn Integer
guardEmpty Maybe Integer
a Maybe Integer
b forall a b. (a -> b) -> a -> b
$
      forall (fn :: [*] -> * -> *) n. Maybe n -> Maybe n -> NumSpec fn n
NumSpecInterval (forall a. Num a => a -> a -> a
(+) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Integer
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Integer
a) (forall a. Num a => a -> a -> a
(+) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Integer
y forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Integer
b)

subNumSpec :: NumSpec fn Integer -> NumSpec fn Integer -> NumSpec fn Integer
subNumSpec :: forall (fn :: [*] -> * -> *).
NumSpec fn Integer -> NumSpec fn Integer -> NumSpec fn Integer
subNumSpec (NumSpecInterval Maybe Integer
x Maybe Integer
y) (NumSpecInterval Maybe Integer
a Maybe Integer
b) =
  forall (fn :: [*] -> * -> *).
Maybe Integer
-> Maybe Integer -> NumSpec fn Integer -> NumSpec fn Integer
guardEmpty Maybe Integer
x Maybe Integer
y forall a b. (a -> b) -> a -> b
$
    forall (fn :: [*] -> * -> *).
Maybe Integer
-> Maybe Integer -> NumSpec fn Integer -> NumSpec fn Integer
guardEmpty Maybe Integer
a Maybe Integer
b forall a b. (a -> b) -> a -> b
$
      forall (fn :: [*] -> * -> *) n. Maybe n -> Maybe n -> NumSpec fn n
NumSpecInterval ((-) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Integer
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Integer
b) ((-) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Integer
y forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Integer
a)

multNumSpec :: NumSpec fn Integer -> NumSpec fn Integer -> NumSpec fn Integer
multNumSpec :: forall (fn :: [*] -> * -> *).
NumSpec fn Integer -> NumSpec fn Integer -> NumSpec fn Integer
multNumSpec (NumSpecInterval Maybe Integer
a Maybe Integer
b) (NumSpecInterval Maybe Integer
c Maybe Integer
d) =
  forall (fn :: [*] -> * -> *).
Maybe Integer
-> Maybe Integer -> NumSpec fn Integer -> NumSpec fn Integer
guardEmpty Maybe Integer
a Maybe Integer
b forall a b. (a -> b) -> a -> b
$
    forall (fn :: [*] -> * -> *).
Maybe Integer
-> Maybe Integer -> NumSpec fn Integer -> NumSpec fn Integer
guardEmpty Maybe Integer
c Maybe Integer
d forall a b. (a -> b) -> a -> b
$
      forall (fn :: [*] -> * -> *) n. Maybe n -> Maybe n -> NumSpec fn n
NumSpecInterval (forall x. T x -> Maybe x
unT (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [T Integer]
s)) (forall x. T x -> Maybe x
unT (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [T Integer]
s))
  where
    s :: [T Integer]
s = [forall x. Num x => T x -> T x -> T x
multT (forall x. Maybe x -> T x
neg Maybe Integer
a) (forall x. Maybe x -> T x
neg Maybe Integer
c), forall x. Num x => T x -> T x -> T x
multT (forall x. Maybe x -> T x
neg Maybe Integer
a) (forall x. Maybe x -> T x
pos Maybe Integer
d), forall x. Num x => T x -> T x -> T x
multT (forall x. Maybe x -> T x
pos Maybe Integer
b) (forall x. Maybe x -> T x
neg Maybe Integer
c), forall x. Num x => T x -> T x -> T x
multT (forall x. Maybe x -> T x
pos Maybe Integer
b) (forall x. Maybe x -> T x
pos Maybe Integer
d)]

negNumSpec :: NumSpec fn Integer -> NumSpec fn Integer
negNumSpec :: forall (fn :: [*] -> * -> *).
NumSpec fn Integer -> NumSpec fn Integer
negNumSpec (NumSpecInterval Maybe Integer
lo Maybe Integer
hi) = forall (fn :: [*] -> * -> *) n. Maybe n -> Maybe n -> NumSpec fn n
NumSpecInterval (forall a. Num a => a -> a
negate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Integer
hi) (forall a. Num a => a -> a
negate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Integer
lo)

instance Num (NumSpec fn Integer) where
  + :: NumSpec fn Integer -> NumSpec fn Integer -> NumSpec fn Integer
(+) = forall (fn :: [*] -> * -> *).
NumSpec fn Integer -> NumSpec fn Integer -> NumSpec fn Integer
addNumSpec
  (-) = forall (fn :: [*] -> * -> *).
NumSpec fn Integer -> NumSpec fn Integer -> NumSpec fn Integer
subNumSpec
  * :: NumSpec fn Integer -> NumSpec fn Integer -> NumSpec fn Integer
(*) = forall (fn :: [*] -> * -> *).
NumSpec fn Integer -> NumSpec fn Integer -> NumSpec fn Integer
multNumSpec
  negate :: NumSpec fn Integer -> NumSpec fn Integer
negate = forall (fn :: [*] -> * -> *).
NumSpec fn Integer -> NumSpec fn Integer
negNumSpec
  fromInteger :: Integer -> NumSpec fn Integer
fromInteger Integer
n = forall (fn :: [*] -> * -> *) n. Maybe n -> Maybe n -> NumSpec fn n
NumSpecInterval (forall a. a -> Maybe a
Just (forall a. Num a => Integer -> a
fromInteger Integer
n)) (forall a. a -> Maybe a
Just (forall a. Num a => Integer -> a
fromInteger Integer
n))
  abs :: NumSpec fn Integer -> NumSpec fn Integer
abs = forall a. HasCallStack => [Char] -> a
error [Char]
"No abs in the Num (NumSpec fn Integer) instance"
  signum :: NumSpec fn Integer -> NumSpec fn Integer
signum = forall a. HasCallStack => [Char] -> a
error [Char]
"No signum in the Num (NumSpec fn Integer) instance"

-- ========================================================================
-- To implement the (HasSpec fn t) method: cardinalTypeSpec :: HasSpec fn a => TypeSpec fn a -> Specification fn Integer
-- We are going to need some arithmetic-like operations on (Specification fn Integer)
-- We will need instance equations like these in some HasSpec instances
--
-- cardinalTypeSpec (Cartesian x y) = 'multSpecInt' (cardinality x) (cardinality y)
--
-- cardinalTypeSpec (SumSpec leftspec rightspec) = 'addSpecInt' (cardinality leftspec) (cardinality rightspec)
--
-- To get those functions, we are going to have to lift opertions on (TypeSpec fn Integer) to (Specification fn Integer)

addSpecInt ::
  BaseUniverse fn => Specification fn Integer -> Specification fn Integer -> Specification fn Integer
addSpecInt :: forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Specification fn Integer
-> Specification fn Integer -> Specification fn Integer
addSpecInt Specification fn Integer
x Specification fn Integer
y = forall (fn :: [*] -> * -> *) n.
(TypeSpec fn n ~ NumSpec fn n, Enum n, Ord n, HasSpec fn n) =>
[Char]
-> (n -> n -> n)
-> (TypeSpec fn n -> TypeSpec fn n -> TypeSpec fn n)
-> Specification fn n
-> Specification fn n
-> Specification fn n
operateSpec [Char]
" + " forall a. Num a => a -> a -> a
(+) forall a. Num a => a -> a -> a
(+) Specification fn Integer
x Specification fn Integer
y

subSpecInt ::
  BaseUniverse fn => Specification fn Integer -> Specification fn Integer -> Specification fn Integer
subSpecInt :: forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Specification fn Integer
-> Specification fn Integer -> Specification fn Integer
subSpecInt Specification fn Integer
x Specification fn Integer
y = forall (fn :: [*] -> * -> *) n.
(TypeSpec fn n ~ NumSpec fn n, Enum n, Ord n, HasSpec fn n) =>
[Char]
-> (n -> n -> n)
-> (TypeSpec fn n -> TypeSpec fn n -> TypeSpec fn n)
-> Specification fn n
-> Specification fn n
-> Specification fn n
operateSpec [Char]
" - " (-) (-) Specification fn Integer
x Specification fn Integer
y

multSpecInt ::
  BaseUniverse fn => Specification fn Integer -> Specification fn Integer -> Specification fn Integer
multSpecInt :: forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Specification fn Integer
-> Specification fn Integer -> Specification fn Integer
multSpecInt Specification fn Integer
x Specification fn Integer
y = forall (fn :: [*] -> * -> *) n.
(TypeSpec fn n ~ NumSpec fn n, Enum n, Ord n, HasSpec fn n) =>
[Char]
-> (n -> n -> n)
-> (TypeSpec fn n -> TypeSpec fn n -> TypeSpec fn n)
-> Specification fn n
-> Specification fn n
-> Specification fn n
operateSpec [Char]
" * " forall a. Num a => a -> a -> a
(*) forall a. Num a => a -> a -> a
(*) Specification fn Integer
x Specification fn Integer
y

-- | let 'n' be some numeric type, and 'f' and 'ft' be operations on 'n' and (TypeSpec fn n)
--   Then lift these operations from (TypeSpec fn n) to (Specification fn n)
--   Normally 'f' will be a (Num n) instance method (+,-,*) on n,
--   and 'ft' will be a a (Num (TypeSpec fn n)) instance method (+,-,*) on (TypeSpec fn n)
--   But this will work for any operations 'f' and 'ft' with the right types
operateSpec ::
  (TypeSpec fn n ~ NumSpec fn n, Enum n, Ord n, HasSpec fn n) =>
  String ->
  (n -> n -> n) ->
  (TypeSpec fn n -> TypeSpec fn n -> TypeSpec fn n) ->
  Specification fn n ->
  Specification fn n ->
  Specification fn n
operateSpec :: forall (fn :: [*] -> * -> *) n.
(TypeSpec fn n ~ NumSpec fn n, Enum n, Ord n, HasSpec fn n) =>
[Char]
-> (n -> n -> n)
-> (TypeSpec fn n -> TypeSpec fn n -> TypeSpec fn n)
-> Specification fn n
-> Specification fn n
-> Specification fn n
operateSpec [Char]
operator n -> n -> n
f TypeSpec fn n -> TypeSpec fn n -> TypeSpec fn n
ft (ExplainSpec [[Char]]
es Specification fn n
x) Specification fn n
y = forall (fn :: [*] -> * -> *) a.
[[Char]] -> Specification fn a -> Specification fn a
explainSpecOpt [[Char]]
es forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) n.
(TypeSpec fn n ~ NumSpec fn n, Enum n, Ord n, HasSpec fn n) =>
[Char]
-> (n -> n -> n)
-> (TypeSpec fn n -> TypeSpec fn n -> TypeSpec fn n)
-> Specification fn n
-> Specification fn n
-> Specification fn n
operateSpec [Char]
operator n -> n -> n
f TypeSpec fn n -> TypeSpec fn n -> TypeSpec fn n
ft Specification fn n
x Specification fn n
y
operateSpec [Char]
operator n -> n -> n
f TypeSpec fn n -> TypeSpec fn n -> TypeSpec fn n
ft Specification fn n
x (ExplainSpec [[Char]]
es Specification fn n
y) = forall (fn :: [*] -> * -> *) a.
[[Char]] -> Specification fn a -> Specification fn a
explainSpecOpt [[Char]]
es forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) n.
(TypeSpec fn n ~ NumSpec fn n, Enum n, Ord n, HasSpec fn n) =>
[Char]
-> (n -> n -> n)
-> (TypeSpec fn n -> TypeSpec fn n -> TypeSpec fn n)
-> Specification fn n
-> Specification fn n
-> Specification fn n
operateSpec [Char]
operator n -> n -> n
f TypeSpec fn n -> TypeSpec fn n -> TypeSpec fn n
ft Specification fn n
x Specification fn n
y
operateSpec [Char]
operator n -> n -> n
f TypeSpec fn n -> TypeSpec fn n -> TypeSpec fn n
ft Specification fn n
x Specification fn n
y = case (Specification fn n
x, Specification fn n
y) of
  (ErrorSpec NonEmpty [Char]
xs, ErrorSpec NonEmpty [Char]
ys) -> forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec (NonEmpty [Char]
xs forall a. Semigroup a => a -> a -> a
<> NonEmpty [Char]
ys)
  (ErrorSpec NonEmpty [Char]
xs, Specification fn n
_) -> forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec NonEmpty [Char]
xs
  (Specification fn n
_, ErrorSpec NonEmpty [Char]
ys) -> forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec NonEmpty [Char]
ys
  (Specification fn n
TrueSpec, Specification fn n
_) -> forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec
  (Specification fn n
_, Specification fn n
TrueSpec) -> forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec
  (Specification fn n
_, SuspendedSpec Var n
_ Pred fn
_) -> forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec
  (SuspendedSpec Var n
_ Pred fn
_, Specification fn n
_) -> forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec
  (TypeSpec TypeSpec fn n
x OrdSet n
bad1, TypeSpec TypeSpec fn n
y OrdSet n
bad2) -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> OrdSet a -> Specification fn a
TypeSpec (TypeSpec fn n -> TypeSpec fn n -> TypeSpec fn n
ft TypeSpec fn n
x TypeSpec fn n
y) [n -> n -> n
f n
b1 n
b2 | n
b1 <- OrdSet n
bad1, n
b2 <- OrdSet n
bad2]
  (MemberSpec NonEmpty n
xs, MemberSpec NonEmpty n
ys) ->
    forall a (fn :: [*] -> * -> *).
Ord a =>
[Char] -> [a] -> Specification fn a
nubOrdMemberSpec
      (forall a. Show a => a -> [Char]
show Specification fn n
x forall a. [a] -> [a] -> [a]
++ [Char]
operator forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn n
y)
      [n -> n -> n
f n
x n
y | n
x <- forall a. NonEmpty a -> [a]
NE.toList NonEmpty n
xs, n
y <- forall a. NonEmpty a -> [a]
NE.toList NonEmpty n
ys]
  -- This block is all (MemberSpec{}, TypeSpec{}) with MemberSpec on the left
  (MemberSpec NonEmpty n
ys, TypeSpec (NumSpecInterval (Just n
i) (Just n
j)) OrdSet n
bad) ->
    let xs :: OrdSet n
xs = forall a. NonEmpty a -> [a]
NE.toList NonEmpty n
ys
     in forall a (fn :: [*] -> * -> *).
Ord a =>
[Char] -> [a] -> Specification fn a
nubOrdMemberSpec
          (forall a. Show a => a -> [Char]
show Specification fn n
x forall a. [a] -> [a] -> [a]
++ [Char]
operator forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn n
y)
          [n -> n -> n
f n
x n
y | n
x <- OrdSet n
xs, n
y <- [n
i .. n
j], Bool -> Bool
not (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem n
y OrdSet n
bad)]
  -- Somewhat loose spec here, but more accurate then TrueSpec, it is exact if 'xs' has one element (i.e. 'xs' = [i])
  (MemberSpec NonEmpty n
ys, TypeSpec (NumSpecInterval Maybe n
lo Maybe n
hi) OrdSet n
bads) ->
    -- We use the specialized version of 'TypeSpec' 'typeSpecOpt'
    let xs :: OrdSet n
xs = forall a. NonEmpty a -> [a]
NE.toList NonEmpty n
ys
     in forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> OrdSet a -> Specification fn a
typeSpecOpt
          (forall (fn :: [*] -> * -> *) n. Maybe n -> Maybe n -> NumSpec fn n
NumSpecInterval (n -> n -> n
f (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum OrdSet n
xs) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe n
lo) (n -> n -> n
f (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum OrdSet n
xs) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe n
hi))
          [n -> n -> n
f n
x n
b | n
x <- OrdSet n
xs, n
b <- OrdSet n
bads]
  -- we flip the arguments, so we need to flip the functions as well
  (Specification fn n
x, Specification fn n
y) -> forall (fn :: [*] -> * -> *) n.
(TypeSpec fn n ~ NumSpec fn n, Enum n, Ord n, HasSpec fn n) =>
[Char]
-> (n -> n -> n)
-> (TypeSpec fn n -> TypeSpec fn n -> TypeSpec fn n)
-> Specification fn n
-> Specification fn n
-> Specification fn n
operateSpec [Char]
operator (\n
a n
b -> n -> n -> n
f n
b n
a) (\TypeSpec fn n
u TypeSpec fn n
v -> TypeSpec fn n -> TypeSpec fn n -> TypeSpec fn n
ft TypeSpec fn n
v TypeSpec fn n
u) Specification fn n
y Specification fn n
x

-- =================================
-- Cardinality

-- | Put some (admittedly loose bounds) on the number of solutions that
--   'genFromTypeSpec' might return. For lots of types, there is no way to be very accurate.
--   Here we lift the HasSpec methods 'cardinalTrueSpec' and 'cardinalTypeSpec'
--   from (TypeSpec fn Integer) to (Specification fn Integer)
cardinality ::
  forall fn a. (Eq a, BaseUniverse fn, HasSpec fn a) => Specification fn a -> Specification fn Integer
cardinality :: forall (fn :: [*] -> * -> *) a.
(Eq a, BaseUniverse fn, HasSpec fn a) =>
Specification fn a -> Specification fn Integer
cardinality (ExplainSpec [[Char]]
es Specification fn a
s) = forall (fn :: [*] -> * -> *) a.
[[Char]] -> Specification fn a -> Specification fn a
explainSpecOpt [[Char]]
es (forall (fn :: [*] -> * -> *) a.
(Eq a, BaseUniverse fn, HasSpec fn a) =>
Specification fn a -> Specification fn Integer
cardinality Specification fn a
s)
cardinality Specification fn a
TrueSpec = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn Integer
cardinalTrueSpec @fn @a
cardinality (MemberSpec NonEmpty a
es) = forall a (fn :: [*] -> * -> *). a -> Specification fn a
equalSpec (forall (fn :: [*] -> * -> *) t. Sized fn t => t -> Integer
sizeOf (forall a. Eq a => [a] -> [a]
nub (forall a. NonEmpty a -> [a]
NE.toList NonEmpty a
es)))
cardinality ErrorSpec {} = forall a (fn :: [*] -> * -> *). a -> Specification fn a
equalSpec Integer
0
cardinality (TypeSpec TypeSpec fn a
s [a]
cant) =
  forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Specification fn Integer
-> Specification fn Integer -> Specification fn Integer
subSpecInt
    (forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn Integer
cardinalTypeSpec @fn @a TypeSpec fn a
s)
    (forall a (fn :: [*] -> * -> *). a -> Specification fn a
equalSpec (forall (fn :: [*] -> * -> *) t. Sized fn t => t -> Integer
sizeOf (forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (\a
c -> forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, HasCallStack) =>
a -> TypeSpec fn a -> Bool
conformsTo @fn @a a
c TypeSpec fn a
s) [a]
cant)))
cardinality SuspendedSpec {} = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Specification fn Integer
cardinalTrueSpec @fn @a

-- | A generic function to use as an instance for the HasSpec method
--   cardinalTypeSpec :: HasSpec fn a => TypeSpec fn a -> Specification fn Integer
--   for types 'n' such that (TypeSpec n ~ NumSpec n)
cardinalNumSpec ::
  forall n fn. (Integral n, Num n, MaybeBounded n) => NumSpec fn n -> Specification fn Integer
cardinalNumSpec :: forall n (fn :: [*] -> * -> *).
(Integral n, Num n, MaybeBounded n) =>
NumSpec fn n -> Specification fn Integer
cardinalNumSpec (NumSpecInterval (Just n
lo) (Just n
hi)) =
  if n
hi forall a. Ord a => a -> a -> Bool
>= n
lo then forall a (fn :: [*] -> * -> *). NonEmpty a -> Specification fn a
MemberSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Integral a => a -> Integer
toInteger n
hi forall a. Num a => a -> a -> a
- forall a. Integral a => a -> Integer
toInteger n
lo forall a. Num a => a -> a -> a
+ Integer
1)) else forall a (fn :: [*] -> * -> *). NonEmpty a -> Specification fn a
MemberSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
0)
cardinalNumSpec (NumSpecInterval Maybe n
Nothing (Just n
hi)) =
  case forall a. MaybeBounded a => Maybe a
lowerBound @n of
    Just n
lo -> forall a (fn :: [*] -> * -> *). NonEmpty a -> Specification fn a
MemberSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Integral a => a -> Integer
toInteger n
hi forall a. Num a => a -> a -> a
- forall a. Integral a => a -> Integer
toInteger n
lo))
    Maybe n
Nothing -> forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec
cardinalNumSpec (NumSpecInterval (Just n
lo) Maybe n
Nothing) =
  case forall a. MaybeBounded a => Maybe a
upperBound @n of
    Just n
hi -> forall a (fn :: [*] -> * -> *). NonEmpty a -> Specification fn a
MemberSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Integral a => a -> Integer
toInteger n
hi forall a. Num a => a -> a -> a
- forall a. Integral a => a -> Integer
toInteger n
lo))
    Maybe n
Nothing -> forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec
cardinalNumSpec (NumSpecInterval Maybe n
Nothing Maybe n
Nothing) = forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec

lowBound :: Bounded n => Maybe n -> n
lowBound :: forall n. Bounded n => Maybe n -> n
lowBound Maybe n
Nothing = forall a. Bounded a => a
minBound
lowBound (Just n
n) = n
n

highBound :: Bounded n => Maybe n -> n
highBound :: forall n. Bounded n => Maybe n -> n
highBound Maybe n
Nothing = forall a. Bounded a => a
maxBound
highBound (Just n
n) = n
n

-- | The exact count of the number elements in a Bounded NumSpec
countSpec :: forall n fn. (Bounded n, Integral n) => NumSpec fn n -> Integer
countSpec :: forall n (fn :: [*] -> * -> *).
(Bounded n, Integral n) =>
NumSpec fn n -> Integer
countSpec (NumSpecInterval Maybe n
lo Maybe n
hi) = if Maybe n
lo forall a. Ord a => a -> a -> Bool
> Maybe n
hi then Integer
0 else forall a. Integral a => a -> Integer
toInteger n
high forall a. Num a => a -> a -> a
- forall a. Integral a => a -> Integer
toInteger n
low forall a. Num a => a -> a -> a
+ Integer
1
  where
    high :: n
high = forall n. Bounded n => Maybe n -> n
highBound Maybe n
hi
    low :: n
low = forall n. Bounded n => Maybe n -> n
lowBound Maybe n
lo

-- | The exact number of elements in a Bounded Integral type.
finiteSize :: forall n. (Integral n, Bounded n) => Integer
finiteSize :: forall n. (Integral n, Bounded n) => Integer
finiteSize = forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
maxBound @n) forall a. Num a => a -> a -> a
- forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
minBound @n) forall a. Num a => a -> a -> a
+ Integer
1

-- | This is an optimizing version of  TypeSpec :: TypeSpec fn n -> [n] -> Specification fn n
--   for Bounded NumSpecs.
--                    notInNumSpec :: Bounded n => TypeSpec fn n -> [n] -> Specification fn n
--   We use this function to specialize the (HasSpec fn t) method 'typeSpecOpt' for Bounded n.
--   So given (TypeSpec interval badlist) we might want to transform it to (MemberSpec goodlist)
--   There are 2 opportunities where this can payoff big time.
--   1) Suppose the total count of the elements in the interval is < length badlist
--      we can then return (MemberSpec (filter elements (`notElem` badlist)))
--      this must be smaller than (TypeSpec interval badlist) because the filtered list must be smaller than badlist
--   2) Suppose the type 't' is finite with size N. If the length of the badlist > (N/2), then the number of possible
--      good things must be smaller than (length badlist), because (possible good + bad == N), so regardless of the
--      count of the interval (MemberSpec (filter elements (`notElem` badlist))) is better. Sometimes much better.
--      Example, let 'n' be the finite set {0,1,2,3,4,5,6,7,8,9} and the bad list be [0,1,3,4,5,6,8,9]
--      (TypeSpec [0..9]  [0,1,3,4,5,6,8,9]) = filter  {0,1,2,3,4,5,6,7,8,9} (`notElem` [0,1,3,4,5,6,8,9]) = [2,7]
--      So (MemberSpec [2,7]) is better than  (TypeSpec [0..9]  [0,1,3,4,5,6,8,9]). This works no matter what
--      the count of interval is. We only need the (length badlist > (N/2)).
notInNumSpec ::
  forall fn n.
  ( Functions fn fn
  , BaseUniverse fn
  , HasSpec fn n
  , TypeSpec fn n ~ NumSpec fn n
  , Bounded n
  , Integral n
  ) =>
  NumSpec fn n ->
  [n] ->
  Specification fn n
notInNumSpec :: forall (fn :: [*] -> * -> *) n.
(Functions fn fn, BaseUniverse fn, HasSpec fn n,
 TypeSpec fn n ~ NumSpec fn n, Bounded n, Integral n) =>
NumSpec fn n -> [n] -> Specification fn n
notInNumSpec ns :: NumSpec fn n
ns@(NumSpecInterval Maybe n
a Maybe n
b) [n]
bad
  | forall a. Integral a => a -> Integer
toInteger (forall (t :: * -> *) a. Foldable t => t a -> Int
length [n]
bad) forall a. Ord a => a -> a -> Bool
> (forall n. (Integral n, Bounded n) => Integer
finiteSize @n forall a. Integral a => a -> a -> a
`div` Integer
2) Bool -> Bool -> Bool
|| forall n (fn :: [*] -> * -> *).
(Bounded n, Integral n) =>
NumSpec fn n -> Integer
countSpec NumSpec fn n
ns forall a. Ord a => a -> a -> Bool
< forall a. Integral a => a -> Integer
toInteger (forall (t :: * -> *) a. Foldable t => t a -> Int
length [n]
bad) =
      forall a (fn :: [*] -> * -> *).
Ord a =>
[Char] -> [a] -> Specification fn a
nubOrdMemberSpec
        ([Char]
"call to: (notInNumSpec " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show NumSpec fn n
ns forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [n]
bad forall a. [a] -> [a] -> [a]
++ [Char]
")")
        [n
x | n
x <- [forall n. Bounded n => Maybe n -> n
lowBound Maybe n
a .. forall n. Bounded n => Maybe n -> n
highBound Maybe n
b], forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem n
x [n]
bad]
  | Bool
otherwise = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> OrdSet a -> Specification fn a
TypeSpec @fn @n NumSpec fn n
ns [n]
bad

-- ========================================================================
-- Helper functions for interval multiplication
--  (a,b) * (c,d) = (minimum s, maximum s) where s = [a * c, a * d, b * c, b * d]

-- | T is a sort of special version of Maybe, with two Nothings.
--   Given:: NumSpecInterval (Maybe n) (Maybe n) -> Numspec
--   We can't distinguish between the two Nothings in (NumSpecInterval Nothing Nothing)
--   But using (NumSpecInterval NegInf PosInf) we can, In fact we can make a total ordering on 'T'
--   So an ascending Sorted [T x] would all the NegInf on the left and all the PosInf on the right, with
--   the Ok's sorted in between. I.e. [NegInf, NegInf, Ok 3, Ok 6, Ok 12, Pos Inf]
data T x = NegInf | Ok x | PosInf
  deriving (Int -> T x -> ShowS
forall x. Show x => Int -> T x -> ShowS
forall x. Show x => [T x] -> ShowS
forall x. Show x => T x -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [T x] -> ShowS
$cshowList :: forall x. Show x => [T x] -> ShowS
show :: T x -> [Char]
$cshow :: forall x. Show x => T x -> [Char]
showsPrec :: Int -> T x -> ShowS
$cshowsPrec :: forall x. Show x => Int -> T x -> ShowS
Show)

instance Ord x => Eq (T x) where
  T x
x == :: T x -> T x -> Bool
== T x
y = forall a. Ord a => a -> a -> Ordering
compare T x
x T x
y forall a. Eq a => a -> a -> Bool
== Ordering
EQ

instance Ord x => Ord (T x) where
  compare :: T x -> T x -> Ordering
compare T x
NegInf T x
NegInf = Ordering
EQ
  compare T x
NegInf T x
_ = Ordering
LT
  compare (Ok x
_) T x
NegInf = Ordering
GT
  compare (Ok x
x) (Ok x
y) = forall a. Ord a => a -> a -> Ordering
compare x
x x
y
  compare (Ok x
_) T x
PosInf = Ordering
LT
  compare T x
PosInf T x
PosInf = Ordering
EQ
  compare T x
PosInf T x
_ = Ordering
GT

-- | Conversion between (T x) and (Maybe x)
unT :: T x -> Maybe x
unT :: forall x. T x -> Maybe x
unT (Ok x
x) = forall a. a -> Maybe a
Just x
x
unT T x
_ = forall a. Maybe a
Nothing

-- | Use this on the lower bound. I.e. lo from pair (lo,hi)
neg :: Maybe x -> T x
neg :: forall x. Maybe x -> T x
neg Maybe x
Nothing = forall x. T x
NegInf
neg (Just x
x) = forall x. x -> T x
Ok x
x

-- | Use this on the upper bound. I.e. hi from pair (lo,hi)
pos :: Maybe x -> T x
pos :: forall x. Maybe x -> T x
pos Maybe x
Nothing = forall x. T x
PosInf
pos (Just x
x) = forall x. x -> T x
Ok x
x

-- | multiply two (T x), correctly handling the infinities NegInf and PosInf
multT :: Num x => T x -> T x -> T x
multT :: forall x. Num x => T x -> T x -> T x
multT T x
NegInf T x
NegInf = forall x. T x
PosInf
multT T x
NegInf T x
PosInf = forall x. T x
NegInf
multT T x
NegInf (Ok x
_) = forall x. T x
NegInf
multT (Ok x
_) T x
NegInf = forall x. T x
NegInf
multT (Ok x
x) (Ok x
y) = forall x. x -> T x
Ok (x
x forall a. Num a => a -> a -> a
* x
y)
multT (Ok x
_) T x
PosInf = forall x. T x
PosInf
multT T x
PosInf T x
PosInf = forall x. T x
PosInf
multT T x
PosInf T x
NegInf = forall x. T x
NegInf
multT T x
PosInf (Ok x
_) = forall x. T x
PosInf

-- ====================================================================================
-- Generally useful functions

-- | sizeOfSpec generalizes the method 'sizeOfTypeSpec'
--   From (sizeOfTypeSpec :: TypeSpec fn t -> Specification fn Integer)
--   To   (sizeOfSpec     :: Specification fn t     -> Specification fn Integer)
--   It is not unusual for instances (HasSpec fn t) to define sizeOfTypeSpec with calls to sizeOfSpec,
--   Because many (TypeSpec fn t)'s contain (Specification fn s), for types 's' different from 't'
sizeOfSpec ::
  forall fn t.
  (BaseUniverse fn, Sized fn t, HasSpec fn t) => Specification fn t -> Specification fn Integer
sizeOfSpec :: forall (fn :: [*] -> * -> *) t.
(BaseUniverse fn, Sized fn t, HasSpec fn t) =>
Specification fn t -> Specification fn Integer
sizeOfSpec (ExplainSpec [[Char]]
_ Specification fn t
s) = forall (fn :: [*] -> * -> *) t.
(BaseUniverse fn, Sized fn t, HasSpec fn t) =>
Specification fn t -> Specification fn Integer
sizeOfSpec Specification fn t
s
sizeOfSpec Specification fn t
TrueSpec = forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec
sizeOfSpec s :: Specification fn t
s@(MemberSpec NonEmpty t
xs) = forall a (fn :: [*] -> * -> *).
Ord a =>
[Char] -> [a] -> Specification fn a
nubOrdMemberSpec ([Char]
"call to (sizeOfSpec " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn t
s forall a. [a] -> [a] -> [a]
++ [Char]
")") (forall a b. (a -> b) -> [a] -> [b]
map (forall (fn :: [*] -> * -> *) t. Sized fn t => t -> Integer
sizeOf @fn) (forall a. NonEmpty a -> [a]
NE.toList NonEmpty t
xs))
sizeOfSpec (ErrorSpec NonEmpty [Char]
xs) = forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec NonEmpty [Char]
xs
sizeOfSpec (SuspendedSpec Var t
x Pred fn
p) =
  forall a (fn :: [*] -> * -> *) p.
(IsPred p fn, HasSpec fn a) =>
(Term fn a -> p) -> Specification fn a
constrained forall a b. (a -> b) -> a -> b
$ \Term fn Integer
len ->
    forall (fn :: [*] -> * -> *) a.
((forall b. Term fn b -> b) -> GE a) -> Binder fn a -> Pred fn
Exists
      (\forall b. Term fn b -> b
_ -> forall (m :: * -> *) a. MonadGenError m => [Char] -> m a
fatalError1 [Char]
"sizeOfSpec: Exists")
      (Var t
x forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Pred fn -> Binder fn a
:-> (forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn -> Pred fn
Explain (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"sizeOfSpec") forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Term fn Bool -> Pred fn
Assert (Term fn Integer
len forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Term fn a -> Term fn a -> Term fn Bool
==. forall a (fn :: [*] -> * -> *).
(HasSpec fn a, Sized fn a) =>
Term fn a -> Term fn Integer
sizeOf_ (forall (fn :: [*] -> * -> *) a. HasSpec fn a => Var a -> Term fn a
V Var t
x)) forall a. Semigroup a => a -> a -> a
<> Pred fn
p))
sizeOfSpec (TypeSpec TypeSpec fn t
x OrdSet t
_) = forall (fn :: [*] -> * -> *) t.
(Sized fn t, HasSpec fn t) =>
TypeSpec fn t -> Specification fn Integer
sizeOfTypeSpec @fn @t TypeSpec fn t
x

-- | Turn a Size spec into an ErrorSpec if it has negative numbers.
checkForNegativeSize :: Specification fn Integer -> Specification fn Integer
checkForNegativeSize :: forall (fn :: [*] -> * -> *).
Specification fn Integer -> Specification fn Integer
checkForNegativeSize spec :: Specification fn Integer
spec@(TypeSpec (NumSpecInterval Maybe Integer
x Maybe Integer
y) [Integer]
_) =
  case (Maybe Integer
x, Maybe Integer
y) of
    (Just Integer
lo, Maybe Integer
_)
      | Integer
lo forall a. Ord a => a -> a -> Bool
< Integer
0 -> forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
"Negative low bound in conversion to SizeSpec: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn Integer
spec))
    (Maybe Integer
_, Just Integer
hi)
      | Integer
hi forall a. Ord a => a -> a -> Bool
< Integer
0 ->
          forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
"Negative high bound in conversion to SizeSpec: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn Integer
spec))
    (Just Integer
lo, Just Integer
hi)
      | Integer
lo forall a. Ord a => a -> a -> Bool
> Integer
hi ->
          forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
"lo(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Integer
lo forall a. [a] -> [a] -> [a]
++ [Char]
") > hi(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Integer
hi forall a. [a] -> [a] -> [a]
++ [Char]
") in conversion to SizeSpec"))
    (Maybe Integer
_, Maybe Integer
_) -> Specification fn Integer
spec
checkForNegativeSize (MemberSpec NonEmpty Integer
xs) | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Ord a => a -> a -> Bool
< Integer
0) NonEmpty Integer
xs = forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
"Negative Size in MemberSpec " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show NonEmpty Integer
xs))
checkForNegativeSize Specification fn Integer
spec = Specification fn Integer
spec

-- | Strip out duplicates
nubOrd :: Ord a => [a] -> [a]
nubOrd :: forall a. Ord a => [a] -> [a]
nubOrd =
  forall {a}. Ord a => Set a -> [a] -> [a]
loop forall a. Monoid a => a
mempty
  where
    loop :: Set a -> [a] -> [a]
loop Set a
_ [] = []
    loop Set a
s (a
a : [a]
as)
      | a
a forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
s = Set a -> [a] -> [a]
loop Set a
s [a]
as
      | Bool
otherwise =
          let s' :: Set a
s' = forall a. Ord a => a -> Set a -> Set a
Set.insert a
a Set a
s in Set a
s' seq :: forall a b. a -> b -> b
`seq` a
a forall a. a -> [a] -> [a]
: Set a -> [a] -> [a]
loop Set a
s' [a]
as

nubOrdMemberSpec :: Ord a => String -> [a] -> Specification fn a
nubOrdMemberSpec :: forall a (fn :: [*] -> * -> *).
Ord a =>
[Char] -> [a] -> Specification fn a
nubOrdMemberSpec [Char]
message [a]
xs =
  forall a (fn :: [*] -> * -> *).
[a] -> NonEmpty [Char] -> Specification fn a
memberSpecList
    (forall a. Ord a => [a] -> [a]
nubOrd [a]
xs)
    ( forall a. [a] -> NonEmpty a
NE.fromList
        [ [Char]
"In call to nubOrdMemberSpec"
        , [Char]
"Called from context"
        , [Char]
message
        , [Char]
"The input is the empty list."
        ]
    )

-- ==============================================================================
-- Experimental changes to conformsToSpecM

runTermE :: Env -> Term fn a -> Either (NE.NonEmpty String) a
runTermE :: forall (fn :: [*] -> * -> *) a.
Env -> Term fn a -> Either (NonEmpty [Char]) a
runTermE Env
env = \case
  Lit a
a -> forall a b. b -> Either a b
Right a
a
  V Var a
v -> case forall a. Typeable a => Env -> Var a -> Maybe a
lookupEnv Env
env Var a
v of
    Just a
a -> forall a b. b -> Either a b
Right a
a
    Maybe a
Nothing -> forall a b. a -> Either a b
Left (forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
"Couldn't find " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Var a
v forall a. [a] -> [a] -> [a]
++ [Char]
" in " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Env
env))
  App fn as a
f List (Term fn) as
ts -> do
    List Identity as
vs <- forall {k} (m :: * -> *) (f :: k -> *) (g :: k -> *) (as :: [k]).
Applicative m =>
(forall (a :: k). f a -> m (g a)) -> List f as -> m (List g as)
mapMList (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fn :: [*] -> * -> *) a.
Env -> Term fn a -> Either (NonEmpty [Char]) a
runTermE Env
env) List (Term fn) as
ts
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (ts :: [*]) (f :: * -> *) r.
TypeList ts =>
(forall a. f a -> a) -> FunTy ts r -> List f ts -> r
uncurryList_ forall a. Identity a -> a
runIdentity (forall (fn :: [*] -> * -> *) (as :: [*]) b.
FunctionLike fn =>
fn as b -> FunTy as b
sem fn as a
f) List Identity as
vs

checkPredsE ::
  FunctionLike fn =>
  NE.NonEmpty String ->
  Env ->
  [Pred fn] ->
  Maybe (NE.NonEmpty String)
checkPredsE :: forall (fn :: [*] -> * -> *).
FunctionLike fn =>
NonEmpty [Char] -> Env -> [Pred fn] -> Maybe (NonEmpty [Char])
checkPredsE NonEmpty [Char]
msgs Env
env [Pred fn]
ps =
  case forall a. [Maybe a] -> [a]
catMaybes (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (fn :: [*] -> * -> *).
FunctionLike fn =>
Env -> NonEmpty [Char] -> Pred fn -> Maybe (NonEmpty [Char])
checkPredE Env
env NonEmpty [Char]
msgs) [Pred fn]
ps) of
    [] -> forall a. Maybe a
Nothing
    (NonEmpty [Char]
x : [NonEmpty [Char]]
xs) -> forall a. a -> Maybe a
Just (forall a. Eq a => NonEmpty a -> NonEmpty a
NE.nub (forall a. Semigroup a => NonEmpty a -> a
sconcat (NonEmpty [Char]
x forall a. a -> [a] -> NonEmpty a
NE.:| [NonEmpty [Char]]
xs)))

checkPredE ::
  forall fn.
  FunctionLike fn =>
  Env -> NE.NonEmpty String -> Pred fn -> Maybe (NE.NonEmpty String)
checkPredE :: forall (fn :: [*] -> * -> *).
FunctionLike fn =>
Env -> NonEmpty [Char] -> Pred fn -> Maybe (NonEmpty [Char])
checkPredE Env
env NonEmpty [Char]
msgs = \case
  Monitor {} -> forall a. Maybe a
Nothing
  Subst Var a
x Term fn a
t Pred fn
p -> forall (fn :: [*] -> * -> *).
FunctionLike fn =>
Env -> NonEmpty [Char] -> Pred fn -> Maybe (NonEmpty [Char])
checkPredE Env
env NonEmpty [Char]
msgs forall a b. (a -> b) -> a -> b
$ forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
Var a -> Term fn a -> Pred fn -> Pred fn
substitutePred Var a
x Term fn a
t Pred fn
p
  Assert Term fn Bool
t -> case forall (fn :: [*] -> * -> *) a.
Env -> Term fn a -> Either (NonEmpty [Char]) a
runTermE Env
env Term fn Bool
t of
    Right Bool
True -> forall a. Maybe a
Nothing
    Right Bool
False ->
      forall a. a -> Maybe a
Just
        (NonEmpty [Char]
msgs forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
"Assert " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Term fn Bool
t forall a. [a] -> [a] -> [a]
++ [Char]
" returns False") forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
"\nenv=\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a ann. Pretty a => a -> Doc ann
pretty Env
env)))
    Left NonEmpty [Char]
es -> forall a. a -> Maybe a
Just (NonEmpty [Char]
msgs forall a. Semigroup a => a -> a -> a
<> NonEmpty [Char]
es)
  GenHint {} -> forall a. Maybe a
Nothing
  p :: Pred fn
p@(Reifies Term fn b
t' Term fn a
t a -> b
f) ->
    case forall (fn :: [*] -> * -> *) a.
Env -> Term fn a -> Either (NonEmpty [Char]) a
runTermE Env
env Term fn a
t of
      Left NonEmpty [Char]
es -> forall a. a -> Maybe a
Just (NonEmpty [Char]
msgs forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> NonEmpty a
NE.fromList [[Char]
"checkPredE: Reification fails", [Char]
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Pred fn
p] forall a. Semigroup a => a -> a -> a
<> NonEmpty [Char]
es)
      Right a
val -> case forall (fn :: [*] -> * -> *) a.
Env -> Term fn a -> Either (NonEmpty [Char]) a
runTermE Env
env Term fn b
t' of
        Left NonEmpty [Char]
es -> forall a. a -> Maybe a
Just (NonEmpty [Char]
msgs forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> NonEmpty a
NE.fromList [[Char]
"checkPredE: Reification fails", [Char]
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Pred fn
p] forall a. Semigroup a => a -> a -> a
<> NonEmpty [Char]
es)
        Right b
val' ->
          if a -> b
f a
val forall a. Eq a => a -> a -> Bool
== b
val'
            then forall a. Maybe a
Nothing
            else
              forall a. a -> Maybe a
Just
                ( NonEmpty [Char]
msgs
                    forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> NonEmpty a
NE.fromList
                      [ [Char]
"checkPredE: Reification doesn't match up"
                      , [Char]
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Pred fn
p
                      , forall a. Show a => a -> [Char]
show (a -> b
f a
val) forall a. [a] -> [a] -> [a]
++ [Char]
" /= " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show b
val'
                      ]
                )
  ForAll Term fn t
t (Var a
x :-> Pred fn
p) -> case forall (fn :: [*] -> * -> *) a.
Env -> Term fn a -> Either (NonEmpty [Char]) a
runTermE Env
env Term fn t
t of
    Left NonEmpty [Char]
es -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (NonEmpty [Char]
msgs forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> NonEmpty a
NE.fromList [[Char]
"checkPredE: ForAll fails to run."] forall a. Semigroup a => a -> a -> a
<> NonEmpty [Char]
es)
    Right t
set ->
      let answers :: [NonEmpty [Char]]
answers =
            forall a. [Maybe a] -> [a]
catMaybes
              [ forall (fn :: [*] -> * -> *).
FunctionLike fn =>
Env -> NonEmpty [Char] -> Pred fn -> Maybe (NonEmpty [Char])
checkPredE Env
env' (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"Some items in ForAll fail") Pred fn
p
              | a
v <- forall t e. Forallable t e => t -> [e]
forAllToList t
set
              , let env' :: Env
env' = forall a. (Typeable a, Show a) => Var a -> a -> Env -> Env
extendEnv Var a
x a
v Env
env
              ]
       in case [NonEmpty [Char]]
answers of
            [] -> forall a. Maybe a
Nothing
            (NonEmpty [Char]
x : [NonEmpty [Char]]
xs) -> forall a. a -> Maybe a
Just (forall a. Eq a => NonEmpty a -> NonEmpty a
NE.nub (forall a. Semigroup a => NonEmpty a -> a
sconcat (NonEmpty [Char]
x forall a. a -> [a] -> NonEmpty a
NE.:| [NonEmpty [Char]]
xs)))
  Case Term fn (SumOver as)
t List (Weighted (Binder fn)) as
bs -> case forall (fn :: [*] -> * -> *) a.
Env -> Term fn a -> Either (NonEmpty [Char]) a
runTermE Env
env Term fn (SumOver as)
t of
    Right SumOver as
v -> forall (as :: [*]) (fn :: [*] -> * -> *) r.
SumOver as
-> List (Binder fn) as
-> (forall a. HasSpec fn a => Var a -> a -> Pred fn -> r)
-> r
runCaseOn SumOver as
v (forall {k} (f :: k -> *) (g :: k -> *) (as :: [k]).
(forall (a :: k). f a -> g a) -> List f as -> List g as
mapList forall (f :: * -> *) a. Weighted f a -> f a
thing List (Weighted (Binder fn)) as
bs) (\Var a
x a
val Pred fn
ps -> forall (fn :: [*] -> * -> *).
FunctionLike fn =>
Env -> NonEmpty [Char] -> Pred fn -> Maybe (NonEmpty [Char])
checkPredE (forall a. (Typeable a, Show a) => Var a -> a -> Env -> Env
extendEnv Var a
x a
val Env
env) NonEmpty [Char]
msgs Pred fn
ps)
    Left NonEmpty [Char]
es -> forall a. a -> Maybe a
Just (NonEmpty [Char]
msgs forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"checkPredE: Case fails" forall a. Semigroup a => a -> a -> a
<> NonEmpty [Char]
es)
  When Term fn Bool
bt Pred fn
p -> case forall (fn :: [*] -> * -> *) a.
Env -> Term fn a -> Either (NonEmpty [Char]) a
runTermE Env
env Term fn Bool
bt of
    Right Bool
b -> if Bool
b then forall (fn :: [*] -> * -> *).
FunctionLike fn =>
Env -> NonEmpty [Char] -> Pred fn -> Maybe (NonEmpty [Char])
checkPredE Env
env NonEmpty [Char]
msgs Pred fn
p else forall a. Maybe a
Nothing
    Left NonEmpty [Char]
es -> forall a. a -> Maybe a
Just (NonEmpty [Char]
msgs forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"checkPredE: When fails" forall a. Semigroup a => a -> a -> a
<> NonEmpty [Char]
es)
  Pred fn
TruePred -> forall a. Maybe a
Nothing
  FalsePred NonEmpty [Char]
es -> forall a. a -> Maybe a
Just (NonEmpty [Char]
msgs forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"checkPredE: FalsePred" forall a. Semigroup a => a -> a -> a
<> NonEmpty [Char]
es)
  DependsOn {} -> forall a. Maybe a
Nothing
  Block [Pred fn]
ps ->
    case forall a. [Maybe a] -> [a]
catMaybes (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (fn :: [*] -> * -> *).
FunctionLike fn =>
Env -> NonEmpty [Char] -> Pred fn -> Maybe (NonEmpty [Char])
checkPredE Env
env (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"Some items in Block fail")) [Pred fn]
ps) of
      [] -> forall a. Maybe a
Nothing
      (NonEmpty [Char]
x : [NonEmpty [Char]]
xs) -> forall a. a -> Maybe a
Just (NonEmpty [Char]
msgs forall a. Semigroup a => a -> a -> a
<> forall a. Eq a => NonEmpty a -> NonEmpty a
NE.nub (forall a. Semigroup a => NonEmpty a -> a
sconcat (NonEmpty [Char]
x forall a. a -> [a] -> NonEmpty a
NE.:| [NonEmpty [Char]]
xs)))
  Let Term fn a
t (Var a
x :-> Pred fn
p) -> case forall (fn :: [*] -> * -> *) a.
Env -> Term fn a -> Either (NonEmpty [Char]) a
runTermE Env
env Term fn a
t of
    Right a
val -> forall (fn :: [*] -> * -> *).
FunctionLike fn =>
Env -> NonEmpty [Char] -> Pred fn -> Maybe (NonEmpty [Char])
checkPredE (forall a. (Typeable a, Show a) => Var a -> a -> Env -> Env
extendEnv Var a
x a
val Env
env) NonEmpty [Char]
msgs Pred fn
p
    Left NonEmpty [Char]
es -> forall a. a -> Maybe a
Just (NonEmpty [Char]
msgs forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"checkPredE: Let fails" forall a. Semigroup a => a -> a -> a
<> NonEmpty [Char]
es)
  Exists (forall b. Term fn b -> b) -> GE a
k (Var a
x :-> Pred fn
p) ->
    let eval :: forall b. Term fn b -> b
        eval :: forall b. Term fn b -> b
eval Term fn b
x = case forall (fn :: [*] -> * -> *) a.
Env -> Term fn a -> Either (NonEmpty [Char]) a
runTermE Env
env Term fn b
x of
          Right b
v -> b
v
          Left NonEmpty [Char]
es -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList (NonEmpty [Char]
msgs forall a. Semigroup a => a -> a -> a
<> NonEmpty [Char]
es)
     in case (forall b. Term fn b -> b) -> GE a
k forall b. Term fn b -> b
eval of
          Result [NonEmpty [Char]]
_ a
a -> forall (fn :: [*] -> * -> *).
FunctionLike fn =>
Env -> NonEmpty [Char] -> Pred fn -> Maybe (NonEmpty [Char])
checkPredE (forall a. (Typeable a, Show a) => Var a -> a -> Env -> Env
extendEnv Var a
x a
a Env
env) NonEmpty [Char]
msgs Pred fn
p
          FatalError [NonEmpty [Char]]
ess NonEmpty [Char]
es -> forall a. a -> Maybe a
Just (NonEmpty [Char]
msgs forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall a. Semigroup a => a -> a -> a
(<>) [NonEmpty [Char]]
ess forall a. Semigroup a => a -> a -> a
<> NonEmpty [Char]
es)
          GenError [NonEmpty [Char]]
ess NonEmpty [Char]
es -> forall a. a -> Maybe a
Just (NonEmpty [Char]
msgs forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall a. Semigroup a => a -> a -> a
(<>) [NonEmpty [Char]]
ess forall a. Semigroup a => a -> a -> a
<> NonEmpty [Char]
es)
  Explain NonEmpty [Char]
es Pred fn
p -> forall (fn :: [*] -> * -> *).
FunctionLike fn =>
Env -> NonEmpty [Char] -> Pred fn -> Maybe (NonEmpty [Char])
checkPredE Env
env (NonEmpty [Char]
msgs forall a. Semigroup a => a -> a -> a
<> NonEmpty [Char]
es) Pred fn
p

conformsToSpecE ::
  forall fn a.
  HasSpec fn a =>
  a ->
  Specification fn a ->
  NE.NonEmpty String ->
  Maybe (NE.NonEmpty String)
conformsToSpecE :: forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a
-> Specification fn a -> NonEmpty [Char] -> Maybe (NonEmpty [Char])
conformsToSpecE a
a (ExplainSpec [] Specification fn a
s) NonEmpty [Char]
msgs = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a
-> Specification fn a -> NonEmpty [Char] -> Maybe (NonEmpty [Char])
conformsToSpecE a
a Specification fn a
s NonEmpty [Char]
msgs
conformsToSpecE a
a (ExplainSpec ([Char]
x : [[Char]]
xs) Specification fn a
s) NonEmpty [Char]
msgs = forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a
-> Specification fn a -> NonEmpty [Char] -> Maybe (NonEmpty [Char])
conformsToSpecE a
a Specification fn a
s (NonEmpty [Char]
msgs forall a. Semigroup a => a -> a -> a
<> ([Char]
x forall a. a -> [a] -> NonEmpty a
NE.:| [[Char]]
xs))
conformsToSpecE a
_ Specification fn a
TrueSpec NonEmpty [Char]
_ = forall a. Maybe a
Nothing
conformsToSpecE a
a (MemberSpec NonEmpty a
as) NonEmpty [Char]
msgs =
  if forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem a
a NonEmpty a
as
    then forall a. Maybe a
Nothing
    else
      forall a. a -> Maybe a
Just
        ( NonEmpty [Char]
msgs
            forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> NonEmpty a
NE.fromList
              [[Char]
"conformsToSpecE MemberSpec case", [Char]
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
a, [Char]
"  not an element of", [Char]
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show NonEmpty a
as, [Char]
""]
        )
conformsToSpecE a
a spec :: Specification fn a
spec@(TypeSpec TypeSpec fn a
s OrdSet a
cant) NonEmpty [Char]
msgs =
  if forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem a
a OrdSet a
cant Bool -> Bool -> Bool
&& forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, HasCallStack) =>
a -> TypeSpec fn a -> Bool
conformsTo @fn a
a TypeSpec fn a
s
    then forall a. Maybe a
Nothing
    else
      forall a. a -> Maybe a
Just
        ( NonEmpty [Char]
msgs
            forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> NonEmpty a
NE.fromList
              [[Char]
"conformsToSpecE TypeSpec case", [Char]
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
a, [Char]
"  (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification fn a
spec forall a. [a] -> [a] -> [a]
++ [Char]
")", [Char]
"fails", [Char]
""]
        )
conformsToSpecE a
a (SuspendedSpec Var a
v Pred fn
ps) NonEmpty [Char]
msgs =
  case forall (fn :: [*] -> * -> *).
FunctionLike fn =>
Env -> NonEmpty [Char] -> Pred fn -> Maybe (NonEmpty [Char])
checkPredE (forall a. (Typeable a, Show a) => Var a -> a -> Env
singletonEnv Var a
v a
a) NonEmpty [Char]
msgs Pred fn
ps of
    Maybe (NonEmpty [Char])
Nothing -> forall a. Maybe a
Nothing
    Just NonEmpty [Char]
es -> forall a. a -> Maybe a
Just (forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
"conformsToSpecE SuspendedSpec case on var " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Var a
v forall a. [a] -> [a] -> [a]
++ [Char]
" fails") forall a. Semigroup a => a -> a -> a
<> NonEmpty [Char]
es)
conformsToSpecE a
_ (ErrorSpec NonEmpty [Char]
es) NonEmpty [Char]
msgs = forall a. a -> Maybe a
Just (NonEmpty [Char]
msgs forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"conformsToSpecE ErrorSpec case" forall a. Semigroup a => a -> a -> a
<> NonEmpty [Char]
es)