{-# 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.AbstractSyntax
import Constrained.Base (
  AppRequires,
  BinaryShow (..),
  Binder,
  Forallable (..),
  Fun (..),
  GenericRequires,
  HOLE (..),
  HasGenHint (..),
  HasSpec (..),
  HintF (..),
  IsPred,
  Logic (..),
  Pred,
  Specification,
  Term,
  TypeSpec,
  addToErrorSpec,
  appFun,
  appTerm,
  bind,
  cardinalTypeSpec,
  combineSpec,
  conformsTo,
  constrained,
  emptySpec,
  equalSpec,
  errorLikeMessage,
  explainSpec,
  explainSpecOpt,
  flipCtx,
  fromGESpec,
  fromSimpleRepSpec,
  genFromTypeSpec,
  guardTypeSpec,
  isErrorLike,
  memberSpecList,
  notEqualSpec,
  notMemberSpec,
  propagateSpec,
  shrinkWithTypeSpec,
  toCtx,
  toPred,
  toPreds,
  typeSpec,
  pattern FromGeneric,
  pattern TypeSpec,
  pattern Unary,
  pattern (:<:),
  pattern (:>:),
 )
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.FunctionSymbol
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,
  topsort,
  transitiveClosure,
 )
import Constrained.List (
  -- All,
  FunTy,
  List (..),
  ListCtx (..),
  -- TypeList,
  curryList,
  foldMapList,
  lengthList,
  mapList,
  mapMList,
  uncurryList_,
 )
import Constrained.NumOrd (
  IntW (..),
  NumLike,
  NumSpec (..),
  Numeric,
  addSpecInt,
  cardinality,
  caseBoolSpec,
  geqSpec,
  leqSpec,
  (<=.),
 )
import Constrained.PrettyUtils
import Constrained.SumList
-- 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.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 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
--      |                   ^
--      |                    \
--      |                     \
--      |                      HasSpec Sum
--      |                           /   ^
--      |                          /    |
--      <.                        /     |
--      <=.                      /      |
--      |                       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 $mSumSpec :: forall {r} {a} {b}.
SumSpec a b
-> (Maybe (Int, Int) -> Specification a -> Specification b -> r)
-> ((# #) -> r)
-> r
$bSumSpec :: forall a b.
Maybe (Int, Int)
-> Specification a -> Specification b -> SumSpec a b
SumSpec a b c <- SumSpecRaw _ a b c
  where
    SumSpec Maybe (Int, Int)
a Specification a
b Specification b
c = Maybe [Char]
-> Maybe (Int, Int)
-> Specification a
-> Specification b
-> SumSpec a b
forall a b.
Maybe [Char]
-> Maybe (Int, Int)
-> Specification a
-> Specification b
-> SumSpec a b
SumSpecRaw Maybe [Char]
forall a. Maybe a
Nothing Maybe (Int, Int)
a Specification a
b Specification b
c

{-# COMPLETE SumSpec #-}

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)
  | Specification a -> Bool
forall a. Specification a -> Bool
isErrorLike Specification a
sa
  , Specification b -> Bool
forall a. Specification a -> Bool
isErrorLike Specification b
sb =
      NonEmpty [Char] -> SpecificationD Deps (Sum a b)
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec (NonEmpty [Char] -> SpecificationD Deps (Sum a b))
-> NonEmpty [Char] -> SpecificationD Deps (Sum a b)
forall a b. (a -> b) -> a -> b
$
        [[Char]] -> NonEmpty [Char]
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList ([[Char]] -> NonEmpty [Char]) -> [[Char]] -> NonEmpty [Char]
forall a b. (a -> b) -> a -> b
$
          [[Char]]
msgs [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"All branches in a caseOn" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Maybe [Char] -> [Char]
sumType Maybe [Char]
tString [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" simplify to False.", SumSpec a b -> [Char]
forall a. Show a => a -> [Char]
show SumSpec a b
s]
  | Bool
otherwise = TypeSpec (Sum a b) -> SpecificationD Deps (Sum a b)
forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec TypeSpec (Sum a b)
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) TypeSpec (Sum a b)
SumSpec a b
sumspec of
    (BinaryShow [Char]
_ [Doc a]
ps) -> Doc a -> [Char]
forall a. Show a => a -> [Char]
show (Doc a -> [Char]) -> Doc a -> [Char]
forall a b. (a -> b) -> a -> b
$ Doc a -> Doc a
forall ann. Doc ann -> Doc ann
parens ([Char] -> Doc a
forall a. IsString a => [Char] -> a
fromString ([Char]
"SumSpec" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Maybe [Char] -> [Char]
sumType Maybe [Char]
tstring) Doc a -> Doc a -> Doc a
forall ann. Doc ann -> Doc ann -> Doc ann
/> [Doc a] -> Doc a
forall ann. [Doc ann] -> Doc ann
vsep [Doc a]
ps)
    BinaryShow
NonBinary ->
      [Char]
"(SumSpec"
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Maybe [Char] -> [Char]
sumType Maybe [Char]
tstring
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Doc Any -> [Char]
forall a. Show a => a -> [Char]
show (Maybe (Int, Int) -> Doc Any
forall a. Maybe (Int, Int) -> Doc a
sumWeightL Maybe (Int, Int)
hint)
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" ("
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Specification a -> [Char]
forall a. Show a => a -> [Char]
show Specification a
l
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
") "
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Doc Any -> [Char]
forall a. Show a => a -> [Char]
show (Maybe (Int, Int) -> Doc Any
forall a. Maybe (Int, Int) -> Doc a
sumWeightR Maybe (Int, Int)
hint)
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" ("
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Specification b -> [Char]
forall a. Show a => a -> [Char]
show Specification b
r
        [Char] -> [Char] -> [Char]
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 [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
y then [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
x else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" | " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
y [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")")
combTypeName (Just [Char]
x) Maybe [Char]
Nothing = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
x
combTypeName Maybe [Char]
Nothing (Just [Char]
x) = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
x
combTypeName Maybe [Char]
Nothing Maybe [Char]
Nothing = Maybe [Char]
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' =
    Maybe [Char]
-> Maybe (Int, Int)
-> Specification a
-> Specification b
-> SumSpec a b
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') (((Int, Int) -> (Int, Int) -> (Int, Int))
-> Maybe (Int, Int) -> Maybe (Int, Int) -> Maybe (Int, Int)
forall a. (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a
unionWithMaybe (Int, Int) -> (Int, Int) -> (Int, Int)
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 Specification a -> Specification a -> Specification a
forall a. Semigroup a => a -> a -> a
<> Specification a
sa') (Specification b
sb Specification b -> Specification b -> Specification b
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 a -> a -> a
forall a. Num a => a -> a -> a
+ a
fA', b
fB b -> b -> b
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 = Maybe (Int, Int)
-> Specification a -> Specification b -> SumSpec a b
forall a b.
Maybe (Int, Int)
-> Specification a -> Specification b -> SumSpec a b
SumSpec Maybe (Int, Int)
forall a. Maybe a
Nothing Specification a
forall a. Monoid a => a
mempty Specification b
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 = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal @(CountCases a) Proxy (CountCases a)
forall {k} (t :: k). Proxy t
Proxy)

totalWeight :: List (Weighted f) as -> Maybe Int
totalWeight :: forall (f :: * -> *) (as :: [*]). List (Weighted f) as -> Maybe Int
totalWeight = (Sum Int -> Int) -> Maybe (Sum Int) -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Sum Int -> Int
forall a. Sum a -> a
getSum (Maybe (Sum Int) -> Maybe Int)
-> (List (Weighted f) as -> Maybe (Sum Int))
-> List (Weighted f) as
-> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Weighted f a -> Maybe (Sum Int))
-> List (Weighted f) as -> Maybe (Sum Int)
forall {k} b (f :: k -> *) (as :: [k]).
Monoid b =>
(forall (a :: k). f a -> b) -> List f as -> b
foldMapList ((Int -> Sum Int) -> Maybe Int -> Maybe (Sum Int)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Sum Int
forall a. a -> Sum a
Semigroup.Sum (Maybe Int -> Maybe (Sum Int))
-> (Weighted f a -> Maybe Int) -> Weighted f a -> Maybe (Sum Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Weighted f a -> Maybe Int
forall (f :: * -> *) a. 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 = TypeSpec (Sum a b)
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' = [[Char]] -> SumSpec a b -> Specification (Sum a b)
forall a b.
(HasSpec a, HasSpec b, KnownNat (CountCases b)) =>
[[Char]] -> SumSpec a b -> Specification (Sum a b)
guardSumSpec [[Char]
"When combining SumSpecs", [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ TypeSpec (Sum a b) -> [Char]
forall a. Show a => a -> [Char]
show TypeSpec (Sum a b)
s, [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ TypeSpec (Sum a b) -> [Char]
forall a. Show a => a -> [Char]
show TypeSpec (Sum a b)
s'] (TypeSpec (Sum a b)
s TypeSpec (Sum a b) -> TypeSpec (Sum a b) -> TypeSpec (Sum a b)
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
_) = a -> Specification a -> Bool
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) = b -> Specification b -> Bool
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 = [Char] -> GenT m (Sum a b)
forall (m :: * -> *) a. MonadGenError m => [Char] -> m a
genError [Char]
"genFromTypeSpec @SumSpec: empty"
    | Bool
emptyA = b -> Sum a b
forall a b. b -> Sum a b
SumRight (b -> Sum a b) -> GenT m b -> GenT m (Sum a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Specification b -> GenT m b
forall a (m :: * -> *).
(HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecT Specification b
sb
    | Bool
emptyB = a -> Sum a b
forall a b. a -> Sum a b
SumLeft (a -> Sum a b) -> GenT m a -> GenT m (Sum a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Specification a -> GenT m a
forall a (m :: * -> *).
(HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecT Specification a
sa
    | Int
fA Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0, Int
fB Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = [Char] -> GenT m (Sum a b)
forall (m :: * -> *) a. MonadGenError m => [Char] -> m a
genError [Char]
"All frequencies 0"
    | Bool
otherwise =
        [(Int, GenT GE (Sum a b))] -> GenT m (Sum a b)
forall a (m :: * -> *).
(Typeable a, MonadGenError m) =>
[(Int, GenT GE a)] -> GenT m a
frequencyT
          [ (Int
fA, a -> Sum a b
forall a b. a -> Sum a b
SumLeft (a -> Sum a b) -> GenT GE a -> GenT GE (Sum a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Specification a -> GenT GE a
forall a (m :: * -> *).
(HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecT Specification a
sa)
          , (Int
fB, b -> Sum a b
forall a b. b -> Sum a b
SumRight (b -> Sum a b) -> GenT GE b -> GenT GE (Sum a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Specification b -> GenT GE b
forall a (m :: * -> *).
(HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecT Specification b
sb)
          ]
    where
      (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 -> Int
fA, Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 -> Int
fB) = (Int, Int) -> Maybe (Int, Int) -> (Int, Int)
forall a. a -> Maybe a -> a
fromMaybe (Int
1, forall a. KnownNat (CountCases a) => Int
countCases @b) Maybe (Int, Int)
h
      emptyA :: Bool
emptyA = Specification a -> Bool
forall a. Specification a -> Bool
isErrorLike Specification a
sa
      emptyB :: Bool
emptyB = Specification b -> Bool
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) = a -> Sum a b
forall a b. a -> Sum a b
SumLeft (a -> Sum a b) -> [a] -> [Sum a b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Specification a -> a -> [a]
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) = b -> Sum a b
forall a b. b -> Sum a b
SumRight (b -> Sum a b) -> [b] -> [Sum a b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Specification b -> b -> [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) =
    TermD Deps (SumOver '[a, b])
-> List (Weighted (BinderD Deps)) '[a, b] -> Pred
forall deps (as :: [*]).
(HasSpecD deps (SumOver as), Show (SumOver as)) =>
TermD deps (SumOver as)
-> List (Weighted (BinderD deps)) as -> PredD deps
Case
      TermD Deps (SumOver '[a, b])
Term (Sum a b)
ct
      ( (Maybe Int -> BinderD Deps a -> Weighted (BinderD Deps) a
forall (f :: * -> *) a. Maybe Int -> f a -> Weighted f a
Weighted ((Int, Int) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> Int) -> Maybe (Int, Int) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Int, Int)
h) (BinderD Deps a -> Weighted (BinderD Deps) a)
-> BinderD Deps a -> Weighted (BinderD Deps) a
forall a b. (a -> b) -> a -> b
$ (Term a -> Pred) -> BinderD Deps a
forall a p. (HasSpec a, IsPred p) => (Term a -> p) -> Binder a
bind ((Term a -> Pred) -> BinderD Deps a)
-> (Term a -> Pred) -> BinderD Deps a
forall a b. (a -> b) -> a -> b
$ \Term a
a -> Term a -> Specification a -> Pred
forall a. HasSpec a => Term a -> Specification a -> Pred
satisfies Term a
a Specification a
sa)
          Weighted (BinderD Deps) a
-> List (Weighted (BinderD Deps)) '[b]
-> List (Weighted (BinderD Deps)) '[a, b]
forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> (Maybe Int -> BinderD Deps b -> Weighted (BinderD Deps) b
forall (f :: * -> *) a. Maybe Int -> f a -> Weighted f a
Weighted ((Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int) -> Maybe (Int, Int) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Int, Int)
h) (BinderD Deps b -> Weighted (BinderD Deps) b)
-> BinderD Deps b -> Weighted (BinderD Deps) b
forall a b. (a -> b) -> a -> b
$ (Term b -> Pred) -> BinderD Deps b
forall a p. (HasSpec a, IsPred p) => (Term a -> p) -> Binder a
bind ((Term b -> Pred) -> BinderD Deps b)
-> (Term b -> Pred) -> BinderD Deps b
forall a b. (a -> b) -> a -> b
$ \Term b
b -> Term b -> Specification b -> Pred
forall a. HasSpec a => Term a -> Specification a -> Pred
satisfies Term b
b Specification b
sb)
          Weighted (BinderD Deps) b
-> List (Weighted (BinderD Deps)) '[]
-> List (Weighted (BinderD Deps)) '[b]
forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> List (Weighted (BinderD Deps)) '[]
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) = Specification Integer
-> Specification Integer -> Specification Integer
forall n.
Number n =>
Specification n -> Specification n -> Specification n
addSpecInt (Specification a -> Specification Integer
forall a.
(Number Integer, HasSpec a) =>
Specification a -> Specification Integer
cardinality Specification a
leftspec) (Specification b -> Specification Integer
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 (Specification a -> Bool
forall a. Specification a -> Bool
isErrorLike Specification a
x, Specification b -> Bool
forall a. Specification a -> Bool
isErrorLike Specification b
y) of
      (Bool
True, Bool
True) -> NonEmpty [Char] -> Maybe (NonEmpty [Char])
forall a. a -> Maybe a
Just (NonEmpty [Char] -> Maybe (NonEmpty [Char]))
-> NonEmpty [Char] -> Maybe (NonEmpty [Char])
forall a b. (a -> b) -> a -> b
$ (Specification a -> NonEmpty [Char]
forall a. Specification a -> NonEmpty [Char]
errorLikeMessage Specification a
x NonEmpty [Char] -> NonEmpty [Char] -> NonEmpty [Char]
forall a. Semigroup a => a -> a -> a
<> Specification b -> NonEmpty [Char]
forall a. Specification a -> NonEmpty [Char]
errorLikeMessage Specification b
y)
      (Bool, Bool)
_ -> Maybe (NonEmpty [Char])
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) -> [Char] -> [Doc a] -> BinaryShow
forall a. [Char] -> [Doc a] -> BinaryShow
BinaryShow [Char]
"SumSpec" (Doc a
"|" Doc a -> Doc a -> Doc a
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Maybe (Int, Int) -> Doc a
forall a. Maybe (Int, Int) -> Doc a
sumWeightL Maybe (Int, Int)
h Doc a -> Doc a -> Doc a
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Specification a -> Doc a
forall a ann. Show a => a -> Doc ann
viaShow Specification a
left Doc a -> [Doc a] -> [Doc a]
forall a. a -> [a] -> [a]
: [Doc a]
ps)
      (BinaryShow [Char]
"Cartesian" [Doc a]
ps) ->
        [Char] -> [Doc a] -> BinaryShow
forall a. [Char] -> [Doc a] -> BinaryShow
BinaryShow [Char]
"SumSpec" (Doc a
"|" Doc a -> Doc a -> Doc a
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Maybe (Int, Int) -> Doc a
forall a. Maybe (Int, Int) -> Doc a
sumWeightL Maybe (Int, Int)
h Doc a -> Doc a -> Doc a
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Specification a -> Doc a
forall a ann. Show a => a -> Doc ann
viaShow Specification a
left Doc a -> [Doc a] -> [Doc a]
forall a. a -> [a] -> [a]
: [Doc a -> Doc a
forall ann. Doc ann -> Doc ann
parens (Doc a
"Cartesian" Doc a -> Doc a -> Doc a
forall ann. Doc ann -> Doc ann -> Doc ann
/> [Doc a] -> Doc a
forall ann. [Doc ann] -> Doc ann
vsep [Doc a]
ps)])
      BinaryShow
_ ->
        [Char] -> [Doc Any] -> BinaryShow
forall a. [Char] -> [Doc a] -> BinaryShow
BinaryShow [Char]
"SumSpec" [Doc Any
"|" Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Maybe (Int, Int) -> Doc Any
forall a. Maybe (Int, Int) -> Doc a
sumWeightL Maybe (Int, Int)
h Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Specification a -> Doc Any
forall a ann. Show a => a -> Doc ann
viaShow Specification a
left, Doc Any
"|" Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Maybe (Int, Int) -> Doc Any
forall a. Maybe (Int, Int) -> Doc a
sumWeightR Maybe (Int, Int)
h Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Specification b -> Doc Any
forall a ann. Show a => a -> Doc ann
viaShow Specification b
right]
  alternateShow (SumSpec Maybe (Int, Int)
h Specification a
left Specification b
right) =
    [Char] -> [Doc Any] -> BinaryShow
forall a. [Char] -> [Doc a] -> BinaryShow
BinaryShow [Char]
"SumSpec" [Doc Any
"|" Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Maybe (Int, Int) -> Doc Any
forall a. Maybe (Int, Int) -> Doc a
sumWeightL Maybe (Int, Int)
h Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Specification a -> Doc Any
forall a ann. Show a => a -> Doc ann
viaShow Specification a
left, Doc Any
"|" Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Maybe (Int, Int) -> Doc Any
forall a. Maybe (Int, Int) -> Doc a
sumWeightR Maybe (Int, Int)
h Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Specification b -> Doc Any
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=" [Char] -> [Char] -> [Char]
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 =
    Maybe (Int, Int)
-> Specification a -> Specification b -> SumSpec a b
forall a b.
Maybe (Int, Int)
-> Specification a -> Specification b -> SumSpec a b
SumSpec
      (Maybe (Int, Int)
 -> Specification a -> Specification b -> SumSpec a b)
-> Gen (Maybe (Int, Int))
-> Gen (Specification a -> Specification b -> SumSpec a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, Gen (Maybe (Int, Int)))] -> Gen (Maybe (Int, Int))
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
        [ (Int
3, Maybe (Int, Int) -> Gen (Maybe (Int, Int))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Int, Int)
forall a. Maybe a
Nothing)
        , (Int
10, (Int, Int) -> Maybe (Int, Int)
forall a. a -> Maybe a
Just ((Int, Int) -> Maybe (Int, Int))
-> Gen (Int, Int) -> Gen (Maybe (Int, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((,) (Int -> Int -> (Int, Int)) -> Gen Int -> Gen (Int -> (Int, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
100) Gen (Int -> (Int, Int)) -> Gen Int -> Gen (Int, Int)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
100)))
        , (Int
1, Gen (Maybe (Int, Int))
forall a. Arbitrary a => Gen a
arbitrary)
        ]
      Gen (Specification a -> Specification b -> SumSpec a b)
-> Gen (Specification a) -> Gen (Specification b -> SumSpec a b)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (Specification a)
forall a. Arbitrary a => Gen a
arbitrary
      Gen (Specification b -> SumSpec a b)
-> Gen (Specification b) -> Gen (SumSpec a b)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (Specification 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) = [Maybe (Int, Int)
-> Specification a -> Specification b -> SumSpec a 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') <- (Maybe (Int, Int), Specification a, Specification b)
-> [(Maybe (Int, Int), Specification a, Specification 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 :: SumW '[a] (Sum a b)
  InjRightW :: 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 = FunTy d r
a -> Sum a b
forall a b. a -> Sum a b
SumLeft
  semantics SumW d r
InjRightW = FunTy d r
b -> Sum a b
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 Specification a -> Specification a -> Specification a
forall a. Semigroup a => a -> a -> a
<> (a -> Specification a) -> [a] -> Specification a
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> Specification a
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 Specification a -> Specification a -> Specification a
forall a. Semigroup a => a -> a -> a
<> (a -> Specification a) -> [a] -> Specification a
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> Specification a
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 <- NonEmpty b -> [b]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty b
es] of
      (a
x : [a]
xs) -> NonEmpty a -> Specification a
forall a deps. NonEmpty a -> SpecificationD deps a
MemberSpec (a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
xs)
      [] ->
        NonEmpty [Char] -> Specification a
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec (NonEmpty [Char] -> Specification a)
-> NonEmpty [Char] -> Specification a
forall a b. (a -> b) -> a -> b
$
          [Char] -> NonEmpty [Char]
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> NonEmpty [Char]) -> [Char] -> NonEmpty [Char]
forall a b. (a -> b) -> a -> b
$
            [Char]
"propMemberSpec (sumleft_ HOLE) on (MemberSpec es) with no SumLeft in es: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [b] -> [Char]
forall a. Show a => a -> [Char]
show (NonEmpty b -> [b]
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 <- NonEmpty b -> [b]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty b
es] of
      (a
x : [a]
xs) -> NonEmpty a -> Specification a
forall a deps. NonEmpty a -> SpecificationD deps a
MemberSpec (a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
xs)
      [] ->
        NonEmpty [Char] -> Specification a
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec (NonEmpty [Char] -> Specification a)
-> NonEmpty [Char] -> Specification a
forall a b. (a -> b) -> a -> b
$
          [Char] -> NonEmpty [Char]
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> NonEmpty [Char]) -> [Char] -> NonEmpty [Char]
forall a b. (a -> b) -> a -> b
$
            [Char]
"propagate(InjRight HOLE) on (MemberSpec es) with no SumLeft in es: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [b] -> [Char]
forall a. Show a => a -> [Char]
show (NonEmpty b -> [b]
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 = TypeSpec b -> Specification b
forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec (TypeSpec b -> Specification b) -> TypeSpec b -> Specification b
forall a b. (a -> b) -> a -> b
$ Maybe (Int, Int)
-> Specification a -> Specification b -> SumSpec a b
forall a b.
Maybe (Int, Int)
-> Specification a -> Specification b -> SumSpec a b
SumSpec Maybe (Int, Int)
forall a. Maybe a
Nothing (TypeSpec a -> Specification a
forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec TypeSpec a
ts) (NonEmpty [Char] -> Specification b
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec ([Char] -> NonEmpty [Char]
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"mapTypeSpec InjLeftW"))
  mapTypeSpec SumW '[a] b
InjRightW TypeSpec a
ts = TypeSpec b -> Specification b
forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec (TypeSpec b -> Specification b) -> TypeSpec b -> Specification b
forall a b. (a -> b) -> a -> b
$ Maybe (Int, Int)
-> Specification a -> Specification a -> SumSpec a a
forall a b.
Maybe (Int, Int)
-> Specification a -> Specification b -> SumSpec a b
SumSpec Maybe (Int, Int)
forall a. Maybe a
Nothing (NonEmpty [Char] -> Specification a
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec ([Char] -> NonEmpty [Char]
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"mapTypeSpec InjRightW")) (TypeSpec a -> Specification a
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_ = SumW '[a] (Sum a b)
-> FunTy (MapList Term '[a]) (TermD Deps (Sum a b))
forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm SumW '[a] (Sum a b)
forall t 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_ = SumW '[b] (Sum a b)
-> FunTy (MapList Term '[b]) (TermD Deps (Sum a b))
forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm SumW '[b] (Sum a b)
forall t a. SumW '[t] (Sum a t)
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)

-- | 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 = FunTy dom rng
Bool -> Bool
not
boolSem BoolW dom rng
OrW = FunTy dom rng
Bool -> Bool -> Bool
(||)

instance Semantics BoolW where
  semantics :: forall (dom :: [*]) rng. BoolW dom rng -> FunTy dom rng
semantics = BoolW d r -> FunTy d r
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 [] SpecificationD Deps b
s) = BoolW as b
-> ListCtx Value as (HOLE a)
-> SpecificationD Deps b
-> Specification a
forall (as :: [*]) b a.
(AppRequires BoolW as b, HasSpec a) =>
BoolW as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification 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 BoolW as b
f ListCtx Value as (HOLE a)
ctxt SpecificationD Deps b
s
  propagate BoolW as b
f ListCtx Value as (HOLE a)
ctxt (ExplainSpec [[Char]]
es SpecificationD Deps b
s) = [[Char]] -> Specification a -> Specification a
forall deps a.
[[Char]] -> SpecificationD deps a -> SpecificationD deps a
ExplainSpec [[Char]]
es (Specification a -> Specification a)
-> Specification a -> Specification a
forall a b. (a -> b) -> a -> b
$ BoolW as b
-> ListCtx Value as (HOLE a)
-> SpecificationD Deps b
-> Specification a
forall (as :: [*]) b a.
(AppRequires BoolW as b, HasSpec a) =>
BoolW as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification 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 BoolW as b
f ListCtx Value as (HOLE a)
ctxt SpecificationD Deps b
s
  propagate BoolW as b
_ ListCtx Value as (HOLE a)
_ SpecificationD Deps b
TrueSpec = Specification a
forall deps a. SpecificationD deps a
TrueSpec
  propagate BoolW as b
_ ListCtx Value as (HOLE a)
_ (ErrorSpec NonEmpty [Char]
msgs) = NonEmpty [Char] -> Specification a
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec NonEmpty [Char]
msgs
  propagate BoolW as b
NotW (Unary HOLE a Bool
HOLE) (SuspendedSpec Var b
v Pred
ps) =
    (Term a -> Pred) -> Specification a
forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained ((Term a -> Pred) -> Specification a)
-> (Term a -> Pred) -> Specification a
forall a b. (a -> b) -> a -> b
$ \Term a
v' -> TermD Deps Bool -> BinderD Deps Bool -> Pred
forall deps a. TermD deps a -> BinderD deps a -> PredD deps
Let (BoolW '[Bool] Bool -> List Term '[Bool] -> TermD Deps Bool
forall deps (t :: [*] -> * -> *) (dom :: [*]) a.
AppRequiresD deps t dom a =>
t dom a -> List (TermD deps) dom -> TermD deps a
App BoolW '[Bool] Bool
NotW (Term a
v' Term a -> List Term '[] -> List Term '[a]
forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> List Term '[]
forall {k} (f :: k -> *). List f '[]
Nil)) (Var b
v Var b -> Pred -> BinderD Deps b
forall deps a.
(HasSpecD deps a, Show a) =>
Var a -> PredD deps -> BinderD deps a
:-> Pred
ps)
  propagate BoolW as b
NotW (Unary HOLE a Bool
HOLE) SpecificationD Deps b
spec =
    Specification Bool
-> (Bool -> Specification Bool) -> Specification Bool
forall a.
HasSpec a =>
Specification Bool -> (Bool -> Specification a) -> Specification a
caseBoolSpec SpecificationD Deps b
Specification Bool
spec (Bool -> Specification Bool
forall a. a -> Specification a
equalSpec (Bool -> Specification Bool)
-> (Bool -> Bool) -> Bool -> Specification Bool
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) =
    (Term a -> Pred) -> Specification a
forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained ((Term a -> Pred) -> Specification a)
-> (Term a -> Pred) -> Specification a
forall a b. (a -> b) -> a -> b
$ \Term a
v' -> TermD Deps Bool -> BinderD Deps Bool -> Pred
forall deps a. TermD deps a -> BinderD deps a -> PredD deps
Let (BoolW '[Bool, Bool] Bool
-> List Term '[Bool, Bool] -> TermD Deps Bool
forall deps (t :: [*] -> * -> *) (dom :: [*]) a.
AppRequiresD deps t dom a =>
t dom a -> List (TermD deps) dom -> TermD deps a
App BoolW '[Bool, Bool] Bool
OrW (Term a
v' Term a -> List Term '[Bool] -> List Term '[a, Bool]
forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> Bool -> TermD Deps Bool
forall a deps. (Typeable a, Eq a, Show a) => a -> TermD deps a
Lit Bool
x TermD Deps Bool -> List Term '[] -> List Term '[Bool]
forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> List Term '[]
forall {k} (f :: k -> *). List f '[]
Nil)) (Var b
v Var b -> Pred -> BinderD Deps b
forall deps a.
(HasSpecD deps a, Show a) =>
Var a -> PredD deps -> BinderD deps a
:-> Pred
ps)
  propagate BoolW as b
OrW (Bool
x :>: HOLE a Bool
HOLE) (SuspendedSpec Var b
v Pred
ps) =
    (Term a -> Pred) -> Specification a
forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained ((Term a -> Pred) -> Specification a)
-> (Term a -> Pred) -> Specification a
forall a b. (a -> b) -> a -> b
$ \Term a
v' -> TermD Deps Bool -> BinderD Deps Bool -> Pred
forall deps a. TermD deps a -> BinderD deps a -> PredD deps
Let (BoolW '[Bool, Bool] Bool
-> List Term '[Bool, Bool] -> TermD Deps Bool
forall deps (t :: [*] -> * -> *) (dom :: [*]) a.
AppRequiresD deps t dom a =>
t dom a -> List (TermD deps) dom -> TermD deps a
App BoolW '[Bool, Bool] Bool
OrW (Bool -> TermD Deps Bool
forall a deps. (Typeable a, Eq a, Show a) => a -> TermD deps a
Lit Bool
x TermD Deps Bool -> List Term '[a] -> List Term '[Bool, a]
forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> Term a
v' Term a -> List Term '[] -> List Term '[a]
forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> List Term '[]
forall {k} (f :: k -> *). List f '[]
Nil)) (Var b
v Var b -> Pred -> BinderD Deps b
forall deps a.
(HasSpecD deps a, Show a) =>
Var a -> PredD deps -> BinderD deps a
:-> Pred
ps)
  propagate BoolW as b
OrW (HOLE a Bool
HOLE :<: Bool
s) SpecificationD Deps b
spec =
    Specification Bool
-> (Bool -> Specification Bool) -> Specification Bool
forall a.
HasSpec a =>
Specification Bool -> (Bool -> Specification a) -> Specification a
caseBoolSpec SpecificationD Deps b
Specification Bool
spec (Bool -> Bool -> Specification Bool
okOr Bool
s)
  propagate BoolW as b
OrW (Bool
s :>: HOLE a Bool
HOLE) SpecificationD Deps b
spec =
    Specification Bool
-> (Bool -> Specification Bool) -> Specification Bool
forall a.
HasSpec a =>
Specification Bool -> (Bool -> Specification a) -> Specification a
caseBoolSpec SpecificationD Deps b
Specification Bool
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 () = TypeSpec b -> Specification b
forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec ()

not_ :: Term Bool -> Term Bool
not_ :: TermD Deps Bool -> TermD Deps Bool
not_ = BoolW '[Bool] Bool
-> FunTy (MapList Term '[Bool]) (TermD Deps Bool)
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) -> Specification Bool
forall deps a. SpecificationD deps a
TrueSpec
  (Bool
True, Bool
False) ->
    NonEmpty [Char] -> Specification Bool
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec
      ([Char] -> NonEmpty [Char]
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Bool -> [Char]
forall a. Show a => a -> [Char]
show Bool
constant [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"||. HOLE) must equal False. That cannot be the case."))
  (Bool
False, Bool
False) -> NonEmpty Bool -> Specification Bool
forall a deps. NonEmpty a -> SpecificationD deps a
MemberSpec (Bool -> NonEmpty Bool
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)
  (Bool
False, Bool
True) -> NonEmpty Bool -> Specification Bool
forall a deps. NonEmpty a -> SpecificationD deps a
MemberSpec (Bool -> NonEmpty Bool
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True)

or_ :: Term Bool -> Term Bool -> Term Bool
or_ :: TermD Deps Bool -> TermD Deps Bool -> TermD Deps Bool
or_ = BoolW '[Bool, Bool] Bool
-> FunTy (MapList Term '[Bool, Bool]) (TermD Deps Bool)
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
  isInfix :: forall (dom :: [*]) rng. EqW dom rng -> Bool
isInfix EqW dom rng
EqualW = Bool
True

instance Semantics EqW where
  semantics :: forall (d :: [*]) r. EqW d r -> FunTy d r
semantics EqW d r
EqualW = FunTy d r
a -> a -> Bool
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 SpecificationD Deps b
s) = [[Char]] -> Specification a -> Specification a
forall a. [[Char]] -> Specification a -> Specification a
explainSpec [[Char]]
es (Specification a -> Specification a)
-> Specification a -> Specification a
forall a b. (a -> b) -> a -> b
$ EqW as b
-> ListCtx Value as (HOLE a)
-> SpecificationD Deps b
-> Specification a
forall (as :: [*]) b a.
(AppRequires EqW as b, HasSpec a) =>
EqW as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification 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 EqW as b
f ListCtx Value as (HOLE a)
ctxt SpecificationD Deps b
s
  propagate EqW as b
_ ListCtx Value as (HOLE a)
_ SpecificationD Deps b
TrueSpec = Specification a
forall deps a. SpecificationD deps a
TrueSpec
  propagate EqW as b
_ ListCtx Value as (HOLE a)
_ (ErrorSpec NonEmpty [Char]
msgs) = NonEmpty [Char] -> Specification a
forall deps a. NonEmpty [Char] -> SpecificationD deps 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) =
    (Term a -> Pred) -> Specification a
forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained ((Term a -> Pred) -> Specification a)
-> (Term a -> Pred) -> Specification a
forall a b. (a -> b) -> a -> b
$ \Term a
v' -> TermD Deps Bool -> BinderD Deps Bool -> Pred
forall deps a. TermD deps a -> BinderD deps a -> PredD deps
Let (EqW '[a, a] Bool -> List Term '[a, a] -> TermD Deps Bool
forall deps (t :: [*] -> * -> *) (dom :: [*]) a.
AppRequiresD deps t dom a =>
t dom a -> List (TermD deps) dom -> TermD deps a
App EqW '[a, a] Bool
forall t. (Eq t, HasSpec t) => EqW '[t, t] Bool
EqualW (Term a
v' Term a -> List Term '[a] -> List Term '[a, a]
forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> a -> TermD Deps a
forall a deps. (Typeable a, Eq a, Show a) => a -> TermD deps a
Lit a
x TermD Deps a -> List Term '[] -> List Term '[a]
forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> List Term '[]
forall {k} (f :: k -> *). List f '[]
Nil)) (Var b
v Var b -> Pred -> BinderD Deps b
forall deps a.
(HasSpecD deps a, Show a) =>
Var a -> PredD deps -> BinderD deps a
:-> Pred
ps)
  propagate EqW as b
EqualW (Value a
x :! Unary HOLE a a
HOLE) (SuspendedSpec Var b
v Pred
ps) =
    (Term a -> Pred) -> Specification a
forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained ((Term a -> Pred) -> Specification a)
-> (Term a -> Pred) -> Specification a
forall a b. (a -> b) -> a -> b
$ \Term a
v' -> TermD Deps Bool -> BinderD Deps Bool -> Pred
forall deps a. TermD deps a -> BinderD deps a -> PredD deps
Let (EqW '[a, a] Bool -> List Term '[a, a] -> TermD Deps Bool
forall deps (t :: [*] -> * -> *) (dom :: [*]) a.
AppRequiresD deps t dom a =>
t dom a -> List (TermD deps) dom -> TermD deps a
App EqW '[a, a] Bool
forall t. (Eq t, HasSpec t) => EqW '[t, t] Bool
EqualW (a -> TermD Deps a
forall a deps. (Typeable a, Eq a, Show a) => a -> TermD deps a
Lit a
x TermD Deps a -> List Term '[a] -> List Term '[a, a]
forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> Term a
v' Term a -> List Term '[] -> List Term '[a]
forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> List Term '[]
forall {k} (f :: k -> *). List f '[]
Nil)) (Var b
v Var b -> Pred -> BinderD Deps b
forall deps a.
(HasSpecD deps a, Show a) =>
Var a -> PredD deps -> BinderD deps a
:-> Pred
ps)
  propagate EqW as b
EqualW (HOLE a a
HOLE :? Value a
s :> List Value as1
Nil) SpecificationD Deps b
spec =
    Specification Bool -> (Bool -> Specification a) -> Specification a
forall a.
HasSpec a =>
Specification Bool -> (Bool -> Specification a) -> Specification a
caseBoolSpec SpecificationD Deps b
Specification Bool
spec ((Bool -> Specification a) -> Specification a)
-> (Bool -> Specification a) -> Specification a
forall a b. (a -> b) -> a -> b
$ \case
      Bool
True -> a -> Specification a
forall a. a -> Specification a
equalSpec a
s
      Bool
False -> a -> Specification a
forall a. HasSpec a => a -> Specification a
notEqualSpec a
s
  propagate EqW as b
EqualW (Value a
s :! Unary HOLE a a
HOLE) SpecificationD Deps b
spec =
    Specification Bool -> (Bool -> Specification a) -> Specification a
forall a.
HasSpec a =>
Specification Bool -> (Bool -> Specification a) -> Specification a
caseBoolSpec SpecificationD Deps b
Specification Bool
spec ((Bool -> Specification a) -> Specification a)
-> (Bool -> Specification a) -> Specification a
forall a b. (a -> b) -> a -> b
$ \case
      Bool
True -> a -> Specification a
forall a. a -> Specification a
equalSpec a
s
      Bool
False -> a -> Specification a
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 Term a -> Term a -> Bool
forall a. Eq a => a -> a -> Bool
== Term a
Term a
t' = Term rng -> Maybe (Term rng)
forall a. a -> Maybe a
Just (Term rng -> Maybe (Term rng)) -> Term rng -> Maybe (Term rng)
forall a b. (a -> b) -> a -> b
$ Bool -> TermD Deps Bool
forall a. HasSpec a => a -> Term a
lit Bool
True
    | Bool
otherwise = Maybe (Term rng)
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) = [Term a -> TypeSpec a -> Pred
forall a. HasSpec a => Term a -> TypeSpec a -> Pred
toPreds Term a
t (Maybe (Int, Int)
-> Specification a -> Specification b -> SumSpec a b
forall a b.
Maybe (Int, Int)
-> Specification a -> Specification b -> SumSpec a b
SumSpec Maybe (Int, Int)
forall a. Maybe a
Nothing Specification a
forall deps a. SpecificationD deps a
TrueSpec (NonEmpty [Char] -> Specification b
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec ([Char] -> NonEmpty [Char]
forall a. a -> NonEmpty a
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) = [Term a -> TypeSpec a -> Pred
forall a. HasSpec a => Term a -> TypeSpec a -> Pred
toPreds Term a
t (Maybe (Int, Int)
-> Specification a -> Specification b -> SumSpec a b
forall a b.
Maybe (Int, Int)
-> Specification a -> Specification b -> SumSpec a b
SumSpec Maybe (Int, Int)
forall a. Maybe a
Nothing (NonEmpty [Char] -> Specification a
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec ([Char] -> NonEmpty [Char]
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"saturatePred")) Specification b
forall deps a. SpecificationD deps 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 -> TermD Deps Bool
(==.) = EqW '[a, a] Bool -> FunTy (MapList Term '[a, a]) (TermD Deps Bool)
forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm EqW '[a, a] Bool
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)
    )

simplifySpec :: HasSpec a => Specification a -> Specification a
simplifySpec :: forall a. HasSpec a => Specification a -> Specification a
simplifySpec Specification a
spec = case Specification a -> Specification a
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 GE (Specification a) -> Specification a
forall a. HasCallStack => GE (Specification a) -> Specification a
fromGESpec (GE (Specification a) -> Specification a)
-> GE (Specification a) -> Specification a
forall a b. (a -> b) -> a -> b
$
          [Char] -> GE (Specification a) -> GE (Specification a)
forall (m :: * -> *) a. MonadGenError m => [Char] -> m a -> m a
explain
            ([Char]
"\nWhile calling simplifySpec on var " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Var a -> [Char]
forall a. Show a => a -> [Char]
show Var a
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\noptP=\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Pred -> [Char]
forall a. Show a => a -> [Char]
show Pred
optP [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n")
            (Var a -> Pred -> GE (Specification a)
forall a.
(HasSpec a, HasCallStack) =>
Var a -> Pred -> GE (Specification a)
computeSpecSimplified Var a
x Pred
optP)
  MemberSpec NonEmpty a
xs -> NonEmpty a -> Specification a
forall a deps. NonEmpty a -> SpecificationD deps a
MemberSpec NonEmpty a
xs
  ErrorSpec NonEmpty [Char]
es -> NonEmpty [Char] -> Specification a
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec NonEmpty [Char]
es
  TypeSpec TypeSpec a
ts [a]
cant -> TypeSpec a -> [a] -> Specification a
forall a. HasSpec a => TypeSpec a -> [a] -> Specification a
TypeSpec TypeSpec a
ts [a]
cant
  Specification a
TrueSpec -> Specification a
forall deps a. SpecificationD deps a
TrueSpec
  ExplainSpec [[Char]]
es Specification a
s -> [[Char]] -> Specification a -> Specification a
forall a. [[Char]] -> Specification a -> Specification a
explainSpecOpt [[Char]]
es (Specification a -> Specification a
forall a. HasSpec a => Specification a -> Specification a
simplifySpec Specification a
s)

instance Numeric a => Complete a where
  simplifyA :: Specification a -> Specification a
simplifyA = Specification a -> Specification a
forall a. HasSpec a => Specification a -> Specification a
simplifySpec
  genFromSpecA :: forall (m :: * -> *).
(HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecA = Specification a -> GenT m a
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) =>
TermD Deps Bool -> p -> q -> Pred
ifElse TermD Deps Bool
b p
p q
q = TermD Deps Bool -> p -> Pred
forall p. IsPred p => TermD Deps Bool -> p -> Pred
whenTrue TermD Deps Bool
b p
p Pred -> Pred -> Pred
forall a. Semigroup a => a -> a -> a
<> TermD Deps Bool -> q -> Pred
forall p. IsPred p => TermD Deps Bool -> p -> Pred
whenTrue (TermD Deps Bool -> TermD Deps Bool
not_ TermD Deps Bool
b) q
q

whenTrue :: forall p. IsPred p => Term Bool -> p -> Pred
whenTrue :: forall p. IsPred p => TermD Deps Bool -> p -> Pred
whenTrue (Lit Bool
True) (p -> Pred
forall p. IsPred p => p -> Pred
toPred -> Pred
p) = Pred
p
whenTrue (Lit Bool
False) p
_ = Pred
forall deps. PredD deps
TruePred
whenTrue TermD Deps Bool
b (p -> Pred
forall p. IsPred p => p -> Pred
toPred -> FalsePred {}) = TermD Deps Bool -> Pred
forall p. IsPred p => p -> Pred
assert (TermD Deps Bool -> TermD Deps Bool
not_ TermD Deps Bool
b)
whenTrue TermD Deps Bool
_ (p -> Pred
forall p. IsPred p => p -> Pred
toPred -> Pred
TruePred) = Pred
forall deps. PredD deps
TruePred
whenTrue TermD Deps Bool
b (p -> Pred
forall p. IsPred p => p -> Pred
toPred -> Pred
p) = TermD Deps Bool -> Pred -> Pred
forall deps. TermD deps Bool -> PredD deps -> PredD deps
When TermD Deps 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 <- Var a -> Var a -> Maybe (a :~: a)
forall a a'.
(Typeable a, Typeable a') =>
Var a -> Var a' -> Maybe (a :~: a')
eqVar Var a
x Var a
x' = Term a -> Maybe (Term a)
forall a. a -> Maybe a
Just Term a
t'
  | V Var a
x' <- Term a
t', Just a :~: a
Refl <- Var a -> Var a -> Maybe (a :~: a)
forall a a'.
(Typeable a, Typeable a') =>
Var a -> Var a' -> Maybe (a :~: a')
eqVar Var a
x Var a
x' = Term a -> Maybe (Term a)
forall a. a -> Maybe a
Just Term a
t
pinnedBy Var a
x (And [Pred]
ps) = [TermD Deps a] -> Maybe (TermD Deps a)
forall a. [a] -> Maybe a
listToMaybe ([TermD Deps a] -> Maybe (TermD Deps a))
-> [TermD Deps a] -> Maybe (TermD Deps a)
forall a b. (a -> b) -> a -> b
$ [Maybe (TermD Deps a)] -> [TermD Deps a]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (TermD Deps a)] -> [TermD Deps a])
-> [Maybe (TermD Deps a)] -> [TermD Deps a]
forall a b. (a -> b) -> a -> b
$ (Pred -> Maybe (TermD Deps a)) -> [Pred] -> [Maybe (TermD Deps a)]
forall a b. (a -> b) -> [a] -> [b]
map (Var a -> Pred -> Maybe (TermD Deps a)
forall a. HasSpec a => Var a -> Pred -> Maybe (Term a)
pinnedBy Var a
x) [Pred]
ps
pinnedBy Var a
_ Pred
_ = Maybe (TermD Deps a)
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
    (Pred -> Pred) -> (Pred -> Pred) -> Pred -> Pred
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pred -> Pred
letSubexpressionElimination
    (Pred -> Pred) -> (Pred -> Pred) -> Pred -> Pred
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pred -> Pred
letFloating
    (Pred -> Pred) -> (Pred -> Pred) -> Pred -> Pred
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pred -> Pred
aggressiveInlining
    (Pred -> Pred) -> (Pred -> Pred) -> Pred -> Pred
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pred -> Pred
simplifyPred
    (Pred -> Pred) -> Pred -> Pred
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) = Writer Any Pred -> (Pred, Any)
forall w a. Writer w a -> (a, w)
runWriter (Writer Any Pred -> (Pred, Any)) -> Writer Any Pred -> (Pred, Any)
forall a b. (a -> b) -> a -> b
$ FreeVars -> Subst -> Pred -> Writer Any Pred
go (Pred -> FreeVars
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 FreeVars -> [Name] -> FreeVars
forall (t :: * -> *). Foldable t => FreeVars -> t Name -> FreeVars
`without` [Var a -> Name
forall a. HasSpec a => Var a -> Name
Name Var a
x] FreeVars -> FreeVars -> FreeVars
forall a. Semigroup a => a -> a -> a
<> Name -> Int -> FreeVars
singleton (Var a -> Name
forall a. HasSpec a => Var a -> Name
Name Var a
x) (Name -> p -> Int
forall a. HasVariables a => Name -> a -> Int
countOf (Var a -> Name
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' Var a -> Term a -> SubstEntry
forall a. HasSpec a => Var a -> Term a -> SubstEntry
:= Term a
t
      | Var a
x' := Term a
t <- Subst
sub
      , Maybe (a :~: a) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (a :~: a) -> Bool) -> Maybe (a :~: a) -> Bool
forall a b. (a -> b) -> a -> b
$ Var a -> Var a -> Maybe (a :~: a)
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 Var a -> Pred -> BinderD Deps a
forall deps a.
(HasSpecD deps a, Show a) =>
Var a -> PredD deps -> BinderD deps a
:->) (Pred -> BinderD Deps a)
-> Writer Any Pred -> WriterT Any Identity (BinderD Deps a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FreeVars -> Subst -> Pred -> Writer Any Pred
go (FreeVars -> Var a -> Pred -> FreeVars
forall {a} {p}.
(HasSpec a, HasVariables p) =>
FreeVars -> Var a -> p -> FreeVars
underBinder FreeVars
fvs Var a
x Pred
p) (Subst -> Var a -> Subst
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 -> PredD deps -> Bool
onlyUsedUniquely Name
n PredD deps
p = case PredD deps
p of
      Assert TermD deps Bool
t
        | Name
n Name -> TermD deps Bool -> Bool
forall a. HasVariables a => Name -> a -> Bool
`appearsIn` TermD deps Bool
t -> Set Name -> Int
forall a. Set a -> Int
Set.size (TermD deps Bool -> Set Name
forall a. HasVariables a => a -> Set Name
freeVarSet TermD deps Bool
t) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
        | Bool
otherwise -> Bool
True
      And [PredD deps]
ps -> (PredD deps -> Bool) -> [PredD deps] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Name -> PredD deps -> Bool
onlyUsedUniquely Name
n) [PredD deps]
ps
      -- TODO: we can (and should) probably add a bunch of cases to this.
      PredD deps
_ -> Bool
False

    go :: FreeVars -> Subst -> Pred -> Writer Any Pred
go FreeVars
fvs Subst
sub Pred
pred2 = case Pred
pred2 of
      ElemPred Bool
bool TermD Deps a
t NonEmpty a
xs
        | Bool -> Bool
not (TermD Deps a -> Bool
forall a. Term a -> Bool
isLit TermD Deps a
t)
        , Lit a
a <- Subst -> TermD Deps a -> TermD Deps a
forall a. Subst -> Term a -> Term a
substituteAndSimplifyTerm Subst
sub TermD Deps a
t -> do
            Any -> WriterT Any Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Any -> WriterT Any Identity ()) -> Any -> WriterT Any Identity ()
forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
            Pred -> Writer Any Pred
forall a. a -> WriterT Any Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pred -> Writer Any Pred) -> Pred -> Writer Any Pred
forall a b. (a -> b) -> a -> b
$ Bool -> TermD Deps a -> NonEmpty a -> Pred
forall deps a.
(HasSpecD deps a, Show a) =>
Bool -> TermD deps a -> NonEmpty a -> PredD deps
ElemPred Bool
bool (a -> TermD Deps a
forall a deps. (Typeable a, Eq a, Show a) => a -> TermD deps a
Lit a
a) NonEmpty a
xs
        | Bool
otherwise -> Pred -> Writer Any Pred
forall a. a -> WriterT Any Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pred -> Writer Any Pred) -> Pred -> Writer Any Pred
forall a b. (a -> b) -> a -> b
$ Bool -> TermD Deps a -> NonEmpty a -> Pred
forall deps a.
(HasSpecD deps a, Show a) =>
Bool -> TermD deps a -> NonEmpty a -> PredD deps
ElemPred Bool
bool TermD Deps a
t NonEmpty a
xs
      Subst Var a
x TermD Deps a
t Pred
p -> FreeVars -> Subst -> Pred -> Writer Any Pred
go FreeVars
fvs Subst
sub (Var a -> TermD Deps a -> Pred -> Pred
forall a. HasSpec a => Var a -> Term a -> Pred -> Pred
substitutePred Var a
x TermD Deps a
t Pred
p)
      Reifies TermD Deps b
t' TermD Deps a
t a -> b
f
        | Bool -> Bool
not (TermD Deps a -> Bool
forall a. Term a -> Bool
isLit TermD Deps a
t)
        , Lit a
a <- Subst -> TermD Deps a -> TermD Deps a
forall a. Subst -> Term a -> Term a
substituteAndSimplifyTerm Subst
sub TermD Deps a
t -> do
            Any -> WriterT Any Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Any -> WriterT Any Identity ()) -> Any -> WriterT Any Identity ()
forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
            Pred -> Writer Any Pred
forall a. a -> WriterT Any Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pred -> Writer Any Pred) -> Pred -> Writer Any Pred
forall a b. (a -> b) -> a -> b
$ TermD Deps b -> TermD Deps a -> (a -> b) -> Pred
forall deps a b.
(HasSpecD deps a, HasSpecD deps b, Show a, Show b) =>
TermD deps b -> TermD deps a -> (a -> b) -> PredD deps
Reifies TermD Deps b
t' (a -> TermD Deps a
forall a deps. (Typeable a, Eq a, Show a) => a -> TermD deps a
Lit a
a) a -> b
f
        | Bool
otherwise -> Pred -> Writer Any Pred
forall a. a -> WriterT Any Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pred -> Writer Any Pred) -> Pred -> Writer Any Pred
forall a b. (a -> b) -> a -> b
$ TermD Deps b -> TermD Deps a -> (a -> b) -> Pred
forall deps a b.
(HasSpecD deps a, HasSpecD deps b, Show a, Show b) =>
TermD deps b -> TermD deps a -> (a -> b) -> PredD deps
Reifies TermD Deps b
t' TermD Deps a
t a -> b
f
      ForAll TermD Deps t
set BinderD Deps e
b
        | Bool -> Bool
not (TermD Deps t -> Bool
forall a. Term a -> Bool
isLit TermD Deps t
set)
        , Lit t
a <- Subst -> TermD Deps t -> TermD Deps t
forall a. Subst -> Term a -> Term a
substituteAndSimplifyTerm Subst
sub TermD Deps t
set -> do
            Any -> WriterT Any Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Any -> WriterT Any Identity ()) -> Any -> WriterT Any Identity ()
forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
            Pred -> Writer Any Pred
forall a. a -> WriterT Any Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pred -> Writer Any Pred) -> Pred -> Writer Any Pred
forall a b. (a -> b) -> a -> b
$ (e -> Pred) -> [e] -> Pred
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (e -> BinderD Deps e -> Pred
forall a. a -> Binder a -> Pred
`unBind` BinderD Deps e
b) (t -> [e]
forall t e. Forallable t e => t -> [e]
forAllToList t
a)
        | Bool
otherwise -> TermD Deps t -> BinderD Deps e -> Pred
forall deps t e.
(ForallableD deps t e, HasSpecD deps t, HasSpecD deps e, Show t,
 Show e) =>
TermD deps t -> BinderD deps e -> PredD deps
ForAll TermD Deps t
set (BinderD Deps e -> Pred)
-> WriterT Any Identity (BinderD Deps e) -> Writer Any Pred
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FreeVars
-> Subst -> BinderD Deps e -> WriterT Any Identity (BinderD Deps e)
forall a. FreeVars -> Subst -> Binder a -> Writer Any (Binder a)
goBinder FreeVars
fvs Subst
sub BinderD Deps e
b
      Case TermD Deps (SumOver as)
t List (Weighted (BinderD Deps)) as
bs
        | Bool -> Bool
not (TermD Deps (SumOver as) -> Bool
forall a. Term a -> Bool
isLit TermD Deps (SumOver as)
t)
        , Lit SumOver as
a <- Subst -> TermD Deps (SumOver as) -> TermD Deps (SumOver as)
forall a. Subst -> Term a -> Term a
substituteAndSimplifyTerm Subst
sub TermD Deps (SumOver as)
t -> do
            Any -> WriterT Any Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Any -> WriterT Any Identity ()) -> Any -> WriterT Any Identity ()
forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
            Pred -> Writer Any Pred
forall a. a -> WriterT Any Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pred -> Writer Any Pred) -> Pred -> Writer Any Pred
forall a b. (a -> b) -> a -> b
$ SumOver as
-> List (BinderD Deps) as
-> (forall {a}. (Typeable a, Show a) => Var a -> a -> Pred -> Pred)
-> Pred
forall (as :: [*]) r.
SumOver as
-> List (BinderD Deps) as
-> (forall a. (Typeable a, Show a) => Var a -> a -> Pred -> r)
-> r
runCaseOn SumOver as
a ((forall a. Weighted (BinderD Deps) a -> Binder a)
-> List (Weighted (BinderD Deps)) as -> List (BinderD Deps) as
forall {k} (f :: k -> *) (g :: k -> *) (as :: [k]).
(forall (a :: k). f a -> g a) -> List f as -> List g as
mapList Weighted (BinderD Deps) a -> BinderD Deps a
forall a. Weighted (BinderD Deps) a -> Binder a
forall (f :: * -> *) a. Weighted f a -> f a
thing List (Weighted (BinderD Deps)) as
bs) ((forall {a}. (Typeable a, Show a) => Var a -> a -> Pred -> Pred)
 -> Pred)
-> (forall {a}. (Typeable a, Show a) => Var a -> a -> Pred -> Pred)
-> Pred
forall a b. (a -> b) -> a -> b
$ \Var a
x a
v Pred
p -> Env -> Pred -> Pred
substPred (Var a -> a -> Env
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 (BinderD Deps)) as1
Nil) <- List (Weighted (BinderD Deps)) as
bs -> do
            let t' :: TermD Deps (SumOver as)
t' = Subst -> TermD Deps (SumOver as) -> TermD Deps (SumOver as)
forall a. Subst -> Term a -> Term a
substituteAndSimplifyTerm Subst
sub TermD Deps (SumOver as)
t
            Pred
p' <- FreeVars -> Subst -> Pred -> Writer Any Pred
go (FreeVars -> Var a -> Pred -> FreeVars
forall {a} {p}.
(HasSpec a, HasVariables p) =>
FreeVars -> Var a -> p -> FreeVars
underBinder FreeVars
fvs Var a
x Pred
p) (Var a
x Var a -> Term a -> SubstEntry
forall a. HasSpec a => Var a -> Term a -> SubstEntry
:= Term a
TermD Deps (SumOver as)
t' SubstEntry -> Subst -> Subst
forall a. a -> [a] -> [a]
: Subst
sub) Pred
p
            Pred -> Writer Any Pred
forall a. a -> WriterT Any Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pred -> Writer Any Pred) -> Pred -> Writer Any Pred
forall a b. (a -> b) -> a -> b
$ TermD Deps (SumOver '[a])
-> List (Weighted (BinderD Deps)) '[a] -> Pred
forall deps (as :: [*]).
(HasSpecD deps (SumOver as), Show (SumOver as)) =>
TermD deps (SumOver as)
-> List (Weighted (BinderD deps)) as -> PredD deps
Case TermD Deps (SumOver as)
TermD Deps (SumOver '[a])
t (Maybe Int -> BinderD Deps a -> Weighted (BinderD Deps) a
forall (f :: * -> *) a. Maybe Int -> f a -> Weighted f a
Weighted Maybe Int
w (Var a
x Var a -> Pred -> BinderD Deps a
forall deps a.
(HasSpecD deps a, Show a) =>
Var a -> PredD deps -> BinderD deps a
:-> Pred
p') Weighted (BinderD Deps) a
-> List (Weighted (BinderD Deps)) '[]
-> List (Weighted (BinderD Deps)) '[a]
forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> List (Weighted (BinderD Deps)) '[]
forall {k} (f :: k -> *). List f '[]
Nil)
        | Bool
otherwise -> TermD Deps (SumOver as)
-> List (Weighted (BinderD Deps)) as -> Pred
forall deps (as :: [*]).
(HasSpecD deps (SumOver as), Show (SumOver as)) =>
TermD deps (SumOver as)
-> List (Weighted (BinderD deps)) as -> PredD deps
Case TermD Deps (SumOver as)
t (List (Weighted (BinderD Deps)) as -> Pred)
-> WriterT Any Identity (List (Weighted (BinderD Deps)) as)
-> Writer Any Pred
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a.
 Weighted (BinderD Deps) a
 -> WriterT Any Identity (Weighted (BinderD Deps) a))
-> List (Weighted (BinderD Deps)) as
-> WriterT Any Identity (List (Weighted (BinderD Deps)) as)
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 ((BinderD Deps a -> WriterT Any Identity (BinderD Deps a))
-> Weighted (BinderD Deps) a
-> WriterT Any Identity (Weighted (BinderD Deps) a)
forall (m :: * -> *) (f :: * -> *) a (g :: * -> *).
Applicative m =>
(f a -> m (g a)) -> Weighted f a -> m (Weighted g a)
traverseWeighted ((BinderD Deps a -> WriterT Any Identity (BinderD Deps a))
 -> Weighted (BinderD Deps) a
 -> WriterT Any Identity (Weighted (BinderD Deps) a))
-> (BinderD Deps a -> WriterT Any Identity (BinderD Deps a))
-> Weighted (BinderD Deps) a
-> WriterT Any Identity (Weighted (BinderD Deps) a)
forall a b. (a -> b) -> a -> b
$ FreeVars
-> Subst -> BinderD Deps a -> WriterT Any Identity (BinderD Deps a)
forall a. FreeVars -> Subst -> Binder a -> Writer Any (Binder a)
goBinder FreeVars
fvs Subst
sub) List (Weighted (BinderD Deps)) as
bs
      When TermD Deps Bool
b Pred
tp
        | Bool -> Bool
not (TermD Deps Bool -> Bool
forall a. Term a -> Bool
isLit TermD Deps Bool
b)
        , Lit Bool
a <- Subst -> TermD Deps Bool -> TermD Deps Bool
forall a. Subst -> Term a -> Term a
substituteAndSimplifyTerm Subst
sub TermD Deps Bool
b -> do
            Any -> WriterT Any Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Any -> WriterT Any Identity ()) -> Any -> WriterT Any Identity ()
forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
            Pred -> Writer Any Pred
forall a. a -> WriterT Any Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pred -> Writer Any Pred) -> Pred -> Writer Any Pred
forall a b. (a -> b) -> a -> b
$ if Bool
a then Pred
tp else Pred
forall deps. PredD deps
TruePred
        | Bool
otherwise -> TermD Deps Bool -> Pred -> Pred
forall p. IsPred p => TermD Deps Bool -> p -> Pred
whenTrue TermD Deps Bool
b (Pred -> Pred) -> Writer Any Pred -> Writer Any Pred
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FreeVars -> Subst -> Pred -> Writer Any Pred
go FreeVars
fvs Subst
sub Pred
tp
      Let TermD Deps a
t (Var a
x :-> Pred
p)
        | (Name -> Bool) -> Set Name -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Name
n -> Name -> FreeVars -> Int
count Name
n FreeVars
fvs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1) (TermD Deps a -> Set Name
forall a. HasVariables a => a -> Set Name
freeVarSet TermD Deps a
t) -> do
            Any -> WriterT Any Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Any -> WriterT Any Identity ()) -> Any -> WriterT Any Identity ()
forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
            Pred -> Writer Any Pred
forall a. a -> WriterT Any Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pred -> Writer Any Pred) -> Pred -> Writer Any Pred
forall a b. (a -> b) -> a -> b
$ Var a -> TermD Deps a -> Pred -> Pred
forall a. HasSpec a => Var a -> Term a -> Pred -> Pred
substitutePred Var a
x TermD Deps a
t Pred
p
        | Name -> Pred -> Bool
forall {deps}.
HasVariables (TermD deps Bool) =>
Name -> PredD deps -> Bool
onlyUsedUniquely (Var a -> Name
forall a. HasSpec a => Var a -> Name
Name Var a
x) Pred
p -> do
            Any -> WriterT Any Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Any -> WriterT Any Identity ()) -> Any -> WriterT Any Identity ()
forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
            Pred -> Writer Any Pred
forall a. a -> WriterT Any Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pred -> Writer Any Pred) -> Pred -> Writer Any Pred
forall a b. (a -> b) -> a -> b
$ Var a -> TermD Deps a -> Pred -> Pred
forall a. HasSpec a => Var a -> Term a -> Pred -> Pred
substitutePred Var a
x TermD Deps a
t Pred
p
        | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Var a -> Name
forall a. HasSpec a => Var a -> Name
Name Var a
x Name -> Pred -> Bool
forall a. HasVariables a => Name -> a -> Bool
`appearsIn` Pred
p -> do
            Any -> WriterT Any Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Any -> WriterT Any Identity ()) -> Any -> WriterT Any Identity ()
forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
            Pred -> Writer Any Pred
forall a. a -> WriterT Any Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pred
p
        | Bool -> Bool
not (TermD Deps a -> Bool
forall a. Term a -> Bool
isLit TermD Deps a
t)
        , Lit a
a <- Subst -> TermD Deps a -> TermD Deps a
forall a. Subst -> Term a -> Term a
substituteAndSimplifyTerm Subst
sub TermD Deps a
t -> do
            Any -> WriterT Any Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Any -> WriterT Any Identity ()) -> Any -> WriterT Any Identity ()
forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
            Pred -> Writer Any Pred
forall a. a -> WriterT Any Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pred -> Writer Any Pred) -> Pred -> Writer Any Pred
forall a b. (a -> b) -> a -> b
$ a -> BinderD Deps a -> Pred
forall a. a -> Binder a -> Pred
unBind a
a (Var a
x Var a -> Pred -> BinderD Deps a
forall deps a.
(HasSpecD deps a, Show a) =>
Var a -> PredD deps -> BinderD deps a
:-> Pred
p)
        | Bool
otherwise -> TermD Deps a -> BinderD Deps a -> Pred
forall deps a. TermD deps a -> BinderD deps a -> PredD deps
Let TermD Deps a
t (BinderD Deps a -> Pred)
-> (Pred -> BinderD Deps a) -> Pred -> Pred
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var a
x Var a -> Pred -> BinderD Deps a
forall deps a.
(HasSpecD deps a, Show a) =>
Var a -> PredD deps -> BinderD deps a
:->) (Pred -> Pred) -> Writer Any Pred -> Writer Any Pred
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FreeVars -> Subst -> Pred -> Writer Any Pred
go (FreeVars -> Var a -> Pred -> FreeVars
forall {a} {p}.
(HasSpec a, HasVariables p) =>
FreeVars -> Var a -> p -> FreeVars
underBinder FreeVars
fvs Var a
x Pred
p) (Var a
x Var a -> TermD Deps a -> SubstEntry
forall a. HasSpec a => Var a -> Term a -> SubstEntry
:= TermD Deps a
t SubstEntry -> Subst -> Subst
forall a. a -> [a] -> [a]
: Subst
sub) Pred
p
      Exists (forall b. TermD Deps b -> b) -> GE a
k BinderD Deps a
b -> ((forall b. TermD Deps b -> b) -> GE a) -> BinderD Deps a -> Pred
forall deps a.
((forall b. TermD deps b -> b) -> GE a)
-> BinderD deps a -> PredD deps
Exists (forall b. TermD Deps b -> b) -> GE a
k (BinderD Deps a -> Pred)
-> WriterT Any Identity (BinderD Deps a) -> Writer Any Pred
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FreeVars
-> Subst -> BinderD Deps a -> WriterT Any Identity (BinderD Deps a)
forall a. FreeVars -> Subst -> Binder a -> Writer Any (Binder a)
goBinder FreeVars
fvs Subst
sub BinderD Deps a
b
      And [Pred]
