{- |
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
              , strictParsing
              , connHandle
              , connInputHandle
              , smtWriterName
              )
  , connState
  , newWriterConn
  , resetEntryStack
  , popEntryStackToTop
  , entryStackHeight
  , pushEntryStack
  , popEntryStack
  , cacheLookupFnNameBimap
  , Command
  , addCommand
  , addCommandNoAck
  , addCommands
  , mkFreeVar
  , bindVarAsFree
  , TypeMap(..)
  , typeMap
  , freshBoundVarName
  , assumeFormula
  , assumeFormulaWithName
  , assumeFormulaWithFreshName
  , DefineStyle(..)
  , AcknowledgementAction(..)
  , ResponseStrictness(..)
  , parserStrictness
  , nullAcknowledgementAction
    -- * SyGuS
  , addSynthFun
  , addDeclareVar
  , addConstraint
    -- * 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 ((.>), Strict)
import           Control.Monad (forM_, unless, when)
import           Control.Monad.IO.Class
import           Control.Monad.Reader (ReaderT(..), asks)
import           Control.Monad.ST
import           Control.Monad.State.Strict (State, runState)
import           Control.Monad.Trans (MonadTrans(..))
import           Control.Monad.Trans.Maybe (MaybeT(..))
import           Data.Bimap (Bimap)
import qualified Data.Bimap as Bimap
import qualified Data.BitVector.Sized as BV
import qualified Data.Bits as Bits
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 qualified Data.Text.Lazy as Lazy
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           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 qualified What4.Config as CFG
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.UnaryBV as UnaryBV
import qualified What4.Expr.WeightedSum as WSum
import           What4.Interface (RoundingMode(..), stringInfo)
import           What4.ProblemFeatures
import           What4.ProgramLoc
import           What4.SatResult
import qualified What4.SemiRing as SR
import qualified What4.SpecialFunctions as SFn
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)
  UnicodeTypeMap :: TypeMap (BaseStringType Unicode)

  -- 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
UnicodeTypeMap           = String
"UnicodeTypeMap"
  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
forall (tp :: Ctx BaseType). Assignment TypeMap 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
forall (tp :: BaseType). TypeMap 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
forall (tp :: Ctx BaseType). Assignment TypeMap 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
forall (tp :: BaseType). TypeMap 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
forall (tp :: Ctx BaseType). Assignment TypeMap 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)
forall (a :: BaseType) (b :: BaseType).
TypeMap a -> TypeMap b -> Maybe (a :~: b)
testEquality TypeMap tp
x TypeMap tp
y)

instance TestEquality TypeMap where
  testEquality :: forall (a :: BaseType) (b :: BaseType).
TypeMap a -> TypeMap b -> Maybe (a :~: b)
testEquality TypeMap a
BoolTypeMap TypeMap b
BoolTypeMap = (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  testEquality TypeMap a
IntegerTypeMap TypeMap b
IntegerTypeMap = (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  testEquality TypeMap a
RealTypeMap TypeMap b
RealTypeMap = (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  testEquality TypeMap a
UnicodeTypeMap TypeMap b
UnicodeTypeMap = (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  testEquality (FloatTypeMap FloatPrecisionRepr fpp
x) (FloatTypeMap FloatPrecisionRepr fpp
y) = do
    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)
forall (a :: FloatPrecision) (b :: FloatPrecision).
FloatPrecisionRepr a -> FloatPrecisionRepr b -> Maybe (a :~: b)
testEquality FloatPrecisionRepr fpp
x FloatPrecisionRepr fpp
y
    return Refl
  testEquality (BVTypeMap NatRepr w
x) (BVTypeMap NatRepr w
y) = do
    Refl <- NatRepr w -> NatRepr w -> Maybe (w :~: w)
forall (a :: Natural) (b :: Natural).
NatRepr a -> NatRepr b -> Maybe (a :~: b)
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
    return Refl
  testEquality TypeMap a
ComplexToStructTypeMap TypeMap b
ComplexToStructTypeMap =
    (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  testEquality TypeMap a
ComplexToArrayTypeMap TypeMap b
ComplexToArrayTypeMap =
    (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
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
    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)
forall (a :: Ctx BaseType) (b :: Ctx BaseType).
Assignment TypeMap a -> Assignment TypeMap b -> Maybe (a :~: b)
testEquality Assignment TypeMap (idxl ::> idx)
xa Assignment TypeMap (idxl ::> idx)
ya
    Refl <- testEquality xr yr
    Just Refl
  testEquality (FnArrayTypeMap Assignment TypeMap (idxl ::> idx)
xa TypeMap tp
xr) (FnArrayTypeMap Assignment TypeMap (idxl ::> idx)
ya TypeMap tp
yr) = do
    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)
forall (a :: Ctx BaseType) (b :: Ctx BaseType).
Assignment TypeMap a -> Assignment TypeMap b -> Maybe (a :~: b)
testEquality Assignment TypeMap (idxl ::> idx)
xa Assignment TypeMap (idxl ::> idx)
ya
    Refl <- testEquality xr yr
    Just Refl
  testEquality (StructTypeMap Assignment TypeMap idx
x) (StructTypeMap Assignment TypeMap idx
y) = do
    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)
forall (a :: Ctx BaseType) (b :: Ctx BaseType).
Assignment TypeMap a -> Assignment TypeMap b -> Maybe (a :~: b)
testEquality Assignment TypeMap idx
x Assignment TypeMap idx
y
    Just Refl
  testEquality TypeMap a
_ TypeMap b
_ = Maybe (a :~: b)
forall a. Maybe a
Nothing

semiRingTypeMap :: SR.SemiRingRepr sr -> TypeMap (SR.SemiRingBase sr)
semiRingTypeMap :: forall (sr :: SemiRing).
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 (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
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 b a. (b -> a -> b) -> b -> [a] -> b
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 (w :: Natural). NatRepr w -> Natural -> Natural -> v -> v
forall v (w :: Natural).
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 (w :: Natural). NatRepr w -> BV w -> v
forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr 1
w1 (NatRepr 1 -> BV 1
forall (w :: Natural). (1 <= w) => NatRepr w -> BV w
BV.one NatRepr 1
w1))
    where w1 :: NatRepr 1
          w1 :: NatRepr 1
w1 = NatRepr 1
forall (n :: Natural). KnownNat n => NatRepr n
knownNat

  bvSumExpr :: NatRepr w -> [v] -> v
  bvSumExpr NatRepr w
w [] = NatRepr w -> BV w -> v
forall (w :: Natural). NatRepr w -> BV w -> v
forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> BV w
forall (w :: Natural). NatRepr w -> BV w
BV.zero NatRepr w
w)
  bvSumExpr NatRepr w
_ (v
h:[v]
r) = (v -> v -> v) -> v -> [v] -> v
forall b a. (b -> a -> b) -> b -> [a] -> b
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
  realTan :: v -> v

  realATan2 :: v -> v -> v

  realSinh :: v -> v
  realCosh :: v -> v
  realTanh :: 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 :: forall h. SMTWriter h => Term h -> Term h
structComplexRealPart Term h
c = 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 (n :: Natural) (ctx :: Ctx BaseType) (r :: BaseType).
Idx n ctx r =>
Index ctx r
forall {k} (n :: Natural) (ctx :: Ctx k) (r :: k).
Idx n ctx r =>
Index ctx r
Ctx.natIndex @0) Term h
c

structComplexImagPart :: forall h. SMTWriter h => Term h -> Term h
structComplexImagPart :: forall h. SMTWriter h => Term h -> Term h
structComplexImagPart Term h
c = 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 (n :: Natural) (ctx :: Ctx BaseType) (r :: BaseType).
Idx n ctx r =>
Index ctx r
forall {k} (n :: Natural) (ctx :: Ctx k) (r :: k).
Idx n ctx r =>
Index ctx r
Ctx.natIndex @1) Term h
c

arrayComplexRealPart :: forall h . SMTWriter h => Term h -> Term h
arrayComplexRealPart :: forall h. SMTWriter h => Term h -> Term h
arrayComplexRealPart Term h
c = 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 :: forall h. SMTWriter h => Term h -> Term h
arrayComplexImagPart Term h
c = 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 {t}. (IsString t, Semigroup t) => [t] -> t
go [Builder]
args
  where go :: [t] -> t
go [] = t
")"
        go (t
f:[t]
r) = t
" " t -> t -> t
forall a. Semigroup a => a -> a -> a
<> t
f t -> t -> t
forall a. Semigroup a => a -> a -> a
<> [t] -> t
go [t]
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 :: forall h (tp :: BaseType).
SupportTermOps (Term h) =>
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 :: forall h (tp :: BaseType). 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 :: Lens' WriterState Word64
nextTermIdx = (WriterState -> Word64)
-> (WriterState -> Word64 -> WriterState)
-> Lens' WriterState 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 = v })

-- | Last position written to file.
lastPosition :: Lens' WriterState Position
lastPosition :: Lens' WriterState Position
lastPosition = (WriterState -> Position)
-> (WriterState -> Position -> WriterState)
-> Lens' WriterState 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 = v })

-- | Position written to file.
position :: Lens' WriterState Position
position :: Lens' WriterState Position
position = (WriterState -> Position)
-> (WriterState -> Position -> WriterState)
-> Lens' WriterState 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 = v })

emptyState :: WriterState
emptyState :: WriterState
emptyState = 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
  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 Word64
nextTermIdx
  nextTermIdx += 1
  return $! (Lazy.toStrict $ Builder.toLazyText $ prefix <> Builder.decimal n)

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

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

