{-# LANGUAGE AllowAmbiguousTypes #-}
{-# 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 #-}
#if __GLASGOW_HASKELL__ < 900
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
#endif
module Constrained.Base where
import Control.Applicative
import Control.Arrow (first)
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)
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.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
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
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, 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) =>
fn '[Set a, Set a] (Set a)
unionFn
instance (Ord 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 ::
((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 =>
NE.NonEmpty String ->
Term fn Bool ->
Pred fn
Reifies ::
( HasSpec fn a
, HasSpec fn b
) =>
Term fn b ->
Term fn a ->
(a -> b) ->
Pred fn
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) ->
List (Weighted (Binder fn)) as ->
Pred fn
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
data Ctx (fn :: [Type] -> Type -> Type) v a where
CtxHOLE ::
HasSpec fn v =>
Ctx fn v v
CtxApp ::
( HasSpec fn b
, TypeList as
, Typeable as
, All (HasSpec fn) as
) =>
fn as b ->
ListCtx Value as (Ctx fn v) ->
Ctx fn v b
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"
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
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 NonEmpty [Char]
es Term fn Bool
t -> forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a -> m a
explain NonEmpty [Char]
es forall a b. (a -> b) -> a -> b
$ 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
type OrdSet a = [a]
data Specification fn a where
MemberSpec ::
NE.NonEmpty a ->
Specification fn a
ErrorSpec ::
NE.NonEmpty String ->
Specification fn a
SuspendedSpec ::
HasSpec fn a =>
Var a ->
Pred fn ->
Specification fn a
TypeSpec ::
HasSpec fn a =>
TypeSpec fn a ->
OrdSet a ->
Specification fn a
TrueSpec :: Specification fn a
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
Specification fn a
TrueSpec <> :: Specification fn a -> Specification fn a -> Specification fn a
<> 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
explainSpec
(forall a. [a] -> NonEmpty a
NE.fromList [[Char]
"Intersecting: ", [Char]
" MemberSpec " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show NonEmpty a
as, [Char]
" MemberSpec " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show 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 OrdSet 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 OrdSet 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 OrdSet a
cant <> TypeSpec TypeSpec fn a
s' OrdSet 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
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'' (OrdSet a
cant forall a. Semigroup a => a -> a -> a
<> OrdSet a
cant' forall a. Semigroup a => a -> a -> a
<> OrdSet 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 (OrdSet a
cant forall a. Semigroup a => a -> a -> a
<> OrdSet 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)
,
(Int
1, forall a. Arbitrary a => Gen a
arbitrary)
]
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 (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 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 NonEmpty [Char]
es Term fn Bool
t) =
forall (fn :: [*] -> * -> *). Pred fn
TruePred
forall a. a -> [a] -> [a]
: forall (fn :: [*] -> * -> *). [Char] -> Pred fn
falsePred1 [Char]
"shrink assert"
forall a. a -> [a] -> [a]
: [forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
NonEmpty [Char] -> Term fn Bool -> Pred fn
Assert (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"shrink assert") Term fn Bool
t | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a. NonEmpty a -> [a]
NE.toList NonEmpty [Char]
es)]
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)
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"]
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 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
data BinaryShow where
BinaryShow :: forall a. String -> [Doc a] -> BinaryShow
NonBinary :: BinaryShow
class
( Typeable a
, Eq a
, Show a
, Show (TypeSpec fn a)
, BaseUniverse fn
) =>
HasSpec fn a
where
type TypeSpec (fn :: [Type] -> Type -> Type) a
type TypeSpec fn a = TypeSpec fn (SimpleRep a)
emptySpec :: TypeSpec fn a
combineSpec :: TypeSpec fn a -> TypeSpec fn a -> Specification fn a
genFromTypeSpec :: (HasCallStack, MonadGenError m) => TypeSpec fn a -> GenT m a
conformsTo :: HasCallStack => a -> TypeSpec fn a -> Bool
shrinkWithTypeSpec :: TypeSpec fn a -> a -> [a]
toPreds :: Term fn a -> TypeSpec fn a -> Pred fn
cardinalTypeSpec :: TypeSpec fn a -> Specification fn Integer
cardinalTrueSpec :: Specification fn Integer
cardinalTrueSpec = forall (fn :: [*] -> * -> *) a. Specification fn a
TrueSpec
typeSpecHasError :: TypeSpec fn a -> Maybe (NE.NonEmpty String)
typeSpecHasError TypeSpec fn a
_ = forall a. Maybe a
Nothing
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
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
type Prerequisites fn a :: Constraint
type Prerequisites fn a = ()
prerequisites :: Evidence (Prerequisites fn a)
default prerequisites :: Prerequisites fn a => Evidence (Prerequisites fn a)
prerequisites = forall (c :: Constraint). c => Evidence c
Evidence
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
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)
class (HasSpec fn a, Show (Hint a)) => HasGenHint fn a where
type Hint a
giveHint :: Hint a -> Specification fn a
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
_ 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", [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
_ (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
_ Specification fn a
TrueSpec = forall (fn :: [*] -> * -> *). Pred fn
TruePred
satisfies Term fn a
e (MemberSpec NonEmpty a
nonempty) = forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
NonEmpty [Char] -> Term fn Bool -> Pred fn
Assert (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 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 :: [*] -> * -> *).
BaseUniverse fn =>
NonEmpty [Char] -> Term fn Bool -> Pred fn
Assert (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 -> 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
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
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)
MemberSpec NonEmpty a
as -> forall (m :: * -> *) a. MonadGenError m => [Char] -> m a -> m a
explain1 ([Char]
"genFromSpecT " 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))
SuspendedSpec Var a
x 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
Env
_ <- forall (m :: * -> *) (fn :: [*] -> * -> *).
(MonadGenError m, BaseUniverse fn) =>
Pred fn -> GenT m Env
genFromPreds 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 (m :: * -> *) (fn :: [*] -> * -> *).
(MonadGenError m, BaseUniverse fn) =>
Pred fn -> GenT m Env
genFromPreds 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]
""
, [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 b. (a -> b) -> a -> b
$
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]
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
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
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)
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 (fn :: [*] -> * -> *) a (m :: * -> *).
(HasCallStack, HasSpec fn a, MonadGenError m) =>
Specification fn a -> GenT m a
genFromSpecT Specification fn a
spec
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
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'
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)
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 NonEmpty [Char]
_ 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 :: ()
..} =
(Doc ann
"\nSolving for variable " forall ann. Doc ann -> Doc ann -> Doc ann
<+> 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'
[
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
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 :: * -> *) (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
saturatePred :: forall fn. Pred fn -> [Pred fn]
saturatePred :: forall {fn :: [*] -> * -> *}. Pred fn -> [Pred fn]
saturatePred Pred fn
p =
Pred fn
p
forall a. a -> [a] -> [a]
: case Pred fn
p of
Assert NonEmpty [Char]
_ (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 NonEmpty [Char]
_ (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)]
Pred fn
_ -> []
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
explainSpec
( 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
]
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 NonEmpty [Char]
_ (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 NonEmpty [Char]
_ (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)
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 => SolverPlan fn -> GenT m (Env, SolverPlan fn)
stepPlan :: forall (m :: * -> *) (fn :: [*] -> * -> *).
MonadGenError m =>
SolverPlan fn -> GenT m (Env, SolverPlan fn)
stepPlan plan :: SolverPlan fn
plan@(SolverPlan [] Graph (Name fn)
_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Monoid a => a
mempty, SolverPlan fn
plan)
stepPlan (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]
specs <- 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]
specs, [Specification fn a]
specs)
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
explainSpec
( 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 env :: Env
env = forall a. (Typeable a, Show a) => Var a -> a -> Env
singletonEnv Var a
x a
val
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Env
env, 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
env 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
genFromPreds :: (MonadGenError m, BaseUniverse fn) => Pred fn -> GenT m Env
genFromPreds :: forall (m :: * -> *) (fn :: [*] -> * -> *).
(MonadGenError m, BaseUniverse fn) =>
Pred fn -> GenT m Env
genFromPreds (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) = 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
"genFromPreds fails\nPreds are:" forall ann. Doc ann -> Doc ann -> Doc ann
/> forall a ann. Pretty a => a -> Doc ann
pretty Pred fn
preds) forall a b. (a -> b) -> a -> b
$ do
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 Pred fn
preds
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
$ forall a ann. Pretty a => a -> Doc ann
pretty SolverPlan fn
plan) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) (fn :: [*] -> * -> *).
MonadGenError m =>
Env -> SolverPlan fn -> GenT m Env
go forall a. Monoid a => a
mempty SolverPlan fn
plan
where
go :: MonadGenError m => Env -> SolverPlan fn -> GenT m Env
go :: forall (m :: * -> *) (fn :: [*] -> * -> *).
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 =>
SolverPlan fn -> GenT m (Env, SolverPlan fn)
stepPlan SolverPlan fn
plan
forall (m :: * -> *) (fn :: [*] -> * -> *).
MonadGenError m =>
Env -> SolverPlan fn -> GenT m Env
go (Env
env forall a. Semigroup a => a -> a -> a
<> Env
env') SolverPlan fn
plan'
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))
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 NonEmpty [Char]
_ (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 = do
Bool
res <- forall (m :: * -> *) (t :: * -> *) (fn :: [*] -> * -> *).
(MonadGenError m, Traversable t, FunctionLike fn) =>
Env -> t (Pred fn) -> m Bool
checkPreds 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)
if Bool
res
then forall (f :: * -> *) a. Applicative f => a -> f a
pure []
else forall (m :: * -> *) a. MonadGenError m => [Char] -> m a
genError1 ([Char]
"Linearize const False")
| 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 =>
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')
fromGESpec :: HasCallStack => GE (Specification fn a) -> Specification fn a
fromGESpec :: forall (fn :: [*] -> * -> *) a.
HasCallStack =>
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
explainSpec (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
explainSpec :: NE.NonEmpty String -> Specification fn a -> Specification fn a
explainSpec :: forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a -> Specification fn a
explainSpec 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')
explainSpec 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 (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 =>
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 a. [a] -> NonEmpty a
NE.fromList
[ forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ Doc Any
"Simplifying: " forall ann. Doc ann -> Doc ann -> Doc ann
/> forall a ann. Pretty a => a -> Doc ann
pretty Specification fn a
spec
, forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ Doc Any
"optimisePred =>" forall ann. Doc ann -> Doc ann -> Doc ann
/> forall a ann. Pretty a => a -> Doc ann
pretty Pred fn
optP
]
)
forall a b. (a -> b) -> a -> b
$ 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
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}.
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
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')
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
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 NonEmpty [Char]
_ (Lit Bool
True) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
Assert NonEmpty [Char]
_ (Lit Bool
False) -> forall (m :: * -> *) a. MonadGenError m => [Char] -> m a
genError1 (forall a. Show a => a -> [Char]
show Pred fn
p)
Assert NonEmpty [Char]
_ Term fn Bool
t -> forall (m :: * -> *) a. MonadGenError m => [Char] -> m a -> m a
explain1 (forall a. Show a => a -> [Char]
show Pred fn
p) forall a b. (a -> b) -> a -> b
$ 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
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
Specification fn a
s <- 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 :: [*] -> * -> *) a.
(HasSpec fn a, HasCallStack) =>
Var a -> Pred fn -> GE (Specification fn a)
computeSpecSimplified Var a
x Pred fn
p
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
explainSpec NonEmpty [Char]
es Specification fn a
s
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
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 =>
GE (Specification fn a) -> Specification fn a
fromGESpec GE (Specification fn a)
ge
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
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 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)
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 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")
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)
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 NonEmpty [Char]
_ 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 NonEmpty [Char]
_ 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 NonEmpty [Char]
_ 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 NonEmpty [Char]
_ 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)
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
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
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 NonEmpty [Char]
es Term fn Bool
t -> forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
NonEmpty [Char] -> Term fn Bool -> Pred fn
Assert NonEmpty [Char]
es (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 NonEmpty [Char]
es Term fn Bool
t -> forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
NonEmpty [Char] -> Term fn Bool -> Pred fn
Assert NonEmpty [Char]
es (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 NonEmpty [Char]
es Term fn Bool
t -> forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
NonEmpty [Char] -> p -> Pred fn
assertExplain NonEmpty [Char]
es (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
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
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 NonEmpty [Char]
es Term fn Bool
t -> forall (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
NonEmpty [Char] -> p -> Pred fn
assertExplain NonEmpty [Char]
es (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 -> 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') (forall (fn :: [*] -> * -> *) a.
BaseUniverse fn =>
Term fn a -> Term fn a
simplifyTerm 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)
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
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
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
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 NonEmpty [Char]
_ (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
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
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'
,
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 NonEmpty [Char]
es Term fn Bool
t -> forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
NonEmpty [Char] -> Term fn Bool -> Pred fn
Assert NonEmpty [Char]
es (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
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
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) =
[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
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
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
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
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
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
Assert NonEmpty [Char]
es Term fn Bool
t -> forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
NonEmpty [Char] -> Term fn Bool -> Pred fn
Assert NonEmpty [Char]
es 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'
]
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
onlyUsedUniquely :: Name fn -> Pred fn -> Bool
onlyUsedUniquely Name fn
n Pred fn
p = case Pred fn
p of
Assert NonEmpty [Char]
_ 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
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 NonEmpty [Char]
es 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 (fn :: [*] -> * -> *) p.
(BaseUniverse fn, IsPred p fn) =>
NonEmpty [Char] -> p -> Pred fn
assertExplain NonEmpty [Char]
es Bool
b
| Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Pred fn
p
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
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'
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
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
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)
data (c :: Symbol) ::: (ts :: [Type])
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]
type family Constr f where
Constr (S1 _ f) = Constr f
Constr (K1 _ k) = '[k]
Constr U1 = '[()]
Constr (f :*: g) = Append (Constr f) (Constr g)
type family SOP constrs where
SOP '[c ::: prod] = ProdOver prod
SOP ((c ::: prod) : constrs) = Sum (ProdOver prod) (SOP constrs)
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
,
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
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
algebra :: SOP constrs -> ALG constrs r
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
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
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)
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 :: MonadGenError m => FoldSpec fn a -> FoldSpec fn a -> m (FoldSpec fn a)
combineFoldSpec :: forall (m :: * -> *) (fn :: [*] -> * -> *) a.
MonadGenError m =>
FoldSpec fn a -> FoldSpec fn a -> m (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 (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
genError
(forall a. [a] -> NonEmpty a
NE.fromList [[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
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
ErrorSpec {} -> Bool
True
Specification fn a
TrueSpec -> Bool
False
MemberSpec NonEmpty a
_ -> Bool
False
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 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 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
) =>
a ->
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
1000 :: Int) (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')
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
| 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)
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 (Specification fn a
elemS, Specification fn a
foldS)
| a
fuel forall a. Eq a => a -> a -> Bool
== a
0 = forall a. Maybe a
Nothing
| 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)
| 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)
| 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)
| 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)
| 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 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)
| 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) 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)
| 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 {p}. (MaybeBounded p, Ord p, Num p) => p -> p
safeNegate 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)
| 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
fuel forall a. Eq a => a -> a -> Bool
== a
1
, a
s forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
a -> Specification fn a -> Bool
`conformsToSpec` Specification fn a
elemS
, forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (forall a. Ord a => a -> a -> Bool
< 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
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
geqSpec @fn a
s, Specification fn a
foldS)
| 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, Ord a,
Enum a, Num a, MaybeBounded a, HasSpec fn a, HasSpec fn a) =>
(Specification fn a, Specification fn a)
-> Maybe (Specification fn a, Specification fn a)
go (Specification fn a, Specification fn a)
specs)
where
go :: (Specification fn a, Specification fn a)
-> Maybe (Specification fn a, Specification fn a)
go (Specification fn a
elemS, Specification fn a
foldS) = case (Specification fn a
elemS, Specification fn a
foldS) of
(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]))
(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
]
)
(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
,
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)
(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
,
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))
(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 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
| 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]
| 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 t. Sized 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
$
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 t. Sized 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
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
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 @()")
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)
guardSumSpec ::
forall fn a b.
(HasSpec fn a, HasSpec fn b, KnownNat (CountCases b)) =>
SumSpec fn a b ->
Specification fn (Sum a b)
guardSumSpec :: forall (fn :: [*] -> * -> *) a b.
(HasSpec fn a, HasSpec fn b, KnownNat (CountCases b)) =>
SumSpec fn a b -> Specification fn (Sum a b)
guardSumSpec 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
[ [Char]
"When combining 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 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)
(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
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)) =>
SumSpec fn a b -> Specification fn (Sum a b)
guardSumSpec (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]
"))"
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)]
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) => SetSpec fn a -> Specification fn (Set a)
guardSetSpec :: forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, Ord a) =>
SetSpec fn a -> Specification fn (Set a)
guardSetSpec (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 (forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
"guardSetSpec: negative size " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Integer
u))
| forall (fn :: [*] -> * -> *) a. Specification fn a -> Bool
isErrorLike Specification fn Integer
size = forall (fn :: [*] -> * -> *) a.
NonEmpty [Char] -> Specification fn a
ErrorSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"guardSetSpec: error in size")
| Bool
otherwise = 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
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) =>
SetSpec fn a -> Specification fn (Set a)
guardSetSpec forall a b. (a -> b) -> a -> b
$ 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 t. Sized 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
]
)
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 t. Sized 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 t. Sized 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']) 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 t. Sized 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
$
[forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
NonEmpty [Char] -> Term fn Bool -> Pred fn
Assert (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 :: [*] -> * -> *) a.
(HasSpec fn a, Ord 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
]
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
deriving instance HasSpec fn a => Show (SetSpec fn a)
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
_ 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
| 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 =>
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 t. Sized 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 a, Ord 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 t. Sized 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 a, Ord a) =>
Term fn (Set a) -> Term fn (Set a) -> Term fn Bool
`subset_` Term fn (Set a)
disjoint
]
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
)
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 =>
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
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 t. Sized 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 t. Sized 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
_ ->
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
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
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
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
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 (ListSpec Maybe Integer
msz [a]
must Specification fn Integer
size Specification fn a
elemS FoldSpec fn a
foldS) (ListSpec Maybe Integer
msz' [a]
must' Specification fn Integer
size' Specification fn a
elemS' FoldSpec fn a
foldS') = forall (fn :: [*] -> * -> *) a.
HasCallStack =>
GE (Specification fn a) -> Specification fn a
fromGESpec forall a b. (a -> b) -> a -> b
$ do
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'' = forall (fn :: [*] -> * -> *) a.
OrdLike fn a =>
a -> Specification fn a
geqSpec Integer
0 forall a. Semigroup a => a -> a -> a
<> Specification fn Integer
size forall a. Semigroup a => a -> a -> a
<> Specification fn Integer
size'
badSizeSpec :: Bool
badSizeSpec
| forall (fn :: [*] -> * -> *) a. Specification fn a -> Bool
isErrorLike Specification fn Integer
size'' = Bool
True
| 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 =
Bool
True
| Bool
otherwise = Bool
False
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (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 a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadGenError m => [Char] -> m a
genError1 [Char]
"combineSpec ListSpec failed with <REASON>"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
badSizeSpec forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadGenError m => [Char] -> m a
genError1 [Char]
"error-like size spec in combineSpec ListSpec"
forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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''
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) (fn :: [*] -> * -> *) a.
MonadGenError m =>
FoldSpec fn a -> FoldSpec fn a -> m (FoldSpec fn a)
combineFoldSpec FoldSpec fn a
foldS FoldSpec fn a
foldS'
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 t. Sized 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 t. Sized 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 t. Sized 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
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 t. Sized 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 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
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
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' = case NumSpec fn n
s forall a. Semigroup a => a -> a -> a
<> NumSpec fn n
s' of
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 (forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
"combineNumSpec has low bound greater than hi bound: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show NumSpec fn n
s''))
| n
a forall a. Eq a => a -> a -> Bool
== n
b -> forall a (fn :: [*] -> * -> *). a -> Specification fn a
equalSpec n
a
NumSpec fn n
s'' -> forall (fn :: [*] -> * -> *) a.
HasSpec fn a =>
TypeSpec fn a -> Specification fn a
typeSpec 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)
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')
| 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
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
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
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
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
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
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
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
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
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
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
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
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
type BaseFns =
'[EqFn, SetFn, BoolFn, PairFn, IntFn, OrdFn, GenericsFn, ListFn, SumFn, MapFn, FunFn, SizeFn]
type BaseFn = Fix (OneofL BaseFns)
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
)
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
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)
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
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
_ 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"
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 :: 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 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
]
| [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
| 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
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] ->
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] ->
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
(forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Num a => a -> a -> a
subtract (forall t. Sized t => t -> Integer
sizeOf [a]
ys)) Maybe Integer
h)
([a]
m forall a. Eq a => [a] -> [a] -> [a]
\\ [a]
ys)
(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 t. Sized 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)
Specification fn a
e
(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)
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 => fn '[[a], [a]] [a]
appendFn :: forall (fn :: [*] -> * -> *) a. HasSpec fn 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 (fn :: [*] -> * -> *) a. ListFn fn '[[a], [a]] [a]
AppendFn @fn
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
_ 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 Add"
, [Char]
"Spec is (MemberSpec is), such that can't safely subtract from any i in is"
, [Char]
"Leads to an empty MemberSpec, and hence this ErrorSpec"
]
)
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
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) =>
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) =>
fn '[a, Set a] Bool
memberFn
subset_ ::
( HasSpec fn a
, Ord a
) =>
Term fn (Set a) ->
Term fn (Set a) ->
Term fn Bool
subset_ :: forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, Ord 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) =>
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) =>
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) =>
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 a) =>
Term fn a ->
Term fn Integer
sizeOf_ :: forall a (fn :: [*] -> * -> *).
(HasSpec fn a, Sized 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 a) =>
fn '[a] Integer
sizeOfFn
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 a) =>
fn '[a] Integer
sizeOfFn
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 a) =>
fn '[a] Integer
sizeOfFn
null_ :: (HasSpec fn a, Sized a) => Term fn a -> Term fn Bool
null_ :: forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, Sized a) =>
Term fn a -> Term fn Bool
null_ Term fn a
xs = forall a (fn :: [*] -> * -> *).
(HasSpec fn a, Sized 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
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 => 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
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
]
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 NonEmpty [Char]
es' Term fn Bool
t) = forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
NonEmpty [Char] -> Term fn Bool -> Pred fn
Assert (NonEmpty [Char]
es forall a. Semigroup a => a -> a -> a
<> NonEmpty [Char]
es') 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
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
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
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!"
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
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
| 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
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 NonEmpty [Char]
nes' Term fn Bool
x) = forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
NonEmpty [Char] -> Term fn Bool -> Pred fn
Assert NonEmpty [Char]
nes' Term fn Bool
x
toPredExplain [[Char]]
nes (Assert NonEmpty [Char]
nes' Term fn Bool
x) = forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
NonEmpty [Char] -> Term fn Bool -> Pred fn
Assert (forall a. [a] -> NonEmpty a
NE.fromList [[Char]]
nes forall a. Semigroup a => a -> a -> a
<> NonEmpty [Char]
nes') Term fn Bool
x
toPredExplain [] (FalsePred NonEmpty [Char]
nes') = forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn
FalsePred NonEmpty [Char]
nes'
toPredExplain [[Char]]
nes (FalsePred NonEmpty [Char]
nes') = forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn
FalsePred (forall a. [a] -> NonEmpty a
NE.fromList [[Char]]
nes 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]]
nes (Explain NonEmpty [Char]
nes' Pred fn
x) = forall p (fn :: [*] -> * -> *).
(PredLike p, BaseUniverse fn, UnivConstr p fn) =>
[[Char]] -> p -> Pred fn
toPredExplain ([[Char]]
nes forall a. Semigroup a => a -> a -> a
<> forall a. NonEmpty a -> [a]
NE.toList NonEmpty [Char]
nes') Pred fn
x
toPredExplain [] Pred fn
p = Pred fn
p
toPredExplain [[Char]]
nes Pred fn
p = forall (fn :: [*] -> * -> *). NonEmpty [Char] -> Pred fn -> Pred fn
Explain (forall a. [a] -> NonEmpty a
NE.fromList [[Char]]
nes) 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 =>
NonEmpty [Char] -> Term fn Bool -> Pred fn
Assert (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"toPred Term") Term fn Bool
tm
toPredExplain [[Char]]
es Term fn Bool
tm = forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
NonEmpty [Char] -> Term fn Bool -> Pred fn
Assert (forall a. [a] -> NonEmpty a
NE.fromList [[Char]]
es) Term fn Bool
tm
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
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 NonEmpty [Char]
es Term fn Bool
t -> Doc ann
"assert" 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 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
"explanation" 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
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
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 ->
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
$
if forall a. NonEmpty a -> Int
NE.length NonEmpty a
xs forall a. Eq a => a -> a -> Bool
== Int
1
then
let raw :: [Char]
raw = forall a. Show a => a -> [Char]
show (forall a. NonEmpty a -> a
NE.head NonEmpty a
xs)
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 ann
"MemberSpec [" 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 ann
"]"
else Doc ann
"MemberSpec [" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow (forall a. NonEmpty a -> Int
NE.length NonEmpty a
xs) forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"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))
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
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
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 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 t. Sized t => t -> Integer
sizeOf
sizeOfFn :: forall fn a. (HasSpec fn a, Member (SizeFn fn) fn, Sized a) => fn '[a] Integer
sizeOfFn :: forall (fn :: [*] -> * -> *) a.
(HasSpec fn a, Member (SizeFn fn) fn, Sized 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 a, HasSpec fn a) =>
SizeFn fn '[a] Integer
SizeOf @fn @a
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
_ 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)
propagateSpecFun SizeFn fn as b
SizeOf (NilCtx HOLE a a
HOLE) (TypeSpec TypeSpec fn b
x OrdSet b
cant) = forall t (fn :: [*] -> * -> *).
(Sized 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 t (fn :: [*] -> * -> *).
(Sized 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 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)
maxSpec :: BaseUniverse fn => Specification fn Integer -> Specification fn Integer
maxSpec :: forall (fn :: [*] -> * -> *).
BaseUniverse fn =>
Specification fn Integer -> Specification fn Integer
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 :: [*] -> * -> *).
BaseUniverse fn =>
NonEmpty [Char] -> Term fn Bool -> Pred fn
Assert (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"maxSpec on SuspendedSpec") (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
class Sized t where
sizeOf :: t -> Integer
liftSizeSpec :: HasSpec fn t => SizeSpec fn -> [Integer] -> Specification fn t
liftMemberSpec :: HasSpec fn t => OrdSet Integer -> Specification fn t
sizeOfTypeSpec :: HasSpec fn t => TypeSpec fn t -> Specification fn Integer
instance Ord a => Sized (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 :: forall (fn :: [*] -> * -> *).
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 :: forall (fn :: [*] -> * -> *).
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 :: forall (fn :: [*] -> * -> *).
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 t. Sized t => t -> Integer
sizeOf Set a
must)
instance Sized [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 :: forall (fn :: [*] -> * -> *).
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 :: forall (fn :: [*] -> * -> *).
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 :: forall (fn :: [*] -> * -> *).
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 t. Sized t => t -> Integer
sizeOf [a]
must)
hasSize :: (HasSpec fn t, Sized t) => SizeSpec fn -> Specification fn t
hasSize :: forall (fn :: [*] -> * -> *) t.
(HasSpec fn t, Sized t) =>
SizeSpec fn -> Specification fn t
hasSize SizeSpec fn
sz = forall t (fn :: [*] -> * -> *).
(Sized t, HasSpec fn t) =>
SizeSpec fn -> [Integer] -> Specification fn t
liftSizeSpec SizeSpec fn
sz []
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"
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
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 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]
(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)]
(MemberSpec NonEmpty n
ys, TypeSpec (NumSpecInterval Maybe n
lo Maybe n
hi) OrdSet n
bads) ->
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]
(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 ::
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 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 t. Sized 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 t. Sized 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
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
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
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
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
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
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
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
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
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
sizeOfSpec ::
forall fn t.
(BaseUniverse fn, Sized t, HasSpec fn t) => Specification fn t -> Specification fn Integer
sizeOfSpec :: forall (fn :: [*] -> * -> *) t.
(BaseUniverse fn, Sized t, HasSpec fn t) =>
Specification fn t -> Specification fn Integer
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 t. Sized t => t -> Integer
sizeOf (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 :: [*] -> * -> *).
BaseUniverse fn =>
NonEmpty [Char] -> Term fn Bool -> Pred fn
Assert (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"sizeOfSpec") (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 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 t (fn :: [*] -> * -> *).
(Sized t, HasSpec fn t) =>
TypeSpec fn t -> Specification fn Integer
sizeOfTypeSpec @t @fn TypeSpec fn t
x
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
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."
]
)