ps -> [Pred] -> Pred
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([Pred] -> Pred) -> WriterT Any Identity [Pred] -> Writer Any Pred
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pred -> Writer Any Pred) -> [Pred] -> WriterT Any Identity [Pred]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (FreeVars -> Subst -> Pred -> Writer Any Pred
go FreeVars
fvs Subst
sub) [Pred]
ps
      Assert TermD Deps Bool
t
        | Bool -> Bool
not (TermD Deps Bool -> Bool
forall a. Term a -> Bool
isLit TermD Deps Bool
t)
        , Lit Bool
b <- Subst -> TermD Deps Bool -> TermD Deps Bool
forall a. Subst -> Term a -> Term a
substituteAndSimplifyTerm Subst
sub TermD Deps Bool
t -> do
            Any -> WriterT Any Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Any -> WriterT Any Identity ()) -> Any -> WriterT Any Identity ()
forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
            Pred -> Writer Any Pred
forall a. a -> WriterT Any Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pred -> Writer Any Pred) -> Pred -> Writer Any Pred
forall a b. (a -> b) -> a -> b
$ Bool -> Pred
forall p. IsPred p => p -> Pred
toPred Bool
b
        | Bool
otherwise -> Pred -> Writer Any Pred
forall a. a -> WriterT Any Identity a
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 HintD Deps a
_ TermD Deps a
t
        | Bool -> Bool
not (TermD Deps a -> Bool
forall a. Term a -> Bool
isLit TermD Deps a
t)
        , Lit {} <- Subst -> TermD Deps a -> TermD Deps a
forall a. Subst -> Term a -> Term a
substituteAndSimplifyTerm Subst
sub TermD Deps a
t -> do
            Any -> WriterT Any Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Any -> WriterT Any Identity ()) -> Any -> WriterT Any Identity ()
forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
            Pred -> Writer Any Pred
forall a. a -> WriterT Any Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pred
forall deps. PredD deps
TruePred
        | Bool
otherwise -> Pred -> Writer Any Pred
forall a. a -> WriterT Any Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pred
pred2
      DependsOn TermD Deps a
t TermD Deps b
t'
        | Bool -> Bool
not (TermD Deps a -> Bool
forall a. Term a -> Bool
isLit TermD Deps a
t)
        , Lit {} <- Subst -> TermD Deps a -> TermD Deps a
forall a. Subst -> Term a -> Term a
substituteAndSimplifyTerm Subst
sub TermD Deps a
t -> do
            Any -> WriterT Any Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Any -> WriterT Any Identity ()) -> Any -> WriterT Any Identity ()
forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
            Pred -> Writer Any Pred
forall a. a -> WriterT Any Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pred -> Writer Any Pred) -> Pred -> Writer Any Pred
forall a b. (a -> b) -> a -> b
$ Pred
forall deps. PredD deps
TruePred
        | Bool -> Bool
not (TermD Deps b -> Bool
forall a. Term a -> Bool
isLit TermD Deps b
t')
        , Lit {} <- Subst -> TermD Deps b -> TermD Deps b
forall a. Subst -> Term a -> Term a
substituteAndSimplifyTerm Subst
sub TermD Deps b
t' -> do
            Any -> WriterT Any Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Any -> WriterT Any Identity ()) -> Any -> WriterT Any Identity ()
forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
            Pred -> Writer Any Pred
forall a. a -> WriterT Any Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pred -> Writer Any Pred) -> Pred -> Writer Any Pred
forall a b. (a -> b) -> a -> b
$ Pred
forall deps. PredD deps
TruePred
        | Bool
otherwise -> Pred -> Writer Any Pred
forall a. a -> WriterT Any Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pred
pred2
      Pred
TruePred -> Pred -> Writer Any Pred
forall a. a -> WriterT Any Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pred
pred2
      FalsePred {} -> Pred -> Writer Any Pred
forall a. a -> WriterT Any Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pred
pred2
      Monitor {} -> Pred -> Writer Any Pred
forall a. a -> WriterT Any Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pred
pred2
      Explain NonEmpty [Char]
es Pred
p -> NonEmpty [Char] -> Pred -> Pred
forall deps. NonEmpty [Char] -> PredD deps -> PredD deps
Explain NonEmpty [Char]
es (Pred -> Pred) -> Writer Any Pred -> Writer Any Pred
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FreeVars -> Subst -> Pred -> Writer Any 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 Writer Any (Term a) -> (Term a, Any)
forall w a. Writer w a -> (a, w)
runWriter (Writer Any (Term a) -> (Term a, Any))
-> Writer Any (Term a) -> (Term a, Any)
forall a b. (a -> b) -> a -> b
$ Subst -> Term a -> Writer Any (Term a)
forall a. Subst -> Term a -> Writer Any (Term a)
substituteTerm' Subst
sub Term a
t of
    (Term a
t', Any Bool
b)
      | Bool
b -> Term a -> Term a
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 -> Var a -> Term a
forall deps a.
(HasSpecD deps a, Typeable a) =>
Var a -> TermD deps a
V Var a
v
  Lit a
l -> a -> Term a
forall a deps. (Typeable a, Eq a, Show a) => a -> TermD deps a
Lit a
l
  App (t dom a
f :: t bs a) ((forall a. Term a -> Term a) -> List Term dom -> List Term dom
forall {k} (f :: k -> *) (g :: k -> *) (as :: [k]).
(forall (a :: k). f a -> g a) -> List f as -> List g as
mapList Term a -> Term a
forall a. Term a -> Term a
simplifyTerm -> List Term dom
ts)
    | Just List Value dom
vs <- List Term dom -> Maybe (List Value dom)
forall (as :: [*]). List Term as -> Maybe (List Value as)
fromLits List Term dom
ts -> a -> Term a
forall a deps. (Typeable a, Eq a, Show a) => a -> TermD deps a
Lit (a -> Term a) -> a -> Term a
forall a b. (a -> b) -> a -> b
$ (forall a. Value a -> a) -> FunTy dom a -> List Value dom -> a
forall (ts :: [*]) (f :: * -> *) r.
TypeList ts =>
(forall a. f a -> a) -> FunTy ts r -> List f ts -> r
forall (f :: * -> *) r.
(forall a. f a -> a) -> FunTy dom r -> List f dom -> r
uncurryList_ Value a -> a
forall a. Value a -> a
unValue (t dom a -> FunTy dom a
forall (d :: [*]) r. t d r -> FunTy d r
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 <- t dom a
-> List Term dom
-> Evidence (AppRequiresD Deps t dom a)
-> Maybe (Term a)
forall (dom :: [*]) rng.
(TypeList dom, Typeable dom, HasSpec rng, All HasSpec dom) =>
t dom rng
-> List Term dom
-> Evidence (AppRequires t dom rng)
-> Maybe (Term rng)
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)) -> Term a -> Term a
forall a. Term a -> Term a
simplifyTerm Term a
t
    | Bool
otherwise -> t dom a -> List Term dom -> Term a
forall deps (t :: [*] -> * -> *) (dom :: [*]) a.
AppRequiresD deps t dom a =>
t dom a -> List (TermD deps) dom -> TermD deps 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 HintD Deps a
h TermD Deps a
t -> case TermD Deps a -> TermD Deps a
forall a. Term a -> Term a
simplifyTerm TermD Deps a
t of
    Lit {} -> Pred
forall deps. PredD deps
TruePred
    TermD Deps a
t' -> HintD Deps a -> TermD Deps a -> Pred
forall deps a.
(HasGenHintD deps a, Show a, Show (HintD deps a)) =>
HintD deps a -> TermD deps a -> PredD deps
GenHint HintD Deps a
h TermD Deps a
t'
  p :: Pred
p@(ElemPred Bool
bool TermD Deps a
t NonEmpty a
xs) -> case TermD Deps a -> TermD Deps a
forall a. Term a -> Term a
simplifyTerm TermD Deps a
t of
    Lit a
x -> case (a -> NonEmpty a -> Bool
forall a. Eq a => a -> NonEmpty a -> Bool
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
forall deps. PredD deps
TruePred
      (Bool
True, Bool
False) -> NonEmpty [Char] -> Pred
forall deps. NonEmpty [Char] -> PredD deps
FalsePred ([Char]
"notElemPred reduces to True" [Char] -> [[Char]] -> NonEmpty [Char]
forall a. a -> [a] -> NonEmpty a
:| [Pred -> [Char]
forall a. Show a => a -> [Char]
show Pred
p])
      (Bool
False, Bool
True) -> NonEmpty [Char] -> Pred
forall deps. NonEmpty [Char] -> PredD deps
FalsePred ([Char]
"elemPred reduces to False" [Char] -> [[Char]] -> NonEmpty [Char]
forall a. a -> [a] -> NonEmpty a
:| [Pred -> [Char]
forall a. Show a => a -> [Char]
show Pred
p])
      (Bool
False, Bool
False) -> Pred
forall deps. PredD deps
TruePred
    TermD Deps a
t' -> Bool -> TermD Deps a -> NonEmpty a -> Pred
forall deps a.
(HasSpecD deps a, Show a) =>
Bool -> TermD deps a -> NonEmpty a -> PredD deps
ElemPred Bool
bool TermD Deps a
t' NonEmpty a
xs
  Subst Var a
x TermD Deps a
t Pred
p -> Pred -> Pred
simplifyPred (Pred -> Pred) -> Pred -> Pred
forall a b. (a -> b) -> a -> b
$ Var a -> TermD Deps a -> Pred -> Pred
forall a. HasSpec a => Var a -> Term a -> Pred -> Pred
substitutePred Var a
x TermD Deps a
t Pred
p
  Assert TermD Deps Bool
t -> TermD Deps Bool -> Pred
forall deps. TermD deps Bool -> PredD deps
Assert (TermD Deps Bool -> Pred) -> TermD Deps Bool -> Pred
forall a b. (a -> b) -> a -> b
$ TermD Deps Bool -> TermD Deps Bool
forall a. Term a -> Term a
simplifyTerm TermD Deps Bool
t
  Reifies TermD Deps b
t' TermD Deps a
t a -> b
f -> case TermD Deps a -> TermD Deps a
forall a. Term a -> Term a
simplifyTerm TermD Deps a
t of
    Lit a
a ->
      -- Assert $ simplifyTerm t' ==. Lit (f a)
      Bool -> TermD Deps b -> NonEmpty b -> Pred
forall deps a.
(HasSpecD deps a, Show a) =>
Bool -> TermD deps a -> NonEmpty a -> PredD deps
ElemPred Bool
True (TermD Deps b -> TermD Deps b
forall a. Term a -> Term a
simplifyTerm TermD Deps b
t') (b -> NonEmpty b
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> b
f a
a))
    TermD Deps a
t'' -> TermD Deps b -> TermD Deps a -> (a -> b) -> Pred
forall deps a b.
(HasSpecD deps a, HasSpecD deps b, Show a, Show b) =>
TermD deps b -> TermD deps a -> (a -> b) -> PredD deps
Reifies (TermD Deps b -> TermD Deps b
forall a. Term a -> Term a
simplifyTerm TermD Deps b
t') TermD Deps a
t'' a -> b
f
  ForAll (Term t
ts :: Term t) (Binder e
b :: Binder a) -> case Term t -> Term t
forall a. Term a -> Term a
simplifyTerm Term t
ts of
    Lit t
as -> (e -> Pred) -> [e] -> Pred
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (e -> Binder e -> Pred
forall a. a -> Binder a -> Pred
`unBind` Binder e
b) (t -> [e]
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 Binder e -> Binder e
forall a. Binder a -> Binder a
simplifyBinder Binder e
b of
      Var e
_ :-> Pred
TruePred -> Pred
forall deps. PredD deps
TruePred
      Binder e
b' -> Term t -> Binder e -> Pred
forall deps t e.
(ForallableD deps t e, HasSpecD deps t, HasSpecD deps e, Show t,
 Show e) =>
TermD deps t -> BinderD deps e -> PredD deps
ForAll Term t
set' Binder e
b'
  DependsOn TermD Deps a
_ Lit {} -> Pred
forall deps. PredD deps
TruePred
  DependsOn Lit {} TermD Deps b
_ -> Pred
forall deps. PredD deps
TruePred
  DependsOn TermD Deps a
x TermD Deps b
y -> TermD Deps a -> TermD Deps b -> Pred
forall deps a b.
(HasSpecD deps a, HasSpecD deps b, Show a, Show b) =>
TermD deps a -> TermD deps b -> PredD deps
DependsOn TermD Deps a
x TermD Deps b
y
  -- Here is where we need the SumSpec instance
  Case TermD Deps (SumOver as)
t List (Weighted (BinderD Deps)) as
bs -> TermD Deps (SumOver as)
-> List (Weighted (BinderD Deps)) as -> Pred
forall (as :: [*]).
HasSpec (SumOver as) =>
Term (SumOver as) -> List (Weighted (BinderD Deps)) as -> Pred
mkCase (TermD Deps (SumOver as) -> TermD Deps (SumOver as)
forall a. Term a -> Term a
simplifyTerm TermD Deps (SumOver as)
t) ((forall a. Weighted (BinderD Deps) a -> Weighted (BinderD Deps) a)
-> List (Weighted (BinderD Deps)) as
-> List (Weighted (BinderD Deps)) as
forall {k} (f :: k -> *) (g :: k -> *) (as :: [k]).
(forall (a :: k). f a -> g a) -> List f as -> List g as
mapList ((BinderD Deps a -> BinderD Deps a)
-> Weighted (BinderD Deps) a -> Weighted (BinderD Deps) a
forall (f :: * -> *) a (g :: * -> *) b.
(f a -> g b) -> Weighted f a -> Weighted g b
mapWeighted BinderD Deps a -> BinderD Deps a
forall a. Binder a -> Binder a
simplifyBinder) List (Weighted (BinderD Deps)) as
bs)
  When TermD Deps Bool
b Pred
p -> TermD Deps Bool -> Pred -> Pred
forall p. IsPred p => TermD Deps Bool -> p -> Pred
whenTrue (TermD Deps Bool -> TermD Deps Bool
forall a. Term a -> Term a
simplifyTerm TermD Deps Bool
b) (Pred -> Pred
simplifyPred Pred
p)
  Pred
TruePred -> Pred
forall deps. PredD deps
TruePred
  FalsePred NonEmpty [Char]
es -> NonEmpty [Char] -> Pred
forall deps. NonEmpty [Char] -> PredD deps
FalsePred NonEmpty [Char]
es
  And [Pred]
ps -> [Pred] -> Pred
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([Pred] -> [Pred]
simplifyPreds [Pred]
ps)
  Let TermD Deps a
t BinderD Deps a
b -> case TermD Deps a -> TermD Deps a
forall a. Term a -> Term a
simplifyTerm TermD Deps a
t of
    t' :: TermD Deps a
t'@App {} -> TermD Deps a -> BinderD Deps a -> Pred
forall deps a. TermD deps a -> BinderD deps a -> PredD deps
Let TermD Deps a
t' (BinderD Deps a -> BinderD Deps a
forall a. Binder a -> Binder a
simplifyBinder BinderD Deps a
b)
    -- Variable or literal
    TermD Deps a
t' | Var a
x :-> Pred
p <- BinderD Deps a
b -> Pred -> Pred
simplifyPred (Pred -> Pred) -> Pred -> Pred
forall a b. (a -> b) -> a -> b
$ Var a -> TermD Deps a -> Pred -> Pred
forall a. HasSpec a => Var a -> Term a -> Pred -> Pred
substitutePred Var a
x TermD Deps a
t' Pred
p
  Exists (forall b. TermD Deps b -> b) -> GE a
k BinderD Deps a
b -> case BinderD Deps a -> BinderD Deps a
forall a. Binder a -> Binder a
simplifyBinder BinderD Deps a
b of
    Var a
_ :-> Pred
TruePred -> Pred
forall deps. PredD deps
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 <- Var a -> Pred -> Maybe (Term a)
forall a. HasSpec a => Var a -> Pred -> Maybe (Term a)
pinnedBy Var a
x Pred
p -> Pred -> Pred
simplifyPred (Pred -> Pred) -> Pred -> Pred
forall a b. (a -> b) -> a -> b
$ Var a -> Term a -> Pred -> Pred
forall a. HasSpec a => Var a -> Term a -> Pred -> Pred
substitutePred Var a
x Term a
t Pred
p
    BinderD Deps a
b' -> ((forall b. TermD Deps b -> b) -> GE a) -> BinderD Deps a -> Pred
forall deps a.
((forall b. TermD deps b -> b) -> GE a)
-> BinderD deps a -> PredD deps
Exists (forall b. TermD Deps b -> b) -> GE a
k BinderD Deps a
b'
  Monitor {} -> Pred
forall deps. PredD deps
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 (Pred -> Pred) -> Pred -> Pred
forall a b. (a -> b) -> a -> b
$ Pred -> Pred
simplifyPred Pred
p

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

simplifyBinder :: Binder a -> Binder a
simplifyBinder :: forall a. Binder a -> Binder a
simplifyBinder (Var a
x :-> Pred
p) = Var a
x Var a -> Pred -> BinderD Deps a
forall deps a.
(HasSpecD deps a, Show a) =>
Var a -> PredD deps -> BinderD deps 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 = GE (SpecificationD Deps a) -> GE (SpecificationD Deps a)
forall {deps} {a}.
GE (SpecificationD deps a) -> GE (SpecificationD deps a)
localGESpec (GE (SpecificationD Deps a) -> GE (SpecificationD Deps a))
-> GE (SpecificationD Deps a) -> GE (SpecificationD Deps a)
forall a b. (a -> b) -> a -> b
$ case Pred -> Pred
simplifyPred Pred
pred3 of
  ElemPred Bool
True TermD Deps a
t NonEmpty a
xs -> Specification a -> Ctx a a -> SpecificationD Deps a
forall v a.
HasSpec v =>
Specification a -> Ctx v a -> Specification v
propagateSpec (NonEmpty a -> Specification a
forall a deps. NonEmpty a -> SpecificationD deps a
MemberSpec NonEmpty a
xs) (Ctx a a -> SpecificationD Deps a)
-> GE (Ctx a a) -> GE (SpecificationD Deps a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Var a -> TermD Deps a -> GE (Ctx a a)
forall (m :: * -> *) v a.
(Typeable v, Show v, MonadGenError m, HasCallStack) =>
Var v -> Term a -> m (Ctx v a)
toCtx Var a
x TermD Deps a
t
  ElemPred Bool
False (Term a
t :: Term b) NonEmpty a
xs -> Specification a -> Ctx a a -> SpecificationD Deps a
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) (NonEmpty a -> [a]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty a
xs)) (Ctx a a -> SpecificationD Deps a)
-> GE (Ctx a a) -> GE (SpecificationD Deps a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Var a -> Term a -> GE (Ctx a a)
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 {} -> SpecificationD Deps a -> GE (SpecificationD Deps a)
forall a. a -> GE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SpecificationD Deps a
forall a. Monoid a => a
mempty
  GenHint (HintF Hint a
h) TermD Deps a
t -> Specification a -> Ctx a a -> SpecificationD Deps a
forall v a.
HasSpec v =>
Specification a -> Ctx v a -> Specification v
propagateSpec (Hint a -> Specification a
forall a. HasGenHint a => Hint a -> Specification a
giveHint Hint a
h) (Ctx a a -> SpecificationD Deps a)
-> GE (Ctx a a) -> GE (SpecificationD Deps a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Var a -> TermD Deps a -> GE (Ctx a a)
forall (m :: * -> *) v a.
(Typeable v, Show v, MonadGenError m, HasCallStack) =>
Var v -> Term a -> m (Ctx v a)
toCtx Var a
x TermD Deps a
t
  Subst Var a
x' TermD Deps a
t Pred
p' -> Var a -> Pred -> GE (SpecificationD Deps a)
forall a.
(HasSpec a, HasCallStack) =>
Var a -> Pred -> GE (Specification a)
computeSpec Var a
x (Var a -> TermD Deps a -> Pred -> Pred
forall a. HasSpec a => Var a -> Term a -> Pred -> Pred
substitutePred Var a
x' TermD Deps a
t Pred
p') -- NOTE: this is impossible as it should have gone away already
  Pred
TruePred -> SpecificationD Deps a -> GE (SpecificationD Deps a)
forall a. a -> GE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SpecificationD Deps a
forall a. Monoid a => a
mempty
  FalsePred NonEmpty [Char]
es -> NonEmpty [Char] -> GE (SpecificationD Deps a)
forall a. HasCallStack => NonEmpty [Char] -> GE a
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
genErrorNE NonEmpty [Char]
es
  And [Pred]
ps -> do
    SpecificationD Deps a
spec <- [SpecificationD Deps a] -> SpecificationD Deps a
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([SpecificationD Deps a] -> SpecificationD Deps a)
-> GE [SpecificationD Deps a] -> GE (SpecificationD Deps a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pred -> GE (SpecificationD Deps a))
-> [Pred] -> GE [SpecificationD Deps a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Var a -> Pred -> GE (SpecificationD Deps a)
forall a.
(HasSpec a, HasCallStack) =>
Var a -> Pred -> GE (Specification a)
computeSpecSimplified Var a
x) [Pred]
ps
    case SpecificationD Deps a
spec of
      ExplainSpec [[Char]]
es (SuspendedSpec Var a
y Pred
ps') -> SpecificationD Deps a -> GE (SpecificationD Deps a)
forall a. a -> GE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SpecificationD Deps a -> GE (SpecificationD Deps a))
-> SpecificationD Deps a -> GE (SpecificationD Deps a)
forall a b. (a -> b) -> a -> b
$ [[Char]] -> SpecificationD Deps a -> SpecificationD Deps a
forall a. [[Char]] -> Specification a -> Specification a
explainSpecOpt [[Char]]
es (Var a -> Pred -> SpecificationD Deps a
forall deps a.
HasSpecD deps a =>
Var a -> PredD deps -> SpecificationD deps a
SuspendedSpec Var a
y (Pred -> SpecificationD Deps a) -> Pred -> SpecificationD Deps a
forall a b. (a -> b) -> a -> b
$ Pred -> Pred
simplifyPred Pred
ps')
      SuspendedSpec Var a
y Pred
ps' -> SpecificationD Deps a -> GE (SpecificationD Deps a)
forall a. a -> GE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SpecificationD Deps a -> GE (SpecificationD Deps a))
-> SpecificationD Deps a -> GE (SpecificationD Deps a)
forall a b. (a -> b) -> a -> b
$ Var a -> Pred -> SpecificationD Deps a
forall deps a.
HasSpecD deps a =>
Var a -> PredD deps -> SpecificationD deps a
SuspendedSpec Var a
y (Pred -> SpecificationD Deps a) -> Pred -> SpecificationD Deps a
forall a b. (a -> b) -> a -> b
$ Pred -> Pred
simplifyPred Pred
ps'
      SpecificationD Deps a
s -> SpecificationD Deps a -> GE (SpecificationD Deps a)
forall a. a -> GE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SpecificationD Deps a
s
  Let TermD Deps a
t BinderD Deps a
b -> SpecificationD Deps a -> GE (SpecificationD Deps a)
forall a. a -> GE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SpecificationD Deps a -> GE (SpecificationD Deps a))
-> SpecificationD Deps a -> GE (SpecificationD Deps a)
forall a b. (a -> b) -> a -> b
$ Var a -> Pred -> SpecificationD Deps a
forall deps a.
HasSpecD deps a =>
Var a -> PredD deps -> SpecificationD deps a
SuspendedSpec Var a
x (TermD Deps a -> BinderD Deps a -> Pred
forall deps a. TermD deps a -> BinderD deps a -> PredD deps
Let TermD Deps a
t BinderD Deps a
b)
  Exists (forall b. TermD Deps b -> b) -> GE a
k BinderD Deps a
b -> SpecificationD Deps a -> GE (SpecificationD Deps a)
forall a. a -> GE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SpecificationD Deps a -> GE (SpecificationD Deps a))
-> SpecificationD Deps a -> GE (SpecificationD Deps a)
forall a b. (a -> b) -> a -> b
$ Var a -> Pred -> SpecificationD Deps a
forall deps a.
HasSpecD deps a =>
Var a -> PredD deps -> SpecificationD deps a
SuspendedSpec Var a
x (((forall b. TermD Deps b -> b) -> GE a) -> BinderD Deps a -> Pred
forall deps a.
((forall b. TermD deps b -> b) -> GE a)
-> BinderD deps a -> PredD deps
Exists (forall b. TermD Deps b -> b) -> GE a
k BinderD Deps a
b)
  Assert (Lit Bool
True) -> SpecificationD Deps a -> GE (SpecificationD Deps a)
forall a. a -> GE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SpecificationD Deps a
forall a. Monoid a => a
mempty
  Assert (Lit Bool
False) -> [Char] -> GE (SpecificationD Deps a)
forall (m :: * -> *) a. MonadGenError m => [Char] -> m a
genError (Pred -> [Char]
forall a. Show a => a -> [Char]
show Pred
pred3)
  Assert (Elem Term a
_ (Lit [])) -> SpecificationD Deps a -> GE (SpecificationD Deps a)
forall a. a -> GE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty [Char] -> SpecificationD Deps a
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec ([[Char]] -> NonEmpty [Char]
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList [[Char]
"Empty list in ElemPat", Pred -> [Char]
forall a. Show a => a -> [Char]
show Pred
pred3]))
  Assert (Elem Term a
t (Lit (a
y : [a]
ys))) -> Specification a -> Ctx a a -> SpecificationD Deps a
forall v a.
HasSpec v =>
Specification a -> Ctx v a -> Specification v
propagateSpec (NonEmpty a -> Specification a
forall a deps. NonEmpty a -> SpecificationD deps a
MemberSpec (a
y a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
ys)) (Ctx a a -> SpecificationD Deps a)
-> GE (Ctx a a) -> GE (SpecificationD Deps a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Var a -> Term a -> GE (Ctx a a)
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 TermD Deps Bool
t -> Specification Bool -> Ctx a Bool -> SpecificationD Deps a
forall v a.
HasSpec v =>
Specification a -> Ctx v a -> Specification v
propagateSpec (Bool -> Specification Bool
forall a. a -> Specification a
equalSpec Bool
True) (Ctx a Bool -> SpecificationD Deps a)
-> GE (Ctx a Bool) -> GE (SpecificationD Deps a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Var a -> TermD Deps Bool -> GE (Ctx a Bool)
forall (m :: * -> *) v a.
(Typeable v, Show v, MonadGenError m, HasCallStack) =>
Var v -> Term a -> m (Ctx v a)
toCtx Var a
x TermD Deps Bool
t
  ForAll (Lit t
s) BinderD Deps e
b -> [SpecificationD Deps a] -> SpecificationD Deps a
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([SpecificationD Deps a] -> SpecificationD Deps a)
-> GE [SpecificationD Deps a] -> GE (SpecificationD Deps a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (e -> GE (SpecificationD Deps a))
-> [e] -> GE [SpecificationD Deps a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\e
val -> Var a -> Pred -> GE (SpecificationD Deps a)
forall a.
(HasSpec a, HasCallStack) =>
Var a -> Pred -> GE (Specification a)
computeSpec Var a
x (Pred -> GE (SpecificationD Deps a))
-> Pred -> GE (SpecificationD Deps a)
forall a b. (a -> b) -> a -> b
$ e -> BinderD Deps e -> Pred
forall a. a -> Binder a -> Pred
unBind e
val BinderD Deps e
b) (t -> [e]
forall t e. Forallable t e => t -> [e]
forAllToList t
s)
  ForAll TermD Deps t
t BinderD Deps e
b -> do
    Specification e
bSpec <- BinderD Deps e -> GE (Specification e)
forall a. Binder a -> GE (Specification a)
computeSpecBinderSimplified BinderD Deps e
b
    Specification t -> Ctx a t -> SpecificationD Deps a
forall v a.
HasSpec v =>
Specification a -> Ctx v a -> Specification v
propagateSpec (Specification e -> Specification t
forall t e.
(Forallable t e, HasSpec t, HasSpec e) =>
Specification e -> Specification t
fromForAllSpec Specification e
bSpec) (Ctx a t -> SpecificationD Deps a)
-> GE (Ctx a t) -> GE (SpecificationD Deps a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Var a -> TermD Deps t -> GE (Ctx a t)
forall (m :: * -> *) v a.
(Typeable v, Show v, MonadGenError m, HasCallStack) =>
Var v -> Term a -> m (Ctx v a)
toCtx Var a
x TermD Deps t
t
  Case (Lit SumOver as
val) List (Weighted (BinderD Deps)) as
bs -> SumOver as
-> List (BinderD Deps) as
-> (forall {a}.
    (Typeable a, Show a) =>
    Var a -> a -> Pred -> GE (SpecificationD Deps a))
-> GE (SpecificationD Deps a)
forall (as :: [*]) r.
SumOver as
-> List (BinderD Deps) as
-> (forall a. (Typeable a, Show a) => Var a -> a -> Pred -> r)
-> r
runCaseOn SumOver as
val ((forall a. Weighted (BinderD Deps) a -> Binder a)
-> List (Weighted (BinderD Deps)) as -> List (BinderD Deps) as
forall {k} (f :: k -> *) (g :: k -> *) (as :: [k]).
(forall (a :: k). f a -> g a) -> List f as -> List g as
mapList Weighted (BinderD Deps) a -> BinderD Deps a
forall a. Weighted (BinderD Deps) a -> Binder a
forall (f :: * -> *) a. Weighted f a -> f a
thing List (Weighted (BinderD Deps)) as
bs) ((forall {a}.
  (Typeable a, Show a) =>
  Var a -> a -> Pred -> GE (SpecificationD Deps a))
 -> GE (SpecificationD Deps a))
-> (forall {a}.
    (Typeable a, Show a) =>
    Var a -> a -> Pred -> GE (SpecificationD Deps a))
-> GE (SpecificationD Deps a)
forall a b. (a -> b) -> a -> b
$ \Var a
va a
vaVal Pred
psa -> Var a -> Pred -> GE (SpecificationD Deps a)
forall a.
(HasSpec a, HasCallStack) =>
Var a -> Pred -> GE (Specification a)
computeSpec Var a
x (Env -> Pred -> Pred
substPred (Var a -> a -> Env
forall a. (Typeable a, Show a) => Var a -> a -> Env
singletonEnv Var a
va a
vaVal) Pred
psa)
  Case TermD Deps (SumOver as)
t List (Weighted (BinderD Deps)) as
branches -> do
    List (Weighted Specification) as
branchSpecs <- (forall a.
 Weighted (BinderD Deps) a -> GE (Weighted Specification a))
-> List (Weighted (BinderD Deps)) as
-> GE (List (Weighted Specification) as)
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 ((BinderD Deps a -> GE (SpecificationD Deps a))
-> Weighted (BinderD Deps) a -> GE (Weighted Specification a)
forall (m :: * -> *) (f :: * -> *) a (g :: * -> *).
Applicative m =>
(f a -> m (g a)) -> Weighted f a -> m (Weighted g a)
traverseWeighted BinderD Deps a -> GE (SpecificationD Deps a)
forall a. Binder a -> GE (Specification a)
computeSpecBinderSimplified) List (Weighted (BinderD Deps)) as
branches
    Specification (SumOver as)
-> Ctx a (SumOver as) -> SpecificationD Deps a
forall v a.
HasSpec v =>
Specification a -> Ctx v a -> Specification v
propagateSpec (Maybe [Char]
-> List (Weighted Specification) as -> Specification (SumOver as)
forall (as :: [*]).
HasSpec (SumOver as) =>
Maybe [Char]
-> List (Weighted Specification) as -> Specification (SumOver as)
caseSpec ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just (forall t. Typeable t => [Char]
forall {k} (t :: k). Typeable t => [Char]
showType @a)) List (Weighted Specification) as
branchSpecs) (Ctx a (SumOver as) -> SpecificationD Deps a)
-> GE (Ctx a (SumOver as)) -> GE (SpecificationD Deps a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Var a -> TermD Deps (SumOver as) -> GE (Ctx a (SumOver as))
forall (m :: * -> *) v a.
(Typeable v, Show v, MonadGenError m, HasCallStack) =>
Var v -> Term a -> m (Ctx v a)
toCtx Var a
x TermD Deps (SumOver as)
t
  When (Lit Bool
b) Pred
tp -> if Bool
b then Var a -> Pred -> GE (SpecificationD Deps a)
forall a.
(HasSpec a, HasCallStack) =>
Var a -> Pred -> GE (Specification a)
computeSpecSimplified Var a
x Pred
tp else SpecificationD Deps a -> GE (SpecificationD Deps a)
forall a. a -> GE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SpecificationD Deps a
forall deps a. SpecificationD deps 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 {} -> SpecificationD Deps a -> GE (SpecificationD Deps a)
forall a. a -> GE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SpecificationD Deps a -> GE (SpecificationD Deps a))
-> SpecificationD Deps a -> GE (SpecificationD Deps a)
forall a b. (a -> b) -> a -> b
$ Var a -> Pred -> SpecificationD Deps a
forall deps a.
HasSpecD deps a =>
Var a -> PredD deps -> SpecificationD deps a
SuspendedSpec Var a
x Pred
pred3
  Reifies (Lit b
a) (Lit a
val) a -> b
f
    | a -> b
f a
val b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
a -> SpecificationD Deps a -> GE (SpecificationD Deps a)
forall a. a -> GE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SpecificationD Deps a
forall deps a. SpecificationD deps a
TrueSpec
    | Bool
otherwise ->
        SpecificationD Deps a -> GE (SpecificationD Deps a)
forall a. a -> GE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SpecificationD Deps a -> GE (SpecificationD Deps a))
-> SpecificationD Deps a -> GE (SpecificationD Deps a)
forall a b. (a -> b) -> a -> b
$
          NonEmpty [Char] -> SpecificationD Deps a
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec ([[Char]] -> NonEmpty [Char]
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList [[Char]
"Value does not reify to literal: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
val [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" -/> " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ b -> [Char]
forall a. Show a => a -> [Char]
show b
a])
  Reifies TermD Deps b
t' (Lit a
val) a -> b
f ->
    Specification b -> Ctx a b -> SpecificationD Deps a
forall v a.
HasSpec v =>
Specification a -> Ctx v a -> Specification v
propagateSpec (b -> Specification b
forall a. a -> Specification a
equalSpec (a -> b
f a
val)) (Ctx a b -> SpecificationD Deps a)
-> GE (Ctx a b) -> GE (SpecificationD Deps a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Var a -> TermD Deps b -> GE (Ctx a b)
forall (m :: * -> *) v a.
(Typeable v, Show v, MonadGenError m, HasCallStack) =>
Var v -> Term a -> m (Ctx v a)
toCtx Var a
x TermD Deps b
t'
  Reifies Lit {} TermD Deps a
_ a -> b
_ ->
    NonEmpty [Char] -> GE (SpecificationD Deps a)
forall a. HasCallStack => NonEmpty [Char] -> GE a
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
fatalErrorNE (NonEmpty [Char] -> GE (SpecificationD Deps a))
-> NonEmpty [Char] -> GE (SpecificationD Deps a)
forall a b. (a -> b) -> a -> b
$ [[Char]] -> NonEmpty [Char]
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList [[Char]
"Dependency error in computeSpec: Reifies", [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Pred -> [Char]
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
    SpecificationD Deps a
s <- [[Char]]
-> GE (SpecificationD Deps a) -> GE (SpecificationD Deps a)
forall a. [[Char]] -> GE a -> GE a
pushGE (NonEmpty [Char] -> [[Char]]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty [Char]
es) (Var a -> Pred -> GE (SpecificationD Deps a)
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 SpecificationD Deps a
s of
      SuspendedSpec Var a
x2 Pred
p2 -> SpecificationD Deps a -> GE (SpecificationD Deps a)
forall a. a -> GE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SpecificationD Deps a -> GE (SpecificationD Deps a))
-> SpecificationD Deps a -> GE (SpecificationD Deps a)
forall a b. (a -> b) -> a -> b
$ Var a -> Pred -> SpecificationD Deps a
forall deps a.
HasSpecD deps a =>
Var a -> PredD deps -> SpecificationD deps a
SuspendedSpec Var a
x2 (NonEmpty [Char] -> Pred -> Pred
explanation NonEmpty [Char]
es Pred
p2)
      SpecificationD Deps a
_ -> SpecificationD Deps a -> GE (SpecificationD Deps a)
forall a. a -> GE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SpecificationD Deps a -> GE (SpecificationD Deps a))
-> SpecificationD Deps a -> GE (SpecificationD Deps a)
forall a b. (a -> b) -> a -> b
$ NonEmpty [Char] -> SpecificationD Deps a -> SpecificationD Deps a
forall a. NonEmpty [Char] -> Specification a -> Specification a
addToErrorSpec NonEmpty [Char]
es SpecificationD Deps a
s
  -- Impossible cases that should be ruled out by the dependency analysis and linearizer
  DependsOn {} ->
    NonEmpty [Char] -> GE (SpecificationD Deps a)
forall a. HasCallStack => NonEmpty [Char] -> GE a
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
fatalErrorNE (NonEmpty [Char] -> GE (SpecificationD Deps a))
-> NonEmpty [Char] -> GE (SpecificationD Deps a)
forall a b. (a -> b) -> a -> b
$
      [[Char]] -> NonEmpty [Char]
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList
        [ [Char]
"The impossible happened in computeSpec: DependsOn"
        , [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Var a -> [Char]
forall a. Show a => a -> [Char]
show Var a
x
        , Doc Any -> [Char]
forall a. Show a => a -> [Char]
show (Doc Any -> [Char]) -> Doc Any -> [Char]
forall a b. (a -> b) -> a -> b
$ Int -> Doc Any -> Doc Any
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Pred -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. Pred -> Doc ann
pretty Pred
pred3)
        ]
  Reifies {} ->
    NonEmpty [Char] -> GE (SpecificationD Deps a)
forall a. HasCallStack => NonEmpty [Char] -> GE a
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
fatalErrorNE (NonEmpty [Char] -> GE (SpecificationD Deps a))
-> NonEmpty [Char] -> GE (SpecificationD Deps a)
forall a b. (a -> b) -> a -> b
$
      [[Char]] -> NonEmpty [Char]
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList
        [[Char]
"The impossible happened in computeSpec: Reifies", [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Var a -> [Char]
forall a. Show a => a -> [Char]
show Var a
x, Doc Any -> [Char]
forall a. Show a => a -> [Char]
show (Doc Any -> [Char]) -> Doc Any -> [Char]
forall a b. (a -> b) -> a -> b
$ Int -> Doc Any -> Doc Any
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Pred -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. Pred -> Doc ann
pretty Pred
pred3)]
  where
    -- We want `genError` to turn into `ErrorSpec` and we want `FatalError` to turn into `FatalError`
    localGESpec :: GE (SpecificationD deps a) -> GE (SpecificationD deps a)
localGESpec GE (SpecificationD deps a)
ge = case GE (SpecificationD deps a)
ge of
      (GenError NonEmpty (NonEmpty [Char])
xs) -> SpecificationD deps a -> GE (SpecificationD deps a)
forall a. a -> GE a
Result (SpecificationD deps a -> GE (SpecificationD deps a))
-> SpecificationD deps a -> GE (SpecificationD deps a)
forall a b. (a -> b) -> a -> b
$ NonEmpty [Char] -> SpecificationD deps a
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec (NonEmpty (NonEmpty [Char]) -> NonEmpty [Char]
catMessageList NonEmpty (NonEmpty [Char])
xs)
      (FatalError NonEmpty (NonEmpty [Char])
es) -> NonEmpty (NonEmpty [Char]) -> GE (SpecificationD deps a)
forall a. NonEmpty (NonEmpty [Char]) -> GE a
FatalError NonEmpty (NonEmpty [Char])
es
      (Result SpecificationD deps a
v) -> SpecificationD deps a -> GE (SpecificationD deps a)
forall a. a -> GE a
Result SpecificationD deps 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 = Var a -> Pred -> GE (Specification a)
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) = Var a -> Pred -> GE (Specification a)
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) = Var a -> Pred -> GE (Specification a)
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
_)) = [Char] -> Doc a
forall a. IsString a => [Char] -> a
fromString (Int -> [Char]
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)) = [Char] -> Doc a
forall a. IsString a => [Char] -> a
fromString (Int -> [Char]
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
  | List (Weighted Specification) as -> Bool
forall (as2 :: [*]). List (Weighted Specification) as2 -> Bool
allBranchesFail List (Weighted Specification) as
ss =
      NonEmpty [Char] -> Specification (SumOver as)
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec
        ( [[Char]] -> NonEmpty [Char]
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList
            [ [Char]
"When simplifying SumSpec, all branches in a caseOn" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Maybe [Char] -> [Char]
sumType Maybe [Char]
tString [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" simplify to False."
            , Specification (SumOver as) -> [Char]
forall a. Show a => a -> [Char]
show Specification (SumOver as)
spec
            ]
        )
  | Bool
True = Specification (SumOver as)
spec
  where
    spec :: Specification (SumOver as)
spec = Maybe [Char]
-> List (Weighted Specification) as -> Specification (SumOver as)
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 = [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"The impossible happened in allBranchesFail"
    allBranchesFail (Weighted Maybe Int
_ Specification a
s :> List (Weighted Specification) as1
Nil) = Specification a -> Bool
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
_)) = Specification a -> Bool
forall a. Specification a -> Bool
isErrorLike Specification a
s Bool -> Bool -> Bool
&& List (Weighted Specification) as1 -> 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 = [Char] -> Specification (SumOver as3)
forall a. HasCallStack => [Char] -> a
error [Char]
"The impossible happened in caseSpec"
    loop Maybe [Char]
_ (Weighted Specification a
s :> List (Weighted Specification) as1
Nil) = Weighted Specification a -> Specification a
forall (f :: * -> *) a. 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) =
          (TypeSpec (SumOver as3) -> Specification (SumOver as3)
forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec (TypeSpec (SumOver as3) -> Specification (SumOver as3))
-> TypeSpec (SumOver as3) -> Specification (SumOver as3)
forall a b. (a -> b) -> a -> b
$ Maybe [Char]
-> Maybe (Int, Int)
-> Specification a
-> Specification (SumOver as1)
-> SumSpec a (SumOver as1)
forall a b.
Maybe [Char]
-> Maybe (Int, Int)
-> Specification a
-> Specification b
-> SumSpec a b
SumSpecRaw Maybe [Char]
mTypeString Maybe (Int, Int)
theWeights (Weighted Specification a -> Specification a
forall (f :: * -> *) a. Weighted f a -> f a
thing Weighted Specification a
s) (Maybe [Char]
-> List (Weighted Specification) as1 -> Specification (SumOver as1)
forall (as :: [*]).
HasSpec (SumOver as) =>
Maybe [Char]
-> List (Weighted Specification) as -> Specification (SumOver as)
loop Maybe [Char]
forall a. Maybe a
Nothing List (Weighted Specification) as1
ss1))
      where
        theWeights :: Maybe (Int, Int)
