{- |
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 " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show NatRepr w
n
  show (FloatTypeMap FloatPrecisionRepr fpp
x)         = String
"FloatTypeMap " forall a. [a] -> [a] -> [a]
++ 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 " forall a. [a] -> [a] -> [a]
++ forall k (f :: k -> Type) (tp :: k). ShowF f => f tp -> String
showF Assignment TypeMap (idxl ::> idx)
ctx forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall k (f :: k -> Type) (tp :: k). ShowF f => f tp -> String
showF TypeMap tp
a
  show (FnArrayTypeMap Assignment TypeMap (idxl ::> idx)
ctx TypeMap tp
a)   = String
"FnArrayTypeMap " forall a. [a] -> [a] -> [a]
++ forall k (f :: k -> Type) (tp :: k). ShowF f => f tp -> String
showF Assignment TypeMap (idxl ::> idx)
ctx forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall k (f :: k -> Type) (tp :: k). ShowF f => f tp -> String
showF TypeMap tp
a
  show (StructTypeMap Assignment TypeMap idx
ctx)      = String
"StructTypeMap " forall a. [a] -> [a] -> [a]
++ forall k (f :: k -> Type) (tp :: k). ShowF f => f tp -> String
showF Assignment TypeMap idx
ctx


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

instance TestEquality TypeMap where
  testEquality :: forall (a :: BaseType) (b :: BaseType).
TypeMap a -> TypeMap b -> Maybe (a :~: b)
testEquality TypeMap a
BoolTypeMap TypeMap b
BoolTypeMap = forall a. a -> Maybe a
Just forall {k} (a :: k). a :~: a
Refl
  testEquality TypeMap a
IntegerTypeMap TypeMap b
IntegerTypeMap = forall a. a -> Maybe a
Just forall {k} (a :: k). a :~: a
Refl
  testEquality TypeMap a
RealTypeMap TypeMap b
RealTypeMap = forall a. a -> Maybe a
Just forall {k} (a :: k). a :~: a
Refl
  testEquality TypeMap a
UnicodeTypeMap TypeMap b
UnicodeTypeMap = forall a. a -> Maybe a
Just forall {k} (a :: k). a :~: a
Refl
  testEquality (FloatTypeMap FloatPrecisionRepr fpp
x) (FloatTypeMap FloatPrecisionRepr fpp
y) = do
    fpp :~: fpp
Refl <- forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality FloatPrecisionRepr fpp
x FloatPrecisionRepr fpp
y
    forall (m :: Type -> Type) a. Monad m => a -> m a
return forall {k} (a :: k). a :~: a
Refl
  testEquality (BVTypeMap NatRepr w
x) (BVTypeMap NatRepr w
y) = do
    w :~: w
Refl <- 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
    forall (m :: Type -> Type) a. Monad m => a -> m a
return forall {k} (a :: k). a :~: a
Refl
  testEquality TypeMap a
ComplexToStructTypeMap TypeMap b
ComplexToStructTypeMap =
    forall a. a -> Maybe a
Just forall {k} (a :: k). a :~: a
Refl
  testEquality TypeMap a
ComplexToArrayTypeMap TypeMap b
ComplexToArrayTypeMap =
    forall a. a -> Maybe a
Just forall {k} (a :: k). a :~: a
Refl
  testEquality (PrimArrayTypeMap Assignment TypeMap (idxl ::> idx)
xa TypeMap tp
xr) (PrimArrayTypeMap Assignment TypeMap (idxl ::> idx)
ya TypeMap tp
yr) = do
    (idxl ::> idx) :~: (idxl ::> idx)
Refl <- forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality Assignment TypeMap (idxl ::> idx)
xa Assignment TypeMap (idxl ::> idx)
ya
    tp :~: tp
Refl <- forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality TypeMap tp
xr TypeMap tp
yr
    forall a. a -> Maybe a
Just forall {k} (a :: k). a :~: a
Refl
  testEquality (FnArrayTypeMap Assignment TypeMap (idxl ::> idx)
xa TypeMap tp
xr) (FnArrayTypeMap Assignment TypeMap (idxl ::> idx)
ya TypeMap tp
yr) = do
    (idxl ::> idx) :~: (idxl ::> idx)
Refl <- forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality Assignment TypeMap (idxl ::> idx)
xa Assignment TypeMap (idxl ::> idx)
ya
    tp :~: tp
Refl <- forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality TypeMap tp
xr TypeMap tp
yr
    forall a. a -> Maybe a
Just forall {k} (a :: k). a :~: a
Refl
  testEquality (StructTypeMap Assignment TypeMap idx
x) (StructTypeMap Assignment TypeMap idx
y) = do
    idx :~: idx
Refl <- forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality Assignment TypeMap idx
x Assignment TypeMap idx
y
    forall a. a -> Maybe a
Just forall {k} (a :: k). a :~: a
Refl
  testEquality TypeMap a
_ TypeMap 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
IntegerTypeMap
semiRingTypeMap SemiRingRepr sr
SR.SemiRingRealRepr        = TypeMap 'BaseRealType
RealTypeMap
semiRingTypeMap (SR.SemiRingBVRepr BVFlavorRepr fv
_flv NatRepr w
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 = forall v. SupportTermOps v => [v] -> v
andAll [v
x, v
y]

  (.||)    :: v -> v -> v
  v
x .|| v
y = 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 = forall v. SupportTermOps v => v -> v
notExpr (v
x forall v. SupportTermOps v => v -> v -> v
.== v
y)

  impliesExpr :: v -> v -> v
  impliesExpr v
x v
y = forall v. SupportTermOps v => v -> v
notExpr v
x 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) = forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl 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 = forall v. SupportTermOps v => v -> v
notExpr (v
y forall v. SupportTermOps v => v -> v -> v
.<= v
x)

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

  -- | Greater then or equal
  (.>=) :: v -> v -> v
  v
x .>= v
y = v
y 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 = (forall v (w :: Natural).
SupportTermOps v =>
NatRepr w -> Natural -> Natural -> v -> v
bvExtract NatRepr w
w Natural
i Natural
1 v
x forall v. SupportTermOps v => v -> v -> v
.== forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr 1
w1 (forall (w :: Natural). (1 <= w) => NatRepr w -> BV w
BV.one NatRepr 1
w1))
    where w1 :: NatRepr 1
          w1 :: NatRepr 1
w1 = forall (n :: Natural). KnownNat n => NatRepr n
knownNat

  bvSumExpr :: NatRepr w -> [v] -> v
  bvSumExpr NatRepr w
w [] = forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (forall (w :: Natural). NatRepr w -> BV w
BV.zero NatRepr w
w)
  bvSumExpr NatRepr w
_ (v
h:[v]
r) = forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl 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 = 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 = 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 (forall {k} (ctx :: Ctx k) (f :: k -> Type).
(ctx ~ EmptyCtx) =>
Assignment f ctx
Ctx.Empty forall {k} (ctx' :: Ctx k) (f :: k -> Type) (ctx :: Ctx k)
       (tp :: k).
(ctx' ~ (ctx ::> tp)) =>
Assignment f ctx -> f tp -> Assignment f ctx'
Ctx.:> TypeMap 'BaseRealType
RealTypeMap forall {k} (ctx' :: Ctx k) (f :: k -> Type) (ctx :: Ctx k)
       (tp :: k).
(ctx' ~ (ctx ::> tp)) =>
Assignment f ctx -> f tp -> Assignment f ctx'
Ctx.:> TypeMap 'BaseRealType
RealTypeMap) (forall {k} (n :: 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 (forall {k} (ctx :: Ctx k) (f :: k -> Type).
(ctx ~ EmptyCtx) =>
Assignment f ctx
Ctx.Empty forall {k} (ctx' :: Ctx k) (f :: k -> Type) (ctx :: Ctx k)
       (tp :: k).
(ctx' ~ (ctx ::> tp)) =>
Assignment f ctx -> f tp -> Assignment f ctx'
Ctx.:> TypeMap 'BaseRealType
RealTypeMap forall {k} (ctx' :: Ctx k) (f :: k -> Type) (ctx :: Ctx k)
       (tp :: k).
(ctx' ~ (ctx ::> tp)) =>
Assignment f ctx -> f tp -> Assignment f ctx'
Ctx.:> TypeMap 'BaseRealType
RealTypeMap) (forall {k} (n :: 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 [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 [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
"(" forall a. Semigroup a => a -> a -> a
<> Builder
o forall a. Semigroup a => a -> a -> a
<> forall {a}. (IsString a, Semigroup a) => [a] -> a
go [Builder]
args
  where go :: [a] -> a
go [] = a
")"
        go (a
f:[a]
r) = a
" " forall a. Semigroup a => a -> a -> a
<> a
f forall a. Semigroup a => a -> a -> a
<> [a] -> a
go [a]
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) = 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 = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens WriterState -> Word64
_nextTermIdx (\WriterState
s Word64
v -> WriterState
s { _nextTermIdx :: Word64
_nextTermIdx = Word64
v })

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

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

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

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

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

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

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

data StackEntry t (h :: Type) = StackEntry
  { 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 = forall t h.
(WriterConn t h -> Command h -> IO ()) -> AcknowledgementAction t h
AckAction (\WriterConn t h
_ Command h
_ -> 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
  IdxCache t (SMTExpr h)
exprCache <- forall (m :: Type -> Type) t (f :: BaseType -> Type).
MonadIO m =>
m (IdxCache t f)
newIdxCache
  HashTable RealWorld (Nonce t) SMTSymFn
fnCache   <- forall a. ST RealWorld a -> IO a
stToIO forall a b. (a -> b) -> a -> b
$ forall {k} s (key :: k -> Type) (val :: k -> Type).
ST s (HashTable s key val)
PH.new
  forall (m :: Type -> Type) a. Monad m => a -> m a
return StackEntry
    { symExprCache :: IdxCache t (SMTExpr h)
symExprCache = IdxCache t (SMTExpr h)
exprCache
    , symFnCache :: HashTable RealWorld (Nonce t) SMTSymFn
symFnCache   = HashTable RealWorld (Nonce t) SMTSymFn
fnCache
    }

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


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

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

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

popEntryStack :: WriterConn t h -> IO ()
popEntryStack :: forall t h. WriterConn t h -> IO ()
popEntryStack WriterConn t h
c = do
  [StackEntry t h]
stk <- forall a. IORef a -> IO a
readIORef (forall t h. WriterConn t h -> IORef [StackEntry t h]
entryStack WriterConn t h
c)
  case [StackEntry t h]
stk of
   []  -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Could not pop from empty entry stack."
   [StackEntry t h
_] -> 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) -> forall a. IORef a -> a -> IO ()
writeIORef (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
  StackEntry t cs
entry <- forall t h. IO (StackEntry t h)
newStackEntry
  IORef [StackEntry t cs]
stk_ref <- forall a. a -> IO (IORef a)
newIORef [StackEntry t cs
entry]
  IORef WriterState
r <- forall a. a -> IO (IORef a)
newIORef WriterState
emptyState
  forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! WriterConn { smtWriterName :: String
smtWriterName = String
solver_name
                       , connHandle :: OutputStream Text
connHandle    = OutputStream Text
h
                       , connInputHandle :: InputStream Text
connInputHandle = InputStream Text
in_h
                       , supportFunctionDefs :: Bool
supportFunctionDefs      = Bool
False
                       , supportFunctionArguments :: Bool
supportFunctionArguments = Bool
False
                       , supportQuantifiers :: Bool
supportQuantifiers       = Bool
False
                       , strictParsing :: ResponseStrictness
strictParsing            = ResponseStrictness
beStrict
                       , supportedFeatures :: ProblemFeatures
supportedFeatures        = ProblemFeatures
features
                       , entryStack :: IORef [StackEntry t cs]
entryStack   = IORef [StackEntry t cs]
stk_ref
                       , stateRef :: IORef WriterState
stateRef     = IORef WriterState
r
                       , varBindings :: SymbolVarBimap t
varBindings  = SymbolVarBimap t
bindings
                       , connState :: cs
connState    = cs
cs
                       , consumeAcknowledgement :: AcknowledgementAction t cs
consumeAcknowledgement = AcknowledgementAction t cs
ack
                       }

-- | 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ResponseStrictness -> ResponseStrictness -> Bool
$c/= :: ResponseStrictness -> ResponseStrictness -> Bool
== :: ResponseStrictness -> ResponseStrictness -> Bool
$c== :: ResponseStrictness -> ResponseStrictness -> Bool
Eq, Int -> ResponseStrictness -> String -> String
[ResponseStrictness] -> String -> String
ResponseStrictness -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ResponseStrictness] -> String -> String
$cshowList :: [ResponseStrictness] -> String -> String
show :: ResponseStrictness -> String
$cshow :: ResponseStrictness -> String
showsPrec :: Int -> ResponseStrictness -> String -> String
$cshowsPrec :: Int -> 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
  Maybe Bool
ovr <- case Maybe (ConfigOption BaseBoolType)
overrideOpt of
           Maybe (ConfigOption BaseBoolType)
Nothing -> forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
           Just ConfigOption BaseBoolType
o -> forall (tp :: BaseType) a.
Opt tp a =>
OptionSetting tp -> IO (Maybe a)
CFG.getMaybeOpt forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (tp :: BaseType).
ConfigOption tp -> Config -> IO (OptionSetting tp)
CFG.getOptionSetting ConfigOption BaseBoolType
o Config
cfg
  Maybe Bool
optval <- case Maybe Bool
ovr of
              Just Bool
v -> forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Bool
v
              Maybe Bool
Nothing -> forall (tp :: BaseType) a.
Opt tp a =>
OptionSetting tp -> IO (Maybe a)
CFG.getMaybeOpt forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (tp :: BaseType).
ConfigOption tp -> Config -> IO (OptionSetting tp)
CFG.getOptionSetting ConfigOption BaseBoolType
strictOpt Config
cfg
  forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe ResponseStrictness
Strict (\Bool
c -> if Bool
c then ResponseStrictness
Strict else ResponseStrictness
Lenient) Maybe Bool
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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TermLifetime -> TermLifetime -> Bool
$c/= :: TermLifetime -> TermLifetime -> Bool
== :: TermLifetime -> TermLifetime -> Bool
$c== :: TermLifetime -> TermLifetime -> Bool
Eq)

cacheValue
  :: WriterConn t h
  -> TermLifetime
  -> (StackEntry t h -> IO ())
  -> IO ()
cacheValue :: 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 =
  forall a. IORef a -> IO a
readIORef (forall t h. WriterConn t h -> IORef [StackEntry t h]
entryStack WriterConn t h
conn) 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 -> 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
    [] -> 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 =
  forall a. IORef a -> IO a
readIORef (forall t h. WriterConn t h -> IORef [StackEntry t h]
entryStack WriterConn t h
conn) forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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)
_ [] = forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
firstJustM a -> m (Maybe b)
p (a
x:[a]
xs) = forall (m :: Type -> Type) b a.
Monad m =>
m b -> (a -> m b) -> m (Maybe a) -> m b
maybeM (forall (m :: Type -> Type) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m (Maybe b)
firstJustM a -> m (Maybe b)
p [a]
xs) (forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe m b
n a -> m b
j 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 Bool
b' <- m Bool
b; forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when Bool
b' m ()
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 = forall t h a.
WriterConn t h -> (StackEntry t h -> IO (Maybe a)) -> IO (Maybe a)
cacheLookup WriterConn t h
c forall a b. (a -> b) -> a -> b
$ \StackEntry t h
entry ->
  forall (m :: Type -> Type) t (f :: BaseType -> Type)
       (tp :: BaseType).
MonadIO m =>
IdxCache t f -> Nonce t tp -> m (Maybe (f tp))
lookupIdx (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 = forall t h a.
WriterConn t h -> (StackEntry t h -> IO (Maybe a)) -> IO (Maybe a)
cacheLookup WriterConn t h
c forall a b. (a -> b) -> a -> b
$ \StackEntry t h
entry ->
  forall a. ST RealWorld a -> IO a
stToIO forall a b. (a -> b) -> a -> b
$ 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 (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 = forall t h.
WriterConn t h
-> TermLifetime -> (StackEntry t h -> IO ()) -> IO ()
cacheValue WriterConn t h
conn TermLifetime
lifetime forall a b. (a -> b) -> a -> b
$ \StackEntry t h
entry ->
  forall (m :: Type -> Type) t (f :: BaseType -> Type)
       (tp :: BaseType).
MonadIO m =>
IdxCache t f -> Nonce t tp -> f tp -> m ()
insertIdxValue (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 = forall t h.
WriterConn t h
-> TermLifetime -> (StackEntry t h -> IO ()) -> IO ()
cacheValue WriterConn t h
conn TermLifetime
lifetime forall a b. (a -> b) -> a -> b
$ \StackEntry t h
entry ->
  forall a. ST RealWorld a -> IO a
stToIO forall a b. (a -> b) -> a -> b
$ 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 (forall t h.
StackEntry t h -> HashTable RealWorld (Nonce t) SMTSymFn
symFnCache StackEntry t h
entry) Nonce t ctx
n SMTSymFn ctx
value

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 = forall a b. (Ord a, Ord b) => [(a, b)] -> Bimap a b
Bimap.fromList forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
  (\some_fn :: SomeExprSymFn t
some_fn@(SomeExprSymFn ExprSymFn t args ret
fn) -> do
    Maybe (SMTSymFn (args ::> ret))
maybe_smt_sym_fn <- forall t h (ctx :: Ctx BaseType).
WriterConn t h -> Nonce t ctx -> IO (Maybe (SMTSymFn ctx))
cacheLookupFn WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> Nonce t (args ::> ret)
symFnId ExprSymFn t args ret
fn
    case Maybe (SMTSymFn (args ::> ret))
maybe_smt_sym_fn of
      Just (SMTSymFn Text
nm Assignment TypeMap args
_ TypeMap ret
_) -> forall (m :: Type -> Type) a. Monad m => a -> m a
return (SomeExprSymFn t
some_fn, Text
nm)
      Maybe (SMTSymFn (args ::> ret))
Nothing -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Could not find function in cache: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show 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
  WriterState
s0 <- forall a. IORef a -> IO a
readIORef (forall t h. WriterConn t h -> IORef WriterState
stateRef WriterConn t h
c)
  let (a
v,WriterState
s) = forall s a. State s a -> s -> (a, s)
runState State WriterState a
m WriterState
s0
  forall a. IORef a -> a -> IO ()
writeIORef (forall t h. WriterConn t h -> IORef WriterState
stateRef WriterConn t h
c) forall a b. (a -> b) -> a -> b
$! WriterState
s
  forall (m :: Type -> Type) a. Monad m => a -> m a
return a
v

-- | Update the current program location to the given one.
updateProgramLoc :: WriterConn t h -> ProgramLoc -> IO ()
updateProgramLoc :: forall t h. WriterConn t h -> ProgramLoc -> IO ()
updateProgramLoc WriterConn t h
c ProgramLoc
l = forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
c forall a b. (a -> b) -> a -> b
$ Lens' WriterState Position
position 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 = 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 = forall a. Int -> a -> [a]
replicate Int
n (forall h (f :: Type -> Type). SMTWriter h => f h -> Command h
popCommand f h
w)

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

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

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

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

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

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

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

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

-- | Write a sequence of commands. All but the last should have
-- acknowledgement.
addCommands :: SMTWriter h => WriterConn t h -> [Command h] -> IO ()
addCommands :: forall h t. SMTWriter h => WriterConn t h -> [Command h] -> IO ()
addCommands WriterConn t h
_ [] = 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
  forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommand WriterConn t h
conn) (forall a. [a] -> [a]
init [Command h]
cmds)
  forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommandNoAck WriterConn t h
conn (forall a. [a] -> a
last [Command h]
cmds)

-- | Create a new variable with the given name.
mkFreeVar :: SMTWriter h
          => WriterConn t h
          -> Ctx.Assignment TypeMap args
          -> TypeMap rtp
          -> IO Text
mkFreeVar :: 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
  Text
var <- forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ State WriterState Text
freshVarName
  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_ (forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn) Assignment TypeMap args
arg_types
  forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn TypeMap rtp
return_type
  forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommand WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ forall h (f :: Type -> Type) (args :: Ctx BaseType)
       (rtp :: BaseType).
SMTWriter h =>
f h -> Text -> Assignment TypeMap args -> TypeMap rtp -> Command h
declareCommand WriterConn t h
conn Text
var Assignment TypeMap args
arg_types TypeMap rtp
return_type
  forall (m :: Type -> Type) a. Monad m => a -> m a
return Text
var

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

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

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

assumeFormulaWithFreshName :: SMTWriter h => WriterConn t h -> Term h -> IO Text
assumeFormulaWithFreshName :: forall h t. SMTWriter h => WriterConn t h -> Term h -> IO Text
assumeFormulaWithFreshName WriterConn t h
conn Term h
p =
  do Text
var <- forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ State WriterState Text
freshVarName
     forall h t.
SMTWriter h =>
WriterConn t h -> Term h -> Text -> IO ()
assumeFormulaWithName WriterConn t h
conn Term h
p Text
var
     forall (m :: Type -> Type) a. Monad m => a -> m a
return Text
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 =
  forall t h (ctx :: Ctx BaseType).
WriterConn t h -> Nonce t ctx -> IO (Maybe (SMTSymFn ctx))
cacheLookupFn WriterConn t h
conn (forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> Nonce t (args ::> ret)
symFnId ExprSymFn t args ret
fn) forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just{} ->
      forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Internal error in SMTLIB exporter: function already declared."
        forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> Nonce t (args ::> ret)
symFnId ExprSymFn t args ret
fn) forall a. [a] -> [a] -> [a]
++ String
" declared at "
        forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (ProgramLoc -> Position
plSourceLoc (forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> ProgramLoc
symFnLoc ExprSymFn t args ret
fn)) forall a. [a] -> [a] -> [a]
++ String
"."
    Maybe (SMTSymFn (args ::> ret))
Nothing -> case 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
        Text
nm <- forall t h. WriterConn t h -> SymbolBinding t -> IO Text
getSymbolName WriterConn t h
conn (forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> SymbolBinding t
FnSymbolBinding ExprSymFn t args ret
fn)
        let fn_source :: SMTSource Any
fn_source = forall ann. SolverSymbol -> ProgramLoc -> SMTSource ann
fnSource (forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> SolverSymbol
symFnName ExprSymFn t args ret
fn) (forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> ProgramLoc
symFnLoc ExprSymFn t args ret
fn)
        Assignment TypeMap args
smt_arg_types <- forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type) (m :: Type -> Type).
(TraversableFC t, Applicative m) =>
(forall (x :: k). f x -> m (g x))
-> forall (x :: l). t f x -> m (t g x)
traverseFC (forall (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 Any
fn_source) Assignment BaseTypeRepr args
arg_types
        forall t h (args :: Ctx BaseType).
WriterConn t h -> Assignment TypeMap args -> IO ()
checkArgumentTypes WriterConn t h
conn Assignment TypeMap args
smt_arg_types
        TypeMap ret
smt_ret_type <- 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 Any
fn_source BaseTypeRepr ret
ret_type
        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_ (forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn) Assignment TypeMap args
smt_arg_types
        forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn TypeMap ret
smt_ret_type
        [(Text, Some TypeMap)]
smt_args <- forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
          (\(Some TypeMap x
tp) -> do
            Text
var <- forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ State WriterState Text
freshVarName
            forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text
var, forall k (f :: k -> Type) (x :: k). f x -> Some f
Some TypeMap x
tp))
          (forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type) a.
FoldableFC t =>
(forall (x :: k). f x -> a) -> forall (x :: l). t f x -> [a]
toListFC forall k (f :: k -> Type) (x :: k). f x -> Some f
Some Assignment TypeMap args
smt_arg_types)
        forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommand WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ forall h (f :: Type -> Type) (tp :: BaseType).
SMTWriter h =>
f h -> Text -> [(Text, Some TypeMap)] -> TypeMap tp -> Command h
synthFunCommand WriterConn t h
conn Text
nm [(Text, Some TypeMap)]
smt_args TypeMap ret
smt_ret_type
        forall t h (ctx :: Ctx BaseType).
WriterConn t h
-> Nonce t ctx -> TermLifetime -> SMTSymFn ctx -> IO ()
cacheValueFn WriterConn t h
conn (forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> Nonce t (args ::> ret)
symFnId ExprSymFn t args ret
fn) TermLifetime
DeleteNever forall a b. (a -> b) -> a -> b
$! forall (idx :: Ctx BaseType) (idx :: BaseType).
Text
-> Assignment TypeMap idx -> TypeMap idx -> SMTSymFn (idx ::> idx)
SMTSymFn Text
nm Assignment TypeMap args
smt_arg_types TypeMap ret
smt_ret_type
      DefinedFnInfo{} ->
        forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Internal error in SMTLIB exporter: defined functions cannot be synthesized."
      MatlabSolverFnInfo{} ->
        forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail 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 =
  forall t h (tp :: BaseType).
WriterConn t h -> Nonce t tp -> IO (Maybe (SMTExpr h tp))
cacheLookupExpr WriterConn t h
conn (forall t (tp :: BaseType). ExprBoundVar t tp -> Nonce t tp
bvarId ExprBoundVar t tp
var) forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just{} ->
      forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Internal error in SMTLIB exporter: variable already declared."
        forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall t (tp :: BaseType). ExprBoundVar t tp -> Nonce t tp
bvarId ExprBoundVar t tp
var) forall a. [a] -> [a] -> [a]
++ String
" declared at "
        forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (ProgramLoc -> Position
plSourceLoc (forall t (tp :: BaseType). ExprBoundVar t tp -> ProgramLoc
bvarLoc ExprBoundVar t tp
var)) forall a. [a] -> [a] -> [a]
++ String
"."
    Maybe (SMTExpr h tp)
Nothing -> do
      Text
nm <- forall t h. WriterConn t h -> SymbolBinding t -> IO Text
getSymbolName WriterConn t h
conn (forall t (tp :: BaseType). ExprBoundVar t tp -> SymbolBinding t
VarSymbolBinding ExprBoundVar t tp
var)
      let fn_source :: SMTSource Any
fn_source = forall ann. SolverSymbol -> ProgramLoc -> SMTSource ann
fnSource (forall t (tp :: BaseType). ExprBoundVar t tp -> SolverSymbol
bvarName ExprBoundVar t tp
var) (forall t (tp :: BaseType). ExprBoundVar t tp -> ProgramLoc
bvarLoc ExprBoundVar t tp
var)
      TypeMap tp
smt_type <- 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 Any
fn_source forall a b. (a -> b) -> a -> b
$ forall t (tp :: BaseType). ExprBoundVar t tp -> BaseTypeRepr tp
bvarType ExprBoundVar t tp
var
      forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn TypeMap tp
smt_type
      forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommand WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ forall h (f :: Type -> Type) (tp :: BaseType).
SMTWriter h =>
f h -> Text -> TypeMap tp -> Command h
declareVarCommand WriterConn t h
conn Text
nm TypeMap tp
smt_type
      forall t h (tp :: BaseType).
WriterConn t h
-> Nonce t tp -> TermLifetime -> SMTExpr h tp -> IO ()
cacheValueExpr WriterConn t h
conn (forall t (tp :: BaseType). ExprBoundVar t tp -> Nonce t tp
bvarId ExprBoundVar t tp
var) TermLifetime
DeleteNever forall a b. (a -> b) -> a -> b
$! forall (tp :: BaseType) h. TypeMap tp -> Text -> SMTExpr h tp
SMTName TypeMap tp
smt_type Text
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
  Term h
f <- forall h t.
SMTWriter h =>
WriterConn t h -> BoolExpr t -> IO (Term h)
mkFormula WriterConn t h
conn BoolExpr t
p
  forall t h. WriterConn t h -> ProgramLoc -> IO ()
updateProgramLoc WriterConn t h
conn (forall t (tp :: BaseType). Expr t tp -> ProgramLoc
exprLoc BoolExpr t
p)
  forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommand WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ forall h (f :: Type -> Type).
SMTWriter h =>
f h -> Term h -> Command h
constraintCommand WriterConn t h
conn Term h
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 -> forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
  TypeMap tp
IntegerTypeMap -> forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
  TypeMap tp
RealTypeMap    -> forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
  BVTypeMap NatRepr w
_ -> forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
  FloatTypeMap FloatPrecisionRepr fpp
_ -> forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
  TypeMap tp
UnicodeTypeMap -> forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
  TypeMap tp
ComplexToStructTypeMap -> forall h t (args :: Ctx BaseType).
SMTWriter h =>
WriterConn t h -> Assignment TypeMap args -> IO ()
declareStructDatatype WriterConn t h
conn (forall {k} (ctx :: Ctx k) (f :: k -> Type).
(ctx ~ EmptyCtx) =>
Assignment f ctx
Ctx.Empty forall {k} (ctx' :: Ctx k) (f :: k -> Type) (ctx :: Ctx k)
       (tp :: k).
(ctx' ~ (ctx ::> tp)) =>
Assignment f ctx -> f tp -> Assignment f ctx'
Ctx.:> TypeMap 'BaseRealType
RealTypeMap forall {k} (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  -> forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
  PrimArrayTypeMap Assignment TypeMap (idxl ::> idx)
args TypeMap tp
ret ->
    do 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_ (forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn) Assignment TypeMap (idxl ::> idx)
args
       forall h t (args :: Ctx BaseType).
SMTWriter h =>
WriterConn t h -> Assignment TypeMap args -> IO ()
declareStructDatatype WriterConn t h
conn Assignment TypeMap (idxl ::> idx)
args
       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 {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_ (forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn) Assignment TypeMap (idxl ::> idx)
args
       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 {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_ (forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn) Assignment TypeMap idx
flds
       forall h t (args :: Ctx BaseType).
SMTWriter h =>
WriterConn t h -> Assignment TypeMap args -> IO ()
declareStructDatatype WriterConn t h
conn Assignment TypeMap idx
flds


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

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

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

-- | The state of a side collector monad
--
-- This has predicate for introducing new bound variables
data SMTCollectorState t h
  = SMTCollectorState
    { 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
  Maybe (FreshVarFn h)
mf <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> Maybe (FreshVarFn h)
freshConstantFn
  case Maybe (FreshVarFn h)
mf of
   Maybe (FreshVarFn h)
Nothing -> do
     WriterConn t h
conn <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> WriterConn t h
scConn
     forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
     Position
loc <- forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
use Lens' WriterState Position
position
     forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Cannot create the free constant within a function needed to define the "
       forall a. [a] -> [a] -> [a]
++ String
nm forall a. [a] -> [a] -> [a]
++ String
" term created at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Position
loc forall a. [a] -> [a] -> [a]
++ String
"."
   Just (FreshVarFn forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp)
f) ->
    forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 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 -> forall a b. b -> Either a b
Right TypeMap tp
tm
    -- Recover from array unsupported if possible.
    Left BaseTypeError
ArrayUnsupported
      | forall t h. WriterConn t h -> Bool
supportFunctionDefs WriterConn t h
conn
      , BaseArrayRepr Assignment BaseTypeRepr (idx ::> tp)
idxTp BaseTypeRepr xs
eltTp <- BaseTypeRepr tp
tp0 ->
        forall (idx :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
Assignment TypeMap (idx ::> idx)
-> TypeMap tp -> TypeMap (BaseArrayType (idx ::> idx) tp)
FnArrayTypeMap forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type) (m :: Type -> Type).
(TraversableFC t, Applicative m) =>
(forall (x :: k). f x -> m (g x))
-> forall (x :: l). t f x -> m (t g x)
traverseFC (forall t h (tp :: BaseType).
WriterConn t h
-> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
typeMapFirstClass WriterConn t h
conn) Assignment BaseTypeRepr (idx ::> tp)
idxTp
                       forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> 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 -> 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 = forall t h. WriterConn t h -> ProblemFeatures
supportedFeatures WriterConn t h
conn
  case BaseTypeRepr tp
tp0 of
    BaseTypeRepr tp
BaseBoolRepr -> forall a b. b -> Either a b
Right TypeMap BaseBoolType
BoolTypeMap
    BaseBVRepr NatRepr w
w -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$! forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w
    BaseFloatRepr FloatPrecisionRepr fpp
fpp -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$! forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp
    BaseTypeRepr tp
BaseRealRepr -> forall a b. b -> Either a b
Right TypeMap 'BaseRealType
RealTypeMap
    BaseTypeRepr tp
BaseIntegerRepr -> forall a b. b -> Either a b
Right TypeMap 'BaseIntegerType
IntegerTypeMap
    BaseStringRepr StringInfoRepr si
UnicodeRepr -> forall a b. b -> Either a b
Right TypeMap ('BaseStringType Unicode)
UnicodeTypeMap
    BaseStringRepr StringInfoRepr si
si -> forall a b. a -> Either a b
Left (Some StringInfoRepr -> BaseTypeError
StringTypeUnsupported (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        -> forall a b. b -> Either a b
Right TypeMap 'BaseComplexType
ComplexToStructTypeMap
      | ProblemFeatures
feat ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useSymbolicArrays -> forall a b. b -> Either a b
Right TypeMap 'BaseComplexType
ComplexToArrayTypeMap
      | Bool
otherwise -> 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 forall (idx :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
Assignment TypeMap (idx ::> idx)
-> TypeMap tp -> TypeMap (BaseArrayType (idx ::> idx) tp)
PrimArrayTypeMap
                    else 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 ('BaseArrayType (idx ::> tp) xs)
mkArray forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type) (m :: Type -> Type).
(TraversableFC t, Applicative m) =>
(forall (x :: k). f x -> m (g x))
-> forall (x :: l). t f x -> m (t g x)
traverseFC (forall t h (tp :: BaseType).
WriterConn t h
-> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
typeMapFirstClass WriterConn t h
conn) Assignment BaseTypeRepr (idx ::> tp)
idxTp
              forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> 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 ->
      forall (idx :: Ctx BaseType).
Assignment TypeMap idx -> TypeMap (BaseStructType idx)
StructTypeMap forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type) (m :: Type -> Type).
(TraversableFC t, Applicative m) =>
(forall (x :: k). f x -> m (g x))
-> forall (x :: l). t f x -> m (t g x)
traverseFC (forall 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
  WriterConn t h
conn <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> WriterConn t h
scConn
  let errMsg :: String -> String
errMsg String
typename =
        forall a. Show a => a -> String
show
          forall a b. (a -> b) -> a -> b
$   forall a ann. Show a => a -> Doc ann
viaShow (forall t (tp :: BaseType). ExprBoundVar t tp -> SolverSymbol
bvarName ExprBoundVar t tp
v)
          forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Any
"is a"
          forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty String
typename
          forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Any
"variable, and we do not support this with"
          forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall t h. WriterConn t h -> String
smtWriterName WriterConn t h
conn forall a. [a] -> [a] -> [a]
++ String
".")
  case forall t h (tp :: BaseType).
WriterConn t h
-> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
typeMap WriterConn t h
conn (forall t (tp :: BaseType). ExprBoundVar t tp -> BaseTypeRepr tp
bvarType ExprBoundVar t tp
v) of
    Left  (StringTypeUnsupported (Some StringInfoRepr x
si)) -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String -> String
errMsg (String
"string " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show StringInfoRepr x
si)
    Left  BaseTypeError
ComplexTypeUnsupported -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String -> String
errMsg String
"complex"
    Left  BaseTypeError
ArrayUnsupported       -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String -> String
errMsg String
"array"
    Right TypeMap tp
smtType                -> 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
  WriterConn t h
conn <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> WriterConn t h
scConn
  Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> Term h -> IO ()
f <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall a b. (a -> b) -> a -> b
$ \SMTCollectorState t h
x -> forall t h.
SMTCollectorState t h
-> forall (rtp :: BaseType).
   Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> Term h -> IO ()
freshBoundTermFn SMTCollectorState t h
x
  forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    Text
var <- forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ State WriterState Text
freshVarName
    Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> Term h -> IO ()
f Text
var [(Text, Some TypeMap)]
args TypeMap rtp
tp Term h
t
    forall (m :: Type -> Type) a. Monad m => a -> m a
return Text
var

-- | Create a fresh bound term from the SMT expression with the given name.
freshBoundTerm :: TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm :: forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap tp
tp Term h
t = forall (tp :: BaseType) h. TypeMap tp -> Text -> SMTExpr h tp
SMTName TypeMap tp
tp forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall (tp :: BaseType) h. TypeMap tp -> Text -> SMTExpr h tp
SMTName TypeMap tp
tp forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (rtp :: BaseType) h t.
[(Text, Some TypeMap)]
-> TypeMap rtp -> Term h -> SMTCollector t h Text
freshBoundFn [] TypeMap tp
tp (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h tp
t)
  where tp :: TypeMap tp
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
  WriterConn t h
conn <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> WriterConn t h
scConn
  Maybe (Term h -> IO ())
mf <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> Maybe (Term h -> IO ())
recordSideCondFn
  Position
loc <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
use Lens' WriterState Position
position
  case Maybe (Term h -> IO ())
mf of
   Just Term h -> IO ()
f ->
     forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Term h -> IO ()
f Term h
t
   Maybe (Term h -> IO ())
Nothing -> do
     forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Cannot add a side condition within a function needed to define the "
       forall a. [a] -> [a] -> [a]
++ String
nm forall a. [a] -> [a] -> [a]
++ String
" term created at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Position
loc 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 = 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) = 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...
  forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"bool_val" forall a b. (a -> b) -> a -> b
$ Term h
t forall v. SupportTermOps v => v -> v -> v
.== 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 forall tp. ValueRange tp -> ValueBound tp
rangeLowBound AbstractValue tp
rng of
       ValueBound Integer
Unbounded -> forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
       Inclusive Integer
lo -> forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"int_range" forall a b. (a -> b) -> a -> b
$ Term h
t forall v. SupportTermOps v => v -> v -> v
.>= forall v. SupportTermOps v => Integer -> v
integerTerm Integer
lo
     case forall tp. ValueRange tp -> ValueBound tp
rangeHiBound AbstractValue tp
rng of
       ValueBound Integer
Unbounded -> forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
       Inclusive Integer
hi -> forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"int_range" forall a b. (a -> b) -> a -> b
$ Term h
t forall v. SupportTermOps v => v -> v -> v
.<= 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 forall tp. ValueRange tp -> ValueBound tp
rangeLowBound (RealAbstractValue -> ValueRange Rational
ravRange AbstractValue tp
rng) of
       ValueBound Rational
Unbounded -> forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
       Inclusive Rational
lo -> forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"real_range" forall a b. (a -> b) -> a -> b
$ Term h
t forall v. SupportTermOps v => v -> v -> v
.>= forall v. SupportTermOps v => Rational -> v
rationalTerm Rational
lo
     case forall tp. ValueRange tp -> ValueBound tp
rangeHiBound (RealAbstractValue -> ValueRange Rational
ravRange AbstractValue tp
rng) of
       ValueBound Rational
Unbounded -> forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
       Inclusive Rational
hi -> forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"real_range" forall a b. (a -> b) -> a -> b
$ Term h
t forall v. SupportTermOps v => v -> v -> v
.<= 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) -> SMTCollector t h ()
assertRange (forall (w :: Natural). Domain w -> Maybe (Integer, Integer)
BVD.arithDomainData Domain w
rng)
   where
   assertRange :: Maybe (Integer, Integer) -> SMTCollector t h ()
assertRange Maybe (Integer, Integer)
Nothing = forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
   assertRange (Just (Integer
lo, Integer
sz)) =
     forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"bv_range" forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
bvULe (forall v. SupportTermOps v => v -> v -> v
bvSub Term h
t (forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (forall (w :: Natural). NatRepr w -> Integer -> BV w
BV.mkBV NatRepr w
w Integer
lo))) (forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
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) -> SMTCollector t h ()
assertBitRange (forall (w :: Natural). Domain w -> (Integer, Integer)
BVD.bitbounds Domain w
rng)
   where
   assertBitRange :: (Integer, Integer) -> SMTCollector t h ()
assertBitRange (Integer
lo, Integer
hi) = do
     forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Integer
lo forall a. Ord a => a -> a -> Bool
> Integer
0) forall a b. (a -> b) -> a -> b
$
       forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"bv_bitrange" forall a b. (a -> b) -> a -> b
$ (forall v. SupportTermOps v => v -> v -> v
bvOr (forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (forall (w :: Natural). NatRepr w -> Integer -> BV w
BV.mkBV NatRepr w
w Integer
lo)) Term h
t) forall v. SupportTermOps v => v -> v -> v
.== Term h
t
     forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Integer
hi forall a. Ord a => a -> a -> Bool
< forall (w :: Natural). NatRepr w -> Integer
maxUnsigned NatRepr w
w) forall a b. (a -> b) -> a -> b
$
       forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"bv_bitrange" forall a b. (a -> b) -> a -> b
$ (forall v. SupportTermOps v => v -> v -> v
bvOr Term h
t (forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (forall (w :: Natural). NatRepr w -> Integer -> BV w
BV.mkBV NatRepr w
w Integer
hi))) forall v. SupportTermOps v => v -> v -> v
.== (forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
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 forall tp. ValueRange tp -> ValueBound tp
rangeLowBound ValueRange Integer
len of
       Inclusive Integer
lo ->
          forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"string length low range" forall a b. (a -> b) -> a -> b
$
             forall v. SupportTermOps v => Integer -> v
integerTerm (forall a. Ord a => a -> a -> a
max Integer
0 Integer
lo) forall v. SupportTermOps v => v -> v -> v
.<= forall h. SMTWriter h => Term h -> Term h
stringLength @h Term h
t
       ValueBound Integer
Unbounded ->
          forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"string length low range" forall a b. (a -> b) -> a -> b
$
             forall v. SupportTermOps v => Integer -> v
integerTerm Integer
0 forall v. SupportTermOps v => v -> v -> v
.<= forall h. SMTWriter h => Term h -> Term h
stringLength @h Term h
t

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

addPartialSideCond WriterConn t h
_ Term h
_ (FloatTypeMap FloatPrecisionRepr fpp
_) (Just ()) = 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
     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 (forall a. a -> Maybe a
Just RealAbstractValue
realRng)
     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 (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
     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 (forall a. a -> Maybe a
Just RealAbstractValue
realRng)
     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 (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) =
     forall {k} (ctx :: Ctx k) r.
Size ctx -> (forall (tp :: k). r -> Index ctx tp -> r) -> r -> r
Ctx.forIndex (forall {k} (f :: k -> Type) (ctx :: Ctx k).
Assignment f ctx -> Size ctx
Ctx.size Assignment TypeMap idx
ctx)
        (\SMTCollector t h ()
start Index idx tp
i ->
            do SMTCollector t h ()
start
               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 forall {k} (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
Assignment f ctx -> Index ctx tp -> f tp
Ctx.! Index idx tp
i)
                 (forall a. a -> Maybe a
Just (forall (tp :: BaseType).
AbstractValueWrapper tp -> AbstractValue tp
unwrapAV (AbstractValue tp
abvs forall {k} (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
Assignment f ctx -> Index ctx tp -> f tp
Ctx.! Index idx tp
i))))
        (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) =
  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) =
  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 = 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 = 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  = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! forall h.
(forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp))
-> FreshVarFn h
FreshVarFn (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 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! 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 = seq :: forall a b. a -> b -> b
seq a
a forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [a]
r (a
aforall 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
  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 forall v.
SupportTermOps v =>
Maybe ([(Text, Some TypeMap)] -> v -> v)
lambdaTerm of
    Maybe ([(Text, Some TypeMap)] -> v -> v)
Nothing -> do
      forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail 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
      seq :: forall a b. a -> b -> b
seq v
r forall a b. (a -> b) -> a -> b
$ 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
  Text
var <- forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ State WriterState Text
freshVarName
  forall a. IORef [a] -> a -> IO ()
prependToRefList IORef [(Text, Some TypeMap)]
ref (Text
var, forall k (f :: k -> Type) (x :: k). f x -> Some f
Some TypeMap tp
tp)
  forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall (tp :: BaseType) h. TypeMap tp -> Text -> SMTExpr h tp
SMTName TypeMap tp
tp Text
var

-- | This describes the result that was collected from the solver.
data CollectorResults h a =
  CollectorResults { 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 (forall h a. CollectorResults h a -> [(Text, Some TypeMap)]
crFreeConstants CollectorResults h (Term h)
cr) forall a b. (a -> b) -> a -> b
$
    forall v. SupportTermOps v => [(Text, v)] -> v -> v
letExpr (forall h a. CollectorResults h a -> [(Text, Term h)]
crBindings CollectorResults h (Term h)
cr) forall a b. (a -> b) -> a -> b
$
      forall v. SupportTermOps v => [v] -> v -> v
impliesAllExpr (forall h a. CollectorResults h a -> [Term h]
crSideConds CollectorResults h (Term h)
cr) (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 = forall v. SupportTermOps v => [v] -> v
orAll ((forall v. SupportTermOps v => v -> v
notExpr forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [v]
l) 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 (forall h a. CollectorResults h a -> [(Text, Some TypeMap)]
crFreeConstants CollectorResults h (Term h)
cr) forall a b. (a -> b) -> a -> b
$
    forall v. SupportTermOps v => [(Text, v)] -> v -> v
letExpr (forall h a. CollectorResults h a -> [(Text, Term h)]
crBindings CollectorResults h (Term h)
cr) forall a b. (a -> b) -> a -> b
$
      forall v. SupportTermOps v => [v] -> v
andAll (forall h a. CollectorResults h a -> [Term h]
crSideConds CollectorResults h (Term h)
cr forall a. [a] -> [a] -> [a]
++ [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.
  IORef [(Text, Term h)]
boundTermRef    <- forall a. a -> IO (IORef a)
newIORef []
  -- A list of free constants
  IORef [(Text, Some TypeMap)]
freeConstantRef <- (forall a. a -> IO (IORef a)
newIORef [] :: IO (IORef [(Text, Some TypeMap)]))
  -- A list of references to side conditions.
  IORef [Term h]
sideCondRef     <- forall a. a -> IO (IORef a)
newIORef []

  let 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 = 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  = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! forall h.
(forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp))
-> FreshVarFn h
FreshVarFn (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 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! forall a. IORef [a] -> a -> IO ()
prependToRefList IORef [Term h]
sideCondRef
          }
  a
r <- forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT SMTCollector t h a
sc SMTCollectorState t h
s

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

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

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

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

-- @bvIntTerm w x@ builds an integer term that has the same value as
-- the unsigned integer value of the bitvector @x@.  This is done by
-- explicitly decomposing the positional notation of the bitvector
-- into a sum of powers of 2.
bvIntTerm :: forall v w
           . (SupportTermOps v, 1 <= w)
          => NatRepr w
          -> v
          -> v
bvIntTerm :: forall v (w :: Natural).
(SupportTermOps v, 1 <= w) =>
NatRepr w -> v -> v
bvIntTerm NatRepr w
w v
x = forall v. SupportTermOps v => [v] -> v
sumExpr ((\Natural
i -> Natural -> v
digit (Natural
iforall a. Num a => a -> a -> a
-Natural
1)) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Natural
1..forall (n :: Natural). NatRepr n -> Natural
natValue NatRepr w
w])
 where digit :: Natural -> v
       digit :: Natural -> v
digit Natural
d = forall v. SupportTermOps v => v -> v -> v -> v
ite (forall v (w :: Natural).
SupportTermOps v =>
NatRepr w -> Natural -> v -> v
bvTestBit NatRepr w
w Natural
d v
x)
                     (forall a. Num a => Integer -> a
fromInteger (Integer
2forall 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 = forall v. SupportTermOps v => [v] -> v
sumExpr (v
signed_offset forall a. a -> [a] -> [a]
: forall v (w :: Natural).
SupportTermOps v =>
NatRepr w -> v -> Natural -> [v]
go NatRepr w
w0 v
x0 (forall (n :: Natural). NatRepr n -> Natural
natValue NatRepr w
w0 forall a. Num a => a -> a -> a
- Natural
2))
 where signed_offset :: v
signed_offset = forall v. SupportTermOps v => v -> v -> v -> v
ite (forall v (w :: Natural).
SupportTermOps v =>
NatRepr w -> Natural -> v -> v
bvTestBit NatRepr w
w0 (forall (n :: Natural). NatRepr n -> Natural
natValue NatRepr w
w0 forall a. Num a => a -> a -> a
- Natural
1) v
x0)
                           (forall a. Num a => Integer -> a
fromInteger (forall a. Num a => a -> a
negate (Integer
2forall a b. (Num a, Integral b) => a -> b -> a
^(forall (n :: Natural). NatRepr n -> Int
widthVal NatRepr w
w0 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 forall a. Ord a => a -> a -> Bool
> Natural
0     = forall v (w :: Natural).
SupportTermOps v =>
NatRepr w -> v -> Natural -> v
digit NatRepr w
w v
x Natural
n forall a. a -> [a] -> [a]
: forall v (w :: Natural).
SupportTermOps v =>
NatRepr w -> v -> Natural -> [v]
go NatRepr w
w v
x (Natural
nforall a. Num a => a -> a -> a
-Natural
1)
        | Natural
n forall a. Eq a => a -> a -> Bool
== Natural
0    = [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 = forall v. SupportTermOps v => v -> v -> v -> v
ite (forall v (w :: Natural).
SupportTermOps v =>
NatRepr w -> Natural -> v -> v
bvTestBit NatRepr w
w Natural
d v
x)
                         (forall a. Num a => Integer -> a
fromInteger (Integer
2forall 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 =
  forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$
  forall ann. [Doc ann] -> Doc ann
vcat
  [ Doc Any
"Cannot generate solver output for term generated at"
      forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (ProgramLoc -> Position
plSourceLoc (forall t (tp :: BaseType). Expr t tp -> ProgramLoc
exprLoc Expr t tp
e)) forall a. Semigroup a => a -> a -> a
<> Doc Any
":"
  , forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (forall a ann. Pretty a => a -> Doc ann
pretty Expr t tp
e)
  ]

-- | Checks whether a variable is supported.
--
-- Returns the SMT type of the variable and a predicate (if needed) that the variable
-- should be assumed to hold.  This is used for Natural number variables.
checkVarTypeSupport :: ExprBoundVar n tp -> SMTCollector n h ()
checkVarTypeSupport :: forall n (tp :: BaseType) h.
ExprBoundVar n tp -> SMTCollector n h ()
checkVarTypeSupport ExprBoundVar n tp
var = do
  let t :: Expr n tp
t = forall t (tp :: BaseType). ExprBoundVar t tp -> Expr t tp
BoundVarExpr ExprBoundVar n tp
var
  case forall t (tp :: BaseType). ExprBoundVar t tp -> BaseTypeRepr tp
bvarType ExprBoundVar n tp
var of
    BaseTypeRepr tp
BaseIntegerRepr -> forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkIntegerSupport Expr n tp
t
    BaseTypeRepr tp
BaseRealRepr    -> forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkLinearSupport Expr n tp
t
    BaseTypeRepr tp
BaseComplexRepr -> forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkLinearSupport Expr n tp
t
    BaseStringRepr StringInfoRepr si
_ -> forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkStringSupport Expr n tp
t
    BaseFloatRepr FloatPrecisionRepr fpp
_  -> forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkFloatSupport Expr n tp
t
    BaseBVRepr NatRepr w
_     -> forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkBitvectorSupport Expr n tp
t
    BaseTypeRepr tp
_ -> 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 =
  forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$
    forall a ann. Pretty a => a -> Doc ann
pretty (forall t h. WriterConn t h -> String
smtWriterName WriterConn t h
conn) forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Any
"does not support the" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty String
theory_name
    forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Any
"term generated at" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (ProgramLoc -> Position
plSourceLoc (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
  WriterConn t h
conn <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> WriterConn t h
scConn
  forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (forall t h. WriterConn t h -> ProblemFeatures
supportedFeatures WriterConn t h
conn ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useIntegerArithmetic) forall a b. (a -> b) -> a -> b
$ do
    forall (m :: Type -> Type) t h (tp :: BaseType) a.
MonadFail m =>
WriterConn t h -> String -> Expr t tp -> m a
theoryUnsupported WriterConn t h
conn String
"integer arithmetic" Expr t tp
t

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

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

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

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

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

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

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

-- | Check that the types can be passed to functions.
checkArgumentTypes :: WriterConn t h -> Ctx.Assignment TypeMap args -> IO ()
checkArgumentTypes :: forall t h (args :: Ctx BaseType).
WriterConn t h -> Assignment TypeMap args -> IO ()
checkArgumentTypes WriterConn t h
conn Assignment TypeMap args
types = do
  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 a b. (a -> b) -> a -> b
$ \TypeMap x
tp -> do
    case TypeMap x
tp of
      FnArrayTypeMap{} | forall t h. WriterConn t h -> Bool
supportFunctionArguments WriterConn t h
conn forall a. Eq a => a -> a -> Bool
== Bool
False -> do
          forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty (forall t h. WriterConn t h -> String
smtWriterName WriterConn t h
conn)
             forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Any
"does not allow arrays encoded as functions to be function arguments."
      TypeMap x
_ ->
        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" forall ann. Doc ann -> Doc ann -> 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 =
  forall ann. [Doc ann] -> Doc ann
vcat
  [ forall a ann. Pretty a => a -> Doc ann
pretty String
solver_name forall ann. Doc ann -> Doc ann -> Doc ann
<+>
    Doc ann
"does not support" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. BaseTypeError -> Doc ann
ppBaseTypeError BaseTypeError
cause forall a. Semigroup a => a -> a -> a
<>
    Doc ann
", and cannot interpret the term generated at" forall ann. Doc ann -> Doc ann -> Doc ann
<+>
    forall a ann. Pretty a => a -> Doc ann
pretty (ProgramLoc -> Position
plSourceLoc (forall t (tp :: BaseType). Expr t tp -> ProgramLoc
exprLoc Expr t tp
e)) forall a. Semigroup a => a -> a -> a
<> Doc ann
":"
  , forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (forall a ann. Pretty a => a -> Doc ann
pretty Expr t tp
e) 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 =
  forall a ann. Pretty a => a -> Doc ann
pretty String
solver_name forall ann. Doc ann -> Doc ann -> Doc ann
<+>
  Doc ann
"does not support" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. BaseTypeError -> Doc ann
ppBaseTypeError BaseTypeError
cause forall a. Semigroup a => a -> a -> a
<>
  Doc ann
", and cannot interpret the function" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow SolverSymbol
fn_name forall ann. Doc ann -> Doc ann -> Doc ann
<+>
  Doc ann
"generated at" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (ProgramLoc -> Position
plSourceLoc ProgramLoc
loc) 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 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 -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ SMTSource ann
src (forall t h. WriterConn t h -> String
smtWriterName WriterConn t h
conn) BaseTypeError
e
    Right TypeMap tp
smt_ret -> 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 = forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (forall t h. WriterConn t h -> IO ()
pushEntryStack WriterConn t h
conn) (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)  = forall a. Num a => Integer -> a
fromInteger Integer
i
mkIndexLitTerm (BVIndexLit NatRepr w
w BV w
i) = 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 k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type) a.
FoldableFC t =>
(forall (x :: k). f x -> a) -> forall (x :: l). t f x -> [a]
toListFC forall v (tp :: BaseType). SupportTermOps v => IndexLit tp -> v
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
        Text
i_nm <- forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ Builder -> State WriterState Text
freshVarName' Builder
"i!"
        forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text
i_nm, forall k (f :: k -> Type) (x :: k). f x -> Some f
Some TypeMap utp
base_tp)
  -- Get SMT arguments.
  forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type) a.
FoldableFC t =>
(forall (x :: k). f x -> a) -> forall (x :: l). t f x -> [a]
toListFC forall (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 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 ->
      forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap tp
res_type forall a b. (a -> b) -> a -> b
$ forall h. SMTWriter h => Term h -> [Term h] -> Term h
arraySelect @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 ->
      forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap tp
res_type forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> [v] -> v
smtFnApp (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 forall t. SymbolBinding t -> SymbolVarBimap t -> Maybe SolverSymbol
lookupSymbolOfBinding SymbolBinding t
b (forall t h. WriterConn t h -> SymbolVarBimap t
varBindings WriterConn t h
conn) of
    Just SolverSymbol
sym -> forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! SolverSymbol -> Text
solverSymbolAsText SolverSymbol
sym
    Maybe SolverSymbol
Nothing -> forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn 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 =
  forall t h a. WriterConn t h -> IO a -> IO a
withConnEntryStack WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ do
    -- A list of bound terms.
    IORef [(Text, Some TypeMap)]
freeConstantRef <- (forall a. a -> IO (IORef a)
newIORef [] :: IO (IORef [(Text, Some TypeMap)]))
    IORef [(Text, Term h)]
boundTermRef    <- forall a. a -> IO (IORef a)
newIORef []
    let 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 = 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  = forall a. Maybe a
Nothing
                              , recordSideCondFn :: Maybe (Term h -> IO ())
recordSideCondFn = forall a. Maybe a
Nothing
                              }
    -- Associate a variable with each bound variable
    let varFn :: FreshVarFn h
varFn = forall h.
(forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp))
-> FreshVarFn h
FreshVarFn (forall t h (tp :: BaseType).
WriterConn t h
-> IORef [(Text, Some TypeMap)] -> TypeMap tp -> IO (SMTExpr h tp)
freshSandboxConstant WriterConn t h
conn IORef [(Text, Some TypeMap)]
freeConstantRef)
    SMTExpr h ret
pair <- forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT SMTCollectorState t h
s (FreshVarFn h -> SMTCollector t h (SMTExpr h ret)
action FreshVarFn h
varFn)

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

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

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

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

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

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

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

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

       -- Add assertion based on var type.
       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 v. SupportTermOps v => Text -> v
fromText Text
var_name) TypeMap tp
smt_type (forall t (tp :: BaseType).
ExprBoundVar t tp -> Maybe (AbstractValue tp)
bvarAbstractValue ExprBoundVar t tp
var)

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

-- | Convert an element to a base expression.
mkBaseExpr :: SMTWriter h => Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr :: forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t tp
e = forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type) b.
FoldableFC t =>
(forall (x :: k). f x -> b -> b)
-> forall (x :: l). b -> t f x -> b
foldrFC (\Expr t x
e ReaderT (SMTCollectorState t h) IO [Term h]
r -> (:) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t x
e forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> ReaderT (SMTCollectorState t h) IO [Term h]
r) (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
  WriterConn t h
conn <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> WriterConn t h
scConn
  let i :: Expr t tp
i = forall t (tp :: BaseType). NonceAppExpr t tp -> Expr t tp
NonceAppExpr NonceAppExpr t tp
e0
  WriterConn t h
h <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> WriterConn t h
scConn
  forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall t h. WriterConn t h -> ProgramLoc -> IO ()
updateProgramLoc WriterConn t h
h (forall t (tp :: BaseType). NonceAppExpr t tp -> ProgramLoc
nonceExprLoc NonceAppExpr t tp
e0)
  case forall t (tp :: BaseType).
NonceAppExpr t tp -> NonceApp t (Expr t) tp
nonceExprApp NonceAppExpr t tp
e0 of
    Annotation BaseTypeRepr tp
_tpr Nonce t tp
_n Expr t tp
e -> 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
      forall t (p :: BaseType) h.
String -> Expr t p -> SMTCollector t h ()
checkQuantifierSupport String
"universal quantifier" Expr t tp
i

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

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

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

          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 (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h tp1
t) TypeMap tp1
smtType (forall t (tp :: BaseType).
ExprBoundVar t tp -> Maybe (AbstractValue tp)
bvarAbstractValue ExprBoundVar t tp1
var)
          forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseBoolType
e
      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall h. SMTWriter h => CollectorResults h (Term h) -> Term h
forallResult CollectorResults h (Term h)
cr
    Exists ExprBoundVar t tp1
var Expr t BaseBoolType
e -> do
      forall t (p :: BaseType) h.
String -> Expr t p -> SMTCollector t h ()
checkQuantifierSupport String
"existential quantifiers" Expr t tp
i

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

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

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

          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 (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h tp1
t) TypeMap tp1
smtType (forall t (tp :: BaseType).
ExprBoundVar t tp -> Maybe (AbstractValue tp)
bvarAbstractValue ExprBoundVar t tp1
var)
          forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseBoolType
e
      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall h. SMTWriter h => CollectorResults h (Term h) -> Term h
existsResult CollectorResults h (Term h)
cr

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

      let array_tp :: TypeMap ('BaseArrayType (idx ::> itp) ret)
array_tp = 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
      forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall (tp :: BaseType) h. TypeMap tp -> Text -> SMTExpr h tp
SMTName TypeMap ('BaseArrayType (idx ::> itp) ret)
array_tp Text
smt_f

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

      Assignment TypeMap (idx ::> itp)
smt_idx_types <- forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type) (m :: Type -> Type).
(TraversableFC t, Applicative m) =>
(forall (x :: k). f x -> m (g x))
-> forall (x :: l). t f x -> m (t g x)
traverseFC (forall (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 (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 :: forall (idx :: Ctx BaseType) (itp :: BaseType) (etp :: BaseType).
ArrayResultWrapper (Expr t) (idx ::> itp) etp
-> SMTCollector
     t h (ArrayResultWrapper (SMTExpr h) (idx ::> itp) etp)
evalArray (ArrayResultWrapper Expr t (BaseArrayType (idx ::> itp) etp)
a) = forall (f :: BaseType -> Type) (idx :: Ctx BaseType)
       (tp :: BaseType).
f (BaseArrayType idx tp) -> ArrayResultWrapper f idx tp
ArrayResultWrapper forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t (BaseArrayType (idx ::> itp) etp)
a

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

      forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do

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

      TypeMap r
ret_type <-
        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 forall a b. (a -> b) -> a -> b
$ \(FreshVarFn forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp)
freshVar) -> do
          -- Create type for indices.
          Assignment (SMTExpr h) (idx ::> itp)
smt_indices <- forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type) (m :: Type -> Type).
(TraversableFC t, Applicative m) =>
(forall (x :: k). f x -> m (g x))
-> forall (x :: l). t f x -> m (t g x)
traverseFC (\TypeMap x
tp -> forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp)
freshVar TypeMap x
tp)) Assignment TypeMap (idx ::> itp)
smt_idx_types

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

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

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


      let array_tp :: TypeMap ('BaseArrayType (idx ::> itp) r)
array_tp = 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
      forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall (tp :: BaseType) h. TypeMap tp -> Text -> SMTExpr h tp
SMTName TypeMap ('BaseArrayType (idx ::> itp) r)
array_tp Text
nm

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

    FnApp ExprSymFn t args tp
f Assignment (Expr t) args
args -> do
      Assignment (SMTExpr h) args
smt_args <- forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type) (m :: Type -> Type).
(TraversableFC t, Applicative m) =>
(forall (x :: k). f x -> m (g x))
-> forall (x :: l). t f x -> m (t g x)
traverseFC forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Assignment (Expr t) args
args
      (Text
smt_f, TypeMap tp
ret_type) <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall h t (args :: Ctx BaseType) (ret :: BaseType).
SMTWriter h =>
WriterConn t h
-> ExprSymFn t args ret
-> Assignment TypeMap args
-> IO (Text, TypeMap ret)
getSMTSymFn WriterConn t h
conn ExprSymFn t args tp
f (forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type).
FunctorFC t =>
(forall (x :: k). f x -> g x) -> forall (x :: l). t f x -> t g x
fmapFC forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType Assignment (SMTExpr h) args
smt_args)
      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap tp
ret_type forall a b. (a -> b) -> a -> b
$! forall v. SupportTermOps v => v -> [v] -> v
smtFnApp (forall v. SupportTermOps v => Text -> v
fromText Text
smt_f) (forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type) a.
FoldableFC t =>
(forall (x :: k). f x -> a) -> forall (x :: l). t f x -> [a]
toListFC forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase Assignment (SMTExpr h) args
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
  WriterConn t h
conn <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> WriterConn t h
scConn
  let i :: Expr t tp
i = forall t (tp :: BaseType). AppExpr t tp -> Expr t tp
AppExpr AppExpr t tp
ae
  forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall t h. WriterConn t h -> ProgramLoc -> IO ()
updateProgramLoc WriterConn t h
conn (forall t (tp :: BaseType). AppExpr t tp -> ProgramLoc
appExprLoc AppExpr t tp
ae)
  case forall t (tp :: BaseType). AppExpr t tp -> App (Expr t) tp
appExprApp AppExpr t tp
ae of

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

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

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

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

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

         forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h tp1
xe forall v. SupportTermOps v => v -> v -> v
.== forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h tp1
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 =
           forall a. Show a => a -> String
show
             forall a b. (a -> b) -> a -> b
$   Doc Any
"we do not support if/then/else expressions at type"
             forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty String
typename
             forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Any
"with solver"
             forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall t h. WriterConn t h -> String
smtWriterName WriterConn t h
conn) forall a. Semigroup a => a -> a -> a
<> Doc Any
"."
      case 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)) -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String -> String
errMsg (String
"string " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show StringInfoRepr x
si)
        Left  BaseTypeError
ComplexTypeUnsupported -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String -> String
errMsg String
"complex"
        Left  BaseTypeError
ArrayUnsupported       -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String -> String
errMsg String
"array"
        Right FnArrayTypeMap{}       -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String -> String
errMsg String
"function-backed array"
        Right TypeMap tp
tym ->
          do Term h
cb <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseBoolType
c
             Term h
xb <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t tp
x
             Term h
yb <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t tp
y
             forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap tp
tym forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v -> v
ite Term h
cb Term h
xb Term h
yb

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

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

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

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

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

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

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

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

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

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

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

    NotPred Expr t BaseBoolType
x -> forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. SupportTermOps v => v -> v
notExpr forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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) = 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) = forall v. SupportTermOps v => v -> v
notExpr forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t tp
x
      in
      case forall (f :: BaseType -> Type). BoolMap f -> BoolMapView f
BM.viewBoolMap BoolMap (Expr t)
xs of
        BoolMapView (Expr t)
BM.BoolMapUnit ->
          forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => Bool -> v
boolExpr Bool
True
        BoolMapView (Expr t)
BM.BoolMapDualUnit ->
          forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => Bool -> v
boolExpr Bool
False
        BM.BoolMapTerms ((Expr t BaseBoolType, Polarity)
t:|[]) ->
          forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap BaseBoolType
BoolTypeMap forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 Term h
cnj <- forall v. SupportTermOps v => [v] -> v
andAll forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {h} {t} {tp :: BaseType}.
SMTWriter h =>
(Expr t tp, Polarity) -> SMTCollector t h (Term h)
pol ((Expr t BaseBoolType, Polarity)
tforall a. a -> [a] -> [a]
:[(Expr t BaseBoolType, Polarity)]
ts)
             forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap Term h
cnj

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

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

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

    SemiRingSum WeightedSum (Expr t) sr
s ->
      case 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 forall a. Eq a => a -> a -> Bool
==  Integer
1   = (forall a. a -> [a] -> [a]
:[]) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t tp
e
                | Integer
c forall a. Eq a => a -> a -> Bool
== -Integer
1   = (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a
negate forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t tp
e
                | Bool
otherwise = (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall v. SupportTermOps v => Integer -> v
integerTerm Integer
c forall a. Num a => a -> a -> a
*) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = [forall v. SupportTermOps v => Integer -> v
integerTerm Integer
x]
              add :: [a] -> [a] -> f [a]
add [a]
x [a]
y = forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([a]
y forall a. [a] -> [a] -> [a]
++ [a]
x) -- reversed for efficiency when grouped to the left
          in
          forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap 'BaseIntegerType
IntegerTypeMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. SupportTermOps v => [v] -> v
sumExpr
            forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 forall {f :: Type -> Type} {a}.
Applicative f =>
[a] -> [a] -> f [a]
add forall {h} {t} {tp :: BaseType}.
SMTWriter h =>
Integer -> Expr t tp -> ReaderT (SMTCollectorState t h) IO [Term h]
smul (forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Eq a => a -> a -> Bool
==  Rational
1 = (forall a. a -> [a] -> [a]
:[]) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t tp
e
                | Rational
c forall a. Eq a => a -> a -> Bool
== -Rational
1 = (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a
negate forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t tp
e
                | Bool
otherwise = (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall v. SupportTermOps v => Rational -> v
rationalTerm Rational
c forall a. Num a => a -> a -> a
*) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = [forall v. SupportTermOps v => Rational -> v
rationalTerm Rational
x]
              add :: [a] -> [a] -> f [a]
add [a]
x [a]
y = forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([a]
y forall a. [a] -> [a] -> [a]
++ [a]
x) -- reversed for efficiency when grouped to the left
          in
          forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap 'BaseRealType
RealTypeMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. SupportTermOps v => [v] -> v
sumExpr
            forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 forall {f :: Type -> Type} {a}.
Applicative f =>
[a] -> [a] -> f [a]
add forall {h} {t} {tp :: BaseType}.
SMTWriter h =>
Rational
-> Expr t tp -> ReaderT (SMTCollectorState t h) IO [Term h]
smul (forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Eq a => a -> a -> Bool
== forall (w :: Natural). (1 <= w) => NatRepr w -> BV w
BV.one NatRepr w
w = (forall a. a -> [a] -> [a]
:[]) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
e
                | BV w
c forall a. Eq a => a -> a -> Bool
== forall (w :: Natural). NatRepr w -> BV w
BV.maxUnsigned NatRepr w
w = (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. SupportTermOps v => v -> v
bvNeg forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
e
                | Bool
otherwise = (forall a. a -> [a] -> [a]
:[]) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall v. SupportTermOps v => v -> v -> v
bvMul (forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w BV w
c)) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = [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 = forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([a]
y forall a. [a] -> [a] -> [a]
++ [a]
x) -- reversed for efficiency when grouped to the left
           in
           forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v (w :: Natural). SupportTermOps v => NatRepr w -> [v] -> v
bvSumExpr NatRepr w
w
             forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 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]
smul (forall (f :: Type -> Type) a. Applicative f => a -> f a
pure 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 forall a. Eq a => a -> a -> Bool
== forall (w :: Natural). NatRepr w -> BV w
BV.maxUnsigned NatRepr w
w = (forall a. a -> [a] -> [a]
:[]) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
e
                | Bool
otherwise             = (forall a. a -> [a] -> [a]
:[]) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall v. SupportTermOps v => v -> v -> v
bvAnd (forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w BV w
c)) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = [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 = forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([a]
y forall a. [a] -> [a] -> [a]
++ [a]
x) -- reversed for efficiency when grouped to the left
              xorsum :: [Term h] -> Term h
xorsum [] = forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (forall (w :: Natural). NatRepr w -> BV w
BV.zero NatRepr w
w)
              xorsum [Term h]
xs = forall (t :: Type -> Type) a.
Foldable t =>
(a -> a -> a) -> t a -> a
foldr1 forall v. SupportTermOps v => v -> v -> v
bvXor [Term h]
xs
           in
           forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Term h] -> Term h
xorsum
             forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 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]
smul (forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. BV w -> [Term h]
cnst) WeightedSum (Expr t) sr
s

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

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

      Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t 'BaseRealType
xe
      SMTExpr h 'BaseRealType
nm <- forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
"real sqrt" TypeMap 'BaseRealType
RealTypeMap
      let v :: Term h
v = forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h 'BaseRealType
nm
      -- assert v*v = x | x < 0
      forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"real sqrt" forall a b. (a -> b) -> a -> b
$ Term h
v forall a. Num a => a -> a -> a
* Term h
v forall v. SupportTermOps v => v -> v -> v
.== Term h
x forall v. SupportTermOps v => v -> v -> v
.|| Term h
x forall v. SupportTermOps v => v -> v -> v
.< Term h
0
      -- assert v >= 0
      forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"real sqrt" forall a b. (a -> b) -> a -> b
$ Term h
v forall v. SupportTermOps v => v -> v -> v
.>= Term h
0
      -- Return variable
      forall (m :: Type -> Type) a. Monad m => a -> m a
return SMTExpr h 'BaseRealType
nm

    RealSpecialFunction SpecialFunction args
fn (SFn.SpecialFnArgs Assignment (SpecialFnArg (Expr t) 'BaseRealType) args
args) -> do
      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) =
             forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap 'BaseRealType
RealTypeMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term h -> Term h
tmfn forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 forall v. SupportTermOps v => v -> v
realSin  Assignment (SpecialFnArg (Expr t) 'BaseRealType) args
args
        SpecialFunction args
SFn.Cos  -> (Term h -> Term h)
-> Assignment
     (SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
-> SMTCollector t h (SMTExpr h 'BaseRealType)
sf1 forall v. SupportTermOps v => v -> v
realCos  Assignment (SpecialFnArg (Expr t) 'BaseRealType) args
args
        SpecialFunction args
SFn.Tan  -> (Term h -> Term h)
-> Assignment
     (SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
-> SMTCollector t h (SMTExpr h 'BaseRealType)
sf1 forall v. SupportTermOps v => v -> v
realTan  Assignment (SpecialFnArg (Expr t) 'BaseRealType) args
args
        SpecialFunction args
SFn.Sinh -> (Term h -> Term h)
-> Assignment
     (SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
-> SMTCollector t h (SMTExpr h 'BaseRealType)
sf1 forall v. SupportTermOps v => v -> v
realSinh Assignment (SpecialFnArg (Expr t) 'BaseRealType) args
args
        SpecialFunction args
SFn.Cosh -> (Term h -> Term h)
-> Assignment
     (SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
-> SMTCollector t h (SMTExpr h 'BaseRealType)
sf1 forall v. SupportTermOps v => v -> v
realCosh Assignment (SpecialFnArg (Expr t) 'BaseRealType) args
args
        SpecialFunction args
SFn.Tanh -> (Term h -> Term h)
-> Assignment
     (SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
-> SMTCollector t h (SMTExpr h 'BaseRealType)
sf1 forall v. SupportTermOps v => v -> v
realTanh Assignment (SpecialFnArg (Expr t) 'BaseRealType) args
args
        SpecialFunction args
SFn.Exp  -> (Term h -> Term h)
-> Assignment
     (SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
-> SMTCollector t h (SMTExpr h 'BaseRealType)
sf1 forall v. SupportTermOps v => v -> v
realExp  Assignment (SpecialFnArg (Expr t) 'BaseRealType) args
args
        SpecialFunction args
SFn.Log  -> (Term h -> Term h)
-> Assignment
     (SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
-> SMTCollector t h (SMTExpr h 'BaseRealType)
sf1 forall v. SupportTermOps v => v -> v
realLog  Assignment (SpecialFnArg (Expr t) 'BaseRealType) args
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 Term h
y <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t 'BaseRealType
ye
                 Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t 'BaseRealType
xe
                 forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap 'BaseRealType
RealTypeMap forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
realATan2 Term h
y Term h
x
        SpecialFunction args
_ -> 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 = 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 = forall p (n :: Natural). UnaryBV p n -> [(p, Integer, Integer)]
UnaryBV.unsignedRanges UnaryBV (Expr t BaseBoolType) n
t

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    StringLength Expr t (BaseStringType si)
xe -> do
      case forall (e :: BaseType -> Type) (si :: StringInfo).
IsExpr e =>
e (BaseStringType si) -> StringInfoRepr si
stringInfo Expr t (BaseStringType si)
xe of
        StringInfoRepr si
UnicodeRepr -> do
          forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkStringSupport Expr t tp
i
          Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseStringType si)
xe
          forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap 'BaseIntegerType
IntegerTypeMap forall a b. (a -> b) -> a -> b
$ forall h. SMTWriter h => Term h -> Term h
stringLength @h Term h
x
        StringInfoRepr si
si -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
"Unsupported symbolic string length operation " forall a. [a] -> [a] -> [a]
++  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 forall (e :: BaseType -> Type) (si :: StringInfo).
IsExpr e =>
e (BaseStringType si) -> StringInfoRepr si
stringInfo Expr t (BaseStringType si)
xe of
        StringInfoRepr si
UnicodeRepr -> do
          forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkStringSupport Expr t tp
i
          Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseStringType si)
xe
          Term h
y <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseStringType si)
ye
          Term h
k <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t 'BaseIntegerType
ke
          forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap 'BaseIntegerType
IntegerTypeMap forall a b. (a -> b) -> a -> b
$ forall h. SMTWriter h => Term h -> Term h -> Term h -> Term h
stringIndexOf @h Term h
x Term h
y Term h
k
        StringInfoRepr si
si -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
"Unsupported symbolic string index-of operation " forall a. [a] -> [a] -> [a]
++  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 forall (e :: BaseType -> Type) (si :: StringInfo).
IsExpr e =>
e (BaseStringType si) -> StringInfoRepr si
stringInfo Expr t ('BaseStringType si)
xe of
        StringInfoRepr si
UnicodeRepr -> do
          forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkStringSupport Expr t tp
i
          Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseStringType si)
xe
          Term h
off <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t 'BaseIntegerType
offe
          Term h
len <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t 'BaseIntegerType
lene
          forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap ('BaseStringType Unicode)
UnicodeTypeMap forall a b. (a -> b) -> a -> b
$ forall h. SMTWriter h => Term h -> Term h -> Term h -> Term h
stringSubstring @h Term h
x Term h
off Term h
len
        StringInfoRepr si
si -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
"Unsupported symbolic string substring operation " forall a. [a] -> [a] -> [a]
++  forall a. Show a => a -> String
show StringInfoRepr si
si)

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

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

    StringIsSuffixOf Expr t (BaseStringType si)
xe Expr t (BaseStringType si)
ye ->
      case forall (e :: BaseType -> Type) (si :: StringInfo).
IsExpr e =>
e (BaseStringType si) -> StringInfoRepr si
stringInfo Expr t (BaseStringType si)
xe of
        StringInfoRepr si
UnicodeRepr -> do
          forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkStringSupport Expr t tp
i
          Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseStringType si)
xe
          Term h
y <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseStringType si)
ye
          forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall h. SMTWriter h => Term h -> Term h -> Term h
stringIsSuffixOf @h Term h
x Term h
y
        StringInfoRepr si
si -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
"Unsupported symbolic string is-suffix-of operation " forall a. [a] -> [a] -> [a]
++  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
          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) = forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall h. SMTWriter h => Text -> Term h
stringTerm @h forall a b. (a -> b) -> a -> b
$ StringLiteral Unicode -> Text
fromUnicodeLit StringLiteral Unicode
l
              f (SSeq.StringSeqTerm Expr t ('BaseStringType Unicode)
t)    = forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseStringType Unicode)
t
          [Term h]
xs <- forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM StringSeqEntry (Expr t) Unicode
-> ReaderT (SMTCollectorState t h) IO (Term h)
f forall a b. (a -> b) -> a -> b
$ forall (e :: BaseType -> Type) (si :: StringInfo).
StringSeq e si -> [StringSeqEntry e si]
SSeq.toList StringSeq (Expr t) si
xes
          forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap ('BaseStringType Unicode)
UnicodeTypeMap forall a b. (a -> b) -> a -> b
$ forall h. SMTWriter h => [Term h] -> Term h
stringAppend @h [Term h]
xs

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

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

    FloatNeg FloatPrecisionRepr fpp
fpp Expr t ('BaseFloatType fpp)
x -> do
      Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
x
      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v
floatNeg Term h
xe
    FloatAbs FloatPrecisionRepr fpp
fpp Expr t ('BaseFloatType fpp)
x -> do
      Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
x
      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v
floatAbs Term h
xe
    FloatSqrt FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t ('BaseFloatType fpp)
x -> do
      Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
x
      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => RoundingMode -> v -> v
floatSqrt RoundingMode
r Term h
xe
    FloatAdd FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t ('BaseFloatType fpp)
x Expr t ('BaseFloatType fpp)
y -> do
      Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
x
      Term h
ye <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
y
      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => RoundingMode -> v -> v -> v
floatAdd RoundingMode
r Term h
xe Term h
ye
    FloatSub FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t ('BaseFloatType fpp)
x Expr t ('BaseFloatType fpp)
y -> do
      Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
x
      Term h
ye <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
y
      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => RoundingMode -> v -> v -> v
floatSub RoundingMode
r Term h
xe Term h
ye
    FloatMul FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t ('BaseFloatType fpp)
x Expr t ('BaseFloatType fpp)
y -> do
      Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
x
      Term h
ye <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
y
      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => RoundingMode -> v -> v -> v
floatMul RoundingMode
r Term h
xe Term h
ye
    FloatDiv FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t ('BaseFloatType fpp)
x Expr t ('BaseFloatType fpp)
y -> do
      Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
x
      Term h
ye <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
y
      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => RoundingMode -> v -> v -> v
floatDiv RoundingMode
r Term h
xe Term h
ye
    FloatRem FloatPrecisionRepr fpp
fpp Expr t ('BaseFloatType fpp)
x Expr t ('BaseFloatType fpp)
y -> do
      Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
x
      Term h
ye <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
y
      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
floatRem Term h
xe Term h
ye
    FloatFMA FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t ('BaseFloatType fpp)
x Expr t ('BaseFloatType fpp)
y Expr t ('BaseFloatType fpp)
z -> do
      Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
x
      Term h
ye <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
y
      Term h
ze <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
z
      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => RoundingMode -> v -> v -> v -> v
floatFMA RoundingMode
r Term h
xe Term h
ye Term h
ze
    FloatFpEq Expr t (BaseFloatType fpp)
x Expr t (BaseFloatType fpp)
y -> do
      Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      Term h
ye <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
y
      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
floatFpEq Term h
xe Term h
ye
    FloatLe Expr t (BaseFloatType fpp)
x Expr t (BaseFloatType fpp)
y -> do
      Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      Term h
ye <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
y
      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
floatLe Term h
xe Term h
ye
    FloatLt Expr t (BaseFloatType fpp)
x Expr t (BaseFloatType fpp)
y -> do
      Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      Term h
ye <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
y
      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
floatLt Term h
xe Term h
ye
    FloatIsNaN Expr t (BaseFloatType fpp)
x -> do
      Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v
floatIsNaN Term h
xe
    FloatIsInf Expr t (BaseFloatType fpp)
x -> do
      Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v
floatIsInf Term h
xe
    FloatIsZero Expr t (BaseFloatType fpp)
x -> do
      Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v
floatIsZero Term h
xe
    FloatIsPos Expr t (BaseFloatType fpp)
x -> do
      Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v
floatIsPos Term h
xe
    FloatIsNeg Expr t (BaseFloatType fpp)
x -> do
      Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v
floatIsNeg Term h
xe
    FloatIsSubnorm Expr t (BaseFloatType fpp)
x -> do
      Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v
floatIsSubnorm Term h
xe
    FloatIsNorm Expr t (BaseFloatType fpp)
x -> do
      Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v
floatIsNorm Term h
xe
    FloatCast FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t (BaseFloatType fpp')
x -> do
      Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp')
x
      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp) forall a b. (a -> b) -> a -> b
$
        forall v (fpp :: FloatPrecision).
SupportTermOps v =>
FloatPrecisionRepr fpp -> RoundingMode -> v -> v
floatCast FloatPrecisionRepr fpp
fpp RoundingMode
r Term h
xe
    FloatRound FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t ('BaseFloatType fpp)
x -> do
      Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
x
      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp)forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => RoundingMode -> v -> v
floatRound RoundingMode
r Term h
xe
    FloatToBinary fpp :: FloatPrecisionRepr (FloatingPointPrecision eb sb)
fpp@(FloatingPointPrecisionRepr NatRepr eb
eb NatRepr sb
sb) Expr t (BaseFloatType (FloatingPointPrecision eb sb))
x -> do
      Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType (FloatingPointPrecision eb sb))
x
      Term h
val <- forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
"float_binary" forall a b. (a -> b) -> a -> b
$ forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap forall a b. (a -> b) -> a -> b
$ forall (m :: Natural) (n :: Natural).
NatRepr m -> NatRepr n -> NatRepr (m + n)
addNat NatRepr eb
eb NatRepr sb
sb)
      -- (assert (= ((_ to_fp eb sb) val) xe))
      forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"float_binary" forall a b. (a -> b) -> a -> b
$
        forall v (fpp :: FloatPrecision).
SupportTermOps v =>
FloatPrecisionRepr fpp -> v -> v
floatFromBinary FloatPrecisionRepr (FloatingPointPrecision eb sb)
fpp Term h
val forall v. SupportTermOps v => v -> v -> v
.== Term h
xe
      -- qnan: 0b0 0b1..1 0b10..0
      -- BGS: I tried using bv-sized primitives for this and it would
      -- have required a lot of proofs. Probable worth revisiting this.
      let qnan :: Term h
qnan = forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm (forall (m :: Natural) (n :: Natural).
NatRepr m -> NatRepr n -> NatRepr (m + n)
addNat NatRepr eb
eb NatRepr sb
sb) forall a b. (a -> b) -> a -> b
$
                 forall (w :: Natural). NatRepr w -> Integer -> BV w
BV.mkBV (forall (m :: Natural) (n :: Natural).
NatRepr m -> NatRepr n -> NatRepr (m + n)
addNat NatRepr eb
eb NatRepr sb
sb) forall a b. (a -> b) -> a -> b
$
                 forall a. Bits a => a -> Int -> a
Bits.shiftL
                  (Integer
2 forall a b. (Num a, Integral b) => a -> b -> a
^ (forall (n :: Natural). NatRepr n -> Natural
natValue NatRepr eb
eb forall a. Num a => a -> a -> a
+ Natural
1) forall a. Num a => a -> a -> a
- Integer
1)
                  (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (n :: Natural). NatRepr n -> Natural
natValue NatRepr sb
sb forall a. Num a => a -> a -> a
- Natural
2))
      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap forall a b. (a -> b) -> a -> b
$ forall (m :: Natural) (n :: Natural).
NatRepr m -> NatRepr n -> NatRepr (m + n)
addNat NatRepr eb
eb NatRepr sb
sb) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v -> v
ite (forall v. SupportTermOps v => v -> v
floatIsNaN Term h
xe) Term h
qnan Term h
val
    FloatFromBinary FloatPrecisionRepr (FloatingPointPrecision eb sb)
fpp Expr t (BaseBVType (eb + sb))
x -> do
      Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType (eb + sb))
x
      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr (FloatingPointPrecision eb sb)
fpp) forall a b. (a -> b) -> a -> b
$
        forall v (fpp :: FloatPrecision).
SupportTermOps v =>
FloatPrecisionRepr fpp -> v -> v
floatFromBinary FloatPrecisionRepr (FloatingPointPrecision eb sb)
fpp Term h
xe
    BVToFloat FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t (BaseBVType w)
x -> do
      Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
x
      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp) forall a b. (a -> b) -> a -> b
$
        forall v (fpp :: FloatPrecision).
SupportTermOps v =>
FloatPrecisionRepr fpp -> RoundingMode -> v -> v
bvToFloat FloatPrecisionRepr fpp
fpp RoundingMode
r Term h
xe
    SBVToFloat FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t (BaseBVType w)
x -> do
      Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
x
      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp) forall a b. (a -> b) -> a -> b
$
        forall v (fpp :: FloatPrecision).
SupportTermOps v =>
FloatPrecisionRepr fpp -> RoundingMode -> v -> v
sbvToFloat FloatPrecisionRepr fpp
fpp RoundingMode
r Term h
xe
    RealToFloat FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t 'BaseRealType
x -> do
      Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t 'BaseRealType
x
      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp) forall a b. (a -> b) -> a -> b
$
        forall v (fpp :: FloatPrecision).
SupportTermOps v =>
FloatPrecisionRepr fpp -> RoundingMode -> v -> v
realToFloat FloatPrecisionRepr fpp
fpp RoundingMode
r Term h
xe
    FloatToBV NatRepr w
w RoundingMode
r Expr t (BaseFloatType fpp)
x -> do
      Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => Natural -> RoundingMode -> v -> v
floatToBV (forall (n :: Natural). NatRepr n -> Natural
natValue NatRepr w
w) RoundingMode
r Term h
xe
    FloatToSBV NatRepr w
w RoundingMode
r Expr t (BaseFloatType fpp)
x -> do
      Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => Natural -> RoundingMode -> v -> v
floatToSBV (forall (n :: Natural). NatRepr n -> Natural
natValue NatRepr w
w) RoundingMode
r Term h
xe
    FloatToReal Expr t (BaseFloatType fpp)
x -> do
      Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap 'BaseRealType
RealTypeMap forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v
floatToReal Term h
xe
    FloatSpecialFunction{} -> 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
      SMTExpr h ('BaseArrayType (i ::> itp) tp1)
base_array <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t ('BaseArrayType (i ::> itp) tp1)
def
      [(Assignment IndexLit (i ::> itp), Term h)]
elt_exprs <- (forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverseforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s t a b. Field2 s t a b => Lens s t a b
_2) forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr (forall (e :: BaseType -> Type) (ctx :: Ctx BaseType)
       (tp :: BaseType).
ArrayUpdateMap e ctx tp -> [(Assignment IndexLit ctx, e tp)]
AUM.toList ArrayUpdateMap (Expr t) (i ::> itp) tp1
elts)
      let array_type :: TypeMap ('BaseArrayType (i ::> itp) tp1)
array_type = forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h ('BaseArrayType (i ::> itp) tp1)
base_array
      case TypeMap ('BaseArrayType (i ::> itp) tp1)
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 (forall v (ctx :: Ctx BaseType).
SupportTermOps v =>
Assignment IndexLit ctx -> [v]
mkIndexLitTerms Assignment IndexLit ctx
idx) Term h
elt
          forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap ('BaseArrayType (i ::> itp) tp1)
array_type forall a b. (a -> b) -> a -> b
$
            forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (ctx :: Ctx BaseType).
Term h -> (Assignment IndexLit ctx, Term h) -> Term h
set_at_index (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 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 k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type) a.
FoldableFC t =>
(forall (x :: k). f x -> a) -> forall (x :: l). t f x -> [a]
toListFC forall v (tp :: BaseType). SupportTermOps v => IndexLit tp -> v
mkIndexLitTerm Assignment IndexLit ctx
idx) Term h
elt
              forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap ('BaseArrayType (i ::> itp) tp1)
array_type forall a b. (a -> b) -> a -> b
$
                forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (ctx :: Ctx BaseType).
Term h -> (Assignment IndexLit ctx, Term h) -> Term h
set_at_index (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.
              forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (forall t h. WriterConn t h -> Bool
supportFunctionDefs WriterConn t h
conn)) forall a b. (a -> b) -> a -> b
$ do
                forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty (forall t h. WriterConn t h -> String
smtWriterName WriterConn t h
conn) forall ann. Doc ann -> Doc ann -> Doc ann
<+>
                  Doc Any
"does not support arrays as functions."
              -- Create names for index variables.
              [(Text, Some TypeMap)]
args <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall t h (args :: Ctx BaseType).
WriterConn t h
-> Assignment TypeMap args -> IO [(Text, Some TypeMap)]
createTypeMapArgsForArray WriterConn t h
conn Assignment TypeMap (idxl ::> idx)
idx_types
              -- Get list of terms for arguments.
              let idx_terms :: [Term h]
idx_terms = forall v. SupportTermOps v => Text -> v
fromText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Some TypeMap)]
args
              -- Return value at index in base_array.
              let base_lookup :: Term h
base_lookup = forall v. SupportTermOps v => v -> [v] -> v
smtFnApp (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 -> (Assignment IndexLit (i ::> itp), Term h) -> Term h
set_at_index Term h
prev_value (Assignment IndexLit (i ::> itp)
idx_lits, Term h
elt) =
                    let update_idx :: [Term h]
update_idx = forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type) a.
FoldableFC t =>
(forall (x :: k). f x -> a) -> forall (x :: l). t f x -> [a]
toListFC forall v (tp :: BaseType). SupportTermOps v => IndexLit tp -> v
mkIndexLitTerm Assignment IndexLit (i ::> itp)
idx_lits
                        cond :: Term h
cond = forall v. SupportTermOps v => [v] -> v
andAll (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall v. SupportTermOps v => v -> v -> v
(.==) [Term h]
update_idx [Term h]
idx_terms)
                     in forall v. SupportTermOps v => v -> v -> v -> v
ite Term h
cond Term h
elt Term h
prev_value
              -- Get final expression for definition.
              let expr :: Term h
expr = 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
              forall (tp :: BaseType) h. TypeMap tp -> Text -> SMTExpr h tp
SMTName TypeMap ('BaseArrayType (i ::> itp) tp1)
array_type forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (rtp :: BaseType) h t.
[(Text, Some TypeMap)]
-> TypeMap rtp -> Term h -> SMTCollector t h Text
freshBoundFn [(Text, Some TypeMap)]
args TypeMap tp
resType Term h
expr

    ConstantArray Assignment BaseTypeRepr (i ::> tp1)
idxRepr BaseTypeRepr b
_bRepr Expr t b
ve -> do
      SMTExpr h b
v <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t b
ve
      let value_type :: TypeMap b
value_type = forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h b
v
          feat :: ProblemFeatures
feat = forall t h. WriterConn t h -> ProblemFeatures
supportedFeatures WriterConn t h
conn
          mkArray :: Assignment TypeMap (i ::> tp1)
-> TypeMap b -> TypeMap ('BaseArrayType (i ::> tp1) b)
mkArray = if ProblemFeatures
feat ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useSymbolicArrays
                    then forall (idx :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
Assignment TypeMap (idx ::> idx)
-> TypeMap tp -> TypeMap (BaseArrayType (idx ::> idx) tp)
PrimArrayTypeMap
                    else forall (idx :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
Assignment TypeMap (idx ::> idx)
-> TypeMap tp -> TypeMap (BaseArrayType (idx ::> idx) tp)
FnArrayTypeMap
      Assignment TypeMap (i ::> tp1)
idx_types <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
        forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
       (g :: k -> Type) (m :: Type -> Type).
(TraversableFC t, Applicative m) =>
(forall (x :: k). f x -> m (g x))
-> forall (x :: l). t f x -> m (t g x)
traverseFC (forall (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 (forall t (tp :: BaseType) ann. Expr t tp -> SMTSource ann
eltSource Expr t tp
i)) Assignment BaseTypeRepr (i ::> tp1)
idxRepr
      let tp :: TypeMap ('BaseArrayType (i ::> tp1) b)
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
      forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn TypeMap ('BaseArrayType (i ::> tp1) b)
tp)

      case forall h. SMTWriter h => Maybe (ArrayConstantFn (Term h))
arrayConstant @h of
        Just ArrayConstantFn (Term h)
constFn
          | Bool
otherwise -> do
            let idx_smt_types :: [Some TypeMap]
idx_smt_types = forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type) a.
FoldableFC t =>
(forall (x :: k). f x -> a) -> forall (x :: l). t f x -> [a]
toListFC forall k (f :: k -> Type) (x :: k). f x -> Some f
Some Assignment TypeMap (i ::> tp1)
idx_types
            forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap ('BaseArrayType (i ::> tp1) b)
tp forall a b. (a -> b) -> a -> b
$!
              ArrayConstantFn (Term h)
constFn [Some TypeMap]
idx_smt_types (forall k (f :: k -> Type) (x :: k). f x -> Some f
Some TypeMap b
value_type) (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h b
v)
        Maybe (ArrayConstantFn (Term h))
Nothing -> do
          forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (forall t h. WriterConn t h -> Bool
supportFunctionDefs WriterConn t h
conn)) forall a b. (a -> b) -> a -> b
$ do
            forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty (forall t h. WriterConn t h -> String
smtWriterName WriterConn t h
conn) forall ann. Doc ann -> Doc ann -> Doc ann
<+>
              Doc Any
"cannot encode constant arrays."
          -- Create names for index variables.
          [(Text, Some TypeMap)]
args <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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
          forall (tp :: BaseType) h. TypeMap tp -> Text -> SMTExpr h tp
SMTName TypeMap ('BaseArrayType (i ::> tp1) b)
tp forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (rtp :: BaseType) h t.
[(Text, Some TypeMap)]
-> TypeMap rtp -> Term h -> SMTCollector t h Text
freshBoundFn [(Text, Some TypeMap)]
args TypeMap b
value_type (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h b
v)

    SelectArray BaseTypeRepr tp
_bRepr Expr t (BaseArrayType (i ::> tp1) tp)
a Assignment (Expr t) (i ::> tp1)
idx -> do
      SMTExpr h (BaseArrayType (i ::> tp1) tp)
aexpr <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t (BaseArrayType (i ::> tp1) tp)
a
      [Term h]
idxl <- forall h t (ctx :: Ctx BaseType).
SMTWriter h =>
Assignment (Expr t) ctx -> SMTCollector t h [Term h]
mkIndicesTerms Assignment (Expr t) (i ::> tp1)
idx
      forall h (tp :: BaseType) t.
SupportTermOps (Term h) =>
SMTExpr h tp -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm' forall a b. (a -> b) -> a -> b
$ forall h (idxl :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
SMTWriter h =>
SMTExpr h (BaseArrayType (idxl ::> idx) tp)
-> [Term h] -> SMTExpr h tp
smt_array_select SMTExpr h (BaseArrayType (i ::> tp1) tp)
aexpr [Term h]
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
      SMTExpr h ('BaseArrayType (i ::> tp1) b)
a <- 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
      [Term h]
updated_idx <- forall h t (ctx :: Ctx BaseType).
SMTWriter h =>
Assignment (Expr t) ctx -> SMTCollector t h [Term h]
mkIndicesTerms Assignment (Expr t) (i ::> tp1)
idx
      Term h
value <- forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t b
ve
      let array_type :: TypeMap ('BaseArrayType (i ::> tp1) b)
array_type = forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h ('BaseArrayType (i ::> tp1) b)
a
      case TypeMap ('BaseArrayType (i ::> tp1) b)
array_type of
        PrimArrayTypeMap Assignment TypeMap (idxl ::> idx)
_ TypeMap tp
_ -> do
            forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap ('BaseArrayType (i ::> tp1) b)
array_type forall a b. (a -> b) -> a -> b
$
              forall h. SMTWriter h => Term h -> [Term h] -> Term h -> Term h
arrayUpdate @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 forall v. SupportTermOps v => Maybe (v -> [v] -> v -> v)
smtFnUpdate of
            Just Term h -> [Term h] -> Term h -> Term h
updateFn -> do
              forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap ('BaseArrayType (i ::> tp1) b)
array_type forall a b. (a -> b) -> a -> b
$ Term h -> [Term h] -> Term h -> Term h
updateFn (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.
              [(Text, Some TypeMap)]
args <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall t h (args :: Ctx BaseType).
WriterConn t h
-> Assignment TypeMap args -> IO [(Text, Some TypeMap)]
createTypeMapArgsForArray WriterConn t h
conn Assignment TypeMap (idxl ::> idx)
idxTypes

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

    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
      SMTExpr h ('BaseArrayType (SingleCtx (BaseBVType w)) a)
dest_arr_typed_expr <- 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 :: TypeMap ('BaseArrayType (SingleCtx (BaseBVType w)) a)
arr_type = forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h ('BaseArrayType (SingleCtx (BaseBVType w)) a)
dest_arr_typed_expr
      SMTExpr h (BaseBVType w)
dest_idx_typed_expr <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t (BaseBVType w)
dest_idx
      let dest_idx_expr :: Term h
dest_idx_expr = forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h (BaseBVType w)
dest_idx_typed_expr
      let idx_type :: TypeMap (BaseBVType w)
idx_type = forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h (BaseBVType w)
dest_idx_typed_expr
      SMTExpr h ('BaseArrayType (SingleCtx (BaseBVType w)) a)
src_arr_typed_expr <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t ('BaseArrayType (SingleCtx (BaseBVType w)) a)
src_arr
      Term h
src_idx_expr <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
src_idx
      Term h
len_expr <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
len

      SMTExpr h ('BaseArrayType (SingleCtx (BaseBVType w)) a)
res <- forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
"array_copy" TypeMap ('BaseArrayType (SingleCtx (BaseBVType w)) a)
arr_type

      CollectorResults h (Term h)
cr <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall t h a. WriterConn t h -> IO a -> IO a
withConnEntryStack WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ forall h t a.
SupportTermOps (Term h) =>
WriterConn t h -> SMTCollector t h a -> IO (CollectorResults h a)
runInSandbox WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ do
        Term h
i_expr <- forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
"i" TypeMap (BaseBVType w)
idx_type
        forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase (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 (SingleCtx (BaseBVType w)) a)
res [Term h
i_expr]) forall v. SupportTermOps v => v -> v -> v
.==
          forall v. SupportTermOps v => v -> v -> v -> v
ite ((forall v. SupportTermOps v => v -> v -> v
bvULe Term h
dest_idx_expr Term h
i_expr) forall v. SupportTermOps v => v -> v -> v
.&& (forall v. SupportTermOps v => v -> v -> v
bvULt Term h
i_expr (forall v. SupportTermOps v => v -> v -> v
bvAdd Term h
dest_idx_expr Term h
len_expr)))
            (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase (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 (SingleCtx (BaseBVType w)) a)
src_arr_typed_expr [forall v. SupportTermOps v => v -> v -> v
bvAdd Term h
src_idx_expr (forall v. SupportTermOps v => v -> v -> v
bvSub Term h
i_expr Term h
dest_idx_expr)]))
            (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase (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 (SingleCtx (BaseBVType w)) a)
dest_arr_typed_expr [Term h
i_expr]))
      forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"array copy" forall a b. (a -> b) -> a -> b
$ forall h. SMTWriter h => CollectorResults h (Term h) -> Term h
forallResult CollectorResults h (Term h)
cr
      forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"array copy" forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
bvULt Term h
dest_idx_expr (forall v. SupportTermOps v => v -> v -> v
bvAdd Term h
dest_idx_expr Term h
len_expr)
      forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"array copy" forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
bvULt Term h
src_idx_expr (forall v. SupportTermOps v => v -> v -> v
bvAdd Term h
src_idx_expr Term h
len_expr)

      forall (m :: Type -> Type) a. Monad m => a -> m a
return SMTExpr h ('BaseArrayType (SingleCtx (BaseBVType w)) a)
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
      SMTExpr h ('BaseArrayType (SingleCtx (BaseBVType w)) a)
arr_typed_expr <- 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 :: TypeMap ('BaseArrayType (SingleCtx (BaseBVType w)) a)
arr_type = forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h ('BaseArrayType (SingleCtx (BaseBVType w)) a)
arr_typed_expr
      SMTExpr h (BaseBVType w)
idx_typed_expr <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t (BaseBVType w)
idx
      let idx_expr :: Term h
idx_expr = forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h (BaseBVType w)
idx_typed_expr
      let idx_type :: TypeMap (BaseBVType w)
idx_type = forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h (BaseBVType w)
idx_typed_expr
      Term h
val_expr <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t a
val
      Term h
len_expr <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
len

      SMTExpr h ('BaseArrayType (SingleCtx (BaseBVType w)) a)
res <- forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
"array_set" TypeMap ('BaseArrayType (SingleCtx (BaseBVType w)) a)
arr_type
      CollectorResults h (Term h)
cr <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall t h a. WriterConn t h -> IO a -> IO a
withConnEntryStack WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ forall h t a.
SupportTermOps (Term h) =>
WriterConn t h -> SMTCollector t h a -> IO (CollectorResults h a)
runInSandbox WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ do
        Term h
i_expr <- forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
"i" TypeMap (BaseBVType w)
idx_type
        forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase (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 (SingleCtx (BaseBVType w)) a)
res [Term h
i_expr]) forall v. SupportTermOps v => v -> v -> v
.==
          forall v. SupportTermOps v => v -> v -> v -> v
ite ((forall v. SupportTermOps v => v -> v -> v
bvULe Term h
idx_expr Term h
i_expr) forall v. SupportTermOps v => v -> v -> v
.&& (forall v. SupportTermOps v => v -> v -> v
bvULt Term h
i_expr (forall v. SupportTermOps v => v -> v -> v
bvAdd Term h
idx_expr Term h
len_expr)))
            Term h
val_expr
            (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase (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 (SingleCtx (BaseBVType w)) a)
arr_typed_expr [Term h
i_expr]))
      forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"array set" forall a b. (a -> b) -> a -> b
$ forall h. SMTWriter h => CollectorResults h (Term h) -> Term h
forallResult CollectorResults h (Term h)
cr
      forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"array set" forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
bvULt Term h
idx_expr (forall v. SupportTermOps v => v -> v -> v
bvAdd Term h
idx_expr Term h
len_expr)

      forall (m :: Type -> Type) a. Monad m => a -> m a
return SMTExpr h ('BaseArrayType (SingleCtx (BaseBVType w)) a)
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
      SMTExpr h (BaseArrayType (SingleCtx (BaseBVType w)) a)
x_arr_typed_expr <- 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
      SMTExpr h (BaseBVType w)
x_idx_typed_expr <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t (BaseBVType w)
x_idx
      let x_idx_expr :: Term h
x_idx_expr = forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h (BaseBVType w)
x_idx_typed_expr
      let idx_type :: TypeMap (BaseBVType w)
idx_type = forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h (BaseBVType w)
x_idx_typed_expr
      SMTExpr h (BaseArrayType (SingleCtx (BaseBVType w)) a)
y_arr_typed_expr <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t (BaseArrayType (SingleCtx (BaseBVType w)) a)
y_arr
      Term h
y_idx_expr <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
y_idx
      Term h
len_expr <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
len

      CollectorResults h (Term h)
cr <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall t h a. WriterConn t h -> IO a -> IO a
withConnEntryStack WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ forall h t a.
SupportTermOps (Term h) =>
WriterConn t h -> SMTCollector t h a -> IO (CollectorResults h a)
runInSandbox WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ do
        Term h
i_expr <- forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
"i" TypeMap (BaseBVType w)
idx_type
        forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
impliesExpr ((forall v. SupportTermOps v => v -> v -> v
bvULe Term h
x_idx_expr Term h
i_expr) forall v. SupportTermOps v => v -> v -> v
.&& (forall v. SupportTermOps v => v -> v -> v
bvULt Term h
i_expr (forall v. SupportTermOps v => v -> v -> v
bvAdd Term h
x_idx_expr Term h
len_expr)))
          ((forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase (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 (SingleCtx (BaseBVType w)) a)
x_arr_typed_expr [Term h
i_expr])) forall v. SupportTermOps v => v -> v -> v
.==
            (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase (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 (SingleCtx (BaseBVType w)) a)
y_arr_typed_expr [forall v. SupportTermOps v => v -> v -> v
bvAdd Term h
y_idx_expr (forall v. SupportTermOps v => v -> v -> v
bvSub Term h
i_expr Term h
x_idx_expr)])))
      forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"array range equal" forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
bvULt Term h
x_idx_expr (forall v. SupportTermOps v => v -> v -> v
bvAdd Term h
x_idx_expr Term h
len_expr)
      forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"array range equal" forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
bvULt Term h
y_idx_expr (forall v. SupportTermOps v => v -> v -> v
bvAdd Term h
y_idx_expr Term h
len_expr)

      forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall h. SMTWriter h => CollectorResults h (Term h) -> Term h
forallResult CollectorResults h (Term h)
cr

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    StructField Expr t (BaseStructType flds)
s Index flds tp
idx BaseTypeRepr tp
_tp -> do
      SMTExpr h (BaseStructType flds)
expr <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t (BaseStructType flds)
s
      case forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h (BaseStructType flds)
expr of
       StructTypeMap Assignment TypeMap idx
flds -> do
         let tp :: TypeMap tp
tp = Assignment TypeMap idx
flds forall {k} (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
Assignment f ctx -> Index ctx tp -> f tp
Ctx.! Index flds 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
idx (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h (BaseStructType flds)
expr)
         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
  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 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
    forall {k} (ctx :: Ctx k) (m :: Type -> Type).
Applicative m =>
Size ctx -> (forall (tp :: k). Index ctx tp -> m ()) -> m ()
Ctx.forIndexM (forall {k} (f :: k -> Type) (ctx :: Ctx k).
Assignment f ctx -> Size ctx
Ctx.size Assignment (ExprBoundVar t) a
arg_vars) forall a b. (a -> b) -> a -> b
$ \Index a tp
i -> do
      let v :: ExprBoundVar t tp
v = Assignment (ExprBoundVar t) a
arg_vars 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 forall {k} (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
Assignment f ctx -> Index ctx tp -> f tp
Ctx.! Index a tp
i
      forall n (tp :: BaseType) h.
ExprBoundVar n tp -> SMTCollector n h ()
checkVarTypeSupport ExprBoundVar t tp
v
      SMTExpr h tp
x <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp)
freshVar TypeMap tp
smtType
      forall t (tp :: BaseType) h.
ExprBoundVar t tp -> SMTExpr h tp -> SMTCollector t h ()
bindVar ExprBoundVar t tp
v SMTExpr h tp
x
    -- Evaluate return value
    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 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 = forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> SolverSymbol
symFnName ExprSymFn t args ret
f
      let l :: ProgramLoc
l = forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> ProgramLoc
symFnLoc ExprSymFn t args ret
f
      TypeMap ret
smt_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 (forall ann. SolverSymbol -> ProgramLoc -> SMTSource ann
fnSource SolverSymbol
fnm ProgramLoc
l) BaseTypeRepr ret
return_type
      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_ (forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn) Assignment TypeMap args
arg_types
      forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn TypeMap ret
smt_ret
      forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommand WriterConn t h
conn forall a b. (a -> b) -> a -> b
$
        forall h (f :: Type -> Type) (args :: Ctx BaseType)
       (rtp :: BaseType).
SMTWriter h =>
f h -> Text -> Assignment TypeMap args -> TypeMap rtp -> Command h
declareCommand WriterConn t h
conn Text
nm Assignment TypeMap args
arg_types TypeMap ret
smt_ret
      forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! TypeMap ret
smt_ret
    DefinedFnInfo Assignment (ExprBoundVar t) args
arg_vars Expr t ret
return_value UnfoldPolicy
_ -> do
      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
      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 = forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> Nonce t (args ::> ret)
symFnId ExprSymFn t args ret
fn
  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 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
      forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Assignment TypeMap args
arg_types forall a. Eq a => a -> a -> Bool
/= Assignment TypeMap args
param_types) forall a b. (a -> b) -> a -> b
$ do
        forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Illegal arguments to function " forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack Text
nm forall a. [a] -> [a] -> [a]
++ String
".\n"
              forall a. [a] -> [a] -> [a]
++ String
"\tExpected arguments: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Assignment TypeMap args
param_types forall a. [a] -> [a] -> [a]
++String
"\n"
              forall a. [a] -> [a] -> [a]
++ String
"\tActual arguments: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Assignment TypeMap args
arg_types
      forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text
nm, TypeMap ret
ret)
    Maybe (SMTSymFn (args ::> ret))
Nothing -> do
      -- Check argument types can be passed to a function.
      forall t h (args :: Ctx BaseType).
WriterConn t h -> Assignment TypeMap args -> IO ()
checkArgumentTypes WriterConn t h
conn Assignment TypeMap args
arg_types
      -- Generate name.
      Text
nm <- forall t h. WriterConn t h -> SymbolBinding t -> IO Text
getSymbolName WriterConn t h
conn (forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> SymbolBinding t
FnSymbolBinding ExprSymFn t args ret
fn)
      TypeMap ret
ret_type <- forall h t (args :: Ctx BaseType) (ret :: BaseType).
SMTWriter h =>
WriterConn t h
-> Text
-> ExprSymFn t args ret
-> Assignment TypeMap args
-> IO (TypeMap ret)
mkSMTSymFn WriterConn t h
conn Text
nm ExprSymFn t args ret
fn Assignment TypeMap args
arg_types
      forall t h (ctx :: Ctx BaseType).
WriterConn t h
-> Nonce t ctx -> TermLifetime -> SMTSymFn ctx -> IO ()
cacheValueFn WriterConn t h
conn Nonce t (args ::> ret)
n TermLifetime
DeleteNever forall a b. (a -> b) -> a -> b
$! forall (idx :: Ctx BaseType) (idx :: BaseType).
Text
-> Assignment TypeMap idx -> TypeMap idx -> SMTSymFn (idx ::> idx)
SMTSymFn Text
nm Assignment TypeMap args
arg_types TypeMap ret
ret_type
      forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text
nm, TypeMap ret
ret_type)

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

-- | Write a expression to SMT
mkSMTTerm :: SMTWriter h => WriterConn t h -> Expr t tp -> IO (Term h)
mkSMTTerm :: 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 = forall h t a.
SMTWriter h =>
WriterConn t h -> SMTCollector t h a -> IO a
runOnLiveConnection WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ 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 = 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 = forall h t a.
SMTWriter h =>
WriterConn t h -> SMTCollector t h a -> IO a
runOnLiveConnection WriterConn t h
conn forall a b. (a -> b) -> a -> b
$
  forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr BoolExpr t
p forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    SMTName TypeMap BaseBoolType
_ Text
nm  -> forall (m :: Type -> Type) a. Monad m => a -> m a
return Text
nm
    SMTExpr TypeMap BaseBoolType
ty Term h
tm -> 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
  forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall t. Expr t BaseBoolType -> [(Expr t BaseBoolType, Polarity)]
asConjunction BoolExpr t
p) forall a b. (a -> b) -> a -> b
$ \(BoolExpr t
v,Polarity
pl) -> do
    Term h
f <- forall h t.
SMTWriter h =>
WriterConn t h -> BoolExpr t -> IO (Term h)
mkFormula WriterConn t h
c BoolExpr t
v
    forall t h. WriterConn t h -> ProgramLoc -> IO ()
updateProgramLoc WriterConn t h
c (forall t (tp :: BaseType). Expr t tp -> ProgramLoc
exprLoc BoolExpr t
v)
    case Polarity
pl of
      Polarity
BM.Positive -> forall h t. SMTWriter h => WriterConn t h -> Term h -> IO ()
assumeFormula WriterConn t h
c Term h
f
      Polarity
BM.Negative -> forall h t. SMTWriter h => WriterConn t h -> Term h -> IO ()
assumeFormula WriterConn t h
c (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 = forall {k} (ctx :: Ctx k) r.
Int
-> Size ctx -> (forall (tp :: k). Index ctx tp -> r -> r) -> r -> r
Ctx.forIndexRange Int
0 Size idx
sz forall (tp :: BaseType). Index idx tp -> [v] -> [v]
f []
  where sz :: Size idx
sz = 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
rforall a. a -> [a] -> [a]
:[v]
l)
         where GVW GroundValue tp
v = Assignment GroundValueWrapper idx
vals 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 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 -> forall v. SupportTermOps v => Integer -> v
integerTerm GroundValue tp
v
                      BVTypeMap NatRepr w
w -> forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w GroundValue tp
v
                      TypeMap tp
_ -> 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 = 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 = 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 = 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 (forall (fpp :: FloatPrecision).
FloatPrecisionRepr fpp -> RoundingMode -> BFOpts
fppOpts FloatPrecisionRepr fpp
fpp RoundingMode
RNE) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (w :: Natural). BV w -> Integer
BV.asUnsigned forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
  Rational
r <- forall h. SMTEvalFunctions h -> Term h -> IO Rational
smtEvalReal SMTEvalFunctions h
smtFns Term h
tm
  forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (forall a. Ratio a -> a
denominator Rational
r forall a. Eq a => a -> a -> Bool
/= Integer
1) forall a b. (a -> b) -> a -> b
$ forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Expected integer value."
  forall (m :: Type -> Type) a. Monad m => a -> m a
return (forall a. Ratio a -> a
numerator Rational
r)
getSolverVal WriterConn t h
_ SMTEvalFunctions h
smtFns TypeMap tp
ComplexToStructTypeMap Term h
tm =
  forall a. a -> a -> Complex a
(:+) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)
       forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> 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 =
  forall a. a -> a -> Complex a
(:+) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)
       forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> 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) <- 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 =
      forall a. a -> Maybe a -> a
fromMaybe GroundArray (idxl ::> idx) tp
byIndex forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (w :: Natural) (v :: Natural). SMTEvalBVArrayFn h w v
evalBVArray NatRepr w
w NatRepr w
v Term h
tm
  | Bool
otherwise = forall (m :: Type -> Type) a. Monad m => a -> m a
return GroundArray (idxl ::> idx) tp
byIndex
  where byIndex :: GroundArray (idxl ::> idx) tp
byIndex = forall (idx :: Ctx BaseType) (b :: BaseType).
(Assignment GroundValueWrapper idx -> IO (GroundValue b))
-> GroundArray idx b
ArrayMapping 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 (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)
          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 = forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (idx :: Ctx BaseType) (b :: BaseType).
(Assignment GroundValueWrapper idx -> IO (GroundValue b))
-> GroundArray idx b
ArrayMapping forall a b. (a -> b) -> a -> b
$ \Assignment GroundValueWrapper (idxl ::> idx)
i -> do
  let term :: Term h
term = forall v. SupportTermOps v => v -> [v] -> v
smtFnApp Term h
tm (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)
  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 {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 (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 = forall (tp :: BaseType). GroundValue tp -> GroundValueWrapper tp
GVW forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
  IdxCache t GroundValueWrapper
groundCache <- forall (m :: Type -> Type) t (f :: BaseType -> Type).
MonadIO m =>
m (IdxCache t f)
newIdxCache

  let cachedEval :: Expr t tp -> IO (GroundValue tp)
      cachedEval :: forall (tp :: BaseType). Expr t tp -> IO (GroundValue tp)
cachedEval Expr t tp
e =
        case forall t (tp :: BaseType). Expr t tp -> Maybe (Nonce t tp)
exprMaybeId Expr t tp
e of
          Maybe (Nonce t tp)
Nothing -> forall t (tp :: BaseType).
(forall (u :: BaseType). Expr t u -> IO (GroundValue u))
-> Expr t tp -> IO (GroundValue tp)
evalGroundExpr forall (tp :: BaseType). Expr t tp -> IO (GroundValue tp)
cachedEval Expr t tp
e
          Just Nonce t tp
e_id -> forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (tp :: BaseType). GroundValueWrapper tp -> GroundValue tp
unGVW forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (tp :: BaseType). GroundValue tp -> GroundValueWrapper tp
GVW forall a b. (a -> b) -> a -> b
$ do
            -- See if we have bound the Expr e to a SMT expression.
            Maybe (SMTExpr h tp)
me <- forall t h (tp :: BaseType).
WriterConn t h -> Nonce t tp -> IO (Maybe (SMTExpr h tp))
cacheLookupExpr WriterConn t h
conn Nonce t tp
e_id
            case Maybe (SMTExpr h tp)
me of
              -- Otherwise, try the evalGroundExpr function to evaluate a ground element.
              Maybe (SMTExpr h tp)
Nothing -> forall t (tp :: BaseType).
(forall (u :: BaseType). Expr t u -> IO (GroundValue u))
-> Expr t tp -> IO (GroundValue tp)
evalGroundExpr 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) ->
                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 (forall v. SupportTermOps v => Text -> v
fromText Text
nm)

              Just (SMTExpr TypeMap tp
tp Term h
expr) ->
                forall (m :: Type -> Type) a. MaybeT m a -> m (Maybe a)
runMaybeT (forall t (tp :: BaseType).
(forall (u :: BaseType). Expr t u -> MaybeT IO (GroundValue u))
-> Expr t tp -> MaybeT IO (GroundValue tp)
tryEvalGroundExpr (forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (tp :: BaseType). Expr t tp -> IO (GroundValue tp)
cachedEval) Expr t tp
e) forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  Just GroundValue tp
x  -> 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 -> 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


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