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

-- | All the things that are mutually recursive.
module Constrained.TheKnot where

import Constrained.Base (
  AppRequires,
  BinaryShow (..),
  Binder (..),
  Forallable (..),
  Fun (..),
  HOLE (..),
  HasGenHint (..),
  HasSpec (..),
  IsPred,
  Logic (..),
  Pred (..),
  Semantics (..),
  Specification (..),
  Syntax (..),
  Term (..),
  TypeSpec,
  Weighted (..),
  WithPrec (..),
  addToErrorSpec,
  appFun,
  appTerm,
  bind,
  cardinalTypeSpec,
  combineSpec,
  conformsTo,
  constrained,
  emptySpec,
  equalSpec,
  errorLikeMessage,
  explainSpec,
  explainSpecOpt,
  flipCtx,
  fromGESpec,
  fromSimpleRepSpec,
  genFromTypeSpec,
  getWitness,
  guardTypeSpec,
  isErrorLike,
  mapWeighted,
  memberSpecList,
  notEqualSpec,
  notMemberSpec,
  parensIf,
  prettyPrec,
  propagateSpec,
  sameFunSym,
  short,
  showType,
  shrinkWithTypeSpec,
  toCtx,
  toPred,
  toPreds,
  traverseWeighted,
  typeSpec,
  typeSpecOpt,
  vsep',
  (/>),
  pattern FromGeneric,
  pattern Unary,
  pattern (:<:),
  pattern (:>:),
 )
import Constrained.SumList

import Constrained.Conformance (
  checkPred,
  checkPredsE,
  conformsToSpec,
  satisfies,
 )
import Constrained.Core (
  Evidence (..),
  Value (..),
  Var (..),
  eqVar,
  freshen,
  unValue,
  unionWithMaybe,
 )
import Constrained.Env (
  Env,
  extendEnv,
  findEnv,
  lookupEnv,
  singletonEnv,
 )
import Constrained.GenT (
  GE (..),
  GenT,
  MonadGenError (..),
  catMessageList,
  catMessages,
  catchGen,
  errorGE,
  explain,
  fatalError,
  frequencyT,
  genError,
  genFromGenT,
  getMode,
  inspect,
  listFromGE,
  listOfT,
  listOfUntilLenT,
  pureGen,
  push,
  pushGE,
  runGE,
  suchThatT,
 )
import Constrained.Generic (
  HasSimpleRep,
  Prod (..),
  SimpleRep,
  Sum (..),
  SumOver,
  toSimpleRep,
 )
import Constrained.Graph (
  deleteNode,
  dependencies,
  nodes,
  opGraph,
  subtractGraph,
  topsort,
  transitiveClosure,
 )
import qualified Constrained.Graph as Graph
import Constrained.List (
  -- All,
  FunTy,
  List (..),
  ListCtx (..),
  -- TypeList,
  curryList,
  foldMapList,
  lengthList,
  mapList,
  mapMList,
  uncurryList_,
 )
import Constrained.NumSpec (
  IntW (..),
  NumLike,
  NumOrdW (..),
  NumSpec (..),
  Numeric,
  OrdLike,
  addFn,
  addSpecInt,
  cardinalNumSpec,
  cardinality,
  combineNumSpec,
  conformsToNumSpec,
  emptyNumSpec,
  genFromNumSpec,
  geqSpec,
  gtSpec,
  guardNumSpec,
  leqSpec,
  ltSpec,
  negateFn,
  notInNumSpec,
  shrinkWithNumSpec,
 )

-- TODO: some strange things here, why is SolverStage in here?!
-- Because it is mutually recursive with something else in here.
import Constrained.Syntax
import Control.Applicative
import Control.Monad
import Control.Monad.Writer (Writer, runWriter, tell)
import Data.Foldable
import Data.Int
import Data.Kind
import Data.List (isPrefixOf, isSuffixOf, nub, partition, (\\))
import Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.List.NonEmpty as NE
import Data.Maybe
import Data.Ratio
import Data.Semigroup (Any (..), getSum)
import qualified Data.Semigroup as Semigroup
import Data.Set (Set)
import qualified Data.Set as Set
import Data.String
import Data.Typeable
import Data.Word
import GHC.Natural
import GHC.Stack
import GHC.TypeLits
import Prettyprinter hiding (cat)
import Test.QuickCheck hiding (Args, Fun, Witness, forAll, witness)
import Test.QuickCheck.Gen
import Test.QuickCheck.Random hiding (left, right)
import Prelude hiding (cycle, pred)

-- ===================================================================================
-- We call this module TheKnot because it binds a mutually recursive set of things
-- The heart of TheKNot is "genFromSpecT" the user interface to generating random instances of a Spec.
-- It is mutually recursive with the 3 simplest HasSpec instances (Bool,Integer,Sum), and 'simplifySpec'.
-- Every HasSpec instance is dependant on HasSpec Integer because the Cardinality properties
-- are expressed in terms of Integer. Generic HasSpec instances (including Bool) are
-- implemented in terms of a Sum of Product Simple Rep. And every HasSpec instance has
-- a genFromTypeSpec method, on which GenFromSpecT depends. There is no avoiding the Knot.
-- The only saving grace, is that genFromTypeSpec is a HasSpec method, so new things
-- depending only on things defined here, or things defined in the same file as the
-- the HasSpec instance can escape from TheKnot.
--
-- Here is a graph of the dependencies.
--
--      +---->HasSpec Integer
--      |      ^            ^
--      |      |             \
--      |      v              \
--      |     HasSpec Bool---->HasSpec Sum
--      |        ^  \               /   ^
--      |        |   \             /    |
--      <.       |    \           /     |
--      <=.      |     \         /      |
--      |        |      v       v       |
--      |        |      genFromSpecT    |
--      |        |            |         |
--      |        |            |         |
--      +-------caseBoolSpec  |    caseSum
--                      ^     |    ^
--                      |     |    |
--                      |     v    |
--                     simplifySpec
--
-- ===============================================================================
-- Things left TODO
-- 1) Use of UnionPat below requires HasSpec(Set a) instance

-- ==================================================================
-- HasSpec for Sums
-- ==================================================================

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

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

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

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

instance (KnownNat (CountCases b), HasSpec a, HasSpec b) => Show (SumSpec a b) where
  show :: SumSpec a b -> [Char]
show sumspec :: SumSpec a b
sumspec@(SumSpecRaw Maybe [Char]
tstring Maybe (Int, Int)
hint Specification a
l Specification b
r) = case forall a. HasSpec a => TypeSpec a -> BinaryShow
alternateShow @(Sum a b) SumSpec 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 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 b
r
        forall a. [a] -> [a] -> [a]
++ [Char]
"))"

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

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

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)

totalWeight :: List (Weighted f) as -> Maybe Int
totalWeight :: forall {k} (f :: k -> *) (as :: [k]).
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
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 {k} (f :: k -> *) (a :: k). Weighted f a -> Maybe Int
weight)

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

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

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

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

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

  genFromTypeSpec :: forall (m :: * -> *).
(HasCallStack, MonadGenError m) =>
TypeSpec (Sum a b) -> GenT m (Sum a b)
genFromTypeSpec (SumSpec Maybe (Int, Int)
h Specification a
sa Specification b
sb)
    | Bool