theWeights =
          case (Weighted Specification a -> Maybe Int
forall (f :: * -> *) a. Weighted f a -> Maybe Int
weight Weighted Specification a
s, List (Weighted Specification) as1 -> Maybe Int
forall (f :: * -> *) (as :: [*]). List (Weighted f) as -> Maybe Int
totalWeight List (Weighted Specification) as1
ss1) of
            (Maybe Int
Nothing, Maybe Int
Nothing) -> Maybe (Int, Int)
forall a. Maybe a
Nothing
            (Maybe Int
a, Maybe Int
b) -> (Int, Int) -> Maybe (Int, Int)
forall a. a -> Maybe a
Just (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
1 Maybe Int
a, Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (List (Weighted Specification) as1 -> Int
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 (Specification a -> Specification a
forall a. HasSpec a => Specification a -> Specification a
simplifySpec -> Specification a
spec) = case Specification a
spec of
  ExplainSpec [] Specification a
s -> Specification a -> GenT m a
forall a (m :: * -> *).
(HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecT Specification a
s
  ExplainSpec [[Char]]
es Specification a
s -> [[Char]] -> GenT m a -> GenT m a
forall (m :: * -> *) a. MonadGenError m => [[Char]] -> m a -> m a
push [[Char]]
es (Specification a -> GenT m a
forall a (m :: * -> *).
(HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecT Specification a
s)
  MemberSpec NonEmpty a
as -> [Char] -> GenT m a -> GenT m a
forall (m :: * -> *) a. MonadGenError m => [Char] -> m a -> m a
explain ([Char]
"genFromSpecT on spec" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Specification a -> [Char]
forall a. Show a => a -> [Char]
show Specification a
spec) (GenT m a -> GenT m a) -> GenT m a -> GenT m a
forall a b. (a -> b) -> a -> b
$ Gen a -> GenT m a
forall (m :: * -> *) a. Applicative m => Gen a -> GenT m a
pureGen ([a] -> Gen a
forall a. HasCallStack => [a] -> Gen a
elements (NonEmpty a -> [a]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty a
as))
  Specification a
TrueSpec -> Specification a -> GenT m a
forall a (m :: * -> *).
(HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecT (TypeSpec a -> Specification a
forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec (TypeSpec a -> Specification a) -> TypeSpec a -> Specification a
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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Var a -> Name
forall a. HasSpec a => Var a -> Name
Name Var a
x Name -> Pred -> Bool
forall a. HasVariables a => Name -> a -> Bool
`appearsIn` Pred
p -> do
        !Env
_ <- Env -> Pred -> GenT m Env
forall (m :: * -> *). MonadGenError m => Env -> Pred -> GenT m Env
genFromPreds Env
forall a. Monoid a => a
mempty Pred
p
        Specification a -> GenT m a
forall a (m :: * -> *).
(HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecT Specification a
forall deps a. SpecificationD deps a
TrueSpec
    | Bool
otherwise -> do
        Env
env <- Env -> Pred -> GenT m Env
forall (m :: * -> *). MonadGenError m => Env -> Pred -> GenT m Env
genFromPreds Env
forall a. Monoid a => a
mempty Pred
p
        Env -> Var a -> GenT m a
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 <- GenT m GenMode
forall (m :: * -> *). Applicative m => GenT m GenMode
getMode
    NonEmpty [Char] -> GenT m a -> GenT m a
forall a. HasCallStack => NonEmpty [Char] -> GenT m a -> GenT m a
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a -> m a
explainNE
      ( [[Char]] -> NonEmpty [Char]
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList
          [ [Char]
"genFromSpecT on (TypeSpec tspec cant) at type " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ forall t. Typeable t => [Char]
forall {k} (t :: k). Typeable t => [Char]
showType @a
          , [Char]
"tspec = "
          , TypeSpec a -> [Char]
forall a. Show a => a -> [Char]
show TypeSpec a
s
          , [Char]
"cant = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Doc Any -> [Char]
forall a. Show a => a -> [Char]
show ([a] -> Doc Any
forall a x. (Show a, Typeable a) => [a] -> Doc x
short [a]
cant)
          , [Char]
"with mode " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ GenMode -> [Char]
forall a. Show a => a -> [Char]
show GenMode
mode
          ]
      )
      (GenT m a -> GenT m a) -> GenT m a -> GenT m a
forall a b. (a -> b) -> a -> b
$
      -- TODO: we could consider giving `cant` as an argument to `genFromTypeSpec` if this
      -- starts giving us trouble.
      TypeSpec a -> GenT m a
forall a (m :: * -> *).
(HasSpec a, HasCallStack, MonadGenError m) =>
TypeSpec a -> GenT m a
forall (m :: * -> *).
(HasCallStack, MonadGenError m) =>
TypeSpec a -> GenT m a
genFromTypeSpec TypeSpec a
s GenT m a -> (a -> Bool) -> GenT m a
forall a (m :: * -> *).
(Typeable a, MonadGenError m) =>
GenT m a -> (a -> Bool) -> GenT m a
`suchThatT` (a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [a]
cant)
  ErrorSpec NonEmpty [Char]
e -> NonEmpty [Char] -> GenT m a
forall a. HasCallStack => NonEmpty [Char] -> GenT m a
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 <- GenT GE a -> Gen (Either (NonEmpty (NonEmpty [Char])) a)
forall a. GenT GE a -> Gen (Either (NonEmpty (NonEmpty [Char])) a)
catchGen (GenT GE a -> Gen (Either (NonEmpty (NonEmpty [Char])) a))
-> GenT GE a -> Gen (Either (NonEmpty (NonEmpty [Char])) a)
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
  (NonEmpty (NonEmpty [Char]) -> Gen a)
-> (a -> Gen a) -> Either (NonEmpty (NonEmpty [Char])) a -> Gen a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> Gen a
forall a. HasCallStack => [Char] -> a
error ([Char] -> Gen a)
-> (NonEmpty (NonEmpty [Char]) -> [Char])
-> NonEmpty (NonEmpty [Char])
-> Gen a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'\n' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:) ([Char] -> [Char])
-> (NonEmpty (NonEmpty [Char]) -> [Char])
-> NonEmpty (NonEmpty [Char])
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (NonEmpty [Char]) -> [Char]
catMessages) a -> Gen a
forall a. a -> Gen a
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 = Gen a -> QCGen -> Int -> a
forall a. Gen a -> QCGen -> Int -> a
unGen (Specification a -> Gen a
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 <- Gen (GE a) -> IO (GE a)
forall a. Gen a -> IO a
generate (Gen (GE a) -> IO (GE a)) -> Gen (GE a) -> IO (GE a)
forall a b. (a -> b) -> a -> b
$ GenT GE (GE a) -> Gen (GE a)
forall a. GenT GE a -> Gen a
genFromGenT (GenT GE (GE a) -> Gen (GE a)) -> GenT GE (GE a) -> Gen (GE a)
forall a b. (a -> b) -> a -> b
$ GenT GE a -> GenT GE (GE a)
forall (m :: * -> *) x.
MonadGenError m =>
GenT GE x -> GenT m (GE x)
inspect (Specification a -> GenT GE a
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 (NonEmpty [Char] -> [[Char]]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty [Char]
x))
      ok :: a -> IO ()
ok a
x =
        if a -> Specification a -> Bool
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 -> (NonEmpty [Char] -> IO ()) -> NonEmpty (NonEmpty [Char]) -> IO ()
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 -> (NonEmpty [Char] -> IO ()) -> NonEmpty (NonEmpty [Char]) -> IO ()
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 -> Specification a -> IO ()
forall a. Show a => a -> IO ()
print Specification a
spec IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> IO ()
forall a. Show a => a -> IO ()
print a
x IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> IO ()
ok a
x

-- ----------------------- 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 (Specification a -> Specification a
forall a. HasSpec a => Specification a -> Specification a
simplifySpec -> Specification a
spec) a
a = (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> Specification a -> Bool
forall a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification a
spec) ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ case Specification a
spec of
  ExplainSpec [[Char]]
_ Specification a
s -> Specification a -> a -> [a]
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]
_ -> TypeSpec a -> a -> [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 = TypeSpec a -> a -> [a]
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 -> GE [a] -> [a]
forall a. GE [a] -> [a]
listFromGE (GE [a] -> [a]) -> GE [a] -> [a]
forall a b. (a -> b) -> a -> b
$ do
      -- NOTE: we do this to e.g. guard against bad construction functions in Exists
      Bool
xaGood <- Env -> Pred -> GE Bool
forall (m :: * -> *). MonadGenError m => Env -> Pred -> m Bool
checkPred (Var a -> a -> Env
forall a. (Typeable a, Show a) => Var a -> a -> Env
singletonEnv Var a
x a
a) Pred
p
      Bool -> GE () -> GE ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
xaGood (GE () -> GE ()) -> GE () -> GE ()
forall a b. (a -> b) -> a -> b
$
        [Char] -> GE ()
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 (Var a -> a -> Env
forall a. (Typeable a, Show a) => Var a -> a -> Env
singletonEnv Var a
x a
a) Pred
p
      [a] -> GE [a]
forall a. a -> GE a
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' <- [Env -> Var a -> Maybe 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' a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
a
        ]
  | Bool
otherwise = [Char] -> Var a -> a -> [a]
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]
Graph Name
solverPlan :: [SolverStage]
solverDependencies :: Graph Name
solverPlan :: SolverPlan -> [SolverStage]
solverDependencies :: SolverPlan -> Graph Name
..} = Env -> [SolverStage] -> [Env]
go Env
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
stageVar :: Var a
stagePreds :: [Pred]
stageSpec :: Specification a
stageVar :: ()
stagePreds :: SolverStage -> [Pred]
stageSpec :: ()
..}) : [SolverStage]
plan) = do
      Just a
a <- [Env -> Var a -> Maybe 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' Env -> Env -> Env
forall a. Semigroup a => a -> a -> a
<> Env
fixedEnv
        | a
a' <- Specification a -> a -> [a]
forall a. HasSpec a => Specification a -> a -> [a]
shrinkWithSpec Specification a
stageSpec a
a
        , let env' :: Env
env' = Var a -> a -> 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
        [Env] -> [Env] -> [Env]
forall a. [a] -> [a] -> [a]
++ Env -> [SolverStage] -> [Env]
go (Var a -> a -> Env -> Env
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 [] = Env -> Maybe Env
forall a. a -> Maybe a
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
stageVar :: ()
stagePreds :: SolverStage -> [Pred]
stageSpec :: ()
stageVar :: Var a
stagePreds :: [Pred]
stageSpec :: Specification a
..}) : [SolverStage]
plan) =
      case Env -> Var a -> Maybe a
forall a. Typeable a => Env -> Var a -> Maybe a
lookupEnv Env
initialEnv Var a
stageVar Maybe a -> (a -> Maybe a) -> Maybe a
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Specification a -> a -> Maybe a
forall a. HasSpec a => Specification a -> a -> Maybe a
fixupWithSpec Specification a
stageSpec of
        Maybe a
Nothing -> Maybe Env
forall a. Maybe a
Nothing
        Just a
a -> Env -> [SolverStage] -> Maybe Env
fixupPlan (Var a -> a -> Env -> Env
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 (SolverStage -> SolverStage) -> SolverStage -> SolverStage
forall a b. (a -> b) -> a -> b
$ Var a -> [Pred] -> Specification a -> SolverStage
forall a.
HasSpec a =>
Var a -> [Pred] -> Specification a -> SolverStage
SolverStage Var a
y (Env -> Pred -> Pred
substPred Env
env (Pred -> Pred) -> [Pred] -> [Pred]
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) = Var a -> [Pred] -> Specification a -> SolverStage
forall a.
HasSpec a =>
Var a -> [Pred] -> Specification a -> SolverStage
SolverStage Var a
x [Pred]
ps'' (Specification a
spec Specification a -> Specification a -> Specification a
forall a. Semigroup a => a -> a -> a
<> Specification a
spec')
  where
    ([Pred]
ps', [Pred]
ps'') = (Pred -> Bool) -> [Pred] -> ([Pred], [Pred])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==) (Int -> Bool) -> (Pred -> Int) -> Pred -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Name -> Int
forall a. Set a -> Int
Set.size (Set Name -> Int) -> (Pred -> Set Name) -> Pred -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pred -> Set Name
forall a. HasVariables a => a -> Set Name
freeVarSet) [Pred]
ps
    spec' :: Specification a
spec' = GE (Specification a) -> Specification a
forall a. HasCallStack => GE (Specification a) -> Specification a
fromGESpec (GE (Specification a) -> Specification a)
-> GE (Specification a) -> Specification a
forall a b. (a -> b) -> a -> b
$ Var a -> Pred -> GE (Specification a)
forall a.
(HasSpec a, HasCallStack) =>
Var a -> Pred -> GE (Specification a)
computeSpec Var a
x ([Pred] -> Pred
forall deps. [PredD deps] -> PredD deps
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 a -> Specification a -> Bool
forall a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification a
spec = a -> Maybe a
forall a. a -> Maybe a
Just a
a
  | Bool
otherwise = case Specification a
spec of
      MemberSpec (a
x :| [a]
_) -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
      Specification a
_ -> [a] -> Maybe a
forall a. [a] -> Maybe a
listToMaybe ([a] -> Maybe a) -> [a] -> Maybe a
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> Specification a -> Bool
forall a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification a
spec) (Specification a -> a -> [a]
forall a. HasSpec a => Specification a -> a -> [a]
shrinkWithSpec Specification a
forall deps a. SpecificationD deps 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] -> Graph Name
computeHints [Pred]
ps =
  Graph Name -> Graph Name
forall node. Ord node => Graph node -> Graph node
transitiveClosure (Graph Name -> Graph Name) -> Graph Name -> Graph Name
forall a b. (a -> b) -> a -> b
$ [Graph Name] -> Graph Name
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [TermD Deps a
x TermD Deps a -> TermD Deps b -> Graph Name
forall t t'.
(HasVariables t, HasVariables t') =>
t -> t' -> Graph Name
`irreflexiveDependencyOn` TermD Deps b
y | DependsOn TermD Deps a
x TermD Deps 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 = (Pred -> [Pred]) -> [Pred] -> [Pred]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Pred -> [Pred]
saturatePred ([Pred] -> [Pred]) -> [Pred] -> [Pred]
forall a b. (a -> b) -> a -> b
$ Pred -> [Pred]
flattenPred Pred
p
      hints :: Graph Name
hints = [Pred] -> Graph Name
computeHints [Pred]
preds
      graph :: Graph Name
graph = Graph Name -> Graph Name
forall node. Ord node => Graph node -> Graph node
transitiveClosure (Graph Name -> Graph Name) -> Graph Name -> Graph Name
forall a b. (a -> b) -> a -> b
$ Graph Name
hints Graph Name -> Graph Name -> Graph Name
forall a. Semigroup a => a -> a -> a
<> Graph Name -> Graph Name -> Graph Name
respecting Graph Name
hints ((Pred -> Graph Name) -> [Pred] -> Graph Name
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Pred -> Graph Name
computeDependencies [Pred]
preds)
  [SolverStage]
plan <-
    NonEmpty [Char] -> GE [SolverStage] -> GE [SolverStage]
forall a. HasCallStack => NonEmpty [Char] -> GE a -> GE a
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a -> m a
explainNE
      ( [[Char]] -> NonEmpty [Char]
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList
          [ [Char]
"Linearizing"
          , Doc Any -> [Char]
forall a. Show a => a -> [Char]
show (Doc Any -> [Char]) -> Doc Any -> [Char]
forall a b. (a -> b) -> a -> b
$ Doc Any
"  preds: " Doc Any -> Doc Any -> Doc Any
forall a. Semigroup a => a -> a -> a
<> [Pred] -> Doc Any
forall ann. [Pred] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Pred]
preds
          , Doc Any -> [Char]
forall a. Show a => a -> [Char]
show (Doc Any -> [Char]) -> Doc Any -> [Char]
forall a b. (a -> b) -> a -> b
$ Doc Any
"  graph: " Doc Any -> Doc Any -> Doc Any
forall a. Semigroup a => a -> a -> a
<> Graph Name -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. Graph Name -> Doc ann
pretty Graph Name
graph
          ]
      )
      (GE [SolverStage] -> GE [SolverStage])
-> GE [SolverStage] -> GE [SolverStage]
forall a b. (a -> b) -> a -> b
$ [Pred] -> Graph Name -> GE [SolverStage]
forall (m :: * -> *).
MonadGenError m =>
[Pred] -> Graph Name -> m [SolverStage]
linearize [Pred]
preds Graph Name
graph
  SolverPlan -> GE SolverPlan
forall a. a -> GE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SolverPlan -> GE SolverPlan) -> SolverPlan -> GE SolverPlan
forall a b. (a -> b) -> a -> b
$ SolverPlan -> SolverPlan
backPropagation (SolverPlan -> SolverPlan) -> SolverPlan -> SolverPlan
forall a b. (a -> b) -> a -> b
$ [SolverStage] -> Graph Name -> SolverPlan
SolverPlan [SolverStage]
plan Graph Name
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 (Pred -> Set Int
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' [Pred] -> [Pred] -> [Pred]
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 TermD Deps a
t BinderD Deps a
b -> Set Int
-> BinderD Deps a
-> [Pred]
-> (HasSpec a => Var a -> [Pred] -> [Pred])
-> [Pred]
forall a.
Set Int
-> Binder a
-> [Pred]
-> (HasSpec a => Var a -> [Pred] -> [Pred])
-> [Pred]
goBinder Set Int
fvs BinderD Deps a
b [Pred]
ps (\Var a
x -> (TermD Deps Bool -> Pred
forall p. IsPred p => p -> Pred
assert (TermD Deps a
t TermD Deps a -> TermD Deps a -> TermD Deps Bool
forall a. HasSpec a => Term a -> Term a -> TermD Deps Bool
==. (Var a -> TermD Deps a
forall deps a.
(HasSpecD deps a, Typeable a) =>
Var a -> TermD deps a
V Var a
x)) Pred -> [Pred] -> [Pred]
forall a. a -> [a] -> [a]
:))
      Exists (forall b. TermD Deps b -> b) -> GE a
_ BinderD Deps a
b -> Set Int
-> BinderD Deps a
-> [Pred]
-> (HasSpec a => Var a -> [Pred] -> [Pred])
-> [Pred]
forall a.
Set Int
-> Binder a
-> [Pred]
-> (HasSpec a => Var a -> [Pred] -> [Pred])
-> [Pred]
goBinder Set Int
fvs BinderD Deps a
b [Pred]
ps (([Pred] -> [Pred]) -> Var a -> [Pred] -> [Pred]
forall a b. a -> b -> a
const [Pred] -> [Pred]
forall a. a -> a
id)
      When TermD Deps Bool
b Pred
pp -> (Pred -> Pred) -> [Pred] -> [Pred]
forall a b. (a -> b) -> [a] -> [b]
map (TermD Deps Bool -> Pred -> Pred
forall deps. TermD deps Bool -> PredD deps -> PredD deps
When TermD Deps Bool
b) (Set Int -> [Pred] -> [Pred]
go Set Int
fvs [Pred
pp]) [Pred] -> [Pred] -> [Pred]
forall a. [a] -> [a] -> [a]
++ Set Int -> [Pred] -> [Pred]
go Set Int
fvs [Pred]
ps
      Explain NonEmpty [Char]
es Pred
pp -> (Pred -> Pred) -> [Pred] -> [Pred]
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]) [Pred] -> [Pred] -> [Pred]
forall a. [a] -> [a] -> [a]
++ Set Int -> [Pred] -> [Pred]
go Set Int
fvs [Pred]
ps
      Pred
_ -> Pred
p Pred -> [Pred] -> [Pred]
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 = Var a -> [Pred] -> [Pred]
HasSpec a => Var a -> [Pred] -> [Pred]
k Var a
x' ([Pred] -> [Pred]) -> [Pred] -> [Pred]
forall a b. (a -> b) -> a -> b
$ Set Int -> [Pred] -> [Pred]
go (Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
Set.insert (Var a -> Int
forall a. Var a -> Int
nameOf Var a
x') Set Int
fvs) (Pred
p' Pred -> [Pred] -> [Pred]
forall a. a -> [a] -> [a]
: [Pred]
ps)
      where
        (Var a
x', Pred
p') = Var a -> Pred -> Set Int -> (Var a, Pred)
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] -> Graph Name -> m [SolverStage]
linearize [Pred]
preds Graph Name
graph = do
  [Name]
sorted <- case Graph Name -> Either [Name] [Name]
forall node. Ord node => Graph node -> Either [node] [node]
topsort Graph Name
graph of
    Left [Name]
cycle ->
      [Char] -> m [Name]
forall (m :: * -> *) a. MonadGenError m => [Char] -> m a
fatalError
        ( Doc Any -> [Char]
forall a. Show a => a -> [Char]
show (Doc Any -> [Char]) -> Doc Any -> [Char]
forall a b. (a -> b) -> a -> b
$
            Doc Any
"linearize: Dependency cycle in graph:"
              Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
/> [Doc Any] -> Doc Any
forall ann. [Doc ann] -> Doc ann
vsep'
                [ Doc Any
"cycle:" Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
/> [Name] -> Doc Any
forall ann. [Name] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Name]
cycle
                , Doc Any
"graph:" Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
/> Graph Name -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. Graph Name -> Doc ann
pretty Graph Name
graph
                ]
        )
    Right [Name]
sorted -> [Name] -> m [Name]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Name]
sorted
  [Name] -> [(Set Name, Pred)] -> m [SolverStage]
go [Name]
sorted [(Pred -> Set Name
forall a. HasVariables a => a -> Set Name
freeVarSet Pred
ps, Pred
ps) | Pred
ps <- (Pred -> Bool) -> [Pred] -> [Pred]
forall a. (a -> Bool) -> [a] -> [a]
filter Pred -> Bool
forall {deps}. PredD deps -> Bool
isRelevantPred [Pred]
preds]
  where
    isRelevantPred :: PredD deps -> Bool
isRelevantPred PredD deps
TruePred = Bool
False
    isRelevantPred DependsOn {} = Bool
False
    isRelevantPred (Assert (Lit Bool
True)) = Bool
False
    isRelevantPred PredD deps
_ = Bool
True

    go :: [Name] -> [(Set Name, Pred)] -> m [SolverStage]
go [] [] = [SolverStage] -> m [SolverStage]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    go [] [(Set Name, Pred)]
ps
      | Set Name -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Set Name -> Bool) -> Set Name -> Bool
forall a b. (a -> b) -> a -> b
$ ((Set Name, Pred) -> Set Name) -> [(Set Name, Pred)] -> Set Name
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Set Name, Pred) -> Set Name
forall a b. (a, b) -> a
fst [(Set Name, Pred)]
ps =
          case NonEmpty [Char] -> Env -> [Pred] -> Maybe (NonEmpty [Char])
checkPredsE ([Char] -> NonEmpty [Char]
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"Linearizing fails") Env
forall a. Monoid a => a
mempty (((Set Name, Pred) -> Pred) -> [(Set Name, Pred)] -> [Pred]
forall a b. (a -> b) -> [a] -> [b]
map (Set Name, Pred) -> Pred
forall a b. (a, b) -> b
snd [(Set Name, Pred)]
ps) of
            Maybe (NonEmpty [Char])
Nothing -> [SolverStage] -> m [SolverStage]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
            Just NonEmpty [Char]
msgs -> NonEmpty [Char] -> m [SolverStage]
forall a. HasCallStack => NonEmpty [Char] -> m a
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
genErrorNE NonEmpty [Char]
msgs
      | Bool