data StackEntry t (h :: Type) = StackEntry
  { forall t h. StackEntry t h -> IdxCache t (SMTExpr h)
symExprCache :: !(IdxCache t (SMTExpr h))
  , forall t 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 { forall t h. WriterConn t h -> String
smtWriterName :: !String
               -- ^ Name of writer for error reporting purposes.

             , forall t h. WriterConn t h -> OutputStream Text
connHandle :: !(OutputStream Text)
               -- ^ Handle to write to

             , forall t h. 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.

             , forall t h. 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.
             , forall t h. 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.
             , forall t h. WriterConn t h -> Bool
supportQuantifiers :: !Bool
               -- ^ Allow the SMT writer to generate problems with quantifiers.
             , forall t h. WriterConn t h -> ResponseStrictness
strictParsing :: !ResponseStrictness
               -- ^ Be strict in parsing SMTLib2 responses; no
               -- verbosity or variants allowed
             , forall t h. WriterConn t h -> ProblemFeatures
supportedFeatures :: !ProblemFeatures
               -- ^ Indicates features supported by the solver.
             , forall t h. 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.
             , forall t h. WriterConn t h -> IORef WriterState
stateRef :: !(IORef WriterState)
               -- ^ Reference to current state
             , forall t h. WriterConn t h -> SymbolVarBimap t
varBindings :: !(SymbolVarBimap t)
               -- ^ Symbol variables.
             , forall t h. WriterConn t h -> h
connState :: !h
               -- ^ The specific connection information.
             , forall t h. 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 { forall t h.
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 :: forall t h. 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 a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ())

newStackEntry :: IO (StackEntry t h)
newStackEntry :: forall t h. IO (StackEntry t h)
newStackEntry = do
  exprCache <- IO (IdxCache t (SMTExpr h))
forall (m :: Type -> Type) t (f :: BaseType -> Type).
MonadIO m =>
m (IdxCache t f)
newIdxCache
  fnCache   <- stToIO $ PH.new
  return StackEntry
    { symExprCache = exprCache
    , symFnCache   = fnCache
    }

-- | Clear the entry stack, and start with a fresh one.
resetEntryStack :: WriterConn t h -> IO ()
resetEntryStack :: forall t h. WriterConn t h -> IO ()
resetEntryStack WriterConn t h
c = do
  entry <- IO (StackEntry t h)
forall t h. IO (StackEntry t h)
newStackEntry
  writeIORef (entryStack c) [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 :: forall t h. WriterConn t h -> IO Int
popEntryStackToTop WriterConn t h
c = do
  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 null stk then
    do entry <- newStackEntry
       writeIORef (entryStack c) [entry]
       return 0
  else
    do writeIORef (entryStack c) [last stk]
       return (length 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 :: forall t h. WriterConn t h -> IO Int
entryStackHeight WriterConn t h
c =
  do 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)
     return (length es - 1)

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

popEntryStack :: WriterConn t h -> IO ()
popEntryStack :: forall t h. WriterConn t h -> IO ()
popEntryStack WriterConn t h
c = do
  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 stk of
   []  -> String -> IO ()
forall a. String -> IO a
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 a. String -> IO a
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.
              -> ResponseStrictness
              -- ^ Be strict in parsing responses?
              -> 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 :: forall t cs.
OutputStream Text
-> InputStream Text
-> AcknowledgementAction t cs
-> String
-> ResponseStrictness
-> ProblemFeatures
-> SymbolVarBimap t
-> cs
-> IO (WriterConn t cs)
newWriterConn OutputStream Text
h InputStream Text
in_h AcknowledgementAction t cs
ack String
solver_name ResponseStrictness
beStrict ProblemFeatures
features SymbolVarBimap t
bindings cs
cs = do
  entry <- IO (StackEntry t cs)
forall t h. IO (StackEntry t h)
newStackEntry
  stk_ref <- newIORef [entry]
  r <- newIORef emptyState
  return $! WriterConn { smtWriterName = solver_name
                       , connHandle    = h
                       , connInputHandle = in_h
                       , supportFunctionDefs      = False
                       , supportFunctionArguments = False
                       , supportQuantifiers       = False
                       , strictParsing            = beStrict
                       , supportedFeatures        = features
                       , entryStack   = stk_ref
                       , stateRef     = r
                       , varBindings  = bindings
                       , connState    = cs
                       , consumeAcknowledgement = ack
                       }

-- | Strictness level for parsing solver responses.
data ResponseStrictness
  = Lenient  -- ^ allows other output preceeding recognized solver responses
  | Strict   -- ^ parse _only_ recognized solver responses; fail on anything else
  deriving (ResponseStrictness -> ResponseStrictness -> Bool
(ResponseStrictness -> ResponseStrictness -> Bool)
-> (ResponseStrictness -> ResponseStrictness -> Bool)
-> Eq ResponseStrictness
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ResponseStrictness -> ResponseStrictness -> Bool
== :: ResponseStrictness -> ResponseStrictness -> Bool
$c/= :: ResponseStrictness -> ResponseStrictness -> Bool
/= :: ResponseStrictness -> ResponseStrictness -> Bool
Eq, Int -> ResponseStrictness -> String -> String
[ResponseStrictness] -> String -> String
ResponseStrictness -> String
(Int -> ResponseStrictness -> String -> String)
-> (ResponseStrictness -> String)
-> ([ResponseStrictness] -> String -> String)
-> Show ResponseStrictness
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ResponseStrictness -> String -> String
showsPrec :: Int -> ResponseStrictness -> String -> String
$cshow :: ResponseStrictness -> String
show :: ResponseStrictness -> String
$cshowList :: [ResponseStrictness] -> String -> String
showList :: [ResponseStrictness] -> String -> String
Show)

-- | Given an optional override configuration option, return the SMT
-- response parsing strictness that should be applied based on the
-- override or thedefault strictSMTParsing configuration.
parserStrictness :: Maybe (CFG.ConfigOption BaseBoolType)
                 -> CFG.ConfigOption BaseBoolType
                 -> CFG.Config
                 -> IO ResponseStrictness
parserStrictness :: Maybe (ConfigOption BaseBoolType)
-> ConfigOption BaseBoolType -> Config -> IO ResponseStrictness
parserStrictness Maybe (ConfigOption BaseBoolType)
overrideOpt ConfigOption BaseBoolType
strictOpt Config
cfg = do
  ovr <- case Maybe (ConfigOption BaseBoolType)
overrideOpt of
           Maybe (ConfigOption BaseBoolType)
Nothing -> Maybe Bool -> IO (Maybe Bool)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe Bool
forall a. Maybe a
Nothing
           Just ConfigOption BaseBoolType
o -> OptionSetting BaseBoolType -> IO (Maybe Bool)
forall (tp :: BaseType) a.
Opt tp a =>
OptionSetting tp -> IO (Maybe a)
CFG.getMaybeOpt (OptionSetting BaseBoolType -> IO (Maybe Bool))
-> IO (OptionSetting BaseBoolType) -> IO (Maybe Bool)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< ConfigOption BaseBoolType
-> Config -> IO (OptionSetting BaseBoolType)
forall (tp :: BaseType).
ConfigOption tp -> Config -> IO (OptionSetting tp)
CFG.getOptionSetting ConfigOption BaseBoolType
o Config
cfg
  optval <- case ovr of
              Just Bool
v -> Maybe Bool -> IO (Maybe Bool)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe Bool -> IO (Maybe Bool)) -> Maybe Bool -> IO (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
v
              Maybe Bool
Nothing -> OptionSetting BaseBoolType -> IO (Maybe Bool)
forall (tp :: BaseType) a.
Opt tp a =>
OptionSetting tp -> IO (Maybe a)
CFG.getMaybeOpt (OptionSetting BaseBoolType -> IO (Maybe Bool))
-> IO (OptionSetting BaseBoolType) -> IO (Maybe Bool)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< ConfigOption BaseBoolType
-> Config -> IO (OptionSetting BaseBoolType)
forall (tp :: BaseType).
ConfigOption tp -> Config -> IO (OptionSetting tp)
CFG.getOptionSetting ConfigOption BaseBoolType
strictOpt Config
cfg
  return $ maybe Strict (\Bool
c -> if Bool
c then ResponseStrictness
Strict else ResponseStrictness
Lenient) optval


-- | 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
$c== :: TermLifetime -> TermLifetime -> Bool
== :: TermLifetime -> TermLifetime -> Bool
$c/= :: TermLifetime -> TermLifetime -> Bool
/= :: TermLifetime -> TermLifetime -> Bool
Eq)

cacheValue
  :: WriterConn t h
  -> TermLifetime
  -> (StackEntry t h -> IO ())
  -> IO ()
cacheValue :: forall t h.
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 a b. IO a -> (a -> IO b) -> IO b
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 :: forall t h a.
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 a b. IO a -> (a -> IO b) -> IO b
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


-- | Like 'findM', but also allows you to compute some additional information in the predicate.
firstJustM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b)
firstJustM :: forall (m :: Type -> Type) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m (Maybe b)
firstJustM a -> m (Maybe b)
_ [] = Maybe b -> m (Maybe b)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe b
forall a. Maybe a
Nothing
firstJustM a -> m (Maybe b)
p (a
x:[a]
xs) = m (Maybe b) -> (b -> m (Maybe b)) -> m (Maybe b) -> m (Maybe b)
forall (m :: Type -> Type) b a.
Monad m =>
m b -> (a -> m b) -> m (Maybe a) -> m b
maybeM ((a -> m (Maybe b)) -> [a] -> m (Maybe b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m (Maybe b)
firstJustM a -> m (Maybe b)
p [a]
xs) (Maybe b -> m (Maybe b)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe b -> m (Maybe b)) -> (b -> Maybe b) -> b -> m (Maybe b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Maybe b
forall a. a -> Maybe a
Just) (a -> m (Maybe b)
p a
x)
{-# INLINE firstJustM #-}

-- | Monadic generalisation of 'maybe'.
maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b
maybeM :: forall (m :: Type -> Type) b a.
Monad m =>
m b -> (a -> m b) -> m (Maybe a) -> m b
maybeM m b
n a -> m b
j m (Maybe a)
x = m b -> (a -> m b) -> Maybe a -> m b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m b
n a -> m b
j (Maybe a -> m b) -> m (Maybe a) -> m b
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Maybe a)
x
{-# INLINE maybeM #-}

-- | Like 'when', but where the test can be monadic.
whenM :: Monad m => m Bool -> m () -> m ()
whenM :: forall (m :: Type -> Type). Monad m => m Bool -> m () -> m ()
whenM m Bool
b m ()
t = do b' <- m Bool
b; when b' t
{-# INLINE whenM #-}

cacheLookupExpr :: WriterConn t h -> Nonce t tp -> IO (Maybe (SMTExpr h tp))
cacheLookupExpr :: 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 = 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 :: forall t h (ctx :: Ctx BaseType).
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 :: forall t h (tp :: BaseType).
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 :: forall t h (ctx :: Ctx BaseType).
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

-- | Construct a function/name bimap. Each function is associated with its
-- cached name if there is one, otherwise with its original name.
cacheLookupFnNameBimap :: WriterConn t h -> [SomeExprSymFn t] -> IO (Bimap (SomeExprSymFn t) Text)
cacheLookupFnNameBimap :: forall t h.
WriterConn t h
-> [SomeExprSymFn t] -> IO (Bimap (SomeExprSymFn t) Text)
cacheLookupFnNameBimap WriterConn t h
conn [SomeExprSymFn t]
fns = [(SomeExprSymFn t, Text)] -> Bimap (SomeExprSymFn t) Text
forall a b. (Ord a, Ord b) => [(a, b)] -> Bimap a b
Bimap.fromList ([(SomeExprSymFn t, Text)] -> Bimap (SomeExprSymFn t) Text)
-> IO [(SomeExprSymFn t, Text)]
-> IO (Bimap (SomeExprSymFn t) Text)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (SomeExprSymFn t -> IO (SomeExprSymFn t, Text))
-> [SomeExprSymFn t] -> IO [(SomeExprSymFn t, Text)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM
  (\some_fn :: SomeExprSymFn t
some_fn@(SomeExprSymFn ExprSymFn t args ret
fn) -> do
    maybe_smt_sym_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) -> IO (Maybe (SMTSymFn (args ::> ret))))
-> Nonce t (args ::> ret) -> IO (Maybe (SMTSymFn (args ::> ret)))
forall a b. (a -> b) -> a -> b
$ 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
    return $ case maybe_smt_sym_fn of
      Just (SMTSymFn Text
nm Assignment TypeMap args
_ TypeMap ret
_) -> (SomeExprSymFn t
some_fn, Text
nm)
      Maybe (SMTSymFn (args ::> ret))
Nothing -> (SomeExprSymFn t
some_fn, SolverSymbol -> Text
solverSymbolAsText (SolverSymbol -> Text) -> SolverSymbol -> Text
forall a b. (a -> b) -> a -> b
$ ExprSymFn t args ret -> SolverSymbol
forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> SolverSymbol
symFnName ExprSymFn t args ret
fn))
  [SomeExprSymFn t]
fns

-- | Run state with handle.
withWriterState :: WriterConn t h -> State WriterState a -> IO a
withWriterState :: forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
c State WriterState a
m = do
  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 (v,s) = runState m s0
  writeIORef (stateRef c) $! s
  return v

-- | Update the current program location to the given one.
updateProgramLoc :: WriterConn t h -> ProgramLoc -> IO ()
updateProgramLoc :: forall t h. 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 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

  -- | Generates command @(push 1)@ that opens the corresponding assertion frame
  pushCommand   :: f h -> Command h

  -- | Generates command @(pop 1)@ that closes the corresponding assertion frame
  popCommand    :: f h -> Command h

  -- | Generates command @(push 2)@ that opens the corresponding assertion frame
  push2Command   :: f h -> Command h

  -- | Generates command @(pop 2)@ that closes the corresponding assertion frame, used for abduction
  pop2Command    :: 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
forall (f :: Type -> Type). 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

  -- | Ask the solver to return an abduct
  getAbductCommand :: f h -> Text -> Term h -> Command h

  -- | Ask the solver for the next abduct, used after a get-abduct command
  getAbductNextCommand :: 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 new SyGuS function to synthesize with the given name,
  -- arguments, and result type.
  synthFunCommand :: f h
                  -> Text
                  -> [(Text, Some TypeMap)]
                  -> TypeMap tp
                  -> Command h

  -- | Declare a new SyGuS universal variables with the given name and type.
  declareVarCommand :: f h
                    -> Text
                    -> TypeMap tp
                    -> Command h

  -- | Add a SyGuS formula to the set of synthesis constraints.
  constraintCommand :: f h -> 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 :: Text -> 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 :: forall h t. SMTWriter h => 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 :: forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommandNoAck WriterConn t h
conn Command h
cmd = do
  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 Position
lastPosition
  cur <- withWriterState conn $ use position

  -- If the position of the last command differs from the current position, then
  -- write the current position and update the last position.
  when (las /= cur) $ do
    writeCommand conn $ commentCommand conn $ Builder.fromText $ Text.pack $ show $ pretty cur
    withWriterState conn $ lastPosition .= cur

  writeCommand conn cmd

-- | Write a sequence of commands. All but the last should have
-- acknowledgement.
addCommands :: SMTWriter h => WriterConn t h -> [Command h] -> IO ()
addCommands :: forall h t. SMTWriter h => WriterConn t h -> [Command h] -> IO ()
addCommands WriterConn t h
_ [] = String -> IO ()
forall a. String -> IO a
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. HasCallStack => [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. HasCallStack => [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 :: 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 args
arg_types TypeMap rtp
return_type = do
  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
  traverseFC_ (declareTypes conn) arg_types
  declareTypes conn return_type
  addCommand conn $ declareCommand conn var arg_types return_type
  return var

mkFreeVar' :: SMTWriter h => WriterConn t h -> TypeMap tp -> IO (SMTExpr h tp)
mkFreeVar' :: forall h t (tp :: BaseType).
SMTWriter h =>
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 :: forall h t (tp :: BaseType).
SMTWriter h =>
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 a b. IO a -> (a -> IO b) -> IO b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just SMTExpr h tp
_ -> String -> IO ()
forall a. String -> IO a
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
      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
      var_name <- getSymbolName conn (VarSymbolBinding var)
      declareTypes conn smt_type
      addCommand conn $ declareCommand conn var_name Ctx.empty smt_type
      cacheValueExpr conn (bvarId var) DeleteOnPop $ SMTName smt_type var_name

-- | Assume that the given formula holds.
assumeFormula :: SMTWriter h => WriterConn t h -> Term h -> IO ()
assumeFormula :: forall h t. SMTWriter h => 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
forall (f :: Type -> Type). 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 :: forall h t.
SMTWriter h =>
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 a. String -> IO a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc (ZonkAny 5) -> String
forall a. Show a => a -> String
show (Doc (ZonkAny 5) -> String) -> Doc (ZonkAny 5) -> String
forall a b. (a -> b) -> a -> b
$ String -> Doc (ZonkAny 5)
forall ann. String -> Doc ann
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 (ZonkAny 5) -> Doc (ZonkAny 5) -> Doc (ZonkAny 5)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc (ZonkAny 5)
"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
forall (f :: Type -> Type). 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 :: forall h t. SMTWriter h => WriterConn t h -> Term h -> IO Text
assumeFormulaWithFreshName WriterConn t h
conn Term h
p =
  do 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
     assumeFormulaWithName conn p var
     return var

addSynthFun ::
  SMTWriter h =>
  WriterConn t h ->
  ExprSymFn t args ret ->
  IO ()
addSynthFun :: forall h t (args :: Ctx BaseType) (ret :: BaseType).
SMTWriter h =>
WriterConn t h -> ExprSymFn t args ret -> IO ()
addSynthFun WriterConn t h
conn 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 (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) IO (Maybe (SMTSymFn (args ::> ret)))
-> (Maybe (SMTSymFn (args ::> ret)) -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just{} ->
      String -> IO ()
forall a. String -> IO a
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: function already declared."
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Nonce t (args ::> ret) -> String
forall a. Show a => a -> String
show (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) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" declared at "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Position -> String
forall a. Show a => a -> String
show (ProgramLoc -> Position
plSourceLoc (ExprSymFn t args ret -> ProgramLoc
forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> ProgramLoc
symFnLoc ExprSymFn t args ret
fn)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
    Maybe (SMTSymFn (args ::> ret))
Nothing -> 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
fn of
      UninterpFnInfo Assignment BaseTypeRepr args
arg_types BaseTypeRepr ret
ret_type -> do
        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)
        let fn_source = SolverSymbol -> ProgramLoc -> SMTSource (ZonkAny 6)
forall ann. SolverSymbol -> ProgramLoc -> SMTSource ann
fnSource (ExprSymFn t args ret -> SolverSymbol
forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> SolverSymbol
symFnName ExprSymFn t args ret
fn) (ExprSymFn t args ret -> ProgramLoc
forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> ProgramLoc
symFnLoc ExprSymFn t args ret
fn)
        smt_arg_types <- traverseFC (evalFirstClassTypeRepr conn fn_source) arg_types
        checkArgumentTypes conn smt_arg_types
        smt_ret_type <- evalFirstClassTypeRepr conn fn_source ret_type
        traverseFC_ (declareTypes conn) smt_arg_types
        declareTypes conn smt_ret_type
        smt_args <- mapM
          (\(Some TypeMap x
tp) -> do
            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
            return (var, Some tp))
          (toListFC Some smt_arg_types)
        addCommand conn $ synthFunCommand conn nm smt_args smt_ret_type
        cacheValueFn conn (symFnId fn) DeleteNever $! SMTSymFn nm smt_arg_types smt_ret_type
      DefinedFnInfo{} ->
        String -> IO ()
forall a. String -> IO a
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: defined functions cannot be synthesized."
      MatlabSolverFnInfo{} ->
        String -> IO ()
forall a. String -> IO a
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: MatlabSolver functions cannot be synthesized."

addDeclareVar ::
  SMTWriter h =>
  WriterConn t h ->
  ExprBoundVar t tp ->
  IO ()
addDeclareVar :: forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> ExprBoundVar t tp -> IO ()
addDeclareVar WriterConn t h
conn ExprBoundVar t tp
var =
  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 a b. IO a -> (a -> IO b) -> IO b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just{} ->
      String -> IO ()
forall a. String -> IO a
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: variable already declared."
        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
" declared 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
      nm <- 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)
      let fn_source = SolverSymbol -> ProgramLoc -> SMTSource (ZonkAny 7)
forall ann. SolverSymbol -> ProgramLoc -> SMTSource ann
fnSource (ExprBoundVar t tp -> SolverSymbol
forall t (tp :: BaseType). ExprBoundVar t tp -> SolverSymbol
bvarName ExprBoundVar t tp
var) (ExprBoundVar t tp -> ProgramLoc
forall t (tp :: BaseType). ExprBoundVar t tp -> ProgramLoc
bvarLoc ExprBoundVar t tp
var)
      smt_type <- evalFirstClassTypeRepr conn fn_source $ bvarType var
      declareTypes conn smt_type
      addCommand conn $ declareVarCommand conn nm smt_type
      cacheValueExpr conn (bvarId var) DeleteNever $! SMTName smt_type nm

addConstraint :: SMTWriter h => WriterConn t h -> BoolExpr t -> IO ()
addConstraint :: forall h t. SMTWriter h => WriterConn t h -> BoolExpr t -> IO ()
addConstraint WriterConn t h
conn BoolExpr t
p = do
  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
conn BoolExpr t
p
  updateProgramLoc conn (exprLoc p)
  addCommand conn $ constraintCommand conn f

-- | 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 :: forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn = \case
  TypeMap tp
BoolTypeMap -> () -> IO ()
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
  TypeMap tp
IntegerTypeMap -> () -> IO ()
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
  TypeMap tp
RealTypeMap    -> () -> IO ()
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
  BVTypeMap NatRepr w
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
  FloatTypeMap FloatPrecisionRepr fpp
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
  TypeMap tp
UnicodeTypeMap -> () -> IO ()
forall a. a -> IO a
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 ()
forall t (args :: Ctx BaseType).
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 a. a -> IO a
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 ())
-> forall (x :: Ctx BaseType). Assignment TypeMap x -> 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 -> Assignment TypeMap (idxl ::> idx) -> IO ()
forall h t (args :: Ctx BaseType).
SMTWriter h =>
WriterConn t h -> Assignment TypeMap args -> IO ()
forall t (args :: Ctx BaseType).
WriterConn t h -> Assignment TypeMap args -> IO ()
declareStructDatatype 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 ())
-> forall (x :: Ctx BaseType). Assignment TypeMap x -> 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 ())
-> forall (x :: Ctx BaseType). Assignment TypeMap x -> 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 ()
forall t (args :: Ctx BaseType).
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
$c== :: DefineStyle -> DefineStyle -> Bool
== :: DefineStyle -> DefineStyle -> Bool
$c/= :: DefineStyle -> DefineStyle -> Bool
/= :: 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
$cshowsPrec :: Int -> DefineStyle -> String -> String
showsPrec :: Int -> DefineStyle -> String -> String
$cshow :: DefineStyle -> String
show :: DefineStyle -> String
$cshowList :: [DefineStyle] -> String -> String
showList :: [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 :: 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
  | 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
forall (f :: Type -> Type) (rtp :: BaseType).
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 a. [a] -> 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 a. String -> IO a
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
forall (f :: Type -> Type) (args :: Ctx BaseType)
       (rtp :: BaseType).
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 :: forall h t (rtp :: BaseType).
SMTWriter h =>
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
  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
  defineSMTVar conn defSty var args return_type expr
  return 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
    { forall t h. SMTCollectorState t h -> WriterConn t h
scConn :: !(WriterConn t h)
    , forall 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'.
    , forall t h. SMTCollectorState t h -> Maybe (FreshVarFn h)
freshConstantFn  :: !(Maybe (FreshVarFn h))
    , forall t 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 :: forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
nm TypeMap tp
tpr = do
  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 mf of
   Maybe (FreshVarFn h)
Nothing -> do
     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
     liftIO $ do
     loc <- withWriterState conn $ use position
     fail $ "Cannot create the free constant within a function needed to define the "
       ++ nm ++ " term created at " ++ show loc ++ "."
   Just (FreshVarFn forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp)
f) ->
    IO (SMTExpr h tp)
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a. IO a -> ReaderT (SMTCollectorState t h) IO a
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
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 :: forall t h (tp :: BaseType).
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 tp
Assignment TypeMap (idx ::> tp)
-> TypeMap xs -> TypeMap ('BaseArrayType (idx ::> tp) xs)
forall (idx :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
Assignment TypeMap (idx ::> idx)
-> TypeMap tp -> TypeMap (BaseArrayType (idx ::> idx) tp)
FnArrayTypeMap (Assignment TypeMap (idx ::> tp) -> TypeMap xs -> TypeMap tp)
-> Either BaseTypeError (Assignment TypeMap (idx ::> tp))
-> Either BaseTypeError (TypeMap xs -> TypeMap tp)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (x :: BaseType).
 BaseTypeRepr x -> Either BaseTypeError (TypeMap x))
-> forall (x :: Ctx BaseType).
   Assignment BaseTypeRepr x
   -> Either BaseTypeError (Assignment TypeMap x)
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)
forall (f :: BaseType -> Type) (g :: BaseType -> Type)
       (m :: Type -> Type).
Applicative m =>
(forall (x :: BaseType). f x -> m (g x))
-> forall (x :: Ctx BaseType). Assignment f x -> m (Assignment 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 tp)
-> Either BaseTypeError (TypeMap xs)
-> Either BaseTypeError (TypeMap tp)
forall a b.
Either BaseTypeError (a -> b)
-> Either BaseTypeError a -> Either BaseTypeError b
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 :: forall t h (tp :: BaseType).
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 tp -> Either BaseTypeError (TypeMap tp)
forall a b. b -> Either a b
Right TypeMap tp
TypeMap BaseBoolType
BoolTypeMap
    BaseBVRepr NatRepr w
w -> TypeMap tp -> Either BaseTypeError (TypeMap tp)
forall a b. b -> Either a b
Right (TypeMap tp -> Either BaseTypeError (TypeMap tp))
-> TypeMap tp -> Either BaseTypeError (TypeMap tp)
forall a b. (a -> b) -> a -> b
$! NatRepr w -> TypeMap ('BaseBVType w)
forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w
    BaseFloatRepr FloatPrecisionRepr fpp
fpp -> TypeMap tp -> Either BaseTypeError (TypeMap tp)
forall a b. b -> Either a b
Right (TypeMap tp -> Either BaseTypeError (TypeMap tp))
-> TypeMap tp -> Either BaseTypeError (TypeMap tp)
forall a b. (a -> b) -> a -> b
$! FloatPrecisionRepr fpp -> TypeMap ('BaseFloatType fpp)
forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp
    BaseTypeRepr tp
BaseRealRepr -> TypeMap tp -> Either BaseTypeError (TypeMap tp)
forall a b. b -> Either a b
Right TypeMap tp
TypeMap 'BaseRealType
RealTypeMap
    BaseTypeRepr tp
BaseIntegerRepr -> TypeMap tp -> Either BaseTypeError (TypeMap tp)
forall a b. b -> Either a b
Right TypeMap tp
TypeMap 'BaseIntegerType
IntegerTypeMap
    BaseStringRepr StringInfoRepr si
UnicodeRepr -> TypeMap tp -> Either BaseTypeError (TypeMap tp)
forall a b. b -> Either a b
Right TypeMap tp
TypeMap ('BaseStringType Unicode)
UnicodeTypeMap
    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 tp -> Either BaseTypeError (TypeMap tp)
forall a b. b -> Either a b
Right TypeMap tp
TypeMap 'BaseComplexType
ComplexToStructTypeMap
      | ProblemFeatures
feat ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useSymbolicArrays -> TypeMap tp -> Either BaseTypeError (TypeMap tp)
forall a b. b -> Either a b
Right TypeMap tp
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 (idx :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
Assignment TypeMap (idx ::> idx)
-> TypeMap tp -> TypeMap (BaseArrayType (idx ::> idx) tp)
PrimArrayTypeMap
                    else Assignment TypeMap (idx ::> tp)
-> TypeMap xs -> TypeMap ('BaseArrayType (idx ::> tp) xs)
forall (idx :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
Assignment TypeMap (idx ::> idx)
-> TypeMap tp -> TypeMap (BaseArrayType (idx ::> idx) tp)
FnArrayTypeMap
      Assignment TypeMap (idx ::> tp) -> TypeMap xs -> TypeMap tp
Assignment TypeMap (idx ::> tp)
-> TypeMap xs -> TypeMap ('BaseArrayType (idx ::> tp) xs)
mkArray (Assignment TypeMap (idx ::> tp) -> TypeMap xs -> TypeMap tp)
-> Either BaseTypeError (Assignment TypeMap (idx ::> tp))
-> Either BaseTypeError (TypeMap xs -> TypeMap tp)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (x :: BaseType).
 BaseTypeRepr x -> Either BaseTypeError (TypeMap x))
-> forall (x :: Ctx BaseType).
   Assignment BaseTypeRepr x
   -> Either BaseTypeError (Assignment TypeMap x)
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)
forall (f :: BaseType -> Type) (g :: BaseType -> Type)
       (m :: Type -> Type).
Applicative m =>
(forall (x :: BaseType). f x -> m (g x))
-> forall (x :: Ctx BaseType). Assignment f x -> m (Assignment 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 tp)
-> Either BaseTypeError (TypeMap xs)
-> Either BaseTypeError (TypeMap tp)
forall a b.
Either BaseTypeError (a -> b)
-> Either BaseTypeError a -> Either BaseTypeError b
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 tp
Assignment TypeMap ctx -> TypeMap ('BaseStructType ctx)
forall (idx :: Ctx BaseType).
Assignment TypeMap idx -> TypeMap (BaseStructType idx)
StructTypeMap (Assignment TypeMap ctx -> TypeMap tp)
-> Either BaseTypeError (Assignment TypeMap ctx)
-> Either BaseTypeError (TypeMap tp)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (x :: BaseType).
 BaseTypeRepr x -> Either BaseTypeError (TypeMap x))
-> forall (x :: Ctx BaseType).
   Assignment BaseTypeRepr x
   -> Either BaseTypeError (Assignment TypeMap x)
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)
forall (f :: BaseType -> Type) (g :: BaseType -> Type)
       (m :: Type -> Type).
Applicative m =>
(forall (x :: BaseType). f x -> m (g x))
-> forall (x :: Ctx BaseType). Assignment f x -> m (Assignment 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 :: forall t (tp :: BaseType) h.
ExprBoundVar t tp -> SMTCollector t h (TypeMap tp)
getBaseSMT_Type ExprBoundVar t tp
v = do
  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
typename =
        Doc (ZonkAny 3) -> String
forall a. Show a => a -> String
show
          (Doc (ZonkAny 3) -> String) -> Doc (ZonkAny 3) -> String
forall a b. (a -> b) -> a -> b
$   SolverSymbol -> Doc (ZonkAny 3)
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 (ZonkAny 3) -> Doc (ZonkAny 3) -> Doc (ZonkAny 3)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc (ZonkAny 3)
"is a"
          Doc (ZonkAny 3) -> Doc (ZonkAny 3) -> Doc (ZonkAny 3)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc (ZonkAny 3)
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
typename
          Doc (ZonkAny 3) -> Doc (ZonkAny 3) -> Doc (ZonkAny 3)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc (ZonkAny 3)
"variable, and we do not support this with"
          Doc (ZonkAny 3) -> Doc (ZonkAny 3) -> Doc (ZonkAny 3)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc (ZonkAny 3)
forall ann. String -> Doc ann
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 typeMap conn (bvarType v) of
    Left  (StringTypeUnsupported (Some StringInfoRepr x
si)) -> String -> ReaderT (SMTCollectorState t h) IO (TypeMap tp)
forall a. String -> ReaderT (SMTCollectorState t h) IO a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> ReaderT (SMTCollectorState t h) IO (TypeMap tp))
-> String -> ReaderT (SMTCollectorState t h) IO (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 -> ReaderT (SMTCollectorState t h) IO (TypeMap tp)
forall a. String -> ReaderT (SMTCollectorState t h) IO a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> ReaderT (SMTCollectorState t h) IO (TypeMap tp))
-> String -> ReaderT (SMTCollectorState t h) IO (TypeMap tp)
forall a b. (a -> b) -> a -> b
$ String -> String
errMsg String
"complex"
    Left  BaseTypeError
ArrayUnsupported       -> String -> ReaderT (SMTCollectorState t h) IO (TypeMap tp)
forall a. String -> ReaderT (SMTCollectorState t h) IO a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> ReaderT (SMTCollectorState t h) IO (TypeMap tp))
-> String -> ReaderT (SMTCollectorState t h) IO (TypeMap tp)
forall a b. (a -> b) -> a -> b
$ String -> String
errMsg String
"array"
    Right TypeMap tp
smtType                -> TypeMap tp -> ReaderT (SMTCollectorState t h) IO (TypeMap tp)
forall a. a -> ReaderT (SMTCollectorState t h) IO a
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 :: forall (rtp :: BaseType) h t.
[(Text, Some TypeMap)]
-> TypeMap rtp -> Term h -> SMTCollector t h Text
freshBoundFn [(Text, Some TypeMap)]
args TypeMap rtp
tp Term h
t = do
  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
  f <- asks $ \SMTCollectorState t h
x -> SMTCollectorState t h
-> forall (rtp :: BaseType).
   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 SMTCollectorState t h
x
  liftIO $ do
    var <- withWriterState conn $ freshVarName
    f var args tp t
    return 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 :: forall (tp :: BaseType) h t.
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
-> ReaderT (SMTCollectorState t h) IO (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' :: forall h (tp :: BaseType) t.
SupportTermOps (Term h) =>
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
-> ReaderT (SMTCollectorState t h) IO (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 :: forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
nm Term h
t = do
  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
  mf <- asks recordSideCondFn
  loc <- liftIO $ withWriterState conn $ use position
  case mf of
   Just Term h -> IO ()
f ->
     IO () -> ReaderT (SMTCollectorState t h) IO ()
forall a. IO a -> ReaderT (SMTCollectorState t h) IO a
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
$ Term h -> IO ()
f Term h
t
   Maybe (Term h -> IO ())
Nothing -> do
     String -> ReaderT (SMTCollectorState t h) IO ()
forall a. String -> ReaderT (SMTCollectorState t h) IO a
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
"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 :: forall t h (tp :: BaseType).
SMTWriter h =>
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 = () -> ReaderT (SMTCollectorState t h) IO ()
forall a. a -> ReaderT (SMTCollectorState t h) IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

addPartialSideCond WriterConn t h
_ Term h
_ TypeMap tp
BoolTypeMap (Just Maybe Bool
AbstractValue tp
Nothing) = () -> ReaderT (SMTCollectorState t h) IO ()
forall a. a -> ReaderT (SMTCollectorState t h) IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
addPartialSideCond WriterConn t h
_ Term h
t TypeMap tp
BoolTypeMap (Just (Just Bool
b)) =
   -- This is a weird case, but technically possible, so...
  String -> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"bool_val" (Term h -> ReaderT (SMTCollectorState t h) IO ())
-> Term h -> ReaderT (SMTCollectorState t h) IO ()
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 -> () -> ReaderT (SMTCollectorState t h) IO ()
forall a. a -> ReaderT (SMTCollectorState t h) IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
       Inclusive Integer
lo -> String -> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"int_range" (Term h -> ReaderT (SMTCollectorState t h) IO ())
-> Term h -> ReaderT (SMTCollectorState t h) IO ()
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 -> () -> ReaderT (SMTCollectorState t h) IO ()
forall a. a -> ReaderT (SMTCollectorState t h) IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
       Inclusive Integer
hi -> String -> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"int_range" (Term h -> ReaderT (SMTCollectorState t h) IO ())
-> Term h -> ReaderT (SMTCollectorState t h) IO ()
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 -> () -> ReaderT (SMTCollectorState t h) IO ()
forall a. a -> ReaderT (SMTCollectorState t h) IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
       Inclusive Rational
lo -> String -> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"real_range" (Term h -> ReaderT (SMTCollectorState t h) IO ())
-> Term h -> ReaderT (SMTCollectorState t h) IO ()
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 -> () -> ReaderT (SMTCollectorState t h) IO ()
forall a. a -> ReaderT (SMTCollectorState t h) IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
       Inclusive Rational
hi -> String -> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"real_range" (Term h -> ReaderT (SMTCollectorState t h) IO ())
-> Term h -> ReaderT (SMTCollectorState t h) IO ()
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 Domain w
rng)) = Maybe (Integer, Integer) -> ReaderT (SMTCollectorState t h) IO ()
assertRange (Domain w -> Maybe (Integer, Integer)
forall (w :: Natural). Domain w -> Maybe (Integer, Integer)
BVD.arithDomainData Domain w
rng)
   where
   assertRange :: Maybe (Integer, Integer) -> ReaderT (SMTCollectorState t h) IO ()
assertRange Maybe (Integer, Integer)
Nothing = () -> ReaderT (SMTCollectorState t h) IO ()
forall a. a -> ReaderT (SMTCollectorState t h) IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
   assertRange (Just (Integer
lo, Integer
sz)) =
     String -> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"bv_range" (Term h -> ReaderT (SMTCollectorState t h) IO ())
-> Term h -> ReaderT (SMTCollectorState t h) IO ()
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 (w :: Natural). NatRepr w -> BV w -> Term h
forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> Integer -> BV w
forall (w :: Natural). NatRepr w -> Integer -> BV w
BV.mkBV NatRepr w
w Integer
lo))) (NatRepr w -> BV w -> Term h
forall (w :: Natural). NatRepr w -> BV w -> Term h
forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> Integer -> BV w
forall (w :: Natural). 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 Domain w
rng)) = (Integer, Integer) -> ReaderT (SMTCollectorState t h) IO ()
assertBitRange (Domain w -> (Integer, Integer)
forall (w :: Natural). Domain w -> (Integer, Integer)
BVD.bitbounds Domain w
rng)
   where
   assertBitRange :: (Integer, Integer) -> ReaderT (SMTCollectorState t h) IO ()
assertBitRange (Integer
lo, Integer
hi) = do
     Bool
-> ReaderT (SMTCollectorState t h) IO ()
-> ReaderT (SMTCollectorState t h) IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Integer
lo Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0) (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
$
       String -> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"bv_bitrange" (Term h -> ReaderT (SMTCollectorState t h) IO ())
-> Term h -> ReaderT (SMTCollectorState t h) IO ()
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 (w :: Natural). NatRepr w -> BV w -> Term h
forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> Integer -> BV w
forall (w :: Natural). 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
-> ReaderT (SMTCollectorState t h) IO ()
-> ReaderT (SMTCollectorState t h) IO ()
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 :: Natural). NatRepr w -> Integer
maxUnsigned NatRepr w
w) (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
$
       String -> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"bv_bitrange" (Term h -> ReaderT (SMTCollectorState t h) IO ())
-> Term h -> ReaderT (SMTCollectorState t h) IO ()
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 (w :: Natural). NatRepr w -> BV w -> Term h
forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> Integer -> BV w
forall (w :: Natural). 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 (w :: Natural). NatRepr w -> BV w -> Term h
forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> Integer -> BV w
forall (w :: Natural). NatRepr w -> Integer -> BV w
BV.mkBV NatRepr w
w Integer
hi))