emptyA, Bool
emptyB = forall (m :: * -> *) a. MonadGenError m => [Char] -> m a
genError [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 a (m :: * -> *).
(HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecT Specification 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 a (m :: * -> *).
(HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecT Specification 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
genError [Char]
"All frequencies 0"
    | Bool
otherwise =
        forall a (m :: * -> *).
(Typeable 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 a (m :: * -> *).
(HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecT Specification 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 a (m :: * -> *).
(HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecT Specification 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 a. Specification a -> Bool
isErrorLike Specification a
sa
      emptyB :: Bool
emptyB = forall a. Specification a -> Bool
isErrorLike Specification b
sb

  shrinkWithTypeSpec :: TypeSpec (Sum a b) -> Sum a b -> [Sum a b]
shrinkWithTypeSpec (SumSpec Maybe (Int, Int)
_ Specification a
sa Specification 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 a. HasSpec a => Specification a -> a -> [a]
shrinkWithSpec Specification a
sa a
a
  shrinkWithTypeSpec (SumSpec Maybe (Int, Int)
_ Specification a
_ Specification 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 a. HasSpec a => Specification a -> a -> [a]
shrinkWithSpec Specification b
sb b
b

  toPreds :: Term (Sum a b) -> TypeSpec (Sum a b) -> Pred
toPreds Term (Sum a b)
ct (SumSpec Maybe (Int, Int)
h Specification a
sa Specification b
sb) =
    forall (as :: [*]).
HasSpec (SumOver as) =>
Term (SumOver as) -> List (Weighted Binder) as -> Pred
Case
      Term (Sum a b)
ct
      ( (forall {k} (f :: k -> *) (a :: k). 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 a p. (HasSpec a, IsPred p) => (Term a -> p) -> Binder a
bind forall a b. (a -> b) -> a -> b
$ \Term a
a -> forall a. HasSpec a => Term a -> Specification a -> Pred
satisfies Term a
a Specification a
sa)
          forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> (forall {k} (f :: k -> *) (a :: k). 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 a p. (HasSpec a, IsPred p) => (Term a -> p) -> Binder a
bind forall a b. (a -> b) -> a -> b
$ \Term b
b -> forall a. HasSpec a => Term a -> Specification a -> Pred
satisfies Term b
b Specification 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 (Sum a b) -> Specification Integer
cardinalTypeSpec (SumSpec Maybe (Int, Int)
_ Specification a
leftspec Specification b
rightspec) = forall n.
Number n =>
Specification n -> Specification n -> Specification n
addSpecInt (forall a.
(Number Integer, HasSpec a) =>
Specification a -> Specification Integer
cardinality Specification a
leftspec) (forall a.
(Number Integer, HasSpec a) =>
Specification a -> Specification Integer
cardinality Specification b
rightspec)

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

  alternateShow :: TypeSpec (Sum a b) -> BinaryShow
alternateShow (SumSpec Maybe (Int, Int)
h Specification a
left right :: Specification b
right@(TypeSpec TypeSpec b
r [])) =
    case forall a. HasSpec a => TypeSpec a -> BinaryShow
alternateShow @b TypeSpec 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 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 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 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 b
right]
  alternateShow (SumSpec Maybe (Int, Int)
h Specification a
left Specification 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 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 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

instance (Arbitrary (Specification a), Arbitrary (Specification b)) => Arbitrary (SumSpec a b) where
  arbitrary :: Gen (SumSpec a b)
arbitrary =
    forall a b.
Maybe (Int, Int)
-> Specification a -> Specification b -> SumSpec 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 a b -> [SumSpec a b]
shrink (SumSpec Maybe (Int, Int)
h Specification a
a Specification b
b) = [forall a b.
Maybe (Int, Int)
-> Specification a -> Specification b -> SumSpec a b
SumSpec Maybe (Int, Int)
h' Specification a
a' Specification b
b' | (Maybe (Int, Int)
h', Specification a
a', Specification b
b') <- forall a. Arbitrary a => a -> [a]
shrink (Maybe (Int, Int)
h, Specification a
a, Specification b
b)]

-- ======================================
-- Here are the Logic Instances for Sum

data SumW dom rng where
  InjLeftW :: (HasSpec a, HasSpec b) => SumW '[a] (Sum a b)
  InjRightW :: (HasSpec a, HasSpec b) => SumW '[b] (Sum a b)

instance Show (SumW dom rng) where
  show :: SumW dom rng -> [Char]
show SumW dom rng
InjLeftW = [Char]
"injLeft_"
  show SumW dom rng
InjRightW = [Char]
"injRight_"

deriving instance (Eq (SumW dom rng))

instance Syntax SumW

instance Semantics SumW where
  semantics :: forall (d :: [*]) r. SumW d r -> FunTy d r
semantics SumW d r
InjLeftW = forall a b. a -> Sum a b
SumLeft
  semantics SumW d r
InjRightW = forall a b. b -> Sum a b
SumRight

instance Logic SumW where
  propagateTypeSpec :: forall (as :: [*]) b a.
(AppRequires SumW as b, HasSpec a) =>
SumW as b
-> ListCtx Value as (HOLE a)
-> TypeSpec b
-> [b]
-> Specification a
propagateTypeSpec SumW as b
InjLeftW (Unary HOLE a a
HOLE) (SumSpec Maybe (Int, Int)
_ Specification a
sl Specification b
_) [b]
cant = Specification a
sl forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. HasSpec a => a -> Specification a
notEqualSpec [a
a | SumLeft a
a <- [b]
cant]
  propagateTypeSpec SumW as b
InjRightW (Unary HOLE a b
HOLE) (SumSpec Maybe (Int, Int)
_ Specification a
_ Specification a
sr) [b]
cant = Specification a
sr forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. HasSpec a => a -> Specification a
notEqualSpec [a
a | SumRight a
a <- [b]
cant]

  propagateMemberSpec :: forall (as :: [*]) b a.
(AppRequires SumW as b, HasSpec a) =>
SumW as b
-> ListCtx Value as (HOLE a) -> NonEmpty b -> Specification a
propagateMemberSpec SumW as b
InjLeftW (Unary HOLE a a
HOLE) NonEmpty b
es =
    case [a
a | SumLeft a
a <- forall a. NonEmpty a -> [a]
NE.toList NonEmpty b
es] of
      (a
x : [a]
xs) -> forall a. NonEmpty a -> Specification a
MemberSpec (a
x forall a. a -> [a] -> NonEmpty a
:| [a]
xs)
      [] ->
        forall a. NonEmpty [Char] -> Specification 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]
"propMemberSpec (sumleft_ HOLE) on (MemberSpec es) with no SumLeft in es: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a. NonEmpty a -> [a]
NE.toList NonEmpty b
es)
  propagateMemberSpec SumW as b
InjRightW (Unary HOLE a b
HOLE) NonEmpty b
es =
    case [a
a | SumRight a
a <- forall a. NonEmpty a -> [a]
NE.toList NonEmpty b
es] of
      (a
x : [a]
xs) -> forall a. NonEmpty a -> Specification a
MemberSpec (a
x forall a. a -> [a] -> NonEmpty a
:| [a]
xs)
      [] ->
        forall a. NonEmpty [Char] -> Specification 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]
"propagate(InjRight HOLE) on (MemberSpec es) with no SumLeft in es: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a. NonEmpty a -> [a]
NE.toList NonEmpty b
es)

  mapTypeSpec :: forall a b.
(HasSpec a, HasSpec b) =>
SumW '[a] b -> TypeSpec a -> Specification b
mapTypeSpec SumW '[a] b
InjLeftW TypeSpec a
ts = forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec forall a b. (a -> b) -> a -> b
$ forall a b.
Maybe (Int, Int)
-> Specification a -> Specification b -> SumSpec a b
SumSpec forall a. Maybe a
Nothing (forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec TypeSpec a
ts) (forall a. NonEmpty [Char] -> Specification a
ErrorSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"mapTypeSpec InjLeftW"))
  mapTypeSpec SumW '[a] b
InjRightW TypeSpec a
ts = forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec forall a b. (a -> b) -> a -> b
$ forall a b.
Maybe (Int, Int)
-> Specification a -> Specification b -> SumSpec a b
SumSpec forall a. Maybe a
Nothing (forall a. NonEmpty [Char] -> Specification a
ErrorSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"mapTypeSpec InjRightW")) (forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec TypeSpec a
ts)

injLeft_ :: (HasSpec a, HasSpec b, KnownNat (CountCases b)) => Term a -> Term (Sum a b)
injLeft_ :: forall a b.
(HasSpec a, HasSpec b, KnownNat (CountCases b)) =>
Term a -> Term (Sum a b)
injLeft_ = forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm forall t a. (HasSpec t, HasSpec a) => SumW '[t] (Sum t a)
InjLeftW

injRight_ :: (HasSpec a, HasSpec b, KnownNat (CountCases b)) => Term b -> Term (Sum a b)
injRight_ :: forall a b.
(HasSpec a, HasSpec b, KnownNat (CountCases b)) =>
Term b -> Term (Sum a b)
injRight_ = forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm forall t a. (HasSpec t, HasSpec a) => SumW '[a] (Sum t a)
InjRightW

pattern InjRight ::
  forall c.
  () =>
  forall a b.
  ( c ~ Sum a b
  , AppRequires SumW '[b] c
  ) =>
  Term b ->
  Term c
pattern $mInjRight :: forall {r} {c}.
Term c
-> (forall {a} {b}.
    (c ~ Sum a b, AppRequires SumW '[b] c) =>
    Term b -> r)
-> ((# #) -> r)
-> r
InjRight x <- (App (getWitness -> Just InjRightW) (x :> Nil))

pattern InjLeft ::
  forall c.
  () =>
  forall a b.
  ( c ~ Sum a b
  , AppRequires SumW '[a] c
  ) =>
  Term a ->
  Term c
pattern $mInjLeft :: forall {r} {c}.
Term c
-> (forall {a} {b}.
    (c ~ Sum a b, AppRequires SumW '[a] c) =>
    Term a -> r)
-> ((# #) -> r)
-> r
InjLeft x <- App (getWitness -> Just InjLeftW) (x :> Nil)

-- ===========================================================================
-- HasSpec Bool
-- ===========================================================================

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

caseBoolSpec ::
  HasSpec a => Specification Bool -> (Bool -> Specification a) -> Specification a
caseBoolSpec :: forall a.
HasSpec a =>
Specification Bool -> (Bool -> Specification a) -> Specification a
caseBoolSpec Specification Bool
spec Bool -> Specification a
cont = case Specification Bool -> [Bool]
possibleValues Specification Bool
spec of
  [] -> forall a. NonEmpty [Char] -> Specification a
ErrorSpec (forall a. [a] -> NonEmpty a
NE.fromList [[Char]
"No possible values in caseBoolSpec"])
  [Bool
b] -> Bool -> Specification a
cont Bool
b
  [Bool]
_ -> forall a. Monoid a => a
mempty
  where
    -- where possibleValues s = filter (flip conformsToSpec (simplifySpec s)) [True, False]
    -- This will always get the same result, and probably faster since running 2
    -- conformsToSpec on True and False takes less time than simplifying the spec.
    -- Since we are in TheKnot, we could keep the simplifySpec. Is there a good reason to?
    possibleValues :: Specification Bool -> [Bool]
possibleValues Specification Bool
s = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. HasSpec a => a -> Specification a -> Bool
conformsToSpec Specification Bool
s) [Bool
True, Bool
False]

-- | Operations on Bool
data BoolW (dom :: [Type]) (rng :: Type) where
  NotW :: BoolW '[Bool] Bool
  OrW :: BoolW '[Bool, Bool] Bool

deriving instance Eq (BoolW dom rng)

instance Show (BoolW dom rng) where
  show :: BoolW dom rng -> [Char]
show BoolW dom rng
NotW = [Char]
"not_"
  show BoolW dom rng
OrW = [Char]
"or_"

boolSem :: BoolW dom rng -> FunTy dom rng
boolSem :: forall (dom :: [*]) rng. BoolW dom rng -> FunTy dom rng
boolSem BoolW dom rng
NotW = Bool -> Bool
not
boolSem BoolW dom rng
OrW = Bool -> Bool -> Bool
(||)

instance Semantics BoolW where
  semantics :: forall (dom :: [*]) rng. BoolW dom rng -> FunTy dom rng
semantics = forall (dom :: [*]) rng. BoolW dom rng -> FunTy dom rng
boolSem

instance Syntax BoolW

-- ======= Logic instance BoolW

instance Logic BoolW where
  propagate :: forall (as :: [*]) b a.
(AppRequires BoolW as b, HasSpec a) =>
BoolW as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification a
propagate BoolW as b
f ListCtx Value as (HOLE a)
ctxt (ExplainSpec [] Specification b
s) = forall (t :: [*] -> * -> *) (as :: [*]) b a.
(Logic t, AppRequires t as b, HasSpec a) =>
t as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification a
propagate BoolW as b
f ListCtx Value as (HOLE a)
ctxt Specification b
s
  propagate BoolW as b
f ListCtx Value as (HOLE a)
ctxt (ExplainSpec [[Char]]
es Specification b
s) = forall a. [[Char]] -> Specification a -> Specification a
ExplainSpec [[Char]]
es forall a b. (a -> b) -> a -> b
$ forall (t :: [*] -> * -> *) (as :: [*]) b a.
(Logic t, AppRequires t as b, HasSpec a) =>
t as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification a
propagate BoolW as b
f ListCtx Value as (HOLE a)
ctxt Specification b
s
  propagate BoolW as b
_ ListCtx Value as (HOLE a)
_ Specification b
TrueSpec = forall a. Specification a
TrueSpec
  propagate BoolW as b
_ ListCtx Value as (HOLE a)
_ (ErrorSpec NonEmpty [Char]
msgs) = forall a. NonEmpty [Char] -> Specification a
ErrorSpec NonEmpty [Char]
msgs
  propagate BoolW as b
NotW (Unary HOLE a Bool
HOLE) (SuspendedSpec Var b
v Pred
ps) =
    forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained forall a b. (a -> b) -> a -> b
$ \Term a
v' -> forall a. Term a -> Binder a -> Pred
Let (forall (t :: [*] -> * -> *) (dom :: [*]) a.
AppRequires t dom a =>
t dom a -> List Term dom -> Term a
App BoolW '[Bool] Bool
NotW (Term 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)) (Var b
v forall a. HasSpec a => Var a -> Pred -> Binder a
:-> Pred
ps)
  propagate BoolW as b
NotW (Unary HOLE a Bool
HOLE) Specification b
spec =
    forall a.
HasSpec a =>
Specification Bool -> (Bool -> Specification a) -> Specification a
caseBoolSpec Specification b
spec (forall a. a -> Specification a
equalSpec forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not)
  propagate BoolW as b
OrW (HOLE a Bool
HOLE :<: Bool
x) (SuspendedSpec Var b
v Pred
ps) =
    forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained forall a b. (a -> b) -> a -> b
$ \Term a
v' -> forall a. Term a -> Binder a -> Pred
Let (forall (t :: [*] -> * -> *) (dom :: [*]) a.
AppRequires t dom a =>
t dom a -> List Term dom -> Term a
App BoolW '[Bool, Bool] Bool
OrW (Term a
v' forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> forall a. (Typeable a, Eq a, Show a) => a -> Term a
Lit Bool
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)) (Var b
v forall a. HasSpec a => Var a -> Pred -> Binder a
:-> Pred
ps)
  propagate BoolW as b
OrW (Bool
x :>: HOLE a Bool
HOLE) (SuspendedSpec Var b
v Pred
ps) =
    forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained forall a b. (a -> b) -> a -> b
$ \Term a
v' -> forall a. Term a -> Binder a -> Pred
Let (forall (t :: [*] -> * -> *) (dom :: [*]) a.
AppRequires t dom a =>
t dom a -> List Term dom -> Term a
App BoolW '[Bool, Bool] Bool
OrW (forall a. (Typeable a, Eq a, Show a) => a -> Term a
Lit Bool
x forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> Term 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)) (Var b
v forall a. HasSpec a => Var a -> Pred -> Binder a
:-> Pred
ps)
  propagate BoolW as b
OrW (HOLE a Bool
HOLE :<: Bool
s) Specification b
spec =
    forall a.
HasSpec a =>
Specification Bool -> (Bool -> Specification a) -> Specification a
caseBoolSpec Specification b
spec (Bool -> Bool -> Specification Bool
okOr Bool
s)
  propagate BoolW as b
OrW (Bool
s :>: HOLE a Bool
HOLE) Specification b
spec =
    forall a.
HasSpec a =>
Specification Bool -> (Bool -> Specification a) -> Specification a
caseBoolSpec Specification b
spec (Bool -> Bool -> Specification Bool
okOr Bool
s)

  mapTypeSpec :: forall a b.
(HasSpec a, HasSpec b) =>
BoolW '[a] b -> TypeSpec a -> Specification b
mapTypeSpec BoolW '[a] b
NotW (SumSpec Maybe (Int, Int)
h Specification ()
a Specification ()
b) = forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec forall a b. (a -> b) -> a -> b
$ forall a b.
Maybe (Int, Int)
-> Specification a -> Specification b -> SumSpec a b
SumSpec Maybe (Int, Int)
h Specification ()
b Specification ()
a

not_ :: Term Bool -> Term Bool
not_ :: Term Bool -> Term Bool
not_ = forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm BoolW '[Bool] Bool
NotW

-- ======= Logic instance OrW(or_)

-- | We have something like ('constant' ||. HOLE) must evaluate to 'need'.
--   Return a (Specification Bool) for HOLE, that makes that True.
okOr :: Bool -> Bool -> Specification Bool
okOr :: Bool -> Bool -> Specification Bool
okOr Bool
constant Bool
need = case (Bool
constant, Bool
need) of
  (Bool
True, Bool
True) -> forall a. Specification a
TrueSpec
  (Bool
True, Bool
False) ->
    forall a. NonEmpty [Char] -> Specification a
ErrorSpec
      (forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
"(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Bool
constant forall a. [a] -> [a] -> [a]
++ [Char]
"||. HOLE) must equal False. That cannot be the case."))
  (Bool
False, Bool
False) -> forall a. NonEmpty a -> Specification a
MemberSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)
  (Bool
False, Bool
True) -> forall a. NonEmpty a -> Specification a
MemberSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True)

or_ :: Term Bool -> Term Bool -> Term Bool
or_ :: Term Bool -> Term Bool -> Term Bool
or_ = forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm BoolW '[Bool, Bool] Bool
OrW

-- ======= Logic instance EqualW(==.)  CAN WE MOVE THIS OUT OF TheKnot?

data EqW :: [Type] -> Type -> Type where
  EqualW :: (Eq a, HasSpec a) => EqW '[a, a] Bool

deriving instance Eq (EqW dom rng)

instance Show (EqW d r) where
  show :: EqW d r -> [Char]
show EqW d r
EqualW = [Char]
"==."

instance Syntax EqW where
  inFix :: forall (dom :: [*]) rng. EqW dom rng -> Bool
inFix EqW dom rng
EqualW = Bool
True
  prettyWit :: forall (dom :: [*]) rng ann.
(All HasSpec dom, HasSpec rng) =>
EqW dom rng -> List Term dom -> Int -> Maybe (Doc ann)
prettyWit EqW dom rng
_ List Term dom
_ Int
_ = forall a. Maybe a
Nothing

instance Semantics EqW where
  semantics :: forall (d :: [*]) r. EqW d r -> FunTy d r
semantics EqW d r
EqualW = forall a. Eq a => a -> a -> Bool
(==)

instance Logic EqW where
  propagate :: forall (as :: [*]) b a.
(AppRequires EqW as b, HasSpec a) =>
EqW as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification a
propagate EqW as b
f ListCtx Value as (HOLE a)
ctxt (ExplainSpec [[Char]]
es Specification b
s) = forall a. [[Char]] -> Specification a -> Specification a
explainSpec [[Char]]
es forall a b. (a -> b) -> a -> b
$ forall (t :: [*] -> * -> *) (as :: [*]) b a.
(Logic t, AppRequires t as b, HasSpec a) =>
t as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification a
propagate EqW as b
f ListCtx Value as (HOLE a)
ctxt Specification b
s
  propagate EqW as b
_ ListCtx Value as (HOLE a)
_ Specification b
TrueSpec = forall a. Specification a
TrueSpec
  propagate EqW as b
_ ListCtx Value as (HOLE a)
_ (ErrorSpec NonEmpty [Char]
msgs) = forall a. NonEmpty [Char] -> Specification a
ErrorSpec NonEmpty [Char]
msgs
  propagate EqW as b
EqualW (HOLE a a
HOLE :? Value a
x :> List Value as1
Nil) (SuspendedSpec Var b
v Pred
ps) =
    forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained forall a b. (a -> b) -> a -> b
$ \Term a
v' -> forall a. Term a -> Binder a -> Pred
Let (forall (t :: [*] -> * -> *) (dom :: [*]) a.
AppRequires t dom a =>
t dom a -> List Term dom -> Term a
App forall t. (Eq t, HasSpec t) => EqW '[t, t] Bool
EqualW (Term a
v' forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> forall a. (Typeable a, Eq a, Show a) => a -> Term a
Lit 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)) (Var b
v forall a. HasSpec a => Var a -> Pred -> Binder a
:-> Pred
ps)
  propagate EqW as b
EqualW (Value a
x :! Unary HOLE a a
HOLE) (SuspendedSpec Var b
v Pred
ps) =
    forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained forall a b. (a -> b) -> a -> b
$ \Term a
v' -> forall a. Term a -> Binder a -> Pred
Let (forall (t :: [*] -> * -> *) (dom :: [*]) a.
AppRequires t dom a =>
t dom a -> List Term dom -> Term a
App forall t. (Eq t, HasSpec t) => EqW '[t, t] Bool
EqualW (forall a. (Typeable a, Eq a, Show a) => a -> Term a
Lit a
x forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> Term 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)) (Var b
v forall a. HasSpec a => Var a -> Pred -> Binder a
:-> Pred
ps)
  propagate EqW as b
EqualW (HOLE a a
HOLE :? Value a
s :> List Value as1
Nil) Specification b
spec =
    forall a.
HasSpec a =>
Specification Bool -> (Bool -> Specification a) -> Specification a
caseBoolSpec Specification b
spec forall a b. (a -> b) -> a -> b
$ \case
      Bool
True -> forall a. a -> Specification a
equalSpec a
s
      Bool
False -> forall a. HasSpec a => a -> Specification a
notEqualSpec a
s
  propagate EqW as b
EqualW (Value a
s :! Unary HOLE a a
HOLE) Specification b
spec =
    forall a.
HasSpec a =>
Specification Bool -> (Bool -> Specification a) -> Specification a
caseBoolSpec Specification b
spec forall a b. (a -> b) -> a -> b
$ \case
      Bool
True -> forall a. a -> Specification a
equalSpec a
s
      Bool
False -> forall a. HasSpec a => a -> Specification a
notEqualSpec a
s

  rewriteRules :: forall (dom :: [*]) rng.
(TypeList dom, Typeable dom, HasSpec rng, All HasSpec dom) =>
EqW dom rng
-> List Term dom
-> Evidence (AppRequires EqW dom rng)
-> Maybe (Term rng)
rewriteRules EqW dom rng
EqualW (Term a
t :> Term a
t' :> List Term as1
Nil) Evidence (AppRequires EqW dom rng)
Evidence
    | Term a
t forall a. Eq a => a -> a -> Bool
== Term a
t' = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. HasSpec a => a -> Term a
lit Bool
True
    | Bool
otherwise = forall a. Maybe a
Nothing

  saturate :: forall (dom :: [*]). EqW dom Bool -> List Term dom -> [Pred]
saturate EqW dom Bool
EqualW (FromGeneric (InjLeft Term a
_) :> Term a
t :> List Term as1
Nil) = [forall a. HasSpec a => Term a -> TypeSpec a -> Pred
toPreds Term a
t (forall a b.
Maybe (Int, Int)
-> Specification a -> Specification b -> SumSpec a b
SumSpec forall a. Maybe a
Nothing forall a. Specification a
TrueSpec (forall a. NonEmpty [Char] -> Specification a
ErrorSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"saturatePred")))]
  saturate EqW dom Bool
EqualW (FromGeneric (InjRight Term b
_) :> Term a
t :> List Term as1
Nil) = [forall a. HasSpec a => Term a -> TypeSpec a -> Pred
toPreds Term a
t (forall a b.
Maybe (Int, Int)
-> Specification a -> Specification b -> SumSpec a b
SumSpec forall a. Maybe a
Nothing (forall a. NonEmpty [Char] -> Specification a
ErrorSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"saturatePred")) forall a. Specification a
TrueSpec)]
  saturate EqW dom Bool
_ List Term dom
_ = []

infix 4 ==.
(==.) :: HasSpec a => Term a -> Term a -> Term Bool
==. :: forall a. HasSpec a => Term a -> Term a -> Term Bool
(==.) = forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm forall t. (Eq t, HasSpec t) => EqW '[t, t] Bool
EqualW

pattern Equal ::
  forall b.
  () =>
  forall a.
  (b ~ Bool, Eq a, HasSpec a) =>
  Term a ->
  Term a ->
  Term b
pattern $mEqual :: forall {r} {b}.
Term b
-> (forall {a}.
    (b ~ Bool, Eq a, HasSpec a) =>
    Term a -> Term a -> r)
-> ((# #) -> r)
-> r
Equal x y <-
  ( App
      (getWitness -> Just EqualW)
      (x :> y :> Nil)
    )

-- ===========================================================================
-- HasSpec for Integer
-- ===========================================================================

toPredsNumSpec ::
  OrdLike n =>
  Term n ->
  NumSpec n ->
  Pred
toPredsNumSpec :: forall n. OrdLike n => Term n -> NumSpec n -> Pred
toPredsNumSpec Term 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 p. IsPred p => p -> Pred
assert forall a b. (a -> b) -> a -> b
$ forall a. (Typeable a, Eq a, Show a) => a -> Term a
Lit n
l forall a. OrdLike a => Term a -> Term a -> Term Bool
<=. Term n
v | n
l <- forall a. Maybe a -> [a]
maybeToList Maybe n
ml]
      forall a. [a] -> [a] -> [a]
++ [forall p. IsPred p => p -> Pred
assert forall a b. (a -> b) -> a -> b
$ Term n
v forall a. OrdLike a => Term a -> Term a -> Term Bool
<=. forall a. (Typeable a, Eq a, Show a) => a -> Term a
Lit n
u | n
u <- forall a. Maybe a -> [a]
maybeToList Maybe n
mu]

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

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

instance Logic NumOrdW where
  propagate :: forall (as :: [*]) b a.
(AppRequires NumOrdW as b, HasSpec a) =>
NumOrdW as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification a
propagate NumOrdW as b
f ListCtx Value as (HOLE a)
ctxt (ExplainSpec [] Specification b
s) = forall (t :: [*] -> * -> *) (as :: [*]) b a.
(Logic t, AppRequires t as b, HasSpec a) =>
t as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification a
propagate NumOrdW as b
f ListCtx Value as (HOLE a)
ctxt Specification b
s
  propagate NumOrdW as b
f ListCtx Value as (HOLE a)
ctxt (ExplainSpec [[Char]]
es Specification b
s) = forall a. [[Char]] -> Specification a -> Specification a
ExplainSpec [[Char]]
es forall a b. (a -> b) -> a -> b
$ forall (t :: [*] -> * -> *) (as :: [*]) b a.
(Logic t, AppRequires t as b, HasSpec a) =>
t as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification a
propagate NumOrdW as b
f ListCtx Value as (HOLE a)
ctxt Specification b
s
  propagate NumOrdW as b
_ ListCtx Value as (HOLE a)
_ Specification b
TrueSpec = forall a. Specification a
TrueSpec
  propagate NumOrdW as b
_ ListCtx Value as (HOLE a)
_ (ErrorSpec NonEmpty [Char]
msgs) = forall a. NonEmpty [Char] -> Specification a
ErrorSpec NonEmpty [Char]
msgs
  propagate NumOrdW as b
GreaterW (HOLE a a
HOLE :? Value a
x :> List Value as1
Nil) Specification b
spec =
    forall (t :: [*] -> * -> *) (as :: [*]) b a.
(Logic t, AppRequires t as b, HasSpec a) =>
t as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification a
propagate forall a. OrdLike a => NumOrdW '[a, a] Bool
LessW (Value a
x forall (f :: * -> *) a (as1 :: [*]) (c :: * -> *).
f a -> ListCtx f as1 c -> ListCtx f (a : as1) c
:! forall a' a (f :: * -> *). HOLE a' a -> ListCtx f '[a] (HOLE a')
Unary forall {k} (a :: k). HOLE a a
HOLE) Specification b
spec
  propagate NumOrdW as b
GreaterW (Value a
x :! Unary HOLE a a
HOLE) Specification b
spec =
    forall (t :: [*] -> * -> *) (as :: [*]) b a.
(Logic t, AppRequires t as b, HasSpec a) =>
t as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification a
propagate forall a. OrdLike a => NumOrdW '[a, a] Bool
LessW (forall {k} (a :: k). HOLE a a
HOLE forall (c :: * -> *) a (f :: * -> *) (as1 :: [*]).
c a -> List f as1 -> ListCtx f (a : as1) c
:? 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 b
spec
  propagate NumOrdW as b
LessOrEqualW (HOLE a a
HOLE :? Value a
x :> List Value as1
Nil) (SuspendedSpec Var b
v Pred
ps) =
    forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained forall a b. (a -> b) -> a -> b
$ \Term a
v' -> forall a. Term a -> Binder a -> Pred
Let (forall (t :: [*] -> * -> *) (dom :: [*]) a.
AppRequires t dom a =>
t dom a -> List Term dom -> Term a
App forall a. OrdLike a => NumOrdW '[a, a] Bool
LessOrEqualW (Term a
v' forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> forall a. (Typeable a, Eq a, Show a) => a -> Term a
Lit 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)) (Var b
v forall a. HasSpec a => Var a -> Pred -> Binder a
:-> Pred
ps)
  propagate NumOrdW as b
LessOrEqualW (Value a
x :! Unary HOLE a a
HOLE) (SuspendedSpec Var b
v Pred
ps) =
    forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained forall a b. (a -> b) -> a -> b
$ \Term a
v' -> forall a. Term a -> Binder a -> Pred
Let (forall (t :: [*] -> * -> *) (dom :: [*]) a.
AppRequires t dom a =>
t dom a -> List Term dom -> Term a
App forall a. OrdLike a => NumOrdW '[a, a] Bool
LessOrEqualW (forall a. (Typeable a, Eq a, Show a) => a -> Term a
Lit a
x forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> Term 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)) (Var b
v forall a. HasSpec a => Var a -> Pred -> Binder a
:-> Pred
ps)
  propagate NumOrdW as b
LessOrEqualW (HOLE a a
HOLE :? Value a
l :> List Value as1
Nil) Specification b
spec =
    forall a.
HasSpec a =>
Specification Bool -> (Bool -> Specification a) -> Specification a
caseBoolSpec Specification b
spec forall a b. (a -> b) -> a -> b
$ \case Bool
True -> forall a. OrdLike a => a -> Specification a
leqSpec a
l; Bool
False -> forall a. OrdLike a => a -> Specification a
gtSpec a
l
  propagate NumOrdW as b
LessOrEqualW (Value a
l :! Unary HOLE a a
HOLE) Specification b
spec =
    forall a.
HasSpec a =>
Specification Bool -> (Bool -> Specification a) -> Specification a
caseBoolSpec Specification b
spec forall a b. (a -> b) -> a -> b
$ \case Bool
True -> forall a. OrdLike a => a -> Specification a
geqSpec a
l; Bool
False -> forall a. OrdLike a => a -> Specification a
ltSpec a
l
  propagate NumOrdW as b
GreaterOrEqualW (HOLE a a
HOLE :? Value a
x :> List Value as1
Nil) Specification b
spec =
    forall (t :: [*] -> * -> *) (as :: [*]) b a.
(Logic t, AppRequires t as b, HasSpec a) =>
t as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification a
propagate forall a. OrdLike a => NumOrdW '[a, a] Bool
LessOrEqualW (forall a. Show a => a -> Value a
Value a
x forall (f :: * -> *) a (as1 :: [*]) (c :: * -> *).
f a -> ListCtx f as1 c -> ListCtx f (a : as1) c
:! forall a' a (f :: * -> *). HOLE a' a -> ListCtx f '[a] (HOLE a')
Unary forall {k} (a :: k). HOLE a a
HOLE) Specification b
spec
  propagate NumOrdW as b
GreaterOrEqualW (Value a
x :! Unary HOLE a a
HOLE) Specification b
spec =
    forall (t :: [*] -> * -> *) (as :: [*]) b a.
(Logic t, AppRequires t as b, HasSpec a) =>
t as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification a
propagate forall a. OrdLike a => NumOrdW '[a, a] Bool
LessOrEqualW (forall {k} (a :: k). HOLE a a
HOLE forall (c :: * -> *) a (f :: * -> *) (as1 :: [*]).
c a -> List f as1 -> ListCtx f (a : as1) c
:? 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 b
spec
  propagate NumOrdW as b
LessW (HOLE a a
HOLE :? Value a
x :> List Value as1
Nil) (SuspendedSpec Var b
v Pred
ps) =
    forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained forall a b. (a -> b) -> a -> b
$ \Term a
v' -> forall a. Term a -> Binder a -> Pred
Let (forall (t :: [*] -> * -> *) (dom :: [*]) a.
AppRequires t dom a =>
t dom a -> List Term dom -> Term a
App forall a. OrdLike a => NumOrdW '[a, a] Bool
LessW (Term a
v' forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> forall a. (Typeable a, Eq a, Show a) => a -> Term a
Lit 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)) (Var b
v forall a. HasSpec a => Var a -> Pred -> Binder a
:-> Pred
ps)
  propagate NumOrdW as b
LessW (Value a
x :! Unary HOLE a a
HOLE) (SuspendedSpec Var b
v Pred
ps) =
    forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained forall a b. (a -> b) -> a -> b
$ \Term a
v' -> forall a. Term a -> Binder a -> Pred
Let (forall (t :: [*] -> * -> *) (dom :: [*]) a.
AppRequires t dom a =>
t dom a -> List Term dom -> Term a
App forall a. OrdLike a => NumOrdW '[a, a] Bool
LessW (forall a. (Typeable a, Eq a, Show a) => a -> Term a
Lit a
x forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> Term 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)) (Var b
v forall a. HasSpec a => Var a -> Pred -> Binder a
:-> Pred
ps)
  propagate NumOrdW as b
LessW (HOLE a a
HOLE :? Value a
l :> List Value as1
Nil) Specification b
spec =
    forall a.
HasSpec a =>
Specification Bool -> (Bool -> Specification a) -> Specification a
caseBoolSpec Specification b
spec forall a b. (a -> b) -> a -> b
$ \case Bool
True -> forall a. OrdLike a => a -> Specification a
ltSpec a
l; Bool
False -> forall a. OrdLike a => a -> Specification a
geqSpec a
l
  propagate NumOrdW as b
LessW (Value a
l :! Unary HOLE a a
HOLE) Specification b
spec =
    forall a.
HasSpec a =>
Specification Bool -> (Bool -> Specification a) -> Specification a
caseBoolSpec Specification b
spec forall a b. (a -> b) -> a -> b
$ \case Bool
True -> forall a. OrdLike a => a -> Specification a
gtSpec a
l; Bool
False -> forall a. OrdLike a => a -> Specification a
leqSpec a
l

infixr 4 <=.
(<=.) :: forall a. OrdLike a => Term a -> Term a -> Term Bool
<=. :: forall a. OrdLike a => Term a -> Term a -> Term Bool
(<=.) = forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm forall a. OrdLike a => NumOrdW '[a, a] Bool
LessOrEqualW

infixr 4 <.
(<.) :: forall a. OrdLike a => Term a -> Term a -> Term Bool
<. :: forall a. OrdLike a => Term a -> Term a -> Term Bool
(<.) = forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm forall a. OrdLike a => NumOrdW '[a, a] Bool
LessW

infixr 4 >=.
(>=.) :: forall a. OrdLike a => Term a -> Term a -> Term Bool
>=. :: forall a. OrdLike a => Term a -> Term a -> Term Bool
(>=.) = forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm forall a. OrdLike a => NumOrdW '[a, a] Bool
GreaterOrEqualW

infixr 4 >.
(>.) :: forall a. OrdLike a => Term a -> Term a -> Term Bool
>. :: forall a. OrdLike a => Term a -> Term a -> Term Bool
(>.) = forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm forall a. OrdLike a => NumOrdW '[a, a] Bool
GreaterW

-- ===========================================================================
-- SimplifySpec
-- ===========================================================================

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

instance Numeric a => Complete a where
  simplifyA :: Specification a -> Specification a
simplifyA = forall a. HasSpec a => Specification a -> Specification a
simplifySpec
  genFromSpecA :: forall (m :: * -> *).
(HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecA = forall a (m :: * -> *).
(HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecT

-- | If the `Specification Bool` doesn't constrain the boolean you will get a `TrueSpec` out.
ifElse :: (IsPred p, IsPred q) => Term Bool -> p -> q -> Pred
ifElse :: forall p q. (IsPred p, IsPred q) => Term Bool -> p -> q -> Pred
ifElse Term Bool
b p
p q
q = forall p. IsPred p => Term Bool -> p -> Pred
whenTrue Term Bool
b p
p forall a. Semigroup a => a -> a -> a
<> forall p. IsPred p => Term Bool -> p -> Pred
whenTrue (Term Bool -> Term Bool
not_ Term Bool
b) q
q

whenTrue :: forall p. IsPred p => Term Bool -> p -> Pred
whenTrue :: forall p. IsPred p => Term Bool -> p -> Pred
whenTrue (Lit Bool
True) (forall p. IsPred p => p -> Pred
toPred -> Pred
p) = Pred
p
whenTrue (Lit Bool
False) p
_ = Pred
TruePred
whenTrue Term Bool
b (forall p. IsPred p => p -> Pred
toPred -> FalsePred {}) = forall p. IsPred p => p -> Pred
assert (Term Bool -> Term Bool
not_ Term Bool
b)
whenTrue Term Bool
_ (forall p. IsPred p => p -> Pred
toPred -> Pred
TruePred) = Pred
TruePred
whenTrue Term Bool
b (forall p. IsPred p => p -> Pred
toPred -> Pred
p) = HasSpec Bool => Term Bool -> Pred -> Pred
When Term Bool
b Pred
p

-- | Is the variable x pinned to some free term in p? (free term
-- meaning that all the variables in the term are free in p).
--
-- TODO: complete this with more cases!
pinnedBy :: forall a. HasSpec a => Var a -> Pred -> Maybe (Term a)
-- pinnedBy x (Assert (App (extractFn @EqFn @fn -> Just EqualW) (t :> t' :> Nil)))
pinnedBy :: forall a. HasSpec a => Var a -> Pred -> Maybe (Term a)
pinnedBy Var a
x (Assert (Equal Term a
t Term a
t'))
  | V Var a
x' <- Term 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 a
t'
  | V Var a
x' <- Term 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 a
t
pinnedBy Var a
x (And [Pred]
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 a. HasSpec a => Var a -> Pred -> Maybe (Term a)
pinnedBy Var a
x) [Pred]
ps
pinnedBy Var a
_ Pred
_ = forall a. Maybe a
Nothing

-- ------- Stages of simplifying -------------------------------

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

aggressiveInlining :: Pred -> Pred
aggressiveInlining :: Pred -> Pred
aggressiveInlining Pred
pred
  | Bool
inlined = Pred -> Pred
aggressiveInlining Pred
pInlined
  | Bool
otherwise = Pred
pred
  where
    (Pred
pInlined, Any Bool
inlined) = forall w a. Writer w a -> (a, w)
runWriter forall a b. (a -> b) -> a -> b
$ FreeVars -> Subst -> Pred -> WriterT Any Identity Pred
go (forall a. HasVariables a => a -> FreeVars
freeVars Pred
pred) [] Pred
pred

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

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

    -- NOTE: this is safe because we only use the `Subst` when it results in a literal so there
    -- is no risk of variable capture.
    goBinder :: FreeVars -> Subst -> Binder a -> Writer Any (Binder a)
    goBinder :: forall a. FreeVars -> Subst -> Binder a -> Writer Any (Binder a)
goBinder FreeVars
fvs Subst
sub (Var a
x :-> Pred
p) = (Var a
x forall a. HasSpec a => Var a -> Pred -> Binder a
:->) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FreeVars -> Subst -> Pred -> WriterT Any Identity Pred
go (forall {a} {p}.
(HasSpec a, HasVariables p) =>
FreeVars -> Var a -> p -> FreeVars
underBinder FreeVars
fvs Var a
x Pred
p) (forall a. HasSpec a => Subst -> Var a -> Subst
underBinderSub Subst
sub Var a
x) Pred
p

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

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

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

-- | Simplify a Term, if the Term is an 'App', apply the rewrite rules
--   chosen by the (Logic sym t bs a) instance attached
--   to the function witness 'f'
simplifyTerm :: forall a. Term a -> Term a
simplifyTerm :: forall a. Term a -> Term a
simplifyTerm = \case
  V Var a
v -> forall a. HasSpec a => Var a -> Term a
V Var a
v
  Lit a
l -> forall a. (Typeable a, Eq a, Show a) => a -> Term a
Lit a
l
  App (t dom a
f :: t bs a) (forall {k} (f :: k -> *) (g :: k -> *) (as :: [k]).
(forall (a :: k). f a -> g a) -> List f as -> List g as
mapList forall a. Term a -> Term a
simplifyTerm -> List Term dom
ts)
    | Just List Value dom
vs <- forall (as :: [*]). List Term as -> Maybe (List Value as)
fromLits List Term dom
ts -> forall a. (Typeable a, Eq a, Show a) => a -> Term 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 (t :: [*] -> * -> *) (d :: [*]) r.
Semantics t =>
t d r -> FunTy d r
semantics t dom a
f) List Value dom
vs
    | Just Term a
t <- forall (t :: [*] -> * -> *) (dom :: [*]) rng.
(Logic t, TypeList dom, Typeable dom, HasSpec rng,
 All HasSpec dom) =>
t dom rng
-> List Term dom
-> Evidence (AppRequires t dom rng)
-> Maybe (Term rng)
rewriteRules t dom a
f List Term dom
ts (forall (c :: Constraint). c => Evidence c
Evidence @(AppRequires t bs a)) -> forall a. Term a -> Term a
simplifyTerm Term a
t
    | Bool
otherwise -> forall (t :: [*] -> * -> *) (dom :: [*]) a.
AppRequires t dom a =>
t dom a -> List Term dom -> Term a
App t dom a
f List Term dom
ts

simplifyPred :: Pred -> Pred
simplifyPred :: Pred -> Pred
simplifyPred = \case
  -- If the term simplifies away to a literal, that means there is no
  -- more generation to do so we can get rid of `GenHint`
  GenHint Hint a
h Term a
t -> case forall a. Term a -> Term a
simplifyTerm Term a
t of
    Lit {} -> Pred
TruePred
    Term a
t' -> forall a. HasGenHint a => Hint a -> Term a -> Pred
GenHint Hint a
h Term a
t'
  p :: Pred
p@(ElemPred Bool
bool Term a
t NonEmpty a
xs) -> case forall a. Term a -> Term a
simplifyTerm Term a
t of
    Lit a
x -> case (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem a
x NonEmpty a
xs, Bool
bool) of
      (Bool
True, Bool
True) -> Pred
TruePred
      (Bool
True, Bool
False) -> NonEmpty [Char] -> Pred
FalsePred ([Char]
"notElemPred reduces to True" forall a. a -> [a] -> NonEmpty a
:| [forall a. Show a => a -> [Char]
show Pred
p])
      (Bool
False, Bool
True) -> NonEmpty [Char] -> Pred
FalsePred ([Char]
"elemPred reduces to False" forall a. a -> [a] -> NonEmpty a
:| [forall a. Show a => a -> [Char]
show Pred
p])
      (Bool
False, Bool
False) -> Pred
TruePred
    Term a
t' -> forall a. HasSpec a => Bool -> Term a -> NonEmpty a -> Pred
ElemPred Bool
bool Term a
t' NonEmpty a
xs
  Subst Var a
x Term a
t Pred
p -> Pred -> Pred
simplifyPred forall a b. (a -> b) -> a -> b
$ forall a. HasSpec a => Var a -> Term a -> Pred -> Pred
substitutePred Var a
x Term a
t Pred
p
  Assert Term Bool
t -> Term Bool -> Pred
Assert forall a b. (a -> b) -> a -> b
$ forall a. Term a -> Term a
simplifyTerm Term Bool
t
  Reifies Term b
t' Term a
t a -> b
f -> case forall a. Term a -> Term a
simplifyTerm Term a
t of
    Lit a
a ->
      -- Assert $ simplifyTerm t' ==. Lit (f a)
      forall a. HasSpec a => Bool -> Term a -> NonEmpty a -> Pred
ElemPred Bool
True (forall a. Term a -> Term a
simplifyTerm Term b
t') (forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> b
f a
a))
    Term a
t'' -> forall a b.
(HasSpec a, HasSpec b) =>
Term b -> Term a -> (a -> b) -> Pred
Reifies (forall a. Term a -> Term a
simplifyTerm Term b
t') Term a
t'' a -> b
f
  ForAll (Term t
ts :: Term t) (Binder a
b :: Binder a) -> case forall a. Term a -> Term a
simplifyTerm Term t
ts of
    Lit t
as -> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. a -> Binder a -> Pred
`unBind` Binder a
b) (forall t e. Forallable t e => t -> [e]
forAllToList t
as)
    -- (App (extractW (UnionW @t) -> Just Refl) xs) -> error "MADE IT"
    {- Has to wait until we have HasSpec(Set a) instance
    UnionPat (xs :: Term (Set a)) ys ->
       let b' = simplifyBinder b
       in mkForAll xs b' <> mkForAll ys b' -}
    Term t
set' -> case forall a. Binder a -> Binder a
simplifyBinder Binder a
b of
      Var a
_ :-> Pred
TruePred -> Pred
TruePred
      Binder a
b' -> forall t a.
(Forallable t a, HasSpec t, HasSpec a) =>
Term t -> Binder a -> Pred
ForAll Term t
set' Binder a
b'
  DependsOn Term a
_ Lit {} -> Pred
TruePred
  DependsOn Lit {} Term b
_ -> Pred
TruePred
  DependsOn Term a
x Term b
y -> forall a b. (HasSpec a, HasSpec b) => Term a -> Term b -> Pred
DependsOn Term a
x Term b
y
  -- Here is where we need the SumSpec instance
  Case Term (SumOver as)
t List (Weighted Binder) as
bs -> forall (as :: [*]).
HasSpec (SumOver as) =>
Term (SumOver as) -> List (Weighted Binder) as -> Pred
mkCase (forall a. Term a -> Term a
simplifyTerm Term (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 {k1} {k2} (f :: k1 -> *) (a :: k1) (g :: k2 -> *) (b :: k2).
(f a -> g b) -> Weighted f a -> Weighted g b
mapWeighted forall a. Binder a -> Binder a
simplifyBinder) List (Weighted Binder) as
bs)
  When Term Bool
b Pred
p -> forall p. IsPred p => Term Bool -> p -> Pred
whenTrue (forall a. Term a -> Term a
simplifyTerm Term Bool
b) (Pred -> Pred
simplifyPred Pred
p)
  Pred
TruePred -> Pred
TruePred
  FalsePred NonEmpty [Char]
es -> NonEmpty [Char] -> Pred
FalsePred NonEmpty [Char]
es
  And [Pred]
ps -> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([Pred] -> [Pred]
simplifyPreds [Pred]
ps)
  Let Term a
t Binder a
b -> case forall a. Term a -> Term a
simplifyTerm Term a
t of
    t' :: Term a
t'@App {} -> forall a. Term a -> Binder a -> Pred
Let Term a
t' (forall a. Binder a -> Binder a
simplifyBinder Binder a
b)
    -- Variable or literal
    Term a
t' | Var a
x :-> Pred
p <- Binder a
b -> Pred -> Pred
simplifyPred forall a b. (a -> b) -> a -> b
$ forall a. HasSpec a => Var a -> Term a -> Pred -> Pred
substitutePred Var a
x Term a
t' Pred
p
  Exists (forall b. Term b -> b) -> GE a
k Binder a
b -> case forall a. Binder a -> Binder a
simplifyBinder Binder a
b of
    Var a
_ :-> Pred
TruePred -> Pred
TruePred
    -- This is to get rid of exisentials like:
    -- `constrained $ \ x -> exists $ \ y -> [x ==. y, y + 2 <. 10]`
    Var a
x :-> Pred
p | Just Term a
t <- forall a. HasSpec a => Var a -> Pred -> Maybe (Term a)
pinnedBy Var a
x Pred
p -> Pred -> Pred
simplifyPred forall a b. (a -> b) -> a -> b
$ forall a. HasSpec a => Var a -> Term a -> Pred -> Pred
substitutePred Var a
x Term a
t Pred
p
    Binder a
b' -> forall a. ((forall b. Term b -> b) -> GE a) -> Binder a -> Pred
Exists (forall b. Term b -> b) -> GE a
k Binder a
b'
  Monitor {} -> Pred
TruePred
  -- TODO: This is a bit questionable. On the one hand we could get rid of `Explain` here
  -- and just return `simplifyPred p` but doing so risks missing explanations when things
  -- do go wrong.
  Explain NonEmpty [Char]
es Pred
p -> NonEmpty [Char] -> Pred -> Pred
explanation NonEmpty [Char]
es forall a b. (a -> b) -> a -> b
$ Pred -> Pred
simplifyPred Pred
p

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

simplifyBinder :: Binder a -> Binder a
simplifyBinder :: forall a. Binder a -> Binder a
simplifyBinder (Var a
x :-> Pred
p) = Var a
x forall a. HasSpec a => Var a -> Pred -> Binder a
:-> Pred -> Pred
simplifyPred Pred
p

-- --------------------------------------------------------------------
-- Turning Preds into Specifications. Here is where Propagation occurs

-- | Precondition: the `Pred` defines the `Var a`
-- Runs in `GE` in order for us to have detailed context on failure.
computeSpecSimplified ::
  forall a. (HasSpec a, HasCallStack) => Var a -> Pred -> GE (Specification a)
computeSpecSimplified :: forall a.
(HasSpec a, HasCallStack) =>
Var a -> Pred -> GE (Specification a)
computeSpecSimplified Var a
x Pred
pred3 = forall {a}. GE (Specification a) -> GE (Specification a)
localGESpec forall a b. (a -> b) -> a -> b
$ case Pred -> Pred
simplifyPred Pred
pred3 of
  ElemPred Bool
True Term a
t NonEmpty a
xs -> forall v a.
HasSpec v =>
Specification a -> Ctx v a -> Specification v
propagateSpec (forall a. NonEmpty a -> Specification a
MemberSpec NonEmpty a
xs) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) v a.
(Typeable v, Show v, MonadGenError m, HasCallStack) =>
Var v -> Term a -> m (Ctx v a)
toCtx Var a
x Term a
t
  ElemPred Bool
False (Term a
t :: Term b) NonEmpty a
xs -> forall v a.
HasSpec v =>
Specification a -> Ctx v a -> Specification v
propagateSpec (forall a. HasSpec a => TypeSpec a -> [a] -> Specification a
TypeSpec @b (forall a. HasSpec a => TypeSpec a
emptySpec @b) (forall a. NonEmpty a -> [a]
NE.toList NonEmpty a
xs)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) v a.
(Typeable v, Show v, MonadGenError m, HasCallStack) =>
Var v -> Term a -> m (Ctx v a)
toCtx Var a
x Term a
t
  Monitor {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
  GenHint Hint a
h Term a
t -> forall v a.
HasSpec v =>
Specification a -> Ctx v a -> Specification v
propagateSpec (forall a. HasGenHint a => Hint a -> Specification a
giveHint Hint a
h) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) v a.
(Typeable v, Show v, MonadGenError m, HasCallStack) =>
Var v -> Term a -> m (Ctx v a)
toCtx Var a
x Term a
t
  Subst Var a
x' Term a
t Pred
p' -> forall a.
(HasSpec a, HasCallStack) =>
Var a -> Pred -> GE (Specification a)
computeSpec Var a
x (forall a. HasSpec a => Var a -> Term a -> Pred -> Pred
substitutePred Var a
x' Term a
t Pred
p') -- NOTE: this is impossible as it should have gone away already
  Pred
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
genErrorNE NonEmpty [Char]
es
  And [Pred]
ps -> do
    Specification 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 a.
(HasSpec a, HasCallStack) =>
Var a -> Pred -> GE (Specification a)
computeSpecSimplified Var a
x) [Pred]
ps
    case Specification a
spec of
      ExplainSpec [[Char]]
es (SuspendedSpec Var a
y Pred
ps') -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [[Char]] -> Specification a -> Specification a
explainSpecOpt [[Char]]
es (forall a. HasSpec a => Var a -> Pred -> Specification a
SuspendedSpec Var a
y forall a b. (a -> b) -> a -> b
$ Pred -> Pred
simplifyPred Pred
ps')
      SuspendedSpec Var a
y Pred
ps' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. HasSpec a => Var a -> Pred -> Specification a
SuspendedSpec Var a
y forall a b. (a -> b) -> a -> b
$ Pred -> Pred
simplifyPred Pred
ps'
      Specification a
s -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Specification a
s
  Let Term a
t Binder a
b -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. HasSpec a => Var a -> Pred -> Specification a
SuspendedSpec Var a
x (forall a. Term a -> Binder a -> Pred
Let Term a
t Binder a
b)
  Exists (forall b. Term b -> b) -> GE a
k Binder a
b -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. HasSpec a => Var a -> Pred -> Specification a
SuspendedSpec Var a
x (forall a. ((forall b. Term b -> b) -> GE a) -> Binder a -> Pred
Exists (forall b. Term b -> b) -> GE a
k Binder a
b)
  Assert (Lit Bool
True) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
  Assert (Lit Bool
False) -> forall (m :: * -> *) a. MonadGenError m => [Char] -> m a
genError (forall a. Show a => a -> [Char]
show Pred
pred3)
  Assert (Elem Term a
_ (Lit [])) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. NonEmpty [Char] -> Specification a
ErrorSpec (forall a. [a] -> NonEmpty a
NE.fromList [[Char]
"Empty list in ElemPat", forall a. Show a => a -> [Char]
show Pred
pred3]))
  Assert (Elem Term a
t (Lit (a
y : [a]
ys))) -> forall v a.
HasSpec v =>
Specification a -> Ctx v a -> Specification v
propagateSpec (forall a. NonEmpty a -> Specification a
MemberSpec (a
y forall a. a -> [a] -> NonEmpty a
:| [a]
ys)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) v a.
(Typeable v, Show v, MonadGenError m, HasCallStack) =>
Var v -> Term a -> m (Ctx v a)
toCtx Var a
x Term a
t
  Assert Term Bool
t -> forall v a.
HasSpec v =>
Specification a -> Ctx v a -> Specification v
propagateSpec (forall a. a -> Specification a
equalSpec Bool
True) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) v a.
(Typeable v, Show v, MonadGenError m, HasCallStack) =>
Var v -> Term a -> m (Ctx v a)
toCtx Var a
x Term Bool
t
  ForAll (Lit t
s) Binder 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 a.
(HasSpec a, HasCallStack) =>
Var a -> Pred -> GE (Specification a)
computeSpec Var a
x forall a b. (a -> b) -> a -> b
$ forall a. a -> Binder a -> Pred
unBind a
val Binder a
b) (forall t e. Forallable t e => t -> [e]
forAllToList t
s)
  ForAll Term t
t Binder a
b -> do
    Specification a
bSpec <- forall a. Binder a -> GE (Specification a)
computeSpecBinderSimplified Binder a
b
    forall v a.
HasSpec v =>
Specification a -> Ctx v a -> Specification v
propagateSpec (forall t e.
(Forallable t e, HasSpec t, HasSpec e) =>
Specification e -> Specification t
fromForAllSpec Specification a
bSpec) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) v a.
(Typeable v, Show v, MonadGenError m, HasCallStack) =>
Var v -> Term a -> m (Ctx v a)
toCtx Var a
x Term t
t
  Case (Lit SumOver as
val) List (Weighted Binder) as
bs -> forall (as :: [*]) r.
SumOver as
-> List Binder as
-> (forall a. HasSpec a => Var a -> a -> Pred -> 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 {k} (f :: k -> *) (a :: k). Weighted f a -> f a
thing List (Weighted Binder) as
bs) forall a b. (a -> b) -> a -> b
$ \Var a
va a
vaVal Pred
psa -> forall a.
(HasSpec a, HasCallStack) =>
Var a -> Pred -> GE (Specification a)
computeSpec Var a
x (Env -> Pred -> Pred
substPred (forall a. (Typeable a, Show a) => Var a -> a -> Env
singletonEnv Var a
va a
vaVal) Pred
psa)
  Case Term (SumOver as)
t List (Weighted Binder) as
branches -> do
    List (Weighted Specification) 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 {k} (m :: * -> *) (f :: k -> *) (a :: k) (g :: k -> *).
Applicative m =>
(f a -> m (g a)) -> Weighted f a -> m (Weighted g a)
traverseWeighted forall a. Binder a -> GE (Specification a)
computeSpecBinderSimplified) List (Weighted Binder) as
branches
    forall v a.
HasSpec v =>
Specification a -> Ctx v a -> Specification v
propagateSpec (forall (as :: [*]).
HasSpec (SumOver as) =>
Maybe [Char]
-> List (Weighted Specification) as -> Specification (SumOver as)
caseSpec (forall a. a -> Maybe a
Just (forall {k} (t :: k). Typeable t => [Char]
showType @a)) List (Weighted Specification) as
branchSpecs) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) v a.
(Typeable v, Show v, MonadGenError m, HasCallStack) =>
Var v -> Term a -> m (Ctx v a)
toCtx Var a
x Term (SumOver as)
t
  When (Lit Bool
b) Pred
tp -> if Bool
b then forall a.
(HasSpec a, HasCallStack) =>
Var a -> Pred -> GE (Specification a)
computeSpecSimplified Var a
x Pred
tp else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Specification a
TrueSpec
  -- This shouldn't happen a lot of the time because when the body is trivial we mostly get rid of the `When` entirely
  When {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. HasSpec a => Var a -> Pred -> Specification a
SuspendedSpec Var a
x Pred
pred3
  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 a. Specification a
TrueSpec
    | Bool
otherwise ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
          forall a. NonEmpty [Char] -> Specification 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 b
t' (Lit a
val) a -> b
f ->
    forall v a.
HasSpec v =>
Specification a -> Ctx v a -> Specification v
propagateSpec (forall a. a -> Specification a
equalSpec (a -> b
f a
val)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) v a.
(Typeable v, Show v, MonadGenError m, HasCallStack) =>
Var v -> Term a -> m (Ctx v a)
toCtx Var a
x Term b
t'
  Reifies Lit {} Term a
_ a -> b
_ ->
    forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
fatalErrorNE 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
pred3]
  Explain NonEmpty [Char]
es Pred
p -> do
    -- In case things crash in here we want the explanation
    Specification a
s <- forall a. [[Char]] -> GE a -> GE a
pushGE (forall a. NonEmpty a -> [a]
NE.toList NonEmpty [Char]
es) (forall a.
(HasSpec a, HasCallStack) =>
Var a -> Pred -> GE (Specification a)
computeSpecSimplified Var a
x Pred
p)
    -- This is because while we do want to propagate `explanation`s into `SuspendedSpec`
    -- we probably don't want to propagate the full "currently simplifying xyz" explanation.
    case Specification a
s of
      SuspendedSpec Var a
x2 Pred
p2 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. HasSpec a => Var a -> Pred -> Specification a
SuspendedSpec Var a
x2 (NonEmpty [Char] -> Pred -> Pred
explanation NonEmpty [Char]
es Pred
p2)
      Specification a
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty [Char] -> Specification a -> Specification a
addToErrorSpec NonEmpty [Char]
es Specification a
s
  -- Impossible cases that should be ruled out by the dependency analysis and linearizer
  DependsOn {} ->
    forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
fatalErrorNE 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
pred3)
        ]
  Reifies {} ->
    forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
fatalErrorNE 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
pred3)]
  where
    -- We want `genError` to turn into `ErrorSpec` and we want `FatalError` to turn into `FatalError`
    localGESpec :: GE (Specification a) -> GE (Specification a)