otherwise =
          NonEmpty [Char] -> m [SolverStage]
forall a. HasCallStack => NonEmpty [Char] -> m a
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
fatalErrorNE (NonEmpty [Char] -> m [SolverStage])
-> NonEmpty [Char] -> m [SolverStage]
forall a b. (a -> b) -> a -> b
$
            [[Char]] -> NonEmpty [Char]
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList
              [ [Char]
"Dependency error in `linearize`: "
              , Doc Any -> [Char]
forall a. Show a => a -> [Char]
show (Doc Any -> [Char]) -> Doc Any -> [Char]
forall a b. (a -> b) -> a -> b
$ Int -> Doc Any -> Doc Any
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc Any -> Doc Any) -> Doc Any -> Doc Any
forall a b. (a -> b) -> a -> b
$ Doc Any
"graph: " Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
/> Graph Name -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. Graph Name -> Doc ann
pretty Graph Name
graph
              , Doc Any -> [Char]
forall a. Show a => a -> [Char]
show (Doc Any -> [Char]) -> Doc Any -> [Char]
forall a b. (a -> b) -> a -> b
$
                  Int -> Doc Any -> Doc Any
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc Any -> Doc Any) -> Doc Any -> Doc Any
forall a b. (a -> b) -> a -> b
$
                    Doc Any
"the following left-over constraints are not defining constraints for a unique variable:"
                      Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
/> [Doc Any] -> Doc Any
forall ann. [Doc ann] -> Doc ann
vsep' (((Set Name, Pred) -> Doc Any) -> [(Set Name, Pred)] -> [Doc Any]
forall a b. (a -> b) -> [a] -> [b]
map (Pred -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. Pred -> Doc ann
pretty (Pred -> Doc Any)
-> ((Set Name, Pred) -> Pred) -> (Set Name, Pred) -> Doc Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set Name, Pred) -> Pred
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) = ((Set Name, Pred) -> Bool)
-> [(Set Name, Pred)] -> ([(Set Name, Pred)], [(Set Name, Pred)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Name -> Set Name -> Bool
isLastVariable Name
n (Set Name -> Bool)
-> ((Set Name, Pred) -> Set Name) -> (Set Name, Pred) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set Name, Pred) -> Set Name
forall a b. (a, b) -> a
fst) [(Set Name, Pred)]
ps
      (SolverStage -> SolverStage
normalizeSolverStage (Var a -> [Pred] -> Specification a -> SolverStage
forall a.
HasSpec a =>
Var a -> [Pred] -> Specification a -> SolverStage
SolverStage Var a
x (((Set Name, Pred) -> Pred) -> [(Set Name, Pred)] -> [Pred]
forall a b. (a -> b) -> [a] -> [b]
map (Set Name, Pred) -> Pred
forall a b. (a, b) -> b
snd [(Set Name, Pred)]
nps) Specification a
forall a. Monoid a => a
mempty) SolverStage -> [SolverStage] -> [SolverStage]
forall a. a -> [a] -> [a]
:) ([SolverStage] -> [SolverStage])
-> m [SolverStage] -> m [SolverStage]
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 Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
set Bool -> Bool -> Bool
&& Name -> Set Name -> Graph Name -> Bool
solvableFrom Name
n (Name -> Set Name -> Set Name
forall a. Ord a => a -> Set a -> Set a
Set.delete Name
n Set Name
set) Graph Name
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 Var a -> Var a -> Maybe (a :~: a)
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 ->
        Var a -> [Pred] -> Specification a -> SolverStage
forall a.
HasSpec a =>
Var a -> [Pred] -> Specification a -> SolverStage
SolverStage
          Var a
y
          ([Pred]
ps [Pred] -> [Pred] -> [Pred]
forall a. [a] -> [a] -> [a]
++ [Pred]
ps')
          ( NonEmpty [Char] -> Specification a -> Specification a
forall a. NonEmpty [Char] -> Specification a -> Specification a
addToErrorSpec
              ( [[Char]] -> NonEmpty [Char]
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList
                  ( [ [Char]
"Solving var " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Var a -> [Char]
forall a. Show a => a -> [Char]
show Var a
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" fails."
                    , [Char]
"Merging the Specs"
                    , [Char]
"   1. " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Specification a -> [Char]
forall a. Show a => a -> [Char]
show Specification a
spec
                    , [Char]
"   2. " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Specification a -> [Char]
forall a. Show a => a -> [Char]
show Specification a
spec'
                    ]
                  )
              )
              (Specification a
spec Specification a -> Specification a -> Specification a
forall a. Semigroup a => a -> a -> a
<> Specification 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 (Specification a -> Specification a
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 =
      [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep'
        [ Doc ann
"Simplified spec:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
/> Specification a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Specification a -> Doc ann
pretty Specification a
spec
        , SolverPlan -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. SolverPlan -> Doc ann
pretty SolverPlan
plan
        ]
  | Bool
otherwise = Doc ann
"Simplfied spec:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
/> Specification a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Specification a -> Doc ann
pretty Specification a
spec

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

isEmptyPlan :: SolverPlan -> Bool
isEmptyPlan :: SolverPlan -> Bool
isEmptyPlan (SolverPlan [SolverStage]
plan Graph Name
_) = [SolverStage] -> Bool
forall a. [a] -> Bool
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 [] Graph Name
_) = (Env, SolverPlan) -> GenT m (Env, SolverPlan)
forall a. a -> GenT m a
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) Graph Name
gr) = do
  (Specification a
spec', [Specification a]
specs) <- GE (Specification a, [Specification a])
-> GenT m (Specification a, [Specification a])
forall (m :: * -> *) r. MonadGenError m => GE r -> m r
runGE
    (GE (Specification a, [Specification a])
 -> GenT m (Specification a, [Specification a]))
-> GE (Specification a, [Specification a])
-> GenT m (Specification a, [Specification a])
forall a b. (a -> b) -> a -> b
$ [Char]
-> GE (Specification a, [Specification a])
-> GE (Specification a, [Specification a])
forall (m :: * -> *) a. MonadGenError m => [Char] -> m a -> m a
explain
      ( Doc Any -> [Char]
forall a. Show a => a -> [Char]
show
          ( Doc Any
"Computing specs for variable "
              Doc Any -> Doc Any -> Doc Any
forall a. Semigroup a => a -> a -> a
<> Var a -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. Var a -> Doc ann
pretty Var a
x
                Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
/> [Doc Any] -> Doc Any
forall ann. [Doc ann] -> Doc ann
vsep' ((Pred -> Doc Any) -> [Pred] -> [Doc Any]
forall a b. (a -> b) -> [a] -> [b]
map Pred -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. Pred -> Doc ann
pretty [Pred]
ps)
          )
      )
    (GE (Specification a, [Specification a])
 -> GE (Specification a, [Specification a]))
-> GE (Specification a, [Specification a])
-> GE (Specification a, [Specification a])
forall a b. (a -> b) -> a -> b
$ do
      [Specification a]
ispecs <- (Pred -> GE (Specification a)) -> [Pred] -> GE [Specification a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Var a -> Pred -> GE (Specification a)
forall a.
(HasSpec a, HasCallStack) =>
Var a -> Pred -> GE (Specification a)
computeSpec Var a
x) [Pred]
ps
      (Specification a, [Specification a])
-> GE (Specification a, [Specification a])
forall a. a -> GE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Specification a, [Specification a])
 -> GE (Specification a, [Specification a]))
-> (Specification a, [Specification a])
-> GE (Specification a, [Specification a])
forall a b. (a -> b) -> a -> b
$ ([Specification a] -> Specification a
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [Specification a]
ispecs, [Specification a]
ispecs)
  a
val <-
    Specification a -> GenT m a