addPartialSideCond WriterConn t h
_ Term h
t (TypeMap tp
UnicodeTypeMap) (Just (StringAbs ValueRange Integer
len)) =
  do case ValueRange Integer -> ValueBound Integer
forall tp. ValueRange tp -> ValueBound tp
rangeLowBound ValueRange Integer
len of
       Inclusive Integer
lo ->
          String -> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"string length low range" (Term h -> ReaderT (SMTCollectorState t h) IO ())
-> Term h -> ReaderT (SMTCollectorState t h) IO ()
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
.<= forall h. SMTWriter h => Term h -> Term h
stringLength @h Term h
t
       ValueBound Integer
Unbounded ->
          String -> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"string length low range" (Term h -> ReaderT (SMTCollectorState t h) IO ())
-> Term h -> ReaderT (SMTCollectorState t h) IO ()
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
.<= 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 -> () -> ReaderT (SMTCollectorState t h) IO ()
forall a. a -> ReaderT (SMTCollectorState t h) IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
       Inclusive Integer
hi ->
         String -> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"string length high range" (Term h -> ReaderT (SMTCollectorState t h) IO ())
-> Term h -> ReaderT (SMTCollectorState t h) IO ()
forall a b. (a -> b) -> a -> b
$
           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 ()) = () -> ReaderT (SMTCollectorState t h) IO ()
forall a. a -> ReaderT (SMTCollectorState t h) IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

addPartialSideCond WriterConn t h
conn Term h
t TypeMap tp
ComplexToStructTypeMap (Just (RealAbstractValue
realRng :+ RealAbstractValue
imagRng)) =
  do let r :: Term h
r = forall h. SMTWriter h => Term h -> Term h
arrayComplexRealPart @h Term h
t
     let i :: Term h
i = forall h. SMTWriter h => Term h -> Term h
arrayComplexImagPart @h Term h
t
     WriterConn t h
-> Term h
-> TypeMap 'BaseRealType
-> Maybe (AbstractValue 'BaseRealType)
-> 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 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)
-> 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 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 (RealAbstractValue
realRng :+ RealAbstractValue
imagRng)) =
  do let r :: Term h
r = forall h. SMTWriter h => Term h -> Term h
arrayComplexRealPart @h Term h
t
     let i :: Term h
i = forall h. SMTWriter h => Term h -> Term h
arrayComplexImagPart @h Term h
t
     WriterConn t h
-> Term h
-> TypeMap 'BaseRealType
-> Maybe (AbstractValue 'BaseRealType)
-> 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 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)
-> 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 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).
    ReaderT (SMTCollectorState t h) IO ()
    -> Index idx tp -> ReaderT (SMTCollectorState t h) IO ())
-> ReaderT (SMTCollectorState t h) IO ()
-> ReaderT (SMTCollectorState t h) IO ()
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)
        (\ReaderT (SMTCollectorState t h) IO ()
start Index idx tp
i ->
            do ReaderT (SMTCollectorState t h) IO ()
start
               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
                 (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))))
        (() -> ReaderT (SMTCollectorState t h) IO ()
forall a. a -> ReaderT (SMTCollectorState t h) IO a
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 -> ReaderT (SMTCollectorState t h) IO ()
forall a. String -> ReaderT (SMTCollectorState t h) IO a
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 -> ReaderT (SMTCollectorState t h) IO ()
forall a. String -> ReaderT (SMTCollectorState t h) IO a
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 :: forall h t a.
SMTWriter h =>
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
              { 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 :: forall a. IORef [a] -> a -> IO ()
prependToRefList IORef [a]
r a
a = a -> IO () -> IO ()
forall a b. a -> b -> b
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 :: forall v (rtp :: BaseType).
SupportTermOps v =>
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 a. String -> IO a
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 ()
forall a b. a -> b -> b
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 :: 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)]
ref TypeMap tp
tp = do
  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
  prependToRefList ref (var, Some tp)
  return $! SMTName tp var

