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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


instance ShowF TypeMap

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


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

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

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

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

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

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

  notExpr  :: v -> v

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  floatTerm  :: FloatPrecisionRepr fpp -> BigFloat -> v

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

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

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

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

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

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

  realDiv :: v -> v -> v

  realSin :: v -> v

  realCos :: v -> v

  realATan2 :: v -> v -> v

  realSinh :: v -> v

  realCosh :: v -> v

  realExp  :: v -> v

  realLog  :: v -> v

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

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

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

  fromText :: Text -> v


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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