localGESpec GE (Specification a)
ge = case GE (Specification a)
ge of
      (GenError NonEmpty (NonEmpty [Char])
xs) -> forall a. a -> GE a
Result forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty [Char] -> Specification a
ErrorSpec (NonEmpty (NonEmpty [Char]) -> NonEmpty [Char]
catMessageList NonEmpty (NonEmpty [Char])
xs)
      (FatalError NonEmpty (NonEmpty [Char])
es) -> forall a. NonEmpty (NonEmpty [Char]) -> GE a
FatalError NonEmpty (NonEmpty [Char])
es
      (Result Specification a
v) -> forall a. a -> GE a
Result Specification a
v

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

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

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

-- --------------- Simplification of Sum types --------------------

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)

-- | Turn a list of branches into a SumSpec. If all the branches fail return an ErrorSpec.
--   Note the requirement of HasSpec(SumOver).
caseSpec ::
  forall as.
  HasSpec (SumOver as) =>
  Maybe String ->
  List (Weighted (Specification)) as ->
  Specification (SumOver as)
caseSpec :: forall (as :: [*]).
HasSpec (SumOver as) =>
Maybe [Char]
-> List (Weighted Specification) as -> Specification (SumOver as)
caseSpec Maybe [Char]
tString List (Weighted Specification) as
ss
  | forall (as2 :: [*]). List (Weighted Specification) as2 -> Bool
allBranchesFail List (Weighted Specification) as
ss =
      forall a. NonEmpty [Char] -> Specification 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 (SumOver as)
spec
            ]
        )
  | Bool
True = Specification (SumOver as)
spec
  where
    spec :: Specification (SumOver as)
spec = forall (as :: [*]).
HasSpec (SumOver as) =>
Maybe [Char]
-> List (Weighted Specification) as -> Specification (SumOver as)
loop Maybe [Char]
tString List (Weighted Specification) as
ss

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

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

-- =======================================================================================
-- Generating from Specifications
-- 1) Simplify
-- 2) Compute a dependency ordering
-- 3) Then generate for each variable in turn, then substituting into the remaining vars
-- =======================================================================================

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

-- | A version of `genFromSpecT` that simply errors if the generator fails
genFromSpec :: forall a. (HasCallStack, HasSpec a) => Specification a -> Gen a
genFromSpec :: forall a. (HasCallStack, HasSpec a) => Specification a -> Gen a
genFromSpec Specification a
spec = do
  Either (NonEmpty (NonEmpty [Char])) a
res <- forall a. GenT GE a -> Gen (Either (NonEmpty (NonEmpty [Char])) a)
catchGen forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *).
(HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecT @a @GE Specification a
spec
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => [Char] -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'\n' forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (NonEmpty [Char]) -> [Char]
catMessages) forall (f :: * -> *) a. Applicative f => a -> f a
pure Either (NonEmpty (NonEmpty [Char])) a
res

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

-- | A version of `genFromSpecT` that runs in the IO monad. Good for debugging.
debugSpec :: forall a. HasSpec a => Specification a -> IO ()
debugSpec :: forall a. HasSpec a => Specification a -> IO ()
debugSpec Specification a
spec = do
  GE a