-- | This describes the result that was collected from the solver.
data CollectorResults h a =
  CollectorResults { forall h a. CollectorResults h a -> a
crResult :: !a
                     -- ^ Result from sandboxed computation.
                   , forall h a. CollectorResults h a -> [(Text, Term h)]
crBindings :: !([(Text, Term h)])
                     -- ^ List of bound variables.
                   , forall h a. CollectorResults h a -> [(Text, Some TypeMap)]
crFreeConstants :: !([(Text, Some TypeMap)])
                     -- ^ Constants added during generation.
                   , forall h a. 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 :: forall h. SMTWriter h => CollectorResults h (Term h) -> Term h
forallResult CollectorResults h (Term h)
cr =
  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 :: forall v. SupportTermOps v => [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 :: forall h. SMTWriter h => CollectorResults h (Term h) -> Term h
existsResult CollectorResults h (Term h)
cr =
  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 :: 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 a
sc = do
  -- A list of bound terms.
  boundTermRef    <- [(Text, Term h)] -> IO (IORef [(Text, Term h)])
forall a. a -> IO (IORef a)
newIORef []
  -- A list of free constants
  freeConstantRef <- (newIORef [] :: IO (IORef [(Text, Some TypeMap)]))
  -- A list of references to side conditions.
  sideCondRef     <- newIORef []

  let s = 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
          }
  r <- runReaderT sc s

  boundTerms    <- readIORef boundTermRef
  freeConstants <- readIORef freeConstantRef
  sideConds     <- readIORef sideCondRef
  return $! CollectorResults { crResult = r
                             , crBindings = reverse boundTerms
                             , crFreeConstants = reverse freeConstants
                             , crSideConds = reverse 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 :: forall t (tp :: BaseType) h.
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
  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
  (liftIO $ cacheLookupExpr c n) >>= \case
    Just SMTExpr h tp
x -> SMTExpr h tp -> SMTCollector t h (SMTExpr h tp)
forall a. a -> ReaderT (SMTCollectorState t h) IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return SMTExpr h tp
x
    Maybe (SMTExpr h tp)
Nothing -> do
      x <- SMTCollector t h (SMTExpr h tp)
fallback
      liftIO $ cacheValueExpr c n lifetime x
      return 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 :: forall t (tp :: BaseType) h.
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
  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
  liftIO $ do
    whenM (isJust <$> cacheLookupExpr c n) $ fail "Variable is already bound."
    cacheValueExpr c n DeleteOnPop 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 :: forall v (w :: Natural).
(SupportTermOps v, 1 <= w) =>
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 :: Natural). 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 (w :: Natural). NatRepr w -> Natural -> v -> v
forall v (w :: Natural).
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 :: forall v (w :: Natural). SupportTermOps v => 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 :: Natural).
SupportTermOps v =>
NatRepr w -> v -> Natural -> [v]
go NatRepr w
w0 v
x0 (NatRepr w -> Natural
forall (n :: Natural). 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 (w :: Natural). NatRepr w -> Natural -> v -> v
forall v (w :: Natural).
SupportTermOps v =>
NatRepr w -> Natural -> v -> v
bvTestBit NatRepr w
w0 (NatRepr w -> Natural
forall (n :: Natural). 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 :: Natural). 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 :: forall v (w :: Natural).
SupportTermOps v =>
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 :: Natural).
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 :: Natural).
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 :: Natural).
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 :: forall v (w :: Natural).
SupportTermOps v =>
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 (w :: Natural). NatRepr w -> Natural -> v -> v
forall v (w :: Natural).
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 :: forall (m :: Type -> Type) t (tp :: BaseType) a.
MonadFail m =>
Expr t tp -> m a
unsupportedTerm Expr t tp
e =
  String -> m a
forall a. 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 (ZonkAny 2) -> String
forall a. Show a => a -> String
show (Doc (ZonkAny 2) -> String) -> Doc (ZonkAny 2) -> String
forall a b. (a -> b) -> a -> b
$
  [Doc (ZonkAny 2)] -> Doc (ZonkAny 2)
forall ann. [Doc ann] -> Doc ann
vcat
  [ Doc (ZonkAny 2)
"Cannot generate solver output for term generated at"
      Doc (ZonkAny 2) -> Doc (ZonkAny 2) -> Doc (ZonkAny 2)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Position -> Doc (ZonkAny 2)
forall a ann. Pretty a => a -> Doc ann
forall ann. Position -> Doc ann
pretty (ProgramLoc -> Position
plSourceLoc (Expr t tp -> ProgramLoc
forall t (tp :: BaseType). Expr t tp -> ProgramLoc
exprLoc Expr t tp
e)) Doc (ZonkAny 2) -> Doc (ZonkAny 2) -> Doc (ZonkAny 2)
forall a. Semigroup a => a -> a -> a
<> Doc (ZonkAny 2)
":"
  , Int -> Doc (ZonkAny 2) -> Doc (ZonkAny 2)
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Expr t tp -> Doc (ZonkAny 2)
forall a ann. Pretty a => a -> Doc ann
forall ann. Expr t tp -> 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 :: forall n (tp :: BaseType) h.
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 a. a -> ReaderT (SMTCollectorState n h) IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

theoryUnsupported :: MonadFail m => WriterConn t h -> String -> Expr t tp -> m a
theoryUnsupported :: 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
theory_name Expr t tp
t =
  String -> m a
forall a. 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 (ZonkAny 1) -> String
forall a. Show a => a -> String
show (Doc (ZonkAny 1) -> String) -> Doc (ZonkAny 1) -> String
forall a b. (a -> b) -> a -> b
$
    String -> Doc (ZonkAny 1)
forall ann. String -> Doc ann
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 (ZonkAny 1) -> Doc (ZonkAny 1) -> Doc (ZonkAny 1)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc (ZonkAny 1)
"does not support the" Doc (ZonkAny 1) -> Doc (ZonkAny 1) -> Doc (ZonkAny 1)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc (ZonkAny 1)
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
theory_name
    Doc (ZonkAny 1) -> Doc (ZonkAny 1) -> Doc (ZonkAny 1)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc (ZonkAny 1)
"term generated at" Doc (ZonkAny 1) -> Doc (ZonkAny 1) -> Doc (ZonkAny 1)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Position -> Doc (ZonkAny 1)
forall a ann. Pretty a => a -> Doc ann
forall ann. Position -> 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 :: forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkIntegerSupport Expr t tp
t = do
  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
  unless (supportedFeatures conn `hasProblemFeature` useIntegerArithmetic) $ do
    theoryUnsupported conn "integer arithmetic" t

checkStringSupport :: Expr t tp -> SMTCollector t h ()
checkStringSupport :: forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkStringSupport Expr t tp
t = do
  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
  unless (supportedFeatures conn `hasProblemFeature` useStrings) $ do
    theoryUnsupported conn "string" t

checkBitvectorSupport :: Expr t tp -> SMTCollector t h ()
checkBitvectorSupport :: forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkBitvectorSupport Expr t tp
t = do
  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
  unless (supportedFeatures conn `hasProblemFeature` useBitvectors) $ do
    theoryUnsupported conn "bitvector" t

checkFloatSupport :: Expr t tp -> SMTCollector t h ()
checkFloatSupport :: forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkFloatSupport Expr t tp
t = do
  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
  unless (supportedFeatures conn `hasProblemFeature` useFloatingPoint) $ do
    theoryUnsupported conn "floating-point arithmetic" t

checkLinearSupport :: Expr t tp -> SMTCollector t h ()
checkLinearSupport :: forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkLinearSupport Expr t tp
t = do
  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
  unless (supportedFeatures conn `hasProblemFeature` useLinearArithmetic) $ do
    theoryUnsupported conn "linear arithmetic" t

checkNonlinearSupport :: Expr t tp -> SMTCollector t h ()
checkNonlinearSupport :: forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkNonlinearSupport Expr t tp
t = do
  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
  unless (supportedFeatures conn `hasProblemFeature` useNonlinearArithmetic) $ do
    theoryUnsupported conn "non-linear arithmetic" t

checkComputableSupport :: Expr t tp -> SMTCollector t h ()
checkComputableSupport :: forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkComputableSupport Expr t tp
t = do
  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
  unless (supportedFeatures conn `hasProblemFeature` useComputableReals) $ do
    theoryUnsupported conn "computable arithmetic" t

checkQuantifierSupport :: String -> Expr t p -> SMTCollector t h ()
checkQuantifierSupport :: forall t (p :: BaseType) h.
String -> Expr t p -> SMTCollector t h ()
checkQuantifierSupport String
nm Expr t p
t = do
  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
  when (supportQuantifiers conn == False) $ do
    theoryUnsupported conn nm t

-- | Check that the types can be passed to functions.
checkArgumentTypes :: WriterConn t h -> Ctx.Assignment TypeMap args -> IO ()
checkArgumentTypes :: forall t h (args :: Ctx BaseType).
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 a. String -> IO a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc (ZonkAny 0) -> String
forall a. Show a => a -> String
show (Doc (ZonkAny 0) -> String) -> Doc (ZonkAny 0) -> String
forall a b. (a -> b) -> a -> b
$ String -> Doc (ZonkAny 0)
forall ann. String -> Doc ann
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 (ZonkAny 0) -> Doc (ZonkAny 0) -> Doc (ZonkAny 0)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc (ZonkAny 0)
"does not allow arrays encoded as functions to be function arguments."
      TypeMap x
_ ->
        () -> IO ()
forall a. a -> IO a
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 :: forall ann. 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 :: forall t (tp :: BaseType) ann. 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 ann. 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
forall ann. Position -> 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
forall ann. Expr t tp -> 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 :: forall ann. SolverSymbol -> ProgramLoc -> SMTSource ann
fnSource SolverSymbol
fn_name ProgramLoc
loc String
solver_name BaseTypeError
cause =
  String -> Doc ann
forall ann. 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
forall ann. Position -> 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 :: 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 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 a. String -> m a
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 a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return TypeMap tp
smt_ret

withConnEntryStack :: WriterConn t h -> IO a -> IO a
withConnEntryStack :: forall t h a. 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 :: forall v (tp :: BaseType). SupportTermOps v => 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 (w :: Natural). NatRepr w -> BV w -> v
forall v (w :: Natural). 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 :: forall v (ctx :: Ctx BaseType).
SupportTermOps v =>
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]
forall (f :: BaseType -> Type) a.
(forall (x :: BaseType). f x -> a)
-> forall (x :: Ctx BaseType). Assignment f x -> [a]
toListFC IndexLit x -> v
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 :: forall t h (args :: Ctx BaseType).
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 :: forall (utp :: BaseType). TypeMap utp -> IO (Text, Some TypeMap)
mkIndexVar TypeMap utp
base_tp = do
        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!"
        return (i_nm, Some 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)
forall (m :: Type -> Type) a. Monad m => [m a] -> m [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 (utp :: BaseType). TypeMap utp -> IO (Text, Some TypeMap))
-> forall (x :: Ctx BaseType).
   Assignment TypeMap x -> [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]
