{- |
Module      : What4.Protocol.SMTWriter
Description : Infrastructure for rendering What4 expressions in the language of SMT solvers
Copyright   : (c) Galois, Inc 2014-2020.
License     : BSD3
Maintainer  : Joe Hendrix <jhendrix@galois.com>

This defines common definitions used in writing SMTLIB (2.0 and later), and
yices outputs from 'Expr' values.

The writer is designed to support solvers with arithmetic, propositional
logic, bitvector, tuples (aka. structs), and arrays.

It maps complex Expr values to either structs or arrays depending
on what the solver supports (structs are preferred if both are supported).

It maps multi-dimensional arrays to either arrays with structs as indices
if structs are supported or nested arrays if they are not.

The solver should detect when something is not supported and give an
error rather than sending invalid output to a file.
-}

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module What4.Protocol.SMTWriter
  ( -- * Type classes
    SupportTermOps(..)
  , ArrayConstantFn
  , SMTWriter(..)
  , SMTReadWriter (..)
  , SMTEvalBVArrayFn
  , SMTEvalBVArrayWrapper(..)
    -- * Terms
  , Term
  , app
  , app_list
  , builder_list
    -- * SMTWriter
  , WriterConn( supportFunctionDefs
              , supportFunctionArguments
              , supportQuantifiers
              , supportedFeatures
              , connHandle
              , connInputHandle
              , smtWriterName
              )
  , connState
  , newWriterConn
  , resetEntryStack
  , popEntryStackToTop
  , entryStackHeight
  , pushEntryStack
  , popEntryStack
  , Command
  , addCommand
  , addCommandNoAck
  , addCommands
  , mkFreeVar
  , bindVarAsFree
  , TypeMap(..)
  , typeMap
  , freshBoundVarName
  , assumeFormula
  , assumeFormulaWithName
  , assumeFormulaWithFreshName
  , DefineStyle(..)
  , AcknowledgementAction(..)
  , nullAcknowledgementAction
    -- * SMTWriter operations
  , assume
  , mkSMTTerm
  , mkFormula
  , mkAtomicFormula
  , SMTEvalFunctions(..)
  , smtExprGroundEvalFn
  , CollectorResults(..)
  , mkBaseExpr
  , runInSandbox
    -- * Reexports
  , What4.Interface.RoundingMode(..)
  ) where

#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail( MonadFail )
#endif

import           Control.Exception
import           Control.Lens hiding ((.>))
import           Control.Monad.Extra
import           Control.Monad.IO.Class
import           Control.Monad.Reader
import           Control.Monad.ST
import           Control.Monad.State.Strict
import           Control.Monad.Trans.Maybe
import qualified Data.Bits as Bits
import qualified Data.BitVector.Sized as BV
import           Data.ByteString (ByteString)
import           Data.IORef
import           Data.Kind
import           Data.List.NonEmpty (NonEmpty(..))
import           Data.Maybe
import           Data.Parameterized.Classes (ShowF(..))
import qualified Data.Parameterized.Context as Ctx
import qualified Data.Parameterized.HashTable as PH
import           Data.Parameterized.Nonce (Nonce)
import           Data.Parameterized.Some
import           Data.Parameterized.TraversableFC
import           Data.Ratio
import           Data.Text (Text)
import qualified Data.Text as Text
import           Data.Text.Lazy.Builder (Builder)
import qualified Data.Text.Lazy.Builder as Builder
import qualified Data.Text.Lazy.Builder.Int as Builder (decimal)
import qualified Data.Text.Lazy as Lazy
import           Data.Word
import           LibBF (BigFloat, bfFromBits)

import           Numeric.Natural
import           Prettyprinter hiding (Unbounded)
import           System.IO.Streams (OutputStream, InputStream)
import qualified System.IO.Streams as Streams

import           What4.BaseTypes
import           What4.Interface (RoundingMode(..), stringInfo)
import           What4.ProblemFeatures
import qualified What4.Expr.ArrayUpdateMap as AUM
import qualified What4.Expr.BoolMap as BM
import           What4.Expr.Builder
import           What4.Expr.GroundEval
import qualified What4.Expr.StringSeq as SSeq
import qualified What4.Expr.WeightedSum as WSum
import qualified What4.Expr.UnaryBV as UnaryBV
import           What4.ProgramLoc
import           What4.SatResult
import qualified What4.SemiRing as SR
import           What4.Symbol
import           What4.Utils.AbstractDomains
import qualified What4.Utils.BVDomain as BVD
import           What4.Utils.Complex
import           What4.Utils.FloatHelpers
import           What4.Utils.StringLiteral

------------------------------------------------------------------------
-- Term construction typeclasses

-- | 'TypeMap' defines how a given 'BaseType' maps to an SMTLIB type.
--
-- It is necessary as there may be several ways in which a base type can
-- be encoded.
data TypeMap (tp::BaseType) where
  BoolTypeMap    :: TypeMap BaseBoolType
  IntegerTypeMap :: TypeMap BaseIntegerType
  RealTypeMap    :: TypeMap BaseRealType
  BVTypeMap      :: (1 <= w) => !(NatRepr w) -> TypeMap (BaseBVType w)
  FloatTypeMap   :: !(FloatPrecisionRepr fpp) -> TypeMap (BaseFloatType fpp)
  Char8TypeMap   :: TypeMap (BaseStringType Char8)

  -- A complex number mapped to an SMTLIB struct.
  ComplexToStructTypeMap:: TypeMap BaseComplexType
  -- A complex number mapped to an SMTLIB array from boolean to real.
  ComplexToArrayTypeMap  :: TypeMap BaseComplexType

  -- An array that is encoded using a builtin SMT theory of arrays.
  --
  -- This theory typically restricts the set of arrays that can be encoded,
  -- but have a decidable equality.
  PrimArrayTypeMap :: !(Ctx.Assignment TypeMap (idxl Ctx.::> idx))
                   -> !(TypeMap tp)
                   -> TypeMap (BaseArrayType (idxl Ctx.::> idx) tp)

  -- An array that is encoded as an SMTLIB function.
  --
  -- The element type must not be an array encoded as a function.
  FnArrayTypeMap :: !(Ctx.Assignment TypeMap (idxl Ctx.::> idx))
                 -> TypeMap tp
                 -> TypeMap (BaseArrayType (idxl Ctx.::> idx) tp)

  -- A struct encoded as an SMTLIB struct/ yices tuple.
  --
  -- None of the fields should be arrays encoded as functions.
  StructTypeMap :: !(Ctx.Assignment TypeMap idx)
                -> TypeMap (BaseStructType idx)


instance ShowF TypeMap

instance Show (TypeMap a) where
  show :: TypeMap a -> String
show TypeMap a
BoolTypeMap              = String
"BoolTypeMap"
  show TypeMap a
IntegerTypeMap           = String
"IntegerTypeMap"
  show TypeMap a
RealTypeMap              = String
"RealTypeMap"
  show (BVTypeMap NatRepr w
n)            = String
"BVTypeMap " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NatRepr w -> String
forall a. Show a => a -> String
show NatRepr w
n
  show (FloatTypeMap FloatPrecisionRepr fpp
x)         = String
"FloatTypeMap " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FloatPrecisionRepr fpp -> String
forall a. Show a => a -> String
show FloatPrecisionRepr fpp
x
  show TypeMap a
Char8TypeMap             = String
"Char8TypeMap"
  show (TypeMap a
ComplexToStructTypeMap) = String
"ComplexToStructTypeMap"
  show TypeMap a
ComplexToArrayTypeMap    = String
"ComplexToArrayTypeMap"
  show (PrimArrayTypeMap Assignment TypeMap (idxl ::> idx)
ctx TypeMap tp
a) = String
"PrimArrayTypeMap " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Assignment TypeMap (idxl ::> idx) -> String
forall k (f :: k -> Type) (tp :: k). ShowF f => f tp -> String
showF Assignment TypeMap (idxl ::> idx)
ctx String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeMap tp -> String
forall k (f :: k -> Type) (tp :: k). ShowF f => f tp -> String
showF TypeMap tp
a
  show (FnArrayTypeMap Assignment TypeMap (idxl ::> idx)
ctx TypeMap tp
a)   = String
"FnArrayTypeMap " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Assignment TypeMap (idxl ::> idx) -> String
forall k (f :: k -> Type) (tp :: k). ShowF f => f tp -> String
showF Assignment TypeMap (idxl ::> idx)
ctx String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeMap tp -> String
forall k (f :: k -> Type) (tp :: k). ShowF f => f tp -> String
showF TypeMap tp
a
  show (StructTypeMap Assignment TypeMap idx
ctx)      = String
"StructTypeMap " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Assignment TypeMap idx -> String
forall k (f :: k -> Type) (tp :: k). ShowF f => f tp -> String
showF Assignment TypeMap idx
ctx


instance Eq (TypeMap tp) where
  TypeMap tp
x == :: TypeMap tp -> TypeMap tp -> Bool
== TypeMap tp
y = Maybe (tp :~: tp) -> Bool
forall a. Maybe a -> Bool
isJust (TypeMap tp -> TypeMap tp -> Maybe (tp :~: tp)
forall k (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality TypeMap tp
x TypeMap tp
y)

instance TestEquality TypeMap where
  testEquality :: TypeMap a -> TypeMap b -> Maybe (a :~: b)
testEquality TypeMap a
BoolTypeMap TypeMap b
BoolTypeMap = (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
  testEquality TypeMap a
IntegerTypeMap TypeMap b
IntegerTypeMap = (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
  testEquality TypeMap a
RealTypeMap TypeMap b
RealTypeMap = (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
  testEquality TypeMap a
Char8TypeMap TypeMap b
Char8TypeMap = (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
  testEquality (FloatTypeMap FloatPrecisionRepr fpp
x) (FloatTypeMap FloatPrecisionRepr fpp
y) = do
    fpp :~: fpp
Refl <- FloatPrecisionRepr fpp
-> FloatPrecisionRepr fpp -> Maybe (fpp :~: fpp)
forall k (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality FloatPrecisionRepr fpp
x FloatPrecisionRepr fpp
y
    (a :~: a) -> Maybe (a :~: a)
forall (m :: Type -> Type) a. Monad m => a -> m a
return a :~: a
forall k (a :: k). a :~: a
Refl
  testEquality (BVTypeMap NatRepr w
x) (BVTypeMap NatRepr w
y) = do
    w :~: w
Refl <- NatRepr w -> NatRepr w -> Maybe (w :~: w)
forall k (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality NatRepr w
x NatRepr w
y
    (a :~: a) -> Maybe (a :~: a)
forall (m :: Type -> Type) a. Monad m => a -> m a
return a :~: a
forall k (a :: k). a :~: a
Refl
  testEquality TypeMap a
ComplexToStructTypeMap TypeMap b
ComplexToStructTypeMap =
    (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
  testEquality TypeMap a
ComplexToArrayTypeMap TypeMap b
ComplexToArrayTypeMap =
    (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
  testEquality (PrimArrayTypeMap Assignment TypeMap (idxl ::> idx)
xa TypeMap tp
xr) (PrimArrayTypeMap Assignment TypeMap (idxl ::> idx)
ya TypeMap tp
yr) = do
    (idxl ::> idx) :~: (idxl ::> idx)
Refl <- Assignment TypeMap (idxl ::> idx)
-> Assignment TypeMap (idxl ::> idx)
-> Maybe ((idxl ::> idx) :~: (idxl ::> idx))
forall k (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality Assignment TypeMap (idxl ::> idx)
xa Assignment TypeMap (idxl ::> idx)
ya
    tp :~: tp
Refl <- TypeMap tp -> TypeMap tp -> Maybe (tp :~: tp)
forall k (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality TypeMap tp
xr TypeMap tp
yr
    (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
  testEquality (FnArrayTypeMap Assignment TypeMap (idxl ::> idx)
xa TypeMap tp
xr) (FnArrayTypeMap Assignment TypeMap (idxl ::> idx)
ya TypeMap tp
yr) = do
    (idxl ::> idx) :~: (idxl ::> idx)
Refl <- Assignment TypeMap (idxl ::> idx)
-> Assignment TypeMap (idxl ::> idx)
-> Maybe ((idxl ::> idx) :~: (idxl ::> idx))
forall k (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality Assignment TypeMap (idxl ::> idx)
xa Assignment TypeMap (idxl ::> idx)
ya
    tp :~: tp
Refl <- TypeMap tp -> TypeMap tp -> Maybe (tp :~: tp)
forall k (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality TypeMap tp
xr TypeMap tp
yr
    (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
  testEquality (StructTypeMap Assignment TypeMap idx
x) (StructTypeMap Assignment TypeMap idx
y) = do
    idx :~: idx
Refl <- Assignment TypeMap idx
-> Assignment TypeMap idx -> Maybe (idx :~: idx)
forall k (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality Assignment TypeMap idx
x Assignment TypeMap idx
y
    (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
  testEquality TypeMap a
_ TypeMap b
_ = Maybe (a :~: b)
forall a. Maybe a
Nothing

semiRingTypeMap :: SR.SemiRingRepr sr -> TypeMap (SR.SemiRingBase sr)
semiRingTypeMap :: SemiRingRepr sr -> TypeMap (SemiRingBase sr)
semiRingTypeMap SemiRingRepr sr
SR.SemiRingIntegerRepr     = TypeMap BaseIntegerType
TypeMap (SemiRingBase sr)
IntegerTypeMap
semiRingTypeMap SemiRingRepr sr
SR.SemiRingRealRepr        = TypeMap BaseRealType
TypeMap (SemiRingBase sr)
RealTypeMap
semiRingTypeMap (SR.SemiRingBVRepr BVFlavorRepr fv
_flv NatRepr w
w) = NatRepr w -> TypeMap (BaseBVType w)
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr w
w

type ArrayConstantFn v
   = [Some TypeMap]
     -- ^ Type for indices
     -> Some TypeMap
     -- ^ Type for value.
     -> v
     -- ^ Constant to assign all values.
     -> v

-- TODO, I'm not convinced it is valuable to have `SupportTermOps`
-- be a separate class from `SMTWriter`, and I'm really not sold
-- on the `Num` superclass constraint.

-- | A class of values containing rational and operations.
class Num v => SupportTermOps v where
  boolExpr :: Bool -> v

  notExpr  :: v -> v

  andAll :: [v] -> v
  orAll :: [v] -> v

  (.&&)    :: v -> v -> v
  v
x .&& v
y = [v] -> v
forall v. SupportTermOps v => [v] -> v
andAll [v
x, v
y]

  (.||)    :: v -> v -> v
  v
x .|| v
y = [v] -> v
forall v. SupportTermOps v => [v] -> v
orAll [v
x, v
y]

  -- | Compare two elements for equality.
  (.==)  :: v -> v -> v

  -- | Compare two elements for in-equality.
  (./=) :: v -> v -> v
  v
x ./= v
y = v -> v
forall v. SupportTermOps v => v -> v
notExpr (v
x v -> v -> v
forall v. SupportTermOps v => v -> v -> v
.== v
y)

  impliesExpr :: v -> v -> v
  impliesExpr v
x v
y = v -> v
forall v. SupportTermOps v => v -> v
notExpr v
x v -> v -> v
forall v. SupportTermOps v => v -> v -> v
.|| v
y

  -- | Create a let expression.  This is a "sequential" let,
  --   which is syntactic sugar for a nested series of single
  --   let bindings.  As a consequence, bound variables are in
  --   scope for the right-hand-sides of subsequent bindings.
  letExpr :: [(Text, v)] -> v -> v

  -- | Create an if-then-else expression.
  ite :: v -> v -> v -> v

  -- | Add a list of values together.
  sumExpr :: [v] -> v
  sumExpr [] = v
0
  sumExpr (v
h:[v]
r) = (v -> v -> v) -> v -> [v] -> v
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl v -> v -> v
forall a. Num a => a -> a -> a
(+) v
h [v]
r

  -- | Convert an integer expression to a real.
  termIntegerToReal :: v -> v

  -- | Convert a real expression to an integer.
  termRealToInteger :: v -> v

  -- | Convert an integer to a term.
  integerTerm :: Integer -> v

  -- | Convert a rational to a term.
  rationalTerm :: Rational -> v

  -- | Less-then-or-equal
  (.<=) :: v -> v -> v

  -- | Less-then
  (.<)  :: v -> v -> v
  v
x .< v
y = v -> v
forall v. SupportTermOps v => v -> v
notExpr (v
y v -> v -> v
forall v. SupportTermOps v => v -> v -> v
.<= v
x)

  -- | Greater then
  (.>)  :: v -> v -> v
  v
x .> v
y = v
y v -> v -> v
forall v. SupportTermOps v => v -> v -> v
.< v
x

  -- | Greater then or equal
  (.>=) :: v -> v -> v
  v
x .>= v
y = v
y v -> v -> v
forall v. SupportTermOps v => v -> v -> v
.<= v
x

  -- | Integer theory terms
  intAbs :: v -> v
  intDiv :: v -> v -> v
  intMod :: v -> v -> v
  intDivisible :: v -> Natural -> v

  -- | Create expression from bitvector.
  bvTerm :: NatRepr w -> BV.BV w -> v
  bvNeg :: v -> v
  bvAdd :: v -> v -> v
  bvSub :: v -> v -> v
  bvMul :: v -> v -> v

  bvSLe :: v -> v -> v
  bvULe :: v -> v -> v

  bvSLt :: v -> v -> v
  bvULt :: v -> v -> v

  bvUDiv :: v -> v -> v
  bvURem :: v -> v -> v
  bvSDiv :: v -> v -> v
  bvSRem :: v -> v -> v

  bvAnd :: v -> v -> v
  bvOr  :: v -> v -> v
  bvXor :: v -> v -> v
  bvNot :: v -> v

  bvShl  :: v -> v -> v
  bvLshr :: v -> v -> v
  bvAshr :: v -> v -> v

  -- | Concatenate two bitvectors together.
  bvConcat :: v -> v -> v

  -- | @bvExtract w i n v@ extracts bits [i..i+n) from @v@ as a new
  -- bitvector.   @v@ must contain at least @w@ elements, and @i+n@
  -- must be less than or equal to @w@.  The result has @n@ elements.
  -- The least significant bit of @v@ should have index @0@.
  bvExtract :: NatRepr w -> Natural -> Natural -> v -> v

  -- | @bvTestBit w i x@ returns predicate that holds if bit @i@
  -- in @x@ is set to true.  @w@ should be the number of bits in @x@.
  bvTestBit :: NatRepr w -> Natural -> v -> v
  bvTestBit NatRepr w
w Natural
i v
x = (NatRepr w -> Natural -> Natural -> v -> v
forall v (w :: Nat).
SupportTermOps v =>
NatRepr w -> Natural -> Natural -> v -> v
bvExtract NatRepr w
w Natural
i Natural
1 v
x v -> v -> v
forall v. SupportTermOps v => v -> v -> v
.== NatRepr 1 -> BV 1 -> v
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr 1
w1 (NatRepr 1 -> BV 1
forall (w :: Nat). (1 <= w) => NatRepr w -> BV w
BV.one NatRepr 1
w1))
    where w1 :: NatRepr 1
          w1 :: NatRepr 1
w1 = NatRepr 1
forall (n :: Nat). KnownNat n => NatRepr n
knownNat

  bvSumExpr :: NatRepr w -> [v] -> v
  bvSumExpr NatRepr w
w [] = NatRepr w -> BV w -> v
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> BV w
forall (w :: Nat). NatRepr w -> BV w
BV.zero NatRepr w
w)
  bvSumExpr NatRepr w
_ (v
h:[v]
r) = (v -> v -> v) -> v -> [v] -> v
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl v -> v -> v
forall v. SupportTermOps v => v -> v -> v
bvAdd v
h [v]
r

  floatTerm  :: FloatPrecisionRepr fpp -> BigFloat -> v

  floatNeg  :: v -> v
  floatAbs  :: v -> v
  floatSqrt :: RoundingMode -> v -> v

  floatAdd :: RoundingMode -> v -> v -> v
  floatSub :: RoundingMode -> v -> v -> v
  floatMul :: RoundingMode -> v -> v -> v
  floatDiv :: RoundingMode -> v -> v -> v
  floatRem :: v -> v -> v
  floatFMA :: RoundingMode -> v -> v -> v -> v

  floatEq   :: v -> v -> v
  floatFpEq :: v -> v -> v
  floatLe   :: v -> v -> v
  floatLt   :: v -> v -> v

  floatIsNaN      :: v -> v
  floatIsInf      :: v -> v
  floatIsZero     :: v -> v
  floatIsPos      :: v -> v
  floatIsNeg      :: v -> v
  floatIsSubnorm  :: v -> v
  floatIsNorm     :: v -> v

  floatCast       :: FloatPrecisionRepr fpp -> RoundingMode -> v -> v
  floatRound      :: RoundingMode -> v -> v
  floatFromBinary :: FloatPrecisionRepr fpp -> v -> v
  bvToFloat       :: FloatPrecisionRepr fpp -> RoundingMode -> v -> v
  sbvToFloat      :: FloatPrecisionRepr fpp -> RoundingMode -> v -> v
  realToFloat     :: FloatPrecisionRepr fpp -> RoundingMode -> v -> v
  floatToBV       :: Natural -> RoundingMode -> v -> v
  floatToSBV      :: Natural -> RoundingMode -> v -> v
  floatToReal     :: v -> v

  -- | Predicate that holds if a real number is an integer.
  realIsInteger :: v -> v

  realDiv :: v -> v -> v

  realSin :: v -> v

  realCos :: v -> v

  realATan2 :: v -> v -> v

  realSinh :: v -> v

  realCosh :: v -> v

  realExp  :: v -> v

  realLog  :: v -> v

  -- | Apply the arguments to the given function.
  smtFnApp :: v -> [v] -> v

  -- | Update a function value to return a new value at the given point.
  --
  -- This may be Nothing if solver has no builtin function for update.
  smtFnUpdate :: Maybe (v -> [v] -> v -> v)
  smtFnUpdate = Maybe (v -> [v] -> v -> v)
forall a. Maybe a
Nothing

  -- | Function for creating a lambda term if output supports it.
  --
  -- Yices support lambda expressions, but SMTLIB2 does not.
  -- The function takes arguments and the expression.
  lambdaTerm :: Maybe ([(Text, Some TypeMap)] -> v -> v)
  lambdaTerm = Maybe ([(Text, Some TypeMap)] -> v -> v)
forall a. Maybe a
Nothing

  fromText :: Text -> v


infixr 3 .&&
infixr 2 .||
infix 4 .==
infix 4 ./=
infix 4 .>
infix 4 .>=
infix 4 .<
infix 4 .<=

------------------------------------------------------------------------
-- Term

structComplexRealPart :: forall h. SMTWriter h => Term h -> Term h
structComplexRealPart :: Term h -> Term h
structComplexRealPart Term h
c = Assignment TypeMap ((EmptyCtx ::> BaseRealType) ::> BaseRealType)
-> Index
     ((EmptyCtx ::> BaseRealType) ::> BaseRealType) BaseRealType
-> Term h
-> Term h
forall h (args :: Ctx BaseType) (tp :: BaseType).
SMTWriter h =>
Assignment TypeMap args -> Index args tp -> Term h -> Term h
structProj @h (Assignment TypeMap EmptyCtx
forall k (ctx :: Ctx k) (f :: k -> Type).
(ctx ~ EmptyCtx) =>
Assignment f ctx
Ctx.Empty Assignment TypeMap EmptyCtx
-> TypeMap BaseRealType
-> Assignment TypeMap (EmptyCtx ::> BaseRealType)
forall k (ctx' :: Ctx k) (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
(ctx' ~ (ctx ::> tp)) =>
Assignment f ctx -> f tp -> Assignment f ctx'
Ctx.:> TypeMap BaseRealType
RealTypeMap Assignment TypeMap (EmptyCtx ::> BaseRealType)
-> TypeMap BaseRealType
-> Assignment
     TypeMap ((EmptyCtx ::> BaseRealType) ::> BaseRealType)
forall k (ctx' :: Ctx k) (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
(ctx' ~ (ctx ::> tp)) =>
Assignment f ctx -> f tp -> Assignment f ctx'
Ctx.:> TypeMap BaseRealType
RealTypeMap) (forall k (n :: Nat) (ctx :: Ctx k) (r :: k).
Idx n ctx r =>
Index ctx r
forall (ctx :: Ctx BaseType) (r :: BaseType).
Idx 0 ctx r =>
Index ctx r
Ctx.natIndex @0) Term h
c

structComplexImagPart :: forall h. SMTWriter h => Term h -> Term h
structComplexImagPart :: Term h -> Term h
structComplexImagPart Term h
c = Assignment TypeMap ((EmptyCtx ::> BaseRealType) ::> BaseRealType)
-> Index
     ((EmptyCtx ::> BaseRealType) ::> BaseRealType) BaseRealType
-> Term h
-> Term h
forall h (args :: Ctx BaseType) (tp :: BaseType).
SMTWriter h =>
Assignment TypeMap args -> Index args tp -> Term h -> Term h
structProj @h (Assignment TypeMap EmptyCtx
forall k (ctx :: Ctx k) (f :: k -> Type).
(ctx ~ EmptyCtx) =>
Assignment f ctx
Ctx.Empty Assignment TypeMap EmptyCtx
-> TypeMap BaseRealType
-> Assignment TypeMap (EmptyCtx ::> BaseRealType)
forall k (ctx' :: Ctx k) (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
(ctx' ~ (ctx ::> tp)) =>
Assignment f ctx -> f tp -> Assignment f ctx'
Ctx.:> TypeMap BaseRealType
RealTypeMap Assignment TypeMap (EmptyCtx ::> BaseRealType)
-> TypeMap BaseRealType
-> Assignment
     TypeMap ((EmptyCtx ::> BaseRealType) ::> BaseRealType)
forall k (ctx' :: Ctx k) (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
(ctx' ~ (ctx ::> tp)) =>
Assignment f ctx -> f tp -> Assignment f ctx'
Ctx.:> TypeMap BaseRealType
RealTypeMap) (forall k (n :: Nat) (ctx :: Ctx k) (r :: k).
Idx n ctx r =>
Index ctx r
forall (ctx :: Ctx BaseType) (r :: BaseType).
Idx 1 ctx r =>
Index ctx r
Ctx.natIndex @1) Term h
c

arrayComplexRealPart :: forall h . SMTWriter h => Term h -> Term h
arrayComplexRealPart :: Term h -> Term h
arrayComplexRealPart Term h
c = Term h -> [Term h] -> Term h
forall h. SMTWriter h => Term h -> [Term h] -> Term h
arraySelect @h Term h
c [Bool -> Term h
forall v. SupportTermOps v => Bool -> v
boolExpr Bool
False]

arrayComplexImagPart :: forall h . SMTWriter h => Term h -> Term h
arrayComplexImagPart :: Term h -> Term h
arrayComplexImagPart Term h
c = Term h -> [Term h] -> Term h
forall h. SMTWriter h => Term h -> [Term h] -> Term h
arraySelect @h Term h
c [Bool -> Term h
forall v. SupportTermOps v => Bool -> v
boolExpr Bool
True]

app :: Builder -> [Builder] -> Builder
app :: Builder -> [Builder] -> Builder
app Builder
o [] = Builder
o
app Builder
o [Builder]
args = Builder -> [Builder] -> Builder
app_list Builder
o [Builder]
args

app_list :: Builder -> [Builder] -> Builder
app_list :: Builder -> [Builder] -> Builder
app_list Builder
o [Builder]
args = Builder
"(" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
o Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Builder] -> Builder
forall p. (IsString p, Semigroup p) => [p] -> p
go [Builder]
args
  where go :: [p] -> p
go [] = p
")"
        go (p
f:[p]
r) = p
" " p -> p -> p
forall a. Semigroup a => a -> a -> a
<> p
f p -> p -> p
forall a. Semigroup a => a -> a -> a
<> [p] -> p
go [p]
r

builder_list :: [Builder] -> Builder
builder_list :: [Builder] -> Builder
builder_list [] = Builder
"()"
builder_list (Builder
h:[Builder]
l) = Builder -> [Builder] -> Builder
app_list Builder
h [Builder]
l

------------------------------------------------------------------------
-- Term

-- | A term in the output language.
type family Term (h :: Type) :: Type

------------------------------------------------------------------------
-- SMTExpr

-- | An expresion for the SMT solver together with information about its type.
data SMTExpr h (tp :: BaseType) where
  SMTName :: !(TypeMap tp) -> !Text -> SMTExpr h tp
  SMTExpr :: !(TypeMap tp) -> !(Term h) -> SMTExpr h tp

-- | Converts an SMT to a base expression.
asBase :: SupportTermOps (Term h)
       => SMTExpr h tp
       -> Term h
asBase :: SMTExpr h tp -> Term h
asBase (SMTName TypeMap tp
_ Text
n) = Text -> Term h
forall v. SupportTermOps v => Text -> v
fromText Text
n
asBase (SMTExpr TypeMap tp
_ Term h
e) = Term h
e

smtExprType :: SMTExpr h tp -> TypeMap tp
smtExprType :: SMTExpr h tp -> TypeMap tp
smtExprType (SMTName TypeMap tp
tp Text
_) = TypeMap tp
tp
smtExprType (SMTExpr TypeMap tp
tp Term h
_) = TypeMap tp
tp

------------------------------------------------------------------------
-- WriterState

-- | State for writer.
data WriterState = WriterState { WriterState -> Word64
_nextTermIdx :: !Word64
                               , WriterState -> Position
_lastPosition :: !Position
                               , WriterState -> Position
_position     :: !Position
                               }

-- | The next index to use in dynamically generating a variable name.
nextTermIdx :: Lens' WriterState Word64
nextTermIdx :: (Word64 -> f Word64) -> WriterState -> f WriterState
nextTermIdx = (WriterState -> Word64)
-> (WriterState -> Word64 -> WriterState)
-> Lens WriterState WriterState Word64 Word64
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens WriterState -> Word64
_nextTermIdx (\WriterState
s Word64
v -> WriterState
s { _nextTermIdx :: Word64
_nextTermIdx = Word64
v })

-- | Last position written to file.
lastPosition :: Lens' WriterState Position
lastPosition :: (Position -> f Position) -> WriterState -> f WriterState
lastPosition = (WriterState -> Position)
-> (WriterState -> Position -> WriterState)
-> Lens WriterState WriterState Position Position
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens WriterState -> Position
_lastPosition (\WriterState
s Position
v -> WriterState
s { _lastPosition :: Position
_lastPosition = Position
v })

-- | Position written to file.
position :: Lens' WriterState Position
position :: (Position -> f Position) -> WriterState -> f WriterState
position = (WriterState -> Position)
-> (WriterState -> Position -> WriterState)
-> Lens WriterState WriterState Position Position
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens WriterState -> Position
_position (\WriterState
s Position
v -> WriterState
s { _position :: Position
_position = Position
v })

emptyState :: WriterState
emptyState :: WriterState
emptyState = WriterState :: Word64 -> Position -> Position -> WriterState
WriterState { _nextTermIdx :: Word64
_nextTermIdx     = Word64
0
                         , _lastPosition :: Position
_lastPosition = Position
InternalPos
                         , _position :: Position
_position     = Position
InternalPos
                         }

-- | Create a new variable
--
-- Variable names have a prefix, an exclamation mark and a unique number.
-- The MSS system ensures that no
freshVarName :: State WriterState Text
freshVarName :: State WriterState Text
freshVarName = Builder -> State WriterState Text
freshVarName' Builder
"x!"

-- | Create a new variable
--
-- Variable names have a prefix, an exclamation mark and a unique number.
-- The MSS system ensures that no
freshVarName' :: Builder -> State WriterState Text
freshVarName' :: Builder -> State WriterState Text
freshVarName' Builder
prefix = do
  Word64
n <- Getting Word64 WriterState Word64
-> StateT WriterState Identity Word64
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
use Getting Word64 WriterState Word64
Lens WriterState WriterState Word64 Word64
nextTermIdx
  (Word64 -> Identity Word64) -> WriterState -> Identity WriterState
Lens WriterState WriterState Word64 Word64
nextTermIdx ((Word64 -> Identity Word64)
 -> WriterState -> Identity WriterState)
-> Word64 -> StateT WriterState Identity ()
forall s (m :: Type -> Type) a.
(MonadState s m, Num a) =>
ASetter' s a -> a -> m ()
+= Word64
1
  Text -> State WriterState Text
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text -> State WriterState Text) -> Text -> State WriterState Text
forall a b. (a -> b) -> a -> b
$! (Text -> Text
Lazy.toStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Builder -> Text
Builder.toLazyText (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ Builder
prefix Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word64 -> Builder
forall a. Integral a => a -> Builder
Builder.decimal Word64
n)

------------------------------------------------------------------------
-- SMTWriter

data SMTSymFn ctx where
  SMTSymFn :: !Text
           -> !(Ctx.Assignment TypeMap args)
           -> !(TypeMap ret)
           -> SMTSymFn (args Ctx.::> ret)

data StackEntry t (h :: Type) = StackEntry
  { StackEntry t h -> IdxCache t (SMTExpr h)
symExprCache :: !(IdxCache t (SMTExpr h))
  , StackEntry t h -> HashTable RealWorld (Nonce t) SMTSymFn
symFnCache :: !(PH.HashTable PH.RealWorld (Nonce t) SMTSymFn)
  }

-- The writer connection maintains a connection to the SMT solver.
--
-- It is responsible for knowing the capabilities of the solver; generating
-- fresh names when needed; maintaining the stack of pushes and pops, and
-- sending queries to the solver.
--
-- A WriterConn should be used in a single-threaded manner or using external
-- synchronization to ensure that only one thread is accessing this connection
-- at a time, otherwise race conditions and unpredictable results may occur.
data WriterConn t (h :: Type) =
  WriterConn { WriterConn t h -> String
smtWriterName :: !String
               -- ^ Name of writer for error reporting purposes.
             , WriterConn t h -> OutputStream Text
connHandle :: !(OutputStream Text)
               -- ^ Handle to write to

             , WriterConn t h -> InputStream Text
connInputHandle :: !(InputStream Text)
               -- ^ Handle to read responses from.  In some contexts, there
               --   are no responses expected (e.g., if we are writing a problem
               --   directly to a file); in these cases, the input stream might
               --   be the trivial stream @nullInput@, which just immediately
               --   returns EOF.

             , WriterConn t h -> Bool
supportFunctionDefs :: !Bool
               -- ^ Indicates if the writer can define constants or functions in terms
               -- of an expression.
               --
               -- If this is not supported, we can only declare free variables, and
               -- assert that they are equal.
             , WriterConn t h -> Bool
supportFunctionArguments :: !Bool
               -- ^ Functions may be passed as arguments to other functions.
               --
               -- We currently never allow SMT_FnType to appear in structs or array
               -- indices.
             , WriterConn t h -> Bool
supportQuantifiers :: !Bool
               -- ^ Allow the SMT writer to generate problems with quantifiers.
             , WriterConn t h -> ProblemFeatures
supportedFeatures :: !ProblemFeatures
               -- ^ Indicates features supported by the solver.
             , WriterConn t h -> IORef [StackEntry t h]
entryStack :: !(IORef [StackEntry t h])
               -- ^ A stack of pairs of hash tables, each stack entry corresponding to
               --   a lexical scope induced by frame push/pops. The entire stack is searched
               --   top-down when looking up element nonce values. Elements that are to
               --   persist across pops are written through the entire stack.
             , WriterConn t h -> IORef WriterState
stateRef :: !(IORef WriterState)
               -- ^ Reference to current state
             , WriterConn t h -> SymbolVarBimap t
varBindings :: !(SymbolVarBimap t)
               -- ^ Symbol variables.
             , WriterConn t h -> h
connState :: !h
               -- ^ The specific connection information.
             , WriterConn t h -> AcknowledgementAction t h
consumeAcknowledgement :: AcknowledgementAction t h
               -- ^ Consume an acknowledgement notifications the solver, if
               --   it produces one
             }

-- | An action for consuming an acknowledgement message from the solver,
--   if it is configured to produce ack messages.
newtype AcknowledgementAction t h =
  AckAction { AcknowledgementAction t h -> WriterConn t h -> Command h -> IO ()
runAckAction :: WriterConn t h -> Command h -> IO () }

-- | An acknowledgement action that does nothing
nullAcknowledgementAction :: AcknowledgementAction t h
nullAcknowledgementAction :: AcknowledgementAction t h
nullAcknowledgementAction = (WriterConn t h -> Command h -> IO ()) -> AcknowledgementAction t h
forall t h.
(WriterConn t h -> Command h -> IO ()) -> AcknowledgementAction t h
AckAction (\WriterConn t h
_ Command h
_ -> () -> IO ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ())

newStackEntry :: IO (StackEntry t h)
newStackEntry :: IO (StackEntry t h)
newStackEntry = do
  IdxCache t (SMTExpr h)
exprCache <- IO (IdxCache t (SMTExpr h))
forall (m :: Type -> Type) t (f :: BaseType -> Type).
MonadIO m =>
m (IdxCache t f)
newIdxCache
  HashTable RealWorld (Nonce t) SMTSymFn
fnCache   <- ST RealWorld (HashTable RealWorld (Nonce t) SMTSymFn)
-> IO (HashTable RealWorld (Nonce t) SMTSymFn)
forall a. ST RealWorld a -> IO a
stToIO (ST RealWorld (HashTable RealWorld (Nonce t) SMTSymFn)
 -> IO (HashTable RealWorld (Nonce t) SMTSymFn))
-> ST RealWorld (HashTable RealWorld (Nonce t) SMTSymFn)
-> IO (HashTable RealWorld (Nonce t) SMTSymFn)
forall a b. (a -> b) -> a -> b
$ ST RealWorld (HashTable RealWorld (Nonce t) SMTSymFn)
forall k s (key :: k -> Type) (val :: k -> Type).
ST s (HashTable s key val)
PH.new
  StackEntry t h -> IO (StackEntry t h)
forall (m :: Type -> Type) a. Monad m => a -> m a
return StackEntry :: forall t h.
IdxCache t (SMTExpr h)
-> HashTable RealWorld (Nonce t) SMTSymFn -> StackEntry t h
StackEntry
    { symExprCache :: IdxCache t (SMTExpr h)
symExprCache = IdxCache t (SMTExpr h)
exprCache
    , symFnCache :: HashTable RealWorld (Nonce t) SMTSymFn
symFnCache   = HashTable RealWorld (Nonce t) SMTSymFn
fnCache
    }

-- | Clear the entry stack, and start with a fresh one.
resetEntryStack :: WriterConn t h -> IO ()
resetEntryStack :: WriterConn t h -> IO ()
resetEntryStack WriterConn t h
c = do
  StackEntry t h
entry <- IO (StackEntry t h)
forall t h. IO (StackEntry t h)
newStackEntry
  IORef [StackEntry t h] -> [StackEntry t h] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (WriterConn t h -> IORef [StackEntry t h]
forall t h. WriterConn t h -> IORef [StackEntry t h]
entryStack WriterConn t h
c) [StackEntry t h
entry]


-- | Pop all but the topmost stack entry.
--   Return the number of entries on the stack prior
--   to popping.
popEntryStackToTop :: WriterConn t h -> IO Int
popEntryStackToTop :: WriterConn t h -> IO Int
popEntryStackToTop WriterConn t h
c = do
  [StackEntry t h]
stk <- IORef [StackEntry t h] -> IO [StackEntry t h]
forall a. IORef a -> IO a
readIORef (WriterConn t h -> IORef [StackEntry t h]
forall t h. WriterConn t h -> IORef [StackEntry t h]
entryStack WriterConn t h
c)
  if [StackEntry t h] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [StackEntry t h]
stk then
    do StackEntry t h
entry <- IO (StackEntry t h)
forall t h. IO (StackEntry t h)
newStackEntry
       IORef [StackEntry t h] -> [StackEntry t h] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (WriterConn t h -> IORef [StackEntry t h]
forall t h. WriterConn t h -> IORef [StackEntry t h]
entryStack WriterConn t h
c) [StackEntry t h
entry]
       Int -> IO Int
forall (m :: Type -> Type) a. Monad m => a -> m a
return Int
0
  else
    do IORef [StackEntry t h] -> [StackEntry t h] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (WriterConn t h -> IORef [StackEntry t h]
forall t h. WriterConn t h -> IORef [StackEntry t h]
entryStack WriterConn t h
c) [[StackEntry t h] -> StackEntry t h
forall a. [a] -> a
last [StackEntry t h]
stk]
       Int -> IO Int
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([StackEntry t h] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [StackEntry t h]
stk)

-- | Return the number of pushed stack frames.  Note, this is one
--   fewer than the number of entries in the stack beacuse the
--   base entry is the top-level context that is not in the scope
--   of any push.
entryStackHeight :: WriterConn t h -> IO Int
entryStackHeight :: WriterConn t h -> IO Int
entryStackHeight WriterConn t h
c =
  do [StackEntry t h]
es <- IORef [StackEntry t h] -> IO [StackEntry t h]
forall a. IORef a -> IO a
readIORef (WriterConn t h -> IORef [StackEntry t h]
forall t h. WriterConn t h -> IORef [StackEntry t h]
entryStack WriterConn t h
c)
     Int -> IO Int
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([StackEntry t h] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [StackEntry t h]
es Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

-- | Push a new frame to the stack for maintaining the writer cache.
pushEntryStack :: WriterConn t h -> IO ()
pushEntryStack :: WriterConn t h -> IO ()
pushEntryStack WriterConn t h
c = do
  StackEntry t h
entry <- IO (StackEntry t h)
forall t h. IO (StackEntry t h)
newStackEntry
  IORef [StackEntry t h]
-> ([StackEntry t h] -> [StackEntry t h]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (WriterConn t h -> IORef [StackEntry t h]
forall t h. WriterConn t h -> IORef [StackEntry t h]
entryStack WriterConn t h
c) (([StackEntry t h] -> [StackEntry t h]) -> IO ())
-> ([StackEntry t h] -> [StackEntry t h]) -> IO ()
forall a b. (a -> b) -> a -> b
$ (StackEntry t h
entryStackEntry t h -> [StackEntry t h] -> [StackEntry t h]
forall a. a -> [a] -> [a]
:)

popEntryStack :: WriterConn t h -> IO ()
popEntryStack :: WriterConn t h -> IO ()
popEntryStack WriterConn t h
c = do
  [StackEntry t h]
stk <- IORef [StackEntry t h] -> IO [StackEntry t h]
forall a. IORef a -> IO a
readIORef (WriterConn t h -> IORef [StackEntry t h]
forall t h. WriterConn t h -> IORef [StackEntry t h]
entryStack WriterConn t h
c)
  case [StackEntry t h]
stk of
   []  -> String -> IO ()
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Could not pop from empty entry stack."
   [StackEntry t h
_] -> String -> IO ()
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Could not pop from empty entry stack."
   (StackEntry t h
_:[StackEntry t h]
r) -> IORef [StackEntry t h] -> [StackEntry t h] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (WriterConn t h -> IORef [StackEntry t h]
forall t h. WriterConn t h -> IORef [StackEntry t h]
entryStack WriterConn t h
c) [StackEntry t h]
r

newWriterConn :: OutputStream Text
              -- ^ Stream to write queries onto
              -> InputStream Text
              -- ^ Input stream to read responses from
              --   (may be the @nullInput@ stream if no responses are expected)
              -> AcknowledgementAction t cs
              -- ^ An action to consume solver acknowledgement responses
              -> String
              -- ^ Name of solver for reporting purposes.
              -> ProblemFeatures
              -- ^ Indicates what features are supported by the solver.
              -> SymbolVarBimap t
              -- ^ A bijective mapping between variables and their
              -- canonical name (if any).
              -> cs -- ^ State information specific to the type of connection
              -> IO (WriterConn t cs)
newWriterConn :: OutputStream Text
-> InputStream Text
-> AcknowledgementAction t cs
-> String
-> ProblemFeatures
-> SymbolVarBimap t
-> cs
-> IO (WriterConn t cs)
newWriterConn OutputStream Text
h InputStream Text
in_h AcknowledgementAction t cs
ack String
solver_name ProblemFeatures
features SymbolVarBimap t
bindings cs
cs = do
  StackEntry t cs
entry <- IO (StackEntry t cs)
forall t h. IO (StackEntry t h)
newStackEntry
  IORef [StackEntry t cs]
stk_ref <- [StackEntry t cs] -> IO (IORef [StackEntry t cs])
forall a. a -> IO (IORef a)
newIORef [StackEntry t cs
entry]
  IORef WriterState
r <- WriterState -> IO (IORef WriterState)
forall a. a -> IO (IORef a)
newIORef WriterState
emptyState
  WriterConn t cs -> IO (WriterConn t cs)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (WriterConn t cs -> IO (WriterConn t cs))
-> WriterConn t cs -> IO (WriterConn t cs)
forall a b. (a -> b) -> a -> b
$! WriterConn :: forall t h.
String
-> OutputStream Text
-> InputStream Text
-> Bool
-> Bool
-> Bool
-> ProblemFeatures
-> IORef [StackEntry t h]
-> IORef WriterState
-> SymbolVarBimap t
-> h
-> AcknowledgementAction t h
-> WriterConn t h
WriterConn { smtWriterName :: String
smtWriterName = String
solver_name
                       , connHandle :: OutputStream Text
connHandle    = OutputStream Text
h
                       , connInputHandle :: InputStream Text
connInputHandle = InputStream Text
in_h
                       , supportFunctionDefs :: Bool
supportFunctionDefs      = Bool
False
                       , supportFunctionArguments :: Bool
supportFunctionArguments = Bool
False
                       , supportQuantifiers :: Bool
supportQuantifiers       = Bool
False
                       , supportedFeatures :: ProblemFeatures
supportedFeatures        = ProblemFeatures
features
                       , entryStack :: IORef [StackEntry t cs]
entryStack   = IORef [StackEntry t cs]
stk_ref
                       , stateRef :: IORef WriterState
stateRef     = IORef WriterState
r
                       , varBindings :: SymbolVarBimap t
varBindings  = SymbolVarBimap t
bindings
                       , connState :: cs
connState    = cs
cs
                       , consumeAcknowledgement :: AcknowledgementAction t cs
consumeAcknowledgement = AcknowledgementAction t cs
ack
                       }

-- | Status to indicate when term value will be uncached.
data TermLifetime
   = DeleteNever
     -- ^ Never delete the term
   | DeleteOnPop
     -- ^ Delete the term when the current frame is popped.
  deriving (TermLifetime -> TermLifetime -> Bool
(TermLifetime -> TermLifetime -> Bool)
-> (TermLifetime -> TermLifetime -> Bool) -> Eq TermLifetime
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TermLifetime -> TermLifetime -> Bool
$c/= :: TermLifetime -> TermLifetime -> Bool
== :: TermLifetime -> TermLifetime -> Bool
$c== :: TermLifetime -> TermLifetime -> Bool
Eq)

cacheValue
  :: WriterConn t h
  -> TermLifetime
  -> (StackEntry t h -> IO ())
  -> IO ()
cacheValue :: WriterConn t h
-> TermLifetime -> (StackEntry t h -> IO ()) -> IO ()
cacheValue WriterConn t h
conn TermLifetime
lifetime StackEntry t h -> IO ()
insert_action =
  IORef [StackEntry t h] -> IO [StackEntry t h]
forall a. IORef a -> IO a
readIORef (WriterConn t h -> IORef [StackEntry t h]
forall t h. WriterConn t h -> IORef [StackEntry t h]
entryStack WriterConn t h
conn) IO [StackEntry t h] -> ([StackEntry t h] -> IO ()) -> IO ()
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    s :: [StackEntry t h]
s@(StackEntry t h
h:[StackEntry t h]
_) -> case TermLifetime
lifetime of
      TermLifetime
DeleteOnPop -> StackEntry t h -> IO ()
insert_action StackEntry t h
h
      TermLifetime
DeleteNever -> (StackEntry t h -> IO ()) -> [StackEntry t h] -> IO ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ StackEntry t h -> IO ()
insert_action [StackEntry t h]
s
    [] -> String -> IO ()
forall a. HasCallStack => String -> a
error String
"cacheValue: empty cache stack!"

cacheLookup
  :: WriterConn t h
  -> (StackEntry t h -> IO (Maybe a))
  -> IO (Maybe a)
cacheLookup :: WriterConn t h -> (StackEntry t h -> IO (Maybe a)) -> IO (Maybe a)
cacheLookup WriterConn t h
conn StackEntry t h -> IO (Maybe a)
lookup_action =
  IORef [StackEntry t h] -> IO [StackEntry t h]
forall a. IORef a -> IO a
readIORef (WriterConn t h -> IORef [StackEntry t h]
forall t h. WriterConn t h -> IORef [StackEntry t h]
entryStack WriterConn t h
conn) IO [StackEntry t h]
-> ([StackEntry t h] -> IO (Maybe a)) -> IO (Maybe a)
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= (StackEntry t h -> IO (Maybe a))
-> [StackEntry t h] -> IO (Maybe a)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m (Maybe b)
firstJustM StackEntry t h -> IO (Maybe a)
lookup_action

cacheLookupExpr :: WriterConn t h -> Nonce t tp -> IO (Maybe (SMTExpr h tp))
cacheLookupExpr :: WriterConn t h -> Nonce t tp -> IO (Maybe (SMTExpr h tp))
cacheLookupExpr WriterConn t h
c Nonce t tp
n = WriterConn t h
-> (StackEntry t h -> IO (Maybe (SMTExpr h tp)))
-> IO (Maybe (SMTExpr h tp))
forall t h a.
WriterConn t h -> (StackEntry t h -> IO (Maybe a)) -> IO (Maybe a)
cacheLookup WriterConn t h
c ((StackEntry t h -> IO (Maybe (SMTExpr h tp)))
 -> IO (Maybe (SMTExpr h tp)))
-> (StackEntry t h -> IO (Maybe (SMTExpr h tp)))
-> IO (Maybe (SMTExpr h tp))
forall a b. (a -> b) -> a -> b
$ \StackEntry t h
entry ->
  IdxCache t (SMTExpr h) -> Nonce t tp -> IO (Maybe (SMTExpr h tp))
forall (m :: Type -> Type) t (f :: BaseType -> Type)
       (tp :: BaseType).
MonadIO m =>
IdxCache t f -> Nonce t tp -> m (Maybe (f tp))
lookupIdx (StackEntry t h -> IdxCache t (SMTExpr h)
forall t h. StackEntry t h -> IdxCache t (SMTExpr h)
symExprCache StackEntry t h
entry) Nonce t tp
n

cacheLookupFn :: WriterConn t h -> Nonce t ctx -> IO (Maybe (SMTSymFn ctx))
cacheLookupFn :: WriterConn t h -> Nonce t ctx -> IO (Maybe (SMTSymFn ctx))
cacheLookupFn WriterConn t h
c Nonce t ctx
n = WriterConn t h
-> (StackEntry t h -> IO (Maybe (SMTSymFn ctx)))
-> IO (Maybe (SMTSymFn ctx))
forall t h a.
WriterConn t h -> (StackEntry t h -> IO (Maybe a)) -> IO (Maybe a)
cacheLookup WriterConn t h
c ((StackEntry t h -> IO (Maybe (SMTSymFn ctx)))
 -> IO (Maybe (SMTSymFn ctx)))
-> (StackEntry t h -> IO (Maybe (SMTSymFn ctx)))
-> IO (Maybe (SMTSymFn ctx))
forall a b. (a -> b) -> a -> b
$ \StackEntry t h
entry ->
  ST RealWorld (Maybe (SMTSymFn ctx)) -> IO (Maybe (SMTSymFn ctx))
forall a. ST RealWorld a -> IO a
stToIO (ST RealWorld (Maybe (SMTSymFn ctx)) -> IO (Maybe (SMTSymFn ctx)))
-> ST RealWorld (Maybe (SMTSymFn ctx)) -> IO (Maybe (SMTSymFn ctx))
forall a b. (a -> b) -> a -> b
$ HashTable RealWorld (Nonce t) SMTSymFn
-> Nonce t ctx -> ST RealWorld (Maybe (SMTSymFn ctx))
forall k (key :: k -> Type) s (val :: k -> Type) (tp :: k).
(HashableF key, TestEquality key) =>
HashTable s key val -> key tp -> ST s (Maybe (val tp))
PH.lookup (StackEntry t h -> HashTable RealWorld (Nonce t) SMTSymFn
forall t h.
StackEntry t h -> HashTable RealWorld (Nonce t) SMTSymFn
symFnCache StackEntry t h
entry) Nonce t ctx
n

cacheValueExpr
  :: WriterConn t h -> Nonce t tp -> TermLifetime -> SMTExpr h tp -> IO ()
cacheValueExpr :: WriterConn t h
-> Nonce t tp -> TermLifetime -> SMTExpr h tp -> IO ()
cacheValueExpr WriterConn t h
conn Nonce t tp
n TermLifetime
lifetime SMTExpr h tp
value = WriterConn t h
-> TermLifetime -> (StackEntry t h -> IO ()) -> IO ()
forall t h.
WriterConn t h
-> TermLifetime -> (StackEntry t h -> IO ()) -> IO ()
cacheValue WriterConn t h
conn TermLifetime
lifetime ((StackEntry t h -> IO ()) -> IO ())
-> (StackEntry t h -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \StackEntry t h
entry ->
  IdxCache t (SMTExpr h) -> Nonce t tp -> SMTExpr h tp -> IO ()
forall (m :: Type -> Type) t (f :: BaseType -> Type)
       (tp :: BaseType).
MonadIO m =>
IdxCache t f -> Nonce t tp -> f tp -> m ()
insertIdxValue (StackEntry t h -> IdxCache t (SMTExpr h)
forall t h. StackEntry t h -> IdxCache t (SMTExpr h)
symExprCache StackEntry t h
entry) Nonce t tp
n SMTExpr h tp
value

cacheValueFn
  :: WriterConn t h -> Nonce t ctx -> TermLifetime -> SMTSymFn ctx -> IO ()
cacheValueFn :: WriterConn t h
-> Nonce t ctx -> TermLifetime -> SMTSymFn ctx -> IO ()
cacheValueFn WriterConn t h
conn Nonce t ctx
n TermLifetime
lifetime SMTSymFn ctx
value = WriterConn t h
-> TermLifetime -> (StackEntry t h -> IO ()) -> IO ()
forall t h.
WriterConn t h
-> TermLifetime -> (StackEntry t h -> IO ()) -> IO ()
cacheValue WriterConn t h
conn TermLifetime
lifetime ((StackEntry t h -> IO ()) -> IO ())
-> (StackEntry t h -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \StackEntry t h
entry ->
  ST RealWorld () -> IO ()
forall a. ST RealWorld a -> IO a
stToIO (ST RealWorld () -> IO ()) -> ST RealWorld () -> IO ()
forall a b. (a -> b) -> a -> b
$ HashTable RealWorld (Nonce t) SMTSymFn
-> Nonce t ctx -> SMTSymFn ctx -> ST RealWorld ()
forall k (key :: k -> Type) s (val :: k -> Type) (tp :: k).
(HashableF key, TestEquality key) =>
HashTable s key val -> key tp -> val tp -> ST s ()
PH.insert (StackEntry t h -> HashTable RealWorld (Nonce t) SMTSymFn
forall t h.
StackEntry t h -> HashTable RealWorld (Nonce t) SMTSymFn
symFnCache StackEntry t h
entry) Nonce t ctx
n SMTSymFn ctx
value

-- | Run state with handle.
withWriterState :: WriterConn t h -> State WriterState a -> IO a
withWriterState :: WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
c State WriterState a
m = do
  WriterState
s0 <- IORef WriterState -> IO WriterState
forall a. IORef a -> IO a
readIORef (WriterConn t h -> IORef WriterState
forall t h. WriterConn t h -> IORef WriterState
stateRef WriterConn t h
c)
  let (a
v,WriterState
s) = State WriterState a -> WriterState -> (a, WriterState)
forall s a. State s a -> s -> (a, s)
runState State WriterState a
m WriterState
s0
  IORef WriterState -> WriterState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (WriterConn t h -> IORef WriterState
forall t h. WriterConn t h -> IORef WriterState
stateRef WriterConn t h
c) (WriterState -> IO ()) -> WriterState -> IO ()
forall a b. (a -> b) -> a -> b
$! WriterState
s
  a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return a
v

-- | Update the current program location to the given one.
updateProgramLoc :: WriterConn t h -> ProgramLoc -> IO ()
updateProgramLoc :: WriterConn t h -> ProgramLoc -> IO ()
updateProgramLoc WriterConn t h
c ProgramLoc
l = WriterConn t h -> StateT WriterState Identity () -> IO ()
forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
c (StateT WriterState Identity () -> IO ())
-> StateT WriterState Identity () -> IO ()
forall a b. (a -> b) -> a -> b
$ (Position -> Identity Position)
-> WriterState -> Identity WriterState
Lens WriterState WriterState Position Position
position ((Position -> Identity Position)
 -> WriterState -> Identity WriterState)
-> Position -> StateT WriterState Identity ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= ProgramLoc -> Position
plSourceLoc ProgramLoc
l

type family Command (h :: Type) :: Type

-- | Typeclass need to generate SMTLIB commands.
class (SupportTermOps (Term h)) => SMTWriter h where

  -- | Create a forall expression
  forallExpr :: [(Text, Some TypeMap)] -> Term h -> Term h

  -- | Create an exists expression
  existsExpr :: [(Text, Some TypeMap)] -> Term h -> Term h

  -- | Create a constant array
  --
  -- This may return Nothing if the solver does not support constant arrays.
  arrayConstant :: Maybe (ArrayConstantFn (Term h))
  arrayConstant = Maybe (ArrayConstantFn (Term h))
forall a. Maybe a
Nothing

  -- | Select an element from an array
  arraySelect :: Term h -> [Term h] -> Term h

  -- | 'arrayUpdate a i v' returns an array that contains value 'v' at
  -- index 'i', and the same value as in 'a' at every other index.
  arrayUpdate :: Term h -> [Term h] -> Term h -> Term h

  -- | Create a command that just defines a comment.
  commentCommand :: f h -> Builder -> Command h

  -- | Create a command that asserts a formula.
  assertCommand :: f h -> Term h -> Command h

  -- | Create a command that asserts a formula and attaches
  --   the given name to it (primarily for the purposes of
  --   later reporting unsatisfiable cores).
  assertNamedCommand :: f h -> Term h -> Text -> Command h

  -- | Push 1 new scope
  pushCommand   :: f h -> Command h

  -- | Pop 1 existing scope
  popCommand    :: f h -> Command h

  -- | Pop several scopes.
  popManyCommands :: f h -> Int -> [Command h]
  popManyCommands f h
w Int
n = Int -> Command h -> [Command h]
forall a. Int -> a -> [a]
replicate Int
n (f h -> Command h
forall h (f :: Type -> Type). SMTWriter h => f h -> Command h
popCommand f h
w)

  -- | Reset the solver state, forgetting all pushed frames and assertions
  resetCommand  :: f h -> Command h

  -- | Check if the current set of assumption is satisfiable. May
  -- require multiple commands. The intial commands require an ack. The
  -- last one does not.
  checkCommands  :: f h -> [Command h]

  -- | Check if a collection of assumptions is satisfiable in the current context.
  --   The assumptions must be given as the names of literals already in scope.
  checkWithAssumptionsCommands :: f h -> [Text] -> [Command h]

  -- | Ask the solver to return an unsatisfiable core from among the assumptions
  --   passed into the previous "check with assumptions" command.
  getUnsatAssumptionsCommand :: f h -> Command h

  -- | Ask the solver to return an unsatisfiable core from among the named assumptions
  --   previously asserted using the `assertNamedCommand` after an unsatisfiable
  --   `checkCommand`.
  getUnsatCoreCommand :: f h -> Command h

  -- | Set an option/parameter.
  setOptCommand :: f h -> Text -> Text -> Command h

  -- | Declare a new symbol with the given name, arguments types, and result type.
  declareCommand :: f h
                 -> Text
                 -> Ctx.Assignment TypeMap args
                 -> TypeMap rtp
                 -> Command h

  -- | Define a new symbol with the given name, arguments, result type, and
  -- associated expression.
  --
  -- The argument contains the variable name and the type of the variable.
  defineCommand :: f h
                -> Text -- ^ Name of variable
                -> [(Text, Some TypeMap)]
                -> TypeMap rtp
                -> Term h
                -> Command h

  -- | Declare a struct datatype if is has not been already given the number of
  -- arguments in the struct.
  declareStructDatatype :: WriterConn t h -> Ctx.Assignment TypeMap args -> IO ()

  -- | Build a struct term with the given types and fields
  structCtor :: Ctx.Assignment TypeMap args -> [Term h] -> Term h

  -- | Project a field from a struct with the given types
  structProj :: Ctx.Assignment TypeMap args -> Ctx.Index args tp -> Term h -> Term h

  -- | Produce a term representing a string literal
  stringTerm :: ByteString -> Term h

  -- | Compute the length of a term
  stringLength :: Term h -> Term h

  -- | @stringIndexOf s t i@ computes the first index following or at i
  --   where @t@ appears within @s@ as a substring, or -1 if no such
  --   index exists
  stringIndexOf :: Term h -> Term h -> Term h -> Term h

  -- | Test if the first string contains the second string
  stringContains :: Term h -> Term h -> Term h

  -- | Test if the first string is a prefix of the second string
  stringIsPrefixOf :: Term h -> Term h -> Term h

  -- | Test if the first string is a suffix of the second string
  stringIsSuffixOf :: Term h -> Term h -> Term h

  -- | @stringSubstring s off len@ extracts the substring of @s@ starting at index @off@ and
  --   having length @len@.  The result of this operation is undefined if @off@ and @len@
  --   to not specify a valid substring of @s@; in particular, we must have @off+len <= length(s)@.
  stringSubstring :: Term h -> Term h -> Term h -> Term h

  -- | Append the given strings
  stringAppend :: [Term h] -> Term h

  -- | Forget all previously-declared struct types.
  resetDeclaredStructs :: WriterConn t h -> IO ()

  -- | Write a command to the connection.
  writeCommand :: WriterConn t h -> Command h -> IO ()

-- | Write a command to the connection along with position information
-- if it differs from the last position.
addCommand :: SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommand :: WriterConn t h -> Command h -> IO ()
addCommand WriterConn t h
conn Command h
cmd = do
  WriterConn t h -> Command h -> IO ()
forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommandNoAck WriterConn t h
conn Command h
cmd
  AcknowledgementAction t h -> WriterConn t h -> Command h -> IO ()
forall t h.
AcknowledgementAction t h -> WriterConn t h -> Command h -> IO ()
runAckAction (WriterConn t h -> AcknowledgementAction t h
forall t h. WriterConn t h -> AcknowledgementAction t h
consumeAcknowledgement WriterConn t h
conn) WriterConn t h
conn Command h
cmd

addCommandNoAck :: SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommandNoAck :: WriterConn t h -> Command h -> IO ()
addCommandNoAck WriterConn t h
conn Command h
cmd = do
  Position
las <- WriterConn t h -> State WriterState Position -> IO Position
forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn (State WriterState Position -> IO Position)
-> State WriterState Position -> IO Position
forall a b. (a -> b) -> a -> b
$ Getting Position WriterState Position -> State WriterState Position
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
use Getting Position WriterState Position
Lens WriterState WriterState Position Position
lastPosition
  Position
cur <- WriterConn t h -> State WriterState Position -> IO Position
forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn (State WriterState Position -> IO Position)
-> State WriterState Position -> IO Position
forall a b. (a -> b) -> a -> b
$ Getting Position WriterState Position -> State WriterState Position
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
use Getting Position WriterState Position
Lens WriterState WriterState Position Position
position

  -- If the position of the last command differs from the current position, then
  -- write the current position and update the last position.
  Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Position
las Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
/= Position
cur) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    WriterConn t h -> Command h -> IO ()
forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
writeCommand WriterConn t h
conn (Command h -> IO ()) -> Command h -> IO ()
forall a b. (a -> b) -> a -> b
$ WriterConn t h -> Builder -> Command h
forall h (f :: Type -> Type).
SMTWriter h =>
f h -> Builder -> Command h
commentCommand WriterConn t h
conn (Builder -> Command h) -> Builder -> Command h
forall a b. (a -> b) -> a -> b
$ Text -> Builder
Builder.fromText (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String) -> Doc Any -> String
forall a b. (a -> b) -> a -> b
$ Position -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty Position
cur
    WriterConn t h -> StateT WriterState Identity () -> IO ()
forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn (StateT WriterState Identity () -> IO ())
-> StateT WriterState Identity () -> IO ()
forall a b. (a -> b) -> a -> b
$ (Position -> Identity Position)
-> WriterState -> Identity WriterState
Lens WriterState WriterState Position Position
lastPosition ((Position -> Identity Position)
 -> WriterState -> Identity WriterState)
-> Position -> StateT WriterState Identity ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Position
cur

  WriterConn t h -> Command h -> IO ()
forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
writeCommand WriterConn t h
conn Command h
cmd

-- | Write a sequence of commands. All but the last should have
-- acknowledgement.
addCommands :: SMTWriter h => WriterConn t h -> [Command h] -> IO ()
addCommands :: WriterConn t h -> [Command h] -> IO ()
addCommands WriterConn t h
_ [] = String -> IO ()
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"internal: empty list in addCommands"
addCommands WriterConn t h
conn [Command h]
cmds = do
  (Command h -> IO ()) -> [Command h] -> IO ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (WriterConn t h -> Command h -> IO ()
forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommand WriterConn t h
conn) ([Command h] -> [Command h]
forall a. [a] -> [a]
init [Command h]
cmds)
  WriterConn t h -> Command h -> IO ()
forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommandNoAck WriterConn t h
conn ([Command h] -> Command h
forall a. [a] -> a
last [Command h]
cmds)

-- | Create a new variable with the given name.
mkFreeVar :: SMTWriter h
          => WriterConn t h
          -> Ctx.Assignment TypeMap args
          -> TypeMap rtp
          -> IO Text
mkFreeVar :: WriterConn t h -> Assignment TypeMap args -> TypeMap rtp -> IO Text
mkFreeVar WriterConn t h
conn Assignment TypeMap args
arg_types TypeMap rtp
return_type = do
  Text
var <- WriterConn t h -> State WriterState Text -> IO Text
forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn (State WriterState Text -> IO Text)
-> State WriterState Text -> IO Text
forall a b. (a -> b) -> a -> b
$ State WriterState Text
freshVarName
  (forall (x :: BaseType). TypeMap x -> IO ())
-> Assignment TypeMap args -> IO ()
forall k l (t :: (k -> Type) -> l -> Type) (m :: Type -> Type)
       (f :: k -> Type) a.
(FoldableFC t, Applicative m) =>
(forall (x :: k). f x -> m a) -> forall (x :: l). t f x -> m ()
traverseFC_ (WriterConn t h -> TypeMap x -> IO ()
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn) Assignment TypeMap args
arg_types
  WriterConn t h -> TypeMap rtp -> IO ()
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn TypeMap rtp
return_type
  WriterConn t h -> Command h -> IO ()
forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommand WriterConn t h
conn (Command h -> IO ()) -> Command h -> IO ()
forall a b. (a -> b) -> a -> b
$ WriterConn t h
-> Text -> Assignment TypeMap args -> TypeMap rtp -> Command h
forall h (f :: Type -> Type) (args :: Ctx BaseType)
       (rtp :: BaseType).
SMTWriter h =>
f h -> Text -> Assignment TypeMap args -> TypeMap rtp -> Command h
declareCommand WriterConn t h
conn Text
var Assignment TypeMap args
arg_types TypeMap rtp
return_type
  Text -> IO Text
forall (m :: Type -> Type) a. Monad m => a -> m a
return Text
var

mkFreeVar' :: SMTWriter h => WriterConn t h -> TypeMap tp -> IO (SMTExpr h tp)
mkFreeVar' :: WriterConn t h -> TypeMap tp -> IO (SMTExpr h tp)
mkFreeVar' WriterConn t h
conn TypeMap tp
tp = TypeMap tp -> Text -> SMTExpr h tp
forall (tp :: BaseType) h. TypeMap tp -> Text -> SMTExpr h tp
SMTName TypeMap tp
tp (Text -> SMTExpr h tp) -> IO Text -> IO (SMTExpr h tp)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterConn t h
-> Assignment TypeMap EmptyCtx -> TypeMap tp -> IO Text
forall h t (args :: Ctx BaseType) (rtp :: BaseType).
SMTWriter h =>
WriterConn t h -> Assignment TypeMap args -> TypeMap rtp -> IO Text
mkFreeVar WriterConn t h
conn Assignment TypeMap EmptyCtx
forall k (f :: k -> Type). Assignment f EmptyCtx
Ctx.empty TypeMap tp
tp

-- | Consider the bound variable as free within the current assumption frame.
bindVarAsFree :: SMTWriter h
              => WriterConn t h
              -> ExprBoundVar t tp
              -> IO ()
bindVarAsFree :: WriterConn t h -> ExprBoundVar t tp -> IO ()
bindVarAsFree WriterConn t h
conn ExprBoundVar t tp
var = do
  WriterConn t h -> Nonce t tp -> IO (Maybe (SMTExpr h tp))
forall t h (tp :: BaseType).
WriterConn t h -> Nonce t tp -> IO (Maybe (SMTExpr h tp))
cacheLookupExpr WriterConn t h
conn (ExprBoundVar t tp -> Nonce t tp
forall t (tp :: BaseType). ExprBoundVar t tp -> Nonce t tp
bvarId ExprBoundVar t tp
var) IO (Maybe (SMTExpr h tp))
-> (Maybe (SMTExpr h tp) -> IO ()) -> IO ()
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just SMTExpr h tp
_ -> String -> IO ()
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Internal error in SMTLIB exporter: bound variables cannot be made free."
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ Nonce t tp -> String
forall a. Show a => a -> String
show (ExprBoundVar t tp -> Nonce t tp
forall t (tp :: BaseType). ExprBoundVar t tp -> Nonce t tp
bvarId ExprBoundVar t tp
var) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" defined at "
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ Position -> String
forall a. Show a => a -> String
show (ProgramLoc -> Position
plSourceLoc (ExprBoundVar t tp -> ProgramLoc
forall t (tp :: BaseType). ExprBoundVar t tp -> ProgramLoc
bvarLoc ExprBoundVar t tp
var)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
    Maybe (SMTExpr h tp)
Nothing -> do
      TypeMap tp
smt_type <- WriterConn t h -> SMTCollector t h (TypeMap tp) -> IO (TypeMap tp)
forall h t a.
SMTWriter h =>
WriterConn t h -> SMTCollector t h a -> IO a
runOnLiveConnection WriterConn t h
conn (SMTCollector t h (TypeMap tp) -> IO (TypeMap tp))
-> SMTCollector t h (TypeMap tp) -> IO (TypeMap tp)
forall a b. (a -> b) -> a -> b
$ do
        ExprBoundVar t tp -> SMTCollector t h ()
forall n (tp :: BaseType) h.
ExprBoundVar n tp -> SMTCollector n h ()
checkVarTypeSupport ExprBoundVar t tp
var
        ExprBoundVar t tp -> SMTCollector t h (TypeMap tp)
forall t (tp :: BaseType) h.
ExprBoundVar t tp -> SMTCollector t h (TypeMap tp)
getBaseSMT_Type ExprBoundVar t tp
var
      Text
var_name <- WriterConn t h -> SymbolBinding t -> IO Text
forall t h. WriterConn t h -> SymbolBinding t -> IO Text
getSymbolName WriterConn t h
conn (ExprBoundVar t tp -> SymbolBinding t
forall t (tp :: BaseType). ExprBoundVar t tp -> SymbolBinding t
VarSymbolBinding ExprBoundVar t tp
var)
      WriterConn t h -> TypeMap tp -> IO ()
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn TypeMap tp
smt_type
      WriterConn t h -> Command h -> IO ()
forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommand WriterConn t h
conn (Command h -> IO ()) -> Command h -> IO ()
forall a b. (a -> b) -> a -> b
$ WriterConn t h
-> Text -> Assignment TypeMap EmptyCtx -> TypeMap tp -> Command h
forall h (f :: Type -> Type) (args :: Ctx BaseType)
       (rtp :: BaseType).
SMTWriter h =>
f h -> Text -> Assignment TypeMap args -> TypeMap rtp -> Command h
declareCommand WriterConn t h
conn Text
var_name Assignment TypeMap EmptyCtx
forall k (f :: k -> Type). Assignment f EmptyCtx
Ctx.empty TypeMap tp
smt_type
      WriterConn t h
-> Nonce t tp -> TermLifetime -> SMTExpr h tp -> IO ()
forall t h (tp :: BaseType).
WriterConn t h
-> Nonce t tp -> TermLifetime -> SMTExpr h tp -> IO ()
cacheValueExpr WriterConn t h
conn (ExprBoundVar t tp -> Nonce t tp
forall t (tp :: BaseType). ExprBoundVar t tp -> Nonce t tp
bvarId ExprBoundVar t tp
var) TermLifetime
DeleteOnPop (SMTExpr h tp -> IO ()) -> SMTExpr h tp -> IO ()
forall a b. (a -> b) -> a -> b
$ TypeMap tp -> Text -> SMTExpr h tp
forall (tp :: BaseType) h. TypeMap tp -> Text -> SMTExpr h tp
SMTName TypeMap tp
smt_type Text
var_name

-- | Assume that the given formula holds.
assumeFormula :: SMTWriter h => WriterConn t h -> Term h -> IO ()
assumeFormula :: WriterConn t h -> Term h -> IO ()
assumeFormula WriterConn t h
c Term h
p = WriterConn t h -> Command h -> IO ()
forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommand WriterConn t h
c (WriterConn t h -> Term h -> Command h
forall h (f :: Type -> Type).
SMTWriter h =>
f h -> Term h -> Command h
assertCommand WriterConn t h
c Term h
p)

assumeFormulaWithName :: SMTWriter h => WriterConn t h -> Term h -> Text -> IO ()
assumeFormulaWithName :: WriterConn t h -> Term h -> Text -> IO ()
assumeFormulaWithName WriterConn t h
conn Term h
p Text
nm =
  do Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (WriterConn t h -> ProblemFeatures
forall t h. WriterConn t h -> ProblemFeatures
supportedFeatures WriterConn t h
conn ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useUnsatCores) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
       String -> IO ()
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String) -> Doc Any -> String
forall a b. (a -> b) -> a -> b
$ String -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty (WriterConn t h -> String
forall t h. WriterConn t h -> String
smtWriterName WriterConn t h
conn) Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Any
"is not configured to produce UNSAT cores"
     WriterConn t h -> Command h -> IO ()
forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommand WriterConn t h
conn (WriterConn t h -> Term h -> Text -> Command h
forall h (f :: Type -> Type).
SMTWriter h =>
f h -> Term h -> Text -> Command h
assertNamedCommand WriterConn t h
conn Term h
p Text
nm)

assumeFormulaWithFreshName :: SMTWriter h => WriterConn t h -> Term h -> IO Text
assumeFormulaWithFreshName :: WriterConn t h -> Term h -> IO Text
assumeFormulaWithFreshName WriterConn t h
conn Term h
p =
  do Text
var <- WriterConn t h -> State WriterState Text -> IO Text
forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn (State WriterState Text -> IO Text)
-> State WriterState Text -> IO Text
forall a b. (a -> b) -> a -> b
$ State WriterState Text
freshVarName
     WriterConn t h -> Term h -> Text -> IO ()
forall h t.
SMTWriter h =>
WriterConn t h -> Term h -> Text -> IO ()
assumeFormulaWithName WriterConn t h
conn Term h
p Text
var
     Text -> IO Text
forall (m :: Type -> Type) a. Monad m => a -> m a
return Text
var

-- | Perform any necessary declarations to ensure that the mentioned type map
--   sorts exist in the solver environment.
declareTypes ::
  SMTWriter h =>
  WriterConn t h ->
  TypeMap tp ->
  IO ()
declareTypes :: WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn = \case
  TypeMap tp
BoolTypeMap -> () -> IO ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
  TypeMap tp
IntegerTypeMap -> () -> IO ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
  TypeMap tp
RealTypeMap    -> () -> IO ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
  BVTypeMap NatRepr w
_ -> () -> IO ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
  FloatTypeMap FloatPrecisionRepr fpp
_ -> () -> IO ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
  TypeMap tp
Char8TypeMap -> () -> IO ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
  TypeMap tp
ComplexToStructTypeMap -> WriterConn t h
-> Assignment
     TypeMap ((EmptyCtx ::> BaseRealType) ::> BaseRealType)
-> IO ()
forall h t (args :: Ctx BaseType).
SMTWriter h =>
WriterConn t h -> Assignment TypeMap args -> IO ()
declareStructDatatype WriterConn t h
conn (Assignment TypeMap EmptyCtx
forall k (ctx :: Ctx k) (f :: k -> Type).
(ctx ~ EmptyCtx) =>
Assignment f ctx
Ctx.Empty Assignment TypeMap EmptyCtx
-> TypeMap BaseRealType
-> Assignment TypeMap (EmptyCtx ::> BaseRealType)
forall k (ctx' :: Ctx k) (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
(ctx' ~ (ctx ::> tp)) =>
Assignment f ctx -> f tp -> Assignment f ctx'
Ctx.:> TypeMap BaseRealType
RealTypeMap Assignment TypeMap (EmptyCtx ::> BaseRealType)
-> TypeMap BaseRealType
-> Assignment
     TypeMap ((EmptyCtx ::> BaseRealType) ::> BaseRealType)
forall k (ctx' :: Ctx k) (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
(ctx' ~ (ctx ::> tp)) =>
Assignment f ctx -> f tp -> Assignment f ctx'
Ctx.:> TypeMap BaseRealType
RealTypeMap)
  TypeMap tp
ComplexToArrayTypeMap  -> () -> IO ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
  PrimArrayTypeMap Assignment TypeMap (idxl ::> idx)
args TypeMap tp
ret ->
    do (forall (x :: BaseType). TypeMap x -> IO ())
-> Assignment TypeMap (idxl ::> idx) -> IO ()
forall k l (t :: (k -> Type) -> l -> Type) (m :: Type -> Type)
       (f :: k -> Type) a.
(FoldableFC t, Applicative m) =>
(forall (x :: k). f x -> m a) -> forall (x :: l). t f x -> m ()
traverseFC_ (WriterConn t h -> TypeMap x -> IO ()
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn) Assignment TypeMap (idxl ::> idx)
args
       WriterConn t h -> TypeMap tp -> IO ()
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn TypeMap tp
ret
  FnArrayTypeMap Assignment TypeMap (idxl ::> idx)
args TypeMap tp
ret ->
    do (forall (x :: BaseType). TypeMap x -> IO ())
-> Assignment TypeMap (idxl ::> idx) -> IO ()
forall k l (t :: (k -> Type) -> l -> Type) (m :: Type -> Type)
       (f :: k -> Type) a.
(FoldableFC t, Applicative m) =>
(forall (x :: k). f x -> m a) -> forall (x :: l). t f x -> m ()
traverseFC_ (WriterConn t h -> TypeMap x -> IO ()
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn) Assignment TypeMap (idxl ::> idx)
args
       WriterConn t h -> TypeMap tp -> IO ()
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn TypeMap tp
ret
  StructTypeMap Assignment TypeMap idx
flds ->
    do (forall (x :: BaseType). TypeMap x -> IO ())
-> Assignment TypeMap idx -> IO ()
forall k l (t :: (k -> Type) -> l -> Type) (m :: Type -> Type)
       (f :: k -> Type) a.
(FoldableFC t, Applicative m) =>
(forall (x :: k). f x -> m a) -> forall (x :: l). t f x -> m ()
traverseFC_ (WriterConn t h -> TypeMap x -> IO ()
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn) Assignment TypeMap idx
flds
       WriterConn t h -> Assignment TypeMap idx -> IO ()
forall h t (args :: Ctx BaseType).
SMTWriter h =>
WriterConn t h -> Assignment TypeMap args -> IO ()
declareStructDatatype WriterConn t h
conn Assignment TypeMap idx
flds


data DefineStyle
  = FunctionDefinition
  | EqualityDefinition
 deriving (DefineStyle -> DefineStyle -> Bool
(DefineStyle -> DefineStyle -> Bool)
-> (DefineStyle -> DefineStyle -> Bool) -> Eq DefineStyle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DefineStyle -> DefineStyle -> Bool
$c/= :: DefineStyle -> DefineStyle -> Bool
== :: DefineStyle -> DefineStyle -> Bool
$c== :: DefineStyle -> DefineStyle -> Bool
Eq, Int -> DefineStyle -> String -> String
[DefineStyle] -> String -> String
DefineStyle -> String
(Int -> DefineStyle -> String -> String)
-> (DefineStyle -> String)
-> ([DefineStyle] -> String -> String)
-> Show DefineStyle
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [DefineStyle] -> String -> String
$cshowList :: [DefineStyle] -> String -> String
show :: DefineStyle -> String
$cshow :: DefineStyle -> String
showsPrec :: Int -> DefineStyle -> String -> String
$cshowsPrec :: Int -> DefineStyle -> String -> String
Show)

-- | Create a variable name eqivalent to the given expression.
defineSMTVar :: SMTWriter h
             => WriterConn t h
             -> DefineStyle
             -> Text
                -- ^ Name of variable to define
                -- Should not be defined or declared in the current SMT context
             -> [(Text, Some TypeMap)]
                -- ^ Names of variables in term and associated type.
             -> TypeMap rtp -- ^ Type of expression.
             -> Term h
             -> IO ()
defineSMTVar :: WriterConn t h
-> DefineStyle
-> Text
-> [(Text, Some TypeMap)]
-> TypeMap rtp
-> Term h
-> IO ()
defineSMTVar WriterConn t h
conn DefineStyle
defSty Text
var [(Text, Some TypeMap)]
args TypeMap rtp
return_type Term h
expr
  | WriterConn t h -> Bool
forall t h. WriterConn t h -> Bool
supportFunctionDefs WriterConn t h
conn Bool -> Bool -> Bool
&& DefineStyle
defSty DefineStyle -> DefineStyle -> Bool
forall a. Eq a => a -> a -> Bool
== DefineStyle
FunctionDefinition = do
    ((Text, Some TypeMap) -> IO ()) -> [(Text, Some TypeMap)] -> IO ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((forall (x :: BaseType). TypeMap x -> IO ())
-> Some TypeMap -> IO ()
forall k (f :: k -> Type) r.
(forall (tp :: k). f tp -> r) -> Some f -> r
viewSome (WriterConn t h -> TypeMap tp -> IO ()
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn) (Some TypeMap -> IO ())
-> ((Text, Some TypeMap) -> Some TypeMap)
-> (Text, Some TypeMap)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Some TypeMap) -> Some TypeMap
forall a b. (a, b) -> b
snd) [(Text, Some TypeMap)]
args
    WriterConn t h -> TypeMap rtp -> IO ()
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn TypeMap rtp
return_type
    WriterConn t h -> Command h -> IO ()
forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommand WriterConn t h
conn (Command h -> IO ()) -> Command h -> IO ()
forall a b. (a -> b) -> a -> b
$ WriterConn t h
-> Text
-> [(Text, Some TypeMap)]
-> TypeMap rtp
-> Term h
-> Command h
forall h (f :: Type -> Type) (rtp :: BaseType).
SMTWriter h =>
f h
-> Text
-> [(Text, Some TypeMap)]
-> TypeMap rtp
-> Term h
-> Command h
defineCommand WriterConn t h
conn Text
var [(Text, Some TypeMap)]
args TypeMap rtp
return_type Term h
expr
  | Bool
otherwise = do
    Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([(Text, Some TypeMap)] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [(Text, Some TypeMap)]
args)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      String -> IO ()
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ WriterConn t h -> String
forall t h. WriterConn t h -> String
smtWriterName WriterConn t h
conn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" interface does not support defined functions."
    WriterConn t h -> TypeMap rtp -> IO ()
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn TypeMap rtp
return_type
    WriterConn t h -> Command h -> IO ()
forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommand WriterConn t h
conn (Command h -> IO ()) -> Command h -> IO ()
forall a b. (a -> b) -> a -> b
$ WriterConn t h
-> Text -> Assignment TypeMap EmptyCtx -> TypeMap rtp -> Command h
forall h (f :: Type -> Type) (args :: Ctx BaseType)
       (rtp :: BaseType).
SMTWriter h =>
f h -> Text -> Assignment TypeMap args -> TypeMap rtp -> Command h
declareCommand WriterConn t h
conn Text
var Assignment TypeMap EmptyCtx
forall k (f :: k -> Type). Assignment f EmptyCtx
Ctx.empty TypeMap rtp
return_type
    WriterConn t h -> Term h -> IO ()
forall h t. SMTWriter h => WriterConn t h -> Term h -> IO ()
assumeFormula WriterConn t h
conn (Term h -> IO ()) -> Term h -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Term h
forall v. SupportTermOps v => Text -> v
fromText Text
var Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.== Term h
expr

-- | Create a variable name eqivalent to the given expression.
freshBoundVarName :: SMTWriter h
                  => WriterConn t h
                  -> DefineStyle
                  -> [(Text, Some TypeMap)]
                     -- ^ Names of variables in term and associated type.
                  -> TypeMap rtp -- ^ Type of expression.
                  -> Term h
                  -> IO Text
freshBoundVarName :: WriterConn t h
-> DefineStyle
-> [(Text, Some TypeMap)]
-> TypeMap rtp
-> Term h
-> IO Text
freshBoundVarName WriterConn t h
conn DefineStyle
defSty [(Text, Some TypeMap)]
args TypeMap rtp
return_type Term h
expr = do
  Text
var <- WriterConn t h -> State WriterState Text -> IO Text
forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn (State WriterState Text -> IO Text)
-> State WriterState Text -> IO Text
forall a b. (a -> b) -> a -> b
$ State WriterState Text
freshVarName
  WriterConn t h
-> DefineStyle
-> Text
-> [(Text, Some TypeMap)]
-> TypeMap rtp
-> Term h
-> IO ()
forall h t (rtp :: BaseType).
SMTWriter h =>
WriterConn t h
-> DefineStyle
-> Text
-> [(Text, Some TypeMap)]
-> TypeMap rtp
-> Term h
-> IO ()
defineSMTVar WriterConn t h
conn DefineStyle
defSty Text
var [(Text, Some TypeMap)]
args TypeMap rtp
return_type Term h
expr
  Text -> IO Text
forall (m :: Type -> Type) a. Monad m => a -> m a
return Text
var

-- | Function for create a new name given a base type.
data FreshVarFn h = FreshVarFn (forall tp . TypeMap tp -> IO (SMTExpr h tp))

-- | The state of a side collector monad
--
-- This has predicate for introducing new bound variables
data SMTCollectorState t h
  = SMTCollectorState
    { SMTCollectorState t h -> WriterConn t h
scConn :: !(WriterConn t h)
    , SMTCollectorState t h
-> forall (rtp :: BaseType).
   Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> Term h -> IO ()
freshBoundTermFn :: !(forall rtp . Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> Term h -> IO ())
      -- ^ 'freshBoundTerm nm args ret_type ret' will record that 'nm(args) = ret'
      -- 'ret_type' should be the type of 'ret'.
    , SMTCollectorState t h -> Maybe (FreshVarFn h)
freshConstantFn  :: !(Maybe (FreshVarFn h))
    , SMTCollectorState t h -> Maybe (Term h -> IO ())
recordSideCondFn :: !(Maybe (Term h -> IO ()))
      -- ^ Called when we need to need to assert a predicate about some
      -- variables.
    }

-- | The SMT term collector
type SMTCollector t h = ReaderT (SMTCollectorState t h) IO

-- | Create a fresh constant
freshConstant :: String -- ^ The name of the constant based on its reaon.
               -> TypeMap tp -- ^ Type of the constant.
               -> SMTCollector t h (SMTExpr h tp)
freshConstant :: String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
nm TypeMap tp
tpr = do
  Maybe (FreshVarFn h)
mf <- (SMTCollectorState t h -> Maybe (FreshVarFn h))
-> ReaderT (SMTCollectorState t h) IO (Maybe (FreshVarFn h))
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks SMTCollectorState t h -> Maybe (FreshVarFn h)
forall t h. SMTCollectorState t h -> Maybe (FreshVarFn h)
freshConstantFn
  case Maybe (FreshVarFn h)
mf of
   Maybe (FreshVarFn h)
Nothing -> do
     WriterConn t h
conn <- (SMTCollectorState t h -> WriterConn t h)
-> ReaderT (SMTCollectorState t h) IO (WriterConn t h)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks SMTCollectorState t h -> WriterConn t h
forall t h. SMTCollectorState t h -> WriterConn t h
scConn
     IO (SMTExpr h tp) -> SMTCollector t h (SMTExpr h tp)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SMTExpr h tp) -> SMTCollector t h (SMTExpr h tp))
-> IO (SMTExpr h tp) -> SMTCollector t h (SMTExpr h tp)
forall a b. (a -> b) -> a -> b
$ do
     Position
loc <- WriterConn t h -> State WriterState Position -> IO Position
forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn (State WriterState Position -> IO Position)
-> State WriterState Position -> IO Position
forall a b. (a -> b) -> a -> b
$ Getting Position WriterState Position -> State WriterState Position
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
use Getting Position WriterState Position
Lens WriterState WriterState Position Position
position
     String -> IO (SMTExpr h tp)
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> IO (SMTExpr h tp)) -> String -> IO (SMTExpr h tp)
forall a b. (a -> b) -> a -> b
$ String
"Cannot create the free constant within a function needed to define the "
       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" term created at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Position -> String
forall a. Show a => a -> String
show Position
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
   Just (FreshVarFn forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp)
f) ->
    IO (SMTExpr h tp) -> SMTCollector t h (SMTExpr h tp)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SMTExpr h tp) -> SMTCollector t h (SMTExpr h tp))
-> IO (SMTExpr h tp) -> SMTCollector t h (SMTExpr h tp)
forall a b. (a -> b) -> a -> b
$ TypeMap tp -> IO (SMTExpr h tp)
forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp)
f TypeMap tp
tpr

data BaseTypeError = ComplexTypeUnsupported
                   | ArrayUnsupported
                   | StringTypeUnsupported (Some StringInfoRepr)

-- | Given a solver connection and a base type repr, 'typeMap' attempts to
-- find the best encoding for a variable of that type supported by teh solver.
typeMap :: WriterConn t h  -> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
typeMap :: WriterConn t h
-> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
typeMap WriterConn t h
conn BaseTypeRepr tp
tp0 = do
  case WriterConn t h
-> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
forall t h (tp :: BaseType).
WriterConn t h
-> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
typeMapFirstClass WriterConn t h
conn BaseTypeRepr tp
tp0 of
    Right TypeMap tp
tm -> TypeMap tp -> Either BaseTypeError (TypeMap tp)
forall a b. b -> Either a b
Right TypeMap tp
tm
    -- Recover from array unsupported if possible.
    Left BaseTypeError
ArrayUnsupported
      | WriterConn t h -> Bool
forall t h. WriterConn t h -> Bool
supportFunctionDefs WriterConn t h
conn
      , BaseArrayRepr Assignment BaseTypeRepr (idx ::> tp)
idxTp BaseTypeRepr xs
eltTp <- BaseTypeRepr tp
tp0 ->
        Assignment TypeMap (idx ::> tp)
-> TypeMap xs -> TypeMap (BaseArrayType (idx ::> tp) xs)
forall (idxl :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
Assignment TypeMap (idxl ::> idx)
-> TypeMap tp -> TypeMap (BaseArrayType (idxl ::> idx) tp)
FnArrayTypeMap (Assignment TypeMap (idx ::> tp)
 -> TypeMap xs -> TypeMap (BaseArrayType (idx ::> tp) xs))
-> Either BaseTypeError (Assignment TypeMap (idx ::> tp))
-> Either
     BaseTypeError
     (TypeMap xs -> TypeMap (BaseArrayType (idx ::> tp) xs))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (x :: BaseType).
 BaseTypeRepr x -> Either BaseTypeError (TypeMap x))
-> Assignment BaseTypeRepr (idx ::> tp)
-> Either BaseTypeError (Assignment TypeMap (idx ::> tp))
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type) (m :: Type -> Type).
(TraversableFC t, Applicative m) =>
(forall (x :: k). f x -> m (g x))
-> forall (x :: l). t f x -> m (t g x)
traverseFC (WriterConn t h
-> BaseTypeRepr x -> Either BaseTypeError (TypeMap x)
forall t h (tp :: BaseType).
WriterConn t h
-> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
typeMapFirstClass WriterConn t h
conn) Assignment BaseTypeRepr (idx ::> tp)
idxTp
                       Either
  BaseTypeError
  (TypeMap xs -> TypeMap (BaseArrayType (idx ::> tp) xs))
-> Either BaseTypeError (TypeMap xs)
-> Either BaseTypeError (TypeMap (BaseArrayType (idx ::> tp) xs))
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> WriterConn t h
-> BaseTypeRepr xs -> Either BaseTypeError (TypeMap xs)
forall t h (tp :: BaseType).
WriterConn t h
-> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
typeMapFirstClass WriterConn t h
conn BaseTypeRepr xs
eltTp
    -- Pass other functions on.
    Left BaseTypeError
e -> BaseTypeError -> Either BaseTypeError (TypeMap tp)
forall a b. a -> Either a b
Left BaseTypeError
e

-- | This is a helper function for 'typeMap' that only returns values that can
-- be passed as arguments to a function.
typeMapFirstClass :: WriterConn t h -> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
typeMapFirstClass :: WriterConn t h
-> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
typeMapFirstClass WriterConn t h
conn BaseTypeRepr tp
tp0 = do
  let feat :: ProblemFeatures
feat = WriterConn t h -> ProblemFeatures
forall t h. WriterConn t h -> ProblemFeatures
supportedFeatures WriterConn t h
conn
  case BaseTypeRepr tp
tp0 of
    BaseTypeRepr tp
BaseBoolRepr -> TypeMap BaseBoolType -> Either BaseTypeError (TypeMap BaseBoolType)
forall a b. b -> Either a b
Right TypeMap BaseBoolType
BoolTypeMap
    BaseBVRepr NatRepr w
w -> TypeMap (BaseBVType w)
-> Either BaseTypeError (TypeMap (BaseBVType w))
forall a b. b -> Either a b
Right (TypeMap (BaseBVType w)
 -> Either BaseTypeError (TypeMap (BaseBVType w)))
-> TypeMap (BaseBVType w)
-> Either BaseTypeError (TypeMap (BaseBVType w))
forall a b. (a -> b) -> a -> b
$! NatRepr w -> TypeMap (BaseBVType w)
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr w
w
    BaseFloatRepr FloatPrecisionRepr fpp
fpp -> TypeMap (BaseFloatType fpp)
-> Either BaseTypeError (TypeMap (BaseFloatType fpp))
forall a b. b -> Either a b
Right (TypeMap (BaseFloatType fpp)
 -> Either BaseTypeError (TypeMap (BaseFloatType fpp)))
-> TypeMap (BaseFloatType fpp)
-> Either BaseTypeError (TypeMap (BaseFloatType fpp))
forall a b. (a -> b) -> a -> b
$! FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
forall (fpp :: FloatPrecision).
FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
FloatTypeMap FloatPrecisionRepr fpp
fpp
    BaseTypeRepr tp
BaseRealRepr -> TypeMap BaseRealType -> Either BaseTypeError (TypeMap BaseRealType)
forall a b. b -> Either a b
Right TypeMap BaseRealType
RealTypeMap
    BaseTypeRepr tp
BaseIntegerRepr -> TypeMap BaseIntegerType
-> Either BaseTypeError (TypeMap BaseIntegerType)
forall a b. b -> Either a b
Right TypeMap BaseIntegerType
IntegerTypeMap
    BaseStringRepr StringInfoRepr si
Char8Repr -> TypeMap (BaseStringType Char8)
-> Either BaseTypeError (TypeMap (BaseStringType Char8))
forall a b. b -> Either a b
Right TypeMap (BaseStringType Char8)
Char8TypeMap
    BaseStringRepr StringInfoRepr si
si -> BaseTypeError -> Either BaseTypeError (TypeMap tp)
forall a b. a -> Either a b
Left (Some StringInfoRepr -> BaseTypeError
StringTypeUnsupported (StringInfoRepr si -> Some StringInfoRepr
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some StringInfoRepr si
si))
    BaseTypeRepr tp
BaseComplexRepr
      | ProblemFeatures
feat ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useStructs        -> TypeMap BaseComplexType
-> Either BaseTypeError (TypeMap BaseComplexType)
forall a b. b -> Either a b
Right TypeMap BaseComplexType
ComplexToStructTypeMap
      | ProblemFeatures
feat ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useSymbolicArrays -> TypeMap BaseComplexType
-> Either BaseTypeError (TypeMap BaseComplexType)
forall a b. b -> Either a b
Right TypeMap BaseComplexType
ComplexToArrayTypeMap
      | Bool
otherwise -> BaseTypeError -> Either BaseTypeError (TypeMap tp)
forall a b. a -> Either a b
Left BaseTypeError
ComplexTypeUnsupported
    BaseArrayRepr Assignment BaseTypeRepr (idx ::> tp)
idxTp BaseTypeRepr xs
eltTp -> do
      -- This is a proxy for the property we want, because we assume that EITHER
      -- the solver uses symbolic arrays, OR functions are first-class objects
      let mkArray :: Assignment TypeMap (idx ::> tp)
-> TypeMap xs -> TypeMap (BaseArrayType (idx ::> tp) xs)
mkArray = if ProblemFeatures
feat ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useSymbolicArrays
                    then Assignment TypeMap (idx ::> tp)
-> TypeMap xs -> TypeMap (BaseArrayType (idx ::> tp) xs)
forall (idxl :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
Assignment TypeMap (idxl ::> idx)
-> TypeMap tp -> TypeMap (BaseArrayType (idxl ::> idx) tp)
PrimArrayTypeMap
                    else Assignment TypeMap (idx ::> tp)
-> TypeMap xs -> TypeMap (BaseArrayType (idx ::> tp) xs)
forall (idxl :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
Assignment TypeMap (idxl ::> idx)
-> TypeMap tp -> TypeMap (BaseArrayType (idxl ::> idx) tp)
FnArrayTypeMap
      Assignment TypeMap (idx ::> tp)
-> TypeMap xs -> TypeMap (BaseArrayType (idx ::> tp) xs)
mkArray (Assignment TypeMap (idx ::> tp)
 -> TypeMap xs -> TypeMap (BaseArrayType (idx ::> tp) xs))
-> Either BaseTypeError (Assignment TypeMap (idx ::> tp))
-> Either
     BaseTypeError
     (TypeMap xs -> TypeMap (BaseArrayType (idx ::> tp) xs))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (x :: BaseType).
 BaseTypeRepr x -> Either BaseTypeError (TypeMap x))
-> Assignment BaseTypeRepr (idx ::> tp)
-> Either BaseTypeError (Assignment TypeMap (idx ::> tp))
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type) (m :: Type -> Type).
(TraversableFC t, Applicative m) =>
(forall (x :: k). f x -> m (g x))
-> forall (x :: l). t f x -> m (t g x)
traverseFC (WriterConn t h
-> BaseTypeRepr x -> Either BaseTypeError (TypeMap x)
forall t h (tp :: BaseType).
WriterConn t h
-> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
typeMapFirstClass WriterConn t h
conn) Assignment BaseTypeRepr (idx ::> tp)
idxTp
              Either
  BaseTypeError
  (TypeMap xs -> TypeMap (BaseArrayType (idx ::> tp) xs))
-> Either BaseTypeError (TypeMap xs)
-> Either BaseTypeError (TypeMap (BaseArrayType (idx ::> tp) xs))
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> WriterConn t h
-> BaseTypeRepr xs -> Either BaseTypeError (TypeMap xs)
forall t h (tp :: BaseType).
WriterConn t h
-> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
typeMapFirstClass WriterConn t h
conn BaseTypeRepr xs
eltTp
    BaseStructRepr Assignment BaseTypeRepr ctx
flds ->
      Assignment TypeMap ctx -> TypeMap (BaseStructType ctx)
forall (idx :: Ctx BaseType).
Assignment TypeMap idx -> TypeMap (BaseStructType idx)
StructTypeMap (Assignment TypeMap ctx -> TypeMap (BaseStructType ctx))
-> Either BaseTypeError (Assignment TypeMap ctx)
-> Either BaseTypeError (TypeMap (BaseStructType ctx))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (x :: BaseType).
 BaseTypeRepr x -> Either BaseTypeError (TypeMap x))
-> Assignment BaseTypeRepr ctx
-> Either BaseTypeError (Assignment TypeMap ctx)
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type) (m :: Type -> Type).
(TraversableFC t, Applicative m) =>
(forall (x :: k). f x -> m (g x))
-> forall (x :: l). t f x -> m (t g x)
traverseFC (WriterConn t h
-> BaseTypeRepr x -> Either BaseTypeError (TypeMap x)
forall t h (tp :: BaseType).
WriterConn t h
-> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
typeMapFirstClass WriterConn t h
conn) Assignment BaseTypeRepr ctx
flds

getBaseSMT_Type :: ExprBoundVar t tp -> SMTCollector t h (TypeMap tp)
getBaseSMT_Type :: ExprBoundVar t tp -> SMTCollector t h (TypeMap tp)
getBaseSMT_Type ExprBoundVar t tp
v = do
  WriterConn t h
conn <- (SMTCollectorState t h -> WriterConn t h)
-> ReaderT (SMTCollectorState t h) IO (WriterConn t h)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks SMTCollectorState t h -> WriterConn t h
forall t h. SMTCollectorState t h -> WriterConn t h
scConn
  let errMsg :: String -> String
errMsg String
typename =
        Doc Any -> String
forall a. Show a => a -> String
show
          (Doc Any -> String) -> Doc Any -> String
forall a b. (a -> b) -> a -> b
$   SolverSymbol -> Doc Any
forall a ann. Show a => a -> Doc ann
viaShow (ExprBoundVar t tp -> SolverSymbol
forall t (tp :: BaseType). ExprBoundVar t tp -> SolverSymbol
bvarName ExprBoundVar t tp
v)
          Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Any
"is a"
          Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty String
typename
          Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Any
"variable, and we do not support this with"
          Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty (WriterConn t h -> String
forall t h. WriterConn t h -> String
smtWriterName WriterConn t h
conn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".")
  case WriterConn t h
-> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
forall t h (tp :: BaseType).
WriterConn t h
-> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
typeMap WriterConn t h
conn (ExprBoundVar t tp -> BaseTypeRepr tp
forall t (tp :: BaseType). ExprBoundVar t tp -> BaseTypeRepr tp
bvarType ExprBoundVar t tp
v) of
    Left  (StringTypeUnsupported (Some StringInfoRepr x
si)) -> String -> SMTCollector t h (TypeMap tp)
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> SMTCollector t h (TypeMap tp))
-> String -> SMTCollector t h (TypeMap tp)
forall a b. (a -> b) -> a -> b
$ String -> String
errMsg (String
"string " String -> String -> String
forall a. [a] -> [a] -> [a]
++ StringInfoRepr x -> String
forall a. Show a => a -> String
show StringInfoRepr x
si)
    Left  BaseTypeError
ComplexTypeUnsupported -> String -> SMTCollector t h (TypeMap tp)
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> SMTCollector t h (TypeMap tp))
-> String -> SMTCollector t h (TypeMap tp)
forall a b. (a -> b) -> a -> b
$ String -> String
errMsg String
"complex"
    Left  BaseTypeError
ArrayUnsupported       -> String -> SMTCollector t h (TypeMap tp)
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> SMTCollector t h (TypeMap tp))
-> String -> SMTCollector t h (TypeMap tp)
forall a b. (a -> b) -> a -> b
$ String -> String
errMsg String
"array"
    Right TypeMap tp
smtType                -> TypeMap tp -> SMTCollector t h (TypeMap tp)
forall (m :: Type -> Type) a. Monad m => a -> m a
return TypeMap tp
smtType

-- | Create a fresh bound term from the SMT expression with the given name.
freshBoundFn :: [(Text, Some TypeMap)] -- ^ Arguments expected for function.
             -> TypeMap rtp -- ^ Type of result
             -> Term h   -- ^ Result of function
             -> SMTCollector t h Text
freshBoundFn :: [(Text, Some TypeMap)]
-> TypeMap rtp -> Term h -> SMTCollector t h Text
freshBoundFn [(Text, Some TypeMap)]
args TypeMap rtp
tp Term h
t = do
  WriterConn t h
conn <- (SMTCollectorState t h -> WriterConn t h)
-> ReaderT (SMTCollectorState t h) IO (WriterConn t h)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks SMTCollectorState t h -> WriterConn t h
forall t h. SMTCollectorState t h -> WriterConn t h
scConn
  Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> Term h -> IO ()
f <- (SMTCollectorState t h
 -> Text
 -> [(Text, Some TypeMap)]
 -> TypeMap rtp
 -> Term h
 -> IO ())
-> ReaderT
     (SMTCollectorState t h)
     IO
     (Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> Term h -> IO ())
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks SMTCollectorState t h
-> Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> Term h -> IO ()
forall t h.
SMTCollectorState t h
-> forall (rtp :: BaseType).
   Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> Term h -> IO ()
freshBoundTermFn
  IO Text -> SMTCollector t h Text
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO Text -> SMTCollector t h Text)
-> IO Text -> SMTCollector t h Text
forall a b. (a -> b) -> a -> b
$ do
    Text
var <- WriterConn t h -> State WriterState Text -> IO Text
forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn (State WriterState Text -> IO Text)
-> State WriterState Text -> IO Text
forall a b. (a -> b) -> a -> b
$ State WriterState Text
freshVarName
    Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> Term h -> IO ()
f Text
var [(Text, Some TypeMap)]
args TypeMap rtp
tp Term h
t
    Text -> IO Text
forall (m :: Type -> Type) a. Monad m => a -> m a
return Text
var

-- | Create a fresh bound term from the SMT expression with the given name.
freshBoundTerm :: TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm :: TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap tp
tp Term h
t = TypeMap tp -> Text -> SMTExpr h tp
forall (tp :: BaseType) h. TypeMap tp -> Text -> SMTExpr h tp
SMTName TypeMap tp
tp (Text -> SMTExpr h tp)
-> ReaderT (SMTCollectorState t h) IO Text
-> SMTCollector t h (SMTExpr h tp)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Some TypeMap)]
-> TypeMap tp -> Term h -> ReaderT (SMTCollectorState t h) IO Text
forall (rtp :: BaseType) h t.
[(Text, Some TypeMap)]
-> TypeMap rtp -> Term h -> SMTCollector t h Text
freshBoundFn [] TypeMap tp
tp Term h
t

-- | Create a fresh bound term from the SMT expression with the given name.
freshBoundTerm' :: SupportTermOps (Term h) => SMTExpr h tp -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm' :: SMTExpr h tp -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm' SMTExpr h tp
t = TypeMap tp -> Text -> SMTExpr h tp
forall (tp :: BaseType) h. TypeMap tp -> Text -> SMTExpr h tp
SMTName TypeMap tp
tp (Text -> SMTExpr h tp)
-> ReaderT (SMTCollectorState t h) IO Text
-> SMTCollector t h (SMTExpr h tp)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Some TypeMap)]
-> TypeMap tp -> Term h -> ReaderT (SMTCollectorState t h) IO Text
forall (rtp :: BaseType) h t.
[(Text, Some TypeMap)]
-> TypeMap rtp -> Term h -> SMTCollector t h Text
freshBoundFn [] TypeMap tp
tp (SMTExpr h tp -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h tp
t)
  where tp :: TypeMap tp
tp = SMTExpr h tp -> TypeMap tp
forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h tp
t

-- | Assert a predicate holds as a side condition to some formula.
addSideCondition ::
   String {- ^ Reason that condition is being added. -} ->
   Term h {- ^ Predicate that should hold. -} ->
   SMTCollector t h ()
addSideCondition :: String -> Term h -> SMTCollector t h ()
addSideCondition String
nm Term h
t = do
  WriterConn t h
conn <- (SMTCollectorState t h -> WriterConn t h)
-> ReaderT (SMTCollectorState t h) IO (WriterConn t h)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks SMTCollectorState t h -> WriterConn t h
forall t h. SMTCollectorState t h -> WriterConn t h
scConn
  Maybe (Term h -> IO ())
mf <- (SMTCollectorState t h -> Maybe (Term h -> IO ()))
-> ReaderT (SMTCollectorState t h) IO (Maybe (Term h -> IO ()))
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks SMTCollectorState t h -> Maybe (Term h -> IO ())
forall t h. SMTCollectorState t h -> Maybe (Term h -> IO ())
recordSideCondFn
  Position
loc <- IO Position -> ReaderT (SMTCollectorState t h) IO Position
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO Position -> ReaderT (SMTCollectorState t h) IO Position)
-> IO Position -> ReaderT (SMTCollectorState t h) IO Position
forall a b. (a -> b) -> a -> b
$ WriterConn t h -> State WriterState Position -> IO Position
forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn (State WriterState Position -> IO Position)
-> State WriterState Position -> IO Position
forall a b. (a -> b) -> a -> b
$ Getting Position WriterState Position -> State WriterState Position
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
use Getting Position WriterState Position
Lens WriterState WriterState Position Position
position
  case Maybe (Term h -> IO ())
mf of
   Just Term h -> IO ()
f ->
     IO () -> SMTCollector t h ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> SMTCollector t h ()) -> IO () -> SMTCollector t h ()
forall a b. (a -> b) -> a -> b
$ Term h -> IO ()
f Term h
t
   Maybe (Term h -> IO ())
Nothing -> do
     String -> SMTCollector t h ()
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> SMTCollector t h ()) -> String -> SMTCollector t h ()
forall a b. (a -> b) -> a -> b
$ String
"Cannot add a side condition within a function needed to define the "
       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" term created at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Position -> String
forall a. Show a => a -> String
show Position
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."

addPartialSideCond ::
  forall t h tp.
  SMTWriter h =>
  WriterConn t h ->
  Term h ->
  TypeMap tp ->
  Maybe (AbstractValue tp) ->
  SMTCollector t h ()

-- no abstract domain information means unconstrained values
addPartialSideCond :: WriterConn t h
-> Term h
-> TypeMap tp
-> Maybe (AbstractValue tp)
-> SMTCollector t h ()
addPartialSideCond WriterConn t h
_ Term h
_ TypeMap tp
_ Maybe (AbstractValue tp)
Nothing = () -> SMTCollector t h ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

addPartialSideCond WriterConn t h
_ Term h
_ TypeMap tp
BoolTypeMap (Just AbstractValue tp
Nothing) = () -> SMTCollector t h ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
addPartialSideCond WriterConn t h
_ Term h
t TypeMap tp
BoolTypeMap (Just (Just b)) =
   -- This is a weird case, but technically possible, so...
  String -> Term h -> SMTCollector t h ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"bool_val" (Term h -> SMTCollector t h ()) -> Term h -> SMTCollector t h ()
forall a b. (a -> b) -> a -> b
$ Term h
t Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.== Bool -> Term h
forall v. SupportTermOps v => Bool -> v
boolExpr Bool
b

addPartialSideCond WriterConn t h
_ Term h
t TypeMap tp
IntegerTypeMap (Just AbstractValue tp
rng) =
  do case ValueRange Integer -> ValueBound Integer
forall tp. ValueRange tp -> ValueBound tp
rangeLowBound AbstractValue tp
ValueRange Integer
rng of
       ValueBound Integer
Unbounded -> () -> SMTCollector t h ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
       Inclusive Integer
lo -> String -> Term h -> SMTCollector t h ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"int_range" (Term h -> SMTCollector t h ()) -> Term h -> SMTCollector t h ()
forall a b. (a -> b) -> a -> b
$ Term h
t Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.>= Integer -> Term h
forall v. SupportTermOps v => Integer -> v
integerTerm Integer
lo
     case ValueRange Integer -> ValueBound Integer
forall tp. ValueRange tp -> ValueBound tp
rangeHiBound AbstractValue tp
ValueRange Integer
rng of
       ValueBound Integer
Unbounded -> () -> SMTCollector t h ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
       Inclusive Integer
hi -> String -> Term h -> SMTCollector t h ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"int_range" (Term h -> SMTCollector t h ()) -> Term h -> SMTCollector t h ()
forall a b. (a -> b) -> a -> b
$ Term h
t Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.<= Integer -> Term h
forall v. SupportTermOps v => Integer -> v
integerTerm Integer
hi

addPartialSideCond WriterConn t h
_ Term h
t TypeMap tp
RealTypeMap (Just AbstractValue tp
rng) =
  do case ValueRange Rational -> ValueBound Rational
forall tp. ValueRange tp -> ValueBound tp
rangeLowBound (RealAbstractValue -> ValueRange Rational
ravRange AbstractValue tp
RealAbstractValue
rng) of
       ValueBound Rational
Unbounded -> () -> SMTCollector t h ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
       Inclusive Rational
lo -> String -> Term h -> SMTCollector t h ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"real_range" (Term h -> SMTCollector t h ()) -> Term h -> SMTCollector t h ()
forall a b. (a -> b) -> a -> b
$ Term h
t Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.>= Rational -> Term h
forall v. SupportTermOps v => Rational -> v
rationalTerm Rational
lo
     case ValueRange Rational -> ValueBound Rational
forall tp. ValueRange tp -> ValueBound tp
rangeHiBound (RealAbstractValue -> ValueRange Rational
ravRange AbstractValue tp
RealAbstractValue
rng) of
       ValueBound Rational
Unbounded -> () -> SMTCollector t h ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
       Inclusive Rational
hi -> String -> Term h -> SMTCollector t h ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"real_range" (Term h -> SMTCollector t h ()) -> Term h -> SMTCollector t h ()
forall a b. (a -> b) -> a -> b
$ Term h
t Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.<= Rational -> Term h
forall v. SupportTermOps v => Rational -> v
rationalTerm Rational
hi

addPartialSideCond WriterConn t h
_ Term h
t (BVTypeMap NatRepr w
w) (Just (BVD.BVDArith rng)) = Maybe (Integer, Integer) -> SMTCollector t h ()
assertRange (Domain w -> Maybe (Integer, Integer)
forall (w :: Nat). Domain w -> Maybe (Integer, Integer)
BVD.arithDomainData Domain w
rng)
   where
   assertRange :: Maybe (Integer, Integer) -> SMTCollector t h ()
assertRange Maybe (Integer, Integer)
Nothing = () -> SMTCollector t h ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
   assertRange (Just (Integer
lo, Integer
sz)) =
     String -> Term h -> SMTCollector t h ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"bv_range" (Term h -> SMTCollector t h ()) -> Term h -> SMTCollector t h ()
forall a b. (a -> b) -> a -> b
$ Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
bvULe (Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
bvSub Term h
t (NatRepr w -> BV w -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> Integer -> BV w
forall (w :: Nat). NatRepr w -> Integer -> BV w
BV.mkBV NatRepr w
w Integer
lo))) (NatRepr w -> BV w -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> Integer -> BV w
forall (w :: Nat). NatRepr w -> Integer -> BV w
BV.mkBV NatRepr w
w Integer
sz))

addPartialSideCond WriterConn t h
_ Term h
t (BVTypeMap NatRepr w
w) (Just (BVD.BVDBitwise rng)) = (Integer, Integer) -> SMTCollector t h ()
assertBitRange (Domain w -> (Integer, Integer)
forall (w :: Nat). Domain w -> (Integer, Integer)
BVD.bitbounds Domain w
rng)
   where
   assertBitRange :: (Integer, Integer) -> SMTCollector t h ()
assertBitRange (Integer
lo, Integer
hi) = do
     Bool -> SMTCollector t h () -> SMTCollector t h ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Integer
lo Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0) (SMTCollector t h () -> SMTCollector t h ())
-> SMTCollector t h () -> SMTCollector t h ()
forall a b. (a -> b) -> a -> b
$
       String -> Term h -> SMTCollector t h ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"bv_bitrange" (Term h -> SMTCollector t h ()) -> Term h -> SMTCollector t h ()
forall a b. (a -> b) -> a -> b
$ (Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
bvOr (NatRepr w -> BV w -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> Integer -> BV w
forall (w :: Nat). NatRepr w -> Integer -> BV w
BV.mkBV NatRepr w
w Integer
lo)) Term h
t) Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.== Term h
t
     Bool -> SMTCollector t h () -> SMTCollector t h ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Integer
hi Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< NatRepr w -> Integer
forall (w :: Nat). NatRepr w -> Integer
maxUnsigned NatRepr w
w) (SMTCollector t h () -> SMTCollector t h ())
-> SMTCollector t h () -> SMTCollector t h ()
forall a b. (a -> b) -> a -> b
$
       String -> Term h -> SMTCollector t h ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"bv_bitrange" (Term h -> SMTCollector t h ()) -> Term h -> SMTCollector t h ()
forall a b. (a -> b) -> a -> b
$ (Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
bvOr Term h
t (NatRepr w -> BV w -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> Integer -> BV w
forall (w :: Nat). NatRepr w -> Integer -> BV w
BV.mkBV NatRepr w
w Integer
hi))) Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.== (NatRepr w -> BV w -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> Integer -> BV w
forall (w :: Nat). NatRepr w -> Integer -> BV w
BV.mkBV NatRepr w
w Integer
hi))

addPartialSideCond WriterConn t h
_ Term h
t (TypeMap tp
Char8TypeMap) (Just (StringAbs len)) =
  do case ValueRange Integer -> ValueBound Integer
forall tp. ValueRange tp -> ValueBound tp
rangeLowBound ValueRange Integer
len of
       Inclusive Integer
lo ->
          String -> Term h -> SMTCollector t h ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"string length low range" (Term h -> SMTCollector t h ()) -> Term h -> SMTCollector t h ()
forall a b. (a -> b) -> a -> b
$
             Integer -> Term h
forall v. SupportTermOps v => Integer -> v
integerTerm (Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
0 Integer
lo) Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.<= Term h -> Term h
forall h. SMTWriter h => Term h -> Term h
stringLength @h Term h
t
       ValueBound Integer
Unbounded ->
          String -> Term h -> SMTCollector t h ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"string length low range" (Term h -> SMTCollector t h ()) -> Term h -> SMTCollector t h ()
forall a b. (a -> b) -> a -> b
$
             Integer -> Term h
forall v. SupportTermOps v => Integer -> v
integerTerm Integer
0 Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.<= Term h -> Term h
forall h. SMTWriter h => Term h -> Term h
stringLength @h Term h
t

     case ValueRange Integer -> ValueBound Integer
forall tp. ValueRange tp -> ValueBound tp
rangeHiBound ValueRange Integer
len of
       ValueBound Integer
Unbounded -> () -> SMTCollector t h ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
       Inclusive Integer
hi ->
         String -> Term h -> SMTCollector t h ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"string length high range" (Term h -> SMTCollector t h ()) -> Term h -> SMTCollector t h ()
forall a b. (a -> b) -> a -> b
$
           Term h -> Term h
forall h. SMTWriter h => Term h -> Term h
stringLength @h Term h
t Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.<= Integer -> Term h
forall v. SupportTermOps v => Integer -> v
integerTerm Integer
hi

addPartialSideCond WriterConn t h
_ Term h
_ (FloatTypeMap FloatPrecisionRepr fpp
_) (Just ()) = () -> SMTCollector t h ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

addPartialSideCond WriterConn t h
conn Term h
t TypeMap tp
ComplexToStructTypeMap (Just (realRng :+ imagRng)) =
  do let r :: Term h
r = Term h -> Term h
forall h. SMTWriter h => Term h -> Term h
arrayComplexRealPart @h Term h
t
     let i :: Term h
i = Term h -> Term h
forall h. SMTWriter h => Term h -> Term h
arrayComplexImagPart @h Term h
t
     WriterConn t h
-> Term h
-> TypeMap BaseRealType
-> Maybe (AbstractValue BaseRealType)
-> SMTCollector t h ()
forall t h (tp :: BaseType).
SMTWriter h =>
WriterConn t h
-> Term h
-> TypeMap tp
-> Maybe (AbstractValue tp)
-> SMTCollector t h ()
addPartialSideCond WriterConn t h
conn Term h
r TypeMap BaseRealType
RealTypeMap (RealAbstractValue -> Maybe RealAbstractValue
forall a. a -> Maybe a
Just RealAbstractValue
realRng)
     WriterConn t h
-> Term h
-> TypeMap BaseRealType
-> Maybe (AbstractValue BaseRealType)
-> SMTCollector t h ()
forall t h (tp :: BaseType).
SMTWriter h =>
WriterConn t h
-> Term h
-> TypeMap tp
-> Maybe (AbstractValue tp)
-> SMTCollector t h ()
addPartialSideCond WriterConn t h
conn Term h
i TypeMap BaseRealType
RealTypeMap (RealAbstractValue -> Maybe RealAbstractValue
forall a. a -> Maybe a
Just RealAbstractValue
imagRng)

addPartialSideCond WriterConn t h
conn Term h
t TypeMap tp
ComplexToArrayTypeMap (Just (realRng :+ imagRng)) =
  do let r :: Term h
r = Term h -> Term h
forall h. SMTWriter h => Term h -> Term h
arrayComplexRealPart @h Term h
t
     let i :: Term h
i = Term h -> Term h
forall h. SMTWriter h => Term h -> Term h
arrayComplexImagPart @h Term h
t
     WriterConn t h
-> Term h
-> TypeMap BaseRealType
-> Maybe (AbstractValue BaseRealType)
-> SMTCollector t h ()
forall t h (tp :: BaseType).
SMTWriter h =>
WriterConn t h
-> Term h
-> TypeMap tp
-> Maybe (AbstractValue tp)
-> SMTCollector t h ()
addPartialSideCond WriterConn t h
conn Term h
r TypeMap BaseRealType
RealTypeMap (RealAbstractValue -> Maybe RealAbstractValue
forall a. a -> Maybe a
Just RealAbstractValue
realRng)
     WriterConn t h
-> Term h
-> TypeMap BaseRealType
-> Maybe (AbstractValue BaseRealType)
-> SMTCollector t h ()
forall t h (tp :: BaseType).
SMTWriter h =>
WriterConn t h
-> Term h
-> TypeMap tp
-> Maybe (AbstractValue tp)
-> SMTCollector t h ()
addPartialSideCond WriterConn t h
conn Term h
i TypeMap BaseRealType
RealTypeMap (RealAbstractValue -> Maybe RealAbstractValue
forall a. a -> Maybe a
Just RealAbstractValue
imagRng)

addPartialSideCond WriterConn t h
conn Term h
t (StructTypeMap Assignment TypeMap idx
ctx) (Just AbstractValue tp
abvs) =
     Size idx
-> (forall (tp :: BaseType).
    SMTCollector t h () -> Index idx tp -> SMTCollector t h ())
-> SMTCollector t h ()
-> SMTCollector t h ()
forall k (ctx :: Ctx k) r.
Size ctx -> (forall (tp :: k). r -> Index ctx tp -> r) -> r -> r
Ctx.forIndex (Assignment TypeMap idx -> Size idx
forall k (f :: k -> Type) (ctx :: Ctx k).
Assignment f ctx -> Size ctx
Ctx.size Assignment TypeMap idx
ctx)
        (\SMTCollector t h ()
start Index idx tp
i ->
            do SMTCollector t h ()
start
               WriterConn t h
-> Term h
-> TypeMap tp
-> Maybe (AbstractValue tp)
-> SMTCollector t h ()
forall t h (tp :: BaseType).
SMTWriter h =>
WriterConn t h
-> Term h
-> TypeMap tp
-> Maybe (AbstractValue tp)
-> SMTCollector t h ()
addPartialSideCond WriterConn t h
conn
                 (Assignment TypeMap idx -> Index idx tp -> Term h -> Term h
forall h (args :: Ctx BaseType) (tp :: BaseType).
SMTWriter h =>
Assignment TypeMap args -> Index args tp -> Term h -> Term h
structProj @h Assignment TypeMap idx
ctx Index idx tp
i Term h
t)
                 (Assignment TypeMap idx
ctx Assignment TypeMap idx -> Index idx tp -> TypeMap tp
forall k (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
Assignment f ctx -> Index ctx tp -> f tp
Ctx.! Index idx tp
i)
                 (AbstractValue tp -> Maybe (AbstractValue tp)
forall a. a -> Maybe a
Just (AbstractValueWrapper tp -> AbstractValue tp
forall (tp :: BaseType).
AbstractValueWrapper tp -> AbstractValue tp
unwrapAV (Assignment AbstractValueWrapper idx
AbstractValue tp
abvs Assignment AbstractValueWrapper idx
-> Index idx tp -> AbstractValueWrapper tp
forall k (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
Assignment f ctx -> Index ctx tp -> f tp
Ctx.! Index idx tp
i))))
        (() -> SMTCollector t h ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ())

addPartialSideCond WriterConn t h
_ Term h
_t (PrimArrayTypeMap Assignment TypeMap (idxl ::> idx)
_idxTp TypeMap tp
_resTp) (Just AbstractValue tp
_abv) =
  String -> SMTCollector t h ()
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"SMTWriter.addPartialSideCond: bounds on array values not supported"
addPartialSideCond WriterConn t h
_ Term h
_t (FnArrayTypeMap Assignment TypeMap (idxl ::> idx)
_idxTp TypeMap tp
_resTp) (Just AbstractValue tp
_abv) =
  String -> SMTCollector t h ()
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"SMTWriter.addPartialSideCond: bounds on array values not supported"


-- | This runs the collector on the connection
runOnLiveConnection :: SMTWriter h => WriterConn t h -> SMTCollector t h a -> IO a
runOnLiveConnection :: WriterConn t h -> SMTCollector t h a -> IO a
runOnLiveConnection WriterConn t h
conn SMTCollector t h a
coll = SMTCollector t h a -> SMTCollectorState t h -> IO a
forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT SMTCollector t h a
coll SMTCollectorState t h
s
  where s :: SMTCollectorState t h
s = SMTCollectorState :: forall t h.
WriterConn t h
-> (forall (rtp :: BaseType).
    Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> Term h -> IO ())
-> Maybe (FreshVarFn h)
-> Maybe (Term h -> IO ())
-> SMTCollectorState t h
SMTCollectorState
              { scConn :: WriterConn t h
scConn = WriterConn t h
conn
              , freshBoundTermFn :: forall (rtp :: BaseType).
Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> Term h -> IO ()
freshBoundTermFn = WriterConn t h
-> DefineStyle
-> Text
-> [(Text, Some TypeMap)]
-> TypeMap rtp
-> Term h
-> IO ()
forall h t (rtp :: BaseType).
SMTWriter h =>
WriterConn t h
-> DefineStyle
-> Text
-> [(Text, Some TypeMap)]
-> TypeMap rtp
-> Term h
-> IO ()
defineSMTVar WriterConn t h
conn DefineStyle
FunctionDefinition
              , freshConstantFn :: Maybe (FreshVarFn h)
freshConstantFn  = FreshVarFn h -> Maybe (FreshVarFn h)
forall a. a -> Maybe a
Just (FreshVarFn h -> Maybe (FreshVarFn h))
-> FreshVarFn h -> Maybe (FreshVarFn h)
forall a b. (a -> b) -> a -> b
$! (forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp))
-> FreshVarFn h
forall h.
(forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp))
-> FreshVarFn h
FreshVarFn (WriterConn t h -> TypeMap tp -> IO (SMTExpr h tp)
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO (SMTExpr h tp)
mkFreeVar' WriterConn t h
conn)
              , recordSideCondFn :: Maybe (Term h -> IO ())
recordSideCondFn = (Term h -> IO ()) -> Maybe (Term h -> IO ())
forall a. a -> Maybe a
Just ((Term h -> IO ()) -> Maybe (Term h -> IO ()))
-> (Term h -> IO ()) -> Maybe (Term h -> IO ())
forall a b. (a -> b) -> a -> b
$! WriterConn t h -> Term h -> IO ()
forall h t. SMTWriter h => WriterConn t h -> Term h -> IO ()
assumeFormula WriterConn t h
conn
              }

prependToRefList :: IORef [a] -> a -> IO ()
prependToRefList :: IORef [a] -> a -> IO ()
prependToRefList IORef [a]
r a
a = a -> IO () -> IO ()
seq a
a (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef [a] -> ([a] -> [a]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [a]
r (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:)

freshSandboxBoundTerm :: SupportTermOps v
                      => IORef [(Text, v)]
                      -> Text -- ^ Name to define.
                      -> [(Text, Some TypeMap)] -- Argument name and types.
                      -> TypeMap rtp
                      -> v
                      -> IO ()
freshSandboxBoundTerm :: IORef [(Text, v)]
-> Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> v -> IO ()
freshSandboxBoundTerm IORef [(Text, v)]
ref Text
var [] TypeMap rtp
_ v
t = do
  IORef [(Text, v)] -> (Text, v) -> IO ()
forall a. IORef [a] -> a -> IO ()
prependToRefList IORef [(Text, v)]
ref (Text
var,v
t)
freshSandboxBoundTerm IORef [(Text, v)]
ref Text
var [(Text, Some TypeMap)]
args TypeMap rtp
_ v
t = do
  case Maybe ([(Text, Some TypeMap)] -> v -> v)
forall v.
SupportTermOps v =>
Maybe ([(Text, Some TypeMap)] -> v -> v)
lambdaTerm of
    Maybe ([(Text, Some TypeMap)] -> v -> v)
Nothing -> do
      String -> IO ()
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Cannot create terms with arguments inside defined functions."
    Just [(Text, Some TypeMap)] -> v -> v
lambdaFn -> do
      let r :: v
r = [(Text, Some TypeMap)] -> v -> v
lambdaFn [(Text, Some TypeMap)]
args v
t
      v -> IO () -> IO ()
seq v
r (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef [(Text, v)] -> (Text, v) -> IO ()
forall a. IORef [a] -> a -> IO ()
prependToRefList IORef [(Text, v)]
ref (Text
var, v
r)

freshSandboxConstant :: WriterConn t h
                     -> IORef [(Text, Some TypeMap)]
                     -> TypeMap tp
                     -> IO (SMTExpr h tp)
freshSandboxConstant :: WriterConn t h
-> IORef [(Text, Some TypeMap)] -> TypeMap tp -> IO (SMTExpr h tp)
freshSandboxConstant WriterConn t h
conn IORef [(Text, Some TypeMap)]
ref TypeMap tp
tp = do
  Text
var <- WriterConn t h -> State WriterState Text -> IO Text
forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn (State WriterState Text -> IO Text)
-> State WriterState Text -> IO Text
forall a b. (a -> b) -> a -> b
$ State WriterState Text
freshVarName
  IORef [(Text, Some TypeMap)] -> (Text, Some TypeMap) -> IO ()
forall a. IORef [a] -> a -> IO ()
prependToRefList IORef [(Text, Some TypeMap)]
ref (Text
var, TypeMap tp -> Some TypeMap
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some TypeMap tp
tp)
  SMTExpr h tp -> IO (SMTExpr h tp)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SMTExpr h tp -> IO (SMTExpr h tp))
-> SMTExpr h tp -> IO (SMTExpr h tp)
forall a b. (a -> b) -> a -> b
$! TypeMap tp -> Text -> SMTExpr h tp
forall (tp :: BaseType) h. TypeMap tp -> Text -> SMTExpr h tp
SMTName TypeMap tp
tp Text
var

-- | This describes the result that was collected from the solver.
data CollectorResults h a =
  CollectorResults { CollectorResults h a -> a
crResult :: !a
                     -- ^ Result from sandboxed computation.
                   , CollectorResults h a -> [(Text, Term h)]
crBindings :: !([(Text, Term h)])
                     -- ^ List of bound variables.
                   , CollectorResults h a -> [(Text, Some TypeMap)]
crFreeConstants :: !([(Text, Some TypeMap)])
                     -- ^ Constants added during generation.
                   , CollectorResults h a -> [Term h]
crSideConds :: !([Term h])
                     -- ^ List of Boolean predicates asserted by collector.
                   }

-- | Create a forall expression from a CollectorResult.
forallResult :: forall h
             .  SMTWriter h
             => CollectorResults h (Term h)
             -> Term h
forallResult :: CollectorResults h (Term h) -> Term h
forallResult CollectorResults h (Term h)
cr =
  [(Text, Some TypeMap)] -> Term h -> Term h
forall h. SMTWriter h => [(Text, Some TypeMap)] -> Term h -> Term h
forallExpr @h (CollectorResults h (Term h) -> [(Text, Some TypeMap)]
forall h a. CollectorResults h a -> [(Text, Some TypeMap)]
crFreeConstants CollectorResults h (Term h)
cr) (Term h -> Term h) -> Term h -> Term h
forall a b. (a -> b) -> a -> b
$
    [(Text, Term h)] -> Term h -> Term h
forall v. SupportTermOps v => [(Text, v)] -> v -> v
letExpr (CollectorResults h (Term h) -> [(Text, Term h)]
forall h a. CollectorResults h a -> [(Text, Term h)]
crBindings CollectorResults h (Term h)
cr) (Term h -> Term h) -> Term h -> Term h
forall a b. (a -> b) -> a -> b
$
      [Term h] -> Term h -> Term h
forall v. SupportTermOps v => [v] -> v -> v
impliesAllExpr (CollectorResults h (Term h) -> [Term h]
forall h a. CollectorResults h a -> [Term h]
crSideConds CollectorResults h (Term h)
cr) (CollectorResults h (Term h) -> Term h
forall h a. CollectorResults h a -> a
crResult CollectorResults h (Term h)
cr)

-- | @impliesAllExpr l r@ returns an expression equivalent to
-- forall l implies r.
impliesAllExpr :: SupportTermOps v => [v] -> v -> v
impliesAllExpr :: [v] -> v -> v
impliesAllExpr [v]
l v
r = [v] -> v
forall v. SupportTermOps v => [v] -> v
orAll ((v -> v
forall v. SupportTermOps v => v -> v
notExpr (v -> v) -> [v] -> [v]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [v]
l) [v] -> [v] -> [v]
forall a. [a] -> [a] -> [a]
++ [v
r])

-- | Create a forall expression from a CollectorResult.
existsResult :: forall h
             .  SMTWriter h
             => CollectorResults h (Term h)
             -> Term h
existsResult :: CollectorResults h (Term h) -> Term h
existsResult CollectorResults h (Term h)
cr =
  [(Text, Some TypeMap)] -> Term h -> Term h
forall h. SMTWriter h => [(Text, Some TypeMap)] -> Term h -> Term h
existsExpr @h (CollectorResults h (Term h) -> [(Text, Some TypeMap)]
forall h a. CollectorResults h a -> [(Text, Some TypeMap)]
crFreeConstants CollectorResults h (Term h)
cr) (Term h -> Term h) -> Term h -> Term h
forall a b. (a -> b) -> a -> b
$
    [(Text, Term h)] -> Term h -> Term h
forall v. SupportTermOps v => [(Text, v)] -> v -> v
letExpr (CollectorResults h (Term h) -> [(Text, Term h)]
forall h a. CollectorResults h a -> [(Text, Term h)]
crBindings CollectorResults h (Term h)
cr) (Term h -> Term h) -> Term h -> Term h
forall a b. (a -> b) -> a -> b
$
      [Term h] -> Term h
forall v. SupportTermOps v => [v] -> v
andAll (CollectorResults h (Term h) -> [Term h]
forall h a. CollectorResults h a -> [Term h]
crSideConds CollectorResults h (Term h)
cr [Term h] -> [Term h] -> [Term h]
forall a. [a] -> [a] -> [a]
++ [CollectorResults h (Term h) -> Term h
forall h a. CollectorResults h a -> a
crResult CollectorResults h (Term h)
cr])

-- | This runs the side collector and collects the results.
runInSandbox :: SupportTermOps (Term h)
             => WriterConn t h
             -> SMTCollector t h a
             -> IO (CollectorResults h a)
runInSandbox :: WriterConn t h -> SMTCollector t h a -> IO (CollectorResults h a)
runInSandbox WriterConn t h
conn SMTCollector t h a
sc = do
  -- A list of bound terms.
  IORef [(Text, Term h)]
boundTermRef    <- [(Text, Term h)] -> IO (IORef [(Text, Term h)])
forall a. a -> IO (IORef a)
newIORef []
  -- A list of free constants
  IORef [(Text, Some TypeMap)]
freeConstantRef <- ([(Text, Some TypeMap)] -> IO (IORef [(Text, Some TypeMap)])
forall a. a -> IO (IORef a)
newIORef [] :: IO (IORef [(Text, Some TypeMap)]))
  -- A list of references to side conditions.
  IORef [Term h]
sideCondRef     <- [Term h] -> IO (IORef [Term h])
forall a. a -> IO (IORef a)
newIORef []

  let s :: SMTCollectorState t h
s = SMTCollectorState :: forall t h.
WriterConn t h
-> (forall (rtp :: BaseType).
    Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> Term h -> IO ())
-> Maybe (FreshVarFn h)
-> Maybe (Term h -> IO ())
-> SMTCollectorState t h
SMTCollectorState
          { scConn :: WriterConn t h
scConn = WriterConn t h
conn
          , freshBoundTermFn :: forall (rtp :: BaseType).
Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> Term h -> IO ()
freshBoundTermFn = IORef [(Text, Term h)]
-> Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> Term h -> IO ()
forall v (rtp :: BaseType).
SupportTermOps v =>
IORef [(Text, v)]
-> Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> v -> IO ()
freshSandboxBoundTerm IORef [(Text, Term h)]
boundTermRef
          , freshConstantFn :: Maybe (FreshVarFn h)
freshConstantFn  = FreshVarFn h -> Maybe (FreshVarFn h)
forall a. a -> Maybe a
Just (FreshVarFn h -> Maybe (FreshVarFn h))
-> FreshVarFn h -> Maybe (FreshVarFn h)
forall a b. (a -> b) -> a -> b
$! (forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp))
-> FreshVarFn h
forall h.
(forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp))
-> FreshVarFn h
FreshVarFn (WriterConn t h
-> IORef [(Text, Some TypeMap)] -> TypeMap tp -> IO (SMTExpr h tp)
forall t h (tp :: BaseType).
WriterConn t h
-> IORef [(Text, Some TypeMap)] -> TypeMap tp -> IO (SMTExpr h tp)
freshSandboxConstant WriterConn t h
conn IORef [(Text, Some TypeMap)]
freeConstantRef)
          , recordSideCondFn :: Maybe (Term h -> IO ())
recordSideCondFn = (Term h -> IO ()) -> Maybe (Term h -> IO ())
forall a. a -> Maybe a
Just ((Term h -> IO ()) -> Maybe (Term h -> IO ()))
-> (Term h -> IO ()) -> Maybe (Term h -> IO ())
forall a b. (a -> b) -> a -> b
$! IORef [Term h] -> Term h -> IO ()
forall a. IORef [a] -> a -> IO ()
prependToRefList IORef [Term h]
sideCondRef
          }
  a
r <- SMTCollector t h a -> SMTCollectorState t h -> IO a
forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT SMTCollector t h a
sc SMTCollectorState t h
s

  [(Text, Term h)]
boundTerms    <- IORef [(Text, Term h)] -> IO [(Text, Term h)]
forall a. IORef a -> IO a
readIORef IORef [(Text, Term h)]
boundTermRef
  [(Text, Some TypeMap)]
freeConstants <- IORef [(Text, Some TypeMap)] -> IO [(Text, Some TypeMap)]
forall a. IORef a -> IO a
readIORef IORef [(Text, Some TypeMap)]
freeConstantRef
  [Term h]
sideConds     <- IORef [Term h] -> IO [Term h]
forall a. IORef a -> IO a
readIORef IORef [Term h]
sideCondRef
  CollectorResults h a -> IO (CollectorResults h a)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (CollectorResults h a -> IO (CollectorResults h a))
-> CollectorResults h a -> IO (CollectorResults h a)
forall a b. (a -> b) -> a -> b
$! CollectorResults :: forall h a.
a
-> [(Text, Term h)]
-> [(Text, Some TypeMap)]
-> [Term h]
-> CollectorResults h a
CollectorResults { crResult :: a
crResult = a
r
                             , crBindings :: [(Text, Term h)]
crBindings = [(Text, Term h)] -> [(Text, Term h)]
forall a. [a] -> [a]
reverse [(Text, Term h)]
boundTerms
                             , crFreeConstants :: [(Text, Some TypeMap)]
crFreeConstants = [(Text, Some TypeMap)] -> [(Text, Some TypeMap)]
forall a. [a] -> [a]
reverse [(Text, Some TypeMap)]
freeConstants
                             , crSideConds :: [Term h]
crSideConds = [Term h] -> [Term h]
forall a. [a] -> [a]
reverse [Term h]
sideConds
                             }

-- | Cache the result of writing an Expr named by the given nonce.
cacheWriterResult :: Nonce t tp
                     -- ^ Nonce to associate term with
                  -> TermLifetime
                     -- ^ Lifetime of term
                  -> SMTCollector t h (SMTExpr h tp)
                     -- ^ Action to create term.
                  -> SMTCollector t h (SMTExpr h tp)
cacheWriterResult :: Nonce t tp
-> TermLifetime
-> SMTCollector t h (SMTExpr h tp)
-> SMTCollector t h (SMTExpr h tp)
cacheWriterResult Nonce t tp
n TermLifetime
lifetime SMTCollector t h (SMTExpr h tp)
fallback = do
  WriterConn t h
c <- (SMTCollectorState t h -> WriterConn t h)
-> ReaderT (SMTCollectorState t h) IO (WriterConn t h)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks SMTCollectorState t h -> WriterConn t h
forall t h. SMTCollectorState t h -> WriterConn t h
scConn
  (IO (Maybe (SMTExpr h tp))
-> ReaderT (SMTCollectorState t h) IO (Maybe (SMTExpr h tp))
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (SMTExpr h tp))
 -> ReaderT (SMTCollectorState t h) IO (Maybe (SMTExpr h tp)))
-> IO (Maybe (SMTExpr h tp))
-> ReaderT (SMTCollectorState t h) IO (Maybe (SMTExpr h tp))
forall a b. (a -> b) -> a -> b
$ WriterConn t h -> Nonce t tp -> IO (Maybe (SMTExpr h tp))
forall t h (tp :: BaseType).
WriterConn t h -> Nonce t tp -> IO (Maybe (SMTExpr h tp))
cacheLookupExpr WriterConn t h
c Nonce t tp
n) ReaderT (SMTCollectorState t h) IO (Maybe (SMTExpr h tp))
-> (Maybe (SMTExpr h tp) -> SMTCollector t h (SMTExpr h tp))
-> SMTCollector t h (SMTExpr h tp)
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just SMTExpr h tp
x -> SMTExpr h tp -> SMTCollector t h (SMTExpr h tp)
forall (m :: Type -> Type) a. Monad m => a -> m a
return SMTExpr h tp
x
    Maybe (SMTExpr h tp)
Nothing -> do
      SMTExpr h tp
x <- SMTCollector t h (SMTExpr h tp)
fallback
      IO () -> ReaderT (SMTCollectorState t h) IO ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT (SMTCollectorState t h) IO ())
-> IO () -> ReaderT (SMTCollectorState t h) IO ()
forall a b. (a -> b) -> a -> b
$ WriterConn t h
-> Nonce t tp -> TermLifetime -> SMTExpr h tp -> IO ()
forall t h (tp :: BaseType).
WriterConn t h
-> Nonce t tp -> TermLifetime -> SMTExpr h tp -> IO ()
cacheValueExpr WriterConn t h
c Nonce t tp
n TermLifetime
lifetime SMTExpr h tp
x
      SMTExpr h tp -> SMTCollector t h (SMTExpr h tp)
forall (m :: Type -> Type) a. Monad m => a -> m a
return SMTExpr h tp
x

-- | Associate a bound variable with the givne SMT Expression until
-- the a
bindVar :: ExprBoundVar t tp
        -- ^ Variable to bind
        -> SMTExpr h tp
        -- ^ SMT Expression to bind to var.
        -> SMTCollector t h ()
bindVar :: ExprBoundVar t tp -> SMTExpr h tp -> SMTCollector t h ()
bindVar ExprBoundVar t tp
v SMTExpr h tp
x  = do
  let n :: Nonce t tp
n = ExprBoundVar t tp -> Nonce t tp
forall t (tp :: BaseType). ExprBoundVar t tp -> Nonce t tp
bvarId ExprBoundVar t tp
v
  WriterConn t h
c <- (SMTCollectorState t h -> WriterConn t h)
-> ReaderT (SMTCollectorState t h) IO (WriterConn t h)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks SMTCollectorState t h -> WriterConn t h
forall t h. SMTCollectorState t h -> WriterConn t h
scConn
  IO () -> SMTCollector t h ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> SMTCollector t h ()) -> IO () -> SMTCollector t h ()
forall a b. (a -> b) -> a -> b
$ do
    IO Bool -> IO () -> IO ()
forall (m :: Type -> Type). Monad m => m Bool -> m () -> m ()
whenM (Maybe (SMTExpr h tp) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (SMTExpr h tp) -> Bool)
-> IO (Maybe (SMTExpr h tp)) -> IO Bool
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterConn t h -> Nonce t tp -> IO (Maybe (SMTExpr h tp))
forall t h (tp :: BaseType).
WriterConn t h -> Nonce t tp -> IO (Maybe (SMTExpr h tp))
cacheLookupExpr WriterConn t h
c Nonce t tp
n) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Variable is already bound."
    WriterConn t h
-> Nonce t tp -> TermLifetime -> SMTExpr h tp -> IO ()
forall t h (tp :: BaseType).
WriterConn t h
-> Nonce t tp -> TermLifetime -> SMTExpr h tp -> IO ()
cacheValueExpr WriterConn t h
c Nonce t tp
n TermLifetime
DeleteOnPop SMTExpr h tp
x

------------------------------------------------------------------------
-- Evaluate applications.

-- @bvIntTerm w x@ builds an integer term that has the same value as
-- the unsigned integer value of the bitvector @x@.  This is done by
-- explicitly decomposing the positional notation of the bitvector
-- into a sum of powers of 2.
bvIntTerm :: forall v w
           . (SupportTermOps v, 1 <= w)
          => NatRepr w
          -> v
          -> v
bvIntTerm :: NatRepr w -> v -> v
bvIntTerm NatRepr w
w v
x = [v] -> v
forall v. SupportTermOps v => [v] -> v
sumExpr ((\Natural
i -> Natural -> v
digit (Natural
iNatural -> Natural -> Natural
forall a. Num a => a -> a -> a
-Natural
1)) (Natural -> v) -> [Natural] -> [v]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Natural
1..NatRepr w -> Natural
forall (n :: Nat). NatRepr n -> Natural
natValue NatRepr w
w])
 where digit :: Natural -> v
       digit :: Natural -> v
digit Natural
d = v -> v -> v -> v
forall v. SupportTermOps v => v -> v -> v -> v
ite (NatRepr w -> Natural -> v -> v
forall v (w :: Nat).
SupportTermOps v =>
NatRepr w -> Natural -> v -> v
bvTestBit NatRepr w
w Natural
d v
x)
                     (Integer -> v
forall a. Num a => Integer -> a
fromInteger (Integer
2Integer -> Natural -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^Natural
d))
                     v
0

sbvIntTerm :: SupportTermOps v
           => NatRepr w
           -> v
           -> v
sbvIntTerm :: NatRepr w -> v -> v
sbvIntTerm NatRepr w
w0 v
x0 = [v] -> v
forall v. SupportTermOps v => [v] -> v
sumExpr (v
signed_offset v -> [v] -> [v]
forall a. a -> [a] -> [a]
: NatRepr w -> v -> Natural -> [v]
forall v (w :: Nat).
SupportTermOps v =>
NatRepr w -> v -> Natural -> [v]
go NatRepr w
w0 v
x0 (NatRepr w -> Natural
forall (n :: Nat). NatRepr n -> Natural
natValue NatRepr w
w0 Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
2))
 where signed_offset :: v
signed_offset = v -> v -> v -> v
forall v. SupportTermOps v => v -> v -> v -> v
ite (NatRepr w -> Natural -> v -> v
forall v (w :: Nat).
SupportTermOps v =>
NatRepr w -> Natural -> v -> v
bvTestBit NatRepr w
w0 (NatRepr w -> Natural
forall (n :: Nat). NatRepr n -> Natural
natValue NatRepr w
w0 Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1) v
x0)
                           (Integer -> v
forall a. Num a => Integer -> a
fromInteger (Integer -> Integer
forall a. Num a => a -> a
negate (Integer
2Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(NatRepr w -> Int
forall (n :: Nat). NatRepr n -> Int
widthVal NatRepr w
w0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))))
                           v
0
       go :: SupportTermOps v => NatRepr w -> v -> Natural -> [v]
       go :: NatRepr w -> v -> Natural -> [v]
go NatRepr w
w v
x Natural
n
        | Natural
n Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
0     = NatRepr w -> v -> Natural -> v
forall v (w :: Nat).
SupportTermOps v =>
NatRepr w -> v -> Natural -> v
digit NatRepr w
w v
x Natural
n v -> [v] -> [v]
forall a. a -> [a] -> [a]
: NatRepr w -> v -> Natural -> [v]
forall v (w :: Nat).
SupportTermOps v =>
NatRepr w -> v -> Natural -> [v]
go NatRepr w
w v
x (Natural
nNatural -> Natural -> Natural
forall a. Num a => a -> a -> a
-Natural
1)
        | Natural
n Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== Natural
0    = [NatRepr w -> v -> Natural -> v
forall v (w :: Nat).
SupportTermOps v =>
NatRepr w -> v -> Natural -> v
digit NatRepr w
w v
x Natural
0]
        | Bool
otherwise = [] -- this branch should only be called in the degenerate case
                         -- of length 1 signed bitvectors

       digit :: SupportTermOps v => NatRepr w -> v -> Natural -> v
       digit :: NatRepr w -> v -> Natural -> v
digit NatRepr w
w v
x Natural
d = v -> v -> v -> v
forall v. SupportTermOps v => v -> v -> v -> v
ite (NatRepr w -> Natural -> v -> v
forall v (w :: Nat).
SupportTermOps v =>
NatRepr w -> Natural -> v -> v
bvTestBit NatRepr w
w Natural
d v
x)
                         (Integer -> v
forall a. Num a => Integer -> a
fromInteger (Integer
2Integer -> Natural -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^Natural
d))
                         v
0

unsupportedTerm  :: MonadFail m => Expr t tp -> m a
unsupportedTerm :: Expr t tp -> m a
unsupportedTerm Expr t tp
e =
  String -> m a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String) -> Doc Any -> String
forall a b. (a -> b) -> a -> b
$
  [Doc Any] -> Doc Any
forall ann. [Doc ann] -> Doc ann
vcat
  [ Doc Any
"Cannot generate solver output for term generated at"
      Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Position -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty (ProgramLoc -> Position
plSourceLoc (Expr t tp -> ProgramLoc
forall t (tp :: BaseType). Expr t tp -> ProgramLoc
exprLoc Expr t tp
e)) Doc Any -> Doc Any -> Doc Any
forall a. Semigroup a => a -> a -> a
<> Doc Any
":"
  , Int -> Doc Any -> Doc Any
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Expr t tp -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty Expr t tp
e)
  ]

-- | Checks whether a variable is supported.
--
-- Returns the SMT type of the variable and a predicate (if needed) that the variable
-- should be assumed to hold.  This is used for Natural number variables.
checkVarTypeSupport :: ExprBoundVar n tp -> SMTCollector n h ()
checkVarTypeSupport :: ExprBoundVar n tp -> SMTCollector n h ()
checkVarTypeSupport ExprBoundVar n tp
var = do
  let t :: Expr n tp
t = ExprBoundVar n tp -> Expr n tp
forall t (tp :: BaseType). ExprBoundVar t tp -> Expr t tp
BoundVarExpr ExprBoundVar n tp
var
  case ExprBoundVar n tp -> BaseTypeRepr tp
forall t (tp :: BaseType). ExprBoundVar t tp -> BaseTypeRepr tp
bvarType ExprBoundVar n tp
var of
    BaseTypeRepr tp
BaseIntegerRepr -> Expr n tp -> SMTCollector n h ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkIntegerSupport Expr n tp
t
    BaseTypeRepr tp
BaseRealRepr    -> Expr n tp -> SMTCollector n h ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkLinearSupport Expr n tp
t
    BaseTypeRepr tp
BaseComplexRepr -> Expr n tp -> SMTCollector n h ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkLinearSupport Expr n tp
t
    BaseStringRepr StringInfoRepr si
_ -> Expr n tp -> SMTCollector n h ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkStringSupport Expr n tp
t
    BaseFloatRepr FloatPrecisionRepr fpp
_  -> Expr n tp -> SMTCollector n h ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkFloatSupport Expr n tp
t
    BaseBVRepr NatRepr w
_     -> Expr n tp -> SMTCollector n h ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkBitvectorSupport Expr n tp
t
    BaseTypeRepr tp
_ -> () -> SMTCollector n h ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

theoryUnsupported :: MonadFail m => WriterConn t h -> String -> Expr t tp -> m a
theoryUnsupported :: WriterConn t h -> String -> Expr t tp -> m a
theoryUnsupported WriterConn t h
conn String
theory_name Expr t tp
t =
  String -> m a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String) -> Doc Any -> String
forall a b. (a -> b) -> a -> b
$
    String -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty (WriterConn t h -> String
forall t h. WriterConn t h -> String
smtWriterName WriterConn t h
conn) Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Any
"does not support the" Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty String
theory_name
    Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Any
"term generated at" Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Position -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty (ProgramLoc -> Position
plSourceLoc (Expr t tp -> ProgramLoc
forall t (tp :: BaseType). Expr t tp -> ProgramLoc
exprLoc Expr t tp
t))
    -- <> ":" <$$> indent 2 (pretty t)


checkIntegerSupport :: Expr t tp -> SMTCollector t h ()
checkIntegerSupport :: Expr t tp -> SMTCollector t h ()
checkIntegerSupport Expr t tp
t = do
  WriterConn t h
conn <- (SMTCollectorState t h -> WriterConn t h)
-> ReaderT (SMTCollectorState t h) IO (WriterConn t h)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks SMTCollectorState t h -> WriterConn t h
forall t h. SMTCollectorState t h -> WriterConn t h
scConn
  Bool -> SMTCollector t h () -> SMTCollector t h ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (WriterConn t h -> ProblemFeatures
forall t h. WriterConn t h -> ProblemFeatures
supportedFeatures WriterConn t h
conn ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useIntegerArithmetic) (SMTCollector t h () -> SMTCollector t h ())
-> SMTCollector t h () -> SMTCollector t h ()
forall a b. (a -> b) -> a -> b
$ do
    WriterConn t h -> String -> Expr t tp -> SMTCollector t h ()
forall (m :: Type -> Type) t h (tp :: BaseType) a.
MonadFail m =>
WriterConn t h -> String -> Expr t tp -> m a
theoryUnsupported WriterConn t h
conn String
"integer arithmetic" Expr t tp
t

checkStringSupport :: Expr t tp -> SMTCollector t h ()
checkStringSupport :: Expr t tp -> SMTCollector t h ()
checkStringSupport Expr t tp
t = do
  WriterConn t h
conn <- (SMTCollectorState t h -> WriterConn t h)
-> ReaderT (SMTCollectorState t h) IO (WriterConn t h)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks SMTCollectorState t h -> WriterConn t h
forall t h. SMTCollectorState t h -> WriterConn t h
scConn
  Bool -> SMTCollector t h () -> SMTCollector t h ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (WriterConn t h -> ProblemFeatures
forall t h. WriterConn t h -> ProblemFeatures
supportedFeatures WriterConn t h
conn ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useStrings) (SMTCollector t h () -> SMTCollector t h ())
-> SMTCollector t h () -> SMTCollector t h ()
forall a b. (a -> b) -> a -> b
$ do
    WriterConn t h -> String -> Expr t tp -> SMTCollector t h ()
forall (m :: Type -> Type) t h (tp :: BaseType) a.
MonadFail m =>
WriterConn t h -> String -> Expr t tp -> m a
theoryUnsupported WriterConn t h
conn String
"string" Expr t tp
t

checkBitvectorSupport :: Expr t tp -> SMTCollector t h ()
checkBitvectorSupport :: Expr t tp -> SMTCollector t h ()
checkBitvectorSupport Expr t tp
t = do
  WriterConn t h
conn <- (SMTCollectorState t h -> WriterConn t h)
-> ReaderT (SMTCollectorState t h) IO (WriterConn t h)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks SMTCollectorState t h -> WriterConn t h
forall t h. SMTCollectorState t h -> WriterConn t h
scConn
  Bool -> SMTCollector t h () -> SMTCollector t h ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (WriterConn t h -> ProblemFeatures
forall t h. WriterConn t h -> ProblemFeatures
supportedFeatures WriterConn t h
conn ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useBitvectors) (SMTCollector t h () -> SMTCollector t h ())
-> SMTCollector t h () -> SMTCollector t h ()
forall a b. (a -> b) -> a -> b
$ do
    WriterConn t h -> String -> Expr t tp -> SMTCollector t h ()
forall (m :: Type -> Type) t h (tp :: BaseType) a.
MonadFail m =>
WriterConn t h -> String -> Expr t tp -> m a
theoryUnsupported WriterConn t h
conn String
"bitvector" Expr t tp
t

checkFloatSupport :: Expr t tp -> SMTCollector t h ()
checkFloatSupport :: Expr t tp -> SMTCollector t h ()
checkFloatSupport Expr t tp
t = do
  WriterConn t h
conn <- (SMTCollectorState t h -> WriterConn t h)
-> ReaderT (SMTCollectorState t h) IO (WriterConn t h)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks SMTCollectorState t h -> WriterConn t h
forall t h. SMTCollectorState t h -> WriterConn t h
scConn
  Bool -> SMTCollector t h () -> SMTCollector t h ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (WriterConn t h -> ProblemFeatures
forall t h. WriterConn t h -> ProblemFeatures
supportedFeatures WriterConn t h
conn ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useFloatingPoint) (SMTCollector t h () -> SMTCollector t h ())
-> SMTCollector t h () -> SMTCollector t h ()
forall a b. (a -> b) -> a -> b
$ do
    WriterConn t h -> String -> Expr t tp -> SMTCollector t h ()
forall (m :: Type -> Type) t h (tp :: BaseType) a.
MonadFail m =>
WriterConn t h -> String -> Expr t tp -> m a
theoryUnsupported WriterConn t h
conn String
"floating-point arithmetic" Expr t tp
t

checkLinearSupport :: Expr t tp -> SMTCollector t h ()
checkLinearSupport :: Expr t tp -> SMTCollector t h ()
checkLinearSupport Expr t tp
t = do
  WriterConn t h
conn <- (SMTCollectorState t h -> WriterConn t h)
-> ReaderT (SMTCollectorState t h) IO (WriterConn t h)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks SMTCollectorState t h -> WriterConn t h
forall t h. SMTCollectorState t h -> WriterConn t h
scConn
  Bool -> SMTCollector t h () -> SMTCollector t h ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (WriterConn t h -> ProblemFeatures
forall t h. WriterConn t h -> ProblemFeatures
supportedFeatures WriterConn t h
conn ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useLinearArithmetic) (SMTCollector t h () -> SMTCollector t h ())
-> SMTCollector t h () -> SMTCollector t h ()
forall a b. (a -> b) -> a -> b
$ do
    WriterConn t h -> String -> Expr t tp -> SMTCollector t h ()
forall (m :: Type -> Type) t h (tp :: BaseType) a.
MonadFail m =>
WriterConn t h -> String -> Expr t tp -> m a
theoryUnsupported WriterConn t h
conn String
"linear arithmetic" Expr t tp
t

checkNonlinearSupport :: Expr t tp -> SMTCollector t h ()
checkNonlinearSupport :: Expr t tp -> SMTCollector t h ()
checkNonlinearSupport Expr t tp
t = do
  WriterConn t h
conn <- (SMTCollectorState t h -> WriterConn t h)
-> ReaderT (SMTCollectorState t h) IO (WriterConn t h)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks SMTCollectorState t h -> WriterConn t h
forall t h. SMTCollectorState t h -> WriterConn t h
scConn
  Bool -> SMTCollector t h () -> SMTCollector t h ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (WriterConn t h -> ProblemFeatures
forall t h. WriterConn t h -> ProblemFeatures
supportedFeatures WriterConn t h
conn ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useNonlinearArithmetic) (SMTCollector t h () -> SMTCollector t h ())
-> SMTCollector t h () -> SMTCollector t h ()
forall a b. (a -> b) -> a -> b
$ do
    WriterConn t h -> String -> Expr t tp -> SMTCollector t h ()
forall (m :: Type -> Type) t h (tp :: BaseType) a.
MonadFail m =>
WriterConn t h -> String -> Expr t tp -> m a
theoryUnsupported WriterConn t h
conn String
"non-linear arithmetic" Expr t tp
t

checkComputableSupport :: Expr t tp -> SMTCollector t h ()
checkComputableSupport :: Expr t tp -> SMTCollector t h ()
checkComputableSupport Expr t tp
t = do
  WriterConn t h
conn <- (SMTCollectorState t h -> WriterConn t h)
-> ReaderT (SMTCollectorState t h) IO (WriterConn t h)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks SMTCollectorState t h -> WriterConn t h
forall t h. SMTCollectorState t h -> WriterConn t h
scConn
  Bool -> SMTCollector t h () -> SMTCollector t h ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (WriterConn t h -> ProblemFeatures
forall t h. WriterConn t h -> ProblemFeatures
supportedFeatures WriterConn t h
conn ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useComputableReals) (SMTCollector t h () -> SMTCollector t h ())
-> SMTCollector t h () -> SMTCollector t h ()
forall a b. (a -> b) -> a -> b
$ do
    WriterConn t h -> String -> Expr t tp -> SMTCollector t h ()
forall (m :: Type -> Type) t h (tp :: BaseType) a.
MonadFail m =>
WriterConn t h -> String -> Expr t tp -> m a
theoryUnsupported WriterConn t h
conn String
"computable arithmetic" Expr t tp
t

checkQuantifierSupport :: String -> Expr t p -> SMTCollector t h ()
checkQuantifierSupport :: String -> Expr t p -> SMTCollector t h ()
checkQuantifierSupport String
nm Expr t p
t = do
  WriterConn t h
conn <- (SMTCollectorState t h -> WriterConn t h)
-> ReaderT (SMTCollectorState t h) IO (WriterConn t h)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks SMTCollectorState t h -> WriterConn t h
forall t h. SMTCollectorState t h -> WriterConn t h
scConn
  Bool -> SMTCollector t h () -> SMTCollector t h ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (WriterConn t h -> Bool
forall t h. WriterConn t h -> Bool
supportQuantifiers WriterConn t h
conn Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
False) (SMTCollector t h () -> SMTCollector t h ())
-> SMTCollector t h () -> SMTCollector t h ()
forall a b. (a -> b) -> a -> b
$ do
    WriterConn t h -> String -> Expr t p -> SMTCollector t h ()
forall (m :: Type -> Type) t h (tp :: BaseType) a.
MonadFail m =>
WriterConn t h -> String -> Expr t tp -> m a
theoryUnsupported WriterConn t h
conn String
nm Expr t p
t

-- | Check that the types can be passed to functions.
checkArgumentTypes :: WriterConn t h -> Ctx.Assignment TypeMap args -> IO ()
checkArgumentTypes :: WriterConn t h -> Assignment TypeMap args -> IO ()
checkArgumentTypes WriterConn t h
conn Assignment TypeMap args
types = do
  Assignment TypeMap args
-> (forall (x :: BaseType). TypeMap x -> IO ()) -> IO ()
forall k l (t :: (k -> Type) -> l -> Type) (m :: Type -> Type)
       (f :: k -> Type) (c :: l) a.
(FoldableFC t, Applicative m) =>
t f c -> (forall (x :: k). f x -> m a) -> m ()
forFC_ Assignment TypeMap args
types ((forall (x :: BaseType). TypeMap x -> IO ()) -> IO ())
-> (forall (x :: BaseType). TypeMap x -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \TypeMap x
tp -> do
    case TypeMap x
tp of
      FnArrayTypeMap{} | WriterConn t h -> Bool
forall t h. WriterConn t h -> Bool
supportFunctionArguments WriterConn t h
conn Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
False -> do
          String -> IO ()
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String) -> Doc Any -> String
forall a b. (a -> b) -> a -> b
$ String -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty (WriterConn t h -> String
forall t h. WriterConn t h -> String
smtWriterName WriterConn t h
conn)
             Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Any
"does not allow arrays encoded as functions to be function arguments."
      TypeMap x
_ ->
        () -> IO ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

-- | This generates an error message from a solver and a type error.
--
-- It issed for error reporting
type SMTSource ann = String -> BaseTypeError -> Doc ann

ppBaseTypeError :: BaseTypeError -> Doc ann
ppBaseTypeError :: BaseTypeError -> Doc ann
ppBaseTypeError BaseTypeError
ComplexTypeUnsupported = Doc ann
"complex values"
ppBaseTypeError BaseTypeError
ArrayUnsupported = Doc ann
"arrays encoded as a functions"
ppBaseTypeError (StringTypeUnsupported (Some StringInfoRepr x
si)) = Doc ann
"string values" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> StringInfoRepr x -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow StringInfoRepr x
si

eltSource :: Expr t tp -> SMTSource ann
eltSource :: Expr t tp -> SMTSource ann
eltSource Expr t tp
e String
solver_name BaseTypeError
cause =
  [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
  [ String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
solver_name Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
    Doc ann
"does not support" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> BaseTypeError -> Doc ann
forall ann. BaseTypeError -> Doc ann
ppBaseTypeError BaseTypeError
cause Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>
    Doc ann
", and cannot interpret the term generated at" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
    Position -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (ProgramLoc -> Position
plSourceLoc (Expr t tp -> ProgramLoc
forall t (tp :: BaseType). Expr t tp -> ProgramLoc
exprLoc Expr t tp
e)) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
":"
  , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Expr t tp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Expr t tp
e) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"."
  ]

fnSource :: SolverSymbol -> ProgramLoc -> SMTSource ann
fnSource :: SolverSymbol -> ProgramLoc -> SMTSource ann
fnSource SolverSymbol
fn_name ProgramLoc
loc String
solver_name BaseTypeError
cause =
  String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
solver_name Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
  Doc ann
"does not support" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> BaseTypeError -> Doc ann
forall ann. BaseTypeError -> Doc ann
ppBaseTypeError BaseTypeError
cause Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>
  Doc ann
", and cannot interpret the function" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> SolverSymbol -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow SolverSymbol
fn_name Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
  Doc ann
"generated at" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Position -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (ProgramLoc -> Position
plSourceLoc ProgramLoc
loc) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"."

-- | Evaluate a base type repr as a first class SMT type.
--
-- First class types are those that can be passed as function arguments and
-- returned by functions.
evalFirstClassTypeRepr :: MonadFail m
                       => WriterConn t h
                       -> SMTSource ann
                       -> BaseTypeRepr tp
                       -> m (TypeMap tp)
evalFirstClassTypeRepr :: WriterConn t h
-> SMTSource ann -> BaseTypeRepr tp -> m (TypeMap tp)
evalFirstClassTypeRepr WriterConn t h
conn SMTSource ann
src BaseTypeRepr tp
base_tp =
  case WriterConn t h
-> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
forall t h (tp :: BaseType).
WriterConn t h
-> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
typeMapFirstClass WriterConn t h
conn BaseTypeRepr tp
base_tp of
    Left BaseTypeError
e -> String -> m (TypeMap tp)
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> m (TypeMap tp)) -> String -> m (TypeMap tp)
forall a b. (a -> b) -> a -> b
$ Doc ann -> String
forall a. Show a => a -> String
show (Doc ann -> String) -> Doc ann -> String
forall a b. (a -> b) -> a -> b
$ SMTSource ann
src (WriterConn t h -> String
forall t h. WriterConn t h -> String
smtWriterName WriterConn t h
conn) BaseTypeError
e
    Right TypeMap tp
smt_ret -> TypeMap tp -> m (TypeMap tp)
forall (m :: Type -> Type) a. Monad m => a -> m a
return TypeMap tp
smt_ret

withConnEntryStack :: WriterConn t h -> IO a -> IO a
withConnEntryStack :: WriterConn t h -> IO a -> IO a
withConnEntryStack WriterConn t h
conn = IO () -> IO () -> IO a -> IO a
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (WriterConn t h -> IO ()
forall t h. WriterConn t h -> IO ()
pushEntryStack WriterConn t h
conn) (WriterConn t h -> IO ()
forall t h. WriterConn t h -> IO ()
popEntryStack WriterConn t h
conn)

-- | Convert structure to list.
mkIndexLitTerm :: SupportTermOps v
               => IndexLit tp
               -> v
mkIndexLitTerm :: IndexLit tp -> v
mkIndexLitTerm (IntIndexLit Integer
i)  = Integer -> v
forall a. Num a => Integer -> a
fromInteger Integer
i
mkIndexLitTerm (BVIndexLit NatRepr w
w BV w
i) = NatRepr w -> BV w -> v
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w BV w
i

-- | Convert structure to list.
mkIndexLitTerms :: SupportTermOps v
                => Ctx.Assignment IndexLit ctx
                -> [v]
mkIndexLitTerms :: Assignment IndexLit ctx -> [v]
mkIndexLitTerms = (forall (x :: BaseType). IndexLit x -> v)
-> forall (x :: Ctx BaseType). Assignment IndexLit x -> [v]
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type) a.
FoldableFC t =>
(forall (x :: k). f x -> a) -> forall (x :: l). t f x -> [a]
toListFC forall v (tp :: BaseType). SupportTermOps v => IndexLit tp -> v
forall (x :: BaseType). IndexLit x -> v
mkIndexLitTerm

-- | Create index arguments with given type.
--
-- Returns the name of the argument and the type.
createTypeMapArgsForArray :: forall t h args
                          .  WriterConn t h
                          -> Ctx.Assignment TypeMap args
                          -> IO [(Text, Some TypeMap)]
createTypeMapArgsForArray :: WriterConn t h
-> Assignment TypeMap args -> IO [(Text, Some TypeMap)]
createTypeMapArgsForArray WriterConn t h
conn Assignment TypeMap args
types = do
  -- Create names for index variables.
  let mkIndexVar :: TypeMap utp -> IO (Text, Some TypeMap)
      mkIndexVar :: TypeMap utp -> IO (Text, Some TypeMap)
mkIndexVar TypeMap utp
base_tp = do
        Text
i_nm <- WriterConn t h -> State WriterState Text -> IO Text
forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn (State WriterState Text -> IO Text)
-> State WriterState Text -> IO Text
forall a b. (a -> b) -> a -> b
$ Builder -> State WriterState Text
freshVarName' Builder
"i!"
        (Text, Some TypeMap) -> IO (Text, Some TypeMap)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text
i_nm, TypeMap utp -> Some TypeMap
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some TypeMap utp
base_tp)
  -- Get SMT arguments.
  [IO (Text, Some TypeMap)] -> IO [(Text, Some TypeMap)]
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([IO (Text, Some TypeMap)] -> IO [(Text, Some TypeMap)])
-> [IO (Text, Some TypeMap)] -> IO [(Text, Some TypeMap)]
forall a b. (a -> b) -> a -> b
$ (forall (x :: BaseType). TypeMap x -> IO (Text, Some TypeMap))
-> Assignment TypeMap args -> [IO (Text, Some TypeMap)]
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type) a.
FoldableFC t =>
(forall (x :: k). f x -> a) -> forall (x :: l). t f x -> [a]
toListFC forall (x :: BaseType). TypeMap x -> IO (Text, Some TypeMap)
mkIndexVar Assignment TypeMap args
types

smt_array_select :: forall h idxl idx tp
                 .  SMTWriter h
                 => SMTExpr h (BaseArrayType (idxl Ctx.::> idx) tp)
                 -> [Term h]
                 -> SMTExpr h tp
smt_array_select :: SMTExpr h (BaseArrayType (idxl ::> idx) tp)
-> [Term h] -> SMTExpr h tp
smt_array_select SMTExpr h (BaseArrayType (idxl ::> idx) tp)
aexpr [Term h]
idxl =
  case SMTExpr h (BaseArrayType (idxl ::> idx) tp)
-> TypeMap (BaseArrayType (idxl ::> idx) tp)
forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h (BaseArrayType (idxl ::> idx) tp)
aexpr of
    PrimArrayTypeMap Assignment TypeMap (idxl ::> idx)
_ TypeMap tp
res_type ->
      TypeMap tp -> Term h -> SMTExpr h tp
forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap tp
res_type (Term h -> SMTExpr h tp) -> Term h -> SMTExpr h tp
forall a b. (a -> b) -> a -> b
$ Term h -> [Term h] -> Term h
forall h. SMTWriter h => Term h -> [Term h] -> Term h
arraySelect @h (SMTExpr h (BaseArrayType (idxl ::> idx) tp) -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h (BaseArrayType (idxl ::> idx) tp)
aexpr) [Term h]
idxl
    FnArrayTypeMap Assignment TypeMap (idxl ::> idx)
_ TypeMap tp
res_type ->
      TypeMap tp -> Term h -> SMTExpr h tp
forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap tp
res_type (Term h -> SMTExpr h tp) -> Term h -> SMTExpr h tp
forall a b. (a -> b) -> a -> b
$ Term h -> [Term h] -> Term h
forall v. SupportTermOps v => v -> [v] -> v
smtFnApp (SMTExpr h (BaseArrayType (idxl ::> idx) tp) -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h (BaseArrayType (idxl ::> idx) tp)
aexpr) [Term h]
idxl

-- | Get name associated with symbol binding if defined, creating it if needed.
getSymbolName :: WriterConn t h -> SymbolBinding t -> IO Text
getSymbolName :: WriterConn t h -> SymbolBinding t -> IO Text
getSymbolName WriterConn t h
conn SymbolBinding t
b =
  case SymbolBinding t -> SymbolVarBimap t -> Maybe SolverSymbol
forall t. SymbolBinding t -> SymbolVarBimap t -> Maybe SolverSymbol
lookupSymbolOfBinding SymbolBinding t
b (WriterConn t h -> SymbolVarBimap t
forall t h. WriterConn t h -> SymbolVarBimap t
varBindings WriterConn t h
conn) of
    Just SolverSymbol
sym -> Text -> IO Text
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$! SolverSymbol -> Text
solverSymbolAsText SolverSymbol
sym
    Maybe SolverSymbol
Nothing -> WriterConn t h -> State WriterState Text -> IO Text
forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn (State WriterState Text -> IO Text)
-> State WriterState Text -> IO Text
forall a b. (a -> b) -> a -> b
$ State WriterState Text
freshVarName

-- | 'defineSMTFunction conn var action' will introduce a function
--
-- It returns the return type of the value.
-- Note: This function is declared at a global scope.  It bypasses
-- any subfunctions.  We need to investigate how to support nested
-- functions.
defineSMTFunction :: SMTWriter h
                  => WriterConn t h
                  -> Text
                  -> (FreshVarFn h -> SMTCollector t h (SMTExpr h ret))
                     -- ^ Action to generate
                  -> IO (TypeMap ret)
defineSMTFunction :: WriterConn t h
-> Text
-> (FreshVarFn h -> SMTCollector t h (SMTExpr h ret))
-> IO (TypeMap ret)
defineSMTFunction WriterConn t h
conn Text
var FreshVarFn h -> SMTCollector t h (SMTExpr h ret)
action =
  WriterConn t h -> IO (TypeMap ret) -> IO (TypeMap ret)
forall t h a. WriterConn t h -> IO a -> IO a
withConnEntryStack WriterConn t h
conn (IO (TypeMap ret) -> IO (TypeMap ret))
-> IO (TypeMap ret) -> IO (TypeMap ret)
forall a b. (a -> b) -> a -> b
$ do
    -- A list of bound terms.
    IORef [(Text, Some TypeMap)]
freeConstantRef <- ([(Text, Some TypeMap)] -> IO (IORef [(Text, Some TypeMap)])
forall a. a -> IO (IORef a)
newIORef [] :: IO (IORef [(Text, Some TypeMap)]))
    IORef [(Text, Term h)]
boundTermRef    <- [(Text, Term h)] -> IO (IORef [(Text, Term h)])
forall a. a -> IO (IORef a)
newIORef []
    let s :: SMTCollectorState t h
s = SMTCollectorState :: forall t h.
WriterConn t h
-> (forall (rtp :: BaseType).
    Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> Term h -> IO ())
-> Maybe (FreshVarFn h)
-> Maybe (Term h -> IO ())
-> SMTCollectorState t h
SMTCollectorState { scConn :: WriterConn t h
scConn = WriterConn t h
conn
                              , freshBoundTermFn :: forall (rtp :: BaseType).
Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> Term h -> IO ()
freshBoundTermFn = IORef [(Text, Term h)]
-> Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> Term h -> IO ()
forall v (rtp :: BaseType).
SupportTermOps v =>
IORef [(Text, v)]
-> Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> v -> IO ()
freshSandboxBoundTerm IORef [(Text, Term h)]
boundTermRef
                              , freshConstantFn :: Maybe (FreshVarFn h)
freshConstantFn  = Maybe (FreshVarFn h)
forall a. Maybe a
Nothing
                              , recordSideCondFn :: Maybe (Term h -> IO ())
recordSideCondFn = Maybe (Term h -> IO ())
forall a. Maybe a
Nothing
                              }
    -- Associate a variable with each bound variable
    let varFn :: FreshVarFn h
varFn = (forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp))
-> FreshVarFn h
forall h.
(forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp))
-> FreshVarFn h
FreshVarFn (WriterConn t h
-> IORef [(Text, Some TypeMap)] -> TypeMap tp -> IO (SMTExpr h tp)
forall t h (tp :: BaseType).
WriterConn t h
-> IORef [(Text, Some TypeMap)] -> TypeMap tp -> IO (SMTExpr h tp)
freshSandboxConstant WriterConn t h
conn IORef [(Text, Some TypeMap)]
freeConstantRef)
    SMTExpr h ret
pair <- (SMTCollector t h (SMTExpr h ret)
 -> SMTCollectorState t h -> IO (SMTExpr h ret))
-> SMTCollectorState t h
-> SMTCollector t h (SMTExpr h ret)
-> IO (SMTExpr h ret)
forall a b c. (a -> b -> c) -> b -> a -> c
flip SMTCollector t h (SMTExpr h ret)
-> SMTCollectorState t h -> IO (SMTExpr h ret)
forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT SMTCollectorState t h
s (FreshVarFn h -> SMTCollector t h (SMTExpr h ret)
action FreshVarFn h
varFn)

    [(Text, Some TypeMap)]
args       <- IORef [(Text, Some TypeMap)] -> IO [(Text, Some TypeMap)]
forall a. IORef a -> IO a
readIORef IORef [(Text, Some TypeMap)]
freeConstantRef
    [(Text, Term h)]
boundTerms <- IORef [(Text, Term h)] -> IO [(Text, Term h)]
forall a. IORef a -> IO a
readIORef IORef [(Text, Term h)]
boundTermRef

    let res :: Term h
res = [(Text, Term h)] -> Term h -> Term h
forall v. SupportTermOps v => [(Text, v)] -> v -> v
letExpr ([(Text, Term h)] -> [(Text, Term h)]
forall a. [a] -> [a]
reverse [(Text, Term h)]
boundTerms) (SMTExpr h ret -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h ret
pair)

    WriterConn t h
-> DefineStyle
-> Text
-> [(Text, Some TypeMap)]
-> TypeMap ret
-> Term h
-> IO ()
forall h t (rtp :: BaseType).
SMTWriter h =>
WriterConn t h
-> DefineStyle
-> Text
-> [(Text, Some TypeMap)]
-> TypeMap rtp
-> Term h
-> IO ()
defineSMTVar WriterConn t h
conn DefineStyle
FunctionDefinition Text
var ([(Text, Some TypeMap)] -> [(Text, Some TypeMap)]
forall a. [a] -> [a]
reverse [(Text, Some TypeMap)]
args) (SMTExpr h ret -> TypeMap ret
forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h ret
pair) Term h
res
    TypeMap ret -> IO (TypeMap ret)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (TypeMap ret -> IO (TypeMap ret))
-> TypeMap ret -> IO (TypeMap ret)
forall a b. (a -> b) -> a -> b
$! SMTExpr h ret -> TypeMap ret
forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h ret
pair

------------------------------------------------------------------------
-- Mutually recursive functions for translating What4 expressions to SMTLIB definitions.

-- | Convert an expression into a SMT Expression.
mkExpr :: forall h t tp. SMTWriter h => Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr :: Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr (BoolExpr Bool
b ProgramLoc
_) =
  SMTExpr h BaseBoolType
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h BaseBoolType)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (TypeMap BaseBoolType -> Term h -> SMTExpr h BaseBoolType
forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap BaseBoolType
BoolTypeMap (Bool -> Term h
forall v. SupportTermOps v => Bool -> v
boolExpr Bool
b))
mkExpr t :: Expr t tp
t@(SemiRingLiteral SemiRingRepr sr
SR.SemiRingIntegerRepr Coefficient sr
i ProgramLoc
_) = do
  Expr t tp -> SMTCollector t h ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkLinearSupport Expr t tp
t
  SMTExpr h BaseIntegerType
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h BaseIntegerType)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (TypeMap BaseIntegerType -> Term h -> SMTExpr h BaseIntegerType
forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap BaseIntegerType
IntegerTypeMap (Integer -> Term h
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
Coefficient sr
i))
mkExpr t :: Expr t tp
t@(SemiRingLiteral SemiRingRepr sr
SR.SemiRingRealRepr Coefficient sr
r ProgramLoc
_) = do
  Expr t tp -> SMTCollector t h ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkLinearSupport Expr t tp
t
  SMTExpr h BaseRealType
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h BaseRealType)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (TypeMap BaseRealType -> Term h -> SMTExpr h BaseRealType
forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap BaseRealType
RealTypeMap (Rational -> Term h
forall v. SupportTermOps v => Rational -> v
rationalTerm Rational
Coefficient sr
r))
mkExpr t :: Expr t tp
t@(SemiRingLiteral (SR.SemiRingBVRepr BVFlavorRepr fv
_flv NatRepr w
w) Coefficient sr
x ProgramLoc
_) = do
  Expr t tp -> SMTCollector t h ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkBitvectorSupport Expr t tp
t
  SMTExpr h (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h (BaseBVType w))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SMTExpr h (BaseBVType w)
 -> ReaderT (SMTCollectorState t h) IO (SMTExpr h (BaseBVType w)))
-> SMTExpr h (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h (BaseBVType w))
forall a b. (a -> b) -> a -> b
$ TypeMap (BaseBVType w) -> Term h -> SMTExpr h (BaseBVType w)
forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr (NatRepr w -> TypeMap (BaseBVType w)
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr w
w) (Term h -> SMTExpr h (BaseBVType w))
-> Term h -> SMTExpr h (BaseBVType w)
forall a b. (a -> b) -> a -> b
$ NatRepr w -> BV w -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w BV w
Coefficient sr
x
mkExpr t :: Expr t tp
t@(FloatExpr FloatPrecisionRepr fpp
fpp BigFloat
f ProgramLoc
_) = do
  Expr t tp -> SMTCollector t h ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkFloatSupport Expr t tp
t
  SMTExpr h (BaseFloatType fpp)
-> ReaderT
     (SMTCollectorState t h) IO (SMTExpr h (BaseFloatType fpp))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SMTExpr h (BaseFloatType fpp)
 -> ReaderT
      (SMTCollectorState t h) IO (SMTExpr h (BaseFloatType fpp)))
-> SMTExpr h (BaseFloatType fpp)
-> ReaderT
     (SMTCollectorState t h) IO (SMTExpr h (BaseFloatType fpp))
forall a b. (a -> b) -> a -> b
$ TypeMap (BaseFloatType fpp)
-> Term h -> SMTExpr h (BaseFloatType fpp)
forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr (FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
forall (fpp :: FloatPrecision).
FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
FloatTypeMap FloatPrecisionRepr fpp
fpp) (Term h -> SMTExpr h (BaseFloatType fpp))
-> Term h -> SMTExpr h (BaseFloatType fpp)
forall a b. (a -> b) -> a -> b
$ FloatPrecisionRepr fpp -> BigFloat -> Term h
forall v (fpp :: FloatPrecision).
SupportTermOps v =>
FloatPrecisionRepr fpp -> BigFloat -> v
floatTerm FloatPrecisionRepr fpp
fpp BigFloat
f
mkExpr t :: Expr t tp
t@(StringExpr StringLiteral si
l ProgramLoc
_) =
  case StringLiteral si
l of
    Char8Literal ByteString
bs -> do
      Expr t tp -> SMTCollector t h ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkStringSupport Expr t tp
t
      SMTExpr h (BaseStringType Char8)
-> ReaderT
     (SMTCollectorState t h) IO (SMTExpr h (BaseStringType Char8))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SMTExpr h (BaseStringType Char8)
 -> ReaderT
      (SMTCollectorState t h) IO (SMTExpr h (BaseStringType Char8)))
-> SMTExpr h (BaseStringType Char8)
-> ReaderT
     (SMTCollectorState t h) IO (SMTExpr h (BaseStringType Char8))
forall a b. (a -> b) -> a -> b
$ TypeMap (BaseStringType Char8)
-> Term h -> SMTExpr h (BaseStringType Char8)
forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap (BaseStringType Char8)
Char8TypeMap (Term h -> SMTExpr h (BaseStringType Char8))
-> Term h -> SMTExpr h (BaseStringType Char8)
forall a b. (a -> b) -> a -> b
$ ByteString -> Term h
forall h. SMTWriter h => ByteString -> Term h
stringTerm @h ByteString
bs
    StringLiteral si
_ -> do
      WriterConn t h
conn <- (SMTCollectorState t h -> WriterConn t h)
-> ReaderT (SMTCollectorState t h) IO (WriterConn t h)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks SMTCollectorState t h -> WriterConn t h
forall t h. SMTCollectorState t h -> WriterConn t h
scConn
      WriterConn t h
-> String -> Expr t tp -> SMTCollector t h (SMTExpr h tp)
forall (m :: Type -> Type) t h (tp :: BaseType) a.
MonadFail m =>
WriterConn t h -> String -> Expr t tp -> m a
theoryUnsupported WriterConn t h
conn (String
"strings " String -> String -> String
forall a. [a] -> [a] -> [a]
++ StringInfoRepr si -> String
forall a. Show a => a -> String
show (StringLiteral si -> StringInfoRepr si
forall (si :: StringInfo). StringLiteral si -> StringInfoRepr si
stringLiteralInfo StringLiteral si
l)) Expr t tp
t

mkExpr (NonceAppExpr NonceAppExpr t tp
ea) =
  Nonce t tp
-> TermLifetime
-> SMTCollector t h (SMTExpr h tp)
-> SMTCollector t h (SMTExpr h tp)
forall t (tp :: BaseType) h.
Nonce t tp
-> TermLifetime
-> SMTCollector t h (SMTExpr h tp)
-> SMTCollector t h (SMTExpr h tp)
cacheWriterResult (NonceAppExpr t tp -> Nonce t tp
forall t (tp :: BaseType). NonceAppExpr t tp -> Nonce t tp
nonceExprId NonceAppExpr t tp
ea) TermLifetime
DeleteOnPop (SMTCollector t h (SMTExpr h tp)
 -> SMTCollector t h (SMTExpr h tp))
-> SMTCollector t h (SMTExpr h tp)
-> SMTCollector t h (SMTExpr h tp)
forall a b. (a -> b) -> a -> b
$
    NonceAppExpr t tp -> SMTCollector t h (SMTExpr h tp)
forall t h (tp :: BaseType).
SMTWriter h =>
NonceAppExpr t tp -> SMTCollector t h (SMTExpr h tp)
predSMTExpr NonceAppExpr t tp
ea
mkExpr (AppExpr AppExpr t tp
ea) =
  Nonce t tp
-> TermLifetime
-> SMTCollector t h (SMTExpr h tp)
-> SMTCollector t h (SMTExpr h tp)
forall t (tp :: BaseType) h.
Nonce t tp
-> TermLifetime
-> SMTCollector t h (SMTExpr h tp)
-> SMTCollector t h (SMTExpr h tp)
cacheWriterResult (AppExpr t tp -> Nonce t tp
forall t (tp :: BaseType). AppExpr t tp -> Nonce t tp
appExprId AppExpr t tp
ea) TermLifetime
DeleteOnPop (SMTCollector t h (SMTExpr h tp)
 -> SMTCollector t h (SMTExpr h tp))
-> SMTCollector t h (SMTExpr h tp)
-> SMTCollector t h (SMTExpr h tp)
forall a b. (a -> b) -> a -> b
$ do
    AppExpr t tp -> SMTCollector t h (SMTExpr h tp)
forall t h (tp :: BaseType).
SMTWriter h =>
AppExpr t tp -> SMTCollector t h (SMTExpr h tp)
appSMTExpr AppExpr t tp
ea
mkExpr (BoundVarExpr ExprBoundVar t tp
var) = do
  case ExprBoundVar t tp -> VarKind
forall t (tp :: BaseType). ExprBoundVar t tp -> VarKind
bvarKind ExprBoundVar t tp
var of
   VarKind
QuantifierVarKind -> do
     WriterConn t h
conn <- (SMTCollectorState t h -> WriterConn t h)
-> ReaderT (SMTCollectorState t h) IO (WriterConn t h)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks SMTCollectorState t h -> WriterConn t h
forall t h. SMTCollectorState t h -> WriterConn t h
scConn
     Maybe (SMTExpr h tp)
mr <- IO (Maybe (SMTExpr h tp))
-> ReaderT (SMTCollectorState t h) IO (Maybe (SMTExpr h tp))
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (SMTExpr h tp))
 -> ReaderT (SMTCollectorState t h) IO (Maybe (SMTExpr h tp)))
-> IO (Maybe (SMTExpr h tp))
-> ReaderT (SMTCollectorState t h) IO (Maybe (SMTExpr h tp))
forall a b. (a -> b) -> a -> b
$ WriterConn t h -> Nonce t tp -> IO (Maybe (SMTExpr h tp))
forall t h (tp :: BaseType).
WriterConn t h -> Nonce t tp -> IO (Maybe (SMTExpr h tp))
cacheLookupExpr WriterConn t h
conn (ExprBoundVar t tp -> Nonce t tp
forall t (tp :: BaseType). ExprBoundVar t tp -> Nonce t tp
bvarId ExprBoundVar t tp
var)
     case Maybe (SMTExpr h tp)
mr of
      Just SMTExpr h tp
x -> SMTExpr h tp -> SMTCollector t h (SMTExpr h tp)
forall (m :: Type -> Type) a. Monad m => a -> m a
return SMTExpr h tp
x
      Maybe (SMTExpr h tp)
Nothing -> do
        String -> SMTCollector t h (SMTExpr h tp)
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> SMTCollector t h (SMTExpr h tp))
-> String -> SMTCollector t h (SMTExpr h tp)
forall a b. (a -> b) -> a -> b
$ String
"Internal error in SMTLIB exporter due to unbound variable "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ Nonce t tp -> String
forall a. Show a => a -> String
show (ExprBoundVar t tp -> Nonce t tp
forall t (tp :: BaseType). ExprBoundVar t tp -> Nonce t tp
bvarId ExprBoundVar t tp
var) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" defined at "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ Position -> String
forall a. Show a => a -> String
show (ProgramLoc -> Position
plSourceLoc (ExprBoundVar t tp -> ProgramLoc
forall t (tp :: BaseType). ExprBoundVar t tp -> ProgramLoc
bvarLoc ExprBoundVar t tp
var)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
   VarKind
LatchVarKind ->
     String -> SMTCollector t h (SMTExpr h tp)
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> SMTCollector t h (SMTExpr h tp))
-> String -> SMTCollector t h (SMTExpr h tp)
forall a b. (a -> b) -> a -> b
$ String
"SMTLib exporter does not support the latch defined at "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ Position -> String
forall a. Show a => a -> String
show (ProgramLoc -> Position
plSourceLoc (ExprBoundVar t tp -> ProgramLoc
forall t (tp :: BaseType). ExprBoundVar t tp -> ProgramLoc
bvarLoc ExprBoundVar t tp
var)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
   VarKind
UninterpVarKind -> do
     WriterConn t h
conn <- (SMTCollectorState t h -> WriterConn t h)
-> ReaderT (SMTCollectorState t h) IO (WriterConn t h)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks SMTCollectorState t h -> WriterConn t h
forall t h. SMTCollectorState t h -> WriterConn t h
scConn
     Nonce t tp
-> TermLifetime
-> SMTCollector t h (SMTExpr h tp)
-> SMTCollector t h (SMTExpr h tp)
forall t (tp :: BaseType) h.
Nonce t tp
-> TermLifetime
-> SMTCollector t h (SMTExpr h tp)
-> SMTCollector t h (SMTExpr h tp)
cacheWriterResult (ExprBoundVar t tp -> Nonce t tp
forall t (tp :: BaseType). ExprBoundVar t tp -> Nonce t tp
bvarId ExprBoundVar t tp
var) TermLifetime
DeleteNever (SMTCollector t h (SMTExpr h tp)
 -> SMTCollector t h (SMTExpr h tp))
-> SMTCollector t h (SMTExpr h tp)
-> SMTCollector t h (SMTExpr h tp)
forall a b. (a -> b) -> a -> b
$ do
       ExprBoundVar t tp -> SMTCollector t h ()
forall n (tp :: BaseType) h.
ExprBoundVar n tp -> SMTCollector n h ()
checkVarTypeSupport ExprBoundVar t tp
var
       -- Use predefined var name if it has not been defined.
       Text
var_name <- IO Text -> ReaderT (SMTCollectorState t h) IO Text
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO Text -> ReaderT (SMTCollectorState t h) IO Text)
-> IO Text -> ReaderT (SMTCollectorState t h) IO Text
forall a b. (a -> b) -> a -> b
$ WriterConn t h -> SymbolBinding t -> IO Text
forall t h. WriterConn t h -> SymbolBinding t -> IO Text
getSymbolName WriterConn t h
conn (ExprBoundVar t tp -> SymbolBinding t
forall t (tp :: BaseType). ExprBoundVar t tp -> SymbolBinding t
VarSymbolBinding ExprBoundVar t tp
var)

       TypeMap tp
smt_type <- ExprBoundVar t tp -> SMTCollector t h (TypeMap tp)
forall t (tp :: BaseType) h.
ExprBoundVar t tp -> SMTCollector t h (TypeMap tp)
getBaseSMT_Type ExprBoundVar t tp
var

       IO () -> SMTCollector t h ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> SMTCollector t h ()) -> IO () -> SMTCollector t h ()
forall a b. (a -> b) -> a -> b
$
         do WriterConn t h -> TypeMap tp -> IO ()
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn TypeMap tp
smt_type
            WriterConn t h -> Command h -> IO ()
forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommand WriterConn t h
conn (Command h -> IO ()) -> Command h -> IO ()
forall a b. (a -> b) -> a -> b
$ WriterConn t h
-> Text -> Assignment TypeMap EmptyCtx -> TypeMap tp -> Command h
forall h (f :: Type -> Type) (args :: Ctx BaseType)
       (rtp :: BaseType).
SMTWriter h =>
f h -> Text -> Assignment TypeMap args -> TypeMap rtp -> Command h
declareCommand WriterConn t h
conn Text
var_name Assignment TypeMap EmptyCtx
forall k (f :: k -> Type). Assignment f EmptyCtx
Ctx.empty TypeMap tp
smt_type

       -- Add assertion based on var type.
       WriterConn t h
-> Term h
-> TypeMap tp
-> Maybe (AbstractValue tp)
-> SMTCollector t h ()
forall t h (tp :: BaseType).
SMTWriter h =>
WriterConn t h
-> Term h
-> TypeMap tp
-> Maybe (AbstractValue tp)
-> SMTCollector t h ()
addPartialSideCond WriterConn t h
conn (Text -> Term h
forall v. SupportTermOps v => Text -> v
fromText Text
var_name) TypeMap tp
smt_type (ExprBoundVar t tp -> Maybe (AbstractValue tp)
forall t (tp :: BaseType).
ExprBoundVar t tp -> Maybe (AbstractValue tp)
bvarAbstractValue ExprBoundVar t tp
var)

       -- Return variable name
       SMTExpr h tp -> SMTCollector t h (SMTExpr h tp)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SMTExpr h tp -> SMTCollector t h (SMTExpr h tp))
-> SMTExpr h tp -> SMTCollector t h (SMTExpr h tp)
forall a b. (a -> b) -> a -> b
$ TypeMap tp -> Text -> SMTExpr h tp
forall (tp :: BaseType) h. TypeMap tp -> Text -> SMTExpr h tp
SMTName TypeMap tp
smt_type Text
var_name

-- | Convert an element to a base expression.
mkBaseExpr :: SMTWriter h => Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr :: Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t tp
e = SMTExpr h tp -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase (SMTExpr h tp -> Term h)
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
-> SMTCollector t h (Term h)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr t tp -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t tp
e

-- | Convert structure to list.
mkIndicesTerms :: SMTWriter h
               => Ctx.Assignment (Expr t) ctx
               -> SMTCollector t h [Term h]
mkIndicesTerms :: Assignment (Expr t) ctx -> SMTCollector t h [Term h]
mkIndicesTerms = (forall (x :: BaseType).
 Expr t x -> SMTCollector t h [Term h] -> SMTCollector t h [Term h])
-> SMTCollector t h [Term h]
-> Assignment (Expr t) ctx
-> SMTCollector t h [Term h]
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type) b.
FoldableFC t =>
(forall (x :: k). f x -> b -> b)
-> forall (x :: l). b -> t f x -> b
foldrFC (\Expr t x
e SMTCollector t h [Term h]
r -> (:) (Term h -> [Term h] -> [Term h])
-> ReaderT (SMTCollectorState t h) IO (Term h)
-> ReaderT (SMTCollectorState t h) IO ([Term h] -> [Term h])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr t x -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t x
e ReaderT (SMTCollectorState t h) IO ([Term h] -> [Term h])
-> SMTCollector t h [Term h] -> SMTCollector t h [Term h]
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> SMTCollector t h [Term h]
r) ([Term h] -> SMTCollector t h [Term h]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [])

predSMTExpr :: forall t h tp
             . SMTWriter h
            => NonceAppExpr t tp
            -> SMTCollector t h (SMTExpr h tp)
predSMTExpr :: NonceAppExpr t tp -> SMTCollector t h (SMTExpr h tp)
predSMTExpr NonceAppExpr t tp
e0 = do
  WriterConn t h
conn <- (SMTCollectorState t h -> WriterConn t h)
-> ReaderT (SMTCollectorState t h) IO (WriterConn t h)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks SMTCollectorState t h -> WriterConn t h
forall t h. SMTCollectorState t h -> WriterConn t h
scConn
  let i :: Expr t tp
i = NonceAppExpr t tp -> Expr t tp
forall t (tp :: BaseType). NonceAppExpr t tp -> Expr t tp
NonceAppExpr NonceAppExpr t tp
e0
  WriterConn t h
h <- (SMTCollectorState t h -> WriterConn t h)
-> ReaderT (SMTCollectorState t h) IO (WriterConn t h)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks SMTCollectorState t h -> WriterConn t h
forall t h. SMTCollectorState t h -> WriterConn t h
scConn
  IO () -> ReaderT (SMTCollectorState t h) IO ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT (SMTCollectorState t h) IO ())
-> IO () -> ReaderT (SMTCollectorState t h) IO ()
forall a b. (a -> b) -> a -> b
$ WriterConn t h -> ProgramLoc -> IO ()
forall t h. WriterConn t h -> ProgramLoc -> IO ()
updateProgramLoc WriterConn t h
h (NonceAppExpr t tp -> ProgramLoc
forall t (tp :: BaseType). NonceAppExpr t tp -> ProgramLoc
nonceExprLoc NonceAppExpr t tp
e0)
  case NonceAppExpr t tp -> NonceApp t (Expr t) tp
forall t (tp :: BaseType).
NonceAppExpr t tp -> NonceApp t (Expr t) tp
nonceExprApp NonceAppExpr t tp
e0 of
    Annotation BaseTypeRepr tp
_tpr Nonce t tp
_n Expr t tp
e -> Expr t tp -> SMTCollector t h (SMTExpr h tp)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t tp
e
    Forall ExprBoundVar t tp
var Expr t BaseBoolType
e -> do
      String -> Expr t tp -> ReaderT (SMTCollectorState t h) IO ()
forall t (p :: BaseType) h.
String -> Expr t p -> SMTCollector t h ()
checkQuantifierSupport String
"universal quantifier" Expr t tp
i

      TypeMap tp
smtType <- ExprBoundVar t tp -> SMTCollector t h (TypeMap tp)
forall t (tp :: BaseType) h.
ExprBoundVar t tp -> SMTCollector t h (TypeMap tp)
getBaseSMT_Type ExprBoundVar t tp
var
      IO () -> ReaderT (SMTCollectorState t h) IO ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT (SMTCollectorState t h) IO ())
-> IO () -> ReaderT (SMTCollectorState t h) IO ()
forall a b. (a -> b) -> a -> b
$ WriterConn t h -> TypeMap tp -> IO ()
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
h TypeMap tp
smtType

      CollectorResults h (Term h)
cr <- IO (CollectorResults h (Term h))
-> ReaderT (SMTCollectorState t h) IO (CollectorResults h (Term h))
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (CollectorResults h (Term h))
 -> ReaderT
      (SMTCollectorState t h) IO (CollectorResults h (Term h)))
-> IO (CollectorResults h (Term h))
-> ReaderT (SMTCollectorState t h) IO (CollectorResults h (Term h))
forall a b. (a -> b) -> a -> b
$ WriterConn t h
-> IO (CollectorResults h (Term h))
-> IO (CollectorResults h (Term h))
forall t h a. WriterConn t h -> IO a -> IO a
withConnEntryStack WriterConn t h
conn (IO (CollectorResults h (Term h))
 -> IO (CollectorResults h (Term h)))
-> IO (CollectorResults h (Term h))
-> IO (CollectorResults h (Term h))
forall a b. (a -> b) -> a -> b
$ do
        WriterConn t h
-> SMTCollector t h (Term h) -> IO (CollectorResults h (Term h))
forall h t a.
SupportTermOps (Term h) =>
WriterConn t h -> SMTCollector t h a -> IO (CollectorResults h a)
runInSandbox WriterConn t h
conn (SMTCollector t h (Term h) -> IO (CollectorResults h (Term h)))
-> SMTCollector t h (Term h) -> IO (CollectorResults h (Term h))
forall a b. (a -> b) -> a -> b
$ do
          ExprBoundVar t tp -> ReaderT (SMTCollectorState t h) IO ()
forall n (tp :: BaseType) h.
ExprBoundVar n tp -> SMTCollector n h ()
checkVarTypeSupport ExprBoundVar t tp
var

          Just (FreshVarFn forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp)
f) <- (SMTCollectorState t h -> Maybe (FreshVarFn h))
-> ReaderT (SMTCollectorState t h) IO (Maybe (FreshVarFn h))
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks SMTCollectorState t h -> Maybe (FreshVarFn h)
forall t h. SMTCollectorState t h -> Maybe (FreshVarFn h)
freshConstantFn
          SMTExpr h tp
t <- IO (SMTExpr h tp)
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SMTExpr h tp)
 -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> IO (SMTExpr h tp)
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a b. (a -> b) -> a -> b
$ TypeMap tp -> IO (SMTExpr h tp)
forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp)
f TypeMap tp
smtType
          ExprBoundVar t tp
-> SMTExpr h tp -> ReaderT (SMTCollectorState t h) IO ()
forall t (tp :: BaseType) h.
ExprBoundVar t tp -> SMTExpr h tp -> SMTCollector t h ()
bindVar ExprBoundVar t tp
var SMTExpr h tp
t

          WriterConn t h
-> Term h
-> TypeMap tp
-> Maybe (AbstractValue tp)
-> ReaderT (SMTCollectorState t h) IO ()
forall t h (tp :: BaseType).
SMTWriter h =>
WriterConn t h
-> Term h
-> TypeMap tp
-> Maybe (AbstractValue tp)
-> SMTCollector t h ()
addPartialSideCond WriterConn t h
conn (SMTExpr h tp -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h tp
t) TypeMap tp
smtType (ExprBoundVar t tp -> Maybe (AbstractValue tp)
forall t (tp :: BaseType).
ExprBoundVar t tp -> Maybe (AbstractValue tp)
bvarAbstractValue ExprBoundVar t tp
var)
          Expr t BaseBoolType -> SMTCollector t h (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseBoolType
e
      TypeMap BaseBoolType
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseBoolType))
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall a b. (a -> b) -> a -> b
$ CollectorResults h (Term h) -> Term h
forall h. SMTWriter h => CollectorResults h (Term h) -> Term h
forallResult CollectorResults h (Term h)
cr
    Exists ExprBoundVar t tp
var Expr t BaseBoolType
e -> do
      String -> Expr t tp -> ReaderT (SMTCollectorState t h) IO ()
forall t (p :: BaseType) h.
String -> Expr t p -> SMTCollector t h ()
checkQuantifierSupport String
"existential quantifiers" Expr t tp
i

      TypeMap tp
smtType <- ExprBoundVar t tp -> SMTCollector t h (TypeMap tp)
forall t (tp :: BaseType) h.
ExprBoundVar t tp -> SMTCollector t h (TypeMap tp)
getBaseSMT_Type ExprBoundVar t tp
var
      IO () -> ReaderT (SMTCollectorState t h) IO ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT (SMTCollectorState t h) IO ())
-> IO () -> ReaderT (SMTCollectorState t h) IO ()
forall a b. (a -> b) -> a -> b
$ WriterConn t h -> TypeMap tp -> IO ()
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
h TypeMap tp
smtType

      CollectorResults h (Term h)
cr <- IO (CollectorResults h (Term h))
-> ReaderT (SMTCollectorState t h) IO (CollectorResults h (Term h))
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (CollectorResults h (Term h))
 -> ReaderT
      (SMTCollectorState t h) IO (CollectorResults h (Term h)))
-> IO (CollectorResults h (Term h))
-> ReaderT (SMTCollectorState t h) IO (CollectorResults h (Term h))
forall a b. (a -> b) -> a -> b
$ WriterConn t h
-> IO (CollectorResults h (Term h))
-> IO (CollectorResults h (Term h))
forall t h a. WriterConn t h -> IO a -> IO a
withConnEntryStack WriterConn t h
conn (IO (CollectorResults h (Term h))
 -> IO (CollectorResults h (Term h)))
-> IO (CollectorResults h (Term h))
-> IO (CollectorResults h (Term h))
forall a b. (a -> b) -> a -> b
$ do
        WriterConn t h
-> SMTCollector t h (Term h) -> IO (CollectorResults h (Term h))
forall h t a.
SupportTermOps (Term h) =>
WriterConn t h -> SMTCollector t h a -> IO (CollectorResults h a)
runInSandbox WriterConn t h
conn (SMTCollector t h (Term h) -> IO (CollectorResults h (Term h)))
-> SMTCollector t h (Term h) -> IO (CollectorResults h (Term h))
forall a b. (a -> b) -> a -> b
$ do
          ExprBoundVar t tp -> ReaderT (SMTCollectorState t h) IO ()
forall n (tp :: BaseType) h.
ExprBoundVar n tp -> SMTCollector n h ()
checkVarTypeSupport ExprBoundVar t tp
var

          Just (FreshVarFn forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp)
f) <- (SMTCollectorState t h -> Maybe (FreshVarFn h))
-> ReaderT (SMTCollectorState t h) IO (Maybe (FreshVarFn h))
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks SMTCollectorState t h -> Maybe (FreshVarFn h)
forall t h. SMTCollectorState t h -> Maybe (FreshVarFn h)
freshConstantFn
          SMTExpr h tp
t <- IO (SMTExpr h tp)
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SMTExpr h tp)
 -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> IO (SMTExpr h tp)
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a b. (a -> b) -> a -> b
$ TypeMap tp -> IO (SMTExpr h tp)
forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp)
f TypeMap tp
smtType
          ExprBoundVar t tp
-> SMTExpr h tp -> ReaderT (SMTCollectorState t h) IO ()
forall t (tp :: BaseType) h.
ExprBoundVar t tp -> SMTExpr h tp -> SMTCollector t h ()
bindVar ExprBoundVar t tp
var SMTExpr h tp
t

          WriterConn t h
-> Term h
-> TypeMap tp
-> Maybe (AbstractValue tp)
-> ReaderT (SMTCollectorState t h) IO ()
forall t h (tp :: BaseType).
SMTWriter h =>
WriterConn t h
-> Term h
-> TypeMap tp
-> Maybe (AbstractValue tp)
-> SMTCollector t h ()
addPartialSideCond WriterConn t h
conn (SMTExpr h tp -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h tp
t) TypeMap tp
smtType (ExprBoundVar t tp -> Maybe (AbstractValue tp)
forall t (tp :: BaseType).
ExprBoundVar t tp -> Maybe (AbstractValue tp)
bvarAbstractValue ExprBoundVar t tp
var)
          Expr t BaseBoolType -> SMTCollector t h (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseBoolType
e
      TypeMap BaseBoolType
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseBoolType))
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall a b. (a -> b) -> a -> b
$ CollectorResults h (Term h) -> Term h
forall h. SMTWriter h => CollectorResults h (Term h) -> Term h
existsResult CollectorResults h (Term h)
cr

    ArrayFromFn ExprSymFn t (idx ::> itp) ret
f -> do
      -- Evaluate arg types
      Assignment TypeMap (idx ::> itp)
smt_arg_types <-
        (forall (x :: BaseType).
 BaseTypeRepr x -> ReaderT (SMTCollectorState t h) IO (TypeMap x))
-> Assignment BaseTypeRepr (idx ::> itp)
-> ReaderT
     (SMTCollectorState t h) IO (Assignment TypeMap (idx ::> itp))
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type) (m :: Type -> Type).
(TraversableFC t, Applicative m) =>
(forall (x :: k). f x -> m (g x))
-> forall (x :: l). t f x -> m (t g x)
traverseFC (WriterConn t h
-> SMTSource Any
-> BaseTypeRepr x
-> ReaderT (SMTCollectorState t h) IO (TypeMap x)
forall (m :: Type -> Type) t h ann (tp :: BaseType).
MonadFail m =>
WriterConn t h
-> SMTSource ann -> BaseTypeRepr tp -> m (TypeMap tp)
evalFirstClassTypeRepr WriterConn t h
conn (Expr t tp -> SMTSource Any
forall t (tp :: BaseType) ann. Expr t tp -> SMTSource ann
eltSource Expr t tp
i))
                   (ExprSymFn t (idx ::> itp) ret
-> Assignment BaseTypeRepr (idx ::> itp)
forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> Assignment BaseTypeRepr args
symFnArgTypes ExprSymFn t (idx ::> itp) ret
f)
      -- Evaluate simple function
      (Text
smt_f, TypeMap ret
ret_tp) <- IO (Text, TypeMap ret)
-> ReaderT (SMTCollectorState t h) IO (Text, TypeMap ret)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Text, TypeMap ret)
 -> ReaderT (SMTCollectorState t h) IO (Text, TypeMap ret))
-> IO (Text, TypeMap ret)
-> ReaderT (SMTCollectorState t h) IO (Text, TypeMap ret)
forall a b. (a -> b) -> a -> b
$ WriterConn t h
-> ExprSymFn t (idx ::> itp) ret
-> Assignment TypeMap (idx ::> itp)
-> IO (Text, TypeMap ret)
forall h t (args :: Ctx BaseType) (ret :: BaseType).
SMTWriter h =>
WriterConn t h
-> ExprSymFn t args ret
-> Assignment TypeMap args
-> IO (Text, TypeMap ret)
getSMTSymFn WriterConn t h
conn ExprSymFn t (idx ::> itp) ret
f Assignment TypeMap (idx ::> itp)
smt_arg_types

      let array_tp :: TypeMap (BaseArrayType (idx ::> itp) ret)
array_tp = Assignment TypeMap (idx ::> itp)
-> TypeMap ret -> TypeMap (BaseArrayType (idx ::> itp) ret)
forall (idxl :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
Assignment TypeMap (idxl ::> idx)
-> TypeMap tp -> TypeMap (BaseArrayType (idxl ::> idx) tp)
FnArrayTypeMap Assignment TypeMap (idx ::> itp)
smt_arg_types TypeMap ret
ret_tp
      SMTExpr h (BaseArrayType (idx ::> itp) ret)
-> ReaderT
     (SMTCollectorState t h)
     IO
     (SMTExpr h (BaseArrayType (idx ::> itp) ret))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SMTExpr h (BaseArrayType (idx ::> itp) ret)
 -> ReaderT
      (SMTCollectorState t h)
      IO
      (SMTExpr h (BaseArrayType (idx ::> itp) ret)))
-> SMTExpr h (BaseArrayType (idx ::> itp) ret)
-> ReaderT
     (SMTCollectorState t h)
     IO
     (SMTExpr h (BaseArrayType (idx ::> itp) ret))
forall a b. (a -> b) -> a -> b
$! TypeMap (BaseArrayType (idx ::> itp) ret)
-> Text -> SMTExpr h (BaseArrayType (idx ::> itp) ret)
forall (tp :: BaseType) h. TypeMap tp -> Text -> SMTExpr h tp
SMTName TypeMap (BaseArrayType (idx ::> itp) ret)
array_tp Text
smt_f

    MapOverArrays ExprSymFn t (ctx ::> d) r
f Assignment BaseTypeRepr (idx ::> itp)
idx_types Assignment (ArrayResultWrapper (Expr t) (idx ::> itp)) (ctx ::> d)
arrays -> do
      -- :: Ctx.Assignment (ArrayResultWrapper (Expr t) (idx Ctx.::> itp)) ctx)  -> do
      -- Evaluate arg types for indices.

      Assignment TypeMap (idx ::> itp)
smt_idx_types <- (forall (x :: BaseType).
 BaseTypeRepr x -> ReaderT (SMTCollectorState t h) IO (TypeMap x))
-> Assignment BaseTypeRepr (idx ::> itp)
-> ReaderT
     (SMTCollectorState t h) IO (Assignment TypeMap (idx ::> itp))
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type) (m :: Type -> Type).
(TraversableFC t, Applicative m) =>
(forall (x :: k). f x -> m (g x))
-> forall (x :: l). t f x -> m (t g x)
traverseFC (WriterConn t h
-> SMTSource Any
-> BaseTypeRepr x
-> ReaderT (SMTCollectorState t h) IO (TypeMap x)
forall (m :: Type -> Type) t h ann (tp :: BaseType).
MonadFail m =>
WriterConn t h
-> SMTSource ann -> BaseTypeRepr tp -> m (TypeMap tp)
evalFirstClassTypeRepr WriterConn t h
conn (Expr t tp -> SMTSource Any
forall t (tp :: BaseType) ann. Expr t tp -> SMTSource ann
eltSource Expr t tp
i)) Assignment BaseTypeRepr (idx ::> itp)
idx_types

      let evalArray :: forall idx itp etp
                     . ArrayResultWrapper (Expr t) (idx Ctx.::> itp) etp
                     -> SMTCollector t h (ArrayResultWrapper (SMTExpr h) (idx Ctx.::> itp) etp)
          evalArray :: ArrayResultWrapper (Expr t) (idx ::> itp) etp
-> SMTCollector
     t h (ArrayResultWrapper (SMTExpr h) (idx ::> itp) etp)
evalArray (ArrayResultWrapper Expr t (BaseArrayType (idx ::> itp) etp)
a) = SMTExpr h (BaseArrayType (idx ::> itp) etp)
-> ArrayResultWrapper (SMTExpr h) (idx ::> itp) etp
forall (f :: BaseType -> Type) (idx :: Ctx BaseType)
       (tp :: BaseType).
f (BaseArrayType idx tp) -> ArrayResultWrapper f idx tp
ArrayResultWrapper (SMTExpr h (BaseArrayType (idx ::> itp) etp)
 -> ArrayResultWrapper (SMTExpr h) (idx ::> itp) etp)
-> ReaderT
     (SMTCollectorState t h)
     IO
     (SMTExpr h (BaseArrayType (idx ::> itp) etp))
-> SMTCollector
     t h (ArrayResultWrapper (SMTExpr h) (idx ::> itp) etp)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr t (BaseArrayType (idx ::> itp) etp)
-> ReaderT
     (SMTCollectorState t h)
     IO
     (SMTExpr h (BaseArrayType (idx ::> itp) etp))
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t (BaseArrayType (idx ::> itp) etp)
a

      Assignment
  (ArrayResultWrapper (SMTExpr h) (idx ::> itp)) (ctx ::> d)
smt_arrays <- (forall (x :: BaseType).
 ArrayResultWrapper (Expr t) (idx ::> itp) x
 -> ReaderT
      (SMTCollectorState t h)
      IO
      (ArrayResultWrapper (SMTExpr h) (idx ::> itp) x))
-> Assignment
     (ArrayResultWrapper (Expr t) (idx ::> itp)) (ctx ::> d)
-> ReaderT
     (SMTCollectorState t h)
     IO
     (Assignment
        (ArrayResultWrapper (SMTExpr h) (idx ::> itp)) (ctx ::> d))
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type) (m :: Type -> Type).
(TraversableFC t, Applicative m) =>
(forall (x :: k). f x -> m (g x))
-> forall (x :: l). t f x -> m (t g x)
traverseFC forall (idx :: Ctx BaseType) (itp :: BaseType) (etp :: BaseType).
ArrayResultWrapper (Expr t) (idx ::> itp) etp
-> SMTCollector
     t h (ArrayResultWrapper (SMTExpr h) (idx ::> itp) etp)
forall (x :: BaseType).
ArrayResultWrapper (Expr t) (idx ::> itp) x
-> ReaderT
     (SMTCollectorState t h)
     IO
     (ArrayResultWrapper (SMTExpr h) (idx ::> itp) x)
evalArray Assignment (ArrayResultWrapper (Expr t) (idx ::> itp)) (ctx ::> d)
arrays

      IO (SMTExpr h (BaseArrayType (idx ::> itp) r))
-> ReaderT
     (SMTCollectorState t h)
     IO
     (SMTExpr h (BaseArrayType (idx ::> itp) r))
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SMTExpr h (BaseArrayType (idx ::> itp) r))
 -> ReaderT
      (SMTCollectorState t h)
      IO
      (SMTExpr h (BaseArrayType (idx ::> itp) r)))
-> IO (SMTExpr h (BaseArrayType (idx ::> itp) r))
-> ReaderT
     (SMTCollectorState t h)
     IO
     (SMTExpr h (BaseArrayType (idx ::> itp) r))
forall a b. (a -> b) -> a -> b
$ do

      -- Create name of function to reutrn.
      Text
nm <- IO Text -> IO Text
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO Text -> IO Text) -> IO Text -> IO Text
forall a b. (a -> b) -> a -> b
$ WriterConn t h -> State WriterState Text -> IO Text
forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn (State WriterState Text -> IO Text)
-> State WriterState Text -> IO Text
forall a b. (a -> b) -> a -> b
$ State WriterState Text
freshVarName

      TypeMap r
ret_type <-
        WriterConn t h
-> Text
-> (FreshVarFn h -> SMTCollector t h (SMTExpr h r))
-> IO (TypeMap r)
forall h t (ret :: BaseType).
SMTWriter h =>
WriterConn t h
-> Text
-> (FreshVarFn h -> SMTCollector t h (SMTExpr h ret))
-> IO (TypeMap ret)
defineSMTFunction WriterConn t h
conn Text
nm ((FreshVarFn h -> SMTCollector t h (SMTExpr h r))
 -> IO (TypeMap r))
-> (FreshVarFn h -> SMTCollector t h (SMTExpr h r))
-> IO (TypeMap r)
forall a b. (a -> b) -> a -> b
$ \(FreshVarFn forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp)
freshVar) -> do
          -- Create type for indices.
          Assignment (SMTExpr h) (idx ::> itp)
smt_indices <- (forall (x :: BaseType).
 TypeMap x -> ReaderT (SMTCollectorState t h) IO (SMTExpr h x))
-> Assignment TypeMap (idx ::> itp)
-> ReaderT
     (SMTCollectorState t h) IO (Assignment (SMTExpr h) (idx ::> itp))
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type) (m :: Type -> Type).
(TraversableFC t, Applicative m) =>
(forall (x :: k). f x -> m (g x))
-> forall (x :: l). t f x -> m (t g x)
traverseFC (\TypeMap x
tp -> IO (SMTExpr h x)
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h x)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (TypeMap x -> IO (SMTExpr h x)
forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp)
freshVar TypeMap x
tp)) Assignment TypeMap (idx ::> itp)
smt_idx_types

          let idxl :: [Term h]
idxl = (forall (x :: BaseType). SMTExpr h x -> Term h)
-> Assignment (SMTExpr h) (idx ::> itp) -> [Term h]
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type) a.
FoldableFC t =>
(forall (x :: k). f x -> a) -> forall (x :: l). t f x -> [a]
toListFC forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
forall (x :: BaseType). SMTExpr h x -> Term h
asBase Assignment (SMTExpr h) (idx ::> itp)
smt_indices
          let select :: forall  idxl idx etp
                     .  ArrayResultWrapper (SMTExpr h) (idxl Ctx.::> idx) etp
                     -> SMTExpr h etp
              select :: ArrayResultWrapper (SMTExpr h) (idxl ::> idx) etp -> SMTExpr h etp
select (ArrayResultWrapper SMTExpr h (BaseArrayType (idxl ::> idx) etp)
a) = SMTExpr h (BaseArrayType (idxl ::> idx) etp)
-> [Term h] -> SMTExpr h etp
forall h (idxl :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
SMTWriter h =>
SMTExpr h (BaseArrayType (idxl ::> idx) tp)
-> [Term h] -> SMTExpr h tp
smt_array_select SMTExpr h (BaseArrayType (idxl ::> idx) etp)
a [Term h]
idxl
          let array_vals :: Assignment (SMTExpr h) (ctx ::> d)
array_vals = (forall (x :: BaseType).
 ArrayResultWrapper (SMTExpr h) (idx ::> itp) x -> SMTExpr h x)
-> Assignment
     (ArrayResultWrapper (SMTExpr h) (idx ::> itp)) (ctx ::> d)
-> Assignment (SMTExpr h) (ctx ::> d)
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type).
FunctorFC t =>
(forall (x :: k). f x -> g x) -> forall (x :: l). t f x -> t g x
fmapFC forall (idxl :: Ctx BaseType) (idx :: BaseType) (etp :: BaseType).
ArrayResultWrapper (SMTExpr h) (idxl ::> idx) etp -> SMTExpr h etp
forall (x :: BaseType).
ArrayResultWrapper (SMTExpr h) (idx ::> itp) x -> SMTExpr h x
select Assignment
  (ArrayResultWrapper (SMTExpr h) (idx ::> itp)) (ctx ::> d)
smt_arrays

          (Text
smt_f, TypeMap r
ret_type) <- IO (Text, TypeMap r)
-> ReaderT (SMTCollectorState t h) IO (Text, TypeMap r)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Text, TypeMap r)
 -> ReaderT (SMTCollectorState t h) IO (Text, TypeMap r))
-> IO (Text, TypeMap r)
-> ReaderT (SMTCollectorState t h) IO (Text, TypeMap r)
forall a b. (a -> b) -> a -> b
$ WriterConn t h
-> ExprSymFn t (ctx ::> d) r
-> Assignment TypeMap (ctx ::> d)
-> IO (Text, TypeMap r)
forall h t (args :: Ctx BaseType) (ret :: BaseType).
SMTWriter h =>
WriterConn t h
-> ExprSymFn t args ret
-> Assignment TypeMap args
-> IO (Text, TypeMap ret)
getSMTSymFn WriterConn t h
conn ExprSymFn t (ctx ::> d) r
f ((forall (x :: BaseType). SMTExpr h x -> TypeMap x)
-> Assignment (SMTExpr h) (ctx ::> d)
-> Assignment TypeMap (ctx ::> d)
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type).
FunctorFC t =>
(forall (x :: k). f x -> g x) -> forall (x :: l). t f x -> t g x
fmapFC forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
forall (x :: BaseType). SMTExpr h x -> TypeMap x
smtExprType Assignment (SMTExpr h) (ctx ::> d)
array_vals)

          SMTExpr h r -> SMTCollector t h (SMTExpr h r)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SMTExpr h r -> SMTCollector t h (SMTExpr h r))
-> SMTExpr h r -> SMTCollector t h (SMTExpr h r)
forall a b. (a -> b) -> a -> b
$ TypeMap r -> Term h -> SMTExpr h r
forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap r
ret_type (Term h -> SMTExpr h r) -> Term h -> SMTExpr h r
forall a b. (a -> b) -> a -> b
$ Term h -> [Term h] -> Term h
forall v. SupportTermOps v => v -> [v] -> v
smtFnApp (Text -> Term h
forall v. SupportTermOps v => Text -> v
fromText Text
smt_f) ((forall (x :: BaseType). SMTExpr h x -> Term h)
-> Assignment (SMTExpr h) (ctx ::> d) -> [Term h]
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type) a.
FoldableFC t =>
(forall (x :: k). f x -> a) -> forall (x :: l). t f x -> [a]
toListFC forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
forall (x :: BaseType). SMTExpr h x -> Term h
asBase Assignment (SMTExpr h) (ctx ::> d)
array_vals)


      let array_tp :: TypeMap (BaseArrayType (idx ::> itp) r)
array_tp = Assignment TypeMap (idx ::> itp)
-> TypeMap r -> TypeMap (BaseArrayType (idx ::> itp) r)
forall (idxl :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
Assignment TypeMap (idxl ::> idx)
-> TypeMap tp -> TypeMap (BaseArrayType (idxl ::> idx) tp)
FnArrayTypeMap Assignment TypeMap (idx ::> itp)
smt_idx_types TypeMap r
ret_type
      SMTExpr h (BaseArrayType (idx ::> itp) r)
-> IO (SMTExpr h (BaseArrayType (idx ::> itp) r))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SMTExpr h (BaseArrayType (idx ::> itp) r)
 -> IO (SMTExpr h (BaseArrayType (idx ::> itp) r)))
-> SMTExpr h (BaseArrayType (idx ::> itp) r)
-> IO (SMTExpr h (BaseArrayType (idx ::> itp) r))
forall a b. (a -> b) -> a -> b
$! TypeMap (BaseArrayType (idx ::> itp) r)
-> Text -> SMTExpr h (BaseArrayType (idx ::> itp) r)
forall (tp :: BaseType) h. TypeMap tp -> Text -> SMTExpr h tp
SMTName TypeMap (BaseArrayType (idx ::> itp) r)
array_tp Text
nm

    ArrayTrueOnEntries{} -> do
      String -> SMTCollector t h (SMTExpr h tp)
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> SMTCollector t h (SMTExpr h tp))
-> String -> SMTCollector t h (SMTExpr h tp)
forall a b. (a -> b) -> a -> b
$ String
"SMTWriter does not yet support ArrayTrueOnEntries.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr t tp -> String
forall a. Show a => a -> String
show Expr t tp
i

    FnApp ExprSymFn t args tp
f Assignment (Expr t) args
args -> do
      Assignment (SMTExpr h) args
smt_args <- (forall (x :: BaseType).
 Expr t x -> ReaderT (SMTCollectorState t h) IO (SMTExpr h x))
-> Assignment (Expr t) args
-> ReaderT (SMTCollectorState t h) IO (Assignment (SMTExpr h) args)
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type) (m :: Type -> Type).
(TraversableFC t, Applicative m) =>
(forall (x :: k). f x -> m (g x))
-> forall (x :: l). t f x -> m (t g x)
traverseFC forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
forall (x :: BaseType).
Expr t x -> ReaderT (SMTCollectorState t h) IO (SMTExpr h x)
mkExpr Assignment (Expr t) args
args
      (Text
smt_f, TypeMap tp
ret_type) <- IO (Text, TypeMap tp)
-> ReaderT (SMTCollectorState t h) IO (Text, TypeMap tp)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Text, TypeMap tp)
 -> ReaderT (SMTCollectorState t h) IO (Text, TypeMap tp))
-> IO (Text, TypeMap tp)
-> ReaderT (SMTCollectorState t h) IO (Text, TypeMap tp)
forall a b. (a -> b) -> a -> b
$ WriterConn t h
-> ExprSymFn t args tp
-> Assignment TypeMap args
-> IO (Text, TypeMap tp)
forall h t (args :: Ctx BaseType) (ret :: BaseType).
SMTWriter h =>
WriterConn t h
-> ExprSymFn t args ret
-> Assignment TypeMap args
-> IO (Text, TypeMap ret)
getSMTSymFn WriterConn t h
conn ExprSymFn t args tp
f ((forall (x :: BaseType). SMTExpr h x -> TypeMap x)
-> Assignment (SMTExpr h) args -> Assignment TypeMap args
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type).
FunctorFC t =>
(forall (x :: k). f x -> g x) -> forall (x :: l). t f x -> t g x
fmapFC forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
forall (x :: BaseType). SMTExpr h x -> TypeMap x
smtExprType Assignment (SMTExpr h) args
smt_args)
      TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap tp
ret_type (Term h -> SMTCollector t h (SMTExpr h tp))
-> Term h -> SMTCollector t h (SMTExpr h tp)
forall a b. (a -> b) -> a -> b
$! Term h -> [Term h] -> Term h
forall v. SupportTermOps v => v -> [v] -> v
smtFnApp (Text -> Term h
forall v. SupportTermOps v => Text -> v
fromText Text
smt_f) ((forall (x :: BaseType). SMTExpr h x -> Term h)
-> Assignment (SMTExpr h) args -> [Term h]
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type) a.
FoldableFC t =>
(forall (x :: k). f x -> a) -> forall (x :: l). t f x -> [a]
toListFC forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
forall (x :: BaseType). SMTExpr h x -> Term h
asBase Assignment (SMTExpr h) args
smt_args)


appSMTExpr :: forall t h tp
            . SMTWriter h
           => AppExpr t tp
           -> SMTCollector t h (SMTExpr h tp)
appSMTExpr :: AppExpr t tp -> SMTCollector t h (SMTExpr h tp)
appSMTExpr AppExpr t tp
ae = do
  WriterConn t h
conn <- (SMTCollectorState t h -> WriterConn t h)
-> ReaderT (SMTCollectorState t h) IO (WriterConn t h)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks SMTCollectorState t h -> WriterConn t h
forall t h. SMTCollectorState t h -> WriterConn t h
scConn
  let i :: Expr t tp
i = AppExpr t tp -> Expr t tp
forall t (tp :: BaseType). AppExpr t tp -> Expr t tp
AppExpr AppExpr t tp
ae
  IO () -> ReaderT (SMTCollectorState t h) IO ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT (SMTCollectorState t h) IO ())
-> IO () -> ReaderT (SMTCollectorState t h) IO ()
forall a b. (a -> b) -> a -> b
$ WriterConn t h -> ProgramLoc -> IO ()
forall t h. WriterConn t h -> ProgramLoc -> IO ()
updateProgramLoc WriterConn t h
conn (AppExpr t tp -> ProgramLoc
forall t (tp :: BaseType). AppExpr t tp -> ProgramLoc
appExprLoc AppExpr t tp
ae)
  case AppExpr t tp -> App (Expr t) tp
forall t (tp :: BaseType). AppExpr t tp -> App (Expr t) tp
appExprApp AppExpr t tp
ae of

    BaseEq BaseTypeRepr tp
_ Expr t tp
x Expr t tp
y ->
      do SMTExpr h tp
xe <- Expr t tp -> SMTCollector t h (SMTExpr h tp)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t tp
x
         SMTExpr h tp
ye <- Expr t tp -> SMTCollector t h (SMTExpr h tp)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t tp
y

         let xtp :: TypeMap tp
xtp = SMTExpr h tp -> TypeMap tp
forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h tp
xe
         let ytp :: TypeMap tp
ytp = SMTExpr h tp -> TypeMap tp
forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h tp
ye

         let checkArrayType :: Expr t tp -> TypeMap tp -> ReaderT (SMTCollectorState t h) IO ()
checkArrayType Expr t tp
z (FnArrayTypeMap{}) = do
               String -> ReaderT (SMTCollectorState t h) IO ()
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> ReaderT (SMTCollectorState t h) IO ())
-> String -> ReaderT (SMTCollectorState t h) IO ()
forall a b. (a -> b) -> a -> b
$ Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String) -> Doc Any -> String
forall a b. (a -> b) -> a -> b
$
                 [Doc Any] -> Doc Any
forall ann. [Doc ann] -> Doc ann
vcat
                 [ String -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty (WriterConn t h -> String
forall t h. WriterConn t h -> String
smtWriterName WriterConn t h
conn) Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
                   Doc Any
"does not support checking equality for the array generated at"
                   Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Position -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty (ProgramLoc -> Position
plSourceLoc (Expr t ('BaseArrayType (idxl ::> idx) tp) -> ProgramLoc
forall t (tp :: BaseType). Expr t tp -> ProgramLoc
exprLoc Expr t tp
Expr t ('BaseArrayType (idxl ::> idx) tp)
z)) Doc Any -> Doc Any -> Doc Any
forall a. Semigroup a => a -> a -> a
<> Doc Any
":"
                 , Int -> Doc Any -> Doc Any
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Expr t ('BaseArrayType (idxl ::> idx) tp) -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty Expr t tp
Expr t ('BaseArrayType (idxl ::> idx) tp)
z)
                 ]
             checkArrayType Expr t tp
_ TypeMap tp
_ = () -> ReaderT (SMTCollectorState t h) IO ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

         Expr t tp -> TypeMap tp -> ReaderT (SMTCollectorState t h) IO ()
checkArrayType Expr t tp
x TypeMap tp
xtp
         Expr t tp -> TypeMap tp -> ReaderT (SMTCollectorState t h) IO ()
checkArrayType Expr t tp
y TypeMap tp
ytp

         Bool
-> ReaderT (SMTCollectorState t h) IO ()
-> ReaderT (SMTCollectorState t h) IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (TypeMap tp
xtp TypeMap tp -> TypeMap tp -> Bool
forall a. Eq a => a -> a -> Bool
/= TypeMap tp
ytp) (ReaderT (SMTCollectorState t h) IO ()
 -> ReaderT (SMTCollectorState t h) IO ())
-> ReaderT (SMTCollectorState t h) IO ()
-> ReaderT (SMTCollectorState t h) IO ()
forall a b. (a -> b) -> a -> b
$ do
           String -> ReaderT (SMTCollectorState t h) IO ()
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> ReaderT (SMTCollectorState t h) IO ())
-> String -> ReaderT (SMTCollectorState t h) IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"Type representations are not equal:", TypeMap tp -> String
forall a. Show a => a -> String
show TypeMap tp
xtp, TypeMap tp -> String
forall a. Show a => a -> String
show TypeMap tp
ytp]

         TypeMap BaseBoolType
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseBoolType))
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall a b. (a -> b) -> a -> b
$ SMTExpr h tp -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h tp
xe Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.== SMTExpr h tp -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h tp
ye

    BaseIte BaseTypeRepr tp
btp Integer
_ Expr t BaseBoolType
c Expr t tp
x Expr t tp
y -> do
      let errMsg :: String -> String
errMsg String
typename =
           Doc Any -> String
forall a. Show a => a -> String
show
             (Doc Any -> String) -> Doc Any -> String
forall a b. (a -> b) -> a -> b
$   Doc Any
"we do not support if/then/else expressions at type"
             Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty String
typename
             Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Any
"with solver"
             Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty (WriterConn t h -> String
forall t h. WriterConn t h -> String
smtWriterName WriterConn t h
conn) Doc Any -> Doc Any -> Doc Any
forall a. Semigroup a => a -> a -> a
<> Doc Any
"."
      case WriterConn t h
-> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
forall t h (tp :: BaseType).
WriterConn t h
-> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
typeMap WriterConn t h
conn BaseTypeRepr tp
btp of
        Left  (StringTypeUnsupported (Some StringInfoRepr x
si)) -> String -> SMTCollector t h (SMTExpr h tp)
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> SMTCollector t h (SMTExpr h tp))
-> String -> SMTCollector t h (SMTExpr h tp)
forall a b. (a -> b) -> a -> b
$ String -> String
errMsg (String
"string " String -> String -> String
forall a. [a] -> [a] -> [a]
++ StringInfoRepr x -> String
forall a. Show a => a -> String
show StringInfoRepr x
si)
        Left  BaseTypeError
ComplexTypeUnsupported -> String -> SMTCollector t h (SMTExpr h tp)
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> SMTCollector t h (SMTExpr h tp))
-> String -> SMTCollector t h (SMTExpr h tp)
forall a b. (a -> b) -> a -> b
$ String -> String
errMsg String
"complex"
        Left  BaseTypeError
ArrayUnsupported       -> String -> SMTCollector t h (SMTExpr h tp)
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> SMTCollector t h (SMTExpr h tp))
-> String -> SMTCollector t h (SMTExpr h tp)
forall a b. (a -> b) -> a -> b
$ String -> String
errMsg String
"array"
        Right FnArrayTypeMap{}       -> String -> SMTCollector t h (SMTExpr h tp)
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> SMTCollector t h (SMTExpr h tp))
-> String -> SMTCollector t h (SMTExpr h tp)
forall a b. (a -> b) -> a -> b
$ String -> String
errMsg String
"function-backed array"
        Right TypeMap tp
tym ->
          do Term h
cb <- Expr t BaseBoolType -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseBoolType
c
             Term h
xb <- Expr t tp -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t tp
x
             Term h
yb <- Expr t tp -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t tp
y
             TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap tp
tym (Term h -> SMTCollector t h (SMTExpr h tp))
-> Term h -> SMTCollector t h (SMTExpr h tp)
forall a b. (a -> b) -> a -> b
$ Term h -> Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v -> v
ite Term h
cb Term h
xb Term h
yb

    SemiRingLe OrderedSemiRingRepr sr
_sr Expr t (SemiRingBase sr)
x Expr t (SemiRingBase sr)
y -> do
      Term h
xb <- Expr t (SemiRingBase sr)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (SemiRingBase sr)
x
      Term h
yb <- Expr t (SemiRingBase sr)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (SemiRingBase sr)
y
      TypeMap BaseBoolType
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseBoolType))
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall a b. (a -> b) -> a -> b
$ Term h
xb Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.<= Term h
yb

    RealIsInteger Expr t BaseRealType
r -> do
      Term h
rb <- Expr t BaseRealType -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseRealType
r
      TypeMap BaseBoolType
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseBoolType))
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall a b. (a -> b) -> a -> b
$! Term h -> Term h
forall v. SupportTermOps v => v -> v
realIsInteger Term h
rb

    BVTestBit Natural
n Expr t (BaseBVType w)
xe -> do
      Term h
x <- Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
xe
      let this_bit :: Term h
this_bit = NatRepr w -> Natural -> Natural -> Term h -> Term h
forall v (w :: Nat).
SupportTermOps v =>
NatRepr w -> Natural -> Natural -> v -> v
bvExtract (Expr t (BaseBVType w) -> NatRepr w
forall (e :: BaseType -> Type) (w :: Nat).
IsExpr e =>
e (BaseBVType w) -> NatRepr w
bvWidth Expr t (BaseBVType w)
xe) Natural
n Natural
1 Term h
x
          one :: Term h
one = NatRepr 1 -> BV 1 -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm (NatRepr 1
forall (n :: Nat). KnownNat n => NatRepr n
knownNat :: NatRepr 1) (NatRepr 1 -> BV 1
forall (w :: Nat). (1 <= w) => NatRepr w -> BV w
BV.one NatRepr 1
forall (n :: Nat). KnownNat n => NatRepr n
knownNat)
      TypeMap BaseBoolType
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseBoolType))
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall a b. (a -> b) -> a -> b
$ Term h
this_bit Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.== Term h
one
    BVSlt Expr t (BaseBVType w)
xe Expr t (BaseBVType w)
ye -> do
      Term h
x <- Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
xe
      Term h
y <- Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
ye
      TypeMap BaseBoolType
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseBoolType))
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall a b. (a -> b) -> a -> b
$ Term h
x Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
`bvSLt` Term h
y
    BVUlt Expr t (BaseBVType w)
xe Expr t (BaseBVType w)
ye -> do
      Term h
x <- Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
xe
      Term h
y <- Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
ye
      TypeMap BaseBoolType
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseBoolType))
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall a b. (a -> b) -> a -> b
$ Term h
x Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
`bvULt` Term h
y

    IntDiv Expr t BaseIntegerType
xe Expr t BaseIntegerType
ye -> do
      case Expr t BaseIntegerType
ye of
        SemiRingLiteral SemiRingRepr sr
_ Coefficient sr
_ ProgramLoc
_ -> () -> ReaderT (SMTCollectorState t h) IO ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
        Expr t BaseIntegerType
_ -> Expr t tp -> ReaderT (SMTCollectorState t h) IO ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkNonlinearSupport Expr t tp
i

      Term h
x <- Expr t BaseIntegerType
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseIntegerType
xe
      Term h
y <- Expr t BaseIntegerType
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseIntegerType
ye

      TypeMap BaseIntegerType
-> Term h -> SMTCollector t h (SMTExpr h BaseIntegerType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseIntegerType
IntegerTypeMap (Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
intDiv Term h
x Term h
y)

    IntMod Expr t BaseIntegerType
xe Expr t BaseIntegerType
ye -> do
      case Expr t BaseIntegerType
ye of
        SemiRingLiteral SemiRingRepr sr
_ Coefficient sr
_ ProgramLoc
_ -> () -> ReaderT (SMTCollectorState t h) IO ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
        Expr t BaseIntegerType
_ -> Expr t tp -> ReaderT (SMTCollectorState t h) IO ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkNonlinearSupport Expr t tp
i

      Term h
x <- Expr t BaseIntegerType
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseIntegerType
xe
      Term h
y <- Expr t BaseIntegerType
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseIntegerType
ye

      TypeMap BaseIntegerType
-> Term h -> SMTCollector t h (SMTExpr h BaseIntegerType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseIntegerType
IntegerTypeMap (Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
intMod Term h
x Term h
y)

    IntAbs Expr t BaseIntegerType
xe -> do
      Term h
x <- Expr t BaseIntegerType
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseIntegerType
xe
      TypeMap BaseIntegerType
-> Term h -> SMTCollector t h (SMTExpr h BaseIntegerType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseIntegerType
IntegerTypeMap (Term h -> Term h
forall v. SupportTermOps v => v -> v
intAbs Term h
x)

    IntDivisible Expr t BaseIntegerType
xe Natural
k -> do
      Term h
x <- Expr t BaseIntegerType
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseIntegerType
xe
      TypeMap BaseBoolType
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap (Term h -> Natural -> Term h
forall v. SupportTermOps v => v -> Natural -> v
intDivisible Term h
x Natural
k)

    NotPred Expr t BaseBoolType
x -> TypeMap BaseBoolType
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseBoolType))
-> (Term h -> Term h)
-> Term h
-> SMTCollector t h (SMTExpr h BaseBoolType)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term h -> Term h
forall v. SupportTermOps v => v -> v
notExpr (Term h -> SMTCollector t h (SMTExpr h BaseBoolType))
-> ReaderT (SMTCollectorState t h) IO (Term h)
-> SMTCollector t h (SMTExpr h BaseBoolType)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Expr t BaseBoolType -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseBoolType
x

    ConjPred BoolMap (Expr t)
xs ->
      let pol :: (Expr t tp, Polarity)
-> ReaderT (SMTCollectorState t h) IO (Term h)
pol (Expr t tp
x,Polarity
Positive) = Expr t tp -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t tp
x
          pol (Expr t tp
x,Polarity
Negative) = Term h -> Term h
forall v. SupportTermOps v => v -> v
notExpr (Term h -> Term h)
-> ReaderT (SMTCollectorState t h) IO (Term h)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr t tp -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t tp
x
      in
      case BoolMap (Expr t) -> BoolMapView (Expr t)
forall (f :: BaseType -> Type). BoolMap f -> BoolMapView f
BM.viewBoolMap BoolMap (Expr t)
xs of
        BoolMapView (Expr t)
BM.BoolMapUnit ->
          SMTExpr h BaseBoolType -> SMTCollector t h (SMTExpr h BaseBoolType)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SMTExpr h BaseBoolType
 -> SMTCollector t h (SMTExpr h BaseBoolType))
-> SMTExpr h BaseBoolType
-> SMTCollector t h (SMTExpr h BaseBoolType)
forall a b. (a -> b) -> a -> b
$ TypeMap BaseBoolType -> Term h -> SMTExpr h BaseBoolType
forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap BaseBoolType
BoolTypeMap (Term h -> SMTExpr h BaseBoolType)
-> Term h -> SMTExpr h BaseBoolType
forall a b. (a -> b) -> a -> b
$ Bool -> Term h
forall v. SupportTermOps v => Bool -> v
boolExpr Bool
True
        BoolMapView (Expr t)
BM.BoolMapDualUnit ->
          SMTExpr h BaseBoolType -> SMTCollector t h (SMTExpr h BaseBoolType)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SMTExpr h BaseBoolType
 -> SMTCollector t h (SMTExpr h BaseBoolType))
-> SMTExpr h BaseBoolType
-> SMTCollector t h (SMTExpr h BaseBoolType)
forall a b. (a -> b) -> a -> b
$ TypeMap BaseBoolType -> Term h -> SMTExpr h BaseBoolType
forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap BaseBoolType
BoolTypeMap (Term h -> SMTExpr h BaseBoolType)
-> Term h -> SMTExpr h BaseBoolType
forall a b. (a -> b) -> a -> b
$ Bool -> Term h
forall v. SupportTermOps v => Bool -> v
boolExpr Bool
False
        BM.BoolMapTerms ((Expr t BaseBoolType, Polarity)
t:|[]) ->
          TypeMap BaseBoolType -> Term h -> SMTExpr h BaseBoolType
forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap BaseBoolType
BoolTypeMap (Term h -> SMTExpr h BaseBoolType)
-> ReaderT (SMTCollectorState t h) IO (Term h)
-> SMTCollector t h (SMTExpr h BaseBoolType)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr t BaseBoolType, Polarity)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
(Expr t tp, Polarity)
-> ReaderT (SMTCollectorState t h) IO (Term h)
pol (Expr t BaseBoolType, Polarity)
t
        BM.BoolMapTerms ((Expr t BaseBoolType, Polarity)
t:|[(Expr t BaseBoolType, Polarity)]
ts) ->
          do Term h
cnj <- [Term h] -> Term h
forall v. SupportTermOps v => [v] -> v
andAll ([Term h] -> Term h)
-> ReaderT (SMTCollectorState t h) IO [Term h]
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Expr t BaseBoolType, Polarity)
 -> ReaderT (SMTCollectorState t h) IO (Term h))
-> [(Expr t BaseBoolType, Polarity)]
-> ReaderT (SMTCollectorState t h) IO [Term h]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Expr t BaseBoolType, Polarity)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
(Expr t tp, Polarity)
-> ReaderT (SMTCollectorState t h) IO (Term h)
pol ((Expr t BaseBoolType, Polarity)
t(Expr t BaseBoolType, Polarity)
-> [(Expr t BaseBoolType, Polarity)]
-> [(Expr t BaseBoolType, Polarity)]
forall a. a -> [a] -> [a]
:[(Expr t BaseBoolType, Polarity)]
ts)
             TypeMap BaseBoolType
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap Term h
cnj

    ------------------------------------------
    -- Real operations.

    SemiRingProd SemiRingProduct (Expr t) sr
pd ->
      case SemiRingProduct (Expr t) sr -> SemiRingRepr sr
forall (f :: BaseType -> Type) (sr :: SemiRing).
SemiRingProduct f sr -> SemiRingRepr sr
WSum.prodRepr SemiRingProduct (Expr t) sr
pd of
        SR.SemiRingBVRepr BVFlavorRepr fv
SR.BVArithRepr NatRepr w
w ->
          do Maybe (Term h)
pd' <- (Term h -> Term h -> ReaderT (SMTCollectorState t h) IO (Term h))
-> (Expr t (SemiRingBase sr)
    -> ReaderT (SMTCollectorState t h) IO (Term h))
-> SemiRingProduct (Expr t) sr
-> ReaderT (SMTCollectorState t h) IO (Maybe (Term h))
forall (m :: Type -> Type) r (f :: BaseType -> Type)
       (sr :: SemiRing).
Monad m =>
(r -> r -> m r)
-> (f (SemiRingBase sr) -> m r)
-> SemiRingProduct f sr
-> m (Maybe r)
WSum.prodEvalM (\Term h
a Term h
b -> Term h -> ReaderT (SMTCollectorState t h) IO (Term h)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
bvMul Term h
a Term h
b)) Expr t (SemiRingBase sr)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr SemiRingProduct (Expr t) sr
pd
             ReaderT (SMTCollectorState t h) IO (SMTExpr h (BaseBVType w))
-> (Term h
    -> ReaderT (SMTCollectorState t h) IO (SMTExpr h (BaseBVType w)))
-> Maybe (Term h)
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h (BaseBVType w))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SMTExpr h (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h (BaseBVType w))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SMTExpr h (BaseBVType w)
 -> ReaderT (SMTCollectorState t h) IO (SMTExpr h (BaseBVType w)))
-> SMTExpr h (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h (BaseBVType w))
forall a b. (a -> b) -> a -> b
$ TypeMap (BaseBVType w) -> Term h -> SMTExpr h (BaseBVType w)
forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr (NatRepr w -> TypeMap (BaseBVType w)
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr w
w) (Term h -> SMTExpr h (BaseBVType w))
-> Term h -> SMTExpr h (BaseBVType w)
forall a b. (a -> b) -> a -> b
$ NatRepr w -> BV w -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> BV w
forall (w :: Nat). (1 <= w) => NatRepr w -> BV w
BV.one NatRepr w
w))
                   (TypeMap (BaseBVType w)
-> Term h
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h (BaseBVType w))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (NatRepr w -> TypeMap (BaseBVType w)
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr w
w))
                   Maybe (Term h)
pd'

        SR.SemiRingBVRepr BVFlavorRepr fv
SR.BVBitsRepr NatRepr w
w ->
          do Maybe (Term h)
pd' <- (Term h -> Term h -> ReaderT (SMTCollectorState t h) IO (Term h))
-> (Expr t (SemiRingBase sr)
    -> ReaderT (SMTCollectorState t h) IO (Term h))
-> SemiRingProduct (Expr t) sr
-> ReaderT (SMTCollectorState t h) IO (Maybe (Term h))
forall (m :: Type -> Type) r (f :: BaseType -> Type)
       (sr :: SemiRing).
Monad m =>
(r -> r -> m r)
-> (f (SemiRingBase sr) -> m r)
-> SemiRingProduct f sr
-> m (Maybe r)
WSum.prodEvalM (\Term h
a Term h
b -> Term h -> ReaderT (SMTCollectorState t h) IO (Term h)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
bvAnd Term h
a Term h
b)) Expr t (SemiRingBase sr)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr SemiRingProduct (Expr t) sr
pd
             ReaderT (SMTCollectorState t h) IO (SMTExpr h (BaseBVType w))
-> (Term h
    -> ReaderT (SMTCollectorState t h) IO (SMTExpr h (BaseBVType w)))
-> Maybe (Term h)
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h (BaseBVType w))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SMTExpr h (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h (BaseBVType w))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SMTExpr h (BaseBVType w)
 -> ReaderT (SMTCollectorState t h) IO (SMTExpr h (BaseBVType w)))
-> SMTExpr h (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h (BaseBVType w))
forall a b. (a -> b) -> a -> b
$ TypeMap (BaseBVType w) -> Term h -> SMTExpr h (BaseBVType w)
forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr (NatRepr w -> TypeMap (BaseBVType w)
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr w
w) (Term h -> SMTExpr h (BaseBVType w))
-> Term h -> SMTExpr h (BaseBVType w)
forall a b. (a -> b) -> a -> b
$ NatRepr w -> BV w -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> BV w
forall (w :: Nat). NatRepr w -> BV w
BV.maxUnsigned NatRepr w
w))
                   (TypeMap (BaseBVType w)
-> Term h
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h (BaseBVType w))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (NatRepr w -> TypeMap (BaseBVType w)
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr w
w))
                   Maybe (Term h)
pd'
        SemiRingRepr sr
sr ->
          do Expr t tp -> ReaderT (SMTCollectorState t h) IO ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkNonlinearSupport Expr t tp
i
             Maybe (Term h)
pd' <- (Term h -> Term h -> ReaderT (SMTCollectorState t h) IO (Term h))
-> (Expr t (SemiRingBase sr)
    -> ReaderT (SMTCollectorState t h) IO (Term h))
-> SemiRingProduct (Expr t) sr
-> ReaderT (SMTCollectorState t h) IO (Maybe (Term h))
forall (m :: Type -> Type) r (f :: BaseType -> Type)
       (sr :: SemiRing).
Monad m =>
(r -> r -> m r)
-> (f (SemiRingBase sr) -> m r)
-> SemiRingProduct f sr
-> m (Maybe r)
WSum.prodEvalM (\Term h
a Term h
b -> Term h -> ReaderT (SMTCollectorState t h) IO (Term h)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Term h
a Term h -> Term h -> Term h
forall a. Num a => a -> a -> a
* Term h
b)) Expr t (SemiRingBase sr)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr SemiRingProduct (Expr t) sr
pd
             SMTCollector t h (SMTExpr h tp)
-> (Term h -> SMTCollector t h (SMTExpr h tp))
-> Maybe (Term h)
-> SMTCollector t h (SMTExpr h tp)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SMTExpr h tp -> SMTCollector t h (SMTExpr h tp)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SMTExpr h tp -> SMTCollector t h (SMTExpr h tp))
-> SMTExpr h tp -> SMTCollector t h (SMTExpr h tp)
forall a b. (a -> b) -> a -> b
$ TypeMap tp -> Term h -> SMTExpr h tp
forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr (SemiRingRepr sr -> TypeMap (SemiRingBase sr)
forall (sr :: SemiRing).
SemiRingRepr sr -> TypeMap (SemiRingBase sr)
semiRingTypeMap SemiRingRepr sr
sr) (Term h -> SMTExpr h tp) -> Term h -> SMTExpr h tp
forall a b. (a -> b) -> a -> b
$ Integer -> Term h
forall v. SupportTermOps v => Integer -> v
integerTerm Integer
1)
                   (TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (SemiRingRepr sr -> TypeMap (SemiRingBase sr)
forall (sr :: SemiRing).
SemiRingRepr sr -> TypeMap (SemiRingBase sr)
semiRingTypeMap SemiRingRepr sr
sr))
                   Maybe (Term h)
pd'

    SemiRingSum WeightedSum (Expr t) sr
s ->
      case WeightedSum (Expr t) sr -> SemiRingRepr sr
forall (f :: BaseType -> Type) (sr :: SemiRing).
WeightedSum f sr -> SemiRingRepr sr
WSum.sumRepr WeightedSum (Expr t) sr
s of
        SemiRingRepr sr
SR.SemiRingIntegerRepr ->
          let smul :: Integer -> Expr t tp -> ReaderT (SMTCollectorState t h) IO [Term h]
smul Integer
c Expr t tp
e
                | Integer
c Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==  Integer
1   = (Term h -> [Term h] -> [Term h]
forall a. a -> [a] -> [a]
:[]) (Term h -> [Term h])
-> ReaderT (SMTCollectorState t h) IO (Term h)
-> ReaderT (SMTCollectorState t h) IO [Term h]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr t tp -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t tp
e
                | Integer
c Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== -Integer
1   = (Term h -> [Term h] -> [Term h]
forall a. a -> [a] -> [a]
:[]) (Term h -> [Term h]) -> (Term h -> Term h) -> Term h -> [Term h]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term h -> Term h
forall a. Num a => a -> a
negate (Term h -> [Term h])
-> ReaderT (SMTCollectorState t h) IO (Term h)
-> ReaderT (SMTCollectorState t h) IO [Term h]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr t tp -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t tp
e
                | Bool
otherwise = (Term h -> [Term h] -> [Term h]
forall a. a -> [a] -> [a]
:[]) (Term h -> [Term h]) -> (Term h -> Term h) -> Term h -> [Term h]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Term h
forall v. SupportTermOps v => Integer -> v
integerTerm Integer
c Term h -> Term h -> Term h
forall a. Num a => a -> a -> a
*) (Term h -> [Term h])
-> ReaderT (SMTCollectorState t h) IO (Term h)
-> ReaderT (SMTCollectorState t h) IO [Term h]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr t tp -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t tp
e
              cnst :: Integer -> [a]
cnst Integer
0 = []
              cnst Integer
x = [Integer -> a
forall v. SupportTermOps v => Integer -> v
integerTerm Integer
x]
              add :: [a] -> [a] -> f [a]
add [a]
x [a]
y = [a] -> f [a]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([a]
y [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
x) -- reversed for efficiency when grouped to the left
          in
          TypeMap BaseIntegerType
-> Term h -> SMTCollector t h (SMTExpr h BaseIntegerType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseIntegerType
IntegerTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseIntegerType))
-> ([Term h] -> Term h)
-> [Term h]
-> SMTCollector t h (SMTExpr h BaseIntegerType)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Term h] -> Term h
forall v. SupportTermOps v => [v] -> v
sumExpr
            ([Term h] -> SMTCollector t h (SMTExpr h BaseIntegerType))
-> ReaderT (SMTCollectorState t h) IO [Term h]
-> SMTCollector t h (SMTExpr h BaseIntegerType)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< ([Term h]
 -> [Term h] -> ReaderT (SMTCollectorState t h) IO [Term h])
-> (Coefficient sr
    -> Expr t (SemiRingBase sr)
    -> ReaderT (SMTCollectorState t h) IO [Term h])
-> (Coefficient sr -> ReaderT (SMTCollectorState t h) IO [Term h])
-> WeightedSum (Expr t) sr
-> ReaderT (SMTCollectorState t h) IO [Term h]
forall (m :: Type -> Type) r (sr :: SemiRing)
       (f :: BaseType -> Type).
Monad m =>
(r -> r -> m r)
-> (Coefficient sr -> f (SemiRingBase sr) -> m r)
-> (Coefficient sr -> m r)
-> WeightedSum f sr
-> m r
WSum.evalM [Term h] -> [Term h] -> ReaderT (SMTCollectorState t h) IO [Term h]
forall (f :: Type -> Type) a. Applicative f => [a] -> [a] -> f [a]
add Coefficient sr
-> Expr t (SemiRingBase sr)
-> ReaderT (SMTCollectorState t h) IO [Term h]
forall h t (tp :: BaseType).
SMTWriter h =>
Integer -> Expr t tp -> ReaderT (SMTCollectorState t h) IO [Term h]
smul ([Term h] -> ReaderT (SMTCollectorState t h) IO [Term h]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([Term h] -> ReaderT (SMTCollectorState t h) IO [Term h])
-> (Integer -> [Term h])
-> Integer
-> ReaderT (SMTCollectorState t h) IO [Term h]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> [Term h]
forall a. SupportTermOps a => Integer -> [a]
cnst) WeightedSum (Expr t) sr
s

        SemiRingRepr sr
SR.SemiRingRealRepr ->
          let smul :: Rational
-> Expr t tp -> ReaderT (SMTCollectorState t h) IO [Term h]
smul Rational
c Expr t tp
e
                | Rational
c Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
==  Rational
1 = (Term h -> [Term h] -> [Term h]
forall a. a -> [a] -> [a]
:[]) (Term h -> [Term h])
-> ReaderT (SMTCollectorState t h) IO (Term h)
-> ReaderT (SMTCollectorState t h) IO [Term h]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr t tp -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t tp
e
                | Rational
c Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== -Rational
1 = (Term h -> [Term h] -> [Term h]
forall a. a -> [a] -> [a]
:[]) (Term h -> [Term h]) -> (Term h -> Term h) -> Term h -> [Term h]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term h -> Term h
forall a. Num a => a -> a
negate (Term h -> [Term h])
-> ReaderT (SMTCollectorState t h) IO (Term h)
-> ReaderT (SMTCollectorState t h) IO [Term h]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr t tp -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t tp
e
                | Bool
otherwise = (Term h -> [Term h] -> [Term h]
forall a. a -> [a] -> [a]
:[]) (Term h -> [Term h]) -> (Term h -> Term h) -> Term h -> [Term h]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rational -> Term h
forall v. SupportTermOps v => Rational -> v
rationalTerm Rational
c Term h -> Term h -> Term h
forall a. Num a => a -> a -> a
*) (Term h -> [Term h])
-> ReaderT (SMTCollectorState t h) IO (Term h)
-> ReaderT (SMTCollectorState t h) IO [Term h]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr t tp -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t tp
e
              cnst :: Rational -> [a]
cnst Rational
0 = []
              cnst Rational
x = [Rational -> a
forall v. SupportTermOps v => Rational -> v
rationalTerm Rational
x]
              add :: [a] -> [a] -> f [a]
add [a]
x [a]
y = [a] -> f [a]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([a]
y [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
x) -- reversed for efficiency when grouped to the left
          in
          TypeMap BaseRealType
-> Term h -> SMTCollector t h (SMTExpr h BaseRealType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseRealType
RealTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseRealType))
-> ([Term h] -> Term h)
-> [Term h]
-> SMTCollector t h (SMTExpr h BaseRealType)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Term h] -> Term h
forall v. SupportTermOps v => [v] -> v
sumExpr
            ([Term h] -> SMTCollector t h (SMTExpr h BaseRealType))
-> ReaderT (SMTCollectorState t h) IO [Term h]
-> SMTCollector t h (SMTExpr h BaseRealType)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< ([Term h]
 -> [Term h] -> ReaderT (SMTCollectorState t h) IO [Term h])
-> (Coefficient sr
    -> Expr t (SemiRingBase sr)
    -> ReaderT (SMTCollectorState t h) IO [Term h])
-> (Coefficient sr -> ReaderT (SMTCollectorState t h) IO [Term h])
-> WeightedSum (Expr t) sr
-> ReaderT (SMTCollectorState t h) IO [Term h]
forall (m :: Type -> Type) r (sr :: SemiRing)
       (f :: BaseType -> Type).
Monad m =>
(r -> r -> m r)
-> (Coefficient sr -> f (SemiRingBase sr) -> m r)
-> (Coefficient sr -> m r)
-> WeightedSum f sr
-> m r
WSum.evalM [Term h] -> [Term h] -> ReaderT (SMTCollectorState t h) IO [Term h]
forall (f :: Type -> Type) a. Applicative f => [a] -> [a] -> f [a]
add Coefficient sr
-> Expr t (SemiRingBase sr)
-> ReaderT (SMTCollectorState t h) IO [Term h]
forall h t (tp :: BaseType).
SMTWriter h =>
Rational
-> Expr t tp -> ReaderT (SMTCollectorState t h) IO [Term h]
smul ([Term h] -> ReaderT (SMTCollectorState t h) IO [Term h]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([Term h] -> ReaderT (SMTCollectorState t h) IO [Term h])
-> (Rational -> [Term h])
-> Rational
-> ReaderT (SMTCollectorState t h) IO [Term h]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> [Term h]
forall a. SupportTermOps a => Rational -> [a]
cnst) WeightedSum (Expr t) sr
s

        SR.SemiRingBVRepr BVFlavorRepr fv
SR.BVArithRepr NatRepr w
w ->
          let smul :: BV w
-> Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO [Term h]
smul BV w
c Expr t (BaseBVType w)
e
                | BV w
c BV w -> BV w -> Bool
forall a. Eq a => a -> a -> Bool
== NatRepr w -> BV w
forall (w :: Nat). (1 <= w) => NatRepr w -> BV w
BV.one NatRepr w
w = (Term h -> [Term h] -> [Term h]
forall a. a -> [a] -> [a]
:[]) (Term h -> [Term h])
-> ReaderT (SMTCollectorState t h) IO (Term h)
-> ReaderT (SMTCollectorState t h) IO [Term h]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
e
                | BV w
c BV w -> BV w -> Bool
forall a. Eq a => a -> a -> Bool
== NatRepr w -> BV w
forall (w :: Nat). NatRepr w -> BV w
BV.maxUnsigned NatRepr w
w = (Term h -> [Term h] -> [Term h]
forall a. a -> [a] -> [a]
:[]) (Term h -> [Term h]) -> (Term h -> Term h) -> Term h -> [Term h]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term h -> Term h
forall v. SupportTermOps v => v -> v
bvNeg (Term h -> [Term h])
-> ReaderT (SMTCollectorState t h) IO (Term h)
-> ReaderT (SMTCollectorState t h) IO [Term h]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
e
                | Bool
otherwise = (Term h -> [Term h] -> [Term h]
forall a. a -> [a] -> [a]
:[]) (Term h -> [Term h]) -> (Term h -> Term h) -> Term h -> [Term h]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
bvMul (NatRepr w -> BV w -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w BV w
c)) (Term h -> [Term h])
-> ReaderT (SMTCollectorState t h) IO (Term h)
-> ReaderT (SMTCollectorState t h) IO [Term h]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
e
              cnst :: BV w -> [Term h]
cnst (BV.BV Integer
0) = []
              cnst BV w
x = [NatRepr w -> BV w -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w BV w
x]
              add :: [a] -> [a] -> f [a]
add [a]
x [a]
y = [a] -> f [a]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([a]
y [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
x) -- reversed for efficiency when grouped to the left
           in
           TypeMap (BaseBVType w)
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType w))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (NatRepr w -> TypeMap (BaseBVType w)
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr w
w) (Term h -> SMTCollector t h (SMTExpr h (BaseBVType w)))
-> ([Term h] -> Term h)
-> [Term h]
-> SMTCollector t h (SMTExpr h (BaseBVType w))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NatRepr w -> [Term h] -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> [v] -> v
bvSumExpr NatRepr w
w
             ([Term h] -> SMTCollector t h (SMTExpr h (BaseBVType w)))
-> ReaderT (SMTCollectorState t h) IO [Term h]
-> SMTCollector t h (SMTExpr h (BaseBVType w))
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< ([Term h]
 -> [Term h] -> ReaderT (SMTCollectorState t h) IO [Term h])
-> (Coefficient sr
    -> Expr t (SemiRingBase sr)
    -> ReaderT (SMTCollectorState t h) IO [Term h])
-> (Coefficient sr -> ReaderT (SMTCollectorState t h) IO [Term h])
-> WeightedSum (Expr t) sr
-> ReaderT (SMTCollectorState t h) IO [Term h]
forall (m :: Type -> Type) r (sr :: SemiRing)
       (f :: BaseType -> Type).
Monad m =>
(r -> r -> m r)
-> (Coefficient sr -> f (SemiRingBase sr) -> m r)
-> (Coefficient sr -> m r)
-> WeightedSum f sr
-> m r
WSum.evalM [Term h] -> [Term h] -> ReaderT (SMTCollectorState t h) IO [Term h]
forall (f :: Type -> Type) a. Applicative f => [a] -> [a] -> f [a]
add BV w
-> Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO [Term h]
Coefficient sr
-> Expr t (SemiRingBase sr)
-> ReaderT (SMTCollectorState t h) IO [Term h]
smul ([Term h] -> ReaderT (SMTCollectorState t h) IO [Term h]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([Term h] -> ReaderT (SMTCollectorState t h) IO [Term h])
-> (BV w -> [Term h])
-> BV w
-> ReaderT (SMTCollectorState t h) IO [Term h]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BV w -> [Term h]
cnst) WeightedSum (Expr t) sr
s

        SR.SemiRingBVRepr BVFlavorRepr fv
SR.BVBitsRepr NatRepr w
w ->
          let smul :: BV w
-> Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO [Term h]
smul BV w
c Expr t (BaseBVType w)
e
                | BV w
c BV w -> BV w -> Bool
forall a. Eq a => a -> a -> Bool
== NatRepr w -> BV w
forall (w :: Nat). NatRepr w -> BV w
BV.maxUnsigned NatRepr w
w = (Term h -> [Term h] -> [Term h]
forall a. a -> [a] -> [a]
:[]) (Term h -> [Term h])
-> ReaderT (SMTCollectorState t h) IO (Term h)
-> ReaderT (SMTCollectorState t h) IO [Term h]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
e
                | Bool
otherwise             = (Term h -> [Term h] -> [Term h]
forall a. a -> [a] -> [a]
:[]) (Term h -> [Term h]) -> (Term h -> Term h) -> Term h -> [Term h]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
bvAnd (NatRepr w -> BV w -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w BV w
c)) (Term h -> [Term h])
-> ReaderT (SMTCollectorState t h) IO (Term h)
-> ReaderT (SMTCollectorState t h) IO [Term h]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
e
              cnst :: BV w -> [Term h]
cnst (BV.BV Integer
0) = []
              cnst BV w
x = [NatRepr w -> BV w -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w BV w
x]
              add :: [a] -> [a] -> f [a]
add [a]
x [a]
y = [a] -> f [a]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([a]
y [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
x) -- reversed for efficiency when grouped to the left
              xorsum :: [Term h] -> Term h
xorsum [] = NatRepr w -> BV w -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> BV w
forall (w :: Nat). NatRepr w -> BV w
BV.zero NatRepr w
w)
              xorsum [Term h]
xs = (Term h -> Term h -> Term h) -> [Term h] -> Term h
forall (t :: Type -> Type) a.
Foldable t =>
(a -> a -> a) -> t a -> a
foldr1 Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
bvXor [Term h]
xs
           in
           TypeMap (BaseBVType w)
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType w))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (NatRepr w -> TypeMap (BaseBVType w)
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr w
w) (Term h -> SMTCollector t h (SMTExpr h (BaseBVType w)))
-> ([Term h] -> Term h)
-> [Term h]
-> SMTCollector t h (SMTExpr h (BaseBVType w))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Term h] -> Term h
xorsum
             ([Term h] -> SMTCollector t h (SMTExpr h (BaseBVType w)))
-> ReaderT (SMTCollectorState t h) IO [Term h]
-> SMTCollector t h (SMTExpr h (BaseBVType w))
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< ([Term h]
 -> [Term h] -> ReaderT (SMTCollectorState t h) IO [Term h])
-> (Coefficient sr
    -> Expr t (SemiRingBase sr)
    -> ReaderT (SMTCollectorState t h) IO [Term h])
-> (Coefficient sr -> ReaderT (SMTCollectorState t h) IO [Term h])
-> WeightedSum (Expr t) sr
-> ReaderT (SMTCollectorState t h) IO [Term h]
forall (m :: Type -> Type) r (sr :: SemiRing)
       (f :: BaseType -> Type).
Monad m =>
(r -> r -> m r)
-> (Coefficient sr -> f (SemiRingBase sr) -> m r)
-> (Coefficient sr -> m r)
-> WeightedSum f sr
-> m r
WSum.evalM [Term h] -> [Term h] -> ReaderT (SMTCollectorState t h) IO [Term h]
forall (f :: Type -> Type) a. Applicative f => [a] -> [a] -> f [a]
add BV w
-> Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO [Term h]
Coefficient sr
-> Expr t (SemiRingBase sr)
-> ReaderT (SMTCollectorState t h) IO [Term h]
smul ([Term h] -> ReaderT (SMTCollectorState t h) IO [Term h]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([Term h] -> ReaderT (SMTCollectorState t h) IO [Term h])
-> (BV w -> [Term h])
-> BV w
-> ReaderT (SMTCollectorState t h) IO [Term h]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BV w -> [Term h]
cnst) WeightedSum (Expr t) sr
s

    RealDiv Expr t BaseRealType
xe Expr t BaseRealType
ye -> do
      Term h
x <- Expr t BaseRealType -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseRealType
xe
      case Expr t BaseRealType
ye of
        SemiRingLiteral SemiRingRepr sr
SR.SemiRingRealRepr Coefficient sr
r ProgramLoc
_ | Rational
Coefficient sr
r Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
/= Rational
0 -> do
          TypeMap BaseRealType
-> Term h -> SMTCollector t h (SMTExpr h BaseRealType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseRealType
RealTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseRealType))
-> Term h -> SMTCollector t h (SMTExpr h BaseRealType)
forall a b. (a -> b) -> a -> b
$ Term h
x Term h -> Term h -> Term h
forall a. Num a => a -> a -> a
* Rational -> Term h
forall v. SupportTermOps v => Rational -> v
rationalTerm (Rational -> Rational
forall a. Fractional a => a -> a
recip Rational
Coefficient sr
r)
        Expr t BaseRealType
_ -> do
          Expr t tp -> ReaderT (SMTCollectorState t h) IO ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkNonlinearSupport Expr t tp
i
          Term h
y <- Expr t BaseRealType -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseRealType
ye
          TypeMap BaseRealType
-> Term h -> SMTCollector t h (SMTExpr h BaseRealType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseRealType
RealTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseRealType))
-> Term h -> SMTCollector t h (SMTExpr h BaseRealType)
forall a b. (a -> b) -> a -> b
$ Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
realDiv Term h
x Term h
y

    RealSqrt Expr t BaseRealType
xe -> do
      Expr t tp -> ReaderT (SMTCollectorState t h) IO ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkNonlinearSupport Expr t tp
i

      Term h
x <- Expr t BaseRealType -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseRealType
xe
      SMTExpr h BaseRealType
nm <- String
-> TypeMap BaseRealType
-> SMTCollector t h (SMTExpr h BaseRealType)
forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
"real sqrt" TypeMap BaseRealType
RealTypeMap
      let v :: Term h
v = SMTExpr h BaseRealType -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h BaseRealType
nm
      -- assert v*v = x | x < 0
      String -> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"real sqrt" (Term h -> ReaderT (SMTCollectorState t h) IO ())
-> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall a b. (a -> b) -> a -> b
$ Term h
v Term h -> Term h -> Term h
forall a. Num a => a -> a -> a
* Term h
v Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.== Term h
x Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.|| Term h
x Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.< Term h
0
      -- assert v >= 0
      String -> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"real sqrt" (Term h -> ReaderT (SMTCollectorState t h) IO ())
-> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall a b. (a -> b) -> a -> b
$ Term h
v Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.>= Term h
0
      -- Return variable
      SMTExpr h BaseRealType -> SMTCollector t h (SMTExpr h BaseRealType)
forall (m :: Type -> Type) a. Monad m => a -> m a
return SMTExpr h BaseRealType
nm
    App (Expr t) tp
Pi -> do
      Expr t tp -> SMTCollector t h (SMTExpr h tp)
forall (m :: Type -> Type) t (tp :: BaseType) a.
MonadFail m =>
Expr t tp -> m a
unsupportedTerm Expr t tp
i
    RealSin Expr t BaseRealType
xe -> do
      Expr t tp -> ReaderT (SMTCollectorState t h) IO ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkComputableSupport Expr t tp
i
      Term h
x <- Expr t BaseRealType -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseRealType
xe
      TypeMap BaseRealType
-> Term h -> SMTCollector t h (SMTExpr h BaseRealType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseRealType
RealTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseRealType))
-> Term h -> SMTCollector t h (SMTExpr h BaseRealType)
forall a b. (a -> b) -> a -> b
$ Term h -> Term h
forall v. SupportTermOps v => v -> v
realSin Term h
x
    RealCos Expr t BaseRealType
xe -> do
      Expr t tp -> ReaderT (SMTCollectorState t h) IO ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkComputableSupport Expr t tp
i
      Term h
x <- Expr t BaseRealType -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseRealType
xe
      TypeMap BaseRealType
-> Term h -> SMTCollector t h (SMTExpr h BaseRealType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseRealType
RealTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseRealType))
-> Term h -> SMTCollector t h (SMTExpr h BaseRealType)
forall a b. (a -> b) -> a -> b
$ Term h -> Term h
forall v. SupportTermOps v => v -> v
realCos Term h
x
    RealATan2 Expr t BaseRealType
xe Expr t BaseRealType
ye -> do
      Expr t tp -> ReaderT (SMTCollectorState t h) IO ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkComputableSupport Expr t tp
i
      Term h
x <- Expr t BaseRealType -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseRealType
xe
      Term h
y <- Expr t BaseRealType -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseRealType
ye
      TypeMap BaseRealType
-> Term h -> SMTCollector t h (SMTExpr h BaseRealType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseRealType
RealTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseRealType))
-> Term h -> SMTCollector t h (SMTExpr h BaseRealType)
forall a b. (a -> b) -> a -> b
$ Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
realATan2 Term h
x Term h
y
    RealSinh Expr t BaseRealType
xe -> do
      Expr t tp -> ReaderT (SMTCollectorState t h) IO ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkComputableSupport Expr t tp
i
      Term h
x <- Expr t BaseRealType -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseRealType
xe
      TypeMap BaseRealType
-> Term h -> SMTCollector t h (SMTExpr h BaseRealType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseRealType
RealTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseRealType))
-> Term h -> SMTCollector t h (SMTExpr h BaseRealType)
forall a b. (a -> b) -> a -> b
$ Term h -> Term h
forall v. SupportTermOps v => v -> v
realSinh Term h
x
    RealCosh Expr t BaseRealType
xe -> do
      Expr t tp -> ReaderT (SMTCollectorState t h) IO ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkComputableSupport Expr t tp
i
      Term h
x <- Expr t BaseRealType -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseRealType
xe
      TypeMap BaseRealType
-> Term h -> SMTCollector t h (SMTExpr h BaseRealType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseRealType
RealTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseRealType))
-> Term h -> SMTCollector t h (SMTExpr h BaseRealType)
forall a b. (a -> b) -> a -> b
$ Term h -> Term h
forall v. SupportTermOps v => v -> v
realCosh Term h
x
    RealExp Expr t BaseRealType
xe -> do
      Expr t tp -> ReaderT (SMTCollectorState t h) IO ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkComputableSupport Expr t tp
i
      Term h
x <- Expr t BaseRealType -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseRealType
xe
      TypeMap BaseRealType
-> Term h -> SMTCollector t h (SMTExpr h BaseRealType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseRealType
RealTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseRealType))
-> Term h -> SMTCollector t h (SMTExpr h BaseRealType)
forall a b. (a -> b) -> a -> b
$ Term h -> Term h
forall v. SupportTermOps v => v -> v
realExp Term h
x
    RealLog Expr t BaseRealType
xe -> do
      Expr t tp -> ReaderT (SMTCollectorState t h) IO ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkComputableSupport Expr t tp
i
      Term h
x <- Expr t BaseRealType -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseRealType
xe
      TypeMap BaseRealType
-> Term h -> SMTCollector t h (SMTExpr h BaseRealType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseRealType
RealTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseRealType))
-> Term h -> SMTCollector t h (SMTExpr h BaseRealType)
forall a b. (a -> b) -> a -> b
$ Term h -> Term h
forall v. SupportTermOps v => v -> v
realLog Term h
x

    ------------------------------------------
    -- Bitvector operations

    -- BGS: If UnaryBV is ported to BV, a lot of the unnecessary masks
    -- here will go away
    BVUnaryTerm UnaryBV (Expr t BaseBoolType) n
t -> do
      let w :: NatRepr n
w = UnaryBV (Expr t BaseBoolType) n -> NatRepr n
forall p (n :: Nat). UnaryBV p n -> NatRepr n
UnaryBV.width UnaryBV (Expr t BaseBoolType) n
t
      let entries :: [(Expr t BaseBoolType, Integer, Integer)]
entries = UnaryBV (Expr t BaseBoolType) n
-> [(Expr t BaseBoolType, Integer, Integer)]
forall p (n :: Nat). UnaryBV p n -> [(p, Integer, Integer)]
UnaryBV.unsignedRanges UnaryBV (Expr t BaseBoolType) n
t

      SMTExpr h (BaseBVType n)
nm <- String
-> TypeMap (BaseBVType n)
-> SMTCollector t h (SMTExpr h (BaseBVType n))
forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
"unary term" (NatRepr n -> TypeMap (BaseBVType n)
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr n
w)
      let nm_s :: Term h
nm_s = SMTExpr h (BaseBVType n) -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h (BaseBVType n)
nm
      [(Expr t BaseBoolType, Integer, Integer)]
-> ((Expr t BaseBoolType, Integer, Integer)
    -> ReaderT (SMTCollectorState t h) IO ())
-> ReaderT (SMTCollectorState t h) IO ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Expr t BaseBoolType, Integer, Integer)]
entries (((Expr t BaseBoolType, Integer, Integer)
  -> ReaderT (SMTCollectorState t h) IO ())
 -> ReaderT (SMTCollectorState t h) IO ())
-> ((Expr t BaseBoolType, Integer, Integer)
    -> ReaderT (SMTCollectorState t h) IO ())
-> ReaderT (SMTCollectorState t h) IO ()
forall a b. (a -> b) -> a -> b
$ \(Expr t BaseBoolType
pr,Integer
l,Integer
u) -> do
        -- Add assertion that for all values v in l,u, the predicate
        -- q is equivalent to v being less than or equal to the result
        -- of this term (denoted by nm)
        Term h
q <- Expr t BaseBoolType -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseBoolType
pr
        String -> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"unary term" (Term h -> ReaderT (SMTCollectorState t h) IO ())
-> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall a b. (a -> b) -> a -> b
$ Term h
q Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.== Term h
nm_s Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
`bvULe` NatRepr n -> BV n -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr n
w (NatRepr n -> Integer -> BV n
forall (w :: Nat). NatRepr w -> Integer -> BV w
BV.mkBV NatRepr n
w Integer
l)
        String -> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"unary term" (Term h -> ReaderT (SMTCollectorState t h) IO ())
-> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall a b. (a -> b) -> a -> b
$ Term h
q Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.== Term h
nm_s Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
`bvULe` NatRepr n -> BV n -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr n
w (NatRepr n -> Integer -> BV n
forall (w :: Nat). NatRepr w -> Integer -> BV w
BV.mkBV NatRepr n
w Integer
u)

      case [(Expr t BaseBoolType, Integer, Integer)]
entries of
        (Expr t BaseBoolType
_, Integer
l, Integer
_):[(Expr t BaseBoolType, Integer, Integer)]
_ | Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 -> do
          String -> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"unary term" (Term h -> ReaderT (SMTCollectorState t h) IO ())
-> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall a b. (a -> b) -> a -> b
$ NatRepr n -> BV n -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr n
w (NatRepr n -> Integer -> BV n
forall (w :: Nat). NatRepr w -> Integer -> BV w
BV.mkBV NatRepr n
w Integer
l) Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
`bvULe` Term h
nm_s
        [(Expr t BaseBoolType, Integer, Integer)]
_ ->
          () -> ReaderT (SMTCollectorState t h) IO ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
      SMTExpr h (BaseBVType n)
-> SMTCollector t h (SMTExpr h (BaseBVType n))
forall (m :: Type -> Type) a. Monad m => a -> m a
return SMTExpr h (BaseBVType n)
nm

    BVOrBits NatRepr w
w BVOrSet (Expr t) w
bs ->
       do [Term h]
bs' <- (Expr t (BaseBVType w)
 -> ReaderT (SMTCollectorState t h) IO (Term h))
-> [Expr t (BaseBVType w)]
-> ReaderT (SMTCollectorState t h) IO [Term h]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr (BVOrSet (Expr t) w -> [Expr t (BaseBVType w)]
forall (e :: BaseType -> Type) (w :: Nat).
BVOrSet e w -> [e (BaseBVType w)]
bvOrToList BVOrSet (Expr t) w
bs)
          TypeMap (BaseBVType w)
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType w))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (NatRepr w -> TypeMap (BaseBVType w)
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr w
w) (Term h -> SMTCollector t h (SMTExpr h (BaseBVType w)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType w))
forall a b. (a -> b) -> a -> b
$!
            case [Term h]
bs' of
              [] -> NatRepr w -> BV w -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> BV w
forall (w :: Nat). NatRepr w -> BV w
BV.zero NatRepr w
w)
              Term h
x:[Term h]
xs -> (Term h -> Term h -> Term h) -> Term h -> [Term h] -> Term h
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
bvOr Term h
x [Term h]
xs

    BVConcat NatRepr (u + v)
w Expr t (BaseBVType u)
xe Expr t (BaseBVType v)
ye -> do
      Term h
x <- Expr t (BaseBVType u)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType u)
xe
      Term h
y <- Expr t (BaseBVType v)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType v)
ye
      TypeMap (BaseBVType (u + v))
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType (u + v)))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (NatRepr (u + v) -> TypeMap (BaseBVType (u + v))
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr (u + v)
w) (Term h -> SMTCollector t h (SMTExpr h (BaseBVType (u + v))))
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType (u + v)))
forall a b. (a -> b) -> a -> b
$ Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
bvConcat Term h
x Term h
y

    BVSelect NatRepr idx
idx NatRepr n
n Expr t (BaseBVType w)
xe -> do
      Term h
x <- Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
xe
      TypeMap (BaseBVType n)
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType n))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (NatRepr n -> TypeMap (BaseBVType n)
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr n
n) (Term h -> SMTCollector t h (SMTExpr h (BaseBVType n)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType n))
forall a b. (a -> b) -> a -> b
$ NatRepr w -> Natural -> Natural -> Term h -> Term h
forall v (w :: Nat).
SupportTermOps v =>
NatRepr w -> Natural -> Natural -> v -> v
bvExtract (Expr t (BaseBVType w) -> NatRepr w
forall (e :: BaseType -> Type) (w :: Nat).
IsExpr e =>
e (BaseBVType w) -> NatRepr w
bvWidth Expr t (BaseBVType w)
xe) (NatRepr idx -> Natural
forall (n :: Nat). NatRepr n -> Natural
natValue NatRepr idx
idx) (NatRepr n -> Natural
forall (n :: Nat). NatRepr n -> Natural
natValue NatRepr n
n) Term h
x

    BVUdiv NatRepr w
w Expr t (BaseBVType w)
xe Expr t (BaseBVType w)
ye -> do
      Term h
x <- Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
xe
      Term h
y <- Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
ye
      TypeMap (BaseBVType w)
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType w))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (NatRepr w -> TypeMap (BaseBVType w)
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr w
w) (Term h -> SMTCollector t h (SMTExpr h (BaseBVType w)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType w))
forall a b. (a -> b) -> a -> b
$ Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
bvUDiv Term h
x Term h
y

    BVUrem NatRepr w
w Expr t (BaseBVType w)
xe Expr t (BaseBVType w)
ye -> do
      Term h
x <- Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
xe
      Term h
y <- Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
ye
      TypeMap (BaseBVType w)
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType w))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (NatRepr w -> TypeMap (BaseBVType w)
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr w
w) (Term h -> SMTCollector t h (SMTExpr h (BaseBVType w)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType w))
forall a b. (a -> b) -> a -> b
$ Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
bvURem Term h
x Term h
y

    BVSdiv NatRepr w
w Expr t (BaseBVType w)
xe Expr t (BaseBVType w)
ye -> do
      Term h
x <- Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
xe
      Term h
y <- Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
ye
      TypeMap (BaseBVType w)
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType w))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (NatRepr w -> TypeMap (BaseBVType w)
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr w
w) (Term h -> SMTCollector t h (SMTExpr h (BaseBVType w)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType w))
forall a b. (a -> b) -> a -> b
$ Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
bvSDiv Term h
x Term h
y

    BVSrem NatRepr w
w Expr t (BaseBVType w)
xe Expr t (BaseBVType w)
ye -> do
      Term h
x <- Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
xe
      Term h
y <- Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
ye
      TypeMap (BaseBVType w)
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType w))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (NatRepr w -> TypeMap (BaseBVType w)
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr w
w) (Term h -> SMTCollector t h (SMTExpr h (BaseBVType w)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType w))
forall a b. (a -> b) -> a -> b
$ Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
bvSRem Term h
x Term h
y

    BVShl NatRepr w
w Expr t (BaseBVType w)
xe Expr t (BaseBVType w)
ye -> do
      Term h
x <- Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
xe
      Term h
y <- Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
ye
      TypeMap (BaseBVType w)
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType w))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (NatRepr w -> TypeMap (BaseBVType w)
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr w
w) (Term h -> SMTCollector t h (SMTExpr h (BaseBVType w)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType w))
forall a b. (a -> b) -> a -> b
$ Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
bvShl Term h
x Term h
y

    BVLshr NatRepr w
w Expr t (BaseBVType w)
xe Expr t (BaseBVType w)
ye -> do
      Term h
x <- Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
xe
      Term h
y <- Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
ye
      TypeMap (BaseBVType w)
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType w))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (NatRepr w -> TypeMap (BaseBVType w)
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr w
w) (Term h -> SMTCollector t h (SMTExpr h (BaseBVType w)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType w))
forall a b. (a -> b) -> a -> b
$ Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
bvLshr Term h
x Term h
y

    BVAshr NatRepr w
w Expr t (BaseBVType w)
xe Expr t (BaseBVType w)
ye -> do
      Term h
x <- Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
xe
      Term h
y <- Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
ye
      TypeMap (BaseBVType w)
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType w))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (NatRepr w -> TypeMap (BaseBVType w)
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr w
w) (Term h -> SMTCollector t h (SMTExpr h (BaseBVType w)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType w))
forall a b. (a -> b) -> a -> b
$ Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
bvAshr Term h
x Term h
y

    BVRol NatRepr w
w Expr t (BaseBVType w)
xe Expr t (BaseBVType w)
ye -> do
      Term h
x  <- Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
xe
      Term h
y  <- Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
ye

      let w' :: Term h
w' = NatRepr w -> BV w -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> BV w
forall (w :: Nat). NatRepr w -> BV w
BV.width NatRepr w
w)
      Term h
y' <- SMTExpr h (BaseBVType w) -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase (SMTExpr h (BaseBVType w) -> Term h)
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h (BaseBVType w))
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (TypeMap (BaseBVType w)
-> Term h
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h (BaseBVType w))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (NatRepr w -> TypeMap (BaseBVType w)
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr w
w) (Term h
 -> ReaderT (SMTCollectorState t h) IO (SMTExpr h (BaseBVType w)))
-> Term h
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h (BaseBVType w))
forall a b. (a -> b) -> a -> b
$ Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
bvURem Term h
y Term h
w')

      let lo :: Term h
lo = Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
bvLshr Term h
x (Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
bvSub Term h
w' Term h
y')
      let hi :: Term h
hi = Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
bvShl Term h
x Term h
y'

      TypeMap (BaseBVType w)
-> Term h
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h (BaseBVType w))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (NatRepr w -> TypeMap (BaseBVType w)
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr w
w) (Term h
 -> ReaderT (SMTCollectorState t h) IO (SMTExpr h (BaseBVType w)))
-> Term h
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h (BaseBVType w))
forall a b. (a -> b) -> a -> b
$ Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
bvXor Term h
hi Term h
lo

    BVRor NatRepr w
w Expr t (BaseBVType w)
xe Expr t (BaseBVType w)
ye -> do
      Term h
x  <- Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
xe
      Term h
y  <- Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
ye

      let w' :: Term h
w' = NatRepr w -> BV w -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> BV w
forall (w :: Nat). NatRepr w -> BV w
BV.width NatRepr w
w)
      Term h
y' <- SMTExpr h (BaseBVType w) -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase (SMTExpr h (BaseBVType w) -> Term h)
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h (BaseBVType w))
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (TypeMap (BaseBVType w)
-> Term h
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h (BaseBVType w))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (NatRepr w -> TypeMap (BaseBVType w)
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr w
w) (Term h
 -> ReaderT (SMTCollectorState t h) IO (SMTExpr h (BaseBVType w)))
-> Term h
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h (BaseBVType w))
forall a b. (a -> b) -> a -> b
$ Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
bvURem Term h
y Term h
w')

      let lo :: Term h
lo = Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
bvLshr Term h
x Term h
y'
      let hi :: Term h
hi = Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
bvShl Term h
x (Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
bvSub Term h
w' Term h
y')

      TypeMap (BaseBVType w)
-> Term h
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h (BaseBVType w))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (NatRepr w -> TypeMap (BaseBVType w)
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr w
w) (Term h
 -> ReaderT (SMTCollectorState t h) IO (SMTExpr h (BaseBVType w)))
-> Term h
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h (BaseBVType w))
forall a b. (a -> b) -> a -> b
$ Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
bvXor Term h
hi Term h
lo

    BVZext NatRepr r
w' Expr t (BaseBVType w)
xe -> do
      let w :: NatRepr w
w = Expr t (BaseBVType w) -> NatRepr w
forall (e :: BaseType -> Type) (w :: Nat).
IsExpr e =>
e (BaseBVType w) -> NatRepr w
bvWidth Expr t (BaseBVType w)
xe
      Term h
x <- Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
xe
      let n :: Integer
n = NatRepr r -> Integer
forall (w :: Nat). NatRepr w -> Integer
intValue NatRepr r
w' Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- NatRepr w -> Integer
forall (w :: Nat). NatRepr w -> Integer
intValue NatRepr w
w
      case Integer -> Maybe (Some NatRepr)
forall a. Integral a => a -> Maybe (Some NatRepr)
someNat Integer
n of
        Just (Some NatRepr x
w2) | Just LeqProof 1 r
LeqProof <- NatRepr r -> Maybe (LeqProof 1 r)
forall (n :: Nat). NatRepr n -> Maybe (LeqProof 1 n)
isPosNat NatRepr r
w' -> do
          let zeros :: Term h
zeros = NatRepr x -> BV x -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr x
w2 (NatRepr x -> BV x
forall (w :: Nat). NatRepr w -> BV w
BV.zero NatRepr x
w2)
          TypeMap (BaseBVType r)
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType r))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (NatRepr r -> TypeMap (BaseBVType r)
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr r
w') (Term h -> SMTCollector t h (SMTExpr h (BaseBVType r)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType r))
forall a b. (a -> b) -> a -> b
$ Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
bvConcat Term h
zeros Term h
x
        Maybe (Some NatRepr)
_ -> String -> SMTCollector t h (SMTExpr h tp)
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"invalid zero extension"

    BVSext NatRepr r
w' Expr t (BaseBVType w)
xe -> do
      let w :: NatRepr w
w = Expr t (BaseBVType w) -> NatRepr w
forall (e :: BaseType -> Type) (w :: Nat).
IsExpr e =>
e (BaseBVType w) -> NatRepr w
bvWidth Expr t (BaseBVType w)
xe
      Term h
x <- Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
xe
      let n :: Integer
n = NatRepr r -> Integer
forall (w :: Nat). NatRepr w -> Integer
intValue NatRepr r
w' Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- NatRepr w -> Integer
forall (w :: Nat). NatRepr w -> Integer
intValue NatRepr w
w
      case Integer -> Maybe (Some NatRepr)
forall a. Integral a => a -> Maybe (Some NatRepr)
someNat Integer
n of
        Just (Some NatRepr x
w2) | Just LeqProof 1 r
LeqProof <- NatRepr r -> Maybe (LeqProof 1 r)
forall (n :: Nat). NatRepr n -> Maybe (LeqProof 1 n)
isPosNat NatRepr r
w' -> do
          let zeros :: Term h
zeros = NatRepr x -> BV x -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr x
w2 (NatRepr x -> BV x
forall (w :: Nat). NatRepr w -> BV w
BV.zero NatRepr x
w2)
          let ones :: Term h
ones  = NatRepr x -> BV x -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr x
w2 (NatRepr x -> BV x
forall (w :: Nat). NatRepr w -> BV w
BV.maxUnsigned NatRepr x
w2)
          let sgn :: Term h
sgn = NatRepr w -> Natural -> Term h -> Term h
forall v (w :: Nat).
SupportTermOps v =>
NatRepr w -> Natural -> v -> v
bvTestBit NatRepr w
w (NatRepr w -> Natural
forall (n :: Nat). NatRepr n -> Natural
natValue NatRepr w
w Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1) Term h
x
          TypeMap (BaseBVType r)
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType r))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (NatRepr r -> TypeMap (BaseBVType r)
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr r
w') (Term h -> SMTCollector t h (SMTExpr h (BaseBVType r)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType r))
forall a b. (a -> b) -> a -> b
$ Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
bvConcat (Term h -> Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v -> v
ite Term h
sgn Term h
ones Term h
zeros) Term h
x
        Maybe (Some NatRepr)
_ -> String -> SMTCollector t h (SMTExpr h tp)
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"invalid sign extension"

    BVFill NatRepr w
w Expr t BaseBoolType
xe ->
      do Term h
x <- Expr t BaseBoolType -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseBoolType
xe
         let zeros :: Term h
zeros = NatRepr w -> BV w -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> BV w
forall (w :: Nat). NatRepr w -> BV w
BV.zero NatRepr w
w)
         let ones :: Term h
ones  = NatRepr w -> BV w -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> BV w
forall (w :: Nat). NatRepr w -> BV w
BV.maxUnsigned NatRepr w
w)
         TypeMap (BaseBVType w)
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType w))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (NatRepr w -> TypeMap (BaseBVType w)
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr w
w) (Term h -> SMTCollector t h (SMTExpr h (BaseBVType w)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType w))
forall a b. (a -> b) -> a -> b
$ Term h -> Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v -> v
ite Term h
x Term h
ones Term h
zeros

    BVPopcount NatRepr w
w Expr t (BaseBVType w)
xe ->
      do Term h
x <- Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
xe
         let zs :: [Term h]
zs = [ Term h -> Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v -> v
ite (NatRepr w -> Natural -> Term h -> Term h
forall v (w :: Nat).
SupportTermOps v =>
NatRepr w -> Natural -> v -> v
bvTestBit NatRepr w
w Natural
idx Term h
x) (NatRepr w -> BV w -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> BV w
forall (w :: Nat). (1 <= w) => NatRepr w -> BV w
BV.one NatRepr w
w)) (NatRepr w -> BV w -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> BV w
forall (w :: Nat). NatRepr w -> BV w
BV.zero NatRepr w
w))
                  | Natural
idx <- [ Natural
0 .. NatRepr w -> Natural
forall (n :: Nat). NatRepr n -> Natural
natValue NatRepr w
w Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1 ]
                  ]
         TypeMap (BaseBVType w)
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType w))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (NatRepr w -> TypeMap (BaseBVType w)
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr w
w) (Term h -> SMTCollector t h (SMTExpr h (BaseBVType w)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType w))
forall a b. (a -> b) -> a -> b
$! NatRepr w -> [Term h] -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> [v] -> v
bvSumExpr NatRepr w
w [Term h]
zs

    -- BGS: The mkBV call here shouldn't be necessary, but it is
    -- unless we use a NatRepr as the index
    BVCountLeadingZeros NatRepr w
w Expr t (BaseBVType w)
xe ->
      do Term h
x <- Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
xe
         TypeMap (BaseBVType w)
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType w))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (NatRepr w -> TypeMap (BaseBVType w)
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr w
w) (Term h -> SMTCollector t h (SMTExpr h (BaseBVType w)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType w))
forall a b. (a -> b) -> a -> b
$! Natural -> Term h -> Term h
go Natural
0 Term h
x
     where
     go :: Natural -> Term h -> Term h
go !Natural
idx Term h
x
       | Natural
idx Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
< NatRepr w -> Natural
forall (n :: Nat). NatRepr n -> Natural
natValue NatRepr w
w = Term h -> Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v -> v
ite (NatRepr w -> Natural -> Term h -> Term h
forall v (w :: Nat).
SupportTermOps v =>
NatRepr w -> Natural -> v -> v
bvTestBit NatRepr w
w (NatRepr w -> Natural
forall (n :: Nat). NatRepr n -> Natural
natValue NatRepr w
w Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
idx Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1) Term h
x) (NatRepr w -> BV w -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> Integer -> BV w
forall (w :: Nat). NatRepr w -> Integer -> BV w
BV.mkBV NatRepr w
w (Natural -> Integer
forall a. Integral a => a -> Integer
toInteger Natural
idx))) (Natural -> Term h -> Term h
go (Natural
idxNatural -> Natural -> Natural
forall a. Num a => a -> a -> a
+Natural
1) Term h
x)
       | Bool
otherwise = NatRepr w -> BV w -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> BV w
forall (w :: Nat). NatRepr w -> BV w
BV.width NatRepr w
w)

    -- BGS: The mkBV call here shouldn't be necessary, but it is
    -- unless we use a NatRepr as the index
    BVCountTrailingZeros NatRepr w
w Expr t (BaseBVType w)
xe ->
      do Term h
x <- Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
xe
         TypeMap (BaseBVType w)
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType w))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (NatRepr w -> TypeMap (BaseBVType w)
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr w
w) (Term h -> SMTCollector t h (SMTExpr h (BaseBVType w)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType w))
forall a b. (a -> b) -> a -> b
$! Natural -> Term h -> Term h
go Natural
0 Term h
x
     where
     go :: Natural -> Term h -> Term h
go !Natural
idx Term h
x
       | Natural
idx Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
< NatRepr w -> Natural
forall (n :: Nat). NatRepr n -> Natural
natValue NatRepr w
w = Term h -> Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v -> v
ite (NatRepr w -> Natural -> Term h -> Term h
forall v (w :: Nat).
SupportTermOps v =>
NatRepr w -> Natural -> v -> v
bvTestBit NatRepr w
w Natural
idx Term h
x) (NatRepr w -> BV w -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> Integer -> BV w
forall (w :: Nat). NatRepr w -> Integer -> BV w
BV.mkBV NatRepr w
w (Natural -> Integer
forall a. Integral a => a -> Integer
toInteger Natural
idx))) (Natural -> Term h -> Term h
go (Natural
idxNatural -> Natural -> Natural
forall a. Num a => a -> a -> a
+Natural
1) Term h
x)
       | Bool
otherwise = NatRepr w -> BV w -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> BV w
forall (w :: Nat). NatRepr w -> BV w
BV.width NatRepr w
w)

    ------------------------------------------
    -- String operations

    StringLength Expr t (BaseStringType si)
xe -> do
      case Expr t (BaseStringType si) -> StringInfoRepr si
forall (e :: BaseType -> Type) (si :: StringInfo).
IsExpr e =>
e (BaseStringType si) -> StringInfoRepr si
stringInfo Expr t (BaseStringType si)
xe of
        StringInfoRepr si
Char8Repr -> do
          Expr t tp -> ReaderT (SMTCollectorState t h) IO ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkStringSupport Expr t tp
i
          Term h
x <- Expr t (BaseStringType si)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseStringType si)
xe
          TypeMap BaseIntegerType
-> Term h -> SMTCollector t h (SMTExpr h BaseIntegerType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseIntegerType
IntegerTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseIntegerType))
-> Term h -> SMTCollector t h (SMTExpr h BaseIntegerType)
forall a b. (a -> b) -> a -> b
$ Term h -> Term h
forall h. SMTWriter h => Term h -> Term h
stringLength @h Term h
x
        StringInfoRepr si
si -> String -> SMTCollector t h (SMTExpr h tp)
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
"Unsupported symbolic string length operation " String -> String -> String
forall a. [a] -> [a] -> [a]
++  StringInfoRepr si -> String
forall a. Show a => a -> String
show StringInfoRepr si
si)

    StringIndexOf Expr t (BaseStringType si)
xe Expr t (BaseStringType si)
ye Expr t BaseIntegerType
ke ->
      case Expr t (BaseStringType si) -> StringInfoRepr si
forall (e :: BaseType -> Type) (si :: StringInfo).
IsExpr e =>
e (BaseStringType si) -> StringInfoRepr si
stringInfo Expr t (BaseStringType si)
xe of
        StringInfoRepr si
Char8Repr -> do
          Expr t tp -> ReaderT (SMTCollectorState t h) IO ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkStringSupport Expr t tp
i
          Term h
x <- Expr t (BaseStringType si)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseStringType si)
xe
          Term h
y <- Expr t (BaseStringType si)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseStringType si)
ye
          Term h
k <- Expr t BaseIntegerType
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseIntegerType
ke
          TypeMap BaseIntegerType
-> Term h -> SMTCollector t h (SMTExpr h BaseIntegerType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseIntegerType
IntegerTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseIntegerType))
-> Term h -> SMTCollector t h (SMTExpr h BaseIntegerType)
forall a b. (a -> b) -> a -> b
$ Term h -> Term h -> Term h -> Term h
forall h. SMTWriter h => Term h -> Term h -> Term h -> Term h
stringIndexOf @h Term h
x Term h
y Term h
k
        StringInfoRepr si
si -> String -> SMTCollector t h (SMTExpr h tp)
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
"Unsupported symbolic string index-of operation " String -> String -> String
forall a. [a] -> [a] -> [a]
++  StringInfoRepr si -> String
forall a. Show a => a -> String
show StringInfoRepr si
si)

    StringSubstring StringInfoRepr si
_ Expr t (BaseStringType si)
xe Expr t BaseIntegerType
offe Expr t BaseIntegerType
lene ->
      case Expr t (BaseStringType si) -> StringInfoRepr si
forall (e :: BaseType -> Type) (si :: StringInfo).
IsExpr e =>
e (BaseStringType si) -> StringInfoRepr si
stringInfo Expr t (BaseStringType si)
xe of
        StringInfoRepr si
Char8Repr -> do
          Expr t tp -> ReaderT (SMTCollectorState t h) IO ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkStringSupport Expr t tp
i
          Term h
x <- Expr t (BaseStringType si)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseStringType si)
xe
          Term h
off <- Expr t BaseIntegerType
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseIntegerType
offe
          Term h
len <- Expr t BaseIntegerType
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseIntegerType
lene
          TypeMap (BaseStringType Char8)
-> Term h -> SMTCollector t h (SMTExpr h (BaseStringType Char8))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap (BaseStringType Char8)
Char8TypeMap (Term h -> SMTCollector t h (SMTExpr h (BaseStringType Char8)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseStringType Char8))
forall a b. (a -> b) -> a -> b
$ Term h -> Term h -> Term h -> Term h
forall h. SMTWriter h => Term h -> Term h -> Term h -> Term h
stringSubstring @h Term h
x Term h
off Term h
len
        StringInfoRepr si
si -> String -> SMTCollector t h (SMTExpr h tp)
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
"Unsupported symbolic string substring operation " String -> String -> String
forall a. [a] -> [a] -> [a]
++  StringInfoRepr si -> String
forall a. Show a => a -> String
show StringInfoRepr si
si)

    StringContains Expr t (BaseStringType si)
xe Expr t (BaseStringType si)
ye ->
      case Expr t (BaseStringType si) -> StringInfoRepr si
forall (e :: BaseType -> Type) (si :: StringInfo).
IsExpr e =>
e (BaseStringType si) -> StringInfoRepr si
stringInfo Expr t (BaseStringType si)
xe of
        StringInfoRepr si
Char8Repr -> do
          Expr t tp -> ReaderT (SMTCollectorState t h) IO ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkStringSupport Expr t tp
i
          Term h
x <- Expr t (BaseStringType si)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseStringType si)
xe
          Term h
y <- Expr t (BaseStringType si)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseStringType si)
ye
          TypeMap BaseBoolType
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseBoolType))
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall a b. (a -> b) -> a -> b
$ Term h -> Term h -> Term h
forall h. SMTWriter h => Term h -> Term h -> Term h
stringContains @h Term h
x Term h
y
        StringInfoRepr si
si -> String -> SMTCollector t h (SMTExpr h tp)
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
"Unsupported symbolic string contains operation " String -> String -> String
forall a. [a] -> [a] -> [a]
++  StringInfoRepr si -> String
forall a. Show a => a -> String
show StringInfoRepr si
si)

    StringIsPrefixOf Expr t (BaseStringType si)
xe Expr t (BaseStringType si)
ye ->
      case Expr t (BaseStringType si) -> StringInfoRepr si
forall (e :: BaseType -> Type) (si :: StringInfo).
IsExpr e =>
e (BaseStringType si) -> StringInfoRepr si
stringInfo Expr t (BaseStringType si)
xe of
        StringInfoRepr si
Char8Repr -> do
          Expr t tp -> ReaderT (SMTCollectorState t h) IO ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkStringSupport Expr t tp
i
          Term h
x <- Expr t (BaseStringType si)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseStringType si)
xe
          Term h
y <- Expr t (BaseStringType si)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseStringType si)
ye
          TypeMap BaseBoolType
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseBoolType))
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall a b. (a -> b) -> a -> b
$ Term h -> Term h -> Term h
forall h. SMTWriter h => Term h -> Term h -> Term h
stringIsPrefixOf @h Term h
x Term h
y
        StringInfoRepr si
si -> String -> SMTCollector t h (SMTExpr h tp)
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
"Unsupported symbolic string is-prefix-of operation " String -> String -> String
forall a. [a] -> [a] -> [a]
++  StringInfoRepr si -> String
forall a. Show a => a -> String
show StringInfoRepr si
si)

    StringIsSuffixOf Expr t (BaseStringType si)
xe Expr t (BaseStringType si)
ye ->
      case Expr t (BaseStringType si) -> StringInfoRepr si
forall (e :: BaseType -> Type) (si :: StringInfo).
IsExpr e =>
e (BaseStringType si) -> StringInfoRepr si
stringInfo Expr t (BaseStringType si)
xe of
        StringInfoRepr si
Char8Repr -> do
          Expr t tp -> ReaderT (SMTCollectorState t h) IO ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkStringSupport Expr t tp
i
          Term h
x <- Expr t (BaseStringType si)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseStringType si)
xe
          Term h
y <- Expr t (BaseStringType si)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseStringType si)
ye
          TypeMap BaseBoolType
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseBoolType))
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall a b. (a -> b) -> a -> b
$ Term h -> Term h -> Term h
forall h. SMTWriter h => Term h -> Term h -> Term h
stringIsSuffixOf @h Term h
x Term h
y
        StringInfoRepr si
si -> String -> SMTCollector t h (SMTExpr h tp)
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
"Unsupported symbolic string is-suffix-of operation " String -> String -> String
forall a. [a] -> [a] -> [a]
++  StringInfoRepr si -> String
forall a. Show a => a -> String
show StringInfoRepr si
si)

    StringAppend StringInfoRepr si
si StringSeq (Expr t) si
xes ->
      case StringInfoRepr si
si of
        StringInfoRepr si
Char8Repr -> do
          Expr t tp -> ReaderT (SMTCollectorState t h) IO ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkStringSupport Expr t tp
i
          let f :: StringSeqEntry (Expr t) Char8
-> ReaderT (SMTCollectorState t h) IO (Term h)
f (SSeq.StringSeqLiteral StringLiteral Char8
l) = Term h -> ReaderT (SMTCollectorState t h) IO (Term h)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Term h -> ReaderT (SMTCollectorState t h) IO (Term h))
-> Term h -> ReaderT (SMTCollectorState t h) IO (Term h)
forall a b. (a -> b) -> a -> b
$ SMTWriter h => ByteString -> Term h
forall h. SMTWriter h => ByteString -> Term h
stringTerm @h (ByteString -> Term h) -> ByteString -> Term h
forall a b. (a -> b) -> a -> b
$ StringLiteral Char8 -> ByteString
fromChar8Lit StringLiteral Char8
l
              f (SSeq.StringSeqTerm Expr t (BaseStringType Char8)
t)    = Expr t (BaseStringType Char8)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseStringType Char8)
t
          [Term h]
xs <- (StringSeqEntry (Expr t) Char8
 -> ReaderT (SMTCollectorState t h) IO (Term h))
-> [StringSeqEntry (Expr t) Char8]
-> ReaderT (SMTCollectorState t h) IO [Term h]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM StringSeqEntry (Expr t) Char8
-> ReaderT (SMTCollectorState t h) IO (Term h)
f ([StringSeqEntry (Expr t) Char8]
 -> ReaderT (SMTCollectorState t h) IO [Term h])
-> [StringSeqEntry (Expr t) Char8]
-> ReaderT (SMTCollectorState t h) IO [Term h]
forall a b. (a -> b) -> a -> b
$ StringSeq (Expr t) si -> [StringSeqEntry (Expr t) si]
forall (e :: BaseType -> Type) (si :: StringInfo).
StringSeq e si -> [StringSeqEntry e si]
SSeq.toList StringSeq (Expr t) si
xes
          TypeMap (BaseStringType Char8)
-> Term h -> SMTCollector t h (SMTExpr h (BaseStringType Char8))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap (BaseStringType Char8)
Char8TypeMap (Term h -> SMTCollector t h (SMTExpr h (BaseStringType Char8)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseStringType Char8))
forall a b. (a -> b) -> a -> b
$ [Term h] -> Term h
forall h. SMTWriter h => [Term h] -> Term h
stringAppend @h [Term h]
xs

        StringInfoRepr si
_ -> String -> SMTCollector t h (SMTExpr h tp)
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
"Unsupported symbolic string append operation " String -> String -> String
forall a. [a] -> [a] -> [a]
++  StringInfoRepr si -> String
forall a. Show a => a -> String
show StringInfoRepr si
si)

    ------------------------------------------
    -- Floating-point operations

    FloatNeg FloatPrecisionRepr fpp
fpp Expr t (BaseFloatType fpp)
x -> do
      Term h
xe <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      TypeMap (BaseFloatType fpp)
-> Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
forall (fpp :: FloatPrecision).
FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
FloatTypeMap FloatPrecisionRepr fpp
fpp) (Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp))
forall a b. (a -> b) -> a -> b
$ Term h -> Term h
forall v. SupportTermOps v => v -> v
floatNeg Term h
xe
    FloatAbs FloatPrecisionRepr fpp
fpp Expr t (BaseFloatType fpp)
x -> do
      Term h
xe <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      TypeMap (BaseFloatType fpp)
-> Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
forall (fpp :: FloatPrecision).
FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
FloatTypeMap FloatPrecisionRepr fpp
fpp) (Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp))
forall a b. (a -> b) -> a -> b
$ Term h -> Term h
forall v. SupportTermOps v => v -> v
floatAbs Term h
xe
    FloatSqrt FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t (BaseFloatType fpp)
x -> do
      Term h
xe <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      TypeMap (BaseFloatType fpp)
-> Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
forall (fpp :: FloatPrecision).
FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
FloatTypeMap FloatPrecisionRepr fpp
fpp) (Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp))
forall a b. (a -> b) -> a -> b
$ RoundingMode -> Term h -> Term h
forall v. SupportTermOps v => RoundingMode -> v -> v
floatSqrt RoundingMode
r Term h
xe
    FloatAdd FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t (BaseFloatType fpp)
x Expr t (BaseFloatType fpp)
y -> do
      Term h
xe <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      Term h
ye <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
y
      TypeMap (BaseFloatType fpp)
-> Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
forall (fpp :: FloatPrecision).
FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
FloatTypeMap FloatPrecisionRepr fpp
fpp) (Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp))
forall a b. (a -> b) -> a -> b
$ RoundingMode -> Term h -> Term h -> Term h
forall v. SupportTermOps v => RoundingMode -> v -> v -> v
floatAdd RoundingMode
r Term h
xe Term h
ye
    FloatSub FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t (BaseFloatType fpp)
x Expr t (BaseFloatType fpp)
y -> do
      Term h
xe <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      Term h
ye <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
y
      TypeMap (BaseFloatType fpp)
-> Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
forall (fpp :: FloatPrecision).
FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
FloatTypeMap FloatPrecisionRepr fpp
fpp) (Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp))
forall a b. (a -> b) -> a -> b
$ RoundingMode -> Term h -> Term h -> Term h
forall v. SupportTermOps v => RoundingMode -> v -> v -> v
floatSub RoundingMode
r Term h
xe Term h
ye
    FloatMul FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t (BaseFloatType fpp)
x Expr t (BaseFloatType fpp)
y -> do
      Term h
xe <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      Term h
ye <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
y
      TypeMap (BaseFloatType fpp)
-> Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
forall (fpp :: FloatPrecision).
FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
FloatTypeMap FloatPrecisionRepr fpp
fpp) (Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp))
forall a b. (a -> b) -> a -> b
$ RoundingMode -> Term h -> Term h -> Term h
forall v. SupportTermOps v => RoundingMode -> v -> v -> v
floatMul RoundingMode
r Term h
xe Term h
ye
    FloatDiv FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t (BaseFloatType fpp)
x Expr t (BaseFloatType fpp)
y -> do
      Term h
xe <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      Term h
ye <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
y
      TypeMap (BaseFloatType fpp)
-> Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
forall (fpp :: FloatPrecision).
FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
FloatTypeMap FloatPrecisionRepr fpp
fpp) (Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp))
forall a b. (a -> b) -> a -> b
$ RoundingMode -> Term h -> Term h -> Term h
forall v. SupportTermOps v => RoundingMode -> v -> v -> v
floatDiv RoundingMode
r Term h
xe Term h
ye
    FloatRem FloatPrecisionRepr fpp
fpp Expr t (BaseFloatType fpp)
x Expr t (BaseFloatType fpp)
y -> do
      Term h
xe <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      Term h
ye <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
y
      TypeMap (BaseFloatType fpp)
-> Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
forall (fpp :: FloatPrecision).
FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
FloatTypeMap FloatPrecisionRepr fpp
fpp) (Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp))
forall a b. (a -> b) -> a -> b
$ Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
floatRem Term h
xe Term h
ye
    FloatFMA FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t (BaseFloatType fpp)
x Expr t (BaseFloatType fpp)
y Expr t (BaseFloatType fpp)
z -> do
      Term h
xe <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      Term h
ye <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
y
      Term h
ze <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
z
      TypeMap (BaseFloatType fpp)
-> Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
forall (fpp :: FloatPrecision).
FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
FloatTypeMap FloatPrecisionRepr fpp
fpp) (Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp))
forall a b. (a -> b) -> a -> b
$ RoundingMode -> Term h -> Term h -> Term h -> Term h
forall v. SupportTermOps v => RoundingMode -> v -> v -> v -> v
floatFMA RoundingMode
r Term h
xe Term h
ye Term h
ze
    FloatFpEq Expr t (BaseFloatType fpp)
x Expr t (BaseFloatType fpp)
y -> do
      Term h
xe <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      Term h
ye <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
y
      TypeMap BaseBoolType
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseBoolType))
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall a b. (a -> b) -> a -> b
$ Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
floatFpEq Term h
xe Term h
ye
    FloatLe Expr t (BaseFloatType fpp)
x Expr t (BaseFloatType fpp)
y -> do
      Term h
xe <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      Term h
ye <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
y
      TypeMap BaseBoolType
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseBoolType))
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall a b. (a -> b) -> a -> b
$ Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
floatLe Term h
xe Term h
ye
    FloatLt Expr t (BaseFloatType fpp)
x Expr t (BaseFloatType fpp)
y -> do
      Term h
xe <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      Term h
ye <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
y
      TypeMap BaseBoolType
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseBoolType))
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall a b. (a -> b) -> a -> b
$ Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
floatLt Term h
xe Term h
ye
    FloatIsNaN Expr t (BaseFloatType fpp)
x -> do
      Term h
xe <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      TypeMap BaseBoolType
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseBoolType))
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall a b. (a -> b) -> a -> b
$ Term h -> Term h
forall v. SupportTermOps v => v -> v
floatIsNaN Term h
xe
    FloatIsInf Expr t (BaseFloatType fpp)
x -> do
      Term h
xe <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      TypeMap BaseBoolType
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseBoolType))
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall a b. (a -> b) -> a -> b
$ Term h -> Term h
forall v. SupportTermOps v => v -> v
floatIsInf Term h
xe
    FloatIsZero Expr t (BaseFloatType fpp)
x -> do
      Term h
xe <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      TypeMap BaseBoolType
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseBoolType))
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall a b. (a -> b) -> a -> b
$ Term h -> Term h
forall v. SupportTermOps v => v -> v
floatIsZero Term h
xe
    FloatIsPos Expr t (BaseFloatType fpp)
x -> do
      Term h
xe <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      TypeMap BaseBoolType
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseBoolType))
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall a b. (a -> b) -> a -> b
$ Term h -> Term h
forall v. SupportTermOps v => v -> v
floatIsPos Term h
xe
    FloatIsNeg Expr t (BaseFloatType fpp)
x -> do
      Term h
xe <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      TypeMap BaseBoolType
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseBoolType))
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall a b. (a -> b) -> a -> b
$ Term h -> Term h
forall v. SupportTermOps v => v -> v
floatIsNeg Term h
xe
    FloatIsSubnorm Expr t (BaseFloatType fpp)
x -> do
      Term h
xe <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      TypeMap BaseBoolType
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseBoolType))
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall a b. (a -> b) -> a -> b
$ Term h -> Term h
forall v. SupportTermOps v => v -> v
floatIsSubnorm Term h
xe
    FloatIsNorm Expr t (BaseFloatType fpp)
x -> do
      Term h
xe <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      TypeMap BaseBoolType
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseBoolType))
-> Term h -> SMTCollector t h (SMTExpr h BaseBoolType)
forall a b. (a -> b) -> a -> b
$ Term h -> Term h
forall v. SupportTermOps v => v -> v
floatIsNorm Term h
xe
    FloatCast FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t (BaseFloatType fpp')
x -> do
      Term h
xe <- Expr t (BaseFloatType fpp')
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp')
x
      TypeMap (BaseFloatType fpp)
-> Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
forall (fpp :: FloatPrecision).
FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
FloatTypeMap FloatPrecisionRepr fpp
fpp) (Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp))
forall a b. (a -> b) -> a -> b
$
        FloatPrecisionRepr fpp -> RoundingMode -> Term h -> Term h
forall v (fpp :: FloatPrecision).
SupportTermOps v =>
FloatPrecisionRepr fpp -> RoundingMode -> v -> v
floatCast FloatPrecisionRepr fpp
fpp RoundingMode
r Term h
xe
    FloatRound FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t (BaseFloatType fpp)
x -> do
      Term h
xe <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      TypeMap (BaseFloatType fpp)
-> Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
forall (fpp :: FloatPrecision).
FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
FloatTypeMap FloatPrecisionRepr fpp
fpp)(Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp))
forall a b. (a -> b) -> a -> b
$ RoundingMode -> Term h -> Term h
forall v. SupportTermOps v => RoundingMode -> v -> v
floatRound RoundingMode
r Term h
xe
    FloatToBinary fpp :: FloatPrecisionRepr (FloatingPointPrecision eb sb)
fpp@(FloatingPointPrecisionRepr NatRepr eb
eb NatRepr sb
sb) Expr t (BaseFloatType (FloatingPointPrecision eb sb))
x -> do
      Term h
xe <- Expr t (BaseFloatType (FloatingPointPrecision eb sb))
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType (FloatingPointPrecision eb sb))
x
      Term h
val <- SMTExpr h (BaseBVType (eb + sb)) -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase (SMTExpr h (BaseBVType (eb + sb)) -> Term h)
-> ReaderT
     (SMTCollectorState t h) IO (SMTExpr h (BaseBVType (eb + sb)))
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (String
-> TypeMap (BaseBVType (eb + sb))
-> ReaderT
     (SMTCollectorState t h) IO (SMTExpr h (BaseBVType (eb + sb)))
forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
"float_binary" (TypeMap (BaseBVType (eb + sb))
 -> ReaderT
      (SMTCollectorState t h) IO (SMTExpr h (BaseBVType (eb + sb))))
-> TypeMap (BaseBVType (eb + sb))
-> ReaderT
     (SMTCollectorState t h) IO (SMTExpr h (BaseBVType (eb + sb)))
forall a b. (a -> b) -> a -> b
$ NatRepr (eb + sb) -> TypeMap (BaseBVType (eb + sb))
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap (NatRepr (eb + sb) -> TypeMap (BaseBVType (eb + sb)))
-> NatRepr (eb + sb) -> TypeMap (BaseBVType (eb + sb))
forall a b. (a -> b) -> a -> b
$ NatRepr eb -> NatRepr sb -> NatRepr (eb + sb)
forall (m :: Nat) (n :: Nat).
NatRepr m -> NatRepr n -> NatRepr (m + n)
addNat NatRepr eb
eb NatRepr sb
sb)
      -- (assert (= ((_ to_fp eb sb) val) xe))
      String -> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"float_binary" (Term h -> ReaderT (SMTCollectorState t h) IO ())
-> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall a b. (a -> b) -> a -> b
$
        FloatPrecisionRepr (FloatingPointPrecision eb sb)
-> Term h -> Term h
forall v (fpp :: FloatPrecision).
SupportTermOps v =>
FloatPrecisionRepr fpp -> v -> v
floatFromBinary FloatPrecisionRepr (FloatingPointPrecision eb sb)
fpp Term h
val Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.== Term h
xe
      -- qnan: 0b0 0b1..1 0b10..0
      -- BGS: I tried using bv-sized primitives for this and it would
      -- have required a lot of proofs. Probable worth revisiting this.
      let qnan :: Term h
qnan = NatRepr (eb + sb) -> BV (eb + sb) -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm (NatRepr eb -> NatRepr sb -> NatRepr (eb + sb)
forall (m :: Nat) (n :: Nat).
NatRepr m -> NatRepr n -> NatRepr (m + n)
addNat NatRepr eb
eb NatRepr sb
sb) (BV (eb + sb) -> Term h) -> BV (eb + sb) -> Term h
forall a b. (a -> b) -> a -> b
$
                 NatRepr (eb + sb) -> Integer -> BV (eb + sb)
forall (w :: Nat). NatRepr w -> Integer -> BV w
BV.mkBV (NatRepr eb -> NatRepr sb -> NatRepr (eb + sb)
forall (m :: Nat) (n :: Nat).
NatRepr m -> NatRepr n -> NatRepr (m + n)
addNat NatRepr eb
eb NatRepr sb
sb) (Integer -> BV (eb + sb)) -> Integer -> BV (eb + sb)
forall a b. (a -> b) -> a -> b
$
                 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
Bits.shiftL
                  (Integer
2 Integer -> Natural -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (NatRepr eb -> Natural
forall (n :: Nat). NatRepr n -> Natural
natValue NatRepr eb
eb Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1)
                  (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (NatRepr sb -> Natural
forall (n :: Nat). NatRepr n -> Natural
natValue NatRepr sb
sb Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
2))
      TypeMap (BaseBVType (eb + sb))
-> Term h
-> ReaderT
     (SMTCollectorState t h) IO (SMTExpr h (BaseBVType (eb + sb)))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (NatRepr (eb + sb) -> TypeMap (BaseBVType (eb + sb))
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap (NatRepr (eb + sb) -> TypeMap (BaseBVType (eb + sb)))
-> NatRepr (eb + sb) -> TypeMap (BaseBVType (eb + sb))
forall a b. (a -> b) -> a -> b
$ NatRepr eb -> NatRepr sb -> NatRepr (eb + sb)
forall (m :: Nat) (n :: Nat).
NatRepr m -> NatRepr n -> NatRepr (m + n)
addNat NatRepr eb
eb NatRepr sb
sb) (Term h
 -> ReaderT
      (SMTCollectorState t h) IO (SMTExpr h (BaseBVType (eb + sb))))
-> Term h
-> ReaderT
     (SMTCollectorState t h) IO (SMTExpr h (BaseBVType (eb + sb)))
forall a b. (a -> b) -> a -> b
$ Term h -> Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v -> v
ite (Term h -> Term h
forall v. SupportTermOps v => v -> v
floatIsNaN Term h
xe) Term h
qnan Term h
val
    FloatFromBinary FloatPrecisionRepr (FloatingPointPrecision eb sb)
fpp Expr t (BaseBVType (eb + sb))
x -> do
      Term h
xe <- Expr t (BaseBVType (eb + sb))
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType (eb + sb))
x
      TypeMap (BaseFloatType (FloatingPointPrecision eb sb))
-> Term h
-> SMTCollector
     t h (SMTExpr h (BaseFloatType (FloatingPointPrecision eb sb)))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (FloatPrecisionRepr (FloatingPointPrecision eb sb)
-> TypeMap (BaseFloatType (FloatingPointPrecision eb sb))
forall (fpp :: FloatPrecision).
FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
FloatTypeMap FloatPrecisionRepr (FloatingPointPrecision eb sb)
fpp) (Term h
 -> SMTCollector
      t h (SMTExpr h (BaseFloatType (FloatingPointPrecision eb sb))))
-> Term h
-> SMTCollector
     t h (SMTExpr h (BaseFloatType (FloatingPointPrecision eb sb)))
forall a b. (a -> b) -> a -> b
$
        FloatPrecisionRepr (FloatingPointPrecision eb sb)
-> Term h -> Term h
forall v (fpp :: FloatPrecision).
SupportTermOps v =>
FloatPrecisionRepr fpp -> v -> v
floatFromBinary FloatPrecisionRepr (FloatingPointPrecision eb sb)
fpp Term h
xe
    BVToFloat FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t (BaseBVType w)
x -> do
      Term h
xe <- Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
x
      TypeMap (BaseFloatType fpp)
-> Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
forall (fpp :: FloatPrecision).
FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
FloatTypeMap FloatPrecisionRepr fpp
fpp) (Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp))
forall a b. (a -> b) -> a -> b
$
        FloatPrecisionRepr fpp -> RoundingMode -> Term h -> Term h
forall v (fpp :: FloatPrecision).
SupportTermOps v =>
FloatPrecisionRepr fpp -> RoundingMode -> v -> v
bvToFloat FloatPrecisionRepr fpp
fpp RoundingMode
r Term h
xe
    SBVToFloat FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t (BaseBVType w)
x -> do
      Term h
xe <- Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
x
      TypeMap (BaseFloatType fpp)
-> Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
forall (fpp :: FloatPrecision).
FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
FloatTypeMap FloatPrecisionRepr fpp
fpp) (Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp))
forall a b. (a -> b) -> a -> b
$
        FloatPrecisionRepr fpp -> RoundingMode -> Term h -> Term h
forall v (fpp :: FloatPrecision).
SupportTermOps v =>
FloatPrecisionRepr fpp -> RoundingMode -> v -> v
sbvToFloat FloatPrecisionRepr fpp
fpp RoundingMode
r Term h
xe
    RealToFloat FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t BaseRealType
x -> do
      Term h
xe <- Expr t BaseRealType -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseRealType
x
      TypeMap (BaseFloatType fpp)
-> Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
forall (fpp :: FloatPrecision).
FloatPrecisionRepr fpp -> TypeMap (BaseFloatType fpp)
FloatTypeMap FloatPrecisionRepr fpp
fpp) (Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseFloatType fpp))
forall a b. (a -> b) -> a -> b
$
        FloatPrecisionRepr fpp -> RoundingMode -> Term h -> Term h
forall v (fpp :: FloatPrecision).
SupportTermOps v =>
FloatPrecisionRepr fpp -> RoundingMode -> v -> v
realToFloat FloatPrecisionRepr fpp
fpp RoundingMode
r Term h
xe
    FloatToBV NatRepr w
w RoundingMode
r Expr t (BaseFloatType fpp)
x -> do
      Term h
xe <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      TypeMap (BaseBVType w)
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType w))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (NatRepr w -> TypeMap (BaseBVType w)
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr w
w) (Term h -> SMTCollector t h (SMTExpr h (BaseBVType w)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType w))
forall a b. (a -> b) -> a -> b
$ Natural -> RoundingMode -> Term h -> Term h
forall v. SupportTermOps v => Natural -> RoundingMode -> v -> v
floatToBV (NatRepr w -> Natural
forall (n :: Nat). NatRepr n -> Natural
natValue NatRepr w
w) RoundingMode
r Term h
xe
    FloatToSBV NatRepr w
w RoundingMode
r Expr t (BaseFloatType fpp)
x -> do
      Term h
xe <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      TypeMap (BaseBVType w)
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType w))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (NatRepr w -> TypeMap (BaseBVType w)
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr w
w) (Term h -> SMTCollector t h (SMTExpr h (BaseBVType w)))
-> Term h -> SMTCollector t h (SMTExpr h (BaseBVType w))
forall a b. (a -> b) -> a -> b
$ Natural -> RoundingMode -> Term h -> Term h
forall v. SupportTermOps v => Natural -> RoundingMode -> v -> v
floatToSBV (NatRepr w -> Natural
forall (n :: Nat). NatRepr n -> Natural
natValue NatRepr w
w) RoundingMode
r Term h
xe
    FloatToReal Expr t (BaseFloatType fpp)
x -> do
      Term h
xe <- Expr t (BaseFloatType fpp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      TypeMap BaseRealType
-> Term h -> SMTCollector t h (SMTExpr h BaseRealType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseRealType
RealTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseRealType))
-> Term h -> SMTCollector t h (SMTExpr h BaseRealType)
forall a b. (a -> b) -> a -> b
$ Term h -> Term h
forall v. SupportTermOps v => v -> v
floatToReal Term h
xe

    ------------------------------------------------------------------------
    -- Array Operations

    ArrayMap Assignment BaseTypeRepr (i ::> itp)
_ BaseTypeRepr tp
_ ArrayUpdateMap (Expr t) (i ::> itp) tp
elts Expr t (BaseArrayType (i ::> itp) tp)
def -> do
      SMTExpr h (BaseArrayType (i ::> itp) tp)
base_array <- Expr t (BaseArrayType (i ::> itp) tp)
-> SMTCollector t h (SMTExpr h (BaseArrayType (i ::> itp) tp))
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t (BaseArrayType (i ::> itp) tp)
def
      [(Assignment IndexLit (i ::> itp), Term h)]
elt_exprs <- (((Assignment IndexLit (i ::> itp), Expr t tp)
 -> ReaderT
      (SMTCollectorState t h)
      IO
      (Assignment IndexLit (i ::> itp), Term h))
-> [(Assignment IndexLit (i ::> itp), Expr t tp)]
-> ReaderT
     (SMTCollectorState t h)
     IO
     [(Assignment IndexLit (i ::> itp), Term h)]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse(((Assignment IndexLit (i ::> itp), Expr t tp)
  -> ReaderT
       (SMTCollectorState t h)
       IO
       (Assignment IndexLit (i ::> itp), Term h))
 -> [(Assignment IndexLit (i ::> itp), Expr t tp)]
 -> ReaderT
      (SMTCollectorState t h)
      IO
      [(Assignment IndexLit (i ::> itp), Term h)])
-> ((Expr t tp -> ReaderT (SMTCollectorState t h) IO (Term h))
    -> (Assignment IndexLit (i ::> itp), Expr t tp)
    -> ReaderT
         (SMTCollectorState t h)
         IO
         (Assignment IndexLit (i ::> itp), Term h))
-> (Expr t tp -> ReaderT (SMTCollectorState t h) IO (Term h))
-> [(Assignment IndexLit (i ::> itp), Expr t tp)]
-> ReaderT
     (SMTCollectorState t h)
     IO
     [(Assignment IndexLit (i ::> itp), Term h)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Expr t tp -> ReaderT (SMTCollectorState t h) IO (Term h))
-> (Assignment IndexLit (i ::> itp), Expr t tp)
-> ReaderT
     (SMTCollectorState t h)
     IO
     (Assignment IndexLit (i ::> itp), Term h)
forall s t a b. Field2 s t a b => Lens s t a b
_2) Expr t tp -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr (ArrayUpdateMap (Expr t) (i ::> itp) tp
-> [(Assignment IndexLit (i ::> itp), Expr t tp)]
forall (e :: BaseType -> Type) (ctx :: Ctx BaseType)
       (tp :: BaseType).
ArrayUpdateMap e ctx tp -> [(Assignment IndexLit ctx, e tp)]
AUM.toList ArrayUpdateMap (Expr t) (i ::> itp) tp
elts)
      let array_type :: TypeMap (BaseArrayType (i ::> itp) tp)
array_type = SMTExpr h (BaseArrayType (i ::> itp) tp)
-> TypeMap (BaseArrayType (i ::> itp) tp)
forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h (BaseArrayType (i ::> itp) tp)
base_array
      case TypeMap (BaseArrayType (i ::> itp) tp)
array_type of
        PrimArrayTypeMap{} -> do
          let set_at_index :: Term h
                           -> (Ctx.Assignment IndexLit ctx, Term h)
                           -> Term h
              set_at_index :: Term h -> (Assignment IndexLit ctx, Term h) -> Term h
set_at_index Term h
ma (Assignment IndexLit ctx
idx, Term h
elt) =
                Term h -> [Term h] -> Term h -> Term h
forall h. SMTWriter h => Term h -> [Term h] -> Term h -> Term h
arrayUpdate @h Term h
ma (Assignment IndexLit ctx -> [Term h]
forall v (ctx :: Ctx BaseType).
SupportTermOps v =>
Assignment IndexLit ctx -> [v]
mkIndexLitTerms Assignment IndexLit ctx
idx) Term h
elt
          TypeMap (BaseArrayType (i ::> itp) tp)
-> Term h
-> SMTCollector t h (SMTExpr h (BaseArrayType (i ::> itp) tp))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap (BaseArrayType (i ::> itp) tp)
array_type (Term h
 -> SMTCollector t h (SMTExpr h (BaseArrayType (i ::> itp) tp)))
-> Term h
-> SMTCollector t h (SMTExpr h (BaseArrayType (i ::> itp) tp))
forall a b. (a -> b) -> a -> b
$
            (Term h -> (Assignment IndexLit (i ::> itp), Term h) -> Term h)
-> Term h -> [(Assignment IndexLit (i ::> itp), Term h)] -> Term h
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Term h -> (Assignment IndexLit (i ::> itp), Term h) -> Term h
forall (ctx :: Ctx BaseType).
Term h -> (Assignment IndexLit ctx, Term h) -> Term h
set_at_index (SMTExpr h (BaseArrayType (i ::> itp) tp) -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h (BaseArrayType (i ::> itp) tp)
base_array) [(Assignment IndexLit (i ::> itp), Term h)]
elt_exprs

        FnArrayTypeMap Assignment TypeMap (idxl ::> idx)
idx_types TypeMap tp
resType -> do
          case Maybe (Term h -> [Term h] -> Term h -> Term h)
forall v. SupportTermOps v => Maybe (v -> [v] -> v -> v)
smtFnUpdate of
            Just Term h -> [Term h] -> Term h -> Term h
updateFn -> do

              let set_at_index :: Term h
                               -> (Ctx.Assignment IndexLit ctx, Term h)
                               -> Term h
                  set_at_index :: Term h -> (Assignment IndexLit ctx, Term h) -> Term h
set_at_index Term h
ma (Assignment IndexLit ctx
idx, Term h
elt) =
                    Term h -> [Term h] -> Term h -> Term h
updateFn Term h
ma ((forall (x :: BaseType). IndexLit x -> Term h)
-> Assignment IndexLit ctx -> [Term h]
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type) a.
FoldableFC t =>
(forall (x :: k). f x -> a) -> forall (x :: l). t f x -> [a]
toListFC forall v (tp :: BaseType). SupportTermOps v => IndexLit tp -> v
forall (x :: BaseType). IndexLit x -> Term h
mkIndexLitTerm Assignment IndexLit ctx
idx) Term h
elt
              TypeMap (BaseArrayType (i ::> itp) tp)
-> Term h
-> SMTCollector t h (SMTExpr h (BaseArrayType (i ::> itp) tp))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap (BaseArrayType (i ::> itp) tp)
array_type (Term h
 -> SMTCollector t h (SMTExpr h (BaseArrayType (i ::> itp) tp)))
-> Term h
-> SMTCollector t h (SMTExpr h (BaseArrayType (i ::> itp) tp))
forall a b. (a -> b) -> a -> b
$
                (Term h -> (Assignment IndexLit (i ::> itp), Term h) -> Term h)
-> Term h -> [(Assignment IndexLit (i ::> itp), Term h)] -> Term h
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Term h -> (Assignment IndexLit (i ::> itp), Term h) -> Term h
forall (ctx :: Ctx BaseType).
Term h -> (Assignment IndexLit ctx, Term h) -> Term h
set_at_index (SMTExpr h (BaseArrayType (i ::> itp) tp) -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h (BaseArrayType (i ::> itp) tp)
base_array) [(Assignment IndexLit (i ::> itp), Term h)]
elt_exprs
            Maybe (Term h -> [Term h] -> Term h -> Term h)
Nothing -> do
              -- Supporting arrays as functons requires that we can create
              -- function definitions.
              Bool
-> ReaderT (SMTCollectorState t h) IO ()
-> ReaderT (SMTCollectorState t h) IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (WriterConn t h -> Bool
forall t h. WriterConn t h -> Bool
supportFunctionDefs WriterConn t h
conn)) (ReaderT (SMTCollectorState t h) IO ()
 -> ReaderT (SMTCollectorState t h) IO ())
-> ReaderT (SMTCollectorState t h) IO ()
-> ReaderT (SMTCollectorState t h) IO ()
forall a b. (a -> b) -> a -> b
$ do
                String -> ReaderT (SMTCollectorState t h) IO ()
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> ReaderT (SMTCollectorState t h) IO ())
-> String -> ReaderT (SMTCollectorState t h) IO ()
forall a b. (a -> b) -> a -> b
$ Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String) -> Doc Any -> String
forall a b. (a -> b) -> a -> b
$ String -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty (WriterConn t h -> String
forall t h. WriterConn t h -> String
smtWriterName WriterConn t h
conn) Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
                  Doc Any
"does not support arrays as functions."
              -- Create names for index variables.
              [(Text, Some TypeMap)]
args <- IO [(Text, Some TypeMap)]
-> ReaderT (SMTCollectorState t h) IO [(Text, Some TypeMap)]
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO [(Text, Some TypeMap)]
 -> ReaderT (SMTCollectorState t h) IO [(Text, Some TypeMap)])
-> IO [(Text, Some TypeMap)]
-> ReaderT (SMTCollectorState t h) IO [(Text, Some TypeMap)]
forall a b. (a -> b) -> a -> b
$ WriterConn t h
-> Assignment TypeMap (idxl ::> idx) -> IO [(Text, Some TypeMap)]
forall t h (args :: Ctx BaseType).
WriterConn t h
-> Assignment TypeMap args -> IO [(Text, Some TypeMap)]
createTypeMapArgsForArray WriterConn t h
conn Assignment TypeMap (idxl ::> idx)
idx_types
              -- Get list of terms for arguments.
              let idx_terms :: [Term h]
idx_terms = Text -> Term h
forall v. SupportTermOps v => Text -> v
fromText (Text -> Term h)
-> ((Text, Some TypeMap) -> Text) -> (Text, Some TypeMap) -> Term h
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Some TypeMap) -> Text
forall a b. (a, b) -> a
fst ((Text, Some TypeMap) -> Term h)
-> [(Text, Some TypeMap)] -> [Term h]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Some TypeMap)]
args
              -- Return value at index in base_array.
              let base_lookup :: Term h
base_lookup = Term h -> [Term h] -> Term h
forall v. SupportTermOps v => v -> [v] -> v
smtFnApp (SMTExpr h (BaseArrayType (i ::> itp) tp) -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h (BaseArrayType (i ::> itp) tp)
base_array) [Term h]
idx_terms
              -- Return if-then-else structure for next elements.
              let set_at_index :: Term h -> (Assignment IndexLit (i ::> itp), Term h) -> Term h
set_at_index Term h
prev_value (Assignment IndexLit (i ::> itp)
idx_lits, Term h
elt) =
                    let update_idx :: [Term h]
update_idx = (forall (x :: BaseType). IndexLit x -> Term h)
-> Assignment IndexLit (i ::> itp) -> [Term h]
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type) a.
FoldableFC t =>
(forall (x :: k). f x -> a) -> forall (x :: l). t f x -> [a]
toListFC forall v (tp :: BaseType). SupportTermOps v => IndexLit tp -> v
forall (x :: BaseType). IndexLit x -> Term h
mkIndexLitTerm Assignment IndexLit (i ::> itp)
idx_lits
                        cond :: Term h
cond = [Term h] -> Term h
forall v. SupportTermOps v => [v] -> v
andAll ((Term h -> Term h -> Term h) -> [Term h] -> [Term h] -> [Term h]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
(.==) [Term h]
update_idx [Term h]
idx_terms)
                     in Term h -> Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v -> v
ite Term h
cond Term h
elt Term h
prev_value
              -- Get final expression for definition.
              let expr :: Term h
expr = (Term h -> (Assignment IndexLit (i ::> itp), Term h) -> Term h)
-> Term h -> [(Assignment IndexLit (i ::> itp), Term h)] -> Term h
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Term h -> (Assignment IndexLit (i ::> itp), Term h) -> Term h
set_at_index Term h
base_lookup [(Assignment IndexLit (i ::> itp), Term h)]
elt_exprs
              -- Add command
              TypeMap (BaseArrayType (i ::> itp) tp)
-> Text -> SMTExpr h (BaseArrayType (i ::> itp) tp)
forall (tp :: BaseType) h. TypeMap tp -> Text -> SMTExpr h tp
SMTName TypeMap (BaseArrayType (i ::> itp) tp)
array_type (Text -> SMTExpr h (BaseArrayType (i ::> itp) tp))
-> ReaderT (SMTCollectorState t h) IO Text
-> SMTCollector t h (SMTExpr h (BaseArrayType (i ::> itp) tp))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Some TypeMap)]
-> TypeMap tp -> Term h -> ReaderT (SMTCollectorState t h) IO Text
forall (rtp :: BaseType) h t.
[(Text, Some TypeMap)]
-> TypeMap rtp -> Term h -> SMTCollector t h Text
freshBoundFn [(Text, Some TypeMap)]
args TypeMap tp
resType Term h
expr

    ConstantArray Assignment BaseTypeRepr (i ::> tp)
idxRepr BaseTypeRepr b
_bRepr Expr t b
ve -> do
      SMTExpr h b
v <- Expr t b -> SMTCollector t h (SMTExpr h b)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t b
ve
      let value_type :: TypeMap b
value_type = SMTExpr h b -> TypeMap b
forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h b
v
          feat :: ProblemFeatures
feat = WriterConn t h -> ProblemFeatures
forall t h. WriterConn t h -> ProblemFeatures
supportedFeatures WriterConn t h
conn
          mkArray :: Assignment TypeMap (i ::> tp)
-> TypeMap b -> TypeMap (BaseArrayType (i ::> tp) b)
mkArray = if ProblemFeatures
feat ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useSymbolicArrays
                    then Assignment TypeMap (i ::> tp)
-> TypeMap b -> TypeMap (BaseArrayType (i ::> tp) b)
forall (idxl :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
Assignment TypeMap (idxl ::> idx)
-> TypeMap tp -> TypeMap (BaseArrayType (idxl ::> idx) tp)
PrimArrayTypeMap
                    else Assignment TypeMap (i ::> tp)
-> TypeMap b -> TypeMap (BaseArrayType (i ::> tp) b)
forall (idxl :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
Assignment TypeMap (idxl ::> idx)
-> TypeMap tp -> TypeMap (BaseArrayType (idxl ::> idx) tp)
FnArrayTypeMap
      Assignment TypeMap (i ::> tp)
idx_types <- IO (Assignment TypeMap (i ::> tp))
-> ReaderT
     (SMTCollectorState t h) IO (Assignment TypeMap (i ::> tp))
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Assignment TypeMap (i ::> tp))
 -> ReaderT
      (SMTCollectorState t h) IO (Assignment TypeMap (i ::> tp)))
-> IO (Assignment TypeMap (i ::> tp))
-> ReaderT
     (SMTCollectorState t h) IO (Assignment TypeMap (i ::> tp))
forall a b. (a -> b) -> a -> b
$
        (forall (x :: BaseType). BaseTypeRepr x -> IO (TypeMap x))
-> Assignment BaseTypeRepr (i ::> tp)
-> IO (Assignment TypeMap (i ::> tp))
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type) (m :: Type -> Type).
(TraversableFC t, Applicative m) =>
(forall (x :: k). f x -> m (g x))
-> forall (x :: l). t f x -> m (t g x)
traverseFC (WriterConn t h -> SMTSource Any -> BaseTypeRepr x -> IO (TypeMap x)
forall (m :: Type -> Type) t h ann (tp :: BaseType).
MonadFail m =>
WriterConn t h
-> SMTSource ann -> BaseTypeRepr tp -> m (TypeMap tp)
evalFirstClassTypeRepr WriterConn t h
conn (Expr t tp -> SMTSource Any
forall t (tp :: BaseType) ann. Expr t tp -> SMTSource ann
eltSource Expr t tp
i)) Assignment BaseTypeRepr (i ::> tp)
idxRepr
      case SMTWriter h => Maybe (ArrayConstantFn (Term h))
forall h. SMTWriter h => Maybe (ArrayConstantFn (Term h))
arrayConstant @h of
        Just ArrayConstantFn (Term h)
constFn
          | Bool
otherwise -> do
            let idx_smt_types :: [Some TypeMap]
idx_smt_types = (forall (x :: BaseType). TypeMap x -> Some TypeMap)
-> Assignment TypeMap (i ::> tp) -> [Some TypeMap]
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type) a.
FoldableFC t =>
(forall (x :: k). f x -> a) -> forall (x :: l). t f x -> [a]
toListFC forall k (f :: k -> Type) (x :: k). f x -> Some f
forall (x :: BaseType). TypeMap x -> Some TypeMap
Some Assignment TypeMap (i ::> tp)
idx_types
            let tp :: TypeMap (BaseArrayType (i ::> tp) b)
tp = Assignment TypeMap (i ::> tp)
-> TypeMap b -> TypeMap (BaseArrayType (i ::> tp) b)
mkArray Assignment TypeMap (i ::> tp)
idx_types TypeMap b
value_type
            TypeMap (BaseArrayType (i ::> tp) b)
-> Term h
-> SMTCollector t h (SMTExpr h (BaseArrayType (i ::> tp) b))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap (BaseArrayType (i ::> tp) b)
tp (Term h
 -> SMTCollector t h (SMTExpr h (BaseArrayType (i ::> tp) b)))
-> Term h
-> SMTCollector t h (SMTExpr h (BaseArrayType (i ::> tp) b))
forall a b. (a -> b) -> a -> b
$!
              ArrayConstantFn (Term h)
constFn [Some TypeMap]
idx_smt_types (TypeMap b -> Some TypeMap
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some TypeMap b
value_type) (SMTExpr h b -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h b
v)
        Maybe (ArrayConstantFn (Term h))
Nothing -> do
          Bool
-> ReaderT (SMTCollectorState t h) IO ()
-> ReaderT (SMTCollectorState t h) IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (WriterConn t h -> Bool
forall t h. WriterConn t h -> Bool
supportFunctionDefs WriterConn t h
conn)) (ReaderT (SMTCollectorState t h) IO ()
 -> ReaderT (SMTCollectorState t h) IO ())
-> ReaderT (SMTCollectorState t h) IO ()
-> ReaderT (SMTCollectorState t h) IO ()
forall a b. (a -> b) -> a -> b
$ do
            String -> ReaderT (SMTCollectorState t h) IO ()
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> ReaderT (SMTCollectorState t h) IO ())
-> String -> ReaderT (SMTCollectorState t h) IO ()
forall a b. (a -> b) -> a -> b
$ Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String) -> Doc Any -> String
forall a b. (a -> b) -> a -> b
$ String -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty (WriterConn t h -> String
forall t h. WriterConn t h -> String
smtWriterName WriterConn t h
conn) Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
              Doc Any
"cannot encode constant arrays."
          -- Constant functions use unnamed variables.
          let array_type :: TypeMap (BaseArrayType (i ::> tp) b)
array_type = Assignment TypeMap (i ::> tp)
-> TypeMap b -> TypeMap (BaseArrayType (i ::> tp) b)
mkArray Assignment TypeMap (i ::> tp)
idx_types TypeMap b
value_type
          -- Create names for index variables.
          [(Text, Some TypeMap)]
args <- IO [(Text, Some TypeMap)]
-> ReaderT (SMTCollectorState t h) IO [(Text, Some TypeMap)]
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO [(Text, Some TypeMap)]
 -> ReaderT (SMTCollectorState t h) IO [(Text, Some TypeMap)])
-> IO [(Text, Some TypeMap)]
-> ReaderT (SMTCollectorState t h) IO [(Text, Some TypeMap)]
forall a b. (a -> b) -> a -> b
$ WriterConn t h
-> Assignment TypeMap (i ::> tp) -> IO [(Text, Some TypeMap)]
forall t h (args :: Ctx BaseType).
WriterConn t h
-> Assignment TypeMap args -> IO [(Text, Some TypeMap)]
createTypeMapArgsForArray WriterConn t h
conn Assignment TypeMap (i ::> tp)
idx_types
          TypeMap (BaseArrayType (i ::> tp) b)
-> Text -> SMTExpr h (BaseArrayType (i ::> tp) b)
forall (tp :: BaseType) h. TypeMap tp -> Text -> SMTExpr h tp
SMTName TypeMap (BaseArrayType (i ::> tp) b)
array_type (Text -> SMTExpr h (BaseArrayType (i ::> tp) b))
-> ReaderT (SMTCollectorState t h) IO Text
-> SMTCollector t h (SMTExpr h (BaseArrayType (i ::> tp) b))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Some TypeMap)]
-> TypeMap b -> Term h -> ReaderT (SMTCollectorState t h) IO Text
forall (rtp :: BaseType) h t.
[(Text, Some TypeMap)]
-> TypeMap rtp -> Term h -> SMTCollector t h Text
freshBoundFn [(Text, Some TypeMap)]
args TypeMap b
value_type (SMTExpr h b -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h b
v)

    SelectArray BaseTypeRepr tp
_bRepr Expr t (BaseArrayType (i ::> tp) tp)
a Assignment (Expr t) (i ::> tp)
idx -> do
      SMTExpr h (BaseArrayType (i ::> tp) tp)
aexpr <- Expr t (BaseArrayType (i ::> tp) tp)
-> SMTCollector t h (SMTExpr h (BaseArrayType (i ::> tp) tp))
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t (BaseArrayType (i ::> tp) tp)
a
      [Term h]
idxl <- Assignment (Expr t) (i ::> tp)
-> ReaderT (SMTCollectorState t h) IO [Term h]
forall h t (ctx :: Ctx BaseType).
SMTWriter h =>
Assignment (Expr t) ctx -> SMTCollector t h [Term h]
mkIndicesTerms Assignment (Expr t) (i ::> tp)
idx
      SMTExpr h tp -> SMTCollector t h (SMTExpr h tp)
forall h (tp :: BaseType) t.
SupportTermOps (Term h) =>
SMTExpr h tp -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm' (SMTExpr h tp -> SMTCollector t h (SMTExpr h tp))
-> SMTExpr h tp -> SMTCollector t h (SMTExpr h tp)
forall a b. (a -> b) -> a -> b
$ SMTExpr h (BaseArrayType (i ::> tp) tp) -> [Term h] -> SMTExpr h tp
forall h (idxl :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
SMTWriter h =>
SMTExpr h (BaseArrayType (idxl ::> idx) tp)
-> [Term h] -> SMTExpr h tp
smt_array_select SMTExpr h (BaseArrayType (i ::> tp) tp)
aexpr [Term h]
idxl

    UpdateArray BaseTypeRepr b
_bRepr Assignment BaseTypeRepr (i ::> tp)
_ Expr t (BaseArrayType (i ::> tp) b)
a_elt Assignment (Expr t) (i ::> tp)
idx Expr t b
ve -> do
      SMTExpr h (BaseArrayType (i ::> tp) b)
a <- Expr t (BaseArrayType (i ::> tp) b)
-> SMTCollector t h (SMTExpr h (BaseArrayType (i ::> tp) b))
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t (BaseArrayType (i ::> tp) b)
a_elt
      [Term h]
updated_idx <- Assignment (Expr t) (i ::> tp)
-> ReaderT (SMTCollectorState t h) IO [Term h]
forall h t (ctx :: Ctx BaseType).
SMTWriter h =>
Assignment (Expr t) ctx -> SMTCollector t h [Term h]
mkIndicesTerms Assignment (Expr t) (i ::> tp)
idx
      Term h
value <- SMTExpr h b -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase (SMTExpr h b -> Term h)
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h b)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr t b -> ReaderT (SMTCollectorState t h) IO (SMTExpr h b)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t b
ve
      let array_type :: TypeMap (BaseArrayType (i ::> tp) b)
array_type = SMTExpr h (BaseArrayType (i ::> tp) b)
-> TypeMap (BaseArrayType (i ::> tp) b)
forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h (BaseArrayType (i ::> tp) b)
a
      case TypeMap (BaseArrayType (i ::> tp) b)
array_type of
        PrimArrayTypeMap Assignment TypeMap (idxl ::> idx)
_ TypeMap tp
_ -> do
            TypeMap (BaseArrayType (i ::> tp) b)
-> Term h
-> SMTCollector t h (SMTExpr h (BaseArrayType (i ::> tp) b))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap (BaseArrayType (i ::> tp) b)
array_type (Term h
 -> SMTCollector t h (SMTExpr h (BaseArrayType (i ::> tp) b)))
-> Term h
-> SMTCollector t h (SMTExpr h (BaseArrayType (i ::> tp) b))
forall a b. (a -> b) -> a -> b
$
              Term h -> [Term h] -> Term h -> Term h
forall h. SMTWriter h => Term h -> [Term h] -> Term h -> Term h
arrayUpdate @h (SMTExpr h (BaseArrayType (i ::> tp) b) -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h (BaseArrayType (i ::> tp) b)
a) [Term h]
updated_idx Term h
value
        FnArrayTypeMap Assignment TypeMap (idxl ::> idx)
idxTypes TypeMap tp
resType  -> do
          case Maybe (Term h -> [Term h] -> Term h -> Term h)
forall v. SupportTermOps v => Maybe (v -> [v] -> v -> v)
smtFnUpdate of
            Just Term h -> [Term h] -> Term h -> Term h
updateFn -> do
              TypeMap (BaseArrayType (i ::> tp) b)
-> Term h
-> SMTCollector t h (SMTExpr h (BaseArrayType (i ::> tp) b))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap (BaseArrayType (i ::> tp) b)
array_type (Term h
 -> SMTCollector t h (SMTExpr h (BaseArrayType (i ::> tp) b)))
-> Term h
-> SMTCollector t h (SMTExpr h (BaseArrayType (i ::> tp) b))
forall a b. (a -> b) -> a -> b
$ Term h -> [Term h] -> Term h -> Term h
updateFn (SMTExpr h (BaseArrayType (i ::> tp) b) -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h (BaseArrayType (i ::> tp) b)
a) [Term h]
updated_idx Term h
value
            Maybe (Term h -> [Term h] -> Term h -> Term h)
Nothing -> do
              -- Return value at index in base_array.
              [(Text, Some TypeMap)]
args <- IO [(Text, Some TypeMap)]
-> ReaderT (SMTCollectorState t h) IO [(Text, Some TypeMap)]
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO [(Text, Some TypeMap)]
 -> ReaderT (SMTCollectorState t h) IO [(Text, Some TypeMap)])
-> IO [(Text, Some TypeMap)]
-> ReaderT (SMTCollectorState t h) IO [(Text, Some TypeMap)]
forall a b. (a -> b) -> a -> b
$ WriterConn t h
-> Assignment TypeMap (idxl ::> idx) -> IO [(Text, Some TypeMap)]
forall t h (args :: Ctx BaseType).
WriterConn t h
-> Assignment TypeMap args -> IO [(Text, Some TypeMap)]
createTypeMapArgsForArray WriterConn t h
conn Assignment TypeMap (idxl ::> idx)
idxTypes

              let idx_terms :: [Term h]
idx_terms = Text -> Term h
forall v. SupportTermOps v => Text -> v
fromText (Text -> Term h)
-> ((Text, Some TypeMap) -> Text) -> (Text, Some TypeMap) -> Term h
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Some TypeMap) -> Text
forall a b. (a, b) -> a
fst ((Text, Some TypeMap) -> Term h)
-> [(Text, Some TypeMap)] -> [Term h]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Some TypeMap)]
args
              let base_array_value :: Term h
base_array_value = Term h -> [Term h] -> Term h
forall v. SupportTermOps v => v -> [v] -> v
smtFnApp (SMTExpr h (BaseArrayType (i ::> tp) b) -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h (BaseArrayType (i ::> tp) b)
a) [Term h]
idx_terms
              let cond :: Term h
cond = [Term h] -> Term h
forall v. SupportTermOps v => [v] -> v
andAll ((Term h -> Term h -> Term h) -> [Term h] -> [Term h] -> [Term h]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
(.==) [Term h]
updated_idx [Term h]
idx_terms)
              let expr :: Term h
expr = Term h -> Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v -> v
ite Term h
cond Term h
value Term h
base_array_value
              TypeMap (BaseArrayType (i ::> tp) b)
-> Text -> SMTExpr h (BaseArrayType (i ::> tp) b)
forall (tp :: BaseType) h. TypeMap tp -> Text -> SMTExpr h tp
SMTName TypeMap (BaseArrayType (i ::> tp) b)
array_type (Text -> SMTExpr h (BaseArrayType (i ::> tp) b))
-> ReaderT (SMTCollectorState t h) IO Text
-> SMTCollector t h (SMTExpr h (BaseArrayType (i ::> tp) b))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Some TypeMap)]
-> TypeMap tp -> Term h -> ReaderT (SMTCollectorState t h) IO Text
forall (rtp :: BaseType) h t.
[(Text, Some TypeMap)]
-> TypeMap rtp -> Term h -> SMTCollector t h Text
freshBoundFn [(Text, Some TypeMap)]
args TypeMap tp
resType Term h
expr

    ------------------------------------------------------------------------
    -- Conversions.

    IntegerToReal Expr t BaseIntegerType
xe -> do
      SMTExpr h BaseIntegerType
x <- Expr t BaseIntegerType
-> SMTCollector t h (SMTExpr h BaseIntegerType)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t BaseIntegerType
xe
      SMTExpr h BaseRealType -> SMTCollector t h (SMTExpr h BaseRealType)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SMTExpr h BaseRealType
 -> SMTCollector t h (SMTExpr h BaseRealType))
-> SMTExpr h BaseRealType
-> SMTCollector t h (SMTExpr h BaseRealType)
forall a b. (a -> b) -> a -> b
$ TypeMap BaseRealType -> Term h -> SMTExpr h BaseRealType
forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap BaseRealType
RealTypeMap (Term h -> Term h
forall v. SupportTermOps v => v -> v
termIntegerToReal (SMTExpr h BaseIntegerType -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h BaseIntegerType
x))
    RealToInteger Expr t BaseRealType
xe -> do
      Expr t tp -> ReaderT (SMTCollectorState t h) IO ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkIntegerSupport Expr t tp
i
      Term h
x <- Expr t BaseRealType -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseRealType
xe
      SMTExpr h BaseIntegerType
-> SMTCollector t h (SMTExpr h BaseIntegerType)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SMTExpr h BaseIntegerType
 -> SMTCollector t h (SMTExpr h BaseIntegerType))
-> SMTExpr h BaseIntegerType
-> SMTCollector t h (SMTExpr h BaseIntegerType)
forall a b. (a -> b) -> a -> b
$ TypeMap BaseIntegerType -> Term h -> SMTExpr h BaseIntegerType
forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap BaseIntegerType
IntegerTypeMap (Term h -> Term h
forall v. SupportTermOps v => v -> v
termRealToInteger Term h
x)

    RoundReal Expr t BaseRealType
xe -> do
      Expr t tp -> ReaderT (SMTCollectorState t h) IO ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkIntegerSupport Expr t tp
i
      Term h
x <- Expr t BaseRealType -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseRealType
xe
      SMTExpr h BaseIntegerType
nm <- String
-> TypeMap BaseIntegerType
-> SMTCollector t h (SMTExpr h BaseIntegerType)
forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
"round" TypeMap BaseIntegerType
IntegerTypeMap
      let r :: Term h
r = Term h -> Term h
forall v. SupportTermOps v => v -> v
termIntegerToReal (SMTExpr h BaseIntegerType -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h BaseIntegerType
nm)
      -- Round always rounds away from zero, so we
      -- first split "r = round(x)" into two cases
      -- depending on if "x" is non-negative.
      let posExpr :: Term h
posExpr = (Term h
2Term h -> Term h -> Term h
forall a. Num a => a -> a -> a
*Term h
x Term h -> Term h -> Term h
forall a. Num a => a -> a -> a
- Term h
1 Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.<  Term h
2Term h -> Term h -> Term h
forall a. Num a => a -> a -> a
*Term h
r) Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.&& (Term h
2Term h -> Term h -> Term h
forall a. Num a => a -> a -> a
*Term h
r Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.<= Term h
2Term h -> Term h -> Term h
forall a. Num a => a -> a -> a
*Term h
x Term h -> Term h -> Term h
forall a. Num a => a -> a -> a
+ Term h
1)
      let negExpr :: Term h
negExpr = (Term h
2Term h -> Term h -> Term h
forall a. Num a => a -> a -> a
*Term h
x Term h -> Term h -> Term h
forall a. Num a => a -> a -> a
- Term h
1 Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.<= Term h
2Term h -> Term h -> Term h
forall a. Num a => a -> a -> a
*Term h
r) Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.&& (Term h
2Term h -> Term h -> Term h
forall a. Num a => a -> a -> a
*Term h
r Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.<  Term h
2Term h -> Term h -> Term h
forall a. Num a => a -> a -> a
*Term h
x Term h -> Term h -> Term h
forall a. Num a => a -> a -> a
+ Term h
1)
      -- Add formula
      String -> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"round" (Term h -> ReaderT (SMTCollectorState t h) IO ())
-> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall a b. (a -> b) -> a -> b
$ Term h
x Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.<  Term h
0 Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.|| Term h
posExpr
      String -> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"round" (Term h -> ReaderT (SMTCollectorState t h) IO ())
-> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall a b. (a -> b) -> a -> b
$ Term h
x Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.>= Term h
0 Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.|| Term h
negExpr
      SMTExpr h BaseIntegerType
-> SMTCollector t h (SMTExpr h BaseIntegerType)
forall (m :: Type -> Type) a. Monad m => a -> m a
return SMTExpr h BaseIntegerType
nm

    RoundEvenReal Expr t BaseRealType
xe -> do
      Expr t tp -> ReaderT (SMTCollectorState t h) IO ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkIntegerSupport Expr t tp
i
      Term h
x <- Expr t BaseRealType -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseRealType
xe
      Term h
nm <- SMTExpr h BaseIntegerType -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase (SMTExpr h BaseIntegerType -> Term h)
-> SMTCollector t h (SMTExpr h BaseIntegerType)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> TypeMap BaseIntegerType
-> SMTCollector t h (SMTExpr h BaseIntegerType)
forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
"roundEven" TypeMap BaseIntegerType
IntegerTypeMap
      Term h
r <- SMTExpr h BaseRealType -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase (SMTExpr h BaseRealType -> Term h)
-> SMTCollector t h (SMTExpr h BaseRealType)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeMap BaseRealType
-> Term h -> SMTCollector t h (SMTExpr h BaseRealType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseRealType
RealTypeMap (Term h -> Term h
forall v. SupportTermOps v => v -> v
termIntegerToReal Term h
nm)
      -- Assert that `x` is in the interval `[r, r+1]`
      String -> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"roundEven" (Term h -> ReaderT (SMTCollectorState t h) IO ())
-> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall a b. (a -> b) -> a -> b
$ (Term h
r Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.<= Term h
x) Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.&& (Term h
x Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.<= Term h
rTerm h -> Term h -> Term h
forall a. Num a => a -> a -> a
+Term h
1)
      Term h
diff <- SMTExpr h BaseRealType -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase (SMTExpr h BaseRealType -> Term h)
-> SMTCollector t h (SMTExpr h BaseRealType)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeMap BaseRealType
-> Term h -> SMTCollector t h (SMTExpr h BaseRealType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseRealType
RealTypeMap (Term h
x Term h -> Term h -> Term h
forall a. Num a => a -> a -> a
- Term h
r)
      TypeMap BaseIntegerType
-> Term h -> SMTCollector t h (SMTExpr h BaseIntegerType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseIntegerType
IntegerTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseIntegerType))
-> Term h -> SMTCollector t h (SMTExpr h BaseIntegerType)
forall a b. (a -> b) -> a -> b
$
        Term h -> Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v -> v
ite (Term h
diff Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.< Rational -> Term h
forall v. SupportTermOps v => Rational -> v
rationalTerm Rational
0.5) Term h
nm (Term h -> Term h) -> Term h -> Term h
forall a b. (a -> b) -> a -> b
$
          Term h -> Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v -> v
ite (Term h
diff Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.> Rational -> Term h
forall v. SupportTermOps v => Rational -> v
rationalTerm Rational
0.5) (Term h
nmTerm h -> Term h -> Term h
forall a. Num a => a -> a -> a
+Term h
1) (Term h -> Term h) -> Term h -> Term h
forall a b. (a -> b) -> a -> b
$
            Term h -> Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v -> v
ite (Term h -> Natural -> Term h
forall v. SupportTermOps v => v -> Natural -> v
intDivisible Term h
nm Natural
2) Term h
nm (Term h
nmTerm h -> Term h -> Term h
forall a. Num a => a -> a -> a
+Term h
1)

    FloorReal Expr t BaseRealType
xe -> do
      Expr t tp -> ReaderT (SMTCollectorState t h) IO ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkIntegerSupport Expr t tp
i
      Term h
x <- Expr t BaseRealType -> ReaderT (SMTCollectorState t h) IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseRealType
xe
      SMTExpr h BaseIntegerType
nm <- String
-> TypeMap BaseIntegerType
-> SMTCollector t h (SMTExpr h BaseIntegerType)
forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
"floor" TypeMap BaseIntegerType
IntegerTypeMap
      let floor_r :: Term h
floor_r = Term h -> Term h
forall v. SupportTermOps v => v -> v
termIntegerToReal (SMTExpr h BaseIntegerType -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h BaseIntegerType
nm)
      String -> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"floor" (Term h -> ReaderT (SMTCollectorState t h) IO ())
-> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall a b. (a -> b) -> a -> b
$ (Term h
floor_r Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.<= Term h
x) Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.&& (Term h
x Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.< Term h
floor_r Term h -> Term h -> Term h
forall a. Num a => a -> a -> a
+ Term h
1)
      SMTExpr h BaseIntegerType
-> SMTCollector t h (SMTExpr h BaseIntegerType)
forall (m :: Type -> Type) a. Monad m => a -> m a
return SMTExpr h BaseIntegerType
nm

    CeilReal Expr t BaseRealType
xe -> do
      Expr t tp -> ReaderT (SMTCollectorState t h) IO ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkIntegerSupport Expr t tp
i
      Term h
x <- SMTExpr h BaseRealType -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase (SMTExpr h BaseRealType -> Term h)
-> SMTCollector t h (SMTExpr h BaseRealType)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr t BaseRealType -> SMTCollector t h (SMTExpr h BaseRealType)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t BaseRealType
xe
      SMTExpr h BaseIntegerType
nm <- String
-> TypeMap BaseIntegerType
-> SMTCollector t h (SMTExpr h BaseIntegerType)
forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
"ceiling" TypeMap BaseIntegerType
IntegerTypeMap
      let r :: Term h
r = Term h -> Term h
forall v. SupportTermOps v => v -> v
termIntegerToReal (SMTExpr h BaseIntegerType -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h BaseIntegerType
nm)
      String -> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"ceiling" (Term h -> ReaderT (SMTCollectorState t h) IO ())
-> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall a b. (a -> b) -> a -> b
$ (Term h
x Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.<= Term h
r) Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.&& (Term h
r Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
.< Term h
x Term h -> Term h -> Term h
forall a. Num a => a -> a -> a
+ Term h
1)
      SMTExpr h BaseIntegerType
-> SMTCollector t h (SMTExpr h BaseIntegerType)
forall (m :: Type -> Type) a. Monad m => a -> m a
return SMTExpr h BaseIntegerType
nm

    BVToInteger Expr t (BaseBVType w)
xe -> do
      Expr t tp -> ReaderT (SMTCollectorState t h) IO ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkLinearSupport Expr t tp
i
      SMTExpr h (BaseBVType w)
x <- Expr t (BaseBVType w)
-> SMTCollector t h (SMTExpr h (BaseBVType w))
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t (BaseBVType w)
xe
      TypeMap BaseIntegerType
-> Term h -> SMTCollector t h (SMTExpr h BaseIntegerType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseIntegerType
IntegerTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseIntegerType))
-> Term h -> SMTCollector t h (SMTExpr h BaseIntegerType)
forall a b. (a -> b) -> a -> b
$ NatRepr w -> Term h -> Term h
forall v (w :: Nat).
(SupportTermOps v, 1 <= w) =>
NatRepr w -> v -> v
bvIntTerm (Expr t (BaseBVType w) -> NatRepr w
forall (e :: BaseType -> Type) (w :: Nat).
IsExpr e =>
e (BaseBVType w) -> NatRepr w
bvWidth Expr t (BaseBVType w)
xe) (SMTExpr h (BaseBVType w) -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h (BaseBVType w)
x)

    SBVToInteger Expr t (BaseBVType w)
xe -> do
      Expr t tp -> ReaderT (SMTCollectorState t h) IO ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkLinearSupport Expr t tp
i
      SMTExpr h (BaseBVType w)
x <- Expr t (BaseBVType w)
-> SMTCollector t h (SMTExpr h (BaseBVType w))
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t (BaseBVType w)
xe
      TypeMap BaseIntegerType
-> Term h -> SMTCollector t h (SMTExpr h BaseIntegerType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseIntegerType
IntegerTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseIntegerType))
-> Term h -> SMTCollector t h (SMTExpr h BaseIntegerType)
forall a b. (a -> b) -> a -> b
$ NatRepr w -> Term h -> Term h
forall v (w :: Nat). SupportTermOps v => NatRepr w -> v -> v
sbvIntTerm (Expr t (BaseBVType w) -> NatRepr w
forall (e :: BaseType -> Type) (w :: Nat).
IsExpr e =>
e (BaseBVType w) -> NatRepr w
bvWidth Expr t (BaseBVType w)
xe) (SMTExpr h (BaseBVType w) -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h (BaseBVType w)
x)

    IntegerToBV Expr t BaseIntegerType
xe NatRepr w
w -> do
      Expr t tp -> ReaderT (SMTCollectorState t h) IO ()
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkLinearSupport Expr t tp
i

      SMTExpr h BaseIntegerType
x <- Expr t BaseIntegerType
-> SMTCollector t h (SMTExpr h BaseIntegerType)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t BaseIntegerType
xe
      let xb :: Term h
xb = SMTExpr h BaseIntegerType -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h BaseIntegerType
x

      SMTExpr h (BaseBVType w)
res <- String
-> TypeMap (BaseBVType w)
-> SMTCollector t h (SMTExpr h (BaseBVType w))
forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
"integerToBV" (NatRepr w -> TypeMap (BaseBVType w)
forall (w :: Nat). (1 <= w) => NatRepr w -> TypeMap (BaseBVType w)
BVTypeMap NatRepr w
w)
      SMTExpr h BaseIntegerType
bvint <- TypeMap BaseIntegerType
-> Term h -> SMTCollector t h (SMTExpr h BaseIntegerType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseIntegerType
IntegerTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseIntegerType))
-> Term h -> SMTCollector t h (SMTExpr h BaseIntegerType)
forall a b. (a -> b) -> a -> b
$ NatRepr w -> Term h -> Term h
forall v (w :: Nat).
(SupportTermOps v, 1 <= w) =>
NatRepr w -> v -> v
bvIntTerm NatRepr w
w (SMTExpr h (BaseBVType w) -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h (BaseBVType w)
res)

      String -> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"integerToBV" (Term h -> ReaderT (SMTCollectorState t h) IO ())
-> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall a b. (a -> b) -> a -> b
$
         (Term h -> Natural -> Term h
forall v. SupportTermOps v => v -> Natural -> v
intDivisible (Term h
xb Term h -> Term h -> Term h
forall a. Num a => a -> a -> a
- (SMTExpr h BaseIntegerType -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h BaseIntegerType
bvint)) (Natural
2Natural -> Natural -> Natural
forall a b. (Num a, Integral b) => a -> b -> a
^NatRepr w -> Natural
forall (n :: Nat). NatRepr n -> Natural
natValue NatRepr w
w))
      SMTExpr h (BaseBVType w)
-> SMTCollector t h (SMTExpr h (BaseBVType w))
forall (m :: Type -> Type) a. Monad m => a -> m a
return SMTExpr h (BaseBVType w)
res

    Cplx Complex (Expr t BaseRealType)
c -> do
      (SMTExpr h BaseRealType
rl :+ SMTExpr h BaseRealType
img) <- (Expr t BaseRealType -> SMTCollector t h (SMTExpr h BaseRealType))
-> Complex (Expr t BaseRealType)
-> ReaderT
     (SMTCollectorState t h) IO (Complex (SMTExpr h BaseRealType))
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr t BaseRealType -> SMTCollector t h (SMTExpr h BaseRealType)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Complex (Expr t BaseRealType)
c

      ProblemFeatures
feat <- (SMTCollectorState t h -> ProblemFeatures)
-> ReaderT (SMTCollectorState t h) IO ProblemFeatures
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks (WriterConn t h -> ProblemFeatures
forall t h. WriterConn t h -> ProblemFeatures
supportedFeatures (WriterConn t h -> ProblemFeatures)
-> (SMTCollectorState t h -> WriterConn t h)
-> SMTCollectorState t h
-> ProblemFeatures
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMTCollectorState t h -> WriterConn t h
forall t h. SMTCollectorState t h -> WriterConn t h
scConn)
      case () of
        ()
_ | ProblemFeatures
feat ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useStructs -> do
            let tp :: TypeMap BaseComplexType
tp = TypeMap BaseComplexType
ComplexToStructTypeMap
            let tm :: Term h
tm = Assignment TypeMap ((EmptyCtx ::> BaseRealType) ::> BaseRealType)
-> [Term h] -> Term h
forall h (args :: Ctx BaseType).
SMTWriter h =>
Assignment TypeMap args -> [Term h] -> Term h
structCtor @h (Assignment TypeMap EmptyCtx
forall k (ctx :: Ctx k) (f :: k -> Type).
(ctx ~ EmptyCtx) =>
Assignment f ctx
Ctx.Empty Assignment TypeMap EmptyCtx
-> TypeMap BaseRealType
-> Assignment TypeMap (EmptyCtx ::> BaseRealType)
forall k (ctx' :: Ctx k) (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
(ctx' ~ (ctx ::> tp)) =>
Assignment f ctx -> f tp -> Assignment f ctx'
Ctx.:> TypeMap BaseRealType
RealTypeMap Assignment TypeMap (EmptyCtx ::> BaseRealType)
-> TypeMap BaseRealType
-> Assignment
     TypeMap ((EmptyCtx ::> BaseRealType) ::> BaseRealType)
forall k (ctx' :: Ctx k) (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
(ctx' ~ (ctx ::> tp)) =>
Assignment f ctx -> f tp -> Assignment f ctx'
Ctx.:> TypeMap BaseRealType
RealTypeMap) [SMTExpr h BaseRealType -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h BaseRealType
rl, SMTExpr h BaseRealType -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h BaseRealType
img]
            TypeMap BaseComplexType
-> Term h -> SMTCollector t h (SMTExpr h BaseComplexType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseComplexType
tp Term h
tm

          | ProblemFeatures
feat ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useSymbolicArrays -> do
            let tp :: TypeMap BaseComplexType
tp = TypeMap BaseComplexType
ComplexToArrayTypeMap
            let r' :: Term h
r' = SMTExpr h BaseRealType -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h BaseRealType
rl
            let i' :: Term h
i' = SMTExpr h BaseRealType -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h BaseRealType
img
            Term h
ra <-
              case SMTWriter h => Maybe (ArrayConstantFn (Term h))
forall h. SMTWriter h => Maybe (ArrayConstantFn (Term h))
arrayConstant @h of
                Just ArrayConstantFn (Term h)
constFn  ->
                  Term h -> ReaderT (SMTCollectorState t h) IO (Term h)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ArrayConstantFn (Term h)
constFn [TypeMap BaseBoolType -> Some TypeMap
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some TypeMap BaseBoolType
BoolTypeMap] (TypeMap BaseRealType -> Some TypeMap
forall k (f :: k -> Type) (x :: k). f x -> Some f
Some TypeMap BaseRealType
RealTypeMap) Term h
r')
                Maybe (ArrayConstantFn (Term h))
Nothing -> do
                  Term h
a <- SMTExpr h BaseComplexType -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase (SMTExpr h BaseComplexType -> Term h)
-> SMTCollector t h (SMTExpr h BaseComplexType)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> TypeMap BaseComplexType
-> SMTCollector t h (SMTExpr h BaseComplexType)
forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
"complex lit" TypeMap BaseComplexType
tp
                  Term h -> ReaderT (SMTCollectorState t h) IO (Term h)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Term h -> ReaderT (SMTCollectorState t h) IO (Term h))
-> Term h -> ReaderT (SMTCollectorState t h) IO (Term h)
forall a b. (a -> b) -> a -> b
$! Term h -> [Term h] -> Term h -> Term h
forall h. SMTWriter h => Term h -> [Term h] -> Term h -> Term h
arrayUpdate @h Term h
a [Bool -> Term h
forall v. SupportTermOps v => Bool -> v
boolExpr Bool
False] Term h
r'
            TypeMap BaseComplexType
-> Term h -> SMTCollector t h (SMTExpr h BaseComplexType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseComplexType
tp (Term h -> SMTCollector t h (SMTExpr h BaseComplexType))
-> Term h -> SMTCollector t h (SMTExpr h BaseComplexType)
forall a b. (a -> b) -> a -> b
$! Term h -> [Term h] -> Term h -> Term h
forall h. SMTWriter h => Term h -> [Term h] -> Term h -> Term h
arrayUpdate @h Term h
ra [Bool -> Term h
forall v. SupportTermOps v => Bool -> v
boolExpr Bool
True] Term h
i'

          | Bool
otherwise ->
            WriterConn t h
-> String -> Expr t tp -> SMTCollector t h (SMTExpr h tp)
forall (m :: Type -> Type) t h (tp :: BaseType) a.
MonadFail m =>
WriterConn t h -> String -> Expr t tp -> m a
theoryUnsupported WriterConn t h
conn String
"complex literals" Expr t tp
i

    RealPart Expr t BaseComplexType
e -> do
      SMTExpr h BaseComplexType
c <- Expr t BaseComplexType
-> SMTCollector t h (SMTExpr h BaseComplexType)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t BaseComplexType
e
      case SMTExpr h BaseComplexType -> TypeMap BaseComplexType
forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h BaseComplexType
c of
        TypeMap BaseComplexType
ComplexToStructTypeMap ->
          do let prj :: Term h
prj = Term h -> Term h
forall h. SMTWriter h => Term h -> Term h
structComplexRealPart @h (SMTExpr h BaseComplexType -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h BaseComplexType
c)
             TypeMap BaseRealType
-> Term h -> SMTCollector t h (SMTExpr h BaseRealType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseRealType
RealTypeMap Term h
prj
        TypeMap BaseComplexType
ComplexToArrayTypeMap ->
          TypeMap BaseRealType
-> Term h -> SMTCollector t h (SMTExpr h BaseRealType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseRealType
RealTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseRealType))
-> Term h -> SMTCollector t h (SMTExpr h BaseRealType)
forall a b. (a -> b) -> a -> b
$ Term h -> Term h
forall h. SMTWriter h => Term h -> Term h
arrayComplexRealPart @h (SMTExpr h BaseComplexType -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h BaseComplexType
c)
    ImagPart Expr t BaseComplexType
e -> do
      SMTExpr h BaseComplexType
c <- Expr t BaseComplexType
-> SMTCollector t h (SMTExpr h BaseComplexType)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t BaseComplexType
e
      case SMTExpr h BaseComplexType -> TypeMap BaseComplexType
forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h BaseComplexType
c of
        TypeMap BaseComplexType
ComplexToStructTypeMap ->
          do let prj :: Term h
prj = Term h -> Term h
forall h. SMTWriter h => Term h -> Term h
structComplexImagPart @h (SMTExpr h BaseComplexType -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h BaseComplexType
c)
             TypeMap BaseRealType
-> Term h -> SMTCollector t h (SMTExpr h BaseRealType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseRealType
RealTypeMap Term h
prj
        TypeMap BaseComplexType
ComplexToArrayTypeMap ->
          TypeMap BaseRealType
-> Term h -> SMTCollector t h (SMTExpr h BaseRealType)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseRealType
RealTypeMap (Term h -> SMTCollector t h (SMTExpr h BaseRealType))
-> Term h -> SMTCollector t h (SMTExpr h BaseRealType)
forall a b. (a -> b) -> a -> b
$ Term h -> Term h
forall h. SMTWriter h => Term h -> Term h
arrayComplexImagPart @h (SMTExpr h BaseComplexType -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h BaseComplexType
c)

    --------------------------------------------------------------------
    -- Structures

    StructCtor Assignment BaseTypeRepr flds
_ Assignment (Expr t) flds
vals -> do
      -- Make sure a struct with the given number of elements has been declared.
      Assignment (SMTExpr h) flds
exprs <- (forall (x :: BaseType).
 Expr t x -> ReaderT (SMTCollectorState t h) IO (SMTExpr h x))
-> Assignment (Expr t) flds
-> ReaderT (SMTCollectorState t h) IO (Assignment (SMTExpr h) flds)
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type) (m :: Type -> Type).
(TraversableFC t, Applicative m) =>
(forall (x :: k). f x -> m (g x))
-> forall (x :: l). t f x -> m (t g x)
traverseFC forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
forall (x :: BaseType).
Expr t x -> ReaderT (SMTCollectorState t h) IO (SMTExpr h x)
mkExpr Assignment (Expr t) flds
vals
      let fld_types :: Assignment TypeMap flds
fld_types = (forall (x :: BaseType). SMTExpr h x -> TypeMap x)
-> Assignment (SMTExpr h) flds -> Assignment TypeMap flds
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type).
FunctorFC t =>
(forall (x :: k). f x -> g x) -> forall (x :: l). t f x -> t g x
fmapFC forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
forall (x :: BaseType). SMTExpr h x -> TypeMap x
smtExprType Assignment (SMTExpr h) flds
exprs

      IO () -> ReaderT (SMTCollectorState t h) IO ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT (SMTCollectorState t h) IO ())
-> IO () -> ReaderT (SMTCollectorState t h) IO ()
forall a b. (a -> b) -> a -> b
$ WriterConn t h -> Assignment TypeMap flds -> IO ()
forall h t (args :: Ctx BaseType).
SMTWriter h =>
WriterConn t h -> Assignment TypeMap args -> IO ()
declareStructDatatype WriterConn t h
conn Assignment TypeMap flds
fld_types
      let tm :: Term h
tm = Assignment TypeMap flds -> [Term h] -> Term h
forall h (args :: Ctx BaseType).
SMTWriter h =>
Assignment TypeMap args -> [Term h] -> Term h
structCtor @h Assignment TypeMap flds
fld_types ((forall (x :: BaseType). SMTExpr h x -> Term h)
-> Assignment (SMTExpr h) flds -> [Term h]
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type) a.
FoldableFC t =>
(forall (x :: k). f x -> a) -> forall (x :: l). t f x -> [a]
toListFC forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
forall (x :: BaseType). SMTExpr h x -> Term h
asBase Assignment (SMTExpr h) flds
exprs)
      TypeMap (BaseStructType flds)
-> Term h -> SMTCollector t h (SMTExpr h (BaseStructType flds))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (Assignment TypeMap flds -> TypeMap (BaseStructType flds)
forall (idx :: Ctx BaseType).
Assignment TypeMap idx -> TypeMap (BaseStructType idx)
StructTypeMap Assignment TypeMap flds
fld_types) Term h
tm

    StructField Expr t (BaseStructType flds)
s Index flds tp
idx BaseTypeRepr tp
_tp -> do
      SMTExpr h (BaseStructType flds)
expr <- Expr t (BaseStructType flds)
-> SMTCollector t h (SMTExpr h (BaseStructType flds))
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t (BaseStructType flds)
s
      case SMTExpr h (BaseStructType flds) -> TypeMap (BaseStructType flds)
forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h (BaseStructType flds)
expr of
       StructTypeMap Assignment TypeMap idx
flds -> do
         let tp :: TypeMap tp
tp = Assignment TypeMap idx
flds Assignment TypeMap idx -> Index idx tp -> TypeMap tp
forall k (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
Assignment f ctx -> Index ctx tp -> f tp
Ctx.! Index flds tp
Index idx tp
idx
         let tm :: Term h
tm = Assignment TypeMap idx -> Index idx tp -> Term h -> Term h
forall h (args :: Ctx BaseType) (tp :: BaseType).
SMTWriter h =>
Assignment TypeMap args -> Index args tp -> Term h -> Term h
structProj @h Assignment TypeMap idx
flds Index flds tp
Index idx tp
idx (SMTExpr h (BaseStructType flds) -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h (BaseStructType flds)
expr)
         TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap tp
tp Term h
tm

defineFn :: SMTWriter h
         => WriterConn t h
         -> Text
         -> Ctx.Assignment (ExprBoundVar t) a
         -> Expr t r
         -> Ctx.Assignment TypeMap a
         -> IO (TypeMap r)
defineFn :: WriterConn t h
-> Text
-> Assignment (ExprBoundVar t) a
-> Expr t r
-> Assignment TypeMap a
-> IO (TypeMap r)
defineFn WriterConn t h
conn Text
nm Assignment (ExprBoundVar t) a
arg_vars Expr t r
return_value Assignment TypeMap a
arg_types =
  -- Define the SMT function
  WriterConn t h
-> Text
-> (FreshVarFn h -> SMTCollector t h (SMTExpr h r))
-> IO (TypeMap r)
forall h t (ret :: BaseType).
SMTWriter h =>
WriterConn t h
-> Text
-> (FreshVarFn h -> SMTCollector t h (SMTExpr h ret))
-> IO (TypeMap ret)
defineSMTFunction WriterConn t h
conn Text
nm ((FreshVarFn h -> SMTCollector t h (SMTExpr h r))
 -> IO (TypeMap r))
-> (FreshVarFn h -> SMTCollector t h (SMTExpr h r))
-> IO (TypeMap r)
forall a b. (a -> b) -> a -> b
$ \(FreshVarFn forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp)
freshVar) -> do
    -- Create SMT expressions and bind them to vars
    Size a
-> (forall (tp :: BaseType).
    Index a tp -> ReaderT (SMTCollectorState t h) IO ())
-> ReaderT (SMTCollectorState t h) IO ()
forall k (ctx :: Ctx k) (m :: Type -> Type).
Applicative m =>
Size ctx -> (forall (tp :: k). Index ctx tp -> m ()) -> m ()
Ctx.forIndexM (Assignment (ExprBoundVar t) a -> Size a
forall k (f :: k -> Type) (ctx :: Ctx k).
Assignment f ctx -> Size ctx
Ctx.size Assignment (ExprBoundVar t) a
arg_vars) ((forall (tp :: BaseType).
  Index a tp -> ReaderT (SMTCollectorState t h) IO ())
 -> ReaderT (SMTCollectorState t h) IO ())
-> (forall (tp :: BaseType).
    Index a tp -> ReaderT (SMTCollectorState t h) IO ())
-> ReaderT (SMTCollectorState t h) IO ()
forall a b. (a -> b) -> a -> b
$ \Index a tp
i -> do
      let v :: ExprBoundVar t tp
v = Assignment (ExprBoundVar t) a
arg_vars Assignment (ExprBoundVar t) a -> Index a tp -> ExprBoundVar t tp
forall k (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
Assignment f ctx -> Index ctx tp -> f tp
Ctx.! Index a tp
i
      let smtType :: TypeMap tp
smtType = Assignment TypeMap a
arg_types Assignment TypeMap a -> Index a tp -> TypeMap tp
forall k (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
Assignment f ctx -> Index ctx tp -> f tp
Ctx.! Index a tp
i
      ExprBoundVar t tp -> ReaderT (SMTCollectorState t h) IO ()
forall n (tp :: BaseType) h.
ExprBoundVar n tp -> SMTCollector n h ()
checkVarTypeSupport ExprBoundVar t tp
v
      SMTExpr h tp
x <- IO (SMTExpr h tp)
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (SMTExpr h tp)
 -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> IO (SMTExpr h tp)
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a b. (a -> b) -> a -> b
$ TypeMap tp -> IO (SMTExpr h tp)
forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp)
freshVar TypeMap tp
smtType
      ExprBoundVar t tp
-> SMTExpr h tp -> ReaderT (SMTCollectorState t h) IO ()
forall t (tp :: BaseType) h.
ExprBoundVar t tp -> SMTExpr h tp -> SMTCollector t h ()
bindVar ExprBoundVar t tp
v SMTExpr h tp
x
    -- Evaluate return value
    Expr t r -> SMTCollector t h (SMTExpr h r)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t r
return_value

-- | Create a SMT symbolic function from the ExprSymFn.
--
-- Returns the return type of the function.
--
-- This is only called by 'getSMTSymFn'.
mkSMTSymFn :: SMTWriter h
           => WriterConn t h
           -> Text
           -> ExprSymFn t args ret
           -> Ctx.Assignment TypeMap args
           -> IO (TypeMap ret)
mkSMTSymFn :: WriterConn t h
-> Text
-> ExprSymFn t args ret
-> Assignment TypeMap args
-> IO (TypeMap ret)
mkSMTSymFn WriterConn t h
conn Text
nm ExprSymFn t args ret
f Assignment TypeMap args
arg_types =
  case ExprSymFn t args ret -> SymFnInfo t args ret
forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> SymFnInfo t args ret
symFnInfo ExprSymFn t args ret
f of
    UninterpFnInfo Assignment BaseTypeRepr args
_ BaseTypeRepr ret
return_type -> do
      let fnm :: SolverSymbol
fnm = ExprSymFn t args ret -> SolverSymbol
forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> SolverSymbol
symFnName ExprSymFn t args ret
f
      let l :: ProgramLoc
l = ExprSymFn t args ret -> ProgramLoc
forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> ProgramLoc
symFnLoc ExprSymFn t args ret
f
      TypeMap ret
smt_ret <- WriterConn t h
-> SMTSource Any -> BaseTypeRepr ret -> IO (TypeMap ret)
forall (m :: Type -> Type) t h ann (tp :: BaseType).
MonadFail m =>
WriterConn t h
-> SMTSource ann -> BaseTypeRepr tp -> m (TypeMap tp)
evalFirstClassTypeRepr WriterConn t h
conn (SolverSymbol -> ProgramLoc -> SMTSource Any
forall ann. SolverSymbol -> ProgramLoc -> SMTSource ann
fnSource SolverSymbol
fnm ProgramLoc
l) BaseTypeRepr ret
return_type
      (forall (x :: BaseType). TypeMap x -> IO ())
-> Assignment TypeMap args -> IO ()
forall k l (t :: (k -> Type) -> l -> Type) (m :: Type -> Type)
       (f :: k -> Type) a.
(FoldableFC t, Applicative m) =>
(forall (x :: k). f x -> m a) -> forall (x :: l). t f x -> m ()
traverseFC_ (WriterConn t h -> TypeMap x -> IO ()
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn) Assignment TypeMap args
arg_types
      WriterConn t h -> TypeMap ret -> IO ()
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn TypeMap ret
smt_ret
      WriterConn t h -> Command h -> IO ()
forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommand WriterConn t h
conn (Command h -> IO ()) -> Command h -> IO ()
forall a b. (a -> b) -> a -> b
$
        WriterConn t h
-> Text -> Assignment TypeMap args -> TypeMap ret -> Command h
forall h (f :: Type -> Type) (args :: Ctx BaseType)
       (rtp :: BaseType).
SMTWriter h =>
f h -> Text -> Assignment TypeMap args -> TypeMap rtp -> Command h
declareCommand WriterConn t h
conn Text
nm Assignment TypeMap args
arg_types TypeMap ret
smt_ret
      TypeMap ret -> IO (TypeMap ret)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (TypeMap ret -> IO (TypeMap ret))
-> TypeMap ret -> IO (TypeMap ret)
forall a b. (a -> b) -> a -> b
$! TypeMap ret
smt_ret
    DefinedFnInfo Assignment (ExprBoundVar t) args
arg_vars Expr t ret
return_value UnfoldPolicy
_ -> do
      WriterConn t h
-> Text
-> Assignment (ExprBoundVar t) args
-> Expr t ret
-> Assignment TypeMap args
-> IO (TypeMap ret)
forall h t (a :: Ctx BaseType) (r :: BaseType).
SMTWriter h =>
WriterConn t h
-> Text
-> Assignment (ExprBoundVar t) a
-> Expr t r
-> Assignment TypeMap a
-> IO (TypeMap r)
defineFn WriterConn t h
conn Text
nm Assignment (ExprBoundVar t) args
arg_vars Expr t ret
return_value Assignment TypeMap args
arg_types
    MatlabSolverFnInfo MatlabSolverFn (Expr t) args ret
_ Assignment (ExprBoundVar t) args
arg_vars Expr t ret
return_value -> do
      WriterConn t h
-> Text
-> Assignment (ExprBoundVar t) args
-> Expr t ret
-> Assignment TypeMap args
-> IO (TypeMap ret)
forall h t (a :: Ctx BaseType) (r :: BaseType).
SMTWriter h =>
WriterConn t h
-> Text
-> Assignment (ExprBoundVar t) a
-> Expr t r
-> Assignment TypeMap a
-> IO (TypeMap r)
defineFn WriterConn t h
conn Text
nm Assignment (ExprBoundVar t) args
arg_vars Expr t ret
return_value Assignment TypeMap args
arg_types

-- | Generate a SMTLIB function for a ExprBuilder function.
--
-- Since SimpleBuilder different simple builder values with the same type may
-- have different SMTLIB types (particularly arrays), getSMTSymFn requires the
-- argument types to call the function with.  This is enforced to be compatible
-- with the argument types expected by the simplebuilder.
--
-- This function caches the result, and we currently generate the function based
-- on the argument types provided the first time getSMTSymFn is called with a
-- particular simple builder function.  In subsequent calls, we validate that
-- the same argument types are provided.  In principal, a function could be
-- called with one type of arguments, and then be called with a different type
-- and this check would fail.  However, due to limitations in the solvers we
-- expect to support, this should never happen as the only time these may differ
-- when arrays are used and one array is encoded using the theory of arrays, while
-- the other uses a defined function.  However, SMTLIB2 does not allow functions
-- to be passed to other functions; yices does, but always encodes arrays as functions.
--
-- Returns the name of the function and the type of the result.
getSMTSymFn :: SMTWriter h
            => WriterConn t h
            -> ExprSymFn t args ret -- ^ Function to
            -> Ctx.Assignment TypeMap args
            -> IO (Text, TypeMap ret)
getSMTSymFn :: WriterConn t h
-> ExprSymFn t args ret
-> Assignment TypeMap args
-> IO (Text, TypeMap ret)
getSMTSymFn WriterConn t h
conn ExprSymFn t args ret
fn Assignment TypeMap args
arg_types = do
  let n :: Nonce t (args ::> ret)
n = ExprSymFn t args ret -> Nonce t (args ::> ret)
forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> Nonce t (args ::> ret)
symFnId ExprSymFn t args ret
fn
  WriterConn t h
-> Nonce t (args ::> ret) -> IO (Maybe (SMTSymFn (args ::> ret)))
forall t h (ctx :: Ctx BaseType).
WriterConn t h -> Nonce t ctx -> IO (Maybe (SMTSymFn ctx))
cacheLookupFn WriterConn t h
conn Nonce t (args ::> ret)
n IO (Maybe (SMTSymFn (args ::> ret)))
-> (Maybe (SMTSymFn (args ::> ret)) -> IO (Text, TypeMap ret))
-> IO (Text, TypeMap ret)
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just (SMTSymFn Text
nm Assignment TypeMap args
param_types TypeMap ret
ret) -> do
      Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Assignment TypeMap args
arg_types Assignment TypeMap args -> Assignment TypeMap args -> Bool
forall a. Eq a => a -> a -> Bool
/= Assignment TypeMap args
Assignment TypeMap args
param_types) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        String -> IO ()
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Illegal arguments to function " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack Text
nm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".\n"
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\tExpected arguments: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Assignment TypeMap args -> String
forall a. Show a => a -> String
show Assignment TypeMap args
param_types String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n"
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\tActual arguments: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Assignment TypeMap args -> String
forall a. Show a => a -> String
show Assignment TypeMap args
arg_types
      (Text, TypeMap ret) -> IO (Text, TypeMap ret)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text
nm, TypeMap ret
ret)
    Maybe (SMTSymFn (args ::> ret))
Nothing -> do
      -- Check argument types can be passed to a function.
      WriterConn t h -> Assignment TypeMap args -> IO ()
forall t h (args :: Ctx BaseType).
WriterConn t h -> Assignment TypeMap args -> IO ()
checkArgumentTypes WriterConn t h
conn Assignment TypeMap args
arg_types
      -- Generate name.
      Text
nm <- WriterConn t h -> SymbolBinding t -> IO Text
forall t h. WriterConn t h -> SymbolBinding t -> IO Text
getSymbolName WriterConn t h
conn (ExprSymFn t args ret -> SymbolBinding t
forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> SymbolBinding t
FnSymbolBinding ExprSymFn t args ret
fn)
      TypeMap ret
ret_type <- WriterConn t h
-> Text
-> ExprSymFn t args ret
-> Assignment TypeMap args
-> IO (TypeMap ret)
forall h t (args :: Ctx BaseType) (ret :: BaseType).
SMTWriter h =>
WriterConn t h
-> Text
-> ExprSymFn t args ret
-> Assignment TypeMap args
-> IO (TypeMap ret)
mkSMTSymFn WriterConn t h
conn Text
nm ExprSymFn t args ret
fn Assignment TypeMap args
arg_types
      WriterConn t h
-> Nonce t (args ::> ret)
-> TermLifetime
-> SMTSymFn (args ::> ret)
-> IO ()
forall t h (ctx :: Ctx BaseType).
WriterConn t h
-> Nonce t ctx -> TermLifetime -> SMTSymFn ctx -> IO ()
cacheValueFn WriterConn t h
conn Nonce t (args ::> ret)
n TermLifetime
DeleteNever (SMTSymFn (args ::> ret) -> IO ())
-> SMTSymFn (args ::> ret) -> IO ()
forall a b. (a -> b) -> a -> b
$! Text
-> Assignment TypeMap args
-> TypeMap ret
-> SMTSymFn (args ::> ret)
forall (args :: Ctx BaseType) (ret :: BaseType).
Text
-> Assignment TypeMap args
-> TypeMap ret
-> SMTSymFn (args ::> ret)
SMTSymFn Text
nm Assignment TypeMap args
arg_types TypeMap ret
ret_type
      (Text, TypeMap ret) -> IO (Text, TypeMap ret)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text
nm, TypeMap ret
ret_type)

------------------------------------------------------------------------
-- Writer high-level interface.

-- | Write a expression to SMT
mkSMTTerm :: SMTWriter h => WriterConn t h -> Expr t tp -> IO (Term h)
mkSMTTerm :: WriterConn t h -> Expr t tp -> IO (Term h)
mkSMTTerm WriterConn t h
conn Expr t tp
p = WriterConn t h -> SMTCollector t h (Term h) -> IO (Term h)
forall h t a.
SMTWriter h =>
WriterConn t h -> SMTCollector t h a -> IO a
runOnLiveConnection WriterConn t h
conn (SMTCollector t h (Term h) -> IO (Term h))
-> SMTCollector t h (Term h) -> IO (Term h)
forall a b. (a -> b) -> a -> b
$ Expr t tp -> SMTCollector t h (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t tp
p

-- | Write a logical expression.
mkFormula :: SMTWriter h => WriterConn t h -> BoolExpr t -> IO (Term h)
mkFormula :: WriterConn t h -> BoolExpr t -> IO (Term h)
mkFormula = WriterConn t h -> BoolExpr t -> IO (Term h)
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> Expr t tp -> IO (Term h)
mkSMTTerm

mkAtomicFormula :: SMTWriter h => WriterConn t h -> BoolExpr t -> IO Text
mkAtomicFormula :: WriterConn t h -> BoolExpr t -> IO Text
mkAtomicFormula WriterConn t h
conn BoolExpr t
p = WriterConn t h -> SMTCollector t h Text -> IO Text
forall h t a.
SMTWriter h =>
WriterConn t h -> SMTCollector t h a -> IO a
runOnLiveConnection WriterConn t h
conn (SMTCollector t h Text -> IO Text)
-> SMTCollector t h Text -> IO Text
forall a b. (a -> b) -> a -> b
$
  BoolExpr t -> SMTCollector t h (SMTExpr h BaseBoolType)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr BoolExpr t
p SMTCollector t h (SMTExpr h BaseBoolType)
-> (SMTExpr h BaseBoolType -> SMTCollector t h Text)
-> SMTCollector t h Text
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    SMTName TypeMap BaseBoolType
_ Text
nm  -> Text -> SMTCollector t h Text
forall (m :: Type -> Type) a. Monad m => a -> m a
return Text
nm
    SMTExpr TypeMap BaseBoolType
ty Term h
tm -> [(Text, Some TypeMap)]
-> TypeMap BaseBoolType -> Term h -> SMTCollector t h Text
forall (rtp :: BaseType) h t.
[(Text, Some TypeMap)]
-> TypeMap rtp -> Term h -> SMTCollector t h Text
freshBoundFn [] TypeMap BaseBoolType
ty Term h
tm

-- | Write assume formula predicates for asserting predicate holds.
assume :: SMTWriter h => WriterConn t h -> BoolExpr t -> IO ()
assume :: WriterConn t h -> BoolExpr t -> IO ()
assume WriterConn t h
c BoolExpr t
p = do
  [(BoolExpr t, Polarity)]
-> ((BoolExpr t, Polarity) -> IO ()) -> IO ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (BoolExpr t -> [(BoolExpr t, Polarity)]
forall t. Expr t BaseBoolType -> [(Expr t BaseBoolType, Polarity)]
asConjunction BoolExpr t
p) (((BoolExpr t, Polarity) -> IO ()) -> IO ())
-> ((BoolExpr t, Polarity) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(BoolExpr t
v,Polarity
pl) -> do
    Term h
f <- WriterConn t h -> BoolExpr t -> IO (Term h)
forall h t.
SMTWriter h =>
WriterConn t h -> BoolExpr t -> IO (Term h)
mkFormula WriterConn t h
c BoolExpr t
v
    WriterConn t h -> ProgramLoc -> IO ()
forall t h. WriterConn t h -> ProgramLoc -> IO ()
updateProgramLoc WriterConn t h
c (BoolExpr t -> ProgramLoc
forall t (tp :: BaseType). Expr t tp -> ProgramLoc
exprLoc BoolExpr t
v)
    case Polarity
pl of
      Polarity
BM.Positive -> WriterConn t h -> Term h -> IO ()
forall h t. SMTWriter h => WriterConn t h -> Term h -> IO ()
assumeFormula WriterConn t h
c Term h
f
      Polarity
BM.Negative -> WriterConn t h -> Term h -> IO ()
forall h t. SMTWriter h => WriterConn t h -> Term h -> IO ()
assumeFormula WriterConn t h
c (Term h -> Term h
forall v. SupportTermOps v => v -> v
notExpr Term h
f)

type SMTEvalBVArrayFn h w v =
    (1 <= w,
     1 <= v)
  => NatRepr w
  -> NatRepr v
  -> Term h
  -> IO (Maybe (GroundArray (Ctx.SingleCtx (BaseBVType w)) (BaseBVType v)))

newtype SMTEvalBVArrayWrapper h =
  SMTEvalBVArrayWrapper { SMTEvalBVArrayWrapper h
-> forall (w :: Nat) (v :: Nat).
   (1 <= w, 1 <= v) =>
   NatRepr w
   -> NatRepr v
   -> Term h
   -> IO
        (Maybe (GroundArray (SingleCtx (BaseBVType w)) (BaseBVType v)))
unEvalBVArrayWrapper :: forall w v. SMTEvalBVArrayFn h w v }

data SMTEvalFunctions h
   = SMTEvalFunctions { SMTEvalFunctions h -> Term h -> IO Bool
smtEvalBool :: Term h -> IO Bool
                        -- ^ Given a SMT term for a Boolean value, this should
                        -- whether the term is assigned true or false.
                      , SMTEvalFunctions h
-> forall (w :: Nat). NatRepr w -> Term h -> IO (BV w)
smtEvalBV   :: forall w . NatRepr w -> Term h -> IO (BV.BV w)
                        -- ^ Given a bitwidth, and a SMT term for a bitvector
                        -- with that bitwidth, this should return an unsigned
                        -- integer with the value of that bitvector.
                      , SMTEvalFunctions h -> Term h -> IO Rational
smtEvalReal :: Term h -> IO Rational
                        -- ^ Given a SMT term for real value, this should
                        -- return a rational value for that term.
                      , SMTEvalFunctions h
-> forall (fpp :: FloatPrecision).
   FloatPrecisionRepr fpp
   -> Term h -> IO (BV (FloatPrecisionBits fpp))
smtEvalFloat :: forall fpp . FloatPrecisionRepr fpp -> Term h -> IO (BV.BV (FloatPrecisionBits fpp))
                        -- ^ Given floating point format, and an SMT
                        -- term for a floating-point value in that
                        -- format, this returns an unsigned integer
                        -- with the bits of the IEEE-754
                        -- representation.
                      , SMTEvalFunctions h -> Maybe (SMTEvalBVArrayWrapper h)
smtEvalBvArray :: Maybe (SMTEvalBVArrayWrapper h)
                        -- ^ If 'Just', a function to read arrays whose domain
                        -- and codomain are both bitvectors. If 'Nothing',
                        -- signifies that we should fall back to index-selection
                        -- representation of arrays.
                      , SMTEvalFunctions h -> Term h -> IO ByteString
smtEvalString :: Term h -> IO ByteString
                        -- ^ Given a SMT term representing as sequence of bytes,
                        -- return the value as a bytestring.
                      }

-- | Used when we need two way communication with the solver.
class SMTWriter h => SMTReadWriter h where
  -- | Get functions for parsing values out of the solver.
  smtEvalFuns ::
    WriterConn t h -> Streams.InputStream Text -> SMTEvalFunctions h

  -- | Parse a set result from the solver's response.
  smtSatResult :: f h -> Streams.InputStream Text -> IO (SatResult () ())

  -- | Parse a list of names of assumptions that form an unsatisfiable core.
  --   These correspond to previously-named assertions.
  smtUnsatCoreResult :: f h -> Streams.InputStream Text -> IO [Text]

  -- | Parse a list of names of assumptions that form an unsatisfiable core.
  --   The boolean indicates the polarity of the atom: true for an ordinary
  --   atom, false for a negated atom.
  smtUnsatAssumptionsResult :: f h -> Streams.InputStream Text -> IO [(Bool,Text)]


-- | Return the terms associated with the given ground index variables.
smtIndicesTerms :: forall v idx
                .  SupportTermOps v
                => Ctx.Assignment TypeMap idx
                -> Ctx.Assignment GroundValueWrapper  idx
                -> [v]
smtIndicesTerms :: Assignment TypeMap idx -> Assignment GroundValueWrapper idx -> [v]
smtIndicesTerms Assignment TypeMap idx
tps Assignment GroundValueWrapper idx
vals = Int
-> Size idx
-> (forall (tp :: BaseType). Index idx tp -> [v] -> [v])
-> [v]
-> [v]
forall k (ctx :: Ctx k) r.
Int
-> Size ctx -> (forall (tp :: k). Index ctx tp -> r -> r) -> r -> r
Ctx.forIndexRange Int
0 Size idx
sz forall (tp :: BaseType). Index idx tp -> [v] -> [v]
f []
  where sz :: Size idx
sz = Assignment TypeMap idx -> Size idx
forall k (f :: k -> Type) (ctx :: Ctx k).
Assignment f ctx -> Size ctx
Ctx.size Assignment TypeMap idx
tps
        f :: Ctx.Index idx tp -> [v] -> [v]
        f :: Index idx tp -> [v] -> [v]
f Index idx tp
i [v]
l = (v
rv -> [v] -> [v]
forall a. a -> [a] -> [a]
:[v]
l)
         where GVW GroundValue tp
v = Assignment GroundValueWrapper idx
vals Assignment GroundValueWrapper idx
-> Index idx tp -> GroundValueWrapper tp
forall k (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
Assignment f ctx -> Index ctx tp -> f tp
Ctx.! Index idx tp
i
               r :: v
r = case Assignment TypeMap idx
tps Assignment TypeMap idx -> Index idx tp -> TypeMap tp
forall k (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
Assignment f ctx -> Index ctx tp -> f tp
Ctx.! Index idx tp
i of
                      TypeMap tp
IntegerTypeMap -> Rational -> v
forall v. SupportTermOps v => Rational -> v
rationalTerm (Integer -> Rational
forall a. Num a => Integer -> a
fromInteger Integer
GroundValue tp
v)
                      BVTypeMap NatRepr w
w -> NatRepr w -> BV w -> v
forall v (w :: Nat). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w BV w
GroundValue tp
v
                      TypeMap tp
_ -> String -> v
forall a. HasCallStack => String -> a
error String
"Do not yet support other index types."

getSolverVal :: forall h t tp
             .  SMTWriter h
             => WriterConn t h
             -> SMTEvalFunctions h
             -> TypeMap tp
             -> Term h
             -> IO (GroundValue tp)
getSolverVal :: WriterConn t h
-> SMTEvalFunctions h
-> TypeMap tp
-> Term h
-> IO (GroundValue tp)
getSolverVal WriterConn t h
_ SMTEvalFunctions h
smtFns TypeMap tp
BoolTypeMap   Term h
tm = SMTEvalFunctions h -> Term h -> IO Bool
forall h. SMTEvalFunctions h -> Term h -> IO Bool
smtEvalBool SMTEvalFunctions h
smtFns Term h
tm
getSolverVal WriterConn t h
_ SMTEvalFunctions h
smtFns (BVTypeMap NatRepr w
w) Term h
tm = SMTEvalFunctions h -> NatRepr w -> Term h -> IO (BV w)
forall h.
SMTEvalFunctions h
-> forall (w :: Nat). NatRepr w -> Term h -> IO (BV w)
smtEvalBV SMTEvalFunctions h
smtFns NatRepr w
w Term h
tm
getSolverVal WriterConn t h
_ SMTEvalFunctions h
smtFns TypeMap tp
RealTypeMap   Term h
tm = SMTEvalFunctions h -> Term h -> IO Rational
forall h. SMTEvalFunctions h -> Term h -> IO Rational
smtEvalReal SMTEvalFunctions h
smtFns Term h
tm
getSolverVal WriterConn t h
_ SMTEvalFunctions h
smtFns (FloatTypeMap FloatPrecisionRepr fpp
fpp) Term h
tm =
  BFOpts -> Integer -> BigFloat
bfFromBits (FloatPrecisionRepr fpp -> RoundingMode -> BFOpts
forall (fpp :: FloatPrecision).
FloatPrecisionRepr fpp -> RoundingMode -> BFOpts
fppOpts FloatPrecisionRepr fpp
fpp RoundingMode
RNE) (Integer -> BigFloat)
-> (BV (FloatPrecisionBits fpp) -> Integer)
-> BV (FloatPrecisionBits fpp)
-> BigFloat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BV (FloatPrecisionBits fpp) -> Integer
forall (w :: Nat). BV w -> Integer
BV.asUnsigned (BV (FloatPrecisionBits fpp) -> BigFloat)
-> IO (BV (FloatPrecisionBits fpp)) -> IO BigFloat
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SMTEvalFunctions h
-> FloatPrecisionRepr fpp
-> Term h
-> IO (BV (FloatPrecisionBits fpp))
forall h.
SMTEvalFunctions h
-> forall (fpp :: FloatPrecision).
   FloatPrecisionRepr fpp
   -> Term h -> IO (BV (FloatPrecisionBits fpp))
smtEvalFloat SMTEvalFunctions h
smtFns FloatPrecisionRepr fpp
fpp Term h
tm
getSolverVal WriterConn t h
_ SMTEvalFunctions h
smtFns TypeMap tp
Char8TypeMap Term h
tm = ByteString -> StringLiteral Char8
Char8Literal (ByteString -> StringLiteral Char8)
-> IO ByteString -> IO (StringLiteral Char8)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SMTEvalFunctions h -> Term h -> IO ByteString
forall h. SMTEvalFunctions h -> Term h -> IO ByteString
smtEvalString SMTEvalFunctions h
smtFns Term h
tm
getSolverVal WriterConn t h
_ SMTEvalFunctions h
smtFns TypeMap tp
IntegerTypeMap Term h
tm = do
  Rational
r <- SMTEvalFunctions h -> Term h -> IO Rational
forall h. SMTEvalFunctions h -> Term h -> IO Rational
smtEvalReal SMTEvalFunctions h
smtFns Term h
tm
  Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Rational -> Integer
forall a. Ratio a -> a
denominator Rational
r Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Expected integer value."
  Integer -> IO Integer
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Rational -> Integer
forall a. Ratio a -> a
numerator Rational
r)
getSolverVal WriterConn t h
_ SMTEvalFunctions h
smtFns TypeMap tp
ComplexToStructTypeMap Term h
tm =
  Rational -> Rational -> Complex Rational
forall a. a -> a -> Complex a
(:+) (Rational -> Rational -> Complex Rational)
-> IO Rational -> IO (Rational -> Complex Rational)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SMTEvalFunctions h -> Term h -> IO Rational
forall h. SMTEvalFunctions h -> Term h -> IO Rational
smtEvalReal SMTEvalFunctions h
smtFns (Term h -> Term h
forall h. SMTWriter h => Term h -> Term h
structComplexRealPart @h Term h
tm)
       IO (Rational -> Complex Rational)
-> IO Rational -> IO (Complex Rational)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> SMTEvalFunctions h -> Term h -> IO Rational
forall h. SMTEvalFunctions h -> Term h -> IO Rational
smtEvalReal SMTEvalFunctions h
smtFns (Term h -> Term h
forall h. SMTWriter h => Term h -> Term h
structComplexImagPart @h Term h
tm)
getSolverVal WriterConn t h
_ SMTEvalFunctions h
smtFns TypeMap tp
ComplexToArrayTypeMap Term h
tm =
  Rational -> Rational -> Complex Rational
forall a. a -> a -> Complex a
(:+) (Rational -> Rational -> Complex Rational)
-> IO Rational -> IO (Rational -> Complex Rational)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SMTEvalFunctions h -> Term h -> IO Rational
forall h. SMTEvalFunctions h -> Term h -> IO Rational
smtEvalReal SMTEvalFunctions h
smtFns (Term h -> Term h
forall h. SMTWriter h => Term h -> Term h
arrayComplexRealPart @h Term h
tm)
       IO (Rational -> Complex Rational)
-> IO Rational -> IO (Complex Rational)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> SMTEvalFunctions h -> Term h -> IO Rational
forall h. SMTEvalFunctions h -> Term h -> IO Rational
smtEvalReal SMTEvalFunctions h
smtFns (Term h -> Term h
forall h. SMTWriter h => Term h -> Term h
arrayComplexImagPart @h Term h
tm)
getSolverVal WriterConn t h
conn SMTEvalFunctions h
smtFns (PrimArrayTypeMap Assignment TypeMap (idxl ::> idx)
idx_types TypeMap tp
eltTp) Term h
tm
  | Just (SMTEvalBVArrayWrapper forall (w :: Nat) (v :: Nat). SMTEvalBVArrayFn h w v
evalBVArray) <- SMTEvalFunctions h -> Maybe (SMTEvalBVArrayWrapper h)
forall h. SMTEvalFunctions h -> Maybe (SMTEvalBVArrayWrapper h)
smtEvalBvArray SMTEvalFunctions h
smtFns
  , Assignment TypeMap ctx
Ctx.Empty Ctx.:> (BVTypeMap NatRepr w
w) <- Assignment TypeMap (idxl ::> idx)
idx_types
  , BVTypeMap NatRepr w
v <- TypeMap tp
eltTp =
      GroundArray (idxl ::> idx) tp
-> Maybe (GroundArray (idxl ::> idx) tp)
-> GroundArray (idxl ::> idx) tp
forall a. a -> Maybe a -> a
fromMaybe GroundArray (idxl ::> idx) tp
byIndex (Maybe (GroundArray (idxl ::> idx) tp)
 -> GroundArray (idxl ::> idx) tp)
-> IO (Maybe (GroundArray (idxl ::> idx) tp))
-> IO (GroundArray (idxl ::> idx) tp)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> NatRepr w
-> NatRepr w
-> Term h
-> IO
     (Maybe (GroundArray (SingleCtx (BaseBVType w)) (BaseBVType w)))
forall (w :: Nat) (v :: Nat). SMTEvalBVArrayFn h w v
evalBVArray NatRepr w
w NatRepr w
v Term h
tm
  | Bool
otherwise = GroundArray (idxl ::> idx) tp -> IO (GroundArray (idxl ::> idx) tp)
forall (m :: Type -> Type) a. Monad m => a -> m a
return GroundArray (idxl ::> idx) tp
byIndex
  where byIndex :: GroundArray (idxl ::> idx) tp
byIndex = (Assignment GroundValueWrapper (idxl ::> idx)
 -> IO (GroundValue tp))
-> GroundArray (idxl ::> idx) tp
forall (idx :: Ctx BaseType) (b :: BaseType).
(Assignment GroundValueWrapper idx -> IO (GroundValue b))
-> GroundArray idx b
ArrayMapping ((Assignment GroundValueWrapper (idxl ::> idx)
  -> IO (GroundValue tp))
 -> GroundArray (idxl ::> idx) tp)
-> (Assignment GroundValueWrapper (idxl ::> idx)
    -> IO (GroundValue tp))
-> GroundArray (idxl ::> idx) tp
forall a b. (a -> b) -> a -> b
$ \Assignment GroundValueWrapper (idxl ::> idx)
i -> do
          let res :: Term h
res = Term h -> [Term h] -> Term h
forall h. SMTWriter h => Term h -> [Term h] -> Term h
arraySelect @h Term h
tm (Assignment TypeMap (idxl ::> idx)
-> Assignment GroundValueWrapper (idxl ::> idx) -> [Term h]
forall v (idx :: Ctx BaseType).
SupportTermOps v =>
Assignment TypeMap idx -> Assignment GroundValueWrapper idx -> [v]
smtIndicesTerms Assignment TypeMap (idxl ::> idx)
idx_types Assignment GroundValueWrapper (idxl ::> idx)
i)
          WriterConn t h
-> SMTEvalFunctions h
-> TypeMap tp
-> Term h
-> IO (GroundValue tp)
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h
-> SMTEvalFunctions h
-> TypeMap tp
-> Term h
-> IO (GroundValue tp)
getSolverVal WriterConn t h
conn SMTEvalFunctions h
smtFns TypeMap tp
eltTp Term h
res
getSolverVal WriterConn t h
conn SMTEvalFunctions h
smtFns (FnArrayTypeMap Assignment TypeMap (idxl ::> idx)
idx_types TypeMap tp
eltTp) Term h
tm = GroundArray (idxl ::> idx) tp -> IO (GroundArray (idxl ::> idx) tp)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (GroundArray (idxl ::> idx) tp
 -> IO (GroundArray (idxl ::> idx) tp))
-> GroundArray (idxl ::> idx) tp
-> IO (GroundArray (idxl ::> idx) tp)
forall a b. (a -> b) -> a -> b
$ (Assignment GroundValueWrapper (idxl ::> idx)
 -> IO (GroundValue tp))
-> GroundArray (idxl ::> idx) tp
forall (idx :: Ctx BaseType) (b :: BaseType).
(Assignment GroundValueWrapper idx -> IO (GroundValue b))
-> GroundArray idx b
ArrayMapping ((Assignment GroundValueWrapper (idxl ::> idx)
  -> IO (GroundValue tp))
 -> GroundArray (idxl ::> idx) tp)
-> (Assignment GroundValueWrapper (idxl ::> idx)
    -> IO (GroundValue tp))
-> GroundArray (idxl ::> idx) tp
forall a b. (a -> b) -> a -> b
$ \Assignment GroundValueWrapper (idxl ::> idx)
i -> do
  let term :: Term h
term = Term h -> [Term h] -> Term h
forall v. SupportTermOps v => v -> [v] -> v
smtFnApp Term h
tm (Assignment TypeMap (idxl ::> idx)
-> Assignment GroundValueWrapper (idxl ::> idx) -> [Term h]
forall v (idx :: Ctx BaseType).
SupportTermOps v =>
Assignment TypeMap idx -> Assignment GroundValueWrapper idx -> [v]
smtIndicesTerms Assignment TypeMap (idxl ::> idx)
idx_types Assignment GroundValueWrapper (idxl ::> idx)
i)
  WriterConn t h
-> SMTEvalFunctions h
-> TypeMap tp
-> Term h
-> IO (GroundValue tp)
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h
-> SMTEvalFunctions h
-> TypeMap tp
-> Term h
-> IO (GroundValue tp)
getSolverVal WriterConn t h
conn SMTEvalFunctions h
smtFns TypeMap tp
eltTp Term h
term
getSolverVal WriterConn t h
conn SMTEvalFunctions h
smtFns (StructTypeMap Assignment TypeMap idx
flds0) Term h
tm =
          (forall (tp :: BaseType).
 Index idx tp -> TypeMap tp -> IO (GroundValueWrapper tp))
-> Assignment TypeMap idx -> IO (Assignment GroundValueWrapper idx)
forall k (m :: Type -> Type) (ctx :: Ctx k) (f :: k -> Type)
       (g :: k -> Type).
Applicative m =>
(forall (tp :: k). Index ctx tp -> f tp -> m (g tp))
-> Assignment f ctx -> m (Assignment g ctx)
Ctx.traverseWithIndex (Assignment TypeMap idx
-> Index idx tp -> TypeMap tp -> IO (GroundValueWrapper tp)
forall (ctx :: Ctx BaseType) (utp :: BaseType).
Assignment TypeMap ctx
-> Index ctx utp -> TypeMap utp -> IO (GroundValueWrapper utp)
f Assignment TypeMap idx
flds0) Assignment TypeMap idx
flds0
        where f :: Ctx.Assignment TypeMap ctx
                -> Ctx.Index ctx utp
                -> TypeMap utp
                -> IO (GroundValueWrapper utp)
              f :: Assignment TypeMap ctx
-> Index ctx utp -> TypeMap utp -> IO (GroundValueWrapper utp)
f Assignment TypeMap ctx
flds Index ctx utp
i TypeMap utp
tp = GroundValue utp -> GroundValueWrapper utp
forall (tp :: BaseType). GroundValue tp -> GroundValueWrapper tp
GVW (GroundValue utp -> GroundValueWrapper utp)
-> IO (GroundValue utp) -> IO (GroundValueWrapper utp)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterConn t h
-> SMTEvalFunctions h
-> TypeMap utp
-> Term h
-> IO (GroundValue utp)
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h
-> SMTEvalFunctions h
-> TypeMap tp
-> Term h
-> IO (GroundValue tp)
getSolverVal WriterConn t h
conn SMTEvalFunctions h
smtFns TypeMap utp
tp Term h
v
                where v :: Term h
v = Assignment TypeMap ctx -> Index ctx utp -> Term h -> Term h
forall h (args :: Ctx BaseType) (tp :: BaseType).
SMTWriter h =>
Assignment TypeMap args -> Index args tp -> Term h -> Term h
structProj @h Assignment TypeMap ctx
flds Index ctx utp
i Term h
tm

-- | The function creates a function for evaluating elts to concrete values
-- given a connection to an SMT solver along with some functions for evaluating
-- different types of terms to concrete values.
smtExprGroundEvalFn :: forall t h
                     . SMTWriter h
                    => WriterConn t h
                       -- ^ Connection to SMT solver.
                    -> SMTEvalFunctions h
                    -> IO (GroundEvalFn t)
smtExprGroundEvalFn :: WriterConn t h -> SMTEvalFunctions h -> IO (GroundEvalFn t)
smtExprGroundEvalFn WriterConn t h
conn SMTEvalFunctions h
smtFns = do
  -- Get solver features
  IdxCache t GroundValueWrapper
groundCache <- IO (IdxCache t GroundValueWrapper)
forall (m :: Type -> Type) t (f :: BaseType -> Type).
MonadIO m =>
m (IdxCache t f)
newIdxCache

  let cachedEval :: Expr t tp -> IO (GroundValue tp)
      cachedEval :: Expr t tp -> IO (GroundValue tp)
cachedEval Expr t tp
e =
        case Expr t tp -> Maybe (Nonce t tp)
forall t (tp :: BaseType). Expr t tp -> Maybe (Nonce t tp)
exprMaybeId Expr t tp
e of
          Maybe (Nonce t tp)
Nothing -> (forall (u :: BaseType). Expr t u -> IO (GroundValue u))
-> Expr t tp -> IO (GroundValue tp)
forall t (tp :: BaseType).
(forall (u :: BaseType). Expr t u -> IO (GroundValue u))
-> Expr t tp -> IO (GroundValue tp)
evalGroundExpr forall (u :: BaseType). Expr t u -> IO (GroundValue u)
cachedEval Expr t tp
e
          Just Nonce t tp
e_id -> (GroundValueWrapper tp -> GroundValue tp)
-> IO (GroundValueWrapper tp) -> IO (GroundValue tp)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap GroundValueWrapper tp -> GroundValue tp
forall (tp :: BaseType). GroundValueWrapper tp -> GroundValue tp
unGVW (IO (GroundValueWrapper tp) -> IO (GroundValue tp))
-> IO (GroundValueWrapper tp) -> IO (GroundValue tp)
forall a b. (a -> b) -> a -> b
$ IdxCache t GroundValueWrapper
-> Nonce t tp
-> IO (GroundValueWrapper tp)
-> IO (GroundValueWrapper tp)
forall (m :: Type -> Type) t (f :: BaseType -> Type)
       (tp :: BaseType).
MonadIO m =>
IdxCache t f -> Nonce t tp -> m (f tp) -> m (f tp)
idxCacheEval' IdxCache t GroundValueWrapper
groundCache Nonce t tp
e_id (IO (GroundValueWrapper tp) -> IO (GroundValueWrapper tp))
-> IO (GroundValueWrapper tp) -> IO (GroundValueWrapper tp)
forall a b. (a -> b) -> a -> b
$ (GroundValue tp -> GroundValueWrapper tp)
-> IO (GroundValue tp) -> IO (GroundValueWrapper tp)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap GroundValue tp -> GroundValueWrapper tp
forall (tp :: BaseType). GroundValue tp -> GroundValueWrapper tp
GVW (IO (GroundValue tp) -> IO (GroundValueWrapper tp))
-> IO (GroundValue tp) -> IO (GroundValueWrapper tp)
forall a b. (a -> b) -> a -> b
$ do
            -- See if we have bound the Expr e to a SMT expression.
            Maybe (SMTExpr h tp)
me <- WriterConn t h -> Nonce t tp -> IO (Maybe (SMTExpr h tp))
forall t h (tp :: BaseType).
WriterConn t h -> Nonce t tp -> IO (Maybe (SMTExpr h tp))
cacheLookupExpr WriterConn t h
conn Nonce t tp
e_id
            case Maybe (SMTExpr h tp)
me of
              -- Otherwise, try the evalGroundExpr function to evaluate a ground element.
              Maybe (SMTExpr h tp)
Nothing -> (forall (u :: BaseType). Expr t u -> IO (GroundValue u))
-> Expr t tp -> IO (GroundValue tp)
forall t (tp :: BaseType).
(forall (u :: BaseType). Expr t u -> IO (GroundValue u))
-> Expr t tp -> IO (GroundValue tp)
evalGroundExpr forall (u :: BaseType). Expr t u -> IO (GroundValue u)
cachedEval Expr t tp
e

              -- If so, try asking the solver for the value of SMT expression.
              Just (SMTName TypeMap tp
tp Text
nm) ->
                WriterConn t h
-> SMTEvalFunctions h
-> TypeMap tp
-> Term h
-> IO (GroundValue tp)
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h
-> SMTEvalFunctions h
-> TypeMap tp
-> Term h
-> IO (GroundValue tp)
getSolverVal WriterConn t h
conn SMTEvalFunctions h
smtFns TypeMap tp
tp (Text -> Term h
forall v. SupportTermOps v => Text -> v
fromText Text
nm)

              Just (SMTExpr TypeMap tp
tp Term h
expr) ->
                MaybeT IO (GroundValue tp) -> IO (Maybe (GroundValue tp))
forall (m :: Type -> Type) a. MaybeT m a -> m (Maybe a)
runMaybeT ((forall (u :: BaseType). Expr t u -> MaybeT IO (GroundValue u))
-> Expr t tp -> MaybeT IO (GroundValue tp)
forall t (tp :: BaseType).
(forall (u :: BaseType). Expr t u -> MaybeT IO (GroundValue u))
-> Expr t tp -> MaybeT IO (GroundValue tp)
tryEvalGroundExpr (IO (GroundValue u) -> MaybeT IO (GroundValue u)
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (GroundValue u) -> MaybeT IO (GroundValue u))
-> (Expr t u -> IO (GroundValue u))
-> Expr t u
-> MaybeT IO (GroundValue u)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr t u -> IO (GroundValue u)
forall (u :: BaseType). Expr t u -> IO (GroundValue u)
cachedEval) Expr t tp
e) IO (Maybe (GroundValue tp))
-> (Maybe (GroundValue tp) -> IO (GroundValue tp))
-> IO (GroundValue tp)
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  Just GroundValue tp
x  -> GroundValue tp -> IO (GroundValue tp)
forall (m :: Type -> Type) a. Monad m => a -> m a
return GroundValue tp
x
                  -- If we cannot compute the value ourself, query the
                  -- value from the solver directly instead.
                  Maybe (GroundValue tp)
Nothing -> WriterConn t h
-> SMTEvalFunctions h
-> TypeMap tp
-> Term h
-> IO (GroundValue tp)
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h
-> SMTEvalFunctions h
-> TypeMap tp
-> Term h
-> IO (GroundValue tp)
getSolverVal WriterConn t h
conn SMTEvalFunctions h
smtFns TypeMap tp
tp Term h
expr


  GroundEvalFn t -> IO (GroundEvalFn t)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (GroundEvalFn t -> IO (GroundEvalFn t))
-> GroundEvalFn t -> IO (GroundEvalFn t)
forall a b. (a -> b) -> a -> b
$ (forall (u :: BaseType). Expr t u -> IO (GroundValue u))
-> GroundEvalFn t
forall t.
(forall (tp :: BaseType). Expr t tp -> IO (GroundValue tp))
-> GroundEvalFn t
GroundEvalFn forall (u :: BaseType). Expr t u -> IO (GroundValue u)
cachedEval