ans <- forall a. Gen a -> IO a
generate forall a b. (a -> b) -> a -> b
$ forall a. GenT GE a -> Gen a
genFromGenT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) x.
MonadGenError m =>
GenT GE x -> GenT m (GE x)
inspect (forall a (m :: * -> *).
(HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecT Specification a
spec)
  let f :: NonEmpty [Char] -> IO ()
f NonEmpty [Char]
x = [Char] -> IO ()
putStrLn ([[Char]] -> [Char]
unlines (forall a. NonEmpty a -> [a]
NE.toList NonEmpty [Char]
x))
      ok :: a -> IO ()
ok a
x =
        if forall a. HasSpec a => a -> Specification a -> Bool
conformsToSpec a
x Specification a
spec
          then [Char] -> IO ()
putStrLn [Char]
"True"
          else [Char] -> IO ()
putStrLn [Char]
"False, perhaps there is an unsafeExists in the spec?"
  case GE a
ans of
    FatalError NonEmpty (NonEmpty [Char])
xs -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ NonEmpty [Char] -> IO ()
f NonEmpty (NonEmpty [Char])
xs
    GenError NonEmpty (NonEmpty [Char])
xs -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ NonEmpty [Char] -> IO ()
f NonEmpty (NonEmpty [Char])
xs
    Result a
x -> forall a. Show a => a -> IO ()
print Specification a
spec forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Show a => a -> IO ()
print a
x forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> IO ()
ok a
x

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

type DependGraph = Graph.Graph Name

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

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

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

type Hints = DependGraph

respecting :: Hints -> DependGraph -> DependGraph
respecting :: DependGraph -> DependGraph -> DependGraph
respecting DependGraph
hints DependGraph
g = DependGraph
g forall node. Ord node => Graph node -> Graph node -> Graph node
`subtractGraph` forall node. Graph node -> Graph node
opGraph DependGraph
hints

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

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

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

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

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

-- ----------------------- Shrinking -------------------------------

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

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

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

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

-- ---------------------- Building a plan -----------------------------------

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

normalizeSolverStage :: SolverStage -> SolverStage
normalizeSolverStage :: SolverStage -> SolverStage
normalizeSolverStage (SolverStage Var a
x [Pred]
ps Specification a
spec) = forall a.
HasSpec a =>
Var a -> [Pred] -> Specification a -> SolverStage
SolverStage Var a
x [Pred]
ps'' (Specification a
spec forall a. Semigroup a => a -> a -> a
<> Specification a
spec')
  where
    ([Pred]
ps', [Pred]
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 a. HasVariables a => a -> Set Name
freeVarSet) [Pred]
ps
    spec' :: Specification a
spec' = forall a. HasCallStack => GE (Specification a) -> Specification a
fromGESpec forall a b. (a -> b) -> a -> b
$ forall a.
(HasSpec a, HasCallStack) =>
Var a -> Pred -> GE (Specification a)
computeSpec Var a
x ([Pred] -> Pred
And [Pred]
ps')

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

-- TODO: here we can compute both the explicit hints (i.e. constraints that
-- define the order of two variables) and any whole-program smarts.
computeHints :: [Pred] -> Hints
computeHints :: [Pred] -> DependGraph
computeHints [Pred]
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 a
x forall t t'.
(HasVariables t, HasVariables t') =>
t -> t' -> DependGraph
`irreflexiveDependencyOn` Term b
y | DependsOn Term a
x Term b
y <- [Pred]
ps]

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

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

    goBinder ::
      Set Int ->
      Binder a ->
      [Pred] ->
      (HasSpec a => Var a -> [Pred] -> [Pred]) ->
      [Pred]
    goBinder :: forall a.
Set Int
-> Binder a
-> [Pred]
-> (HasSpec a => Var a -> [Pred] -> [Pred])
-> [Pred]
goBinder Set Int
fvs (Var a
x :-> Pred
p) [Pred]
ps HasSpec a => Var a -> [Pred] -> [Pred]
k = HasSpec a => Var a -> [Pred] -> [Pred]
k Var a
x' forall a b. (a -> b) -> a -> b
$ Set Int -> [Pred] -> [Pred]
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
p' forall a. a -> [a] -> [a]
: [Pred]
ps)
      where
        (Var a
x', Pred
p') = forall a t.
(Typeable a, Rename t) =>
Var a -> t -> Set Int -> (Var a, t)
freshen Var a
x Pred
p Set Int
fvs

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

    go :: [Name] -> [(Set Name, Pred)] -> m [SolverStage]
go [] [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    go [] [(Set Name, Pred)]
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, Pred)]
ps =
          case NonEmpty [Char] -> Env -> [Pred] -> Maybe (NonEmpty [Char])
checkPredsE (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"Linearizing fails") forall a. Monoid a => a
mempty (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Set Name, Pred)]
ps) of
            Maybe (NonEmpty [Char])
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
            Just NonEmpty [Char]
msgs -> forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
genErrorNE NonEmpty [Char]
msgs
      | Bool
otherwise =
          forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
fatalErrorNE 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
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, Pred)]
ps)
              ]
    go (n :: Name
n@(Name Var a
x) : [Name]
ns) [(Set Name, Pred)]
ps = do
      let ([(Set Name, Pred)]
nps, [(Set Name, Pred)]
ops) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Name -> Set Name -> Bool
isLastVariable Name
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Set Name, Pred)]
ps
      (SolverStage -> SolverStage
normalizeSolverStage (forall a.
HasSpec a =>
Var a -> [Pred] -> Specification a -> SolverStage
SolverStage Var a
x (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Set Name, Pred)]
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] -> [(Set Name, Pred)] -> m [SolverStage]
go [Name]
ns [(Set Name, Pred)]
ops

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

-- =================================
-- Operations on Stages and Plans

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

prettyPlan :: HasSpec a => Specification a -> Doc ann
prettyPlan :: forall a ann. HasSpec a => Specification a -> Doc ann
prettyPlan (forall a. HasSpec a => Specification a -> Specification a
simplifySpec -> Specification a
spec)
  | SuspendedSpec Var a
_ Pred
p <- Specification a
spec
  , Result SolverPlan
plan <- Pred -> GE SolverPlan
prepareLinearization Pred
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 a
spec
        , forall a ann. Pretty a => a -> Doc ann
pretty SolverPlan
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 a
spec

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

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

stepPlan :: MonadGenError m => Env -> SolverPlan -> GenT m (Env, SolverPlan)
stepPlan :: forall (m :: * -> *).
MonadGenError m =>
Env -> SolverPlan -> GenT m (Env, SolverPlan)
stepPlan Env
env plan :: SolverPlan
plan@(SolverPlan [] DependGraph
_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Env
env, SolverPlan
plan)
stepPlan Env
env (SolverPlan (SolverStage Var a
x [Pred]
ps Specification a
spec : [SolverStage]
pl) DependGraph
gr) = do
  (Specification a
spec', [Specification 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
explain
      ( 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]
ps)
          )
      )
    forall a b. (a -> b) -> a -> b
$ do
      [Specification a]
ispecs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a.
(HasSpec a, HasCallStack) =>
Var a -> Pred -> GE (Specification a)
computeSpec Var a
x) [Pred]
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 a]
ispecs, [Specification a]
ispecs)
  a
val <-
    forall a (m :: * -> *).
(HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecT
      ( forall a. NonEmpty [Char] -> Specification a -> Specification a
addToErrorSpec
          ( forall a. [a] -> NonEmpty a
NE.fromList
              ( ( [Char]
"\nStepPlan for variable: "
                    forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Var a
x
                    forall a. [a] -> [a] -> [a]
++ [Char]
" fails to produce Specification, probably overconstrained."
                    forall a. [a] -> [a] -> [a]
++ [Char]
"PS = "
                    forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unlines (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> [Char]
show [Pred]
ps)
                )
                  forall a. a -> [a] -> [a]
: ([Char]
"Original spec " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification 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
pred Specification a
specx -> [Char]
"  pred " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Pred
pred forall a. [a] -> [a] -> [a]
++ [Char]
" -> " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification a
specx)
                    [Pred]
ps
                    [Specification a]
specs
              )
          )
          (Specification a
spec forall a. Semigroup a => a -> a -> a
<> Specification a
spec')
      )
  let env1 :: Env
env1 = forall a. (Typeable a, Show a) => Var a -> a -> Env -> Env
extendEnv Var a
x a
val Env
env
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Env
env1, SolverPlan -> SolverPlan
backPropagation forall a b. (a -> b) -> a -> b
$ [SolverStage] -> DependGraph -> SolverPlan
SolverPlan (Env -> SolverStage -> SolverStage
substStage Env
env1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SolverStage]
pl) (forall node. Ord node => node -> Graph node -> Graph node
deleteNode (forall a. HasSpec a => Var a -> Name
Name Var a
x) DependGraph
gr))

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

-- | Push as much information we can backwards through the plan.
backPropagation :: SolverPlan -> SolverPlan
-- backPropagation (SolverPlan _plan _graph) =
backPropagation :: SolverPlan -> SolverPlan
backPropagation (SolverPlan [SolverStage]
initplan DependGraph
graph) = [SolverStage] -> DependGraph -> SolverPlan
SolverPlan ([SolverStage] -> [SolverStage] -> [SolverStage]
go [] (forall a. [a] -> [a]
reverse [SolverStage]
initplan)) DependGraph
graph
  where
    go :: [SolverStage] -> [SolverStage] -> [SolverStage]
    go :: [SolverStage] -> [SolverStage] -> [SolverStage]
go [SolverStage]
acc [] = [SolverStage]
acc
    go [SolverStage]
acc (s :: SolverStage
s@(SolverStage (Var a
x :: Var a) [Pred]
ps Specification a
spec) : [SolverStage]
plan) = [SolverStage] -> [SolverStage] -> [SolverStage]
go (SolverStage
s forall a. a -> [a] -> [a]
: [SolverStage]
acc) [SolverStage]
plan'
      where
        newStages :: [SolverStage]
newStages = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Specification a -> Pred -> [SolverStage]
newStage Specification a
spec) [Pred]
ps
        plan' :: [SolverStage]
plan' = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr SolverStage -> [SolverStage] -> [SolverStage]
mergeSolverStage [SolverStage]
plan [SolverStage]
newStages
        -- Note use of the Term Pattern Equal
        newStage :: Specification a -> Pred -> [SolverStage]
newStage Specification a
specl (Assert (Equal (V Var a
x') Term a
t)) =
          forall b.
HasSpec b =>
Specification a -> Var b -> Term b -> [SolverStage]
termVarEqCases Specification a
specl Var a
x' Term a
t
        newStage Specification a
specr (Assert (Equal Term a
t (V Var a
x'))) =
          forall b.
HasSpec b =>
Specification a -> Var b -> Term b -> [SolverStage]
termVarEqCases Specification a
specr Var a
x' Term a
t
        newStage Specification a
_ Pred
_ = []

        termVarEqCases :: HasSpec b => Specification a -> Var b -> Term b -> [SolverStage]
        termVarEqCases :: forall b.
HasSpec b =>
Specification a -> Var b -> Term b -> [SolverStage]
termVarEqCases (MemberSpec NonEmpty a
vs) Var b
x' Term b
t
          | forall a. a -> Set a
Set.singleton (forall a. HasSpec a => Var a -> Name
Name Var a
x) forall a. Eq a => a -> a -> Bool
== forall a. HasVariables a => a -> Set Name
freeVarSet Term b
t =
              [forall a.
HasSpec a =>
Var a -> [Pred] -> Specification a -> SolverStage
SolverStage Var b
x' [] forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> Specification 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 :: * -> *) a. MonadGenError m => Env -> Term a -> m a
runTerm (forall a. (Typeable a, Show a) => Var a -> a -> Env
singletonEnv Var a
x a
v) Term b
t) NonEmpty a
vs))]
        termVarEqCases Specification a
specx Var b
x' Term 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 a. HasVariables a => a -> Set Name
freeVarSet Term b
t
          , Result Ctx a b
ctx <- forall (m :: * -> *) v a.
(Typeable v, Show v, MonadGenError m, HasCallStack) =>
Var v -> Term a -> m (Ctx v a)
toCtx Var a
y Term b
t =
              [forall a.
HasSpec a =>
Var a -> [Pred] -> Specification a -> SolverStage
SolverStage Var a
y [] (forall v a.
HasSpec v =>
Specification a -> Ctx v a -> Specification v
propagateSpec Specification a
specx Ctx a b
ctx)]
        termVarEqCases Specification a
_ Var b
_ Term b
_ = []

-- =======================================================================================

-- | Functor like property for Specification, but instead of a Haskell function (a -> b),
--   it takes a function symbol (t '[a] b) from a to b.
--   Note, in this context, a function symbol is some constructor of a witnesstype.
--   Eg. ProdFstW, InjRightW, SingletonW, etc. NOT the lifted versions like fst_ singleton_,
--   which construct Terms. We had to wait until here to define this because it
--   depends on Semigroup property of Specification, and Asserting equality
mapSpec ::
  forall t a b.
  AppRequires t '[a] b =>
  t '[a] b ->
  Specification a ->
  Specification b
mapSpec :: forall (t :: [*] -> * -> *) a b.
AppRequires t '[a] b =>
t '[a] b -> Specification a -> Specification b
mapSpec t '[a] b
f (ExplainSpec [[Char]]
es Specification a
s) = forall a. [[Char]] -> Specification a -> Specification a
explainSpecOpt [[Char]]
es (forall (t :: [*] -> * -> *) a b.
AppRequires t '[a] b =>
t '[a] b -> Specification a -> Specification b
mapSpec t '[a] b
f Specification a
s)
mapSpec t '[a] b
f Specification a
TrueSpec = forall (t :: [*] -> * -> *) a b.
(Logic t, HasSpec a, HasSpec b) =>
t '[a] b -> TypeSpec a -> Specification b
mapTypeSpec t '[a] b
f (forall a. HasSpec a => TypeSpec a
emptySpec @a)
mapSpec t '[a] b
_ (ErrorSpec NonEmpty [Char]
err) = forall a. NonEmpty [Char] -> Specification a
ErrorSpec NonEmpty [Char]
err
mapSpec t '[a] b
f (MemberSpec NonEmpty a
as) = forall a. NonEmpty a -> Specification 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 (t :: [*] -> * -> *) (d :: [*]) r.
Semantics t =>
t d r -> FunTy d r
semantics t '[a] b
f) NonEmpty a
as
mapSpec t '[a] b
f (SuspendedSpec Var a
x Pred
p) =
  forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained forall a b. (a -> b) -> a -> b
$ \Term b
x' ->
    forall a. ((forall b. Term b -> b) -> GE a) -> Binder a -> Pred
Exists (\forall b. Term b -> b
_ -> forall (m :: * -> *) a. MonadGenError m => [Char] -> m a
fatalError [Char]
"mapSpec") (Var a
x forall a. HasSpec a => Var a -> Pred -> Binder a
:-> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [Term Bool -> Pred
Assert forall a b. (a -> b) -> a -> b
$ (Term b
x' forall a. HasSpec a => Term a -> Term a -> Term Bool
==. forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm t '[a] b
f (forall a. HasSpec a => Var a -> Term a
V Var a
x)), Pred
p])
mapSpec t '[a] b
f (TypeSpec TypeSpec a
ts [a]
cant) = forall (t :: [*] -> * -> *) a b.
(Logic t, HasSpec a, HasSpec b) =>
t '[a] b -> TypeSpec a -> Specification b
mapTypeSpec t '[a] b
f TypeSpec a
ts forall a. Semigroup a => a -> a -> a
<> forall a (f :: * -> *).
(HasSpec a, Foldable f) =>
f a -> Specification a
notMemberSpec (forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: [*] -> * -> *) (d :: [*]) r.
Semantics t =>
t d r -> FunTy d r
semantics t '[a] b
f) [a]
cant)

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

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

-- Without this code the example wouldn't work because `y` is completely unconstrained during
-- generation. With this code we essentially rewrite occurences of `cJust_ A == B` to
-- `[cJust A == B, case B of Nothing -> False; Just _ -> True]` to add extra information
-- about the variables in `B`. Consequently, `y` in the example above is
-- constrained to `MemberSpec [100 .. 102]` in the plan.
saturatePred :: Pred -> [Pred]
saturatePred :: Pred -> [Pred]
saturatePred Pred
p =
  -- [p]
  --  + ---- if there is an Explain, it is still on 'p' here
  --  |
  --  v
  Pred
p forall a. a -> [a] -> [a]
: case Pred
p of
    Explain NonEmpty [Char]
_es Pred
x -> Pred -> [Pred]
saturatePred Pred
x -- Note that the Explain is still on the original 'p', so it is not lost
    {- We want rules like this. But because the patterns can not be in scope, we implement these in
    -- the 'saturate' method of the Logic class
    Assert (Equal (FromGeneric (InjLeft _)) t) -> [toPreds t (SumSpec Nothing TrueSpec (ErrorSpec (pure "saturatePred")))]
    Assert (Equal (FromGeneric (InjRight _)) t) -> [toPreds t (SumSpec Nothing (ErrorSpec (pure "saturatePred")) TrueSpec)]
    Assert (Elem @Bool @a (FromGeneric (Product @n @m x y)) (Lit zs))
      | Just Refl <- eqT @a @(m, n) -> case zs of
          (w : ws) -> [ElemPred True x (fmap fst (w :| ws))]
          [] -> [FalsePred (pure $ "empty list, zs , in elem_ " ++ show (x, y) ++ " zs")]
    Assert (Elem x (Lit (y : ys))) -> [satisfies x (MemberSpec (y :| ys))]
    -- ElemPred True x ys -> [satisfies x (MemberSpec ys)]
    -}
    -- Note how the saturation is done by the 'saturate' method of the Logic class
    Assert ((App (t dom Bool
sym :: t dom Bool) List Term dom
xs) :: Term Bool) -> forall (t :: [*] -> * -> *) (dom :: [*]).
Logic t =>
t dom Bool -> List Term dom -> [Pred]
saturate t dom Bool
sym List Term dom
xs
    -- TODO: e.g. `elem (pair x y) (lit zs) -> elem x (lit $ map fst zs)` etc.
    Pred
_ -> []

-- ================================================================
-- HasSpec for Products
-- ================================================================

pairView :: forall a b. (HasSpec a, HasSpec b) => Term (Prod a b) -> Maybe (Term a, Term b)
pairView :: forall a b.
(HasSpec a, HasSpec b) =>
Term (Prod a b) -> Maybe (Term a, Term b)
pairView (App (forall (t1 :: [*] -> * -> *) (d1 :: [*]) r1 (t2 :: [*] -> * -> *)
       (d2 :: [*]) r2.
(AppRequires t1 d1 r1, AppRequires t2 d2 r2) =>
t1 d1 r1
-> t2 d2 r2 -> Maybe (t1 d1 r1, t1 :~: t2, d1 :~: d2, r1 :~: r2)
sameFunSym forall a b. (a -> b) -> a -> b
$ forall t a. (HasSpec t, HasSpec a) => ProdW '[t, a] (Prod t a)
ProdW @a @b -> Just (ProdW '[a, b] (Prod a b)
_, ProdW :~: t
Refl, '[a, b] :~: dom
Refl, Prod a b :~: Prod a b
Refl)) (Term a
x :> Term a
y :> List Term as1
Nil)) = forall a. a -> Maybe a
Just (Term a
x, Term a
y)
pairView Term (Prod a b)
_ = forall a. Maybe a
Nothing

cartesian ::
  forall a b.
  (HasSpec a, HasSpec b) =>
  Specification a ->
  Specification b ->
  Specification (Prod a b)
cartesian :: forall a b.
(HasSpec a, HasSpec b) =>
Specification a -> Specification b -> Specification (Prod a b)
cartesian (ErrorSpec NonEmpty [Char]
es) (ErrorSpec NonEmpty [Char]
fs) = forall a. NonEmpty [Char] -> Specification a
ErrorSpec (NonEmpty [Char]
es forall a. Semigroup a => a -> a -> a
<> NonEmpty [Char]
fs)
cartesian (ErrorSpec NonEmpty [Char]
es) Specification b
_ = forall a. NonEmpty [Char] -> Specification a
ErrorSpec (forall a. a -> NonEmpty a -> NonEmpty a
NE.cons [Char]
"cartesian left" NonEmpty [Char]
es)
cartesian Specification a
_ (ErrorSpec NonEmpty [Char]
es) = forall a. NonEmpty [Char] -> Specification a
ErrorSpec (forall a. a -> NonEmpty a -> NonEmpty a
NE.cons [Char]
"cartesian right" NonEmpty [Char]
es)
cartesian Specification a
s Specification b
s' = forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec forall a b. (a -> b) -> a -> b
$ forall a b. Specification a -> Specification b -> PairSpec a b
Cartesian Specification a
s Specification b
s'

data PairSpec a b = Cartesian (Specification a) (Specification b)

instance (Arbitrary (Specification a), Arbitrary (Specification b)) => Arbitrary (PairSpec a b) where
  arbitrary :: Gen (PairSpec a b)
arbitrary = forall a b. Specification a -> Specification b -> PairSpec a b
Cartesian 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
  shrink :: PairSpec a b -> [PairSpec a b]
shrink (Cartesian Specification a
a Specification b
b) = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. Specification a -> Specification b -> PairSpec a b
Cartesian forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => a -> [a]
shrink (Specification a
a, Specification b
b)

instance (HasSpec a, HasSpec b) => HasSpec (Prod a b) where
  type TypeSpec (Prod a b) = PairSpec a b

  type Prerequisites (Prod a b) = (HasSpec a, HasSpec b)

  emptySpec :: TypeSpec (Prod a b)
emptySpec = forall a b. Specification a -> Specification b -> PairSpec a b
Cartesian forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty

  combineSpec :: TypeSpec (Prod a b)