forall (f :: BaseType -> Type) a.
(forall (x :: BaseType). f x -> a)
-> forall (x :: Ctx BaseType). Assignment f x -> [a]
toListFC TypeMap x -> IO (Text, Some TypeMap)
forall (utp :: BaseType). TypeMap utp -> 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 :: 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) 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
TypeMap tp
res_type (Term h -> SMTExpr h tp) -> Term h -> SMTExpr h tp
forall a b. (a -> b) -> a -> b
$ 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
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 :: forall t h. 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 a. a -> IO a
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 :: 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
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.
    freeConstantRef <- ([(Text, Some TypeMap)] -> IO (IORef [(Text, Some TypeMap)])
forall a. a -> IO (IORef a)
newIORef [] :: IO (IORef [(Text, Some TypeMap)]))
    boundTermRef    <- newIORef []
    let s = 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 = (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)
    pair <- flip runReaderT s (action varFn)

    args       <- readIORef freeConstantRef
    boundTerms <- readIORef boundTermRef

    let 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)

    defineSMTVar conn FunctionDefinition var (reverse args) (smtExprType pair) res
    return $! smtExprType 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 :: forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr (BoolExpr Bool
b ProgramLoc
_) =
  SMTExpr h tp -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a. a -> ReaderT (SMTCollectorState t h) IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (TypeMap tp -> Term h -> SMTExpr h tp
forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap tp
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 tp -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a. a -> ReaderT (SMTCollectorState t h) IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (TypeMap tp -> Term h -> SMTExpr h tp
forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap tp
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 tp -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a. a -> ReaderT (SMTCollectorState t h) IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (TypeMap tp -> Term h -> SMTExpr h tp
forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap tp
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 tp -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a. a -> ReaderT (SMTCollectorState t h) IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SMTExpr h tp -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> SMTExpr h tp
-> ReaderT (SMTCollectorState t h) IO (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 (NatRepr w -> TypeMap (BaseBVType w)
forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w) (Term h -> SMTExpr h tp) -> Term h -> SMTExpr h tp
forall a b. (a -> b) -> a -> b
$ NatRepr w -> BV w -> Term h
forall (w :: Natural). NatRepr w -> BV w -> Term h
forall v (w :: Natural). 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 tp -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a. a -> ReaderT (SMTCollectorState t h) IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SMTExpr h tp -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> SMTExpr h tp
-> ReaderT (SMTCollectorState t h) IO (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 (FloatPrecisionRepr fpp -> TypeMap ('BaseFloatType fpp)
forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp) (Term h -> SMTExpr h tp) -> Term h -> SMTExpr h tp
forall a b. (a -> b) -> a -> b
$ FloatPrecisionRepr fpp -> BigFloat -> Term h
forall v (fpp :: FloatPrecision).
SupportTermOps v =>
FloatPrecisionRepr fpp -> BigFloat -> v
forall (fpp :: FloatPrecision).
FloatPrecisionRepr fpp -> BigFloat -> Term h
floatTerm FloatPrecisionRepr fpp
fpp BigFloat
f
mkExpr t :: Expr t tp
t@(StringExpr StringLiteral si
l ProgramLoc
_) =
  case StringLiteral si
l of
    UnicodeLiteral Text
str -> 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 tp -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a. a -> ReaderT (SMTCollectorState t h) IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SMTExpr h tp -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> SMTExpr h tp
-> ReaderT (SMTCollectorState t h) IO (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 TypeMap tp
TypeMap ('BaseStringType Unicode)
UnicodeTypeMap (Term h -> SMTExpr h tp) -> Term h -> SMTExpr h tp
forall a b. (a -> b) -> a -> b
$ forall h. SMTWriter h => Text -> Term h
stringTerm @h Text
str
    StringLiteral si
_ -> do
      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
      theoryUnsupported conn ("strings " ++ show (stringLiteralInfo l)) t

mkExpr (NonceAppExpr NonceAppExpr t tp
ea) =
  Nonce t tp
-> TermLifetime
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
-> ReaderT (SMTCollectorState t h) IO (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 (ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
 -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a b. (a -> b) -> a -> b
$
    NonceAppExpr t tp
-> ReaderT (SMTCollectorState t h) IO (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
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
-> ReaderT (SMTCollectorState t h) IO (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 (ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
 -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a b. (a -> b) -> a -> b
$ do
    AppExpr t tp -> ReaderT (SMTCollectorState t h) IO (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
     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
     mr <- liftIO $ cacheLookupExpr conn (bvarId var)
     case mr of
      Just SMTExpr h tp
x -> SMTExpr h tp -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a. a -> ReaderT (SMTCollectorState t h) IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return SMTExpr h tp
x
      Maybe (SMTExpr h tp)
Nothing -> do
        String -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a. String -> ReaderT (SMTCollectorState t h) IO a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> String -> ReaderT (SMTCollectorState t h) IO (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 -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a. String -> ReaderT (SMTCollectorState t h) IO a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> String -> ReaderT (SMTCollectorState t h) IO (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
     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
     cacheWriterResult (bvarId var) DeleteNever $ do
       checkVarTypeSupport var
       -- Use predefined var name if it has not been defined.
       var_name <- liftIO $ getSymbolName conn (VarSymbolBinding var)

       smt_type <- getBaseSMT_Type var

       liftIO $
         do declareTypes conn smt_type
            addCommand conn $ declareCommand conn var_name Ctx.empty smt_type

       -- Add assertion based on var type.
       addPartialSideCond conn (fromText var_name) smt_type (bvarAbstractValue var)

       -- Return variable name
       return $ SMTName smt_type var_name

-- | Convert an element to a base expression.
mkBaseExpr :: SMTWriter h => Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr :: forall h t (tp :: BaseType).
SMTWriter h =>
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)
-> 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 (SMTExpr h tp)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t tp
e
{-# INLINE mkBaseExpr #-}

-- | Convert structure to list.
mkIndicesTerms :: SMTWriter h
               => Ctx.Assignment (Expr t) ctx
               -> SMTCollector t h [Term h]
mkIndicesTerms :: forall h t (ctx :: Ctx BaseType).
SMTWriter h =>
Assignment (Expr t) ctx -> SMTCollector t h [Term h]
mkIndicesTerms = (forall (x :: BaseType).
 Expr t x
 -> ReaderT (SMTCollectorState t h) IO [Term h]
 -> ReaderT (SMTCollectorState t h) IO [Term h])
-> forall (x :: Ctx BaseType).
   ReaderT (SMTCollectorState t h) IO [Term h]
   -> Assignment (Expr t) x
   -> ReaderT (SMTCollectorState t h) IO [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
forall (f :: BaseType -> Type) b.
(forall (x :: BaseType). f x -> b -> b)
-> forall (x :: Ctx BaseType). b -> Assignment f x -> b
foldrFC (\Expr t x
e ReaderT (SMTCollectorState t h) IO [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])
-> ReaderT (SMTCollectorState t h) IO [Term h]
-> ReaderT (SMTCollectorState t h) IO [Term h]
forall a b.
ReaderT (SMTCollectorState t h) IO (a -> b)
-> ReaderT (SMTCollectorState t h) IO a
-> ReaderT (SMTCollectorState t h) IO b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> ReaderT (SMTCollectorState t h) IO [Term h]
r) ([Term h] -> ReaderT (SMTCollectorState t h) IO [Term h]
forall a. a -> ReaderT (SMTCollectorState t h) IO a
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 :: forall t h (tp :: BaseType).
SMTWriter h =>
NonceAppExpr t tp -> SMTCollector t h (SMTExpr h tp)
predSMTExpr NonceAppExpr t tp
e0 = do
  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 = NonceAppExpr t tp -> Expr t tp
forall t (tp :: BaseType). NonceAppExpr t tp -> Expr t tp
NonceAppExpr NonceAppExpr t tp
e0
  h <- asks scConn
  liftIO $ updateProgramLoc h (nonceExprLoc e0)
  case nonceExprApp e0 of
    Annotation BaseTypeRepr tp
_tpr Nonce t tp
_n Expr t tp
e -> 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
    Forall ExprBoundVar t tp1
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

      smtType <- ExprBoundVar t tp1 -> SMTCollector t h (TypeMap tp1)
forall t (tp :: BaseType) h.
ExprBoundVar t tp -> SMTCollector t h (TypeMap tp)
getBaseSMT_Type ExprBoundVar t tp1
var
      liftIO $ declareTypes h smtType

      cr <- liftIO $ withConnEntryStack conn $ do
        runInSandbox conn $ do
          checkVarTypeSupport var

          Just (FreshVarFn f) <- asks freshConstantFn
          t <- liftIO $ f smtType
          bindVar var t

          addPartialSideCond conn (asBase t) smtType (bvarAbstractValue var)
          mkBaseExpr e
      freshBoundTerm BoolTypeMap $ forallResult cr
    Exists ExprBoundVar t tp1
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

      smtType <- ExprBoundVar t tp1 -> SMTCollector t h (TypeMap tp1)
forall t (tp :: BaseType) h.
ExprBoundVar t tp -> SMTCollector t h (TypeMap tp)
getBaseSMT_Type ExprBoundVar t tp1
var
      liftIO $ declareTypes h smtType

      cr <- liftIO $ withConnEntryStack conn $ do
        runInSandbox conn $ do
          checkVarTypeSupport var

          Just (FreshVarFn f) <- asks freshConstantFn
          t <- liftIO $ f smtType
          bindVar var t

          addPartialSideCond conn (asBase t) smtType (bvarAbstractValue var)
          mkBaseExpr e
      freshBoundTerm BoolTypeMap $ existsResult cr

    ArrayFromFn ExprSymFn t (idx ::> itp) ret
f -> do
      -- Evaluate arg types
      smt_arg_types <-
        (forall (x :: BaseType).
 BaseTypeRepr x -> ReaderT (SMTCollectorState t h) IO (TypeMap x))
-> forall (x :: Ctx BaseType).
   Assignment BaseTypeRepr x
   -> ReaderT (SMTCollectorState t h) IO (Assignment TypeMap x)
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)
forall (f :: BaseType -> Type) (g :: BaseType -> Type)
       (m :: Type -> Type).
Applicative m =>
(forall (x :: BaseType). f x -> m (g x))
-> forall (x :: Ctx BaseType). Assignment f x -> m (Assignment g x)
traverseFC (WriterConn t h
-> SMTSource (ZonkAny 9)
-> 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 (ZonkAny 9)
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
      (smt_f, ret_tp) <- liftIO $ getSMTSymFn conn f smt_arg_types

      let array_tp = Assignment TypeMap (idx ::> itp)
-> TypeMap ret -> TypeMap ('BaseArrayType (idx ::> itp) ret)
forall (idx :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
Assignment TypeMap (idx ::> idx)
-> TypeMap tp -> TypeMap (BaseArrayType (idx ::> idx) tp)
FnArrayTypeMap Assignment TypeMap (idx ::> itp)
smt_arg_types TypeMap ret
ret_tp
      return $! SMTName array_tp 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.

      smt_idx_types <- (forall (x :: BaseType).
 BaseTypeRepr x -> ReaderT (SMTCollectorState t h) IO (TypeMap x))
-> forall (x :: Ctx BaseType).
   Assignment BaseTypeRepr x
   -> ReaderT (SMTCollectorState t h) IO (Assignment TypeMap x)
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)
forall (f :: BaseType -> Type) (g :: BaseType -> Type)
       (m :: Type -> Type).
Applicative m =>
(forall (x :: BaseType). f x -> m (g x))
-> forall (x :: Ctx BaseType). Assignment f x -> m (Assignment g x)
traverseFC (WriterConn t h
-> SMTSource (ZonkAny 10)
-> 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 (ZonkAny 10)
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 (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))
-> ReaderT
     (SMTCollectorState t h)
     IO
     (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

      smt_arrays <- traverseFC evalArray arrays

      liftIO $ do

      -- Create name of function to reutrn.
      nm <- liftIO $ withWriterState conn $ freshVarName

      ret_type <-
        defineSMTFunction conn nm $ \(FreshVarFn forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp)
freshVar) -> do
          -- Create type for indices.
          smt_indices <- (forall (x :: BaseType).
 TypeMap x -> ReaderT (SMTCollectorState t h) IO (SMTExpr h x))
-> forall (x :: Ctx BaseType).
   Assignment TypeMap x
   -> ReaderT (SMTCollectorState t h) IO (Assignment (SMTExpr h) x)
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)
forall (f :: BaseType -> Type) (g :: BaseType -> Type)
       (m :: Type -> Type).
Applicative m =>
(forall (x :: BaseType). f x -> m (g x))
-> forall (x :: Ctx BaseType). Assignment f x -> m (Assignment g x)
traverseFC (\TypeMap x
tp -> IO (SMTExpr h x)
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h x)
forall a. IO a -> ReaderT (SMTCollectorState t h) IO a
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 = (forall (x :: BaseType). SMTExpr h x -> Term h)
-> forall (x :: Ctx BaseType). Assignment (SMTExpr h) x -> [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]
forall (f :: BaseType -> Type) a.
(forall (x :: BaseType). f x -> a)
-> forall (x :: Ctx BaseType). Assignment f x -> [a]
toListFC SMTExpr h x -> Term h
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 (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 = (forall (x :: BaseType).
 ArrayResultWrapper (SMTExpr h) (idx ::> itp) x -> SMTExpr h x)
-> forall (x :: Ctx BaseType).
   Assignment (ArrayResultWrapper (SMTExpr h) (idx ::> itp)) x
   -> Assignment (SMTExpr h) x
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
forall (f :: BaseType -> Type) (g :: BaseType -> Type).
(forall (x :: BaseType). f x -> g x)
-> forall (x :: Ctx BaseType). Assignment f x -> Assignment g x
fmapFC ArrayResultWrapper (SMTExpr h) (idx ::> itp) x -> SMTExpr h x
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

          (smt_f, ret_type) <- liftIO $ getSMTSymFn conn f (fmapFC smtExprType array_vals)

          return $ SMTExpr ret_type $ smtFnApp (fromText smt_f) (toListFC asBase array_vals)


      let array_tp = Assignment TypeMap (idx ::> itp)
-> TypeMap r -> TypeMap ('BaseArrayType (idx ::> itp) r)
forall (idx :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
Assignment TypeMap (idx ::> idx)
-> TypeMap tp -> TypeMap (BaseArrayType (idx ::> idx) tp)
FnArrayTypeMap Assignment TypeMap (idx ::> itp)
smt_idx_types TypeMap r
ret_type
      return $! SMTName array_tp nm

    ArrayTrueOnEntries{} -> do
      String -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a. String -> ReaderT (SMTCollectorState t h) IO a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> String -> ReaderT (SMTCollectorState t h) IO (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
      smt_args <- (forall (x :: BaseType).
 Expr t x -> ReaderT (SMTCollectorState t h) IO (SMTExpr h x))
-> forall (x :: Ctx BaseType).
   Assignment (Expr t) x
   -> ReaderT (SMTCollectorState t h) IO (Assignment (SMTExpr h) x)
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)
forall (f :: BaseType -> Type) (g :: BaseType -> Type)
       (m :: Type -> Type).
Applicative m =>
(forall (x :: BaseType). f x -> m (g x))
-> forall (x :: Ctx BaseType). Assignment f x -> m (Assignment g x)
traverseFC Expr t x -> SMTCollector t h (SMTExpr h x)
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
      (smt_f, ret_type) <- liftIO $ getSMTSymFn conn f (fmapFC smtExprType smt_args)
      freshBoundTerm ret_type $! smtFnApp (fromText smt_f) (toListFC asBase smt_args)


appSMTExpr :: forall t h tp
            . SMTWriter h
           => AppExpr t tp
           -> SMTCollector t h (SMTExpr h tp)
appSMTExpr :: forall t h (tp :: BaseType).
SMTWriter h =>
AppExpr t tp -> SMTCollector t h (SMTExpr h tp)
appSMTExpr AppExpr t tp
ae = do
  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 = AppExpr t tp -> Expr t tp
forall t (tp :: BaseType). AppExpr t tp -> Expr t tp
AppExpr AppExpr t tp
ae
  liftIO $ updateProgramLoc conn (appExprLoc ae)
  case appExprApp ae of

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

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

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

         checkArrayType x xtp
         checkArrayType y ytp

         when (xtp /= ytp) $ do
           fail $ unwords ["Type representations are not equal:", show xtp, show ytp]

         freshBoundTerm BoolTypeMap $ asBase xe .== asBase 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 (ZonkAny 11) -> String
forall a. Show a => a -> String
show
             (Doc (ZonkAny 11) -> String) -> Doc (ZonkAny 11) -> String
forall a b. (a -> b) -> a -> b
$   Doc (ZonkAny 11)
"we do not support if/then/else expressions at type"
             Doc (ZonkAny 11) -> Doc (ZonkAny 11) -> Doc (ZonkAny 11)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc (ZonkAny 11)
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
typename
             Doc (ZonkAny 11) -> Doc (ZonkAny 11) -> Doc (ZonkAny 11)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc (ZonkAny 11)
"with solver"
             Doc (ZonkAny 11) -> Doc (ZonkAny 11) -> Doc (ZonkAny 11)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc (ZonkAny 11)
forall ann. String -> Doc ann
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 (ZonkAny 11) -> Doc (ZonkAny 11) -> Doc (ZonkAny 11)
forall a. Semigroup a => a -> a -> a
<> Doc (ZonkAny 11)
"."
      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 -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a. String -> ReaderT (SMTCollectorState t h) IO a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> String -> ReaderT (SMTCollectorState t h) IO (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 -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a. String -> ReaderT (SMTCollectorState t h) IO a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> String -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a b. (a -> b) -> a -> b
$ String -> String
errMsg String
"complex"
        Left  BaseTypeError
ArrayUnsupported       -> String -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a. String -> ReaderT (SMTCollectorState t h) IO a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> String -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a b. (a -> b) -> a -> b
$ String -> String
errMsg String
"array"
        Right FnArrayTypeMap{}       -> String -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a. String -> ReaderT (SMTCollectorState t h) IO a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> String -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a b. (a -> b) -> a -> b
$ String -> String
errMsg String
"function-backed array"
        Right TypeMap tp
tym ->
          do 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
             xb <- mkBaseExpr x
             yb <- mkBaseExpr y
             freshBoundTerm tym $ ite cb xb yb

    SemiRingLe OrderedSemiRingRepr sr
_sr Expr t (SemiRingBase sr)
x Expr t (SemiRingBase sr)
y -> do
      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
      yb <- mkBaseExpr y
      freshBoundTerm BoolTypeMap $ xb .<= yb

    RealIsInteger Expr t 'BaseRealType
r -> do
      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
      freshBoundTerm BoolTypeMap $! realIsInteger rb

    BVTestBit Natural
n Expr t (BaseBVType w)
xe -> do
      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 = NatRepr w -> Natural -> Natural -> Term h -> Term h
forall (w :: Natural).
NatRepr w -> Natural -> Natural -> Term h -> Term h
forall v (w :: Natural).
SupportTermOps v =>
NatRepr w -> Natural -> Natural -> v -> v
bvExtract (Expr t (BaseBVType w) -> NatRepr w
forall (w :: Natural). Expr t (BaseBVType w) -> NatRepr w
forall (e :: BaseType -> Type) (w :: Natural).
IsExpr e =>
e (BaseBVType w) -> NatRepr w
bvWidth Expr t (BaseBVType w)
xe) Natural
n Natural
1 Term h
x
          one = NatRepr 1 -> BV 1 -> Term h
forall (w :: Natural). NatRepr w -> BV w -> Term h
forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm (NatRepr 1
forall (n :: Natural). KnownNat n => NatRepr n
knownNat :: NatRepr 1) (NatRepr 1 -> BV 1
forall (w :: Natural). (1 <= w) => NatRepr w -> BV w
BV.one NatRepr 1
forall (n :: Natural). KnownNat n => NatRepr n
knownNat)
      freshBoundTerm BoolTypeMap $ this_bit .== one
    BVSlt Expr t (BaseBVType w)
xe Expr t (BaseBVType w)
ye -> do
      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
      y <- mkBaseExpr ye
      freshBoundTerm BoolTypeMap $ x `bvSLt` y
    BVUlt Expr t (BaseBVType w)
xe Expr t (BaseBVType w)
ye -> do
      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
      y <- mkBaseExpr ye
      freshBoundTerm BoolTypeMap $ x `bvULt` 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 a. a -> ReaderT (SMTCollectorState t h) IO a
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

      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
      y <- mkBaseExpr ye

      freshBoundTerm IntegerTypeMap (intDiv x 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 a. a -> ReaderT (SMTCollectorState t h) IO a
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

      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
      y <- mkBaseExpr ye

      freshBoundTerm IntegerTypeMap (intMod x y)

    IntAbs Expr t 'BaseIntegerType
xe -> do
      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
      freshBoundTerm IntegerTypeMap (intAbs x)

    IntDivisible Expr t 'BaseIntegerType
xe Natural
k -> do
      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
      freshBoundTerm BoolTypeMap (intDivisible x k)

    NotPred Expr t BaseBoolType
x -> TypeMap tp
-> Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap tp
TypeMap BaseBoolType
BoolTypeMap (Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> (Term h -> Term h)
-> Term h
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term h -> Term h
forall v. SupportTermOps v => v -> v
notExpr (Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> ReaderT (SMTCollectorState t h) IO (Term h)
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
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) -> SMTCollector t h (Term h)
pol (Expr t tp
x,Polarity
Positive) = 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
x
          pol (Expr t tp
x,Polarity
Negative) = Term h -> Term h
forall v. SupportTermOps v => v -> v
notExpr (Term h -> Term h)
-> SMTCollector t h (Term h) -> SMTCollector t h (Term h)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f 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
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 tp -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a. a -> ReaderT (SMTCollectorState t h) IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SMTExpr h tp -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> SMTExpr h tp
-> ReaderT (SMTCollectorState t h) IO (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 TypeMap tp
TypeMap BaseBoolType
BoolTypeMap (Term h -> SMTExpr h tp) -> Term h -> SMTExpr h tp
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 tp -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a. a -> ReaderT (SMTCollectorState t h) IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SMTExpr h tp -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> SMTExpr h tp
-> ReaderT (SMTCollectorState t h) IO (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 TypeMap tp
TypeMap BaseBoolType
BoolTypeMap (Term h -> SMTExpr h tp) -> Term h -> SMTExpr h tp
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 tp -> Term h -> SMTExpr h tp
forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap tp
TypeMap BaseBoolType
BoolTypeMap (Term h -> SMTExpr h tp)
-> ReaderT (SMTCollectorState t h) IO (Term h)
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
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) -> SMTCollector t h (Term h)
pol (Expr t BaseBoolType, Polarity)
t
        BM.BoolMapTerms ((Expr t BaseBoolType, Polarity)
t:|[(Expr t BaseBoolType, Polarity)]
ts) ->
          do 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)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM (Expr t BaseBoolType, Polarity)
-> ReaderT (SMTCollectorState t h) IO (Term h)
forall {h} {t} {tp :: BaseType}.
SMTWriter h =>
(Expr t tp, Polarity) -> SMTCollector t h (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)
             freshBoundTerm BoolTypeMap 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 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 a. a -> ReaderT (SMTCollectorState t h) IO a
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 (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
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
             maybe (return $ SMTExpr (BVTypeMap w) $ bvTerm w (BV.one w))
                   (freshBoundTerm (BVTypeMap w))
                   pd'

        SR.SemiRingBVRepr BVFlavorRepr fv
SR.BVBitsRepr NatRepr w
w ->
          do 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 a. a -> ReaderT (SMTCollectorState t h) IO a
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 (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO (Term h)
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
             maybe (return $ SMTExpr (BVTypeMap w) $ bvTerm w (BV.maxUnsigned w))
                   (freshBoundTerm (BVTypeMap w))
                   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
             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 a. a -> ReaderT (SMTCollectorState t h) IO a
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 tp -> ReaderT (SMTCollectorState t h) IO (Term h)
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
             maybe (return $ SMTExpr (semiRingTypeMap sr) $ integerTerm 1)
                   (freshBoundTerm (semiRingTypeMap sr))
                   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 a. 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 tp
-> Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap tp
TypeMap 'BaseIntegerType
IntegerTypeMap (Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> ([Term h] -> Term h)
-> [Term h]
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Term h] -> Term h
forall v. SupportTermOps v => [v] -> v
sumExpr
            ([Term h] -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> ReaderT (SMTCollectorState t h) IO [Term h]
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
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 Integer
-> Expr t 'BaseIntegerType
-> ReaderT (SMTCollectorState t h) IO [Term h]
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 a. a -> ReaderT (SMTCollectorState t h) IO a
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 a. 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 tp
-> Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap tp
TypeMap 'BaseRealType
RealTypeMap (Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> ([Term h] -> Term h)
-> [Term h]
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Term h] -> Term h
forall v. SupportTermOps v => [v] -> v
sumExpr
            ([Term h] -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> ReaderT (SMTCollectorState t h) IO [Term h]
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
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 Rational
-> Expr t 'BaseRealType
-> ReaderT (SMTCollectorState t h) IO [Term h]
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 a. a -> ReaderT (SMTCollectorState t h) IO a
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 :: Natural). (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 :: Natural). 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 (w :: Natural). NatRepr w -> BV w -> Term h
forall v (w :: Natural). 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 (w :: Natural). NatRepr w -> BV w -> Term h
forall v (w :: Natural). 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 a. 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 tp
-> Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (NatRepr w -> TypeMap (BaseBVType w)
forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w) (Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> ([Term h] -> Term h)
-> [Term h]
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NatRepr w -> [Term h] -> Term h
forall (w :: Natural). NatRepr w -> [Term h] -> Term h
forall v (w :: Natural). SupportTermOps v => NatRepr w -> [v] -> v
bvSumExpr NatRepr w
w
             ([Term h] -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> ReaderT (SMTCollectorState t h) IO [Term h]
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
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 a. a -> ReaderT (SMTCollectorState t h) IO a
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 :: Natural). 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 (w :: Natural). NatRepr w -> BV w -> Term h
forall v (w :: Natural). 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 (w :: Natural). NatRepr w -> BV w -> Term h
forall v (w :: Natural). 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 a. 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 (w :: Natural). NatRepr w -> BV w -> Term h
forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> BV w
forall (w :: Natural). NatRepr w -> BV w
BV.zero NatRepr w
w)
              xorsum [Term h]
xs = (Term h -> Term h -> Term h) -> [Term h] -> Term h
forall a. (a -> a -> a) -> [a] -> a
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 tp
-> Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (NatRepr w -> TypeMap (BaseBVType w)
forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w) (Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> ([Term h] -> Term h)
-> [Term h]
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Term h] -> Term h
xorsum
             ([Term h] -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> ReaderT (SMTCollectorState t h) IO [Term h]
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
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 a. a -> ReaderT (SMTCollectorState t h) IO a
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
      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 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 tp
-> Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap tp
TypeMap 'BaseRealType
RealTypeMap (Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
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
          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
          freshBoundTerm RealTypeMap $ realDiv x 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

      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
      nm <- freshConstant "real sqrt" RealTypeMap
      let 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
      addSideCondition "real sqrt" $ v * v .== x .|| x .< 0
      -- assert v >= 0
      addSideCondition "real sqrt" $ v .>= 0
      -- Return variable
      return nm

    RealSpecialFunction SpecialFunction args
fn (SFn.SpecialFnArgs Assignment (SpecialFnArg (Expr t) 'BaseRealType) args
args) -> 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
      let sf1 :: (Term h -> Term h) ->
                 Ctx.Assignment (SFn.SpecialFnArg (Expr t) BaseRealType) (Ctx.EmptyCtx Ctx.::> SFn.R) ->
                 SMTCollector t h (SMTExpr h BaseRealType)
          sf1 :: (Term h -> Term h)
-> Assignment
     (SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
-> SMTCollector t h (SMTExpr h 'BaseRealType)
sf1 Term h -> Term h
tmfn (Assignment (SpecialFnArg (Expr t) 'BaseRealType) ctx
Ctx.Empty Ctx.:> SFn.SpecialFnArg 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 -> Term h)
-> Term h
-> SMTCollector t h (SMTExpr h 'BaseRealType)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term h -> Term h
tmfn (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
=<< 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 SpecialFunction args
fn of
        SpecialFunction args
SFn.Sin  -> (Term h -> Term h)
-> Assignment
     (SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
-> SMTCollector t h (SMTExpr h 'BaseRealType)
sf1 Term h -> Term h
forall v. SupportTermOps v => v -> v
realSin  Assignment (SpecialFnArg (Expr t) 'BaseRealType) args
Assignment (SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
args
        SpecialFunction args
SFn.Cos  -> (Term h -> Term h)
-> Assignment
     (SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
-> SMTCollector t h (SMTExpr h 'BaseRealType)
sf1 Term h -> Term h
forall v. SupportTermOps v => v -> v
realCos  Assignment (SpecialFnArg (Expr t) 'BaseRealType) args
Assignment (SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
args
        SpecialFunction args
SFn.Tan  -> (Term h -> Term h)
-> Assignment
     (SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
-> SMTCollector t h (SMTExpr h 'BaseRealType)
sf1 Term h -> Term h
forall v. SupportTermOps v => v -> v
realTan  Assignment (SpecialFnArg (Expr t) 'BaseRealType) args
Assignment (SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
args
        SpecialFunction args
SFn.Sinh -> (Term h -> Term h)
-> Assignment
     (SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
-> SMTCollector t h (SMTExpr h 'BaseRealType)
sf1 Term h -> Term h
forall v. SupportTermOps v => v -> v
realSinh Assignment (SpecialFnArg (Expr t) 'BaseRealType) args
Assignment (SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
args
        SpecialFunction args
SFn.Cosh -> (Term h -> Term h)
-> Assignment
     (SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
-> SMTCollector t h (SMTExpr h 'BaseRealType)
sf1 Term h -> Term h
forall v. SupportTermOps v => v -> v
realCosh Assignment (SpecialFnArg (Expr t) 'BaseRealType) args
Assignment (SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
args
        SpecialFunction args
SFn.Tanh -> (Term h -> Term h)
-> Assignment
     (SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
-> SMTCollector t h (SMTExpr h 'BaseRealType)
sf1 Term h -> Term h
forall v. SupportTermOps v => v -> v
realTanh Assignment (SpecialFnArg (Expr t) 'BaseRealType) args
Assignment (SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
args
        SpecialFunction args
SFn.Exp  -> (Term h -> Term h)
-> Assignment
     (SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
-> SMTCollector t h (SMTExpr h 'BaseRealType)
sf1 Term h -> Term h
forall v. SupportTermOps v => v -> v
realExp  Assignment (SpecialFnArg (Expr t) 'BaseRealType) args
Assignment (SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
args
        SpecialFunction args
SFn.Log  -> (Term h -> Term h)
-> Assignment
     (SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
-> SMTCollector t h (SMTExpr h 'BaseRealType)
sf1 Term h -> Term h
forall v. SupportTermOps v => v -> v
realLog  Assignment (SpecialFnArg (Expr t) 'BaseRealType) args
Assignment (SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
args
        SpecialFunction args
SFn.Arctan2 ->
          case Assignment (SpecialFnArg (Expr t) 'BaseRealType) args
args of
            Assignment (SpecialFnArg (Expr t) 'BaseRealType) ctx
Ctx.Empty Ctx.:> SFn.SpecialFnArg Expr t 'BaseRealType
ye Ctx.:> SFn.SpecialFnArg Expr t 'BaseRealType
xe ->
              do 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
                 x <- mkBaseExpr xe
                 freshBoundTerm RealTypeMap $ realATan2 y x
        SpecialFunction args
_ -> Expr t tp -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall (m :: Type -> Type) t (tp :: BaseType) a.
MonadFail m =>
Expr t tp -> m a
unsupportedTerm Expr t tp
i -- TODO? more functions?

    ------------------------------------------
    -- 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 :: Natural). 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 :: Natural). UnaryBV p n -> [(p, Integer, Integer)]
UnaryBV.unsignedRanges UnaryBV (Expr t BaseBoolType) n
t

      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 (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr n
w)
      let 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
      forM_ entries $ \(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)
        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
        addSideCondition "unary term" $ q .== nm_s `bvULe` bvTerm w (BV.mkBV w l)
        addSideCondition "unary term" $ q .== nm_s `bvULe` bvTerm w (BV.mkBV w u)

      case 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 (w :: Natural). NatRepr w -> BV w -> Term h
forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr n
w (NatRepr n -> Integer -> BV n
forall (w :: Natural). 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 a. a -> ReaderT (SMTCollectorState t h) IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
      return nm

    BVOrBits NatRepr w
w BVOrSet (Expr t) w
bs ->
       do 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)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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 :: Natural).
BVOrSet e w -> [e (BaseBVType w)]
bvOrToList BVOrSet (Expr t) w
bs)
          freshBoundTerm (BVTypeMap w) $!
            case bs' of
              [] -> NatRepr w -> BV w -> Term h
forall (w :: Natural). NatRepr w -> BV w -> Term h
forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> BV w
forall (w :: Natural). 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 b a. (b -> a -> b) -> b -> [a] -> b
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
      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
      y <- mkBaseExpr ye
      freshBoundTerm (BVTypeMap w) $ bvConcat x y

    BVSelect NatRepr idx
idx NatRepr n
n Expr t (BaseBVType w)
xe -> do
      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
      freshBoundTerm (BVTypeMap n) $ bvExtract (bvWidth xe) (natValue idx) (natValue n) x

    BVUdiv NatRepr w
w Expr t ('BaseBVType w)
xe Expr t ('BaseBVType w)
ye -> do
      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
      y <- mkBaseExpr ye
      freshBoundTerm (BVTypeMap w) $ bvUDiv x y

    BVUrem NatRepr w
w Expr t ('BaseBVType w)
xe Expr t ('BaseBVType w)
ye -> do
      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
      y <- mkBaseExpr ye
      freshBoundTerm (BVTypeMap w) $ bvURem x y

    BVSdiv NatRepr w
w Expr t ('BaseBVType w)
xe Expr t ('BaseBVType w)
ye -> do
      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
      y <- mkBaseExpr ye
      freshBoundTerm (BVTypeMap w) $ bvSDiv x y

    BVSrem NatRepr w
w Expr t ('BaseBVType w)
xe Expr t ('BaseBVType w)
ye -> do
      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
      y <- mkBaseExpr ye
      freshBoundTerm (BVTypeMap w) $ bvSRem x y

    BVShl NatRepr w
w Expr t ('BaseBVType w)
xe Expr t ('BaseBVType w)
ye -> do
      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
      y <- mkBaseExpr ye
      freshBoundTerm (BVTypeMap w) $ bvShl x y

    BVLshr NatRepr w
w Expr t ('BaseBVType w)
xe Expr t ('BaseBVType w)
ye -> do
      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
      y <- mkBaseExpr ye
      freshBoundTerm (BVTypeMap w) $ bvLshr x y

    BVAshr NatRepr w
w Expr t ('BaseBVType w)
xe Expr t ('BaseBVType w)
ye -> do
      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
      y <- mkBaseExpr ye
      freshBoundTerm (BVTypeMap w) $ bvAshr x y

    BVRol NatRepr w
w Expr t ('BaseBVType w)
xe Expr t ('BaseBVType w)
ye -> do
      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
      y  <- mkBaseExpr ye

      let w' = NatRepr w -> BV w -> Term h
forall (w :: Natural). NatRepr w -> BV w -> Term h
forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> BV w
forall (w :: Natural). NatRepr w -> BV w
BV.width NatRepr w
w)
      y' <- asBase <$> (freshBoundTerm (BVTypeMap w) $ bvURem y w')

      let 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 -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v
bvShl Term h
x Term h
y'

      freshBoundTerm (BVTypeMap w) $ bvXor hi lo

    BVRor NatRepr w
w Expr t ('BaseBVType w)
xe Expr t ('BaseBVType w)
ye -> do
      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
      y  <- mkBaseExpr ye

      let w' = NatRepr w -> BV w -> Term h
forall (w :: Natural). NatRepr w -> BV w -> Term h
forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> BV w
forall (w :: Natural). NatRepr w -> BV w
BV.width NatRepr w
w)
      y' <- asBase <$> (freshBoundTerm (BVTypeMap w) $ bvURem y w')

      let 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 -> 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')

      freshBoundTerm (BVTypeMap w) $ bvXor hi lo

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

    BVFill NatRepr w
w Expr t BaseBoolType
xe ->
      do 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 = NatRepr w -> BV w -> Term h
forall (w :: Natural). NatRepr w -> BV w -> Term h
forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> BV w
forall (w :: Natural). NatRepr w -> BV w
BV.zero NatRepr w
w)
         let ones  = NatRepr w -> BV w -> Term h
forall (w :: Natural). NatRepr w -> BV w -> Term h
forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> BV w
forall (w :: Natural). NatRepr w -> BV w
BV.maxUnsigned NatRepr w
w)
         freshBoundTerm (BVTypeMap w) $ ite x ones zeros

    BVPopcount NatRepr w
w Expr t ('BaseBVType w)
xe ->
      do 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 -> Term h -> Term h -> Term h
forall v. SupportTermOps v => v -> v -> v -> v
ite (NatRepr w -> Natural -> Term h -> Term h
forall (w :: Natural). NatRepr w -> Natural -> Term h -> Term h
forall v (w :: Natural).
SupportTermOps v =>
NatRepr w -> Natural -> v -> v
bvTestBit NatRepr w
w Natural
idx Term h
x) (NatRepr w -> BV w -> Term h
forall (w :: Natural). NatRepr w -> BV w -> Term h
forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> BV w
forall (w :: Natural). (1 <= w) => NatRepr w -> BV w
BV.one NatRepr w
w)) (NatRepr w -> BV w -> Term h
forall (w :: Natural). NatRepr w -> BV w -> Term h
forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> BV w
forall (w :: Natural). NatRepr w -> BV w
BV.zero NatRepr w
w))
                  | Natural
idx <- [ Natural
0 .. NatRepr w -> Natural
forall (n :: Natural). NatRepr n -> Natural
natValue NatRepr w
w Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1 ]
                  ]
         freshBoundTerm (BVTypeMap w) $! bvSumExpr w 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 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
         freshBoundTerm (BVTypeMap w) $! go 0 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 :: Natural). 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 (w :: Natural). NatRepr w -> Natural -> Term h -> Term h
forall v (w :: Natural).
SupportTermOps v =>
NatRepr w -> Natural -> v -> v
bvTestBit NatRepr w
w (NatRepr w -> Natural
forall (n :: Natural). 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 (w :: Natural). NatRepr w -> BV w -> Term h
forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> Integer -> BV w
forall (w :: Natural). 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 (w :: Natural). NatRepr w -> BV w -> Term h
forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> BV w
forall (w :: Natural). 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 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
         freshBoundTerm (BVTypeMap w) $! go 0 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 :: Natural). 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 (w :: Natural). NatRepr w -> Natural -> Term h -> Term h
forall v (w :: Natural).
SupportTermOps v =>
NatRepr w -> Natural -> v -> v
bvTestBit NatRepr w
w Natural
idx Term h
x) (NatRepr w -> BV w -> Term h
forall (w :: Natural). NatRepr w -> BV w -> Term h
forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> Integer -> BV w
forall (w :: Natural). 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 (w :: Natural). NatRepr w -> BV w -> Term h
forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (NatRepr w -> BV w
forall (w :: Natural). 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 (si :: StringInfo).
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
UnicodeRepr -> 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
          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
          freshBoundTerm IntegerTypeMap $ stringLength @h x
        StringInfoRepr si
si -> String -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a. String -> ReaderT (SMTCollectorState t h) IO a
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 (si :: StringInfo).
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
UnicodeRepr -> 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
          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
          y <- mkBaseExpr ye
          k <- mkBaseExpr ke
          freshBoundTerm IntegerTypeMap $ stringIndexOf @h x y k
        StringInfoRepr si
si -> String -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a. String -> ReaderT (SMTCollectorState t h) IO a
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 (si :: StringInfo).
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
UnicodeRepr -> 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
          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
          off <- mkBaseExpr offe
          len <- mkBaseExpr lene
          freshBoundTerm UnicodeTypeMap $ stringSubstring @h x off len
        StringInfoRepr si
si -> String -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a. String -> ReaderT (SMTCollectorState t h) IO a
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 (si :: StringInfo).
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
UnicodeRepr -> 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
          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
          y <- mkBaseExpr ye
          freshBoundTerm BoolTypeMap $ stringContains @h x y
        StringInfoRepr si
si -> String -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a. String -> ReaderT (SMTCollectorState t h) IO a
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 (si :: StringInfo).
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
UnicodeRepr -> 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
          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
          y <- mkBaseExpr ye
          freshBoundTerm BoolTypeMap $ stringIsPrefixOf @h x y
        StringInfoRepr si
si -> String -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a. String -> ReaderT (SMTCollectorState t h) IO a
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 (si :: StringInfo).
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
UnicodeRepr -> 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
          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
          y <- mkBaseExpr ye
          freshBoundTerm BoolTypeMap $ stringIsSuffixOf @h x y
        StringInfoRepr si
si -> String -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a. String -> ReaderT (SMTCollectorState t h) IO a
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
UnicodeRepr -> 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) Unicode
-> ReaderT (SMTCollectorState t h) IO (Term h)
f (SSeq.StringSeqLiteral StringLiteral Unicode
l) = Term h -> ReaderT (SMTCollectorState t h) IO (Term h)
forall a. a -> ReaderT (SMTCollectorState t h) IO a
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
$ forall h. SMTWriter h => Text -> Term h
stringTerm @h (Text -> Term h) -> Text -> Term h
forall a b. (a -> b) -> a -> b
$ StringLiteral Unicode -> Text
fromUnicodeLit StringLiteral Unicode
l
              f (SSeq.StringSeqTerm Expr t ('BaseStringType Unicode)
t)    = Expr t ('BaseStringType Unicode)
-> 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 Unicode)
t
          xs <- (StringSeqEntry (Expr t) Unicode
 -> ReaderT (SMTCollectorState t h) IO (Term h))
-> [StringSeqEntry (Expr t) Unicode]
-> 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)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM StringSeqEntry (Expr t) Unicode
-> ReaderT (SMTCollectorState t h) IO (Term h)
f ([StringSeqEntry (Expr t) Unicode]
 -> ReaderT (SMTCollectorState t h) IO [Term h])
-> [StringSeqEntry (Expr t) Unicode]
-> ReaderT (SMTCollectorState t h) IO [Term h]
forall a b. (a -> b) -> a -> b
$ StringSeq (Expr t) Unicode -> [StringSeqEntry (Expr t) Unicode]
forall (e :: BaseType -> Type) (si :: StringInfo).
StringSeq e si -> [StringSeqEntry e si]
SSeq.toList StringSeq (Expr t) si
StringSeq (Expr t) Unicode
xes
          freshBoundTerm UnicodeTypeMap $ stringAppend @h xs

        StringInfoRepr si
_ -> String -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a. String -> ReaderT (SMTCollectorState t h) IO a
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
      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
      freshBoundTerm (FloatTypeMap fpp) $ floatNeg xe
    FloatAbs FloatPrecisionRepr fpp
fpp Expr t ('BaseFloatType fpp)
x -> do
      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
      freshBoundTerm (FloatTypeMap fpp) $ floatAbs xe
    FloatSqrt FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t ('BaseFloatType fpp)
x -> do
      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
      freshBoundTerm (FloatTypeMap fpp) $ floatSqrt r xe
    FloatAdd FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t ('BaseFloatType fpp)
x Expr t ('BaseFloatType fpp)
y -> do
      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
      ye <- mkBaseExpr y
      freshBoundTerm (FloatTypeMap fpp) $ floatAdd r xe ye
    FloatSub FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t ('BaseFloatType fpp)
x Expr t ('BaseFloatType fpp)
y -> do
      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
      ye <- mkBaseExpr y
      freshBoundTerm (FloatTypeMap fpp) $ floatSub r xe ye
    FloatMul FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t ('BaseFloatType fpp)
x Expr t ('BaseFloatType fpp)
y -> do
      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
      ye <- mkBaseExpr y
      freshBoundTerm (FloatTypeMap fpp) $ floatMul r xe ye
    FloatDiv FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t ('BaseFloatType fpp)
x Expr t ('BaseFloatType fpp)
y -> do
      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
      ye <- mkBaseExpr y
      freshBoundTerm (FloatTypeMap fpp) $ floatDiv r xe ye
    FloatRem FloatPrecisionRepr fpp
fpp Expr t ('BaseFloatType fpp)
x Expr t ('BaseFloatType fpp)
y -> do
      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
      ye <- mkBaseExpr y
      freshBoundTerm (FloatTypeMap fpp) $ floatRem xe ye
    FloatFMA FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t ('BaseFloatType fpp)
x Expr t ('BaseFloatType fpp)
y Expr t ('BaseFloatType fpp)
z -> do
      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
      ye <- mkBaseExpr y
      ze <- mkBaseExpr z
      freshBoundTerm (FloatTypeMap fpp) $ floatFMA r xe ye ze
    FloatFpEq Expr t (BaseFloatType fpp)
x Expr t (BaseFloatType fpp)
y -> do
      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
      ye <- mkBaseExpr y
      freshBoundTerm BoolTypeMap $ floatFpEq xe ye
    FloatLe Expr t (BaseFloatType fpp)
x Expr t (BaseFloatType fpp)
y -> do
      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
      ye <- mkBaseExpr y
      freshBoundTerm BoolTypeMap $ floatLe xe ye
    FloatLt Expr t (BaseFloatType fpp)
x Expr t (BaseFloatType fpp)
y -> do
      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
      ye <- mkBaseExpr y
      freshBoundTerm BoolTypeMap $ floatLt xe ye
    FloatIsNaN Expr t (BaseFloatType fpp)
x -> do
      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
      freshBoundTerm BoolTypeMap $ floatIsNaN xe
    FloatIsInf Expr t (BaseFloatType fpp)
x -> do
      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
      freshBoundTerm BoolTypeMap $ floatIsInf xe
    FloatIsZero Expr t (BaseFloatType fpp)
x -> do
      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
      freshBoundTerm BoolTypeMap $ floatIsZero xe
    FloatIsPos Expr t (BaseFloatType fpp)
x -> do
      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
      freshBoundTerm BoolTypeMap $ floatIsPos xe
    FloatIsNeg Expr t (BaseFloatType fpp)
x -> do
      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
      freshBoundTerm BoolTypeMap $ floatIsNeg xe
    FloatIsSubnorm Expr t (BaseFloatType fpp)
x -> do
      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
      freshBoundTerm BoolTypeMap $ floatIsSubnorm xe
    FloatIsNorm Expr t (BaseFloatType fpp)
x -> do
      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
      freshBoundTerm BoolTypeMap $ floatIsNorm xe
    FloatCast FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t (BaseFloatType fpp')
x -> do
      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
      freshBoundTerm (FloatTypeMap fpp) $
        floatCast fpp r xe
    FloatRound FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t ('BaseFloatType fpp)
x -> do
      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
      freshBoundTerm (FloatTypeMap fpp)$ floatRound r xe
    FloatToBinary fpp :: FloatPrecisionRepr (FloatingPointPrecision eb sb)
fpp@(FloatingPointPrecisionRepr NatRepr eb
eb NatRepr sb
sb) Expr t (BaseFloatType (FloatingPointPrecision eb sb))
x -> do
      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
      val <- asBase <$> (freshConstant "float_binary" $ BVTypeMap $ addNat eb sb)
      -- (assert (= ((_ to_fp eb sb) val) xe))
      addSideCondition "float_binary" $
        floatFromBinary fpp val .== 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 = NatRepr (eb + sb) -> BV (eb + sb) -> Term h
forall (w :: Natural). NatRepr w -> BV w -> Term h
forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm (NatRepr eb -> NatRepr sb -> NatRepr (eb + sb)
forall (m :: Natural) (n :: Natural).
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 :: Natural). NatRepr w -> Integer -> BV w
BV.mkBV (NatRepr eb -> NatRepr sb -> NatRepr (eb + sb)
forall (m :: Natural) (n :: Natural).
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 :: Natural). 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 :: Natural). NatRepr n -> Natural
natValue NatRepr sb
sb Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
2))
      freshBoundTerm (BVTypeMap $ addNat eb sb) $ ite (floatIsNaN xe) qnan val
    FloatFromBinary FloatPrecisionRepr (FloatingPointPrecision eb sb)
fpp Expr t (BaseBVType (eb + sb))
x -> do
      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
      freshBoundTerm (FloatTypeMap fpp) $
        floatFromBinary fpp xe
    BVToFloat FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t (BaseBVType w)
x -> do
      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
      freshBoundTerm (FloatTypeMap fpp) $
        bvToFloat fpp r xe
    SBVToFloat FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t (BaseBVType w)
x -> do
      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
      freshBoundTerm (FloatTypeMap fpp) $
        sbvToFloat fpp r xe
    RealToFloat FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t 'BaseRealType
x -> do
      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
      freshBoundTerm (FloatTypeMap fpp) $
        realToFloat fpp r xe
    FloatToBV NatRepr w
w RoundingMode
r Expr t (BaseFloatType fpp)
x -> do
      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
      freshBoundTerm (BVTypeMap w) $ floatToBV (natValue w) r xe
    FloatToSBV NatRepr w
w RoundingMode
r Expr t (BaseFloatType fpp)
x -> do
      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
      freshBoundTerm (BVTypeMap w) $ floatToSBV (natValue w) r xe
    FloatToReal Expr t (BaseFloatType fpp)
x -> do
      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
      freshBoundTerm RealTypeMap $ floatToReal xe
    FloatSpecialFunction{} -> Expr t tp -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall (m :: Type -> Type) t (tp :: BaseType) a.
MonadFail m =>
Expr t tp -> m a
unsupportedTerm Expr t tp
i

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

    ArrayMap Assignment BaseTypeRepr (i ::> itp)
_ BaseTypeRepr tp1
_ ArrayUpdateMap (Expr t) (i ::> itp) tp1
elts Expr t ('BaseArrayType (i ::> itp) tp1)
def -> do
      base_array <- Expr t ('BaseArrayType (i ::> itp) tp1)
-> SMTCollector t h (SMTExpr h ('BaseArrayType (i ::> itp) tp1))
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t ('BaseArrayType (i ::> itp) tp1)
def
      elt_exprs <- (traverse._2) mkBaseExpr (AUM.toList elts)
      let array_type = SMTExpr h ('BaseArrayType (i ::> itp) tp1)
-> TypeMap ('BaseArrayType (i ::> itp) tp1)
forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h ('BaseArrayType (i ::> itp) tp1)
base_array
      case array_type of
        PrimArrayTypeMap{} -> do
          let set_at_index :: Term h
                           -> (Ctx.Assignment IndexLit ctx, Term h)
                           -> Term h
              set_at_index :: forall (ctx :: Ctx BaseType).
Term h -> (Assignment IndexLit ctx, Term h) -> Term h
set_at_index Term h
ma (Assignment IndexLit ctx
idx, Term h
elt) =
                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 tp
-> Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap tp
TypeMap ('BaseArrayType (i ::> itp) tp1)
array_type (Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h 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 b a. (b -> a -> b) -> b -> [a] -> b
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) tp1) -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h ('BaseArrayType (i ::> itp) tp1)
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 :: forall (ctx :: Ctx BaseType).
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)
-> forall (x :: Ctx BaseType). Assignment IndexLit x -> [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]
forall (f :: BaseType -> Type) a.
(forall (x :: BaseType). f x -> a)
-> forall (x :: Ctx BaseType). Assignment f x -> [a]
toListFC IndexLit x -> Term h
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 tp
-> Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap tp
TypeMap ('BaseArrayType (i ::> itp) tp1)
array_type (Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h 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 b a. (b -> a -> b) -> b -> [a] -> b
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) tp1) -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h ('BaseArrayType (i ::> itp) tp1)
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 a. String -> ReaderT (SMTCollectorState t h) IO a
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 (ZonkAny 13) -> String
forall a. Show a => a -> String
show (Doc (ZonkAny 13) -> String) -> Doc (ZonkAny 13) -> String
forall a b. (a -> b) -> a -> b
$ String -> Doc (ZonkAny 13)
forall ann. String -> Doc ann
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 (ZonkAny 13) -> Doc (ZonkAny 13) -> Doc (ZonkAny 13)
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
                  Doc (ZonkAny 13)
"does not support arrays as functions."
              -- Create names for index variables.
              args <- IO [(Text, Some TypeMap)]
-> ReaderT (SMTCollectorState t h) IO [(Text, Some TypeMap)]
forall a. IO a -> ReaderT (SMTCollectorState t h) IO a
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 = 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 -> [Term h] -> Term h
forall v. SupportTermOps v => v -> [v] -> v
smtFnApp (SMTExpr h ('BaseArrayType (i ::> itp) tp1) -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h ('BaseArrayType (i ::> itp) tp1)
base_array) [Term h]
idx_terms
              -- Return if-then-else structure for next elements.
              let 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)
-> forall (x :: Ctx BaseType). Assignment IndexLit x -> [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]
forall (f :: BaseType -> Type) a.
(forall (x :: BaseType). f x -> a)
-> forall (x :: Ctx BaseType). Assignment f x -> [a]
toListFC IndexLit x -> Term h
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 -> (Assignment IndexLit (i ::> itp), Term h) -> Term h)
-> Term h -> [(Assignment IndexLit (i ::> itp), Term h)] -> Term h
forall b a. (b -> a -> b) -> b -> [a] -> b
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
              SMTName array_type <$> freshBoundFn args resType expr

    ConstantArray Assignment BaseTypeRepr (i ::> tp1)
idxRepr BaseTypeRepr b
_bRepr Expr t b
ve -> do
      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 = SMTExpr h b -> TypeMap b
forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h b
v
          feat = WriterConn t h -> ProblemFeatures
forall t h. WriterConn t h -> ProblemFeatures
supportedFeatures WriterConn t h
conn
          mkArray = if ProblemFeatures
feat ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useSymbolicArrays
                    then Assignment TypeMap (i ::> tp1)
-> TypeMap b -> TypeMap ('BaseArrayType (i ::> tp1) b)
forall (idx :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
Assignment TypeMap (idx ::> idx)
-> TypeMap tp -> TypeMap (BaseArrayType (idx ::> idx) tp)
PrimArrayTypeMap
                    else Assignment TypeMap (i ::> tp1)
-> TypeMap b -> TypeMap ('BaseArrayType (i ::> tp1) b)
forall (idx :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
Assignment TypeMap (idx ::> idx)
-> TypeMap tp -> TypeMap (BaseArrayType (idx ::> idx) tp)
FnArrayTypeMap
      idx_types <- liftIO $
        traverseFC (evalFirstClassTypeRepr conn (eltSource i)) idxRepr
      let tp = Assignment TypeMap (i ::> tp1)
-> TypeMap b -> TypeMap ('BaseArrayType (i ::> tp1) b)
mkArray Assignment TypeMap (i ::> tp1)
idx_types TypeMap b
value_type
      -- make sure any referenced tuple types exist
      liftIO (declareTypes conn tp)

      case 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)
-> forall (x :: Ctx BaseType).
   Assignment TypeMap x -> [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]
forall (f :: BaseType -> Type) a.
(forall (x :: BaseType). f x -> a)
-> forall (x :: Ctx BaseType). Assignment f x -> [a]
toListFC TypeMap x -> Some TypeMap
forall k (f :: k -> Type) (x :: k). f x -> Some f
forall (x :: BaseType). TypeMap x -> Some TypeMap
Some Assignment TypeMap (i ::> tp1)
idx_types
            TypeMap tp
-> Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap tp
TypeMap ('BaseArrayType (i ::> tp1) b)
tp (Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
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 a. String -> ReaderT (SMTCollectorState t h) IO a
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 (ZonkAny 14) -> String
forall a. Show a => a -> String
show (Doc (ZonkAny 14) -> String) -> Doc (ZonkAny 14) -> String
forall a b. (a -> b) -> a -> b
$ String -> Doc (ZonkAny 14)
forall ann. String -> Doc ann
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 (ZonkAny 14) -> Doc (ZonkAny 14) -> Doc (ZonkAny 14)
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
              Doc (ZonkAny 14)
"cannot encode constant arrays."
          -- Create names for index variables.
          args <- IO [(Text, Some TypeMap)]
-> ReaderT (SMTCollectorState t h) IO [(Text, Some TypeMap)]
forall a. IO a -> ReaderT (SMTCollectorState t h) IO a
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 ::> tp1) -> 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 ::> tp1)
idx_types
          SMTName tp <$> freshBoundFn args value_type (asBase v)

    SelectArray BaseTypeRepr tp
_bRepr Expr t (BaseArrayType (i ::> tp1) tp)
a Assignment (Expr t) (i ::> tp1)
idx -> do
      aexpr <- Expr t (BaseArrayType (i ::> tp1) tp)
-> SMTCollector t h (SMTExpr h (BaseArrayType (i ::> tp1) tp))
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t (BaseArrayType (i ::> tp1) tp)
a
      idxl <- mkIndicesTerms idx
      freshBoundTerm' $ smt_array_select aexpr idxl

    UpdateArray BaseTypeRepr b
_bRepr Assignment BaseTypeRepr (i ::> tp1)
_ Expr t ('BaseArrayType (i ::> tp1) b)
a_elt Assignment (Expr t) (i ::> tp1)
idx Expr t b
ve -> do
      a <- Expr t ('BaseArrayType (i ::> tp1) b)
-> SMTCollector t h (SMTExpr h ('BaseArrayType (i ::> tp1) b))
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t ('BaseArrayType (i ::> tp1) b)
a_elt
      updated_idx <- mkIndicesTerms idx
      value <- asBase <$> mkExpr ve
      let array_type = SMTExpr h ('BaseArrayType (i ::> tp1) b)
-> TypeMap ('BaseArrayType (i ::> tp1) b)
forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h ('BaseArrayType (i ::> tp1) b)
a
      case array_type of
        PrimArrayTypeMap Assignment TypeMap (idxl ::> idx)
_ TypeMap tp
_ -> do
            TypeMap tp
-> Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap tp
TypeMap ('BaseArrayType (i ::> tp1) b)
array_type (Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a b. (a -> b) -> a -> b
$
              forall h. SMTWriter h => Term h -> [Term h] -> Term h -> Term h
arrayUpdate @h (SMTExpr h ('BaseArrayType (i ::> tp1) b) -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h ('BaseArrayType (i ::> tp1) 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 tp
-> Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap tp
TypeMap ('BaseArrayType (i ::> tp1) b)
array_type (Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a b. (a -> b) -> a -> b
$ Term h -> [Term h] -> Term h -> Term h
updateFn (SMTExpr h ('BaseArrayType (i ::> tp1) b) -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h ('BaseArrayType (i ::> tp1) 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.
              args <- IO [(Text, Some TypeMap)]
-> ReaderT (SMTCollectorState t h) IO [(Text, Some TypeMap)]
forall a. IO a -> ReaderT (SMTCollectorState t h) IO a
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 = 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 -> [Term h] -> Term h
forall v. SupportTermOps v => v -> [v] -> v
smtFnApp (SMTExpr h ('BaseArrayType (i ::> tp1) b) -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h ('BaseArrayType (i ::> tp1) b)
a) [Term h]
idx_terms
              let 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 -> 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
              SMTName array_type <$> freshBoundFn args resType expr

    CopyArray NatRepr w
_w_repr BaseTypeRepr a
_a_repr Expr t ('BaseArrayType (SingleCtx (BaseBVType w)) a)
dest_arr Expr t (BaseBVType w)
dest_idx Expr t ('BaseArrayType (SingleCtx (BaseBVType w)) a)
src_arr Expr t (BaseBVType w)
src_idx Expr t (BaseBVType w)
len Expr t (BaseBVType w)
_dest_end_idx Expr t (BaseBVType w)
_src_end_idx -> do
      dest_arr_typed_expr <- Expr t ('BaseArrayType (SingleCtx (BaseBVType w)) a)
-> SMTCollector
     t h (SMTExpr h ('BaseArrayType (SingleCtx (BaseBVType w)) a))
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t ('BaseArrayType (SingleCtx (BaseBVType w)) a)
dest_arr
      let arr_type = SMTExpr h ('BaseArrayType (SingleCtx (BaseBVType w)) a)
-> TypeMap ('BaseArrayType (SingleCtx (BaseBVType w)) a)
forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h ('BaseArrayType (SingleCtx (BaseBVType w)) a)
dest_arr_typed_expr
      dest_idx_typed_expr <- mkExpr dest_idx
      let dest_idx_expr = SMTExpr h (BaseBVType w) -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h (BaseBVType w)
dest_idx_typed_expr
      let idx_type = SMTExpr h (BaseBVType w) -> TypeMap (BaseBVType w)
forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h (BaseBVType w)
dest_idx_typed_expr
      src_arr_typed_expr <- mkExpr src_arr
      src_idx_expr <- mkBaseExpr src_idx
      len_expr <- mkBaseExpr len

      res <- freshConstant "array_copy" arr_type

      cr <- liftIO $ withConnEntryStack conn $ runInSandbox conn $ do
        i_expr <- asBase <$> freshConstant "i" idx_type
        return $ asBase (smt_array_select res [i_expr]) .==
          ite ((bvULe dest_idx_expr i_expr) .&& (bvULt i_expr (bvAdd dest_idx_expr len_expr)))
            (asBase (smt_array_select src_arr_typed_expr [bvAdd src_idx_expr (bvSub i_expr dest_idx_expr)]))
            (asBase (smt_array_select dest_arr_typed_expr [i_expr]))
      addSideCondition "array copy" $ forallResult cr
      addSideCondition "array copy" $ bvULt dest_idx_expr (bvAdd dest_idx_expr len_expr)
      addSideCondition "array copy" $ bvULt src_idx_expr (bvAdd src_idx_expr len_expr)

      return res

    SetArray NatRepr w
_w_repr BaseTypeRepr a
_a_repr Expr t ('BaseArrayType (SingleCtx (BaseBVType w)) a)
arr Expr t (BaseBVType w)
idx Expr t a
val Expr t (BaseBVType w)
len Expr t (BaseBVType w)
_end_idx -> do
      arr_typed_expr <- Expr t ('BaseArrayType (SingleCtx (BaseBVType w)) a)
-> SMTCollector
     t h (SMTExpr h ('BaseArrayType (SingleCtx (BaseBVType w)) a))
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t ('BaseArrayType (SingleCtx (BaseBVType w)) a)
arr
      let arr_type = SMTExpr h ('BaseArrayType (SingleCtx (BaseBVType w)) a)
-> TypeMap ('BaseArrayType (SingleCtx (BaseBVType w)) a)
forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h ('BaseArrayType (SingleCtx (BaseBVType w)) a)
arr_typed_expr
      idx_typed_expr <- mkExpr idx
      let idx_expr = SMTExpr h (BaseBVType w) -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h (BaseBVType w)
idx_typed_expr
      let idx_type = SMTExpr h (BaseBVType w) -> TypeMap (BaseBVType w)
forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h (BaseBVType w)
idx_typed_expr
      val_expr <- mkBaseExpr val
      len_expr <- mkBaseExpr len

      res <- freshConstant "array_set" arr_type
      cr <- liftIO $ withConnEntryStack conn $ runInSandbox conn $ do
        i_expr <- asBase <$> freshConstant "i" idx_type
        return $ asBase (smt_array_select res [i_expr]) .==
          ite ((bvULe idx_expr i_expr) .&& (bvULt i_expr (bvAdd idx_expr len_expr)))
            val_expr
            (asBase (smt_array_select arr_typed_expr [i_expr]))
      addSideCondition "array set" $ forallResult cr
      addSideCondition "array set" $ bvULt idx_expr (bvAdd idx_expr len_expr)

      return res

    EqualArrayRange NatRepr w
_w_repr BaseTypeRepr a
_a_repr Expr t (BaseArrayType (SingleCtx (BaseBVType w)) a)
x_arr Expr t (BaseBVType w)
x_idx Expr t (BaseArrayType (SingleCtx (BaseBVType w)) a)
y_arr Expr t (BaseBVType w)
y_idx Expr t (BaseBVType w)
len Expr t (BaseBVType w)
_x_end_idx Expr t (BaseBVType w)
_y_end_idx -> do
      x_arr_typed_expr <- Expr t (BaseArrayType (SingleCtx (BaseBVType w)) a)
-> SMTCollector
     t h (SMTExpr h (BaseArrayType (SingleCtx (BaseBVType w)) a))
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t (BaseArrayType (SingleCtx (BaseBVType w)) a)
x_arr
      x_idx_typed_expr <- mkExpr x_idx
      let x_idx_expr = SMTExpr h (BaseBVType w) -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h (BaseBVType w)
x_idx_typed_expr
      let idx_type = SMTExpr h (BaseBVType w) -> TypeMap (BaseBVType w)
forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h (BaseBVType w)
x_idx_typed_expr
      y_arr_typed_expr <- mkExpr y_arr
      y_idx_expr <- mkBaseExpr y_idx
      len_expr <- mkBaseExpr len

      cr <- liftIO $ withConnEntryStack conn $ runInSandbox conn $ do
        i_expr <- asBase <$> freshConstant "i" idx_type
        return $ impliesExpr ((bvULe x_idx_expr i_expr) .&& (bvULt i_expr (bvAdd x_idx_expr len_expr)))
          ((asBase (smt_array_select x_arr_typed_expr [i_expr])) .==
            (asBase (smt_array_select y_arr_typed_expr [bvAdd y_idx_expr (bvSub i_expr x_idx_expr)])))
      addSideCondition "array range equal" $ bvULt x_idx_expr (bvAdd x_idx_expr len_expr)
      addSideCondition "array range equal" $ bvULt y_idx_expr (bvAdd y_idx_expr len_expr)

      freshBoundTerm BoolTypeMap $ forallResult cr

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

    IntegerToReal Expr t 'BaseIntegerType
xe -> do
      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
      return $ SMTExpr RealTypeMap (termIntegerToReal (asBase 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
      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
      return $ SMTExpr IntegerTypeMap (termRealToInteger 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
      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
      nm <- freshConstant "round" IntegerTypeMap
      let 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
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
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
      addSideCondition "round" $ x .<  0 .|| posExpr
      addSideCondition "round" $ x .>= 0 .|| negExpr
      return 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
      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
      nm <- asBase <$> freshConstant "roundEven" IntegerTypeMap
      r <- asBase <$> freshBoundTerm RealTypeMap (termIntegerToReal nm)
      -- Assert that `x` is in the interval `[r, r+1]`
      addSideCondition "roundEven" $ (r .<= x) .&& (x .<= r+1)
      diff <- asBase <$> freshBoundTerm RealTypeMap (x - r)
      freshBoundTerm IntegerTypeMap $
        ite (diff .< rationalTerm 0.5) nm $
          ite (diff .> rationalTerm 0.5) (nm+1) $
            ite (intDivisible nm 2) nm (nm+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
      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
      nm <- freshConstant "floor" IntegerTypeMap
      let 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)
      addSideCondition "floor" $ (floor_r .<= x) .&& (x .< floor_r + 1)
      return 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
      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
      nm <- freshConstant "ceiling" IntegerTypeMap
      let 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)
      addSideCondition "ceiling" $ (x .<= r) .&& (r .< x + 1)
      return 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
      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
      freshBoundTerm IntegerTypeMap $ bvIntTerm (bvWidth xe) (asBase 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
      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
      freshBoundTerm IntegerTypeMap $ sbvIntTerm (bvWidth xe) (asBase 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

      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 = SMTExpr h 'BaseIntegerType -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h 'BaseIntegerType
x

      res <- freshConstant "integerToBV" (BVTypeMap w)
      bvint <- freshBoundTerm IntegerTypeMap $ bvIntTerm w (asBase res)

      addSideCondition "integerToBV" $
         (intDivisible (xb - (asBase bvint)) (2^natValue w))
      return res

    Cplx Complex (Expr t 'BaseRealType)
c -> do
      (rl :+ 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)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> Complex a -> f (Complex 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

      feat <- asks (supportedFeatures . 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 = 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 tp
-> Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap tp
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
            ra <-
              case 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 a. a -> ReaderT (SMTCollectorState t h) IO a
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
                  a <- SMTExpr h 'BaseComplexType -> Term h
forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase (SMTExpr h 'BaseComplexType -> Term h)
-> ReaderT (SMTCollectorState t h) IO (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
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h 'BaseComplexType)
forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
"complex lit" TypeMap 'BaseComplexType
tp
                  return $! arrayUpdate @h a [boolExpr False] r'
            freshBoundTerm tp $! arrayUpdate @h ra [boolExpr True] i'

          | Bool
otherwise ->
            WriterConn t h
-> String
-> Expr t tp
-> ReaderT (SMTCollectorState t h) IO (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
      c <- Expr t 'BaseComplexType
-> ReaderT (SMTCollectorState t h) IO (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 smtExprType c of
        TypeMap 'BaseComplexType
ComplexToStructTypeMap ->
          do let prj :: Term h
prj = 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 tp
-> Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap tp
TypeMap 'BaseRealType
RealTypeMap Term h
prj
        TypeMap 'BaseComplexType
ComplexToArrayTypeMap ->
          TypeMap tp
-> Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap tp
TypeMap 'BaseRealType
RealTypeMap (Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a b. (a -> b) -> a -> b
$ 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
      c <- Expr t 'BaseComplexType
-> ReaderT (SMTCollectorState t h) IO (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 smtExprType c of
        TypeMap 'BaseComplexType
ComplexToStructTypeMap ->
          do let prj :: Term h
prj = 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 tp
-> Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap tp
TypeMap 'BaseRealType
RealTypeMap Term h
prj
        TypeMap 'BaseComplexType
ComplexToArrayTypeMap ->
          TypeMap tp
-> Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap tp
TypeMap 'BaseRealType
RealTypeMap (Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp))
-> Term h -> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a b. (a -> b) -> a -> b
$ 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.
      exprs <- (forall (x :: BaseType).
 Expr t x -> ReaderT (SMTCollectorState t h) IO (SMTExpr h x))
-> forall (x :: Ctx BaseType).
   Assignment (Expr t) x
   -> ReaderT (SMTCollectorState t h) IO (Assignment (SMTExpr h) x)
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)
forall (f :: BaseType -> Type) (g :: BaseType -> Type)
       (m :: Type -> Type).
Applicative m =>
(forall (x :: BaseType). f x -> m (g x))
-> forall (x :: Ctx BaseType). Assignment f x -> m (Assignment g x)
traverseFC Expr t x -> SMTCollector t h (SMTExpr h x)
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 = (forall (x :: BaseType). SMTExpr h x -> TypeMap x)
-> forall (x :: Ctx BaseType).
   Assignment (SMTExpr h) x -> Assignment TypeMap x
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
forall (f :: BaseType -> Type) (g :: BaseType -> Type).
(forall (x :: BaseType). f x -> g x)
-> forall (x :: Ctx BaseType). Assignment f x -> Assignment g x
fmapFC SMTExpr h x -> TypeMap x
forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
forall (x :: BaseType). SMTExpr h x -> TypeMap x
smtExprType Assignment (SMTExpr h) flds
exprs

      liftIO $ declareStructDatatype conn fld_types
      let tm = 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)
-> forall (x :: Ctx BaseType). Assignment (SMTExpr h) x -> [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]
forall (f :: BaseType -> Type) a.
(forall (x :: BaseType). f x -> a)
-> forall (x :: Ctx BaseType). Assignment f x -> [a]
toListFC SMTExpr h x -> Term h
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)
      freshBoundTerm (StructTypeMap fld_types) tm

    StructField Expr t (BaseStructType flds)
s Index flds tp
idx BaseTypeRepr tp
_tp -> do
      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 smtExprType 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 = 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 -> ReaderT (SMTCollectorState t h) IO (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 :: 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) 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
      x <- IO (SMTExpr h tp)
-> ReaderT (SMTCollectorState t h) IO (SMTExpr h tp)
forall a. IO a -> ReaderT (SMTCollectorState t h) IO a
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
      bindVar v 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 :: 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
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
      smt_ret <- WriterConn t h
-> SMTSource (ZonkAny 8) -> 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 (ZonkAny 8)
forall ann. SolverSymbol -> ProgramLoc -> SMTSource ann
fnSource SolverSymbol
fnm ProgramLoc
l) BaseTypeRepr ret
return_type
      traverseFC_ (declareTypes conn) arg_types
      declareTypes conn smt_ret
      addCommand conn $
        declareCommand conn nm arg_types smt_ret
      return $! 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 :: 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 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 a b. IO a -> (a -> IO b) -> IO b
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 a. String -> IO a
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 a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text
nm, TypeMap ret
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.
      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)
      ret_type <- mkSMTSymFn conn nm fn arg_types
      cacheValueFn conn n DeleteNever $! SMTSymFn nm arg_types ret_type
      return (nm, ret_type)

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

-- | Write a expression to SMT
mkSMTTerm :: SMTWriter h => WriterConn t h -> Expr t tp -> IO (Term h)
mkSMTTerm :: forall h t (tp :: BaseType).
SMTWriter h =>
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 :: forall h t.
SMTWriter h =>
WriterConn t h -> BoolExpr t -> IO (Term h)
mkFormula = WriterConn t h -> Expr t BaseBoolType -> 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 :: forall h t. SMTWriter h => 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 a b.
ReaderT (SMTCollectorState t h) IO a
-> (a -> ReaderT (SMTCollectorState t h) IO b)
-> ReaderT (SMTCollectorState t h) IO b
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 a. a -> ReaderT (SMTCollectorState t h) IO a
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 :: forall h t. SMTWriter h => 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
    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
    updateProgramLoc c (exprLoc v)
    case 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 { forall h.
SMTEvalBVArrayWrapper h
-> forall (w :: Natural) (v :: Natural). SMTEvalBVArrayFn h w v
unEvalBVArrayWrapper :: forall w v. SMTEvalBVArrayFn h w v }

data SMTEvalFunctions h
   = SMTEvalFunctions { forall h. SMTEvalFunctions h -> Term h -> IO Bool
smtEvalBool :: Term h -> IO Bool
                        -- ^ Given a SMT term for a Boolean value, this should
                        -- return an indication of whether the term is assigned
                        -- true or false.
                      , forall h.
SMTEvalFunctions h
-> forall (w :: Natural). 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.
                      , forall h. 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.
                      , forall h.
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.
                      , forall h. 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.
                      , forall h. SMTEvalFunctions h -> Term h -> IO Text
smtEvalString :: Term h -> IO Text
                        -- ^ 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 -> WriterConn t h -> IO (SatResult () ())

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

  -- | Parse an abduct returned by the get-abduct command
  smtAbductResult :: f h -> WriterConn t h -> Text -> Term h -> IO String

  -- | Parse an abduct returned by the get-abduct-next command
  smtAbductNextResult :: f h -> WriterConn t h -> IO String

  -- | 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 -> WriterConn t h -> 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 :: forall v (idx :: Ctx BaseType).
SupportTermOps v =>
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 Index idx tp -> [v] -> [v]
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 :: forall (tp :: BaseType). 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 -> Integer -> v
forall v. SupportTermOps v => Integer -> v
integerTerm Integer
GroundValue tp
v
                      BVTypeMap NatRepr w
w -> NatRepr w -> BV w -> v
forall (w :: Natural). NatRepr w -> BV w -> v
forall v (w :: Natural). 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 :: forall h t (tp :: BaseType).
SMTWriter h =>
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
-> forall (w :: Natural). NatRepr w -> Term h -> IO (BV w)
forall h.
SMTEvalFunctions h
-> forall (w :: Natural). 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 :: Natural). 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
-> forall (fpp :: FloatPrecision).
   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
UnicodeTypeMap Term h
tm = Text -> StringLiteral Unicode
UnicodeLiteral (Text -> StringLiteral Unicode)
-> IO Text -> IO (StringLiteral Unicode)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SMTEvalFunctions h -> Term h -> IO Text
forall h. SMTEvalFunctions h -> Term h -> IO Text
smtEvalString SMTEvalFunctions h
smtFns Term h
tm
getSolverVal WriterConn t h
_ SMTEvalFunctions h
smtFns TypeMap tp
IntegerTypeMap Term h
tm = do
  r <- SMTEvalFunctions h -> Term h -> IO Rational
forall h. SMTEvalFunctions h -> Term h -> IO Rational
smtEvalReal SMTEvalFunctions h
smtFns Term h
tm
  when (denominator r /= 1) $ fail "Expected integer value."
  return (numerator 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 (forall h. SMTWriter h => Term h -> Term h
structComplexRealPart @h Term h
tm)
       IO (Rational -> Complex Rational)
-> IO Rational -> IO (Complex Rational)
forall a b. IO (a -> b) -> IO a -> IO b
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 (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 (forall h. SMTWriter h => Term h -> Term h
arrayComplexRealPart @h Term h
tm)
       IO (Rational -> Complex Rational)
-> IO Rational -> IO (Complex Rational)
forall a b. IO (a -> b) -> IO a -> IO b
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 (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 :: Natural) (v :: Natural). 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 :: Natural) (v :: Natural). 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 a. a -> IO a
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 = 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 = GroundValue tp -> IO (GroundValue tp)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (GroundValue tp -> IO (GroundValue tp))
-> GroundValue tp -> IO (GroundValue 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 :: forall (ctx :: Ctx BaseType) (utp :: BaseType).
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 = 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 :: forall t h.
SMTWriter h =>
WriterConn t h -> SMTEvalFunctions h -> IO (GroundEvalFn t)
smtExprGroundEvalFn WriterConn t h
conn SMTEvalFunctions h
smtFns = do
  -- Get solver features
  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
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 (tp :: BaseType). Expr t tp -> IO (GroundValue tp))
-> 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 Expr t u -> IO (GroundValue u)
forall (tp :: BaseType). Expr t tp -> IO (GroundValue tp)
cachedEval Expr t tp
e
          Just Nonce t tp
e_id -> (GroundValueWrapper tp -> GroundValue tp)
-> IO (GroundValueWrapper tp) -> IO (GroundValue tp)
forall a b. (a -> b) -> IO a -> IO b
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 a b. (a -> b) -> IO a -> IO b
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.
            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 me of
              -- Otherwise, try the evalGroundExpr function to evaluate a ground element.
              Maybe (SMTExpr h tp)
Nothing -> (forall (tp :: BaseType). Expr t tp -> IO (GroundValue tp))
-> 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 Expr t u -> IO (GroundValue u)
forall (tp :: BaseType). Expr t tp -> IO (GroundValue tp)
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 (m :: Type -> Type) a. Monad m => m a -> MaybeT m a
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 (tp :: BaseType). Expr t tp -> IO (GroundValue tp)
cachedEval) Expr t tp
e) IO (Maybe (GroundValue tp))
-> (Maybe (GroundValue tp) -> IO (GroundValue tp))
-> IO (GroundValue tp)
forall a b. IO a -> (a -> IO b) -> IO b
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 a. a -> IO a
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


  return $ GroundEvalFn cachedEval