forall a (m :: * -> *).
(HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecT
      ( NonEmpty [Char] -> Specification a -> Specification a
forall a. NonEmpty [Char] -> Specification a -> Specification a
addToErrorSpec
          ( [[Char]] -> NonEmpty [Char]
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList
              ( ( [Char]
"\nStepPlan for variable: "
                    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Var a -> [Char]
forall a. Show a => a -> [Char]
show Var a
x
                    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" fails to produce Specification, probably overconstrained."
                    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"PS = "
                    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unlines ((Pred -> [Char]) -> [Pred] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Pred -> [Char]
forall a. Show a => a -> [Char]
show [Pred]
ps)
                )
                  [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: ([Char]
"Original spec " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Specification a -> [Char]
forall a. Show a => a -> [Char]
show Specification a
spec)
                  [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char]
"Predicates"
                  [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: (Pred -> Specification a -> [Char])
-> [Pred] -> [Specification a] -> [[Char]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
                    (\Pred
pred Specification a
specx -> [Char]
"  pred " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Pred -> [Char]
forall a. Show a => a -> [Char]
show Pred
pred [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" -> " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Specification a -> [Char]
forall a. Show a => a -> [Char]
show Specification a
specx)
                    [Pred]
ps
                    [Specification a]
specs
              )
          )
          (Specification a
spec Specification a -> Specification a -> Specification a
forall a. Semigroup a => a -> a -> a
<> Specification a
spec')
      )
  let env1 :: Env
env1 = Var a -> a -> Env -> Env
forall a. (Typeable a, Show a) => Var a -> a -> Env -> Env
extendEnv Var a
x a
val Env
env
  (Env, SolverPlan) -> GenT m (Env, SolverPlan)
forall a. a -> GenT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Env
env1, SolverPlan -> SolverPlan
backPropagation (SolverPlan -> SolverPlan) -> SolverPlan -> SolverPlan
forall a b. (a -> b) -> a -> b
$ [SolverStage] -> Graph Name -> SolverPlan
SolverPlan (Env -> SolverStage -> SolverStage
substStage Env
env1 (SolverStage -> SolverStage) -> [SolverStage] -> [SolverStage]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SolverStage]
pl) (Name -> Graph Name -> Graph Name
forall node. Ord node => node -> Graph node -> Graph node
deleteNode (Var a -> Name
forall a. HasSpec a => Var a -> Name
Name Var a
x) Graph Name
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 (Pred -> Pred) -> (Pred -> Pred) -> Pred -> Pred
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 <- GE SolverPlan -> GenT m SolverPlan
forall (m :: * -> *) r. MonadGenError m => GE r -> m r
runGE (GE SolverPlan -> GenT m SolverPlan)
-> GE SolverPlan -> GenT m SolverPlan
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 = Env -> GenT m Env
forall a. a -> GenT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Env
env
    go Env
env SolverPlan
plan = do
      (Env
env', SolverPlan
plan') <-
        [Char] -> GenT m (Env, SolverPlan) -> GenT m (Env, SolverPlan)
forall (m :: * -> *) a. MonadGenError m => [Char] -> m a -> m a
explain (Doc Any -> [Char]
forall a. Show a => a -> [Char]
show (Doc Any -> [Char]) -> Doc Any -> [Char]
forall a b. (a -> b) -> a -> b
$ Doc Any
"Stepping the plan:" Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
/> [Doc Any] -> Doc Any
forall ann. [Doc ann] -> Doc ann
vsep [SolverPlan -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. SolverPlan -> Doc ann
pretty SolverPlan
plan, Env -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. Env -> Doc ann
pretty Env
env]) (GenT m (Env, SolverPlan) -> GenT m (Env, SolverPlan))
-> GenT m (Env, SolverPlan) -> GenT m (Env, SolverPlan)
forall a b. (a -> b) -> a -> b
$ Env -> SolverPlan -> GenT m (Env, SolverPlan)
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 Graph Name
graph) = [SolverStage] -> Graph Name -> SolverPlan
SolverPlan ([SolverStage] -> [SolverStage] -> [SolverStage]
go [] ([SolverStage] -> [SolverStage]
forall a. [a] -> [a]
reverse [SolverStage]
initplan)) Graph Name
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 SolverStage -> [SolverStage] -> [SolverStage]
forall a. a -> [a] -> [a]
: [SolverStage]
acc) [SolverStage]
plan'
      where
        newStages :: [SolverStage]
newStages = (Pred -> [SolverStage]) -> [Pred] -> [SolverStage]
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' = (SolverStage -> [SolverStage] -> [SolverStage])
-> [SolverStage] -> [SolverStage] -> [SolverStage]
forall a b. (a -> b -> b) -> b -> [a] -> b
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') TermD Deps a
t)) =
          Specification a -> Var a -> TermD Deps a -> [SolverStage]
forall b.
HasSpec b =>
Specification a -> Var b -> Term b -> [SolverStage]
termVarEqCases Specification a
specl Var a
x' TermD Deps a
t
        newStage Specification a
specr (Assert (Equal Term a
t (V Var a
x'))) =
          Specification a -> Var a -> Term a -> [SolverStage]
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
          | Name -> Set Name
forall a. a -> Set a
Set.singleton (Var a -> Name
forall a. HasSpec a => Var a -> Name
Name Var a
x) Set Name -> Set Name -> Bool
forall a. Eq a => a -> a -> Bool
== Term b -> Set Name
forall a. HasVariables a => a -> Set Name
freeVarSet Term b
t =
              [Var b -> [Pred] -> Specification b -> SolverStage
forall a.
HasSpec a =>
Var a -> [Pred] -> Specification a -> SolverStage
SolverStage Var b
x' [] (Specification b -> SolverStage) -> Specification b -> SolverStage
forall a b. (a -> b) -> a -> b
$ NonEmpty b -> Specification b
forall a deps. NonEmpty a -> SpecificationD deps a
MemberSpec (NonEmpty b -> NonEmpty b
forall a. Eq a => NonEmpty a -> NonEmpty a
NE.nub ((a -> b) -> NonEmpty a -> NonEmpty b
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
v -> GE b -> b
forall a. GE a -> a
errorGE (GE b -> b) -> GE b -> b
forall a b. (a -> b) -> a -> b
$ Env -> Term b -> GE b
forall (m :: * -> *) deps a.
MonadGenError m =>
Env -> TermD deps a -> m a
runTerm (Var a -> a -> Env
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 <- Var a -> Var b -> Maybe (a :~: b)
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] <- Set Name -> [Name]
forall a. Set a -> [a]
Set.toList (Set Name -> [Name]) -> Set Name -> [Name]
forall a b. (a -> b) -> a -> b
$ Term b -> Set Name
forall a. HasVariables a => a -> Set Name
freeVarSet Term b
t
          , Result Ctx a b
ctx <- Var a -> Term b -> GE (Ctx a b)
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 =
              [Var a -> [Pred] -> Specification a -> SolverStage
forall a.
HasSpec a =>
Var a -> [Pred] -> Specification a -> SolverStage
SolverStage Var a
y [] (Specification a -> Ctx a a -> Specification a
forall v a.
HasSpec v =>
Specification a -> Ctx v a -> Specification v
propagateSpec Specification a
specx Ctx a a
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 SpecificationD Deps a
s) = [[Char]] -> Specification b -> Specification b
forall a. [[Char]] -> Specification a -> Specification a
explainSpecOpt [[Char]]
es (t '[a] b -> SpecificationD Deps a -> Specification b
forall (t :: [*] -> * -> *) a b.
AppRequires t '[a] b =>
t '[a] b -> Specification a -> Specification b
mapSpec t '[a] b
f SpecificationD Deps a
s)
mapSpec t '[a] b
f SpecificationD Deps a
TrueSpec = t '[a] b -> TypeSpec a -> Specification b
forall a b.
(HasSpec a, HasSpec b) =>
t '[a] b -> TypeSpec a -> Specification b
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) = NonEmpty [Char] -> Specification b
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec NonEmpty [Char]
err
mapSpec t '[a] b
f (MemberSpec NonEmpty a
as) = NonEmpty b -> Specification b
forall a deps. NonEmpty a -> SpecificationD deps a
MemberSpec (NonEmpty b -> Specification b) -> NonEmpty b -> Specification b
forall a b. (a -> b) -> a -> b
$ NonEmpty b -> NonEmpty b
forall a. Eq a => NonEmpty a -> NonEmpty a
NE.nub (NonEmpty b -> NonEmpty b) -> NonEmpty b -> NonEmpty b
forall a b. (a -> b) -> a -> b
$ (a -> b) -> NonEmpty a -> NonEmpty b
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (t '[a] b -> FunTy '[a] b
forall (d :: [*]) r. t d r -> FunTy d r
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) =
  (Term b -> Pred) -> Specification b
forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained ((Term b -> Pred) -> Specification b)
-> (Term b -> Pred) -> Specification b
forall a b. (a -> b) -> a -> b
$ \Term b
x' ->
    ((forall b. TermD Deps b -> b) -> GE a) -> BinderD Deps a -> Pred
forall deps a.
((forall b. TermD deps b -> b) -> GE a)
-> BinderD deps a -> PredD deps
Exists (\forall b. TermD Deps b -> b
_ -> [Char] -> GE a
forall (m :: * -> *) a. MonadGenError m => [Char] -> m a
fatalError [Char]
"mapSpec") (Var a
x Var a -> Pred -> BinderD Deps a
forall deps a.
(HasSpecD deps a, Show a) =>
Var a -> PredD deps -> BinderD deps a
:-> [Pred] -> Pred
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [TermD Deps Bool -> Pred
forall deps. TermD deps Bool -> PredD deps
Assert (TermD Deps Bool -> Pred) -> TermD Deps Bool -> Pred
forall a b. (a -> b) -> a -> b
$ (Term b
x' Term b -> Term b -> TermD Deps Bool
forall a. HasSpec a => Term a -> Term a -> TermD Deps Bool
==. t '[a] b -> FunTy (MapList Term '[a]) (Term b)
forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm t '[a] b
f (Var a -> TermD Deps a
forall deps a.
(HasSpecD deps a, Typeable a) =>
Var a -> TermD deps a
V Var a
x)), Pred
p])
mapSpec t '[a] b
f (TypeSpec TypeSpec a
ts [a]
cant) = t '[a] b -> TypeSpec a -> Specification b
forall a b.
(HasSpec a, HasSpec b) =>
t '[a] b -> TypeSpec a -> Specification b
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 Specification b -> Specification b -> Specification b
forall a. Semigroup a => a -> a -> a
<> [b] -> Specification b
forall a (f :: * -> *).
(HasSpec a, Foldable f) =>
f a -> Specification a
notMemberSpec ((a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (t '[a] b -> FunTy '[a] b
forall (d :: [*]) r. t d r -> FunTy d r
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 Pred -> [Pred] -> [Pred]
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) -> t dom Bool -> List Term dom -> [Pred]
forall (dom :: [*]). t dom Bool -> List Term dom -> [Pred]
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 :: Term (Prod a b) -> Maybe (Term a, Term b)
pairView :: forall a b. Term (Prod a b) -> Maybe (Term a, Term b)
pairView (App (t dom (Prod a b) -> Maybe (ProdW dom (Prod a b))
forall {k1} {k2} (t :: k1 -> k2 -> *) (t' :: k1 -> k2 -> *)
       (d :: k1) (r :: k2).
(Typeable t, Typeable d, Typeable r, Typeable t') =>
t d r -> Maybe (t' d r)
getWitness -> Just ProdW dom (Prod a b)
ProdW) (TermD Deps a
x :> TermD Deps a
y :> List Term as1
Nil)) = (Term a, Term b) -> Maybe (Term a, Term b)
forall a. a -> Maybe a
Just (Term a
TermD Deps a
x, Term b
TermD Deps a
y)
pairView TermD Deps (Prod a b)
_ = Maybe (Term a, Term 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) = NonEmpty [Char] -> SpecificationD Deps (Prod a b)
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec (NonEmpty [Char]
es NonEmpty [Char] -> NonEmpty [Char] -> NonEmpty [Char]
forall a. Semigroup a => a -> a -> a
<> NonEmpty [Char]
fs)
cartesian (ErrorSpec NonEmpty [Char]
es) SpecificationD Deps b
_ = NonEmpty [Char] -> SpecificationD Deps (Prod a b)
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec ([Char] -> NonEmpty [Char] -> NonEmpty [Char]
forall a. a -> NonEmpty a -> NonEmpty a
NE.cons [Char]
"cartesian left" NonEmpty [Char]
es)
cartesian SpecificationD Deps a
_ (ErrorSpec NonEmpty [Char]
es) = NonEmpty [Char] -> SpecificationD Deps (Prod a b)
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec ([Char] -> NonEmpty [Char] -> NonEmpty [Char]
forall a. a -> NonEmpty a -> NonEmpty a
NE.cons [Char]
"cartesian right" NonEmpty [Char]
es)
cartesian SpecificationD Deps a
s SpecificationD Deps b
s' = TypeSpec (Prod a b) -> SpecificationD Deps (Prod a b)
forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec (TypeSpec (Prod a b) -> SpecificationD Deps (Prod a b))
-> TypeSpec (Prod a b) -> SpecificationD Deps (Prod a b)
forall a b. (a -> b) -> a -> b
$ SpecificationD Deps a -> SpecificationD Deps b -> PairSpec a b
forall a b. Specification a -> Specification b -> PairSpec a b
Cartesian SpecificationD Deps a
s SpecificationD Deps 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 = Specification a -> Specification b -> PairSpec a b
forall a b. Specification a -> Specification b -> PairSpec a b
Cartesian (Specification a -> Specification b -> PairSpec a b)
-> Gen (Specification a) -> Gen (Specification b -> PairSpec a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Specification a)
forall a. Arbitrary a => Gen a
arbitrary Gen (Specification b -> PairSpec a b)
-> Gen (Specification b) -> Gen (PairSpec a b)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (Specification b)
forall a. Arbitrary a => Gen a
arbitrary
  shrink :: PairSpec a b -> [PairSpec a b]
shrink (Cartesian Specification a
a Specification b
b) = (Specification a -> Specification b -> PairSpec a b)
-> (Specification a, Specification b) -> PairSpec a b
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Specification a -> Specification b -> PairSpec a b
forall a b. Specification a -> Specification b -> PairSpec a b
Cartesian ((Specification a, Specification b) -> PairSpec a b)
-> [(Specification a, Specification b)] -> [PairSpec a b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Specification a, Specification b)
-> [(Specification a, Specification 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 = Specification a -> Specification b -> PairSpec a b
forall a b. Specification a -> Specification b -> PairSpec a b
Cartesian Specification a
forall a. Monoid a => a
mempty Specification b
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') = Specification a -> Specification b -> Specification (Prod a b)
forall a b.
(HasSpec a, HasSpec b) =>
Specification a -> Specification b -> Specification (Prod a b)
cartesian (Specification a
a Specification a -> Specification a -> Specification a
forall a. Semigroup a => a -> a -> a
<> Specification a
a') (Specification b
b Specification b -> Specification b -> Specification 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) = a -> Specification a -> Bool
forall a. HasSpec a => a -> Specification a -> Bool
conformsToSpec a
a Specification a
sa Bool -> Bool -> Bool
&& b -> Specification b -> 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) = a -> b -> Prod a b
forall a b. a -> b -> Prod a b
Prod (a -> b -> Prod a b) -> GenT m a -> GenT m (b -> Prod a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Specification a -> GenT m a
forall a (m :: * -> *).
(HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecT Specification a
sa GenT m (b -> Prod a b) -> GenT m b -> GenT m (Prod a b)
forall a b. GenT m (a -> b) -> GenT m a -> GenT m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Specification b -> GenT m 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) =
    [a -> b -> Prod a b
forall a b. a -> b -> Prod a b
Prod a
a' b
b | a
a' <- Specification a -> a -> [a]
forall a. HasSpec a => Specification a -> a -> [a]
shrinkWithSpec Specification a
sa a
a]
      [Prod a b] -> [Prod a b] -> [Prod a b]
forall a. [a] -> [a] -> [a]
++ [a -> b -> Prod a b
forall a b. a -> b -> Prod a b
Prod a
a b
b' | b
b' <- Specification 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) =
    Term a -> Specification a -> Pred
forall a. HasSpec a => Term a -> Specification a -> Pred
satisfies (Term (Prod a b) -> Term a
forall a b. (HasSpec a, HasSpec b) => Term (Prod a b) -> Term a
prodFst_ Term (Prod a b)
x) Specification a
sf
      Pred -> Pred -> Pred
forall a. Semigroup a => a -> a -> a
<> Term b -> Specification b -> Pred
forall a. HasSpec a => Term a -> Specification a -> Pred
satisfies (Term (Prod a b) -> Term b
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) = (Specification a -> Specification Integer
forall a.
(Number Integer, HasSpec a) =>
Specification a -> Specification Integer
cardinality Specification a
x) Specification Integer
-> Specification Integer -> Specification Integer
forall a. Num a => a -> a -> a
+ (Specification b -> Specification Integer
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 (Specification a -> Bool
forall a. Specification a -> Bool
isErrorLike Specification a
x, Specification b -> Bool
forall a. Specification a -> Bool
isErrorLike Specification b
y) of
      (Bool
False, Bool
False) -> Maybe (NonEmpty [Char])
forall a. Maybe a
Nothing
      (Bool
True, Bool
False) -> NonEmpty [Char] -> Maybe (NonEmpty [Char])
forall a. a -> Maybe a
Just (NonEmpty [Char] -> Maybe (NonEmpty [Char]))
-> NonEmpty [Char] -> Maybe (NonEmpty [Char])
forall a b. (a -> b) -> a -> b
$ Specification a -> NonEmpty [Char]
forall a. Specification a -> NonEmpty [Char]
errorLikeMessage Specification a
x
      (Bool
False, Bool
True) -> NonEmpty [Char] -> Maybe (NonEmpty [Char])
forall a. a -> Maybe a
Just (NonEmpty [Char] -> Maybe (NonEmpty [Char]))
-> NonEmpty [Char] -> Maybe (NonEmpty [Char])
forall a b. (a -> b) -> a -> b
$ Specification b -> NonEmpty [Char]
forall a. Specification a -> NonEmpty [Char]
errorLikeMessage Specification b
y
      (Bool
True, Bool
True) -> NonEmpty [Char] -> Maybe (NonEmpty [Char])
forall a. a -> Maybe a
Just (NonEmpty [Char] -> Maybe (NonEmpty [Char]))
-> NonEmpty [Char] -> Maybe (NonEmpty [Char])
forall a b. (a -> b) -> a -> b
$ (Specification a -> NonEmpty [Char]
forall a. Specification a -> NonEmpty [Char]
errorLikeMessage Specification a
x NonEmpty [Char] -> NonEmpty [Char] -> NonEmpty [Char]
forall a. Semigroup a => a -> a -> a
<> Specification b -> NonEmpty [Char]
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) -> [Char] -> [Doc a] -> BinaryShow
forall a. [Char] -> [Doc a] -> BinaryShow
BinaryShow [Char]
"Cartesian" (Doc a
"," Doc a -> Doc a -> Doc a
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Specification a -> Doc a
forall a ann. Show a => a -> Doc ann
viaShow Specification a
left Doc a -> [Doc a] -> [Doc a]
forall a. a -> [a] -> [a]
: [Doc a]
ps)
      (BinaryShow [Char]
"SumSpec" [Doc a]
ps) -> [Char] -> [Doc a] -> BinaryShow
forall a. [Char] -> [Doc a] -> BinaryShow
BinaryShow [Char]
"Cartesian" (Doc a
"," Doc a -> Doc a -> Doc a
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Specification a -> Doc a
forall a ann. Show a => a -> Doc ann
viaShow Specification a
left Doc a -> [Doc a] -> [Doc a]
forall a. a -> [a] -> [a]
: [Doc a
"SumSpec" Doc a -> Doc a -> Doc a
forall ann. Doc ann -> Doc ann -> Doc ann
/> [Doc a] -> Doc a
forall ann. [Doc ann] -> Doc ann
vsep [Doc a]
ps])
      BinaryShow
_ -> [Char] -> [Doc Any] -> BinaryShow
forall a. [Char] -> [Doc a] -> BinaryShow
BinaryShow [Char]
"Cartesian" [Doc Any
"," Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Specification a -> Doc Any
forall a ann. Show a => a -> Doc ann
viaShow Specification a
left, Doc Any
"," Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Specification b -> Doc Any
forall a ann. Show a => a -> Doc ann
viaShow Specification b
right]
  alternateShow (Cartesian Specification a
left Specification b
right) = [Char] -> [Doc Any] -> BinaryShow
forall a. [Char] -> [Doc a] -> BinaryShow
BinaryShow [Char]
"Cartesian" [Doc Any
"," Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Specification a -> Doc Any
forall a ann. Show a => a -> Doc ann
viaShow Specification a
left, Doc Any
"," Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Specification b -> Doc Any
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) TypeSpec (Prod a b)
PairSpec a b
pair of
    (BinaryShow [Char]
"Cartesian" [Doc a]
ps) -> Doc a -> [Char]
forall a. Show a => a -> [Char]
show (Doc a -> [Char]) -> Doc a -> [Char]
forall a b. (a -> b) -> a -> b
$ Doc a -> Doc a
forall ann. Doc ann -> Doc ann
parens (Doc a
"Cartesian" Doc a -> Doc a -> Doc a
forall ann. Doc ann -> Doc ann -> Doc ann
/> [Doc a] -> Doc a
forall ann. [Doc ann] -> Doc ann
vsep [Doc a]
ps)
    BinaryShow
_ -> [Char]
"(Cartesian " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Specification a -> [Char]
forall a. Show a => a -> [Char]
show Specification a
l [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
") (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Specification b -> [Char]
forall a. Show a => a -> [Char]
show Specification b
r [Char] -> [Char] -> [Char]
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 = FunTy d r
a -> b -> Prod a b
forall a b. a -> b -> Prod a b
Prod
  semantics ProdW d r
ProdFstW = FunTy d r
Prod r b -> r
forall a b. Prod a b -> a
prodFst
  semantics ProdW d r
ProdSndW = FunTy d r
Prod a r -> r
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 = Specification b -> Specification b -> Specification (Prod b b)
forall a b.
(HasSpec a, HasSpec b) =>
Specification a -> Specification b -> Specification (Prod a b)
cartesian (TypeSpec b -> [b] -> Specification b
forall a. HasSpec a => TypeSpec a -> [a] -> Specification a
TypeSpec TypeSpec b
ts [b]
cant) Specification b
forall deps a. SpecificationD deps a
TrueSpec
  propagateTypeSpec ProdW as b
ProdSndW (Unary HOLE a (Prod a b)
HOLE) TypeSpec b
ts [b]
cant =
    Specification a -> Specification b -> Specification (Prod a b)
forall a b.
(HasSpec a, HasSpec b) =>
Specification a -> Specification b -> Specification (Prod a b)
cartesian Specification a
forall deps a. SpecificationD deps a
TrueSpec (TypeSpec b -> [b] -> Specification b
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 SpecificationD Deps a
sb) [b]
cant
    | a
a a -> Specification a -> Bool
forall a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification a
sa = SpecificationD Deps a
sb SpecificationD Deps a
-> SpecificationD Deps a -> SpecificationD Deps a
forall a. Semigroup a => a -> a -> a
<> (a -> SpecificationD Deps a) -> [a] -> SpecificationD Deps a
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> SpecificationD Deps a
forall a. HasSpec a => a -> Specification a
notEqualSpec (a -> [Prod a a] -> [a]
forall a1 a2. Eq a1 => a1 -> [Prod a1 a2] -> [a2]
sameFst a
a [b]
[Prod a a]
cant)
    | Bool
otherwise =
        NonEmpty [Char] -> SpecificationD Deps a
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec
          ( [[Char]] -> NonEmpty [Char]
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList
              [[Char]
"propagate (pair_ " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
a [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" HOLE) has conformance failure on a", Specification b -> [Char]
forall a. Show a => a -> [Char]
show (TypeSpec b -> [b] -> Specification b
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 SpecificationD Deps a
sa Specification b
sb) [b]
cant
    | b
b b -> Specification b -> Bool
forall a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification b
sb = SpecificationD Deps a
sa SpecificationD Deps a
-> SpecificationD Deps a -> SpecificationD Deps a
forall a. Semigroup a => a -> a -> a
<> (a -> SpecificationD Deps a) -> [a] -> SpecificationD Deps a
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> SpecificationD Deps a
forall a. HasSpec a => a -> Specification a
notEqualSpec (b -> [Prod a b] -> [a]
forall a1 a2. Eq a1 => a1 -> [Prod a2 a1] -> [a2]
sameSnd b
b [b]
[Prod a b]
cant)
    | Bool
otherwise =
        NonEmpty [Char] -> SpecificationD Deps a
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec
          ( [[Char]] -> NonEmpty [Char]
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList
              [[Char]
"propagate (pair_ HOLE " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ b -> [Char]
forall a. Show a => a -> [Char]
show b
b [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
") has conformance failure on b", Specification b -> [Char]
forall a. Show a => a -> [Char]
show (TypeSpec b -> [b] -> Specification b
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 = Specification b -> Specification b -> Specification (Prod b b)
forall a b.
(HasSpec a, HasSpec b) =>
Specification a -> Specification b -> Specification (Prod a b)
cartesian (NonEmpty b -> Specification b
forall a deps. NonEmpty a -> SpecificationD deps a
MemberSpec NonEmpty b
es) Specification b
forall deps a. SpecificationD deps a
TrueSpec
  propagateMemberSpec ProdW as b
ProdSndW (Unary HOLE a (Prod a b)
HOLE) NonEmpty b
es = Specification a -> Specification b -> Specification (Prod a b)
forall a b.
(HasSpec a, HasSpec b) =>
Specification a -> Specification b -> Specification (Prod a b)
cartesian Specification a
forall deps a. SpecificationD deps a
TrueSpec (NonEmpty b -> Specification b
forall a deps. NonEmpty a -> SpecificationD deps a
MemberSpec NonEmpty b
es)
  propagateMemberSpec ProdW as b
ProdW (a
a :>: HOLE a b
HOLE) NonEmpty b
es =
    case ([a] -> [a]
forall a. Eq a => [a] -> [a]
nub (a -> [Prod a a] -> [a]
forall a1 a2. Eq a1 => a1 -> [Prod a1 a2] -> [a2]
sameFst a
a (NonEmpty b -> [b]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty b
es))) of
      (a
w : [a]
ws) -> NonEmpty a -> SpecificationD Deps a
forall a deps. NonEmpty a -> SpecificationD deps a
MemberSpec (a
w a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
ws)
      [] ->
        NonEmpty [Char] -> SpecificationD Deps a
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec (NonEmpty [Char] -> SpecificationD Deps a)
-> NonEmpty [Char] -> SpecificationD Deps a
forall a b. (a -> b) -> a -> b
$
          [[Char]] -> NonEmpty [Char]
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList
            [ [Char]
"propagate (pair_ HOLE " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
a [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
") on (MemberSpec " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [b] -> [Char]
forall a. Show a => a -> [Char]
show (NonEmpty b -> [b]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty b
es)
            , [Char]
"Where " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
a [Char] -> [Char] -> [Char]
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 ([a] -> [a]
forall a. Eq a => [a] -> [a]
nub (b -> [Prod a b] -> [a]
forall a1 a2. Eq a1 => a1 -> [Prod a2 a1] -> [a2]
sameSnd b
b (NonEmpty b -> [b]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty b
es))) of
      (a
w : [a]
ws) -> NonEmpty a -> SpecificationD Deps a
forall a deps. NonEmpty a -> SpecificationD deps a
MemberSpec (a
w a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
ws)
      [] ->
        NonEmpty [Char] -> SpecificationD Deps a
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec (NonEmpty [Char] -> SpecificationD Deps a)
-> NonEmpty [Char] -> SpecificationD Deps a
forall a b. (a -> b) -> a -> b
$
          [[Char]] -> NonEmpty [Char]
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList
            [ [Char]
"propagate (pair_ HOLE " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ b -> [Char]
forall a. Show a => a -> [Char]
show b
b [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
") on (MemberSpec " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [b] -> [Char]
forall a. Show a => a -> [Char]
show (NonEmpty b -> [b]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty b
es)
            , [Char]
"Where " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ b -> [Char]
forall a. Show a => a -> [Char]
show b
b [Char] -> [Char] -> [Char]
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 ((Term a -> Maybe (Term rng, Term b)
Term (Prod rng b) -> Maybe (Term rng, Term b)
forall a 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 = Term rng -> Maybe (Term rng)
forall a. a -> Maybe a
Just Term rng
x
  rewriteRules ProdW dom rng
ProdSndW ((Term a -> Maybe (Term a, Term rng)
Term (Prod a rng) -> Maybe (Term a, Term rng)
forall a 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 = Term rng -> Maybe (Term rng)
forall a. a -> Maybe a
Just Term rng
y
  rewriteRules ProdW dom rng
_ List Term dom
_ Evidence (AppRequires ProdW dom rng)
_ = Maybe (Term 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_ = ProdW '[Prod a b] a
-> FunTy (MapList Term '[Prod a b]) (TermD Deps a)
forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm ProdW '[Prod a b] a
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_ = ProdW '[Prod a b] b
-> FunTy (MapList Term '[Prod a b]) (TermD Deps b)
forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm ProdW '[Prod a b] b
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 a1 -> a1 -> Bool
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 a1 -> a1 -> Bool
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_ = ProdW '[a, b] (Prod a b)
-> FunTy (MapList Term '[a, b]) (TermD Deps (Prod a b))
forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm ProdW '[a, b] (Prod a b)
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 <-
      [(Int, Gen (Specification a))] -> Gen (Specification a)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
        [ (Int
1, Specification a -> Gen (Specification a)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Specification a
forall deps a. SpecificationD deps a
TrueSpec)
        ,
          ( Int
7
          , do
              [a]
zs <- [a] -> [a]
forall a. Eq a => [a] -> [a]
nub ([a] -> [a]) -> Gen [a] -> Gen [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a -> Gen [a]
forall a. Gen a -> Gen [a]
listOf1 (Specification a -> Gen a
forall a. (HasCallStack, HasSpec a) => Specification a -> Gen a
genFromSpec Specification a
forall deps a. SpecificationD deps a
TrueSpec)
              Specification a -> Gen (Specification a)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                ( [a] -> NonEmpty [Char] -> Specification a
forall a. [a] -> NonEmpty [Char] -> Specification a
memberSpecList
                    [a]
zs
                    ( [[Char]] -> NonEmpty [Char]
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList
                        [ [Char]
"In (Arbitrary Specification) this should never happen"
                        , [Char]
"listOf1 generates empty list."
                        ]
                    )
                )
          )
        , (Int
10, TypeSpec a -> Specification a
forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec (TypeSpec a -> Specification a)
-> Gen (TypeSpec a) -> Gen (Specification a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (TypeSpec a)
forall a. Arbitrary a => Gen a
arbitrary)
        ,
          ( Int
1
          , do
              Int
len <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
5)
              TypeSpec a -> [a] -> Specification a
forall a. HasSpec a => TypeSpec a -> [a] -> Specification a
TypeSpec (TypeSpec a -> [a] -> Specification a)
-> Gen (TypeSpec a) -> Gen ([a] -> Specification a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (TypeSpec a)
forall a. Arbitrary a => Gen a
arbitrary Gen ([a] -> Specification a) -> Gen [a] -> Gen (Specification a)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Gen a -> Gen [a]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
len (Specification a -> Gen a
forall a. (HasCallStack, HasSpec a) => Specification a -> Gen a
genFromSpec Specification a
forall deps a. SpecificationD deps a
TrueSpec)
          )
        , (Int
1, NonEmpty [Char] -> Specification a
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec (NonEmpty [Char] -> Specification a)
-> Gen (NonEmpty [Char]) -> Gen (Specification a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (NonEmpty [Char])
forall a. Arbitrary a => Gen a
arbitrary)
        , -- Recurse to make sure we apply the tricks for generating suspended specs multiple times
          (Int
1, Gen (Specification a)
forall a. Arbitrary a => Gen a
arbitrary)
        ]
    -- TODO: we probably want smarter ways of generating constraints
    [(Int, Gen (Specification a))] -> Gen (Specification a)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
      [ (Int
1, Specification a -> Gen (Specification a)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Specification a -> Gen (Specification a))
-> Specification a -> Gen (Specification a)
forall a b. (a -> b) -> a -> b
$ (Term a -> Pred) -> Specification a
forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained ((Term a -> Pred) -> Specification a)
-> (Term a -> Pred) -> Specification a
forall a b. (a -> b) -> a -> b
$ \Term a
x -> Term a
x Term a -> Specification a -> Pred
forall a. HasSpec a => Term a -> Specification a -> Pred
`satisfies` Specification a
baseSpec)
      , (Int
1, [[Char]] -> Specification a -> Specification a
forall deps a.
[[Char]] -> SpecificationD deps a -> SpecificationD deps a
ExplainSpec [[Char]
"Arbitrary"] (Specification a -> Specification a)
-> Gen (Specification a) -> Gen (Specification a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Specification a)
forall a. Arbitrary a => Gen a
arbitrary)
      ,
        ( Int
1
        , Specification a -> Gen (Specification a)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Specification a -> Gen (Specification a))
-> Specification a -> Gen (Specification a)
forall a b. (a -> b) -> a -> b
$ (Term a -> Pred) -> Specification a
forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained ((Term a -> Pred) -> Specification a)
-> (Term a -> Pred) -> Specification a
forall a b. (a -> b) -> a -> b
$ \Term a
x -> ((forall b. TermD Deps b -> b) -> GE a)
-> (Term a -> [Pred]) -> Pred
forall a p.
(HasSpec a, IsPred p) =>
((forall b. TermD Deps b -> b) -> GE a) -> (Term a -> p) -> Pred
exists (\forall b. TermD Deps b -> b
eval -> a -> GE a
forall a. a -> GE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> GE a) -> a -> GE a
forall a b. (a -> b) -> a -> b
$ Term a -> a
forall b. TermD Deps b -> b
eval Term a
x) ((Term a -> [Pred]) -> Pred) -> (Term a -> [Pred]) -> Pred
forall a b. (a -> b) -> a -> b
$ \Term a
y ->
            [ TermD Deps Bool -> Pred
forall p. IsPred p => p -> Pred
assert (TermD Deps Bool -> Pred) -> TermD Deps Bool -> Pred
forall a b. (a -> b) -> a -> b
$ Term a
x Term a -> Term a -> TermD Deps Bool
forall a. HasSpec a => Term a -> Term a -> TermD Deps Bool
==. Term a
y
            , Term a
y Term a -> Specification a -> Pred
forall a. HasSpec a => Term a -> Specification a -> Pred
`satisfies` Specification a
baseSpec
            ]
        )
      , (Int
1, Specification a -> Gen (Specification a)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Specification a -> Gen (Specification a))
-> Specification a -> Gen (Specification a)
forall a b. (a -> b) -> a -> b
$ (Term a -> Pred) -> Specification a
forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained ((Term a -> Pred) -> Specification a)
-> (Term a -> Pred) -> Specification a
forall a b. (a -> b) -> a -> b
$ \Term a
x -> Term a -> (Term a -> Pred) -> Pred
forall a p.
(HasSpec a, IsPred p) =>
Term a -> (Term a -> p) -> Pred
letBind Term a
x ((Term a -> Pred) -> Pred) -> (Term a -> Pred) -> Pred
forall a b. (a -> b) -> a -> b
$ \Term a
y -> Term a
y Term a -> Specification a -> Pred
forall a. HasSpec a => Term a -> Specification a -> Pred
`satisfies` Specification a
baseSpec)
      ,
        ( Int
1
        , Specification a -> Gen (Specification a)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Specification a -> Gen (Specification a))
-> Specification a -> Gen (Specification a)
forall a b. (a -> b) -> a -> b
$ (Term a -> Pred) -> Specification a
forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained ((Term a -> Pred) -> Specification a)
-> (Term a -> Pred) -> Specification a
forall a b. (a -> b) -> a -> b
$ \Term a
x -> ((forall b. TermD Deps b -> b) -> GE Bool)
-> (TermD Deps Bool -> Pred) -> Pred
forall a p.
(HasSpec a, IsPred p) =>
((forall b. TermD Deps b -> b) -> GE a) -> (Term a -> p) -> Pred
exists (\forall b. TermD Deps b -> b
_ -> Bool -> GE Bool
forall a. a -> GE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True) ((TermD Deps Bool -> Pred) -> Pred)
-> (TermD Deps Bool -> Pred) -> Pred
forall a b. (a -> b) -> a -> b
$ \TermD Deps Bool
b ->
            TermD Deps Bool -> Pred -> Pred -> Pred
forall p q.
(IsPred p, IsPred q) =>
TermD Deps Bool -> p -> q -> Pred
ifElse TermD Deps Bool
b (Term a
x Term a -> Specification a -> Pred
forall a. HasSpec a => Term a -> Specification a -> Pred
`satisfies` Specification a
baseSpec) (Term a
x Term a -> Specification a -> Pred
forall a. HasSpec a => Term a -> Specification a -> Pred
`satisfies` Specification a
baseSpec)
        )
      ,
        ( Int
1
        , Specification a -> Gen (Specification a)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Specification a -> Gen (Specification a))
-> Specification a -> Gen (Specification a)
forall a b. (a -> b) -> a -> b
$ (Term a -> Pred) -> Specification a
forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained ((Term a -> Pred) -> Specification a)
-> (Term a -> Pred) -> Specification a
forall a b. (a -> b) -> a -> b
$ \Term a
x -> ((forall b. TermD Deps b -> b) -> GE Bool)
-> (TermD Deps Bool -> [Pred]) -> Pred
forall a p.
(HasSpec a, IsPred p) =>
((forall b. TermD Deps b -> b) -> GE a) -> (Term a -> p) -> Pred
exists (\forall b. TermD Deps b -> b
_ -> Bool -> GE Bool
forall a. a -> GE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True) ((TermD Deps Bool -> [Pred]) -> Pred)
-> (TermD Deps Bool -> [Pred]) -> Pred
forall a b. (a -> b) -> a -> b
$ \TermD Deps Bool
b ->
            [ TermD Deps Bool -> Bool -> Pred -> Pred
forall p q.
(IsPred p, IsPred q) =>
TermD Deps Bool -> p -> q -> Pred
ifElse TermD Deps Bool
b Bool
True (Term a
x Term a -> Specification a -> Pred
forall a. HasSpec a => Term a -> Specification a -> Pred
`satisfies` Specification a
baseSpec)
            , Term a
x Term a -> Specification a -> Pred
forall a. HasSpec a => Term a -> Specification a -> Pred
`satisfies` Specification a
baseSpec
            ]
        )
      ,
        ( Int
1
        , Specification a -> Gen (Specification a)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Specification a -> Gen (Specification a))
-> Specification a -> Gen (Specification a)
forall a b. (a -> b) -> a -> b
$ (Term a -> Pred) -> Specification a
forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained ((Term a -> Pred) -> Specification a)
-> (Term a -> Pred) -> Specification a
forall a b. (a -> b) -> a -> b
$ \Term a
x -> ((forall b. TermD Deps b -> b) -> GE Bool)
-> (TermD Deps Bool -> [Pred]) -> Pred
forall a p.
(HasSpec a, IsPred p) =>
((forall b. TermD Deps b -> b) -> GE a) -> (Term a -> p) -> Pred
exists (\forall b. TermD Deps b -> b
_ -> Bool -> GE Bool
forall a. a -> GE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False) ((TermD Deps Bool -> [Pred]) -> Pred)
-> (TermD Deps Bool -> [Pred]) -> Pred
forall a b. (a -> b) -> a -> b
$ \TermD Deps Bool
b ->
            [ TermD Deps Bool -> Pred -> Bool -> Pred
forall p q.
(IsPred p, IsPred q) =>
TermD Deps Bool -> p -> q -> Pred
ifElse TermD Deps Bool
b (Term a
x Term a -> Specification a -> Pred
forall a. HasSpec a => Term a -> Specification a -> Pred
`satisfies` Specification a
baseSpec) Bool
True
            , Term a
x Term a -> Specification a -> Pred
forall a. HasSpec a => Term a -> Specification a -> Pred
`satisfies` Specification a
baseSpec
            ]
        )
      ,
        ( Int
1
        , Specification a -> Gen (Specification a)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Specification a -> Gen (Specification a))
-> Specification a -> Gen (Specification a)
forall a b. (a -> b) -> a -> b
$ (Term a -> Pred) -> Specification a
forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained ((Term a -> Pred) -> Specification a)
-> (Term a -> Pred) -> Specification a
forall a b. (a -> b) -> a -> b
$ \Term a
x -> NonEmpty [Char] -> Pred -> Pred
explanation ([Char] -> NonEmpty [Char]
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"its very subtle, you won't get it.") (Pred -> Pred) -> Pred -> Pred
forall a b. (a -> b) -> a -> b
$ Term a
x Term a -> Specification a -> Pred
forall a. HasSpec a => Term a -> Specification a -> Pred
`satisfies` Specification a
baseSpec
        )
      , (Int
10, Specification a -> Gen (Specification a)
forall a. a -> Gen a
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 = FunTy d r
a -> [a] -> Bool
forall a. Eq a => a -> [a] -> Bool
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 SpecificationD Deps b
s) = [[Char]] -> Specification a -> Specification a
forall a. [[Char]] -> Specification a -> Specification a
explainSpec [[Char]]
es (Specification a -> Specification a)
-> Specification a -> Specification a
forall a b. (a -> b) -> a -> b
$ ElemW as b
-> ListCtx Value as (HOLE a)
-> SpecificationD Deps b
-> Specification a
forall (as :: [*]) b a.
(AppRequires ElemW as b, HasSpec a) =>
ElemW as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification 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 ElemW as b
f ListCtx Value as (HOLE a)
ctxt SpecificationD Deps b
s
  propagate ElemW as b
_ ListCtx Value as (HOLE a)
_ SpecificationD Deps b
TrueSpec = Specification a
forall deps a. SpecificationD deps a
TrueSpec
  propagate ElemW as b
_ ListCtx Value as (HOLE a)
_ (ErrorSpec NonEmpty [Char]
msgs) = NonEmpty [Char] -> Specification a
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec NonEmpty [Char]
msgs
  propagate ElemW as b
ElemW (HOLE a a
HOLE :<: ([a]
x :: [w])) (SuspendedSpec Var b
v Pred
ps) =
    (Term a -> Pred) -> Specification a
forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained ((Term a -> Pred) -> Specification a)
-> (Term a -> Pred) -> Specification a
forall a b. (a -> b) -> a -> b
$ \Term a
v' -> TermD Deps Bool -> BinderD Deps Bool -> Pred
forall deps a. TermD deps a -> BinderD deps a -> PredD deps
Let (ElemW '[a, [a]] Bool -> List Term '[a, [a]] -> TermD Deps Bool
forall deps (t :: [*] -> * -> *) (dom :: [*]) a.
AppRequiresD deps t dom a =>
t dom a -> List (TermD deps) dom -> TermD deps a
App ElemW '[a, [a]] Bool
forall t. HasSpec t => ElemW '[t, [t]] Bool
ElemW ((Term a
v' :: Term w) Term a -> List Term '[[a]] -> List Term '[a, [a]]
forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> [a] -> TermD Deps [a]
forall a deps. (Typeable a, Eq a, Show a) => a -> TermD deps a
Lit [a]
x TermD Deps [a] -> List Term '[] -> List Term '[[a]]
forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> List Term '[]
forall {k} (f :: k -> *). List f '[]
Nil)) (Var b
v Var b -> Pred -> BinderD Deps b
forall deps a.
(HasSpecD deps a, Show a) =>
Var a -> PredD deps -> BinderD deps a
:-> Pred
ps)
  propagate ElemW as b
ElemW (a
x :>: HOLE a [a]
HOLE) (SuspendedSpec Var b
v Pred
ps) =
    (Term a -> Pred) -> Specification a
forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained ((Term a -> Pred) -> Specification a)
-> (Term a -> Pred) -> Specification a
forall a b. (a -> b) -> a -> b
$ \Term a
v' -> TermD Deps Bool -> BinderD Deps Bool -> Pred
forall deps a. TermD deps a -> BinderD deps a -> PredD deps
Let (ElemW '[a, [a]] Bool -> List Term '[a, [a]] -> TermD Deps Bool
forall deps (t :: [*] -> * -> *) (dom :: [*]) a.
AppRequiresD deps t dom a =>
t dom a -> List (TermD deps) dom -> TermD deps a
App ElemW '[a, [a]] Bool
forall t. HasSpec t => ElemW '[t, [t]] Bool
ElemW (a -> TermD Deps a
forall a deps. (Typeable a, Eq a, Show a) => a -> TermD deps a
Lit a
x TermD Deps a -> List Term '[a] -> List Term '[a, a]
forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> Term a
v' Term a -> List Term '[] -> List Term '[a]
forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> List Term '[]
forall {k} (f :: k -> *). List f '[]
Nil)) (Var b
v Var b -> Pred -> BinderD Deps b
forall deps a.
(HasSpecD deps a, Show a) =>
Var a -> PredD deps -> BinderD deps a
:-> Pred
ps)
  propagate ElemW as b
ElemW (HOLE a a
HOLE :<: [a]
es) SpecificationD Deps b
spec =
    Specification Bool -> (Bool -> Specification a) -> Specification a
forall a.
HasSpec a =>
Specification Bool -> (Bool -> Specification a) -> Specification a
caseBoolSpec SpecificationD Deps b
Specification Bool
spec ((Bool -> Specification a) -> Specification a)
-> (Bool -> Specification a) -> Specification a
forall a b. (a -> b) -> a -> b
$ \case
      Bool
True -> [a] -> NonEmpty [Char] -> Specification a
forall a. [a] -> NonEmpty [Char] -> Specification a
memberSpecList ([a] -> [a]
forall a. Eq a => [a] -> [a]
nub [a]
[a]
es) ([Char] -> NonEmpty [Char]
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"propagate on (elem_ x []), The empty list, [], has no solution")
      Bool
False -> [a] -> Specification a
forall a (f :: * -> *).
(HasSpec a, Foldable f) =>
f a -> Specification a
notMemberSpec [a]
[a]
es
  propagate ElemW as b
ElemW (a
e :>: HOLE a [a]
HOLE) SpecificationD Deps b
spec =
    Specification Bool -> (Bool -> Specification a) -> Specification a
forall a.
HasSpec a =>
Specification Bool -> (Bool -> Specification a) -> Specification a
caseBoolSpec SpecificationD Deps b
Specification Bool
spec ((Bool -> Specification a) -> Specification a)
-> (Bool -> Specification a) -> Specification a
forall a b. (a -> b) -> a -> b
$ \case
      Bool
True -> TypeSpec a -> Specification a
forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec (Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
forall a.
Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
ListSpec Maybe Integer
forall a. Maybe a
Nothing [a
e] Specification Integer
forall a. Monoid a => a
mempty Specification a
forall a. Monoid a => a
mempty FoldSpec a
forall a. FoldSpec a
NoFold)
      Bool
False -> TypeSpec a -> Specification a
forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec (Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
forall a.
Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
ListSpec Maybe Integer
forall a. Maybe a
Nothing [a]
forall a. Monoid a => a
mempty Specification Integer
forall a. Monoid a => a
mempty (a -> Specification a
forall a. HasSpec a => a -> Specification a
notEqualSpec a
e) FoldSpec a
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 = Term rng -> Maybe (Term rng)
forall a. a -> Maybe a
Just (Term rng -> Maybe (Term rng)) -> Term rng -> Maybe (Term rng)
forall a b. (a -> b) -> a -> b
$ Bool -> TermD Deps Bool
forall a deps. (Typeable a, Eq a, Show a) => a -> TermD deps 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 = TermD Deps Bool -> Maybe (TermD Deps Bool)
forall a. a -> Maybe a
Just (TermD Deps Bool -> Maybe (TermD Deps Bool))
-> TermD Deps Bool -> Maybe (TermD Deps Bool)
forall a b. (a -> b) -> a -> b
$ Term a
t Term a -> Term a -> TermD Deps Bool
forall a. HasSpec a => Term a -> Term a -> TermD Deps Bool
==. (a -> TermD Deps a
forall a deps. (Typeable a, Eq a, Show a) => a -> TermD deps a
Lit a
a)
  rewriteRules ElemW dom rng
_ List Term dom
_ Evidence (AppRequires ElemW dom rng)
_ = Maybe (Term 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)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @c @(a, b) = case a
zs of
        ((a, b)
w : [(a, b)]
ws) -> [Bool -> Term a -> NonEmpty a -> Pred
forall deps a.
(HasSpecD deps a, Show a) =>
Bool -> TermD deps a -> NonEmpty a -> PredD deps
ElemPred Bool
True Term a
x (((a, b) -> a) -> NonEmpty (a, b) -> NonEmpty a
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, b) -> a
forall a b. (a, b) -> a
fst ((a, b)
w (a, b) -> [(a, b)] -> NonEmpty (a, b)
forall a. a -> [a] -> NonEmpty a
:| [(a, b)]
ws))]
        [] -> [NonEmpty [Char] -> Pred
forall deps. NonEmpty [Char] -> PredD deps
FalsePred ([Char] -> NonEmpty [Char]
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> NonEmpty [Char]) -> [Char] -> NonEmpty [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"empty list, zs , in elem_ " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Term a, Term b) -> [Char]
forall a. Show a => a -> [Char]
show (Term a
x, Term b
y) [Char] -> [Char] -> [Char]
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) = [Term a -> Specification a -> Pred
forall a. HasSpec a => Term a -> Specification a -> Pred
satisfies Term a
x (NonEmpty a -> SpecificationD Deps a
forall a deps. NonEmpty a -> SpecificationD deps a
MemberSpec (a
y a -> [a] -> NonEmpty a
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] -> TermD Deps Bool
elem_ = ElemW '[a, [a]] Bool
-> FunTy (MapList Term '[a, [a]]) (TermD Deps Bool)
forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm ElemW '[a, [a]] Bool
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 = ElemW '[a, [a]] Bool -> Fun '[a, [a]] Bool
forall (t :: [*] -> * -> *) (dom :: [*]) rng.
AppRequires t dom rng =>
t dom rng -> Fun dom rng
Fun ElemW '[a, [a]] Bool
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 = Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
forall a.
Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
ListSpec (Maybe Integer
 -> [a]
 -> Specification Integer
 -> Specification a
 -> FoldSpec a
 -> ListSpec a)
-> Gen (Maybe Integer)
-> Gen
     ([a]
      -> Specification Integer
      -> Specification a
      -> FoldSpec a
      -> ListSpec a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Maybe Integer)
forall a. Arbitrary a => Gen a
arbitrary Gen
  ([a]
   -> Specification Integer
   -> Specification a
   -> FoldSpec a
   -> ListSpec a)
-> Gen [a]
-> Gen
     (Specification Integer
      -> Specification a -> FoldSpec a -> ListSpec a)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen [a]
forall a. Arbitrary a => Gen a
arbitrary Gen
  (Specification Integer
   -> Specification a -> FoldSpec a -> ListSpec a)
-> Gen (Specification Integer)
-> Gen (Specification a -> FoldSpec a -> ListSpec a)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (Specification Integer)
forall a. Arbitrary a => Gen a
arbitrary Gen (Specification a -> FoldSpec a -> ListSpec a)
-> Gen (Specification a) -> Gen (FoldSpec a -> ListSpec a)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (Specification a)
forall a. Arbitrary a => Gen a
arbitrary Gen (FoldSpec a -> ListSpec a)
-> Gen (FoldSpec a) -> Gen (ListSpec a)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (FoldSpec a)
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) = [Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
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') <- (Maybe Integer, [a], Specification Integer, Specification a,
 FoldSpec a)
-> [(Maybe Integer, [a], Specification Integer, Specification a,
     FoldSpec a)]
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 -> [Char] -> [Char]
showsPrec Int
d = Doc Any -> [Char] -> [Char]
forall a. Show a => a -> [Char] -> [Char]
shows (Doc Any -> [Char] -> [Char])
-> (FoldSpec a -> Doc Any) -> FoldSpec a -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> FoldSpec a -> Doc Any
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)) =
    Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
parensIf (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
      Doc ann
"FoldSpec"
        Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
/> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep'
          [ Doc ann
"fn   =" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Fun '[a] b -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow Fun '[a] b
fun
          , Doc ann
"spec =" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Specification b -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Specification b -> Doc ann
pretty Specification b
s
          ]

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

instance HasSpec a => Show (ListSpec a) where
  showsPrec :: Int -> ListSpec a -> [Char] -> [Char]
showsPrec Int
d = Doc Any -> [Char] -> [Char]
forall a. Show a => a -> [Char] -> [Char]
shows (Doc Any -> [Char] -> [Char])
-> (ListSpec a -> Doc Any) -> ListSpec a -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ListSpec a -> Doc Any
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) =
    Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
parensIf (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
      Doc ann
"ListSpec"
        Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
/> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep'
          [ Doc ann
"hint =" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Maybe Integer -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow (ListSpec a -> Maybe Integer
forall a. ListSpec a -> Maybe Integer
listSpecHint ListSpec a
s)
          , Doc ann
"must =" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [a] -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow (ListSpec a -> [a]
forall a. ListSpec a -> [a]
listSpecMust ListSpec a
s)
          , Doc ann
"size =" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Specification Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Specification Integer -> Doc ann
pretty (ListSpec a -> Specification Integer
forall a. ListSpec a -> Specification Integer
listSpecSize ListSpec a
s)
          , Doc ann
"elem =" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Specification a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Specification a -> Doc ann
pretty (ListSpec a -> Specification a
forall a. ListSpec a -> Specification a
listSpecElem ListSpec a
s)
          , Doc ann
"fold =" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> FoldSpec a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. FoldSpec a -> Doc ann
pretty (ListSpec a -> FoldSpec a
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 = Int -> ListSpec a -> Doc ann
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 = NonEmpty [Char] -> SpecificationD Deps [a]
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec (NonEmpty [Char] -> SpecificationD Deps [a])
-> NonEmpty [Char] -> SpecificationD Deps [a]
forall a b. (a -> b) -> a -> b
$ ([[Char]] -> NonEmpty [Char]
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList ([Char]
"Error in size of ListSpec" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
msg)) NonEmpty [Char] -> NonEmpty [Char] -> NonEmpty [Char]
forall a. Semigroup a => a -> a -> a
<> NonEmpty [Char]
es
  | Just Integer
u <- Specification Integer -> Maybe Integer
forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Maybe a
knownUpperBound Specification Integer
size
  , Integer
u Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 =
      NonEmpty [Char] -> SpecificationD Deps [a]
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec (NonEmpty [Char] -> SpecificationD Deps [a])
-> NonEmpty [Char] -> SpecificationD Deps [a]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> NonEmpty [Char]
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList ([[Char]
"Negative size in guardListSpec", Specification Integer -> [Char]
forall a. Show a => a -> [Char]
show Specification Integer
size] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
msg)
  | Bool -> Bool
not ((a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a -> Specification a -> Bool
forall a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification a
elemS) [a]
must) =
      NonEmpty [Char] -> SpecificationD Deps [a]
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec (NonEmpty [Char] -> SpecificationD Deps [a])
-> NonEmpty [Char] -> SpecificationD Deps [a]
forall a b. (a -> b) -> a -> b
$
        ( [[Char]] -> NonEmpty [Char]
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList
            ([[Char]
"Some items in the must list do not conform to 'element' spec.", [Char]
"   " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Specification a -> [Char]
forall a. Show a => a -> [Char]
show Specification a
elemS] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
msg)
        )
  | Bool
otherwise = (TypeSpec [a] -> SpecificationD Deps [a]
forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec TypeSpec [a]
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 = Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
forall a.
Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
ListSpec Maybe Integer
forall a. Maybe a
Nothing [] Specification Integer
forall a. Monoid a => a
mempty Specification a
forall a. Monoid a => a
mempty FoldSpec a
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'' = [a] -> [a]
forall a. Eq a => [a] -> [a]
nub ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ [a]
must [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> [a]
must'
        elemS'' :: Specification a
elemS'' = Specification a
elemS Specification a -> Specification a -> Specification a
forall a. Semigroup a => a -> a -> a
<> Specification a
elemS'
        size'' :: Specification Integer
size'' = Specification Integer
size Specification Integer
-> Specification Integer -> Specification Integer
forall a. Semigroup a => a -> a -> a
<> Specification Integer
size'
        foldeither :: Either [[Char]] (FoldSpec a)
foldeither = FoldSpec a -> FoldSpec a -> Either [[Char]] (FoldSpec a)
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) " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ TypeSpec [a] -> [Char]
forall a. Show a => a -> [Char]
show TypeSpec [a]
l1, [Char]
"2) " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ TypeSpec [a] -> [Char]
forall a. Show a => a -> [Char]
show TypeSpec [a]
l2]
     in case Either [[Char]] (FoldSpec a)
foldeither of
          Left [[Char]]
foldmsg -> NonEmpty [Char] -> Specification [a]
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec ([[Char]] -> NonEmpty [Char]
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList ([[Char]]
msg [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
foldmsg))
          Right FoldSpec a
fold'' -> [[Char]] -> ListSpec a -> Specification [a]
forall a. HasSpec a => [[Char]] -> ListSpec a -> Specification [a]
guardListSpec [[Char]]
msg (ListSpec a -> Specification [a])
-> ListSpec a -> Specification [a]
forall a b. (a -> b) -> a -> b
$ Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
forall a.
Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
ListSpec ((Integer -> Integer -> Integer)
-> Maybe Integer -> Maybe Integer -> Maybe Integer
forall a. (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a
unionWithMaybe Integer -> Integer -> Integer
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
_)
    | (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Specification a -> Bool
forall a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification a
elemS)) [a]
must =
        [Char] -> GenT m [a]
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 -> GenT GE a -> GenT m [a]
forall (m :: * -> *) a. MonadGenError m => GenT GE a -> GenT m [a]
listOfT (GenT GE a -> GenT m [a]) -> GenT GE a -> GenT m [a]
forall a b. (a -> b) -> a -> b
$ Specification a -> GenT GE a
forall a (m :: * -> *).
(HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecT Specification a
elemS
      Just Integer
szHint -> do
        Integer
sz <- Specification Integer -> GenT m Integer
forall (m :: * -> *).
MonadGenError m =>
Specification Integer -> GenT m Integer
genFromSizeSpec (Integer -> Specification Integer
forall a. OrdLike a => a -> Specification a
leqSpec Integer
szHint)
        GenT GE a -> Int -> (Int -> Bool) -> GenT m [a]
forall a (m :: * -> *).
(Typeable a, MonadGenError m) =>
GenT GE a -> Int -> (Int -> Bool) -> GenT m [a]
listOfUntilLenT (Specification a -> GenT GE a
forall a (m :: * -> *).
(HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecT Specification a
elemS) (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
sz) (Bool -> Int -> Bool
forall a b. a -> b -> a
const Bool
True)
    Gen [a] -> GenT m [a]
forall (m :: * -> *) a. Applicative m => Gen a -> GenT m a
pureGen (Gen [a] -> GenT m [a]) -> Gen [a] -> GenT m [a]
forall a b. (a -> b) -> a -> b
$ [a] -> Gen [a]
forall a. [a] -> Gen [a]
shuffle ([a]
must [a] -> [a] -> [a]
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 <- Specification Integer -> GenT m Integer
forall (m :: * -> *).
MonadGenError m =>
Specification Integer -> GenT m Integer
genFromSizeSpec (Specification Integer
szSpec Specification Integer
-> Specification Integer -> Specification Integer
forall a. Semigroup a => a -> a -> a
<> Integer -> Specification Integer
forall a. OrdLike a => a -> Specification a
geqSpec ([a] -> Integer
forall t. Sized t => t -> Integer
sizeOf [a]
must) Specification Integer
-> Specification Integer -> Specification Integer
forall a. Semigroup a => a -> a -> a
<> Specification Integer
-> (Integer -> Specification Integer)
-> Maybe Integer
-> Specification Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Specification Integer
forall deps a. SpecificationD deps a
TrueSpec (Integer -> Specification Integer
forall a. OrdLike a => a -> Specification a
leqSpec (Integer -> Specification Integer)
-> (Integer -> Integer) -> Integer -> Specification Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
0) Maybe Integer
msz)
    let sz :: Int
sz = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
sz0 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- [a] -> Integer
forall t. Sized t => t -> Integer
sizeOf [a]
must)
    [a]
lst <-
      GenT GE a -> Int -> (Int -> Bool) -> GenT m [a]
forall a (m :: * -> *).
(Typeable a, MonadGenError m) =>
GenT GE a -> Int -> (Int -> Bool) -> GenT m [a]
listOfUntilLenT
        (Specification a -> GenT GE a
forall a (m :: * -> *).
(HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecT Specification a
elemS)
        Int
sz
        ((Integer -> Specification Integer -> Bool
forall a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification Integer
szSpec) (Integer -> Bool) -> (Int -> Integer) -> Int -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ [a] -> Integer
forall t. Sized t => t -> Integer
sizeOf [a]
must) (Integer -> Integer) -> (Int -> Integer) -> Int -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral)
    Gen [a] -> GenT m [a]
forall (m :: * -> *) a. Applicative m => Gen a -> GenT m a
pureGen (Gen [a] -> GenT m [a]) -> Gen [a] -> GenT m [a]
forall a b. (a -> b) -> a -> b
$ [a] -> Gen [a]
forall a. [a] -> Gen [a]
shuffle ([a]
must [a] -> [a] -> [a]
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 Specification Integer
-> Specification Integer -> Specification Integer
forall a. Semigroup a => a -> a -> a
<> Specification Integer
-> (Integer -> Specification Integer)
-> Maybe Integer
-> Specification Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Specification Integer
forall deps a. SpecificationD deps a
TrueSpec (Integer -> Specification Integer
forall a. OrdLike a => a -> Specification a
leqSpec (Integer -> Specification Integer)
-> (Integer -> Integer) -> Integer -> Specification Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
0) Maybe Integer
msz
    [a]
-> Specification Integer
-> Specification a
-> Fun '[a] b
-> Specification b
-> GenT m [a]
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 =
    (a -> [a]) -> [a] -> [[a]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList (Specification a -> a -> [a]
forall a. HasSpec a => Specification a -> a -> [a]
shrinkWithSpec Specification a
es) [a]
as

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

  guardTypeSpec :: [[Char]] -> TypeSpec [a] -> Specification [a]
guardTypeSpec = [[Char]] -> TypeSpec [a] -> Specification [a]
[[Char]] -> ListSpec a -> Specification [a]
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) =
    [a] -> Integer
forall t. Sized t => t -> Integer
sizeOf [a]
xs
      Integer -> Specification Integer -> Bool
forall a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification Integer
size
      Bool -> Bool -> Bool
&& (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a -> [a] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
xs) [a]
must
      Bool -> Bool -> Bool
&& (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a -> Specification a -> Bool
forall a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification a
elemS) [a]
xs
      Bool -> Bool -> Bool
&& [a]
xs
        [a] -> FoldSpec a -> Bool
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) =
    (Term [a] -> (Term a -> Pred) -> Pred
forall t a p.
(Forallable t a, HasSpec t, HasSpec a, IsPred p) =>
Term t -> (Term a -> p) -> Pred
forAll Term [a]
x ((Term a -> Pred) -> Pred) -> (Term a -> Pred) -> Pred
forall a b. (a -> b) -> a -> b
$ \Term a
x' -> Term a -> Specification a -> Pred
forall a. HasSpec a => Term a -> Specification a -> Pred
satisfies Term a
x' Specification a
elemS)
      Pred -> Pred -> Pred
forall a. Semigroup a => a -> a -> a
<> (Term [a] -> (Term a -> Pred) -> Pred
forall t a p.
(Forallable t a, HasSpec t, HasSpec a, IsPred p) =>
Term t -> (Term a -> p) -> Pred
forAll ([a] -> Term [a]
forall a deps. (Typeable a, Eq a, Show a) => a -> TermD deps a
Lit [a]
must) ((Term a -> Pred) -> Pred) -> (Term a -> Pred) -> Pred
forall a b. (a -> b) -> a -> b
$ \Term a
x' -> TermD Deps Bool -> Pred
forall deps. TermD deps Bool -> PredD deps
Assert (Term a -> Term [a] -> TermD Deps Bool
forall a.
(Sized [a], HasSpec a) =>
Term a -> Term [a] -> TermD Deps Bool
elem_ Term a
x' Term [a]
x))
      Pred -> Pred -> Pred
forall a. Semigroup a => a -> a -> a
<> Term [a] -> FoldSpec a -> Pred
forall a. HasSpec a => Term [a] -> FoldSpec a -> Pred
toPredsFoldSpec Term [a]
x FoldSpec a
foldS
      Pred -> Pred -> Pred
forall a. Semigroup a => a -> a -> a
<> Term Integer -> Specification Integer -> Pred
forall a. HasSpec a => Term a -> Specification a -> Pred
satisfies (Term [a] -> Term Integer
forall a. (HasSpec a, Sized a) => Term a -> Term Integer
sizeOf_ Term [a]
x) Specification Integer
size
      Pred -> Pred -> Pred
forall a. Semigroup a => a -> a -> a
<> Pred -> (Hint [a] -> Pred) -> Maybe (Hint [a]) -> Pred
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Pred
forall deps. PredD deps
TruePred ((Hint [a] -> Term [a] -> Pred) -> Term [a] -> Hint [a] -> Pred
forall a b c. (a -> b -> c) -> b -> a -> c
flip Hint [a] -> Term [a] -> Pred
forall t. HasGenHint t => Hint t -> Term t -> Pred
genHint Term [a]
x) Maybe Integer
Maybe (Hint [a])
msz

sizeOf_ :: (HasSpec a, Sized a) => Term a -> Term Integer
sizeOf_ :: forall a. (HasSpec a, Sized a) => Term a -> Term Integer
sizeOf_ = (List Term '[a] -> Term Integer)
-> FunTy (MapList Term '[a]) (Term Integer)
forall (ts :: [*]) (f :: * -> *) r.
TypeList ts =>
(List f ts -> r) -> FunTy (MapList f ts) r
forall (f :: * -> *) r.
(List f '[a] -> r) -> FunTy (MapList f '[a]) r
curryList (SizeW '[a] Integer -> List Term '[a] -> Term Integer
forall deps (t :: [*] -> * -> *) (dom :: [*]) a.
AppRequiresD deps t dom a =>
t dom a -> List (TermD deps) dom -> TermD deps a
App SizeW '[a] Integer
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 = Specification Integer -> GenT m Integer
forall a (m :: * -> *).
(HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecT (Specification Integer
integerSpec Specification Integer
-> Specification Integer -> Specification Integer
forall a. Semigroup a => a -> a -> a
<> Integer -> Specification Integer
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 = TypeSpec [a] -> Specification [a]
forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec (TypeSpec [a] -> Specification [a])
-> TypeSpec [a] -> Specification [a]
forall a b. (a -> b) -> a -> b
$ Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
forall a.
Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
ListSpec (Hint [a] -> Maybe (Hint [a])
forall a. a -> Maybe a
Just Hint [a]
szHint) [] Specification Integer
forall a. Monoid a => a
mempty Specification a
forall a. Monoid a => a
mempty FoldSpec a
forall a. FoldSpec a
NoFold

instance Forallable [a] a where
  fromForAllSpec :: (HasSpec [a], HasSpec a) => Specification a -> Specification [a]
fromForAllSpec Specification a
es = TypeSpec [a] -> Specification [a]
forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec (Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
forall a.
Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
ListSpec Maybe Integer
forall a. Maybe a
Nothing [] Specification Integer
forall a. Monoid a => a
mempty Specification a
es FoldSpec a
forall a. FoldSpec a
NoFold)
  forAllToList :: [a] -> [a]
forAllToList = [a] -> [a]
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 = ListW d r -> FunTy d r
forall (d :: [*]) r. ListW d r -> FunTy d r
listSem

instance Syntax ListW where
  prettySymbol :: forall deps (dom :: [*]) rng ann.
ListW dom rng -> List (TermD deps) dom -> Int -> Maybe (Doc ann)
prettySymbol ListW dom rng
AppendW (Lit a
n :> TermD deps a
y :> List (TermD deps) as1
Nil) Int
p = Doc ann -> Maybe (Doc ann)
forall a. a -> Maybe a
Just (Doc ann -> Maybe (Doc ann)) -> Doc ann -> Maybe (Doc ann)
forall a b. (a -> b) -> a -> b
$ Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
parensIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann
"append_" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [a] -> Doc ann
forall a x. (Show a, Typeable a) => [a] -> Doc x
short a
[a]
n Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> TermD deps a -> Doc ann
forall a ann. Pretty (WithPrec a) => Int -> a -> Doc ann
prettyPrec Int
10 TermD deps a
y
  prettySymbol ListW dom rng
AppendW (TermD deps a
y :> Lit a
n :> List (TermD deps) as1
Nil) Int
p = Doc ann -> Maybe (Doc ann)
forall a. a -> Maybe a
Just (Doc ann -> Maybe (Doc ann)) -> Doc ann -> Maybe (Doc ann)
forall a b. (a -> b) -> a -> b
$ Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
parensIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann
"append_" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> TermD deps a -> Doc ann
forall a ann. Pretty (WithPrec a) => Int -> a -> Doc ann
prettyPrec Int
10 TermD deps a
y Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [a] -> Doc ann
forall a x. (Show a, Typeable a) => [a] -> Doc x
short a
[a]
n
  prettySymbol ListW dom rng
_ List (TermD deps) dom
_ Int
_ = Maybe (Doc ann)
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)) = [rng] -> rng
forall a. Foldy a => [a] -> a
adds ([rng] -> rng) -> ([a] -> [rng]) -> [a] -> rng
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> rng) -> [a] -> [rng]
forall a b. (a -> b) -> [a] -> [b]
map (t '[a] rng -> FunTy '[a] rng
forall (d :: [*]) r. t d r -> FunTy d r
forall (t :: [*] -> * -> *) (d :: [*]) r.
Semantics t =>
t d r -> FunTy d r
semantics t '[a] rng
f)
listSem ListW dom rng
SingletonListW = (a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [])
listSem ListW dom rng
AppendW = FunTy dom rng
[a] -> [a] -> [a]
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  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Fun '[a] r -> [Char]
forall a. Show a => a -> [Char]
show Fun '[a] r
n [Char] -> [Char] -> [Char]
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 =
    TypeSpec a -> Specification a
forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec (Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
forall a.
Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
ListSpec Maybe Integer
forall a. Maybe a
Nothing [] Specification Integer
forall deps a. SpecificationD deps a
TrueSpec Specification a
forall deps a. SpecificationD deps a
TrueSpec (FoldSpec a -> ListSpec a) -> FoldSpec a -> ListSpec a
forall a b. (a -> b) -> a -> b
$ Fun '[a] b -> Specification b -> FoldSpec a
forall t a.
(HasSpec a, HasSpec t, Foldy t) =>
Fun '[a] t -> Specification t -> FoldSpec a
FoldSpec Fun '[a] b
f (TypeSpec b -> [b] -> Specification b
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
    | [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 =
        NonEmpty [Char] -> Specification a
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec (NonEmpty [Char] -> Specification a)
-> NonEmpty [Char] -> Specification a
forall a b. (a -> b) -> a -> b
$
          [[Char]] -> NonEmpty [Char]
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList
            [ [Char]
"Too many required elements for SingletonListW : "
            , [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [a] -> [Char]
forall a. Show a => a -> [Char]
show [a]
m
            ]
    | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Integer
1 Integer -> Specification Integer -> Bool
forall a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification Integer
sz =
        NonEmpty [Char] -> Specification a
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec (NonEmpty [Char] -> Specification a)
-> NonEmpty [Char] -> Specification a
forall a b. (a -> b) -> a -> b
$ [Char] -> NonEmpty [Char]
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> NonEmpty [Char]) -> [Char] -> NonEmpty [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"Size spec requires too many elements for SingletonListW : " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Specification Integer -> [Char]
forall a. Show a => a -> [Char]
show Specification Integer
sz
    | bad :: [a]
bad@(a
_ : [a]
_) <- (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Specification a -> Bool
forall a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification a
e)) [a]
m =
        NonEmpty [Char] -> Specification a
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec (NonEmpty [Char] -> Specification a)
-> NonEmpty [Char] -> Specification a
forall a b. (a -> b) -> a -> b
$
          [[Char]] -> NonEmpty [Char]
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList
            [ [Char]
"The following elements of the must spec do not conforms to the elem spec:"
            , [a] -> [Char]
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 = a -> Specification a
forall a. a -> Specification a
equalSpec a
a Specification a -> Specification a -> Specification a
forall a. Semigroup a => a -> a -> a
<> [a] -> Specification a
forall a (f :: * -> *).
(HasSpec a, Foldable f) =>
f a -> Specification a
notMemberSpec [a
z | [a
z] <- [b]
cant] Specification a -> Specification a -> Specification a
forall a. Semigroup a => a -> a -> a
<> FoldSpec a -> Specification 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 Specification a -> Specification a -> Specification a
forall a. Semigroup a => a -> a -> a
<> [a] -> Specification a
forall a (f :: * -> *).
(HasSpec a, Foldable f) =>
f a -> Specification a
notMemberSpec [a
a | [a
a] <- [b]
cant] Specification a -> Specification a -> Specification a
forall a. Semigroup a => a -> a -> a
<> FoldSpec a -> Specification 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]
    , (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a -> Specification a -> Bool
forall a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification a
e) [a]
ys =
        TypeSpec [a] -> [[a]] -> Specification [a]
forall a. HasSpec a => TypeSpec a -> [a] -> Specification a
TypeSpec ([a] -> ListSpec a -> ListSpec a
forall a. Eq a => [a] -> ListSpec a -> ListSpec a
alreadyHave [a]
ys TypeSpec b
ListSpec a
ts) ([a] -> [[a]] -> [[a]]
forall a. Eq a => [a] -> [[a]] -> [[a]]
suffixedBy [a]
ys [b]
[[a]]
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]
    , (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a -> Specification a -> Bool
forall a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification a
e) [a]
ys =
        TypeSpec [a] -> [[a]] -> Specification [a]
forall a. HasSpec a => TypeSpec a -> [a] -> Specification a
TypeSpec ([a] -> ListSpec a -> ListSpec a
forall a. Eq a => [a] -> ListSpec a -> ListSpec a
alreadyHave [a]
ys TypeSpec b
ListSpec a
ts) ([a] -> [[a]] -> [[a]]
forall a. Eq a => [a] -> [[a]] -> [[a]]
prefixedBy [a]
ys [b]
[[a]]
cant)
    | Bool
otherwise = NonEmpty [Char] -> Specification a
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec (NonEmpty [Char] -> Specification a)
-> NonEmpty [Char] -> Specification a
forall a b. (a -> b) -> a -> b
$ [Char] -> NonEmpty [Char]
forall a. a -> NonEmpty a
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 =
    TypeSpec a -> Specification a
forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec (Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
forall a.
Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
ListSpec Maybe Integer
forall a. Maybe a
Nothing [] Specification Integer
forall deps a. SpecificationD deps a
TrueSpec Specification a
forall deps a. SpecificationD deps a
TrueSpec (FoldSpec a -> ListSpec a) -> FoldSpec a -> ListSpec a
forall a b. (a -> b) -> a -> b
$ Fun '[a] b -> Specification b -> FoldSpec a
forall t a.
(HasSpec a, HasSpec t, Foldy t) =>
Fun '[a] t -> Specification t -> FoldSpec a
FoldSpec Fun '[a] b
f (NonEmpty b -> Specification b
forall a deps. NonEmpty a -> SpecificationD deps a
MemberSpec NonEmpty b
es))
  propagateMemberSpec ListW as b
SingletonListW (Unary HOLE a a
HOLE) NonEmpty b
xss =
    case [a
a | [a
a] <- NonEmpty b -> [b]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty b
xss] of
      [] ->
        NonEmpty [Char] -> Specification a
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec (NonEmpty [Char] -> Specification a)
-> NonEmpty [Char] -> Specification a
forall a b. (a -> b) -> a -> b
$ ([Char] -> NonEmpty [Char]
forall a. a -> NonEmpty a
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) -> NonEmpty a -> Specification a
forall a deps. NonEmpty a -> SpecificationD deps a
MemberSpec (a
x a -> [a] -> NonEmpty a
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 [a] -> [[a]] -> [[a]]
forall a. Eq a => [a] -> [[a]] -> [[a]]
suffixedBy [a]
ys (NonEmpty b -> [b]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty b
xss) of
          [] ->
            NonEmpty [Char] -> Specification a
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec
              ( [[Char]] -> NonEmpty [Char]
forall a. HasCallStack => [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) -> NonEmpty [a] -> SpecificationD Deps [a]
forall a deps. NonEmpty a -> SpecificationD deps a
MemberSpec ([a]
x [a] -> [[a]] -> NonEmpty [a]
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 [a] -> [[a]] -> [[a]]
forall a. Eq a => [a] -> [[a]] -> [[a]]
prefixedBy [a]
ys (NonEmpty b -> [b]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty b
xss) of
          [] ->
            NonEmpty [Char] -> Specification a
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec
              ( [[Char]] -> NonEmpty [Char]
forall a. HasCallStack => [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) -> NonEmpty [a] -> SpecificationD Deps [a]
forall a deps. NonEmpty a -> SpecificationD deps a
MemberSpec ([a]
x [a] -> [[a]] -> NonEmpty [a]
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 = TypeSpec b -> Specification b
forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec (Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
forall a.
Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
ListSpec Maybe Integer
forall a. Maybe a
Nothing [] (Integer -> Specification Integer
forall a. a -> Specification a
equalSpec Integer
1) (TypeSpec a -> Specification a
forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec TypeSpec a
ts) FoldSpec a
forall a. FoldSpec a
NoFold)
  mapTypeSpec (FoldMapW Fun '[a] b
g) TypeSpec a
ts =
    (Term b -> Pred) -> Specification b
forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained ((Term b -> Pred) -> Specification b)
-> (Term b -> Pred) -> Specification b
forall a b. (a -> b) -> a -> b
$ \Term b
x ->
      (Term [a] -> Pred) -> Pred
forall a p. (HasSpec a, IsPred p) => (Term a -> p) -> Pred
unsafeExists ((Term [a] -> Pred) -> Pred) -> (Term [a] -> Pred) -> Pred
forall a b. (a -> b) -> a -> b
$ \Term [a]
x' ->
        TermD Deps Bool -> Pred
forall deps. TermD deps Bool -> PredD deps
Assert (Term b
x Term b -> Term b -> TermD Deps Bool
forall a. HasSpec a => Term a -> Term a -> TermD Deps Bool
==. Fun '[[a]] b -> Term [a] -> Term b
forall x b. Fun '[x] b -> Term x -> Term b
appFun (Fun '[a] b -> Fun '[[a]] b
forall a b. (HasSpec a, Foldy b) => Fun '[a] b -> Fun '[[a]] b
foldMapFn Fun '[a] b
g) Term [a]
x') Pred -> Pred -> Pred
forall a. Semigroup a => a -> a -> a
<> Term [a] -> TypeSpec [a] -> Pred
forall a. HasSpec a => Term a -> TypeSpec a -> Pred
toPreds Term [a]
x' TypeSpec a
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 = Fun '[[a]] b -> Term [a] -> Term b
forall x b. Fun '[x] b -> Term x -> Term b
appFun (Fun '[[a]] b -> Term [a] -> Term b)
-> Fun '[[a]] b -> Term [a] -> Term b
forall a b. (a -> b) -> a -> b
$ Fun '[a] b -> Fun '[[a]] b
forall a b. (HasSpec a, Foldy b) => Fun '[a] b -> Fun '[[a]] b
foldMapFn (Fun '[a] b -> Fun '[[a]] b) -> Fun '[a] b -> Fun '[[a]] b
forall a b. (a -> b) -> a -> b
$ Term b -> Fun '[a] b
forall x. HasCallStack => Term x -> Fun '[a] x
toFn (Term b -> Fun '[a] b) -> Term b -> Fun '[a] b
forall a b. (a -> b) -> a -> b
$ Term a -> Term b
f (Var a -> Term a
forall deps a.
(HasSpecD deps a, Typeable a) =>
Var a -> TermD deps a
V Var a
v)
  where
    v :: Var a
v = Int -> [Char] -> Var a
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 <- Var a -> Var a -> Maybe (a :~: a)
forall a a'.
(Typeable a, Typeable a') =>
Var a -> Var a' -> Maybe (a :~: a')
eqVar Var a
v Var a
v' = t dom x -> Fun dom x
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 (TermD Deps a
t :> List Term as1
Nil)) = Fun '[a] x -> Fun '[a] a -> Fun '[a] x
forall b c a.
(HasSpec b, HasSpec c) =>
Fun '[b] c -> Fun '[a] b -> Fun '[a] c
composeFn (t dom x -> Fun dom x
forall (t :: [*] -> * -> *) (dom :: [*]) rng.
AppRequires t dom rng =>
t dom rng -> Fun dom rng
Fun t dom x
fn) (TermD Deps a -> Fun '[a] a
forall x. HasCallStack => Term x -> Fun '[a] x
toFn TermD Deps a
t)
    toFn (V Var x
v') | Just a :~: x
Refl <- Var a -> Var x -> Maybe (a :~: x)
forall a a'.
(Typeable a, Typeable a') =>
Var a -> Var a' -> Maybe (a :~: a')
eqVar Var a
v Var x
v' = Fun '[a] a
Fun '[a] x
forall a. HasSpec a => Fun '[a] a
idFn
    toFn TermD Deps x
_ = [Char] -> Fun '[a] 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_ = (Term a -> Term a) -> Term [a] -> Term a
forall a b.
(Foldy b, HasSpec a) =>
(Term a -> Term b) -> Term [a] -> Term b
foldMap_ Term a -> Term a
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_ = ListW '[a] [a] -> FunTy (MapList Term '[a]) (TermD Deps [a])
forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm ListW '[a] [a]
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_ = ListW '[[a], [a]] [a]
-> FunTy (MapList Term '[[a], [a]]) (TermD Deps [a])
forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm ListW '[[a], [a]] [a]
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 = ListW '[[a], [a]] [a] -> Fun '[[a], [a]] [a]
forall (t :: [*] -> * -> *) (dom :: [*]) rng.
AppRequires t dom rng =>
t dom rng -> Fun dom rng
Fun ListW '[[a], [a]] [a]
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 = ListW '[a] [a] -> Fun '[a] [a]
forall (t :: [*] -> * -> *) (dom :: [*]) rng.
AppRequires t dom rng =>
t dom rng -> Fun dom rng
Fun ListW '[a] [a]
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 = ListW '[[a]] b -> Fun '[[a]] b
forall (t :: [*] -> * -> *) (dom :: [*]) rng.
AppRequires t dom rng =>
t dom rng -> Fun dom rng
Fun (Fun '[a] b -> ListW '[[a]] b
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 = SpecificationD Deps a
forall deps a. SpecificationD deps 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) = t '[a] b
-> ListCtx Value '[a] (HOLE a)
-> Specification b
-> SpecificationD Deps a
forall (as :: [*]) b a.
(AppRequires t as b, HasSpec a) =>
t as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification 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
fn (HOLE a a
forall {k} (a :: k). HOLE a a
HOLE HOLE a a -> List Value '[] -> ListCtx Value '[a] (HOLE a)
forall (c :: * -> *) a (f :: * -> *) (as1 :: [*]).
c a -> List f as1 -> ListCtx f (a : as1) c
:? List Value '[]
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 = [Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ys) [a]
xs | [a]
xs <- [[a]]
xss, [a]
ys [a] -> [a] -> Bool
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 = [Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
- [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ys) [a]
xs | [a]
xs <- [[a]]
xss, [a]
ys [a] -> [a] -> Bool
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) =
  Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
forall a.
Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
ListSpec
    -- Reduce the hint
    ((Integer -> Integer) -> Maybe Integer -> Maybe Integer
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
subtract ([a] -> Integer
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 [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
\\ [a]
ys)
    -- Reduce the required size
    ((Term Integer -> Pred) -> Specification Integer
forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained ((Term Integer -> Pred) -> Specification Integer)
-> (Term Integer -> Pred) -> Specification Integer
forall a b. (a -> b) -> a -> b
$ \Term Integer
x -> (Term Integer
x Term Integer -> Term Integer -> Term Integer
forall a. Num a => a -> a -> a
+ Integer -> Term Integer
forall a deps. (Typeable a, Eq a, Show a) => a -> TermD deps a
Lit ([a] -> Integer
forall t. Sized t => t -> Integer
sizeOf [a]
ys)) Term Integer -> Specification Integer -> Pred
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
    ([a] -> FoldSpec a -> FoldSpec a
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 = FoldSpec a
forall a. FoldSpec a
NoFold
alreadyHaveFold [a]
ys (FoldSpec Fun '[a] b
fn Specification b
spec) =
  Fun '[a] b -> Specification b -> FoldSpec a
forall t a.
(HasSpec a, HasSpec t, Foldy t) =>
Fun '[a] t -> Specification t -> FoldSpec a
FoldSpec
    Fun '[a] b
fn
    ((Term b -> Pred) -> Specification b
forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained ((Term b -> Pred) -> Specification b)
-> (Term b -> Pred) -> Specification b
forall a b. (a -> b) -> a -> b
$ \Term b
s -> IntW '[b, b] b -> FunTy (MapList Term '[b, b]) (Term b)
forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm IntW '[b, b] b
forall a. Foldy a => IntW '[a, a] a
theAddFn Term b
s ((Term a -> Term b) -> Term [a] -> Term b
forall a b.
(Foldy b, HasSpec a) =>
(Term a -> Term b) -> Term [a] -> Term b
foldMap_ (Fun '[a] b -> Term a -> Term b
forall x b. Fun '[x] b -> Term x -> Term b
appFun Fun '[a] b
fn) ([a] -> Term [a]
forall a deps. (Typeable a, Eq a, Show a) => a -> TermD deps a
Lit [a]
ys)) Term b -> Specification b -> Pred
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
forall deps. PredD deps
TruePred
toPredsFoldSpec Term [a]
x (FoldSpec Fun '[a] b
funAB Specification b
sspec) =
  Term b -> Specification b -> Pred
forall a. HasSpec a => Term a -> Specification a -> Pred
satisfies (Fun '[[a]] b -> Term [a] -> Term b
forall x b. Fun '[x] b -> Term x -> Term b
appFun (Fun '[a] b -> Fun '[[a]] b
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 = FoldSpec a
forall a. FoldSpec a
NoFold
preMapFoldSpec Fun '[a] b
f (FoldSpec Fun '[b] b
g Specification b
s) = Fun '[a] b -> Specification b -> FoldSpec a
forall t a.
(HasSpec a, HasSpec t, Foldy t) =>
Fun '[a] t -> Specification t -> FoldSpec a
FoldSpec (Fun '[b] b -> Fun '[a] b -> Fun '[a] b
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) = (FunW '[a] c -> Fun '[a] c
forall (t :: [*] -> * -> *) (dom :: [*]) rng.
AppRequires t dom rng =>
t dom rng -> Fun dom rng
Fun (t '[b] c -> t '[a] b -> FunW '[a] c
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 = FunW '[a] a -> Fun '[a] a
forall (t :: [*] -> * -> *) (dom :: [*]) rng.
AppRequires t dom rng =>
t dom rng -> Fun dom rng
Fun FunW '[a] a
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 = FoldSpec a -> Either [[Char]] (FoldSpec a)
forall a. a -> Either [[Char]] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FoldSpec a
s
combineFoldSpec FoldSpec a
s FoldSpec a
NoFold = FoldSpec a -> Either [[Char]] (FoldSpec a)
forall a. a -> Either [[Char]] a
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 t '[a] b -> t '[a] b -> Maybe (t :~: t, '[a] :~: '[a], b :~: b)
forall (t1 :: [*] -> * -> *) (d1 :: [*]) r1 (t2 :: [*] -> * -> *)
       (d2 :: [*]) r2.
(Typeable t1, Typeable d1, Typeable r1, Typeable t2, Typeable d2,
 Typeable r2, Eq (t1 d1 r1)) =>
t1 d1 r1 -> t2 d2 r2 -> Maybe (t1 :~: t2, d1 :~: d2, r1 :~: r2)
sameFunSym t '[a] b
f t '[a] b
g of
    Just (t :~: t
_, '[a] :~: '[a]
_, b :~: b
Refl) -> FoldSpec a -> Either [[Char]] (FoldSpec a)
forall a. a -> Either [[Char]] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FoldSpec a -> Either [[Char]] (FoldSpec a))
-> FoldSpec a -> Either [[Char]] (FoldSpec a)
forall a b. (a -> b) -> a -> b
$ Fun '[a] b -> Specification b -> FoldSpec a
forall t a.
(HasSpec a, HasSpec t, Foldy t) =>
Fun '[a] t -> Specification t -> FoldSpec a
FoldSpec (t '[a] b -> Fun '[a] b
forall (t :: [*] -> * -> *) (dom :: [*]) rng.
AppRequires t dom rng =>
t dom rng -> Fun dom rng
Fun t '[a] b
f) (Specification b
s Specification b -> Specification b -> Specification b
forall a. Semigroup a => a -> a -> a
<> Specification b
Specification b
s')
    Maybe (t :~: t, '[a] :~: '[a], b :~: b)
Nothing -> [[Char]] -> Either [[Char]] (FoldSpec a)
forall a b. a -> Either a b
Left [[Char]
"Can't combine fold specs on different functions", [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ t '[a] b -> [Char]
forall a. Show a => a -> [Char]
show t '[a] b
f, [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ t '[a] b -> [Char]
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) = [b] -> b
forall a. Foldy a => [a] -> a
adds ((a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (t '[a] b -> FunTy '[a] b
forall (d :: [*]) r. t d r -> FunTy d r
forall (t :: [*] -> * -> *) (d :: [*]) r.
Semantics t =>
t d r -> FunTy d r
semantics t '[a] b
f) [a]
xs) b -> Specification b -> Bool
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 = IntW '[a, a] a
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 = SimpleRep t -> Integer
forall t. Sized t => t -> Integer
sizeOf (SimpleRep t -> Integer) -> (t -> SimpleRep t) -> t -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> SimpleRep t
forall a. HasSimpleRep a => a -> SimpleRep a
toSimpleRep

  liftSizeSpec :: HasSpec t => SizeSpec -> [Integer] -> Specification t
  default liftSizeSpec ::
    ( Sized (SimpleRep t)
    , GenericRequires t
    ) =>
    SizeSpec ->
    [Integer] ->
    Specification t
  liftSizeSpec NumSpec Integer
sz [Integer]
cant = Specification (SimpleRep t) -> Specification t
forall a.
GenericRequires a =>
Specification (SimpleRep a) -> Specification a
fromSimpleRepSpec (Specification (SimpleRep t) -> Specification t)
-> Specification (SimpleRep t) -> Specification t
forall a b. (a -> b) -> a -> b
$ NumSpec Integer -> [Integer] -> Specification (SimpleRep t)
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 ::
    ( Sized (SimpleRep t)
    , GenericRequires t
    ) =>
    [Integer] ->
    Specification t
  liftMemberSpec = Specification (SimpleRep t) -> Specification t
forall a.
GenericRequires a =>
Specification (SimpleRep a) -> Specification a
fromSimpleRepSpec (Specification (SimpleRep t) -> Specification t)
-> ([Integer] -> Specification (SimpleRep t))
-> [Integer]
-> Specification t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Integer] -> Specification (SimpleRep t)
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 = (a -> a -> a) -> a -> [a] -> a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (IntW '[a, a] a -> FunTy '[a, a] a
forall (d :: [*]) r. IntW d r -> FunTy d r
forall (t :: [*] -> * -> *) (d :: [*]) r.
Semantics t =>
t d r -> FunTy d r
semantics IntW '[a, a] a
forall a. Foldy a => IntW '[a, a] a
theAddFn) a
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), Foldy a) => Arbitrary (FoldSpec a) where
  arbitrary :: Gen (FoldSpec a)
arbitrary = [Gen (FoldSpec a)] -> Gen (FoldSpec a)
forall a. HasCallStack => [Gen a] -> Gen a
oneof [Fun '[a] a -> Specification a -> FoldSpec a
forall t a.
(HasSpec a, HasSpec t, Foldy t) =>
Fun '[a] t -> Specification t -> FoldSpec a
FoldSpec (FunW '[a] a -> Fun '[a] a
forall (t :: [*] -> * -> *) (dom :: [*]) rng.
AppRequires t dom rng =>
t dom rng -> Fun dom rng
Fun FunW '[a] a
forall a. FunW '[a] a
IdW) (Specification a -> FoldSpec a)
-> Gen (Specification a) -> Gen (FoldSpec a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Specification a)
forall a. Arbitrary a => Gen a
arbitrary, FoldSpec a -> Gen (FoldSpec a)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FoldSpec a
forall a. FoldSpec a
NoFold]
  shrink :: FoldSpec a -> [FoldSpec a]
shrink FoldSpec a
NoFold = []
  shrink (FoldSpec (Fun (t '[a] b -> Maybe (FunW '[a] b)
forall {k1} {k2} (t :: k1 -> k2 -> *) (t' :: k1 -> k2 -> *)
       (d :: k1) (r :: k2).
(Typeable t, Typeable d, Typeable r, Typeable t') =>
t d r -> Maybe (t' d r)
getWitness -> Just FunW '[a] b
IdW)) Specification b
spec) = Fun '[b] b -> Specification b -> FoldSpec b
forall t a.
(HasSpec a, HasSpec t, Foldy t) =>
Fun '[a] t -> Specification t -> FoldSpec a
FoldSpec (FunW '[b] b -> Fun '[b] b
forall (t :: [*] -> * -> *) (dom :: [*]) rng.
AppRequires t dom rng =>
t dom rng -> Fun dom rng
Fun FunW '[b] b
forall a. FunW '[a] a
IdW) (Specification b -> FoldSpec b)
-> [Specification b] -> [FoldSpec b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Specification b -> [Specification b]
forall a. Arbitrary a => a -> [a]
shrink Specification b
spec
  shrink FoldSpec {} = [FoldSpec a
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 = FunTy dom rng
rng -> rng
forall a. a -> a
id
funSem (ComposeW t1 '[b] rng
f t2 '[a] b
g) = (\a
a -> t1 '[b] rng -> FunTy '[b] rng
forall (d :: [*]) r. t1 d r -> FunTy d r
forall (t :: [*] -> * -> *) (d :: [*]) r.
Semantics t =>
t d r -> FunTy d r
semantics t1 '[b] rng
f (t2 '[a] b -> FunTy '[a] b
forall (d :: [*]) r. t2 d r -> FunTy d r
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)) = (a -> b -> rng) -> b -> a -> rng
forall a b c. (a -> b -> c) -> b -> a -> c
flip (t '[a, b] rng -> FunTy '[a, b] rng
forall (d :: [*]) r. t d r -> FunTy d r
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 = FunW d r -> FunTy d r
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_ " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ t '[a, b] rng -> [Char]
forall a. Show a => a -> [Char]
show t '[a, b] rng
f [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
  show (ComposeW t1 '[b] rng
x t2 '[a] b
y) = [Char]
"(compose_ " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ t1 '[b] rng -> [Char]
forall a. Show a => a -> [Char]
show t1 '[b] rng
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ t2 '[a] b -> [Char]
forall a. Show a => a -> [Char]
show t2 '[a] b
y [Char] -> [Char] -> [Char]
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 = t '[a, b] rng -> t '[a, b] rng -> Bool
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' = t1 '[b] rng -> t1 '[b] rng -> Bool
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
&& t2 '[a] b -> t2 '[a] b -> 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)
forall (a :: [*] -> * -> *) (b :: [*] -> * -> *).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @t1 @t2, forall (a :: [*]) (b :: [*]).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
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)
forall a b. (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 t1 bs1 r1 -> t1 bs1 r1 -> Bool
forall a. Eq a => a -> a -> Bool
== t1 bs1 r1
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) = Specification b -> Specification b
Specification b -> SpecificationD Deps a
forall a. a -> a
id
  propagate (FlipW t '[a, b] b
f) ListCtx Value as (HOLE a)
ctx = t '[a, b] b
-> ListCtx Value '[a, b] (HOLE a)
-> Specification b
-> SpecificationD Deps a
forall (as :: [*]) b a.
(AppRequires t as b, HasSpec a) =>
t as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification 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] b
f (ListCtx Value '[b, a] (HOLE a) -> ListCtx Value '[a, b] (HOLE a)
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)
ListCtx Value '[b, a] (HOLE a)
ctx)
  propagate (ComposeW t1 '[b] b
f t2 '[a] b
g) (Unary HOLE a a
HOLE) = t2 '[a] b
-> ListCtx Value '[a] (HOLE a)
-> Specification b
-> Specification a
forall (as :: [*]) b a.
(AppRequires t2 as b, HasSpec a) =>
t2 as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification 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 t2 '[a] b
g (HOLE a a -> ListCtx Value '[a] (HOLE a)
forall a' a (f :: * -> *). HOLE a' a -> ListCtx f '[a] (HOLE a')
Unary HOLE a a
forall {k} (a :: k). HOLE a a
HOLE) (Specification b -> Specification a)
-> (Specification b -> Specification b)
-> Specification b
-> Specification a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t1 '[b] b
-> ListCtx Value '[b] (HOLE b)
-> Specification b
-> Specification b
forall (as :: [*]) b a.
(AppRequires t1 as b, HasSpec a) =>
t1 as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification 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 t1 '[b] b
f (HOLE b b -> ListCtx Value '[b] (HOLE b)
forall a' a (f :: * -> *). HOLE a' a -> ListCtx f '[a] (HOLE a')
Unary HOLE b b
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 = TypeSpec b -> Specification b
forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec TypeSpec a
TypeSpec b
ts
  mapTypeSpec (ComposeW t1 '[b] b
g t2 '[a] b
h) TypeSpec a
ts = t1 '[b] b -> Specification b -> Specification b
forall (t :: [*] -> * -> *) a b.
AppRequires t '[a] b =>
t '[a] b -> Specification a -> Specification b
mapSpec t1 '[b] b
g (Specification b -> Specification b)
-> (Specification a -> Specification b)
-> Specification a
-> Specification b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t2 '[a] b -> Specification a -> Specification b
forall (t :: [*] -> * -> *) a b.
AppRequires t '[a] b =>
t '[a] b -> Specification a -> Specification b
mapSpec t2 '[a] b
h (Specification a -> Specification b)
-> Specification a -> Specification b
forall a b. (a -> b) -> a -> b
$ TypeSpec a -> Specification a
forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec TypeSpec a
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 = Term rng -> Maybe (Term rng)
forall a. a -> Maybe a
Just (Term rng -> Maybe (Term rng)) -> Term rng -> Maybe (Term rng)
forall a b. (a -> b) -> a -> b
$ t1 '[b] rng -> List Term '[b] -> Term rng
forall deps (t :: [*] -> * -> *) (dom :: [*]) a.
AppRequiresD deps t dom a =>
t dom a -> List (TermD deps) dom -> TermD deps a
App t1 '[b] rng
f (t2 '[a] b -> List Term '[a] -> TermD Deps b
forall deps (t :: [*] -> * -> *) (dom :: [*]) a.
AppRequiresD deps t dom a =>
t dom a -> List (TermD deps) dom -> TermD deps a
App t2 '[a] b
g (Term a
x Term a -> List Term '[] -> List Term '[a]
forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> List Term '[]
forall {k} (f :: k -> *). List f '[]
Nil) TermD Deps b -> List Term '[] -> List Term '[b]
forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> List Term '[]
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 = Term a -> Maybe (Term a)
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 = Term rng -> Maybe (Term rng)
forall a. a -> Maybe a
Just (Term rng -> Maybe (Term rng)) -> Term rng -> Maybe (Term rng)
forall a b. (a -> b) -> a -> b
$ t '[a, b] rng -> List Term '[a, b] -> Term rng
forall deps (t :: [*] -> * -> *) (dom :: [*]) a.
AppRequiresD deps t dom a =>
t dom a -> List (TermD deps) dom -> TermD deps a
App t '[a, b] rng
f (Term a
b Term a -> List Term '[a] -> List Term '[a, a]
forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> Term a
a Term a -> List Term '[] -> List Term '[a]
forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> List Term '[]
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 = Term rng -> Maybe (Term rng)
forall a. a -> Maybe a
Just (Term rng -> Maybe (Term rng)) -> Term rng -> Maybe (Term rng)
forall a b. (a -> b) -> a -> b
$ t '[a, b] rng -> List Term '[a, b] -> Term rng
forall deps (t :: [*] -> * -> *) (dom :: [*]) a.
AppRequiresD deps t dom a =>
t dom a -> List (TermD deps) dom -> TermD deps a
App t '[a, b] rng
f (Term a
b Term a -> List Term '[a] -> List Term '[a, a]
forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> Term a
a Term a -> List Term '[] -> List Term '[a]
forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> List Term '[]
forall {k} (f :: k -> *). List f '[]
Nil)
  rewriteRules (FlipW {}) List Term dom
_ Evidence (AppRequires FunW dom rng)
Evidence = Maybe (Term rng)
forall a. Maybe a
Nothing

id_ :: forall a. HasSpec a => Term a -> Term a
id_ :: forall a. HasSpec a => Term a -> Term a
id_ = FunW '[a] a -> FunTy (MapList Term '[a]) (TermD Deps a)
forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm FunW '[a] a
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 = FunW '[b, a] r -> FunTy (MapList Term '[b, a]) (TermD Deps r)
forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm (t '[a, b] r -> FunW '[b, a] r
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 = FunW '[a] r -> FunTy (MapList Term '[a]) (TermD Deps r)
forall (t :: [*] -> * -> *) (ds :: [*]) r.
AppRequires t ds r =>
t ds r -> FunTy (MapList Term ds) (Term r)
appTerm (FunW '[a] r -> FunTy (MapList Term '[a]) (TermD Deps r))
-> FunW '[a] r -> FunTy (MapList Term '[a]) (TermD Deps r)
forall a b. (a -> b) -> a -> b
$ t1 '[b] r -> t2 '[a] b -> FunW '[a] r
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 = Specification Integer -> Specification Integer -> GenT m [Integer]
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 = Specification Integer
-> Specification Integer
-> Specification Integer
-> GenT m [Integer]
forall a (m :: * -> *).
(Complete a, TypeSpec a ~ NumSpec a, MonadGenError m, Random a,
 Integral a, Arbitrary a, MaybeBounded a, Complete 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 = Specification Int -> Specification Int -> GenT m [Int]
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 = Specification Integer
-> Specification Int -> Specification Int -> GenT m [Int]
forall a (m :: * -> *).
(Complete a, TypeSpec a ~ NumSpec a, MonadGenError m, Random a,
 Integral a, Arbitrary a, MaybeBounded a, Complete 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 = Specification Int8 -> Specification Int8 -> GenT m [Int8]
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 = Specification Integer
-> Specification Int8 -> Specification Int8 -> GenT m [Int8]
forall a (m :: * -> *).
(Complete a, TypeSpec a ~ NumSpec a, MonadGenError m, Random a,
 Integral a, Arbitrary a, MaybeBounded a, Complete 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 = Specification Int16 -> Specification Int16 -> GenT m [Int16]
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 = Specification Integer
-> Specification Int16 -> Specification Int16 -> GenT m [Int16]
forall a (m :: * -> *).
(Complete a, TypeSpec a ~ NumSpec a, MonadGenError m, Random a,
 Integral a, Arbitrary a, MaybeBounded a, Complete 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 = Specification Int32 -> Specification Int32 -> GenT m [Int32]
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 = Specification Integer
-> Specification Int32 -> Specification Int32 -> GenT m [Int32]
forall a (m :: * -> *).
(Complete a, TypeSpec a ~ NumSpec a, MonadGenError m, Random a,
 Integral a, Arbitrary a, MaybeBounded a, Complete 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 = Specification Int64 -> Specification Int64 -> GenT m [Int64]
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 = Specification Integer
-> Specification Int64 -> Specification Int64 -> GenT m [Int64]
forall a (m :: * -> *).
(Complete a, TypeSpec a ~ NumSpec a, MonadGenError m, Random a,
 Integral a, Arbitrary a, MaybeBounded a, Complete 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 Nat -> Specification Nat -> GenT m [Nat]
genList = Specification Nat -> Specification Nat -> GenT m [Nat]
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 Nat -> Specification Nat -> GenT m [Nat]
genSizedList = Specification Integer
-> Specification Nat -> Specification Nat -> GenT m [Nat]
forall a (m :: * -> *).
(Complete a, TypeSpec a ~ NumSpec a, MonadGenError m, Random a,
 Integral a, Arbitrary a, MaybeBounded a, Complete 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 = Specification Word8 -> Specification Word8 -> GenT m [Word8]
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 = Specification Integer
-> Specification Word8 -> Specification Word8 -> GenT m [Word8]
forall a (m :: * -> *).
(Complete a, TypeSpec a ~ NumSpec a, MonadGenError m, Random a,
 Integral a, Arbitrary a, MaybeBounded a, Complete 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 = Specification Word16 -> Specification Word16 -> GenT m [Word16]
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 = Specification Integer
-> Specification Word16 -> Specification Word16 -> GenT m [Word16]
forall a (m :: * -> *).
(Complete a, TypeSpec a ~ NumSpec a, MonadGenError m, Random a,
 Integral a, Arbitrary a, MaybeBounded a, Complete 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 = Specification Word32 -> Specification Word32 -> GenT m [Word32]
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 = Specification Integer
-> Specification Word32 -> Specification Word32 -> GenT m [Word32]
forall a (m :: * -> *).
(Complete a, TypeSpec a ~ NumSpec a, MonadGenError m, Random a,
 Integral a, Arbitrary a, MaybeBounded a, Complete 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 = Specification Word64 -> Specification Word64 -> GenT m [Word64]
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 = Specification Integer
-> Specification Word64 -> Specification Word64 -> GenT m [Word64]
forall a (m :: * -> *).
(Complete a, TypeSpec a ~ NumSpec a, MonadGenError m, Random a,
 Integral a, Arbitrary a, MaybeBounded a, Complete 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 Specification a -> Specification a -> Specification a
forall a. Semigroup a => a -> a -> a
<> t '[a] b
-> ListCtx Value '[a] (HOLE a)
-> Specification b
-> Specification a
forall (as :: [*]) b a.
(AppRequires t as b, HasSpec a) =>
t as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification 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 (HOLE a a
forall {k} (a :: k). HOLE a a
HOLE HOLE a a -> List Value '[] -> ListCtx Value '[a] (HOLE a)
forall (c :: * -> *) a (f :: * -> *) (as1 :: [*]).
c a -> List f as1 -> ListCtx f (a : as1) c
:? List Value '[]
forall {k} (f :: k -> *). List f '[]
Nil) (b -> Specification b
forall a. a -> Specification a
equalSpec b
x)
   in NonEmpty [Char] -> GenT m a -> GenT m a
forall a. HasCallStack => NonEmpty [Char] -> GenT m a -> GenT m a
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a -> m a
explainNE
        ( [[Char]] -> NonEmpty [Char]
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList
            [ [Char]
"genInverse"
            , [Char]
"  f = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ t '[a] b -> [Char]
forall a. Show a => a -> [Char]
show t '[a] b
f
            , Doc Any -> [Char]
forall a. Show a => a -> [Char]
show (Doc Any -> [Char]) -> Doc Any -> [Char]
forall a b. (a -> b) -> a -> b
$ Doc Any
"  argS =" Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Specification a -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. Specification a -> Doc ann
pretty Specification a
argS
            , [Char]
"  x = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ b -> [Char]
forall a. Show a => a -> [Char]
show b
x
            , Doc Any -> [Char]
forall a. Show a => a -> [Char]
show (Doc Any -> [Char]) -> Doc Any -> [Char]
forall a b. (a -> b) -> a -> b
$ Doc Any
"  argSpec' =" Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Specification a -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. Specification a -> Doc ann
pretty Specification a
argSpec'
            ]
        )
        (GenT m a -> GenT m a) -> GenT m a -> GenT m a
forall a b. (a -> b) -> a -> b
$ Specification a -> GenT m a
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 (Specification Integer -> Specification Integer
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
  | Specification Integer -> Bool
forall a. Specification a -> Bool
isErrorLike Specification Integer
size =
      NonEmpty [Char] -> GenT m [a]
forall a. HasCallStack => NonEmpty [Char] -> GenT m a
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
fatalErrorNE ([Char] -> NonEmpty [Char] -> NonEmpty [Char]
forall a. a -> NonEmpty a -> NonEmpty a
NE.cons [Char]
"genFromFold has ErrorLike sizeSpec" (Specification Integer -> NonEmpty [Char]
forall a. Specification a -> NonEmpty [Char]
errorLikeMessage Specification Integer
size))
  | Specification a -> Bool
forall a. Specification a -> Bool
isErrorLike Specification a
elemS =
      NonEmpty [Char] -> GenT m [a]
forall a. HasCallStack => NonEmpty [Char] -> GenT m a
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
fatalErrorNE ([Char] -> NonEmpty [Char] -> NonEmpty [Char]
forall a. a -> NonEmpty a -> NonEmpty a
NE.cons [Char]
"genFromFold has ErrorLike elemSpec" (Specification a -> NonEmpty [Char]
forall a. Specification a -> NonEmpty [Char]
errorLikeMessage Specification a
elemS))
  | Specification b -> Bool
forall a. Specification a -> Bool
isErrorLike Specification b
foldS =
      NonEmpty [Char] -> GenT m [a]
forall a. HasCallStack => NonEmpty [Char] -> GenT m a
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a
fatalErrorNE ([Char] -> NonEmpty [Char] -> NonEmpty [Char]
forall a. a -> NonEmpty a -> NonEmpty a
NE.cons [Char]
"genFromFold has ErrorLike totalSpec" (Specification b -> NonEmpty [Char]
forall a. Specification a -> NonEmpty [Char]
errorLikeMessage Specification b
foldS))
  | Bool
otherwise = ( NonEmpty [Char] -> GenT m [a] -> GenT m [a]
forall a. HasCallStack => NonEmpty [Char] -> GenT m a -> GenT m a
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a -> m a
explainNE
                    ( [[Char]] -> NonEmpty [Char]
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList
                        [ [Char]
"while calling genFromFold"
                        , [Char]
"  must  = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [a] -> [Char]
forall a. Show a => a -> [Char]
show [a]
must
                        , [Char]
"  size  = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Specification Integer -> [Char]
forall a. Show a => a -> [Char]
show Specification Integer
size
                        , [Char]
"  elemS = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Specification a -> [Char]
forall a. Show a => a -> [Char]
show Specification a
elemS
                        , [Char]
"  fun   = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Fun '[a] b -> [Char]
forall a. Show a => a -> [Char]
show Fun '[a] b
fun
                        , [Char]
"  foldS = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Specification b -> [Char]
forall a. Show a => a -> [Char]
show Specification b
foldS
                        ]
                    )
                )
      (GenT m [a] -> GenT m [a]) -> GenT m [a] -> GenT m [a]
forall a b. (a -> b) -> a -> b
$ do
        let elemS' :: Specification b
            elemS' :: Specification b
elemS' = t '[a] b -> Specification a -> Specification b
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 = [b] -> b
forall a. Foldy a => [a] -> a
adds ((a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (t '[a] b -> FunTy '[a] b
forall (d :: [*]) r. t d r -> FunTy d r
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' = IntW '[b, b] b
-> ListCtx Value '[b, b] (HOLE b)
-> Specification b
-> Specification b
forall (as :: [*]) b a.
(AppRequires IntW as b, HasSpec a) =>
IntW as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification 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 IntW '[b, b] b
forall a. Foldy a => IntW '[a, a] a
theAddFn (HOLE b b
forall {k} (a :: k). HOLE a a
HOLE HOLE b b -> List Value '[b] -> ListCtx Value '[b, b] (HOLE b)
forall (c :: * -> *) a (f :: * -> *) (as1 :: [*]).
c a -> List f as1 -> ListCtx f (a : as1) c
:? b -> Value b
forall a. Show a => a -> Value a
Value b
mustVal Value b -> List Value '[] -> List Value '[b]
forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> List Value '[]
forall {k} (f :: k -> *). List f '[]
Nil) Specification b
foldS
            sizeSpec' :: Specification Integer
            sizeSpec' :: Specification Integer
sizeSpec' = IntW '[Integer, Integer] Integer
-> ListCtx Value '[Integer, Integer] (HOLE Integer)
-> Specification Integer
-> Specification Integer
forall (as :: [*]) b a.
(AppRequires IntW as b, HasSpec a) =>
IntW as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification 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 IntW '[Integer, Integer] Integer
forall b. NumLike b => IntW '[b, b] b
AddW (HOLE Integer Integer
forall {k} (a :: k). HOLE a a
HOLE HOLE Integer Integer
-> List Value '[Integer]
-> ListCtx Value '[Integer, Integer] (HOLE Integer)
forall (c :: * -> *) a (f :: * -> *) (as1 :: [*]).
c a -> List f as1 -> ListCtx f (a : as1) c
:? Integer -> Value Integer
forall a. Show a => a -> Value a
Value ([a] -> Integer
forall t. Sized t => t -> Integer
sizeOf [a]
must) Value Integer -> List Value '[] -> List Value '[Integer]
forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> List Value '[]
forall {k} (f :: k -> *). List f '[]
Nil) Specification Integer
size
        Bool -> GenT m () -> GenT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Specification Integer -> Bool
forall a. Specification a -> Bool
isErrorLike Specification Integer
sizeSpec') (GenT m () -> GenT m ()) -> GenT m () -> GenT m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> GenT m ()
forall (m :: * -> *) a. MonadGenError m => [Char] -> m a
genError [Char]
"Inconsistent size spec"
        [b]
results0 <- case Specification Integer
sizeSpec' of
          Specification Integer
TrueSpec -> Specification b -> Specification b -> GenT m [b]
forall a (m :: * -> *).
(Foldy a, MonadGenError m) =>
Specification a -> Specification a -> GenT m [a]
forall (m :: * -> *).
MonadGenError m =>
Specification b -> Specification b -> GenT m [b]
genList (Specification b -> Specification b
forall a. HasSpec a => Specification a -> Specification a
simplifySpec Specification b
elemS') (Specification b -> Specification b
forall a. HasSpec a => Specification a -> Specification a
simplifySpec Specification b
foldS')
          Specification Integer
_ -> Specification Integer
-> Specification b -> Specification b -> GenT m [b]
forall a (m :: * -> *).
(Foldy a, MonadGenError m) =>
Specification Integer
-> Specification a -> Specification a -> GenT m [a]
forall (m :: * -> *).
MonadGenError m =>
Specification Integer
-> Specification b -> Specification b -> GenT m [b]
genSizedList Specification Integer
sizeSpec' (Specification b -> Specification b
forall a. HasSpec a => Specification a -> Specification a
simplifySpec Specification b
elemS') (Specification b -> Specification b
forall a. HasSpec a => Specification a -> Specification a
simplifySpec Specification b
foldS')
        [a]
results <-
          NonEmpty [Char] -> GenT m [a] -> GenT m [a]
forall a. HasCallStack => NonEmpty [Char] -> GenT m a -> GenT m a
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty [Char] -> m a -> m a
explainNE
            ( [[Char]] -> NonEmpty [Char]
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList
                [ [Char]
"genInverse"
                , [Char]
"  fun = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Fun '[a] b -> [Char]
forall a. Show a => a -> [Char]
show Fun '[a] b
fun
                , [Char]
"  results0 = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [b] -> [Char]
forall a. Show a => a -> [Char]
show [b]
results0
                , Doc Any -> [Char]
forall a. Show a => a -> [Char]
show (Doc Any -> [Char]) -> Doc Any -> [Char]
forall a b. (a -> b) -> a -> b
$ Doc Any
"  elemS' =" Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Specification b -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. Specification b -> Doc ann
pretty Specification b
elemS'
                ]
            )
            (GenT m [a] -> GenT m [a]) -> GenT m [a] -> GenT m [a]
forall a b. (a -> b) -> a -> b
$ (b -> GenT m a) -> [b] -> GenT m [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Fun '[a] b -> Specification a -> b -> GenT m a
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
        Gen [a] -> GenT m [a]
forall (m :: * -> *) a. Applicative m => Gen a -> GenT m a
pureGen (Gen [a] -> GenT m [a]) -> Gen [a] -> GenT m [a]
forall a b. (a -> b) -> a -> b
$ [a] -> Gen [a]
forall a. [a] -> Gen [a]
shuffle ([a] -> Gen [a]) -> [a] -> Gen [a]
forall a b. (a -> b) -> a -> b
$ [a]
must [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
results

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

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

instance Sized [a] where
  sizeOf :: [a] -> Integer
sizeOf = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> ([a] -> Int) -> [a] -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
  liftSizeSpec :: HasSpec [a] => NumSpec Integer -> [Integer] -> Specification [a]
liftSizeSpec NumSpec Integer
spec [Integer]
cant = TypeSpec [a] -> Specification [a]
forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec (Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
forall a.
Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
ListSpec Maybe Integer
forall a. Maybe a
Nothing [a]
forall a. Monoid a => a
mempty (TypeSpec Integer -> [Integer] -> Specification Integer
forall a. HasSpec a => TypeSpec a -> [a] -> Specification a
TypeSpec TypeSpec Integer
NumSpec Integer
spec [Integer]
cant) Specification a
forall deps a. SpecificationD deps a
TrueSpec FoldSpec a
forall a. FoldSpec a
NoFold)
  liftMemberSpec :: HasSpec [a] => [Integer] -> Specification [a]
liftMemberSpec [Integer]
xs = case [Integer] -> Maybe (NonEmpty Integer)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Integer]
xs of
    Maybe (NonEmpty Integer)
Nothing -> NonEmpty [Char] -> Specification [a]
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec ([Char] -> NonEmpty [Char]
forall a. a -> NonEmpty a
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 -> TypeSpec [a] -> Specification [a]
forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec (Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
forall a.
Maybe Integer
-> [a]
-> Specification Integer
-> Specification a
-> FoldSpec a
-> ListSpec a
ListSpec Maybe Integer
forall a. Maybe a
Nothing [a]
forall a. Monoid a => a
mempty (NonEmpty Integer -> Specification Integer
forall a deps. NonEmpty a -> SpecificationD deps a
MemberSpec NonEmpty Integer
zs) Specification a
forall deps a. SpecificationD deps a
TrueSpec FoldSpec a
forall a. FoldSpec a
NoFold)
  sizeOfTypeSpec :: HasSpec [a] => TypeSpec [a] -> Specification Integer
sizeOfTypeSpec (ListSpec Maybe Integer
_ [a]
_ Specification Integer
_ ErrorSpec {} FoldSpec a
_) = Integer -> Specification Integer
forall a. a -> Specification a
equalSpec Integer
0
  sizeOfTypeSpec (ListSpec Maybe Integer
_ [a]
must Specification Integer
sizespec Specification a
_ FoldSpec a
_) = Specification Integer
sizespec Specification Integer
-> Specification Integer -> Specification Integer
forall a. Semigroup a => a -> a -> a
<> Integer -> Specification Integer
forall a. OrdLike a => a -> Specification a
geqSpec ([a] -> Integer
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 = FunTy d r
n -> Integer
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 = NumSpec Integer -> [Integer] -> Specification a
forall t.
(Sized t, HasSpec t) =>
NumSpec Integer -> [Integer] -> Specification t
liftSizeSpec TypeSpec b
NumSpec Integer
ts [b]
[Integer]
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 = [Integer] -> Specification a
forall t. (Sized t, HasSpec t) => [Integer] -> Specification t
liftMemberSpec (NonEmpty b -> [b]
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 =
    (Term b -> Pred) -> Specification b
forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained ((Term b -> Pred) -> Specification b)
-> (Term b -> Pred) -> Specification b
forall a b. (a -> b) -> a -> b
$ \Term b
x ->
      (Term a -> Pred) -> Pred
forall a p. (HasSpec a, IsPred p) => (Term a -> p) -> Pred
unsafeExists ((Term a -> Pred) -> Pred) -> (Term a -> Pred) -> Pred
forall a b. (a -> b) -> a -> b
$ \Term a
x' -> TermD Deps Bool -> Pred
forall deps. TermD deps Bool -> PredD deps
Assert (Term b
x Term b -> Term b -> TermD Deps Bool
forall a. HasSpec a => Term a -> Term a -> TermD Deps Bool
==. Term a -> Term Integer
forall a. (HasSpec a, Sized a) => Term a -> Term Integer
sizeOf_ Term a
x') Pred -> Pred -> Pred
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 = SizeW '[a] Integer -> Fun '[a] Integer
forall (t :: [*] -> * -> *) (dom :: [*]) rng.
AppRequires t dom rng =>
t dom rng -> Fun dom rng
Fun SizeW '[a] Integer
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 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 Bool -> Bool -> Bool
|| Integer
b Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 = [Char] -> NumSpec Integer
forall a. HasCallStack => [Char] -> a
error ([Char]
"Negative Int in call to rangeSize: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
a [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
b)
rangeSize Integer
a Integer
b = Maybe Integer -> Maybe Integer -> NumSpec Integer
forall n. Maybe n -> Maybe n -> NumSpec n
NumSpecInterval (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
a) (Integer -> Maybe Integer
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 = TypeSpec a -> [a] -> Specification a
forall a. HasSpec a => TypeSpec a -> [a] -> Specification a
TypeSpec (Maybe a -> Maybe a -> NumSpec a
forall n. Maybe n -> Maybe n -> NumSpec n
NumSpecInterval (a -> Maybe a
forall a. a -> Maybe a
Just a
lo) (a -> Maybe a
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) = [[Char]] -> Specification Integer -> Specification Integer
forall a. [[Char]] -> Specification a -> Specification a
explainSpecOpt [[Char]]
es (Specification Integer -> Specification Integer
maxSpec Specification Integer
s)
maxSpec Specification Integer
TrueSpec = Specification Integer
forall deps a. SpecificationD deps a
TrueSpec
maxSpec s :: Specification Integer
s@(SuspendedSpec Var Integer
_ Pred
_) =
  (Term Integer -> Pred) -> Specification Integer
forall a p.
(IsPred p, HasSpec a) =>
(Term a -> p) -> Specification a
constrained ((Term Integer -> Pred) -> Specification Integer)
-> (Term Integer -> Pred) -> Specification Integer
forall a b. (a -> b) -> a -> b
$ \Term Integer
x -> (Term Integer -> [Pred]) -> Pred
forall a p. (HasSpec a, IsPred p) => (Term a -> p) -> Pred
unsafeExists ((Term Integer -> [Pred]) -> Pred)
-> (Term Integer -> [Pred]) -> Pred
forall a b. (a -> b) -> a -> b
$ \Term Integer
y -> [Term Integer
y Term Integer -> Specification Integer -> Pred
forall a. HasSpec a => Term a -> Specification a -> Pred
`satisfies` Specification Integer
s, NonEmpty [Char] -> Pred -> Pred
forall deps. NonEmpty [Char] -> PredD deps -> PredD deps
Explain ([Char] -> NonEmpty [Char]
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"maxSpec on SuspendedSpec") (Pred -> Pred) -> Pred -> Pred
forall a b. (a -> b) -> a -> b
$ TermD Deps Bool -> Pred
forall deps. TermD deps Bool -> PredD deps
Assert (Term Integer
x Term Integer -> Term Integer -> TermD Deps Bool
forall a. OrdLike a => Term a -> Term a -> TermD Deps Bool
<=. Term Integer
y)]
maxSpec (ErrorSpec NonEmpty [Char]
xs) = NonEmpty [Char] -> Specification Integer
forall deps a. NonEmpty [Char] -> SpecificationD deps a
ErrorSpec NonEmpty [Char]
xs
maxSpec (MemberSpec NonEmpty Integer
xs) = Integer -> Specification Integer
forall a. OrdLike a => a -> Specification a
leqSpec (NonEmpty Integer -> Integer
forall a. Ord a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum NonEmpty Integer
xs)
maxSpec (TypeSpec (NumSpecInterval Maybe Integer
_ Maybe Integer
hi) [Integer]
bad) = TypeSpec Integer -> [Integer] -> Specification Integer
forall a. HasSpec a => TypeSpec a -> [a] -> Specification a
TypeSpec (Maybe Integer -> Maybe Integer -> NumSpec Integer
forall n. Maybe n -> Maybe n -> NumSpec n
NumSpecInterval Maybe Integer
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 = NumSpec Integer -> [Integer] -> Specification t
forall t.
(Sized t, HasSpec t) =>
NumSpec Integer -> [Integer] -> Specification t
liftSizeSpec NumSpec Integer
sz []