-> TypeSpec (Prod a b) -> Specification (Prod a b)
combineSpec (Cartesian Specification a
a Specification b
b) (Cartesian Specification a
a' Specification b
b') = forall a b.
(HasSpec a, HasSpec b) =>
Specification a -> Specification b -> Specification (Prod a b)
cartesian (Specification a
a forall a. Semigroup a => a -> a -> a
<> Specification a
a') (Specification b
b forall a. Semigroup a => a -> a -> a
<> Specification b
b')

  conformsTo :: HasCallStack => Prod a b -> TypeSpec (Prod a b) -> Bool
conformsTo (Prod a
a b
b) (Cartesian Specification a
sa Specification b
sb) = forall a. HasSpec a => a -> Specification a -> Bool
conformsToSpec a
a Specification a
sa Bool -> Bool -> Bool
&& forall a. HasSpec a => a -> Specification a -> Bool
conformsToSpec b
b Specification b
sb

  genFromTypeSpec :: forall (m :: * -> *).
(HasCallStack, MonadGenError m) =>
TypeSpec (Prod a b) -> GenT m (Prod a b)
genFromTypeSpec (Cartesian Specification a
sa Specification b
sb) = forall a b. a -> b -> Prod a b
Prod forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecT Specification a
sa forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *).
(HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecT Specification b
sb

  shrinkWithTypeSpec :: TypeSpec (Prod a b) -> Prod a b -> [Prod a b]
shrinkWithTypeSpec (Cartesian Specification a
sa Specification b
sb) (Prod a
a b
b) =
    [forall a b. a -> b -> Prod a b
Prod a
a' b
b | a
a' <- forall a. HasSpec a => Specification a -> a -> [a]
shrinkWithSpec Specification a
sa a
a]
      forall a. [a] -> [a] -> [a]
++ [forall a b. a -> b -> Prod a b
Prod a
a b
b' | b
b' <- forall a. HasSpec a => Specification a -> a -> [a]
shrinkWithSpec Specification b
sb b
b]

  toPreds :: Term (Prod a b) -> TypeSpec (Prod a b) -> Pred
toPreds Term (Prod a b)
x (Cartesian Specification a
sf Specification b
ss) =
    forall a. HasSpec a => Term a -> Specification a -> Pred
satisfies (forall a b. (HasSpec a, HasSpec b) => Term (Prod a b) -> Term a
prodFst_ Term (Prod a b)
x) Specification a
sf
      forall a. Semigroup a => a -> a -> a
<> forall a. HasSpec a => Term a -> Specification a -> Pred
satisfies (forall a b. (HasSpec a, HasSpec b) => Term (Prod a b) -> Term b
prodSnd_ Term (Prod a b)
x) Specification b
ss

  cardinalTypeSpec :: TypeSpec (Prod a b) -> Specification Integer
cardinalTypeSpec (Cartesian Specification a
x Specification b
y) = (forall a.
(Number Integer, HasSpec a) =>
Specification a -> Specification Integer
cardinality Specification a
x) forall a. Num a => a -> a -> a
+ (forall a.
(Number Integer, HasSpec a) =>
Specification a -> Specification Integer
cardinality Specification b
y)

  typeSpecHasError :: TypeSpec (Prod a b) -> Maybe (NonEmpty [Char])
typeSpecHasError (Cartesian Specification a
x Specification b
y) =
    case (forall a. Specification a -> Bool
isErrorLike Specification a
x, forall a. Specification a -> Bool
isErrorLike Specification b
y) of
      (Bool
False, Bool
False) -> forall a. Maybe a
Nothing
      (Bool
True, Bool
False) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Specification a -> NonEmpty [Char]
errorLikeMessage Specification a
x
      (Bool
False, Bool
True) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Specification a -> NonEmpty [Char]
errorLikeMessage Specification b
y
      (Bool
True, Bool
True) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (forall a. Specification a -> NonEmpty [Char]
errorLikeMessage Specification a
x forall a. Semigroup a => a -> a -> a
<> forall a. Specification a -> NonEmpty [Char]
errorLikeMessage Specification b
y)

  alternateShow :: TypeSpec (Prod a b) -> BinaryShow
alternateShow (Cartesian Specification a
left right :: Specification b
right@(TypeSpec TypeSpec b
r [])) =
    case forall a. HasSpec a => TypeSpec a -> BinaryShow
alternateShow @b TypeSpec b
r of
      (BinaryShow [Char]
"Cartesian" [Doc a]
ps) -> forall a. [Char] -> [Doc a] -> BinaryShow
BinaryShow [Char]
"Cartesian" (Doc a
"," forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow Specification a
left forall a. a -> [a] -> [a]
: [Doc a]
ps)
      (BinaryShow [Char]
"SumSpec" [Doc a]
ps) -> forall a. [Char] -> [Doc a] -> BinaryShow
BinaryShow [Char]
"Cartesian" (Doc a
"," forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow Specification a
left forall a. a -> [a] -> [a]
: [Doc a
"SumSpec" 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]
"Cartesian" [Doc Any
"," forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow Specification a
left, Doc Any
"," forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow Specification b
right]
  alternateShow (Cartesian Specification a
left Specification b
right) = forall a. [Char] -> [Doc a] -> BinaryShow
BinaryShow [Char]
"Cartesian" [Doc Any
"," forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow Specification a
left, Doc Any
"," forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow Specification b
right]

instance (HasSpec a, HasSpec b) => Show (PairSpec a b) where
  show :: PairSpec a b -> [Char]
show pair :: PairSpec a b
pair@(Cartesian Specification a
l Specification b
r) = case forall a. HasSpec a => TypeSpec a -> BinaryShow
alternateShow @(Prod a b) PairSpec a b
pair of
    (BinaryShow [Char]
"Cartesian" [Doc a]
ps) -> forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ 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
_ -> [Char]
"(Cartesian " forall a. [a] -> [a] -> [a]
++ [Char]
"(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification a
l forall a. [a] -> [a] -> [a]
++ [Char]
") (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification b
r forall a. [a] -> [a] -> [a]
++ [Char]
"))"

-- ==================================================
-- Logic instances for Prod
-- ==================================================

-- ========= ProdFstW

data ProdW :: [Type] -> Type -> Type where
  ProdW :: (HasSpec a, HasSpec b) => ProdW '[a, b] (Prod a b)
  ProdFstW :: (HasSpec a, HasSpec b) => ProdW '[Prod a b] a
  ProdSndW :: (HasSpec a, HasSpec b) => ProdW '[Prod a b] b
deriving instance Eq (ProdW as b)
deriving instance Show (ProdW as b)

instance Syntax ProdW
instance Semantics ProdW where
  semantics :: forall (d :: [*]) r. ProdW d r -> FunTy d r
semantics ProdW d r
ProdW = forall a b. a -> b -> Prod a b
Prod
  semantics ProdW d r
ProdFstW = forall a b. Prod a b -> a
prodFst
  semantics ProdW d r
ProdSndW = forall a b. Prod a b -> b
prodSnd

instance Logic ProdW where
  propagateTypeSpec :: forall (as :: [*]) b a.
(AppRequires ProdW as b, HasSpec a) =>
ProdW as b
-> ListCtx Value as (HOLE a)
-> TypeSpec b
-> [b]
-> Specification a
propagateTypeSpec ProdW as b
ProdFstW (Unary HOLE a (Prod b b)
HOLE) TypeSpec b
ts [b]
cant = forall a b.
(HasSpec a, HasSpec b) =>
Specification a -> Specification b -> Specification (Prod a b)
cartesian (forall a. HasSpec a => TypeSpec a -> [a] -> Specification a
TypeSpec TypeSpec b
ts [b]
cant) forall a. Specification a
TrueSpec
  propagateTypeSpec ProdW as b
ProdSndW (Unary HOLE a (Prod a b)
HOLE) TypeSpec b
ts [b]
cant =
    forall a b.
(HasSpec a, HasSpec b) =>
Specification a -> Specification b -> Specification (Prod a b)
cartesian forall a. Specification a
TrueSpec (forall a. HasSpec a => TypeSpec a -> [a] -> Specification a
TypeSpec TypeSpec b
ts [b]
cant)
  propagateTypeSpec ProdW as b
ProdW (a
a :>: HOLE a b
HOLE) sc :: TypeSpec b
sc@(Cartesian Specification a
sa Specification a
sb) [b]
cant
    | a
a forall a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification a
sa = Specification a
sb forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. HasSpec a => a -> Specification a
notEqualSpec (forall a1 a2. Eq a1 => a1 -> [Prod a1 a2] -> [a2]
sameFst a
a [b]
cant)
    | Bool
otherwise =
        forall a. NonEmpty [Char] -> Specification a
ErrorSpec
          ( forall a. [a] -> NonEmpty a
NE.fromList
              [[Char]
"propagate (pair_ " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
a forall a. [a] -> [a] -> [a]
++ [Char]
" HOLE) has conformance failure on a", forall a. Show a => a -> [Char]
show (forall a. HasSpec a => TypeSpec a -> [a] -> Specification a
TypeSpec TypeSpec b
sc [b]
cant)]
          )
  propagateTypeSpec ProdW as b
ProdW (HOLE a a
HOLE :<: b
b) sc :: TypeSpec b
sc@(Cartesian Specification a
sa Specification b
sb) [b]
cant
    | b
b forall a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification b
sb = Specification a
sa forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. HasSpec a => a -> Specification a
notEqualSpec (forall a1 a2. Eq a1 => a1 -> [Prod a2 a1] -> [a2]
sameSnd b
b [b]
cant)
    | Bool
otherwise =
        forall a. NonEmpty [Char] -> Specification a
ErrorSpec
          ( forall a. [a] -> NonEmpty a
NE.fromList
              [[Char]
"propagate (pair_ HOLE " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show b
b forall a. [a] -> [a] -> [a]
++ [Char]
") has conformance failure on b", forall a. Show a => a -> [Char]
show (forall a. HasSpec a => TypeSpec a -> [a] -> Specification a
TypeSpec TypeSpec b
sc [b]
cant)]
          )

  propagateMemberSpec :: forall (as :: [*]) b a.
(AppRequires ProdW as b, HasSpec a) =>
ProdW as b
-> ListCtx Value as (HOLE a) -> NonEmpty b -> Specification a
propagateMemberSpec ProdW as b
ProdFstW (Unary HOLE a (Prod b b)
HOLE) NonEmpty b
es = forall a b.
(HasSpec a, HasSpec b) =>
Specification a -> Specification b -> Specification (Prod a b)
cartesian (forall a. NonEmpty a -> Specification a
MemberSpec NonEmpty b
es) forall a. Specification a
TrueSpec
  propagateMemberSpec ProdW as b
ProdSndW (Unary HOLE a (Prod a b)
HOLE) NonEmpty b
es = forall a b.
(HasSpec a, HasSpec b) =>
Specification a -> Specification b -> Specification (Prod a b)
cartesian forall a. Specification a
TrueSpec (forall a. NonEmpty a -> Specification a
MemberSpec NonEmpty b
es)
  propagateMemberSpec ProdW as b
ProdW (a
a :>: HOLE a b
HOLE) NonEmpty b
es =
    case (forall a. Eq a => [a] -> [a]
nub (forall a1 a2. Eq a1 => a1 -> [Prod a1 a2] -> [a2]
sameFst a
a (forall a. NonEmpty a -> [a]
NE.toList NonEmpty b
es))) of
      (a
w : [a]
ws) -> forall a. NonEmpty a -> Specification a
MemberSpec (a
w forall a. a -> [a] -> NonEmpty a
:| [a]
ws)
      [] ->
        forall a. NonEmpty [Char] -> Specification a
ErrorSpec forall a b. (a -> b) -> a -> b
$
          forall a. [a] -> NonEmpty a
NE.fromList
            [ [Char]
"propagate (pair_ HOLE " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
a forall a. [a] -> [a] -> [a]
++ [Char]
") on (MemberSpec " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a. NonEmpty a -> [a]
NE.toList NonEmpty b
es)
            , [Char]
"Where " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
a forall a. [a] -> [a] -> [a]
++ [Char]
" does not appear as the fst component of anything in the MemberSpec."
            ]
  propagateMemberSpec ProdW as b
ProdW (HOLE a a
HOLE :<: b
b) NonEmpty b
es =
    case (forall a. Eq a => [a] -> [a]
nub (forall a1 a2. Eq a1 => a1 -> [Prod a2 a1] -> [a2]
sameSnd b
b (forall a. NonEmpty a -> [a]
NE.toList NonEmpty b
es))) of
      (a
w : [a]
ws) -> forall a. NonEmpty a -> Specification a
MemberSpec (a
w forall a. a -> [a] -> NonEmpty a
:| [a]
ws)
      [] ->
        forall a. NonEmpty [Char] -> Specification a
ErrorSpec forall a b. (a -> b) -> a -> b
$
          forall a. [a] -> NonEmpty a
NE.fromList
            [ [Char]
"propagate (pair_ HOLE " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show b
b forall a. [a] -> [a] -> [a]
++ [Char]
") on (MemberSpec " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a. NonEmpty a -> [a]
NE.toList NonEmpty b
es)
            , [Char]
"Where " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show b
b forall a. [a] -> [a] -> [a]
++ [Char]
" does not appear as the snd component of anything in the MemberSpec."
            ]

  rewriteRules :: forall (dom :: [*]) rng.
(TypeList dom, Typeable dom, HasSpec rng, All HasSpec dom) =>
ProdW dom rng
-> List Term dom
-> Evidence (AppRequires ProdW dom rng)
-> Maybe (Term rng)
rewriteRules ProdW dom rng
ProdFstW ((forall a b.
(HasSpec a, HasSpec b) =>
Term (Prod a b) -> Maybe (Term a, Term b)
pairView -> Just (Term rng
x, Term b
_)) :> List Term as1
Nil) Evidence (AppRequires ProdW dom rng)
Evidence = forall a. a -> Maybe a
Just Term rng
x
  rewriteRules ProdW dom rng
ProdSndW ((forall a b.
(HasSpec a, HasSpec b) =>
Term (Prod a b) -> Maybe (Term a, Term b)
pairView -> Just (Term a
_, Term rng
y)) :> List Term as1
Nil) Evidence (AppRequires ProdW dom rng)
Evidence = forall a. a -> Maybe a
Just Term rng
y
  rewriteRules ProdW dom rng
_ List Term dom
_ Evidence (AppRequires ProdW dom rng)
_ = forall a. Maybe a
Nothing

  mapTypeSpec :: forall a b.
(HasSpec a, HasSpec b) =>
ProdW '[a] b -> TypeSpec a -> Specification b
mapTypeSpec ProdW '[a] b
ProdFstW (Cartesian Specification b
s Specification b
_) = Specification b
s
  mapTypeSpec ProdW '[a] b
ProdSndW (Cartesian Specification a
_ Specification b
s) = Specification b
s

prodFst_ :: (HasSpec a, HasSpec b) => Term (Prod a b) -> Term a
prodFst_ :: forall a b. (HasSpec a, HasSpec b) => Term (Prod a b) -> Term a
prodFst_ = forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm forall a t. (HasSpec a, HasSpec t) => ProdW '[Prod a t] a
ProdFstW

prodSnd_ :: (HasSpec a, HasSpec b) => Term (Prod a b) -> Term b
prodSnd_ :: forall a b. (HasSpec a, HasSpec b) => Term (Prod a b) -> Term b
prodSnd_ = forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm forall t b. (HasSpec t, HasSpec b) => ProdW '[Prod t b] b
ProdSndW

-- ========= ProdW
sameFst :: Eq a1 => a1 -> [Prod a1 a2] -> [a2]
sameFst :: forall a1 a2. Eq a1 => a1 -> [Prod a1 a2] -> [a2]
sameFst a1
a [Prod a1 a2]
ps = [a2
b | Prod a1
a' a2
b <- [Prod a1 a2]
ps, a1
a forall a. Eq a => a -> a -> Bool
== a1
a']

sameSnd :: Eq a1 => a1 -> [Prod a2 a1] -> [a2]
sameSnd :: forall a1 a2. Eq a1 => a1 -> [Prod a2 a1] -> [a2]
sameSnd a1
b [Prod a2 a1]
ps = [a2
a | Prod a2
a a1
b' <- [Prod a2 a1]
ps, a1
b forall a. Eq a => a -> a -> Bool
== a1
b']

prod_ :: (HasSpec a, HasSpec b) => Term a -> Term b -> Term (Prod a b)
prod_ :: forall a b.
(HasSpec a, HasSpec b) =>
Term a -> Term b -> Term (Prod a b)
prod_ = forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm forall t a. (HasSpec t, HasSpec a) => ProdW '[t, a] (Prod t a)
ProdW

-- ===============================================================================
-- Arbitrary instances
-- ===============================================================================

instance (HasSpec a, Arbitrary (TypeSpec a)) => Arbitrary (Specification a) where
  arbitrary :: Gen (Specification a)
arbitrary = do
    Specification a
baseSpec <-
      forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
        [ (Int
1, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Specification 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 a. (HasCallStack, HasSpec a) => Specification a -> Gen a
genFromSpec forall a. Specification a
TrueSpec)
              forall (f :: * -> *) a. Applicative f => a -> f a
pure
                ( forall a. [a] -> NonEmpty [Char] -> Specification 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 a. HasSpec a => TypeSpec a -> Specification 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 a. HasSpec a => TypeSpec a -> [a] -> Specification 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 a. (HasCallStack, HasSpec a) => Specification a -> Gen a
genFromSpec forall a. Specification a
TrueSpec)
          )
        , (Int
1, forall a. NonEmpty [Char] -> Specification a
ErrorSpec forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary)
        , -- Recurse to make sure we apply the tricks for generating suspended specs multiple times
          (Int
1, forall a. Arbitrary a => Gen a
arbitrary)
        ]
    -- TODO: we probably want smarter ways of generating constraints
    forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
      [ (Int
1, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained forall a b. (a -> b) -> a -> b
$ \Term a
x -> Term a
x forall a. HasSpec a => Term a -> Specification a -> Pred
`satisfies` Specification a
baseSpec)
      , (Int
1, forall a. [[Char]] -> Specification a -> Specification a
ExplainSpec [[Char]
"Arbitrary"] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary)
      ,
        ( Int
1
        , forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained forall a b. (a -> b) -> a -> b
$ \Term a
x -> forall a p.
(HasSpec a, IsPred p) =>
((forall b. Term b -> b) -> GE a) -> (Term a -> p) -> Pred
exists (\forall b. Term b -> b
eval -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b. Term b -> b
eval Term a
x) forall a b. (a -> b) -> a -> b
$ \Term a
y ->
            [ forall p. IsPred p => p -> Pred
assert forall a b. (a -> b) -> a -> b
$ Term a
x forall a. HasSpec a => Term a -> Term a -> Term Bool
==. Term a
y
            , Term a
y forall a. HasSpec a => Term a -> Specification a -> Pred
`satisfies` Specification a
baseSpec
            ]
        )
      , (Int
1, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained forall a b. (a -> b) -> a -> b
$ \Term a
x -> forall a p.
(HasSpec a, IsPred p) =>
Term a -> (Term a -> p) -> Pred
letBind Term a
x forall a b. (a -> b) -> a -> b
$ \Term a
y -> Term a
y forall a. HasSpec a => Term a -> Specification a -> Pred
`satisfies` Specification a
baseSpec)
      ,
        ( Int
1
        , forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained forall a b. (a -> b) -> a -> b
$ \Term a
x -> forall a p.
(HasSpec a, IsPred p) =>
((forall b. Term b -> b) -> GE a) -> (Term a -> p) -> Pred
exists (\forall b. Term b -> b
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True) forall a b. (a -> b) -> a -> b
$ \Term Bool
b ->
            forall p q. (IsPred p, IsPred q) => Term Bool -> p -> q -> Pred
ifElse Term Bool
b (Term a
x forall a. HasSpec a => Term a -> Specification a -> Pred
`satisfies` Specification a
baseSpec) (Term a
x forall a. HasSpec a => Term a -> Specification a -> Pred
`satisfies` Specification a
baseSpec)
        )
      ,
        ( Int
1
        , forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained forall a b. (a -> b) -> a -> b
$ \Term a
x -> forall a p.
(HasSpec a, IsPred p) =>
((forall b. Term b -> b) -> GE a) -> (Term a -> p) -> Pred
exists (\forall b. Term b -> b
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True) forall a b. (a -> b) -> a -> b
$ \Term Bool
b ->
            [ forall p q. (IsPred p, IsPred q) => Term Bool -> p -> q -> Pred
ifElse Term Bool
b Bool
True (Term a
x forall a. HasSpec a => Term a -> Specification a -> Pred
`satisfies` Specification a
baseSpec)
            , Term a
x forall a. HasSpec a => Term a -> Specification a -> Pred
`satisfies` Specification a
baseSpec
            ]
        )
      ,
        ( Int
1
        , forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained forall a b. (a -> b) -> a -> b
$ \Term a
x -> forall a p.
(HasSpec a, IsPred p) =>
((forall b. Term b -> b) -> GE a) -> (Term a -> p) -> Pred
exists (\forall b. Term b -> b
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False) forall a b. (a -> b) -> a -> b
$ \Term Bool
b ->
            [ forall p q. (IsPred p, IsPred q) => Term Bool -> p -> q -> Pred
ifElse Term Bool
b (Term a
x forall a. HasSpec a => Term a -> Specification a -> Pred
`satisfies` Specification a
baseSpec) Bool
True
            , Term a
x forall a. HasSpec a => Term a -> Specification a -> Pred
`satisfies` Specification a
baseSpec
            ]
        )
      ,
        ( Int
1
        , forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained forall a b. (a -> b) -> a -> b
$ \Term a
x -> NonEmpty [Char] -> Pred -> Pred
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 a
x forall a. HasSpec a => Term a -> Specification a -> Pred
`satisfies` Specification a
baseSpec
        )
      , (Int
10, forall (f :: * -> *) a. Applicative f => a -> f a
pure Specification a
baseSpec)
      ]

pattern Product ::
  forall c.
  () =>
  forall a b.
  ( c ~ Prod a b
  , AppRequires ProdW '[a, b] (Prod a b)
  ) =>
  Term a ->
  Term b ->
  Term c
pattern $mProduct :: forall {r} {c}.
Term c
-> (forall {a} {b}.
    (c ~ Prod a b, AppRequires ProdW '[a, b] (Prod a b)) =>
    Term a -> Term b -> r)
-> ((# #) -> r)
-> r
Product x y <- (App (getWitness -> Just ProdW) (x :> y :> Nil))

-- =================================================
-- CAN WE MOVE THIS OUT OF TheKnot?

data ElemW :: [Type] -> Type -> Type where
  ElemW :: HasSpec a => ElemW '[a, [a]] Bool

deriving instance Eq (ElemW dom rng)

instance Show (ElemW dom rng) where
  show :: ElemW dom rng -> [Char]
show ElemW dom rng
ElemW = [Char]
"elem_"

instance Syntax ElemW

instance Semantics ElemW where
  semantics :: forall (d :: [*]) r. ElemW d r -> FunTy d r
semantics ElemW d r
ElemW = forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem

instance Logic ElemW where
  propagate :: forall (as :: [*]) b a.
(AppRequires ElemW as b, HasSpec a) =>
ElemW as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification a
propagate ElemW as b
f ListCtx Value as (HOLE a)
ctxt (ExplainSpec [[Char]]
es Specification b
s) = forall a. [[Char]] -> Specification a -> Specification a
explainSpec [[Char]]
es forall a b. (a -> b) -> a -> b
$ forall (t :: [*] -> * -> *) (as :: [*]) b a.
(Logic t, AppRequires t as b, HasSpec a) =>
t as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification a
propagate ElemW as b
f ListCtx Value as (HOLE a)
ctxt Specification b
s
  propagate ElemW as b
_ ListCtx Value as (HOLE a)
_ Specification b
TrueSpec = forall a. Specification a
TrueSpec
  propagate ElemW as b
_ ListCtx Value as (HOLE a)
_ (ErrorSpec NonEmpty [Char]
msgs) = forall a. NonEmpty [Char] -> Specification a
ErrorSpec NonEmpty [Char]
msgs
  propagate ElemW as b
ElemW (HOLE a a
HOLE :<: ([a]
x :: [w])) (SuspendedSpec Var b
v Pred
ps) =
    forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained forall a b. (a -> b) -> a -> b
$ \Term a
v' -> forall a. Term a -> Binder a -> Pred
Let (forall (t :: [*] -> * -> *) (dom :: [*]) a.
AppRequires t dom a =>
t dom a -> List Term dom -> Term a
App forall t. HasSpec t => ElemW '[t, [t]] Bool
ElemW ((Term a
v' :: Term w) forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> forall a. (Typeable a, Eq a, Show a) => a -> Term a
Lit [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)) (Var b
v forall a. HasSpec a => Var a -> Pred -> Binder a
:-> Pred
ps)
  propagate ElemW as b
ElemW (a
x :>: HOLE a [a]
HOLE) (SuspendedSpec Var b
v Pred
ps) =
    forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained forall a b. (a -> b) -> a -> b
$ \Term a
v' -> forall a. Term a -> Binder a -> Pred
Let (forall (t :: [*] -> * -> *) (dom :: [*]) a.
AppRequires t dom a =>
t dom a -> List Term dom -> Term a
App forall t. HasSpec t => ElemW '[t, [t]] Bool
ElemW (forall a. (Typeable a, Eq a, Show a) => a -> Term a
Lit a
x forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> Term 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)) (Var b
v forall a. HasSpec a => Var a -> Pred -> Binder a
:-> Pred
ps)
  propagate ElemW as b
ElemW (HOLE a a
HOLE :<: [a]
es) Specification b
spec =
    forall a.
HasSpec a =>
Specification Bool -> (Bool -> Specification a) -> Specification a
caseBoolSpec Specification b
spec forall a b. (a -> b) -> a -> b
$ \case
      Bool
True -> forall a. [a] -> NonEmpty [Char] -> Specification a
memberSpecList (forall a. Eq a => [a] -> [a]
nub [a]
es) (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"propagate on (elem_ x []), The empty list, [], has no solution")
      Bool
False -> forall a (f :: * -> *).
(HasSpec a, Foldable f) =>
f a -> Specification a
notMemberSpec [a]
es
  propagate ElemW as b
ElemW (a
e :>: HOLE a [a]
HOLE) Specification b
spec =
    forall a.
HasSpec a =>
Specification Bool -> (Bool -> Specification a) -> Specification a
caseBoolSpec Specification b
spec forall a b. (a -> b) -> a -> b
$ \case
      Bool
True -> forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec (forall a.
Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
ListSpec forall a. Maybe a
Nothing [a
e] forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. FoldSpec a
NoFold)
      Bool
False -> forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec (forall a.
Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
ListSpec forall a. Maybe a
Nothing forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty (forall a. HasSpec a => a -> Specification a
notEqualSpec a
e) forall a. FoldSpec a
NoFold)

  rewriteRules :: forall (dom :: [*]) rng.
(TypeList dom, Typeable dom, HasSpec rng, All HasSpec dom) =>
ElemW dom rng
-> List Term dom
-> Evidence (AppRequires ElemW dom rng)
-> Maybe (Term rng)
rewriteRules ElemW dom rng
ElemW (Term a
_ :> Lit [] :> List Term as1
Nil) Evidence (AppRequires ElemW dom rng)
Evidence = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. (Typeable a, Eq a, Show a) => a -> Term a
Lit Bool
False
  rewriteRules ElemW dom rng
ElemW (Term a
t :> Lit [a
a] :> List Term as1
Nil) Evidence (AppRequires ElemW dom rng)
Evidence = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Term a
t forall a. HasSpec a => Term a -> Term a -> Term Bool
==. (forall a. (Typeable a, Eq a, Show a) => a -> Term a
Lit a
a)
  rewriteRules ElemW dom rng
_ List Term dom
_ Evidence (AppRequires ElemW dom rng)
_ = forall a. Maybe a
Nothing

  saturate :: forall (dom :: [*]). ElemW dom Bool -> List Term dom -> [Pred]
saturate ElemW dom Bool
ElemW ((FromGeneric (Product (Term a
x :: Term a) (Term b
y :: Term b)) :: Term c) :> Lit a
zs :> List Term as1
Nil)
    | Just a :~: (a, b)
Refl <- forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @c @(a, b) = case a
zs of
        ((a, b)
w : [(a, b)]
ws) -> [forall a. HasSpec a => Bool -> Term a -> NonEmpty a -> Pred
ElemPred Bool
True Term a
x (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst ((a, b)
w forall a. a -> [a] -> NonEmpty a
:| [(a, b)]
ws))]
        [] -> [NonEmpty [Char] -> Pred
FalsePred (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Char]
"empty list, zs , in elem_ " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Term a
x, Term b
y) forall a. [a] -> [a] -> [a]
++ [Char]
" zs")]
    | Bool
otherwise = []
  saturate ElemW dom Bool
ElemW (Term a
x :> Lit (a
y : [a]
ys) :> List Term as1
Nil) = [forall a. HasSpec a => Term a -> Specification a -> Pred
satisfies Term a
x (forall a. NonEmpty a -> Specification a
MemberSpec (a
y forall a. a -> [a] -> NonEmpty a
:| [a]
ys))]
  saturate ElemW dom Bool
_ List Term dom
_ = []

infix 4 `elem_`
elem_ :: (Sized [a], HasSpec a) => Term a -> Term [a] -> Term Bool
elem_ :: forall a. (Sized [a], HasSpec a) => Term a -> Term [a] -> Term Bool
elem_ = forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm forall t. HasSpec t => ElemW '[t, [t]] Bool
ElemW

elemFn :: HasSpec a => Fun '[a, [a]] Bool
elemFn :: forall a. HasSpec a => Fun '[a, [a]] Bool
elemFn = forall (t :: [*] -> * -> *) (dom :: [*]) rng.
AppRequires t dom rng =>
t dom rng -> Fun dom rng
Fun forall t. HasSpec t => ElemW '[t, [t]] Bool
ElemW

pattern Elem ::
  forall b.
  () =>
  forall a.
  (b ~ Bool, Eq a, HasSpec a) =>
  Term a ->
  Term [a] ->
  Term b
pattern $mElem :: forall {r} {b}.
Term b
-> (forall {a}.
    (b ~ Bool, Eq a, HasSpec a) =>
    Term a -> Term [a] -> r)
-> ((# #) -> r)
-> r
Elem x y <-
  ( App
      (getWitness -> Just ElemW)
      (x :> y :> Nil)
    )

-- ================================================================
-- The TypeSpec for List. Used in the HasSpec instance for Lists
-- ================================================================

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

instance
  ( Arbitrary a
  , Arbitrary (FoldSpec a)
  , Arbitrary (TypeSpec a)
  , HasSpec a
  ) =>
  Arbitrary (ListSpec a)
  where
  arbitrary :: Gen (ListSpec a)
arbitrary = forall a.
Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec 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 a -> [ListSpec a]
shrink (ListSpec Maybe Integer
a [a]
b Specification Integer
c Specification a
d FoldSpec a
e) = [forall a.
Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
ListSpec Maybe Integer
a' [a]
b' Specification Integer
c' Specification a
d' FoldSpec a
e' | (Maybe Integer
a', [a]
b', Specification Integer
c', Specification a
d', FoldSpec a
e') <- forall a. Arbitrary a => a -> [a]
shrink (Maybe Integer
a, [a]
b, Specification Integer
c, Specification a
d, FoldSpec a
e)]

instance HasSpec a => Show (FoldSpec a) where
  showsPrec :: Int -> FoldSpec 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 a => Pretty (WithPrec (FoldSpec a)) where
  pretty :: forall ann. WithPrec (FoldSpec a) -> Doc ann
pretty (WithPrec Int
_ FoldSpec a
NoFold) = Doc ann
"NoFold"
  pretty (WithPrec Int
d (FoldSpec Fun '[a] b
fun Specification 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 Fun '[a] b
fun
          , Doc ann
"spec =" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Specification b
s
          ]

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

instance HasSpec a => Show (ListSpec a) where
  showsPrec :: Int -> ListSpec 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 a =>
  Pretty (WithPrec (ListSpec a))
  where
  pretty :: forall ann. WithPrec (ListSpec a) -> Doc ann
pretty (WithPrec Int
d ListSpec 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 a. ListSpec a -> Maybe Integer
listSpecHint ListSpec a
s)
          , Doc ann
"must =" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow (forall a. ListSpec a -> [a]
listSpecMust ListSpec a
s)
          , Doc ann
"size =" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall a. ListSpec a -> Specification Integer
listSpecSize ListSpec a
s)
          , Doc ann
"elem =" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall a. ListSpec a -> Specification a
listSpecElem ListSpec a
s)
          , Doc ann
"fold =" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall a. ListSpec a -> FoldSpec a
listSpecFold ListSpec a
s)
          ]

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

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

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

  genFromTypeSpec :: forall (m :: * -> *).
(HasCallStack, MonadGenError m) =>
TypeSpec [a] -> GenT m [a]
genFromTypeSpec (ListSpec Maybe Integer
_ [a]
must Specification Integer
_ Specification a
elemS FoldSpec 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 a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification a
elemS)) [a]
must =
        forall (m :: * -> *) a. MonadGenError m => [Char] -> m a
genError [Char]
"genTypeSpecSpec @ListSpec: some elements of mustSet do not conform to elemS"
  genFromTypeSpec (ListSpec Maybe Integer
msz [a]
must Specification Integer
TrueSpec Specification a
elemS FoldSpec 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 a (m :: * -> *).
(HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecT Specification a
elemS
      Just Integer
szHint -> do
        Integer
sz <- forall (m :: * -> *).
MonadGenError m =>
Specification Integer -> GenT m Integer
genFromSizeSpec (forall a. OrdLike a => a -> Specification a
leqSpec Integer
szHint)
        forall a (m :: * -> *).
(Typeable a, MonadGenError m) =>
GenT GE a -> Int -> (Int -> Bool) -> GenT m [a]
listOfUntilLenT (forall a (m :: * -> *).
(HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecT Specification 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 Integer
szSpec Specification a
elemS FoldSpec a
NoFold) = do
    Integer
sz0 <- forall (m :: * -> *).
MonadGenError m =>
Specification Integer -> GenT m Integer
genFromSizeSpec (Specification Integer
szSpec forall a. Semigroup a => a -> a -> a
<> forall a. OrdLike a => a -> Specification a
geqSpec (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 a. Specification a
TrueSpec (forall a. OrdLike a => a -> Specification 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 a (m :: * -> *).
(Typeable a, MonadGenError m) =>
GenT GE a -> Int -> (Int -> Bool) -> GenT m [a]
listOfUntilLenT
        (forall a (m :: * -> *).
(HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecT Specification a
elemS)
        Int
sz
        ((forall a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification 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 Integer
szSpec Specification a
elemS (FoldSpec Fun '[a] b
f Specification b
foldS)) = do
    let szSpec' :: Specification Integer
szSpec' = Specification Integer
szSpec forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Specification a
TrueSpec (forall a. OrdLike a => a -> Specification 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
    forall (m :: * -> *) a b.
(MonadGenError m, Foldy b, HasSpec a) =>
[a]
-> Specification Integer
-> Specification a
-> Fun '[a] b
-> Specification b
-> GenT m [a]
genFromFold [a]
must Specification Integer
szSpec' Specification a
elemS Fun '[a] b
f Specification b
foldS

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

  cardinalTypeSpec :: TypeSpec [a] -> Specification Integer
cardinalTypeSpec TypeSpec [a]
_ = forall a. Specification a
TrueSpec

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

  conformsTo :: HasCallStack => [a] -> TypeSpec [a] -> Bool
conformsTo [a]
xs (ListSpec Maybe Integer
_ [a]
must Specification Integer
size Specification a
elemS FoldSpec a
foldS) =
    forall t. Sized t => t -> Integer
sizeOf [a]
xs
      forall a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification 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 a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification a
elemS) [a]
xs
      Bool -> Bool -> Bool
&& [a]
xs
        forall a. [a] -> FoldSpec a -> Bool
`conformsToFoldSpec` FoldSpec a
foldS

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

sizeOf_ :: (HasSpec a, Sized a) => Term a -> Term Integer
sizeOf_ :: forall a. (HasSpec a, Sized a) => Term a -> Term Integer
sizeOf_ = forall (ts :: [*]) (f :: * -> *) r.
TypeList ts =>
(List f ts -> r) -> FunTy (MapList f ts) r
curryList (forall (t :: [*] -> * -> *) (dom :: [*]) a.
AppRequires t dom a =>
t dom a -> List Term dom -> Term a
App forall t. (Sized t, HasSpec t) => SizeW '[t] Integer
SizeOfW)

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

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

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

-- =====================================================================
-- Syntax, Semantics and Logic instances for function symbols on List

data ListW (args :: [Type]) (res :: Type) where
  FoldMapW :: forall a b. (Foldy b, HasSpec a) => Fun '[a] b -> ListW '[[a]] b
  SingletonListW :: HasSpec a => ListW '[a] [a]
  AppendW :: (HasSpec a, Typeable a, Show a) => ListW '[[a], [a]] [a]

instance Semantics ListW where
  semantics :: forall (d :: [*]) r. ListW d r -> FunTy d r
semantics = forall (d :: [*]) r. ListW d r -> FunTy d r
listSem

instance Syntax ListW where
  prettyWit :: forall (dom :: [*]) rng ann.
(All HasSpec dom, HasSpec rng) =>
ListW dom rng -> List Term dom -> Int -> Maybe (Doc ann)
prettyWit ListW dom rng
AppendW (Lit a
n :> Term a
y :> List Term as1
Nil) Int
p = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall ann. Bool -> Doc ann -> Doc ann
parensIf (Int
p forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$ Doc ann
"append_" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a x. (Show a, Typeable a) => [a] -> Doc x
short a
n forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty (WithPrec a) => Int -> a -> Doc ann
prettyPrec Int
10 Term a
y
  prettyWit ListW dom rng
AppendW (Term a
y :> Lit a
n :> List Term as1
Nil) Int
p = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall ann. Bool -> Doc ann -> Doc ann
parensIf (Int
p forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$ Doc ann
"append_" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty (WithPrec a) => Int -> a -> Doc ann
prettyPrec Int
10 Term a
y forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a x. (Show a, Typeable a) => [a] -> Doc x
short a
n
  prettyWit ListW dom rng
_ List Term dom
_ Int
_ = forall a. Maybe a
Nothing

listSem :: ListW dom rng -> FunTy dom rng
listSem :: forall (d :: [*]) r. ListW d r -> FunTy d r
listSem (FoldMapW (Fun t '[a] rng
f)) = forall a. Foldy a => [a] -> a
adds forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: [*] -> * -> *) (d :: [*]) r.
Semantics t =>
t d r -> FunTy d r
semantics t '[a] rng
f)
listSem ListW dom rng
SingletonListW = (forall a. a -> [a] -> [a]
: [])
listSem ListW dom rng
AppendW = forall a. [a] -> [a] -> [a]
(++)

instance Show (ListW d r) where
  show :: ListW d r -> [Char]
show ListW d r
AppendW = [Char]
"append_"
  show ListW d r
SingletonListW = [Char]
"singletonList_"
  show (FoldMapW Fun '[a] r
n) = [Char]
"(FoldMapW  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Fun '[a] r
n forall a. [a] -> [a] -> [a]
++ [Char]
")"

deriving instance (Eq (ListW d r))

instance Logic ListW where
  propagateTypeSpec :: forall (as :: [*]) b a.
(AppRequires ListW as b, HasSpec a) =>
ListW as b
-> ListCtx Value as (HOLE a)
-> TypeSpec b
-> [b]
-> Specification a
propagateTypeSpec (FoldMapW Fun '[a] b
f) (Unary HOLE a [a]
HOLE) TypeSpec b
ts [b]
cant =
    forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec (forall a.
Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
ListSpec forall a. Maybe a
Nothing [] forall a. Specification a
TrueSpec forall a. Specification a
TrueSpec forall a b. (a -> b) -> a -> b
$ forall t a.
(HasSpec a, HasSpec t, Foldy t) =>
Fun '[a] t -> Specification t -> FoldSpec a
FoldSpec Fun '[a] b
f (forall a. HasSpec a => TypeSpec a -> [a] -> Specification a
TypeSpec TypeSpec b
ts [b]
cant))
  propagateTypeSpec ListW as b
SingletonListW (Unary HOLE a a
HOLE) (ListSpec Maybe Integer
_ [a]
m Specification Integer
sz Specification a
e FoldSpec a
f) [b]
cant
    | forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
m forall a. Ord a => a -> a -> Bool
> Int
1 =
        forall a. NonEmpty [Char] -> Specification a
ErrorSpec forall a b. (a -> b) -> a -> b
$
          forall a. [a] -> NonEmpty a
NE.fromList
            [ [Char]
"Too many required elements for SingletonListW : "
            , [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 a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification Integer
sz =
        forall a. NonEmpty [Char] -> Specification 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 SingletonListW : " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification 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 a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification a
e)) [a]
m =
        forall a. NonEmpty [Char] -> Specification a
ErrorSpec forall a b. (a -> b) -> a -> b
$
          forall a. [a] -> NonEmpty a
NE.fromList
            [ [Char]
"The following elements of the must spec do not conforms to the elem spec:"
            , forall a. Show a => a -> [Char]
show [a]
bad
            ]
    -- There is precisely one required element in the final list, so the argument to singletonList_ has to
    -- be that element and we have to respect the cant and fold specs
    | [a
a] <- [a]
m = forall a. a -> Specification a
equalSpec a
a forall a. Semigroup a => a -> a -> a
<> forall a (f :: * -> *).
(HasSpec a, Foldable f) =>
f a -> Specification a
notMemberSpec [a
z | [a
z] <- [b]
cant] forall a. Semigroup a => a -> a -> a
<> forall a. FoldSpec a -> Specification a
reverseFoldSpec FoldSpec a
f
    -- We have to respect the elem-spec, the can't spec, and the fold spec.
    | Bool
otherwise = Specification a
e forall a. Semigroup a => a -> a -> a
<> forall a (f :: * -> *).
(HasSpec a, Foldable f) =>
f a -> Specification a
notMemberSpec [a
a | [a
a] <- [b]
cant] forall a. Semigroup a => a -> a -> a
<> forall a. FoldSpec a -> Specification a
reverseFoldSpec FoldSpec a
f
  propagateTypeSpec ListW as b
AppendW ListCtx Value as (HOLE a)
ctx (ts :: TypeSpec b
ts@ListSpec {listSpecElem :: forall a. ListSpec a -> Specification a
listSpecElem = Specification a
e}) [b]
cant
    | (HOLE a a
HOLE :? Value ([a]
ys :: [a]) :> List Value as1
Nil) <- ListCtx Value as (HOLE a)
ctx
    , Evidence (Prerequisites [a])
Evidence <- forall a. HasSpec a => Evidence (Prerequisites a)
prerequisites @[a]
    , forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification a
e) [a]
ys =
        forall a. HasSpec a => TypeSpec a -> [a] -> Specification a
TypeSpec (forall a. Eq a => [a] -> ListSpec a -> ListSpec a
alreadyHave [a]
ys TypeSpec b
ts) (forall a. Eq a => [a] -> [[a]] -> [[a]]
suffixedBy [a]
ys [b]
cant)
    | (Value ([a]
ys :: [a]) :! Unary HOLE a [a]
HOLE) <- ListCtx Value as (HOLE a)
ctx
    , Evidence (Prerequisites [a])
Evidence <- forall a. HasSpec a => Evidence (Prerequisites a)
prerequisites @[a]
    , forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification a
e) [a]
ys =
        forall a. HasSpec a => TypeSpec a -> [a] -> Specification a
TypeSpec (forall a. Eq a => [a] -> ListSpec a -> ListSpec a
alreadyHave [a]
ys TypeSpec b
ts) (forall a. Eq a => [a] -> [[a]] -> [[a]]
prefixedBy [a]
ys [b]
cant)
    | Bool
otherwise = forall a. NonEmpty [Char] -> Specification a
ErrorSpec forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"The spec given to propagate for AppendW is inconsistent!"

  propagateMemberSpec :: forall (as :: [*]) b a.
(AppRequires ListW as b, HasSpec a) =>
ListW as b
-> ListCtx Value as (HOLE a) -> NonEmpty b -> Specification a
propagateMemberSpec (FoldMapW Fun '[a] b
f) (Unary HOLE a [a]
HOLE) NonEmpty b
es =
    forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec (forall a.
Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
ListSpec forall a. Maybe a
Nothing [] forall a. Specification a
TrueSpec forall a. Specification a
TrueSpec forall a b. (a -> b) -> a -> b
$ forall t a.
(HasSpec a, HasSpec t, Foldy t) =>
Fun '[a] t -> Specification t -> FoldSpec a
FoldSpec Fun '[a] b
f (forall a. NonEmpty a -> Specification a
MemberSpec NonEmpty b
es))
  propagateMemberSpec ListW as b
SingletonListW (Unary HOLE a a
HOLE) NonEmpty b
xss =
    case [a
a | [a
a] <- forall a. NonEmpty a -> [a]
NE.toList NonEmpty b
xss] of
      [] ->
        forall a. NonEmpty [Char] -> Specification a
ErrorSpec forall a b. (a -> b) -> a -> b
$ (forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"PropagateSpec SingletonListW  with MemberSpec which has no lists of length 1")
      (a
x : [a]
xs) -> forall a. NonEmpty a -> Specification a
MemberSpec (a
x forall a. a -> [a] -> NonEmpty a
:| [a]
xs)
  propagateMemberSpec ListW as b
AppendW ListCtx Value as (HOLE a)
ctx NonEmpty b
xss
    | (HOLE a [a]
HOLE :<: ([a]
ys :: [a])) <- ListCtx Value as (HOLE a)
ctx
    , Evidence (Prerequisites [a])
Evidence <- forall a. HasSpec a => Evidence (Prerequisites a)
prerequisites @[a] =
        -- Only keep the prefixes of the elements of xss that can
        -- give you the correct resulting list
        case forall a. Eq a => [a] -> [[a]] -> [[a]]
suffixedBy [a]
ys (forall a. NonEmpty a -> [a]
NE.toList NonEmpty b
xss) of
          [] ->
            forall a. NonEmpty [Char] -> Specification a
ErrorSpec
              ( 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"
                  ]
              )
          ([a]
x : [[a]]
xs) -> forall a. NonEmpty a -> Specification a
MemberSpec ([a]
x forall a. a -> [a] -> NonEmpty a
:| [[a]]
xs)
    | (([a]
ys :: [a]) :>: HOLE a [a]
HOLE) <- ListCtx Value as (HOLE a)
ctx
    , Evidence (Prerequisites [a])
Evidence <- forall a. HasSpec a => Evidence (Prerequisites a)
prerequisites @[a] =
        -- Only keep the suffixes of the elements of xss that can
        -- give you the correct resulting list
        case forall a. Eq a => [a] -> [[a]] -> [[a]]
prefixedBy [a]
ys (forall a. NonEmpty a -> [a]
NE.toList NonEmpty b
xss) of
          [] ->
            forall a. NonEmpty [Char] -> Specification a
ErrorSpec
              ( 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"
                  ]
              )
          ([a]
x : [[a]]
xs) -> forall a. NonEmpty a -> Specification a
MemberSpec ([a]
x forall a. a -> [a] -> NonEmpty a
:| [[a]]
xs)

  mapTypeSpec :: forall a b.
(HasSpec a, HasSpec b) =>
ListW '[a] b -> TypeSpec a -> Specification b
mapTypeSpec ListW '[a] b
SingletonListW TypeSpec a
ts = forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec (forall a.
Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
ListSpec forall a. Maybe a
Nothing [] (forall a. a -> Specification a
equalSpec Integer
1) (forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec TypeSpec a
ts) forall a. FoldSpec a
NoFold)
  mapTypeSpec (FoldMapW Fun '[a] b
g) TypeSpec a
ts =
    forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained forall a b. (a -> b) -> a -> b
$ \Term b
x ->
      forall a p. (HasSpec a, IsPred p) => (Term a -> p) -> Pred
unsafeExists forall a b. (a -> b) -> a -> b
$ \Term [a]
x' ->
        Term Bool -> Pred
Assert (Term b
x forall a. HasSpec a => Term a -> Term a -> Term Bool
==. forall x b. Fun '[x] b -> Term x -> Term b
appFun (forall a b. (HasSpec a, Foldy b) => Fun '[a] b -> Fun '[[a]] b
foldMapFn Fun '[a] b
g) Term [a]
x') forall a. Semigroup a => a -> a -> a
<> forall a. HasSpec a => Term a -> TypeSpec a -> Pred
toPreds Term [a]
x' TypeSpec a
ts

foldMap_ :: forall a b. (Foldy b, HasSpec a) => (Term a -> Term b) -> Term [a] -> Term b
foldMap_ :: forall a b.
(Foldy b, HasSpec a) =>
(Term a -> Term b) -> Term [a] -> Term b
foldMap_ Term a -> Term b
f = forall x b. Fun '[x] b -> Term x -> Term b
appFun forall a b. (a -> b) -> a -> b
$ forall a b. (HasSpec a, Foldy b) => Fun '[a] b -> Fun '[[a]] b
foldMapFn forall a b. (a -> b) -> a -> b
$ forall x. HasCallStack => Term x -> Fun '[a] x
toFn forall a b. (a -> b) -> a -> b
$ Term a -> Term b
f (forall a. HasSpec a => Var a -> Term a
V Var a
v)
  where
    v :: Var a
v = forall a. Int -> [Char] -> Var a
Var (-Int
1) [Char]
"v" :: Var a
    -- Turn `f (V v) = fn (gn (hn v))` into `composeFn fn (composeFn gn hn)`
    -- Note: composeFn :: HasSpec b => Fun '[b] c -> Fun '[a] b -> Fun '[a] c
    toFn :: forall x. HasCallStack => Term x -> Fun '[a] x
    toFn :: forall x. HasCallStack => Term x -> Fun '[a] x
toFn (App t dom x
fn (V Var a
v' :> List Term 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' = forall (t :: [*] -> * -> *) (dom :: [*]) rng.
AppRequires t dom rng =>
t dom rng -> Fun dom rng
Fun t dom x
fn
    toFn (App t dom x
fn (Term a
t :> List Term as1
Nil)) = forall b c a.
(HasSpec b, HasSpec c) =>
Fun '[b] c -> Fun '[a] b -> Fun '[a] c
composeFn (forall (t :: [*] -> * -> *) (dom :: [*]) rng.
AppRequires t dom rng =>
t dom rng -> Fun dom rng
Fun t dom x
fn) (forall x. HasCallStack => Term x -> Fun '[a] x
toFn Term a
t)
    toFn (V Var x
v') | Just a :~: x
Refl <- forall a a'.
(Typeable a, Typeable a') =>
Var a -> Var a' -> Maybe (a :~: a')
eqVar Var a
v Var x
v' = forall a. HasSpec a => Fun '[a] a
idFn
    toFn Term x
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"foldMap_ has not been given a function of the form \\ x -> f (g ... (h x))"

-- function symbol definitions for List
sum_ ::
  Foldy a =>
  Term [a] ->
  Term a
sum_ :: forall a. Foldy a => Term [a] -> Term a
sum_ = forall a b.
(Foldy b, HasSpec a) =>
(Term a -> Term b) -> Term [a] -> Term b
foldMap_ forall a. a -> a
id

singletonList_ :: (Sized [a], HasSpec a) => Term a -> Term [a]
singletonList_ :: forall a. (Sized [a], HasSpec a) => Term a -> Term [a]
singletonList_ = forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm forall t. HasSpec t => ListW '[t] [t]
SingletonListW

append_ :: (Sized [a], HasSpec a) => Term [a] -> Term [a] -> Term [a]
append_ :: forall a.
(Sized [a], HasSpec a) =>
Term [a] -> Term [a] -> Term [a]
append_ = forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm forall t. (HasSpec t, Typeable t, Show t) => ListW '[[t], [t]] [t]
AppendW

-- Fun types for lists and their helper functions

appendFn :: forall a. (Sized [a], HasSpec a) => Fun '[[a], [a]] [a]
appendFn :: forall a. (Sized [a], HasSpec a) => Fun '[[a], [a]] [a]
appendFn = forall (t :: [*] -> * -> *) (dom :: [*]) rng.
AppRequires t dom rng =>
t dom rng -> Fun dom rng
Fun forall t. (HasSpec t, Typeable t, Show t) => ListW '[[t], [t]] [t]
AppendW

singletonListFn :: forall a. HasSpec a => Fun '[a] [a]
singletonListFn :: forall a. HasSpec a => Fun '[a] [a]
singletonListFn = forall (t :: [*] -> * -> *) (dom :: [*]) rng.
AppRequires t dom rng =>
t dom rng -> Fun dom rng
Fun forall t. HasSpec t => ListW '[t] [t]
SingletonListW

foldMapFn :: forall a b. (HasSpec a, Foldy b) => Fun '[a] b -> Fun '[[a]] b
foldMapFn :: forall a b. (HasSpec a, Foldy b) => Fun '[a] b -> Fun '[[a]] b
foldMapFn Fun '[a] b
f = forall (t :: [*] -> * -> *) (dom :: [*]) rng.
AppRequires t dom rng =>
t dom rng -> Fun dom rng
Fun (forall t b. (Foldy b, HasSpec t) => Fun '[t] b -> ListW '[[t]] b
FoldMapW Fun '[a] b
f)

reverseFoldSpec :: FoldSpec a -> Specification a
reverseFoldSpec :: forall a. FoldSpec a -> Specification a
reverseFoldSpec FoldSpec a
NoFold = forall a. Specification a
TrueSpec
-- The single element list has to sum to something that obeys spec, i.e. `conformsToSpec (f a) spec`
reverseFoldSpec (FoldSpec (Fun t '[a] b
fn) Specification b
spec) = forall (t :: [*] -> * -> *) (as :: [*]) b a.
(Logic t, AppRequires t as b, HasSpec a) =>
t as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification a
propagate t '[a] b
fn (forall {k} (a :: k). HOLE a a
HOLE forall (c :: * -> *) a (f :: * -> *) (as1 :: [*]).
c a -> List f as1 -> ListCtx f (a : as1) c
:? forall {k} (f :: k -> *). List f '[]
Nil) Specification b
spec

-- ==============  Helper functions

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

alreadyHaveFold :: [a] -> FoldSpec a -> FoldSpec a
alreadyHaveFold :: forall a. [a] -> FoldSpec a -> FoldSpec a
alreadyHaveFold [a]
_ FoldSpec a
NoFold = forall a. FoldSpec a
NoFold
alreadyHaveFold [a]
ys (FoldSpec Fun '[a] b
fn Specification b
spec) =
  forall t a.
(HasSpec a, HasSpec t, Foldy t) =>
Fun '[a] t -> Specification t -> FoldSpec a
FoldSpec
    Fun '[a] b
fn
    (forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained forall a b. (a -> b) -> a -> b
$ \Term b
s -> forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm forall a. Foldy a => IntW '[a, a] a
theAddFn Term b
s (forall a b.
(Foldy b, HasSpec a) =>
(Term a -> Term b) -> Term [a] -> Term b
foldMap_ (forall x b. Fun '[x] b -> Term x -> Term b
appFun Fun '[a] b
fn) (forall a. (Typeable a, Eq a, Show a) => a -> Term a
Lit [a]
ys)) forall a. HasSpec a => Term a -> Specification a -> Pred
`satisfies` Specification b
spec)

-- | Used in the HasSpec [a] instance
toPredsFoldSpec :: HasSpec a => Term [a] -> FoldSpec a -> Pred
toPredsFoldSpec :: forall a. HasSpec a => Term [a] -> FoldSpec a -> Pred
toPredsFoldSpec Term [a]
_ FoldSpec a
NoFold = Pred
TruePred
toPredsFoldSpec Term [a]
x (FoldSpec Fun '[a] b
funAB Specification b
sspec) =
  forall a. HasSpec a => Term a -> Specification a -> Pred
satisfies (forall x b. Fun '[x] b -> Term x -> Term b
appFun (forall a b. (HasSpec a, Foldy b) => Fun '[a] b -> Fun '[[a]] b
foldMapFn Fun '[a] b
funAB) Term [a]
x) Specification b
sspec

-- =======================================================
-- FoldSpec is a Spec that appears inside of ListSpec

data FoldSpec a where
  NoFold :: FoldSpec a
  FoldSpec ::
    forall b a.
    ( HasSpec a
    , HasSpec b
    , Foldy b
    ) =>
    Fun '[a] b ->
    Specification b ->
    FoldSpec a

preMapFoldSpec :: HasSpec a => Fun '[a] b -> FoldSpec b -> FoldSpec a
preMapFoldSpec :: forall a b. HasSpec a => Fun '[a] b -> FoldSpec b -> FoldSpec a
preMapFoldSpec Fun '[a] b
_ FoldSpec b
NoFold = forall a. FoldSpec a
NoFold
preMapFoldSpec Fun '[a] b
f (FoldSpec Fun '[b] b
g Specification b
s) = forall t a.
(HasSpec a, HasSpec t, Foldy t) =>
Fun '[a] t -> Specification t -> FoldSpec a
FoldSpec (forall b c a.
(HasSpec b, HasSpec c) =>
Fun '[b] c -> Fun '[a] b -> Fun '[a] c
composeFn Fun '[b] b
g Fun '[a] b
f) Specification b
s

composeFn :: (HasSpec b, HasSpec c) => Fun '[b] c -> Fun '[a] b -> Fun '[a] c
composeFn :: forall b c a.
(HasSpec b, HasSpec c) =>
Fun '[b] c -> Fun '[a] b -> Fun '[a] c
composeFn (Fun t '[b] c
f) (Fun t '[a] b
g) = (forall (t :: [*] -> * -> *) (dom :: [*]) rng.
AppRequires t dom rng =>
t dom rng -> Fun dom rng
Fun (forall t (a :: [*] -> * -> *) (b :: [*] -> * -> *) a r.
(AppRequires a '[t] r, AppRequires b '[a] t, HasSpec t) =>
a '[t] r -> b '[a] t -> FunW '[a] r
ComposeW t '[b] c
f t '[a] b
g))

idFn :: HasSpec a => Fun '[a] a
idFn :: forall a. HasSpec a => Fun '[a] a
idFn = forall (t :: [*] -> * -> *) (dom :: [*]) rng.
AppRequires t dom rng =>
t dom rng -> Fun dom rng
Fun forall a. FunW '[a] a
IdW

combineFoldSpec :: FoldSpec a -> FoldSpec a -> Either [String] (FoldSpec a)
combineFoldSpec :: forall a. FoldSpec a -> FoldSpec a -> Either [[Char]] (FoldSpec a)
combineFoldSpec FoldSpec a
NoFold FoldSpec a
s = forall (f :: * -> *) a. Applicative f => a -> f a
pure FoldSpec a
s
combineFoldSpec FoldSpec a
s FoldSpec a
NoFold = forall (f :: * -> *) a. Applicative f => a -> f a
pure FoldSpec a
s
combineFoldSpec (FoldSpec (Fun t '[a] b
f) Specification b
s) (FoldSpec (Fun t '[a] b
g) Specification b
s') =
  case forall (t1 :: [*] -> * -> *) (d1 :: [*]) r1 (t2 :: [*] -> * -> *)
       (d2 :: [*]) r2.
(AppRequires t1 d1 r1, AppRequires t2 d2 r2) =>
t1 d1 r1
-> t2 d2 r2 -> Maybe (t1 d1 r1, t1 :~: t2, d1 :~: d2, r1 :~: r2)
sameFunSym t '[a] b
f t '[a] b
g of
    Just (t '[a] b
_h, t :~: t
Refl, '[a] :~: '[a]
Refl, b :~: b
Refl) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall t a.
(HasSpec a, HasSpec t, Foldy t) =>
Fun '[a] t -> Specification t -> FoldSpec a
FoldSpec (forall (t :: [*] -> * -> *) (dom :: [*]) rng.
AppRequires t dom rng =>
t dom rng -> Fun dom rng
Fun t '[a] b
f) (Specification b
s forall a. Semigroup a => a -> a -> a
<> Specification b
s')
    Maybe (t '[a] b, t :~: t, '[a] :~: '[a], b :~: b)
Nothing -> forall a b. a -> Either a b
Left [[Char]
"Can't combine fold specs on different functions", [Char]
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show t '[a] b
f, [Char]
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show t '[a] b
g]

conformsToFoldSpec :: forall a. [a] -> FoldSpec a -> Bool
conformsToFoldSpec :: forall a. [a] -> FoldSpec a -> Bool
conformsToFoldSpec [a]
_ FoldSpec a
NoFold = Bool
True
conformsToFoldSpec [a]
xs (FoldSpec (Fun t '[a] b
f) Specification b
s) = forall a. Foldy a => [a] -> a
adds (forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: [*] -> * -> *) (d :: [*]) r.
Semantics t =>
t d r -> FunTy d r
semantics t '[a] b
f) [a]
xs) forall a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification b
s

class (HasSpec a, NumLike a, Logic IntW) => Foldy a where
  genList ::
    MonadGenError m => Specification a -> Specification a -> GenT m [a]
  theAddFn :: IntW '[a, a] a
  theAddFn = forall b. NumLike b => IntW '[b, b] b
AddW
  theZero :: a
  theZero = a
0
  genSizedList ::
    MonadGenError m =>
    Specification Integer ->
    Specification a ->
    Specification a ->
    GenT m [a]
  noNegativeValues :: Bool

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

type SizeSpec = NumSpec Integer

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

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

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

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

adds :: Foldy a => [a] -> a
adds :: forall a. Foldy a => [a] -> a
adds = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall (t :: [*] -> * -> *) (d :: [*]) r.
Semantics t =>
t d r -> FunTy d r
semantics forall a. Foldy a => IntW '[a, a] a
theAddFn) forall a. Foldy a => a
theZero

-- =============================================================
-- All Foldy class instances are over Numbers (so far).
-- Foldy class requires higher order functions, so here they are.
-- Note this is a new witness type, different from BaseW
-- but serving the same purpose. Note it can take Witnesses from
-- other classes as inputs. See FlipW amd ComposeW
-- ==============================================================

-- We need Arbitrary Specification to do this
instance {-# OVERLAPPABLE #-} (Arbitrary (Specification a {- Arbitrary (TypeSpec a), -}), Foldy a) => Arbitrary (FoldSpec a) where
  arbitrary :: Gen (FoldSpec a)
arbitrary = forall a. HasCallStack => [Gen a] -> Gen a
oneof [forall t a.
(HasSpec a, HasSpec t, Foldy t) =>
Fun '[a] t -> Specification t -> FoldSpec a
FoldSpec (forall (t :: [*] -> * -> *) (dom :: [*]) rng.
AppRequires t dom rng =>
t dom rng -> Fun dom rng
Fun forall a. FunW '[a] a
IdW) 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 a. FoldSpec a
NoFold]
  shrink :: FoldSpec a -> [FoldSpec a]
shrink FoldSpec a
NoFold = []
  shrink (FoldSpec (Fun t '[a] b
wit) Specification b
spec)
    | Just (FunW '[a] a
idW, FunW :~: t
Refl, '[a] :~: '[a]
Refl, a :~: b
Refl) <- forall (t1 :: [*] -> * -> *) (d1 :: [*]) r1 (t2 :: [*] -> * -> *)
       (d2 :: [*]) r2.
(AppRequires t1 d1 r1, AppRequires t2 d2 r2) =>
t1 d1 r1
-> t2 d2 r2 -> Maybe (t1 d1 r1, t1 :~: t2, d1 :~: d2, r1 :~: r2)
sameFunSym (forall a. FunW '[a] a
IdW @a) t '[a] b
wit = forall t a.
(HasSpec a, HasSpec t, Foldy t) =>
Fun '[a] t -> Specification t -> FoldSpec a
FoldSpec (forall (t :: [*] -> * -> *) (dom :: [*]) rng.
AppRequires t dom rng =>
t dom rng -> Fun dom rng
Fun FunW '[a] a
idW) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => a -> [a]
shrink Specification b
spec
  shrink FoldSpec {} = [forall a. FoldSpec a
NoFold]

data FunW (dom :: [Type]) (rng :: Type) where
  IdW :: forall a. FunW '[a] a
  ComposeW ::
    forall b t1 t2 a r.
    ( AppRequires t1 '[b] r
    , AppRequires t2 '[a] b
    , HasSpec b
    ) =>
    t1 '[b] r ->
    t2 '[a] b ->
    FunW '[a] r
  FlipW ::
    forall t a b r.
    AppRequires t '[a, b] r =>
    t '[a, b] r ->
    FunW '[b, a] r

funSem :: FunW dom rng -> FunTy dom rng
funSem :: forall (dom :: [*]) rng. FunW dom rng -> FunTy dom rng
funSem FunW dom rng
IdW = forall a. a -> a
id
funSem (ComposeW t1 '[b] rng
f t2 '[a] b
g) = (\a
a -> forall (t :: [*] -> * -> *) (d :: [*]) r.
Semantics t =>
t d r -> FunTy d r
semantics t1 '[b] rng
f (forall (t :: [*] -> * -> *) (d :: [*]) r.
Semantics t =>
t d r -> FunTy d r
semantics t2 '[a] b
g a
a))
funSem (FlipW (t '[a, b] rng
f :: g d r)) = forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (t :: [*] -> * -> *) (d :: [*]) r.
Semantics t =>
t d r -> FunTy d r
semantics t '[a, b] rng
f)

instance Semantics FunW where
  semantics :: forall (dom :: [*]) rng. FunW dom rng -> FunTy dom rng
semantics = forall (dom :: [*]) rng. FunW dom rng -> FunTy dom rng
funSem

instance Syntax FunW

instance Show (FunW dom rng) where
  show :: FunW dom rng -> [Char]
show FunW dom rng
IdW = [Char]
"id_"
  show (FlipW t '[a, b] rng
f) = [Char]
"(flip_ " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show t '[a, b] rng
f forall a. [a] -> [a] -> [a]
++ [Char]
")"
  show (ComposeW t1 '[b] rng
x t2 '[a] b
y) = [Char]
"(compose_ " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show t1 '[b] rng
x forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show t2 '[a] b
y forall a. [a] -> [a] -> [a]
++ [Char]
")"

instance Eq (FunW dom rng) where
  FunW dom rng
IdW == :: FunW dom rng -> FunW dom rng -> Bool
== FunW dom rng
IdW = Bool
True
  FlipW t '[a, b] rng
t1 == FlipW t '[a, b] rng
t2 = forall (t1 :: [*] -> * -> *) (bs1 :: [*]) r1 (t2 :: [*] -> * -> *)
       (bs2 :: [*]) r2.
(AppRequires t1 bs1 r1, AppRequires t2 bs2 r2) =>
t1 bs1 r1 -> t2 bs2 r2 -> Bool
compareWit t '[a, b] rng
t1 t '[a, b] rng
t2
  ComposeW t1 '[b] rng
f t2 '[a] b
f' == ComposeW t1 '[b] rng
g t2 '[a] b
g' = forall (t1 :: [*] -> * -> *) (bs1 :: [*]) r1 (t2 :: [*] -> * -> *)
       (bs2 :: [*]) r2.
(AppRequires t1 bs1 r1, AppRequires t2 bs2 r2) =>
t1 bs1 r1 -> t2 bs2 r2 -> Bool
compareWit t1 '[b] rng
f t1 '[b] rng
g Bool -> Bool -> Bool
&& forall (t1 :: [*] -> * -> *) (bs1 :: [*]) r1 (t2 :: [*] -> * -> *)
       (bs2 :: [*]) r2.
(AppRequires t1 bs1 r1, AppRequires t2 bs2 r2) =>
t1 bs1 r1 -> t2 bs2 r2 -> Bool
compareWit t2 '[a] b
f' t2 '[a] b
g'
  FunW dom rng
_ == FunW dom rng
_ = Bool
False

compareWit ::
  forall t1 bs1 r1 t2 bs2 r2.
  (AppRequires t1 bs1 r1, AppRequires t2 bs2 r2) =>
  t1 bs1 r1 ->
  t2 bs2 r2 ->
  Bool
compareWit :: forall (t1 :: [*] -> * -> *) (bs1 :: [*]) r1 (t2 :: [*] -> * -> *)
       (bs2 :: [*]) r2.
(AppRequires t1 bs1 r1, AppRequires t2 bs2 r2) =>
t1 bs1 r1 -> t2 bs2 r2 -> Bool
compareWit t1 bs1 r1
x t2 bs2 r2
y = case (forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @t1 @t2, forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @bs1 @bs2, forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @r1 @r2) of
  (Just t1 :~: t2
Refl, Just bs1 :~: bs2
Refl, Just r1 :~: r2
Refl) -> t1 bs1 r1
x forall a. Eq a => a -> a -> Bool
== t2 bs2 r2
y
  (Maybe (t1 :~: t2), Maybe (bs1 :~: bs2), Maybe (r1 :~: r2))
_ -> Bool
False

-- ===================================
-- Logic instances for IdW, FlipW and ComposeW
-- Also their Haskell implementations id_ flip_ composeFn

instance Logic FunW where
  propagate :: forall (as :: [*]) b a.
(AppRequires FunW as b, HasSpec a) =>
FunW as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification a
propagate FunW as b
IdW (Unary HOLE a b
HOLE) = forall a. a -> a
id
  propagate (FlipW t '[a, b] b
f) ListCtx Value as (HOLE a)
ctx = forall (t :: [*] -> * -> *) (as :: [*]) b a.
(Logic t, AppRequires t as b, HasSpec a) =>
t as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification a
propagate t '[a, b] b
f (forall a b c.
(Typeable a, Show a, Typeable b, Show b) =>
ListCtx Value '[a, b] (HOLE c) -> ListCtx Value '[b, a] (HOLE c)
flipCtx ListCtx Value as (HOLE a)
ctx)
  propagate (ComposeW t1 '[b] b
f t2 '[a] b
g) (Unary HOLE a a
HOLE) = forall (t :: [*] -> * -> *) (as :: [*]) b a.
(Logic t, AppRequires t as b, HasSpec a) =>
t as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification a
propagate t2 '[a] b
g (forall a' a (f :: * -> *). HOLE a' a -> ListCtx f '[a] (HOLE a')
Unary forall {k} (a :: k). HOLE a a
HOLE) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: [*] -> * -> *) (as :: [*]) b a.
(Logic t, AppRequires t as b, HasSpec a) =>
t as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification a
propagate t1 '[b] b
f (forall a' a (f :: * -> *). HOLE a' a -> ListCtx f '[a] (HOLE a')
Unary forall {k} (a :: k). HOLE a a
HOLE)

  mapTypeSpec :: forall a b.
(HasSpec a, HasSpec b) =>
FunW '[a] b -> TypeSpec a -> Specification b
mapTypeSpec FunW '[a] b
IdW TypeSpec a
ts = forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec TypeSpec a
ts
  mapTypeSpec (ComposeW t1 '[b] b
g t2 '[a] b
h) TypeSpec a
ts = forall (t :: [*] -> * -> *) a b.
AppRequires t '[a] b =>
t '[a] b -> Specification a -> Specification b
mapSpec t1 '[b] b
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: [*] -> * -> *) a b.
AppRequires t '[a] b =>
t '[a] b -> Specification a -> Specification b
mapSpec t2 '[a] b
h forall a b. (a -> b) -> a -> b
$ forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec TypeSpec a
ts

  -- Note we need the Evidence to apply App to f, and to apply App to g
  rewriteRules :: forall (dom :: [*]) rng.
(TypeList dom, Typeable dom, HasSpec rng, All HasSpec dom) =>
FunW dom rng
-> List Term dom
-> Evidence (AppRequires FunW dom rng)
-> Maybe (Term rng)
rewriteRules (ComposeW t1 '[b] rng
f t2 '[a] b
g) (Term a
x :> List Term as1
Nil) Evidence (AppRequires FunW dom rng)
Evidence = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (t :: [*] -> * -> *) (dom :: [*]) a.
AppRequires t dom a =>
t dom a -> List Term dom -> Term a
App t1 '[b] rng
f (forall (t :: [*] -> * -> *) (dom :: [*]) a.
AppRequires t dom a =>
t dom a -> List Term dom -> Term a
App t2 '[a] b
g (Term 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) forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> forall {k} (f :: k -> *). List f '[]
Nil)
  rewriteRules FunW dom rng
IdW (Term a
x :> List Term as1
Nil) Evidence (AppRequires FunW dom rng)
Evidence = forall a. a -> Maybe a
Just Term a
x
  rewriteRules (FlipW t '[a, b] rng
f) (a :: Term a
a@Lit {} :> Term a
b :> List Term as1
Nil) Evidence (AppRequires FunW dom rng)
Evidence = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (t :: [*] -> * -> *) (dom :: [*]) a.
AppRequires t dom a =>
t dom a -> List Term dom -> Term a
App t '[a, b] rng
f (Term a
b forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> Term a
a forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> forall {k} (f :: k -> *). List f '[]
Nil)
  rewriteRules (FlipW t '[a, b] rng
f) (Term a
a :> b :: Term a
b@Lit {} :> List Term as1
Nil) Evidence (AppRequires FunW dom rng)
Evidence = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (t :: [*] -> * -> *) (dom :: [*]) a.
AppRequires t dom a =>
t dom a -> List Term dom -> Term a
App t '[a, b] rng
f (Term a
b forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> Term a
a forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> forall {k} (f :: k -> *). List f '[]
Nil)
  rewriteRules (FlipW {}) List Term dom
_ Evidence (AppRequires FunW dom rng)
Evidence = forall a. Maybe a
Nothing

id_ :: forall a. HasSpec a => Term a -> Term a
id_ :: forall a. HasSpec a => Term a -> Term a
id_ = forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm forall a. FunW '[a] a
IdW

--   -- Note we need Evidence to apply App to f

flip_ ::
  forall (t :: [Type] -> Type -> Type) a b r.
  (HasSpec b, HasSpec a, AppRequires t '[a, b] r) =>
  t '[a, b] r ->
  Term b ->
  Term a ->
  Term r
flip_ :: forall (t :: [*] -> * -> *) a b r.
(HasSpec b, HasSpec a, AppRequires t '[a, b] r) =>
t '[a, b] r -> Term b -> Term a -> Term r
flip_ t '[a, b] r
x = forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm (forall (t :: [*] -> * -> *) a b r.
AppRequires t '[a, b] r =>
t '[a, b] r -> FunW '[b, a] r
FlipW t '[a, b] r
x)

compose_ ::
  forall b t1 t2 a r.
  ( AppRequires t1 '[b] r
  , AppRequires t2 '[a] b
  ) =>
  t1 '[b] r ->
  t2 '[a] b ->
  Term a ->
  Term r
compose_ :: forall b (t1 :: [*] -> * -> *) (t2 :: [*] -> * -> *) a r.
(AppRequires t1 '[b] r, AppRequires t2 '[a] b) =>
t1 '[b] r -> t2 '[a] b -> Term a -> Term r
compose_ t1 '[b] r
f t2 '[a] b
g = forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm forall a b. (a -> b) -> a -> b
$ forall t (a :: [*] -> * -> *) (b :: [*] -> * -> *) a r.
(AppRequires a '[t] r, AppRequires b '[a] t, HasSpec t) =>
a '[t] r -> b '[a] t -> FunW '[a] r
ComposeW t1 '[b] r
f t2 '[a] b
g -- @b @c1 @c2 @s1 @s2 @t1 @t2 @a @r f g

-- =======================================================
-- The Foldy class instances for Numbers
-- =======================================================

instance Foldy Integer where
  noNegativeValues :: Bool
noNegativeValues = Bool
False
  genList :: forall (m :: * -> *).
MonadGenError m =>
Specification Integer -> Specification Integer -> GenT m [Integer]
genList = forall a (m :: * -> *).
(MonadGenError m, Arbitrary a, Integral a, MaybeBounded a,
 TypeSpec a ~ NumSpec a, Random a, Complete a) =>
Specification a -> Specification a -> GenT m [a]
genNumList
  genSizedList :: forall (m :: * -> *).
MonadGenError m =>
Specification Integer
-> Specification Integer
-> Specification Integer
-> GenT m [Integer]
genSizedList = forall a (m :: * -> *).
(Complete a, TypeSpec a ~ NumSpec a, MonadGenError m, Random a,
 Integral a, Arbitrary a, MaybeBounded a, Complete Integer,
 TypeSpec Integer ~ NumSpec Integer) =>
Specification Integer
-> Specification a -> Specification a -> GenT m [a]
genListWithSize

instance Foldy Int where
  noNegativeValues :: Bool
noNegativeValues = Bool
False
  genList :: forall (m :: * -> *).
MonadGenError m =>
Specification Int -> Specification Int -> GenT m [Int]
genList = forall a (m :: * -> *).
(MonadGenError m, Arbitrary a, Integral a, MaybeBounded a,
 TypeSpec a ~ NumSpec a, Random a, Complete a) =>
Specification a -> Specification a -> GenT m [a]
genNumList
  genSizedList :: forall (m :: * -> *).
MonadGenError m =>
Specification Integer
-> Specification Int -> Specification Int -> GenT m [Int]
genSizedList = forall a (m :: * -> *).
(Complete a, TypeSpec a ~ NumSpec a, MonadGenError m, Random a,
 Integral a, Arbitrary a, MaybeBounded a, Complete Integer,
 TypeSpec Integer ~ NumSpec Integer) =>
Specification Integer
-> Specification a -> Specification a -> GenT m [a]
genListWithSize

instance Foldy Int8 where
  noNegativeValues :: Bool
noNegativeValues = Bool
False
  genList :: forall (m :: * -> *).
MonadGenError m =>
Specification Int8 -> Specification Int8 -> GenT m [Int8]
genList = forall a (m :: * -> *).
(MonadGenError m, Arbitrary a, Integral a, MaybeBounded a,
 TypeSpec a ~ NumSpec a, Random a, Complete a) =>
Specification a -> Specification a -> GenT m [a]
genNumList
  genSizedList :: forall (m :: * -> *).
MonadGenError m =>
Specification Integer
-> Specification Int8 -> Specification Int8 -> GenT m [Int8]
genSizedList = forall a (m :: * -> *).
(Complete a, TypeSpec a ~ NumSpec a, MonadGenError m, Random a,
 Integral a, Arbitrary a, MaybeBounded a, Complete Integer,
 TypeSpec Integer ~ NumSpec Integer) =>
Specification Integer
-> Specification a -> Specification a -> GenT m [a]
genListWithSize

instance Foldy Int16 where
  noNegativeValues :: Bool
noNegativeValues = Bool
False
  genList :: forall (m :: * -> *).
MonadGenError m =>
Specification Int16 -> Specification Int16 -> GenT m [Int16]
genList = forall a (m :: * -> *).
(MonadGenError m, Arbitrary a, Integral a, MaybeBounded a,
 TypeSpec a ~ NumSpec a, Random a, Complete a) =>
Specification a -> Specification a -> GenT m [a]
genNumList
  genSizedList :: forall (m :: * -> *).
MonadGenError m =>
Specification Integer
-> Specification Int16 -> Specification Int16 -> GenT m [Int16]
genSizedList = forall a (m :: * -> *).
(Complete a, TypeSpec a ~ NumSpec a, MonadGenError m, Random a,
 Integral a, Arbitrary a, MaybeBounded a, Complete Integer,
 TypeSpec Integer ~ NumSpec Integer) =>
Specification Integer
-> Specification a -> Specification a -> GenT m [a]
genListWithSize

instance Foldy Int32 where
  noNegativeValues :: Bool
noNegativeValues = Bool
False
  genList :: forall (m :: * -> *).
MonadGenError m =>
Specification Int32 -> Specification Int32 -> GenT m [Int32]
genList = forall a (m :: * -> *).
(MonadGenError m, Arbitrary a, Integral a, MaybeBounded a,
 TypeSpec a ~ NumSpec a, Random a, Complete a) =>
Specification a -> Specification a -> GenT m [a]
genNumList
  genSizedList :: forall (m :: * -> *).
MonadGenError m =>
Specification Integer
-> Specification Int32 -> Specification Int32 -> GenT m [Int32]
genSizedList = forall a (m :: * -> *).
(Complete a, TypeSpec a ~ NumSpec a, MonadGenError m, Random a,
 Integral a, Arbitrary a, MaybeBounded a, Complete Integer,
 TypeSpec Integer ~ NumSpec Integer) =>
Specification Integer
-> Specification a -> Specification a -> GenT m [a]
genListWithSize

instance Foldy Int64 where
  noNegativeValues :: Bool
noNegativeValues = Bool
False
  genList :: forall (m :: * -> *).
MonadGenError m =>
Specification Int64 -> Specification Int64 -> GenT m [Int64]
genList = forall a (m :: * -> *).
(MonadGenError m, Arbitrary a, Integral a, MaybeBounded a,
 TypeSpec a ~ NumSpec a, Random a, Complete a) =>
Specification a -> Specification a -> GenT m [a]
genNumList
  genSizedList :: forall (m :: * -> *).
MonadGenError m =>
Specification Integer
-> Specification Int64 -> Specification Int64 -> GenT m [Int64]
genSizedList = forall a (m :: * -> *).
(Complete a, TypeSpec a ~ NumSpec a, MonadGenError m, Random a,
 Integral a, Arbitrary a, MaybeBounded a, Complete Integer,
 TypeSpec Integer ~ NumSpec Integer) =>
Specification Integer
-> Specification a -> Specification a -> GenT m [a]
genListWithSize

instance Foldy Natural where
  noNegativeValues :: Bool
noNegativeValues = Bool
True
  genList :: forall (m :: * -> *).
MonadGenError m =>
Specification Natural -> Specification Natural -> GenT m [Natural]
genList = forall a (m :: * -> *).
(MonadGenError m, Arbitrary a, Integral a, MaybeBounded a,
 TypeSpec a ~ NumSpec a, Random a, Complete a) =>
Specification a -> Specification a -> GenT m [a]
genNumList
  genSizedList :: forall (m :: * -> *).
MonadGenError m =>
Specification Integer
-> Specification Natural
-> Specification Natural
-> GenT m [Natural]
genSizedList = forall a (m :: * -> *).
(Complete a, TypeSpec a ~ NumSpec a, MonadGenError m, Random a,
 Integral a, Arbitrary a, MaybeBounded a, Complete Integer,
 TypeSpec Integer ~ NumSpec Integer) =>
Specification Integer
-> Specification a -> Specification a -> GenT m [a]
genListWithSize

instance Foldy Word8 where
  noNegativeValues :: Bool
noNegativeValues = Bool
True
  genList :: forall (m :: * -> *).
MonadGenError m =>
Specification Word8 -> Specification Word8 -> GenT m [Word8]
genList = forall a (m :: * -> *).
(MonadGenError m, Arbitrary a, Integral a, MaybeBounded a,
 TypeSpec a ~ NumSpec a, Random a, Complete a) =>
Specification a -> Specification a -> GenT m [a]
genNumList
  genSizedList :: forall (m :: * -> *).
MonadGenError m =>
Specification Integer
-> Specification Word8 -> Specification Word8 -> GenT m [Word8]
genSizedList = forall a (m :: * -> *).
(Complete a, TypeSpec a ~ NumSpec a, MonadGenError m, Random a,
 Integral a, Arbitrary a, MaybeBounded a, Complete Integer,
 TypeSpec Integer ~ NumSpec Integer) =>
Specification Integer
-> Specification a -> Specification a -> GenT m [a]
genListWithSize

instance Foldy Word16 where
  noNegativeValues :: Bool
noNegativeValues = Bool
True
  genList :: forall (m :: * -> *).
MonadGenError m =>
Specification Word16 -> Specification Word16 -> GenT m [Word16]
genList = forall a (m :: * -> *).
(MonadGenError m, Arbitrary a, Integral a, MaybeBounded a,
 TypeSpec a ~ NumSpec a, Random a, Complete a) =>
Specification a -> Specification a -> GenT m [a]
genNumList
  genSizedList :: forall (m :: * -> *).
MonadGenError m =>
Specification Integer
-> Specification Word16 -> Specification Word16 -> GenT m [Word16]
genSizedList = forall a (m :: * -> *).
(Complete a, TypeSpec a ~ NumSpec a, MonadGenError m, Random a,
 Integral a, Arbitrary a, MaybeBounded a, Complete Integer,
 TypeSpec Integer ~ NumSpec Integer) =>
Specification Integer
-> Specification a -> Specification a -> GenT m [a]
genListWithSize

instance Foldy Word32 where
  noNegativeValues :: Bool
noNegativeValues = Bool
True
  genList :: forall (m :: * -> *).
MonadGenError m =>
Specification Word32 -> Specification Word32 -> GenT m [Word32]
genList = forall a (m :: * -> *).
(MonadGenError m, Arbitrary a, Integral a, MaybeBounded a,
 TypeSpec a ~ NumSpec a, Random a, Complete a) =>
Specification a -> Specification a -> GenT m [a]
genNumList
  genSizedList :: forall (m :: * -> *).
MonadGenError m =>
Specification Integer
-> Specification Word32 -> Specification Word32 -> GenT m [Word32]
genSizedList = forall a (m :: * -> *).
(Complete a, TypeSpec a ~ NumSpec a, MonadGenError m, Random a,
 Integral a, Arbitrary a, MaybeBounded a, Complete Integer,
 TypeSpec Integer ~ NumSpec Integer) =>
Specification Integer
-> Specification a -> Specification a -> GenT m [a]
genListWithSize

instance Foldy Word64 where
  noNegativeValues :: Bool
noNegativeValues = Bool
True
  genList :: forall (m :: * -> *).
MonadGenError m =>
Specification Word64 -> Specification Word64 -> GenT m [Word64]
genList = forall a (m :: * -> *).
(MonadGenError m, Arbitrary a, Integral a, MaybeBounded a,
 TypeSpec a ~ NumSpec a, Random a, Complete a) =>
Specification a -> Specification a -> GenT m [a]
genNumList
  genSizedList :: forall (m :: * -> *).
MonadGenError m =>
Specification Integer
-> Specification Word64 -> Specification Word64 -> GenT m [Word64]
genSizedList = forall a (m :: * -> *).
(Complete a, TypeSpec a ~ NumSpec a, MonadGenError m, Random a,
 Integral a, Arbitrary a, MaybeBounded a, Complete Integer,
 TypeSpec Integer ~ NumSpec Integer) =>
Specification Integer
-> Specification a -> Specification a -> GenT m [a]
genListWithSize

genInverse ::
  ( MonadGenError m
  , HasSpec a
  , HasSpec b
  ) =>
  Fun '[a] b ->
  Specification a ->
  b ->
  GenT m a
genInverse :: forall (m :: * -> *) a b.
(MonadGenError m, HasSpec a, HasSpec b) =>
Fun '[a] b -> Specification a -> b -> GenT m a
genInverse (Fun t '[a] b
f) Specification a
argS b
x =
  let argSpec' :: Specification a
argSpec' = Specification a
argS forall a. Semigroup a => a -> a -> a
<> forall (t :: [*] -> * -> *) (as :: [*]) b a.
(Logic t, AppRequires t as b, HasSpec a) =>
t as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification a
propagate t '[a] b
f (forall {k} (a :: k). HOLE a a
HOLE forall (c :: * -> *) a (f :: * -> *) (as1 :: [*]).
c a -> List f as1 -> ListCtx f (a : as1) c
:? forall {k} (f :: k -> *). List f '[]
Nil) (forall a. a -> Specification a
equalSpec b
x)
   in forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a -> m a
explainNE
        ( forall a. [a] -> NonEmpty a
NE.fromList
            [ [Char]
"genInverse"
            , [Char]
"  f = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show t '[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 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 a
argSpec'
            ]
        )
        forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *).
(HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecT Specification a
argSpec'

genFromFold ::
  forall m a b.
  ( MonadGenError m
  , Foldy b
  , HasSpec a
  ) =>
  [a] ->
  Specification Integer ->
  Specification a ->
  Fun '[a] b ->
  Specification b ->
  GenT m [a]
genFromFold :: forall (m :: * -> *) a b.
(MonadGenError m, Foldy b, HasSpec a) =>
[a]
-> Specification Integer
-> Specification a
-> Fun '[a] b
-> Specification b
-> GenT m [a]
genFromFold [a]
must (forall a. HasSpec a => Specification a -> Specification a
simplifySpec -> Specification Integer
size) Specification a
elemS fun :: Fun '[a] b
fun@(Fun t '[a] b
fn) Specification b
foldS
  | forall a. Specification a -> Bool
isErrorLike Specification Integer
size =
      forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
fatalErrorNE (forall a. a -> NonEmpty a -> NonEmpty a
NE.cons [Char]
"genFromFold has ErrorLike sizeSpec" (forall a. Specification a -> NonEmpty [Char]
errorLikeMessage Specification Integer
size))
  | forall a. Specification a -> Bool
isErrorLike Specification a
elemS =
      forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
fatalErrorNE (forall a. a -> NonEmpty a -> NonEmpty a
NE.cons [Char]
"genFromFold has ErrorLike elemSpec" (forall a. Specification a -> NonEmpty [Char]
errorLikeMessage Specification a
elemS))
  | forall a. Specification a -> Bool
isErrorLike Specification b
foldS =
      forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
fatalErrorNE (forall a. a -> NonEmpty a -> NonEmpty a
NE.cons [Char]
"genFromFold has ErrorLike totalSpec" (forall a. Specification a -> NonEmpty [Char]
errorLikeMessage Specification b
foldS))
  | Bool
otherwise = ( forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a -> m a
explainNE
                    ( 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 Integer
size
                        , [Char]
"  elemS = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification a
elemS
                        , [Char]
"  fun   = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Fun '[a] b
fun
                        , [Char]
"  foldS = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Specification b
foldS
                        ]
                    )
                )
      forall a b. (a -> b) -> a -> b
$ do
        let elemS' :: Specification b
            elemS' :: Specification b
elemS' = forall (t :: [*] -> * -> *) a b.
AppRequires t '[a] b =>
t '[a] b -> Specification a -> Specification b
mapSpec t '[a] b
fn Specification a
elemS
            mustVal :: b
mustVal = forall a. Foldy a => [a] -> a
adds (forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: [*] -> * -> *) (d :: [*]) r.
Semantics t =>
t d r -> FunTy d r
semantics t '[a] b
fn) [a]
must)
            foldS' :: Specification b
            foldS' :: Specification b
foldS' = forall (t :: [*] -> * -> *) (as :: [*]) b a.
(Logic t, AppRequires t as b, HasSpec a) =>
t as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification a
propagate forall a. Foldy a => IntW '[a, a] a
theAddFn (forall {k} (a :: k). 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 b
foldS
            sizeSpec' :: Specification Integer
            sizeSpec' :: Specification Integer
sizeSpec' = forall (t :: [*] -> * -> *) (as :: [*]) b a.
(Logic t, AppRequires t as b, HasSpec a) =>
t as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification a
propagate forall b. NumLike b => IntW '[b, b] b
AddW (forall {k} (a :: k). 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 Integer
size
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Specification a -> Bool
isErrorLike Specification Integer
sizeSpec') forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadGenError m => [Char] -> m a
genError [Char]
"Inconsistent size spec"
        [b]
results0 <- case Specification Integer
sizeSpec' of
          Specification Integer
TrueSpec -> forall a (m :: * -> *).
(Foldy a, MonadGenError m) =>
Specification a -> Specification a -> GenT m [a]
genList (forall a. HasSpec a => Specification a -> Specification a
simplifySpec Specification b
elemS') (forall a. HasSpec a => Specification a -> Specification a
simplifySpec Specification b
foldS')
          Specification Integer
_ -> forall a (m :: * -> *).
(Foldy a, MonadGenError m) =>
Specification Integer
-> Specification a -> Specification a -> GenT m [a]
genSizedList Specification Integer
sizeSpec' (forall a. HasSpec a => Specification a -> Specification a
simplifySpec Specification b
elemS') (forall a. HasSpec a => Specification a -> Specification a
simplifySpec Specification b
foldS')
        [a]
results <-
          forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a -> m a
explainNE
            ( forall a. [a] -> NonEmpty a
NE.fromList
                [ [Char]
"genInverse"
                , [Char]
"  fun = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Fun '[a] b
fun
                , [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 b
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 :: * -> *) a b.
(MonadGenError m, HasSpec a, HasSpec b) =>
Fun '[a] b -> Specification a -> b -> GenT m a
genInverse Fun '[a] b
fun Specification 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

addFun :: NumLike n => Fun '[n, n] n
addFun :: forall n. NumLike n => Fun '[n, n] n
addFun = forall (t :: [*] -> * -> *) (dom :: [*]) rng.
AppRequires t dom rng =>
t dom rng -> Fun dom rng
Fun forall b. NumLike b => IntW '[b, b] b
AddW

-- ================================================
-- Sized instance for Lists

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 :: HasSpec [a] => NumSpec Integer -> [Integer] -> Specification [a]
liftSizeSpec NumSpec Integer
spec [Integer]
cant = forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec (forall a.
Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
ListSpec forall a. Maybe a
Nothing forall a. Monoid a => a
mempty (forall a. HasSpec a => TypeSpec a -> [a] -> Specification a
TypeSpec NumSpec Integer
spec [Integer]
cant) forall a. Specification a
TrueSpec forall a. FoldSpec a
NoFold)
  liftMemberSpec :: HasSpec [a] => [Integer] -> Specification [a]
liftMemberSpec [Integer]
xs = case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Integer]
xs of
    Maybe (NonEmpty Integer)
Nothing -> forall a. NonEmpty [Char] -> Specification 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 a. HasSpec a => TypeSpec a -> Specification a
typeSpec (forall a.
Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
ListSpec forall a. Maybe a
Nothing forall a. Monoid a => a
mempty (forall a. NonEmpty a -> Specification a
MemberSpec NonEmpty Integer
zs) forall a. Specification a
TrueSpec forall a. FoldSpec a
NoFold)
  sizeOfTypeSpec :: HasSpec [a] => TypeSpec [a] -> Specification Integer
sizeOfTypeSpec (ListSpec Maybe Integer
_ [a]
_ Specification Integer
_ ErrorSpec {} FoldSpec a
_) = forall a. a -> Specification a
equalSpec Integer
0
  sizeOfTypeSpec (ListSpec Maybe Integer
_ [a]
must Specification Integer
sizespec Specification a
_ FoldSpec a
_) = Specification Integer
sizespec forall a. Semigroup a => a -> a -> a
<> forall a. OrdLike a => a -> Specification a
geqSpec (forall t. Sized t => t -> Integer
sizeOf [a]
must)

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

data SizeW (dom :: [Type]) rng :: Type where
  SizeOfW :: (Sized n, HasSpec n) => SizeW '[n] Integer

deriving instance Eq (SizeW ds r)

instance Show (SizeW d r) where
  show :: SizeW d r -> [Char]
show SizeW d r
SizeOfW = [Char]
"sizeOf_"

instance Semantics SizeW where
  semantics :: forall (d :: [*]) r. SizeW d r -> FunTy d r
semantics SizeW d r
SizeOfW = forall t. Sized t => t -> Integer
sizeOf -- From the Sized class.

instance Syntax SizeW

instance Logic SizeW where
  propagateTypeSpec :: forall (as :: [*]) b a.
(AppRequires SizeW as b, HasSpec a) =>
SizeW as b
-> ListCtx Value as (HOLE a)
-> TypeSpec b
-> [b]
-> Specification a
propagateTypeSpec SizeW as b
SizeOfW (Unary HOLE a n
HOLE) TypeSpec b
ts [b]
cant = forall t.
(Sized t, HasSpec t) =>
NumSpec Integer -> [Integer] -> Specification t
liftSizeSpec TypeSpec b
ts [b]
cant

  propagateMemberSpec :: forall (as :: [*]) b a.
(AppRequires SizeW as b, HasSpec a) =>
SizeW as b
-> ListCtx Value as (HOLE a) -> NonEmpty b -> Specification a
propagateMemberSpec SizeW as b
SizeOfW (Unary HOLE a n
HOLE) NonEmpty b
es = forall t. (Sized t, HasSpec t) => [Integer] -> Specification t
liftMemberSpec (forall a. NonEmpty a -> [a]
NE.toList NonEmpty b
es)

  mapTypeSpec :: forall a b.
(HasSpec a, HasSpec b) =>
SizeW '[a] b -> TypeSpec a -> Specification b
mapTypeSpec (SizeW '[a] b
SizeOfW :: SizeW '[a] b) TypeSpec a
ts =
    forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained forall a b. (a -> b) -> a -> b
$ \Term b
x ->
      forall a p. (HasSpec a, IsPred p) => (Term a -> p) -> Pred
unsafeExists forall a b. (a -> b) -> a -> b
$ \Term a
x' -> Term Bool -> Pred
Assert (Term b
x forall a. HasSpec a => Term a -> Term a -> Term Bool
==. forall a. (HasSpec a, Sized a) => Term a -> Term Integer
sizeOf_ Term a
x') forall a. Semigroup a => a -> a -> a
<> forall a. HasSpec a => Term a -> TypeSpec a -> Pred
toPreds @a Term a
x' TypeSpec a
ts

sizeOfFn :: forall a. (HasSpec a, Sized a) => Fun '[a] Integer
sizeOfFn :: forall a. (HasSpec a, Sized a) => Fun '[a] Integer
sizeOfFn = forall (t :: [*] -> * -> *) (dom :: [*]) rng.
AppRequires t dom rng =>
t dom rng -> Fun dom rng
Fun forall t. (Sized t, HasSpec t) => SizeW '[t] Integer
SizeOfW

-- ======================================

rangeSize :: Integer -> Integer -> SizeSpec
rangeSize :: Integer -> Integer -> NumSpec Integer
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 n. Maybe n -> Maybe n -> NumSpec n
NumSpecInterval (forall a. a -> Maybe a
Just Integer
a) (forall a. a -> Maybe a
Just Integer
b)

between :: (HasSpec a, TypeSpec a ~ NumSpec a) => a -> a -> Specification a
between :: forall a.
(HasSpec a, TypeSpec a ~ NumSpec a) =>
a -> a -> Specification a
between a
lo a
hi = forall a. HasSpec a => TypeSpec a -> [a] -> Specification a
TypeSpec (forall n. Maybe n -> Maybe n -> NumSpec n
NumSpecInterval (forall a. a -> Maybe a
Just a
lo) (forall a. a -> Maybe a
Just a
hi)) []

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

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

-- =================================================
infix 4 +.
(+.) :: NumLike a => Term a -> Term a -> Term a
+. :: forall a. NumLike a => Term a -> Term a -> Term a
(+.) = forall a. NumLike a => Term a -> Term a -> Term a
addFn

negate_ :: NumLike a => Term a -> Term a
negate_ :: forall a. NumLike a => Term a -> Term a
negate_ = forall a. NumLike a => Term a -> Term a
negateFn

infix 4 -.
(-.) :: Numeric n => Term n -> Term n -> Term n
-. :: forall n. Numeric n => Term n -> Term n -> Term n
(-.) Term n
x Term n
y = forall a. NumLike a => Term a -> Term a -> Term a
addFn Term n
x (forall a. NumLike a => Term a -> Term a
negateFn Term n
y)

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

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

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

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

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

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

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

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

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

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

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