{-# 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
(
SupportTermOps(..)
, ArrayConstantFn
, SMTWriter(..)
, SMTReadWriter (..)
, SMTEvalBVArrayFn
, SMTEvalBVArrayWrapper(..)
, Term
, app
, app_list
, builder_list
, WriterConn( supportFunctionDefs
, supportFunctionArguments
, supportQuantifiers
, supportedFeatures
, strictParsing
, connHandle
, connInputHandle
, smtWriterName
)
, connState
, newWriterConn
, resetEntryStack
, popEntryStackToTop
, entryStackHeight
, pushEntryStack
, popEntryStack
, cacheLookupFnNameBimap
, Command
, addCommand
, addCommandNoAck
, addCommands
, mkFreeVar
, bindVarAsFree
, TypeMap(..)
, typeMap
, freshBoundVarName
, assumeFormula
, assumeFormulaWithName
, assumeFormulaWithFreshName
, DefineStyle(..)
, AcknowledgementAction(..)
, ResponseStrictness(..)
, parserStrictness
, nullAcknowledgementAction
, addSynthFun
, addDeclareVar
, addConstraint
, assume
, mkSMTTerm
, mkFormula
, mkAtomicFormula
, SMTEvalFunctions(..)
, smtExprGroundEvalFn
, CollectorResults(..)
, mkBaseExpr
, runInSandbox
, What4.Interface.RoundingMode(..)
) where
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Exception
import Control.Lens hiding ((.>), Strict)
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.ST
import Control.Monad.State.Strict
import Control.Monad.Trans.Maybe
import Data.Bimap (Bimap)
import qualified Data.Bimap as Bimap
import qualified Data.BitVector.Sized as BV
import qualified Data.Bits as Bits
import Data.IORef
import Data.Kind
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe
import Data.Parameterized.Classes (ShowF(..))
import qualified Data.Parameterized.Context as Ctx
import qualified Data.Parameterized.HashTable as PH
import Data.Parameterized.Nonce (Nonce)
import Data.Parameterized.Some
import Data.Parameterized.TraversableFC
import Data.Ratio
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Lazy as Lazy
import Data.Text.Lazy.Builder (Builder)
import qualified Data.Text.Lazy.Builder as Builder
import qualified Data.Text.Lazy.Builder.Int as Builder (decimal)
import Data.Word
import LibBF (BigFloat, bfFromBits)
import Numeric.Natural
import Prettyprinter hiding (Unbounded)
import System.IO.Streams (OutputStream, InputStream)
import qualified System.IO.Streams as Streams
import What4.BaseTypes
import qualified What4.Config as CFG
import qualified What4.Expr.ArrayUpdateMap as AUM
import qualified What4.Expr.BoolMap as BM
import What4.Expr.Builder
import What4.Expr.GroundEval
import qualified What4.Expr.StringSeq as SSeq
import qualified What4.Expr.UnaryBV as UnaryBV
import qualified What4.Expr.WeightedSum as WSum
import What4.Interface (RoundingMode(..), stringInfo)
import What4.ProblemFeatures
import What4.ProgramLoc
import What4.SatResult
import qualified What4.SemiRing as SR
import qualified What4.SpecialFunctions as SFn
import What4.Symbol
import What4.Utils.AbstractDomains
import qualified What4.Utils.BVDomain as BVD
import What4.Utils.Complex
import What4.Utils.FloatHelpers
import What4.Utils.StringLiteral
data TypeMap (tp::BaseType) where
BoolTypeMap :: TypeMap BaseBoolType
IntegerTypeMap :: TypeMap BaseIntegerType
RealTypeMap :: TypeMap BaseRealType
BVTypeMap :: (1 <= w) => !(NatRepr w) -> TypeMap (BaseBVType w)
FloatTypeMap :: !(FloatPrecisionRepr fpp) -> TypeMap (BaseFloatType fpp)
UnicodeTypeMap :: TypeMap (BaseStringType Unicode)
ComplexToStructTypeMap:: TypeMap BaseComplexType
ComplexToArrayTypeMap :: TypeMap BaseComplexType
PrimArrayTypeMap :: !(Ctx.Assignment TypeMap (idxl Ctx.::> idx))
-> !(TypeMap tp)
-> TypeMap (BaseArrayType (idxl Ctx.::> idx) tp)
FnArrayTypeMap :: !(Ctx.Assignment TypeMap (idxl Ctx.::> idx))
-> TypeMap tp
-> TypeMap (BaseArrayType (idxl Ctx.::> idx) tp)
StructTypeMap :: !(Ctx.Assignment TypeMap idx)
-> TypeMap (BaseStructType idx)
instance ShowF TypeMap
instance Show (TypeMap a) where
show :: TypeMap a -> String
show TypeMap a
BoolTypeMap = String
"BoolTypeMap"
show TypeMap a
IntegerTypeMap = String
"IntegerTypeMap"
show TypeMap a
RealTypeMap = String
"RealTypeMap"
show (BVTypeMap NatRepr w
n) = String
"BVTypeMap " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show NatRepr w
n
show (FloatTypeMap FloatPrecisionRepr fpp
x) = String
"FloatTypeMap " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FloatPrecisionRepr fpp
x
show TypeMap a
UnicodeTypeMap = String
"UnicodeTypeMap"
show (TypeMap a
ComplexToStructTypeMap) = String
"ComplexToStructTypeMap"
show TypeMap a
ComplexToArrayTypeMap = String
"ComplexToArrayTypeMap"
show (PrimArrayTypeMap Assignment TypeMap (idxl ::> idx)
ctx TypeMap tp
a) = String
"PrimArrayTypeMap " forall a. [a] -> [a] -> [a]
++ forall k (f :: k -> Type) (tp :: k). ShowF f => f tp -> String
showF Assignment TypeMap (idxl ::> idx)
ctx forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall k (f :: k -> Type) (tp :: k). ShowF f => f tp -> String
showF TypeMap tp
a
show (FnArrayTypeMap Assignment TypeMap (idxl ::> idx)
ctx TypeMap tp
a) = String
"FnArrayTypeMap " forall a. [a] -> [a] -> [a]
++ forall k (f :: k -> Type) (tp :: k). ShowF f => f tp -> String
showF Assignment TypeMap (idxl ::> idx)
ctx forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall k (f :: k -> Type) (tp :: k). ShowF f => f tp -> String
showF TypeMap tp
a
show (StructTypeMap Assignment TypeMap idx
ctx) = String
"StructTypeMap " forall a. [a] -> [a] -> [a]
++ forall k (f :: k -> Type) (tp :: k). ShowF f => f tp -> String
showF Assignment TypeMap idx
ctx
instance Eq (TypeMap tp) where
TypeMap tp
x == :: TypeMap tp -> TypeMap tp -> Bool
== TypeMap tp
y = forall a. Maybe a -> Bool
isJust (forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality TypeMap tp
x TypeMap tp
y)
instance TestEquality TypeMap where
testEquality :: forall (a :: BaseType) (b :: BaseType).
TypeMap a -> TypeMap b -> Maybe (a :~: b)
testEquality TypeMap a
BoolTypeMap TypeMap b
BoolTypeMap = forall a. a -> Maybe a
Just forall {k} (a :: k). a :~: a
Refl
testEquality TypeMap a
IntegerTypeMap TypeMap b
IntegerTypeMap = forall a. a -> Maybe a
Just forall {k} (a :: k). a :~: a
Refl
testEquality TypeMap a
RealTypeMap TypeMap b
RealTypeMap = forall a. a -> Maybe a
Just forall {k} (a :: k). a :~: a
Refl
testEquality TypeMap a
UnicodeTypeMap TypeMap b
UnicodeTypeMap = forall a. a -> Maybe a
Just forall {k} (a :: k). a :~: a
Refl
testEquality (FloatTypeMap FloatPrecisionRepr fpp
x) (FloatTypeMap FloatPrecisionRepr fpp
y) = do
fpp :~: fpp
Refl <- forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality FloatPrecisionRepr fpp
x FloatPrecisionRepr fpp
y
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall {k} (a :: k). a :~: a
Refl
testEquality (BVTypeMap NatRepr w
x) (BVTypeMap NatRepr w
y) = do
w :~: w
Refl <- forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality NatRepr w
x NatRepr w
y
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall {k} (a :: k). a :~: a
Refl
testEquality TypeMap a
ComplexToStructTypeMap TypeMap b
ComplexToStructTypeMap =
forall a. a -> Maybe a
Just forall {k} (a :: k). a :~: a
Refl
testEquality TypeMap a
ComplexToArrayTypeMap TypeMap b
ComplexToArrayTypeMap =
forall a. a -> Maybe a
Just forall {k} (a :: k). a :~: a
Refl
testEquality (PrimArrayTypeMap Assignment TypeMap (idxl ::> idx)
xa TypeMap tp
xr) (PrimArrayTypeMap Assignment TypeMap (idxl ::> idx)
ya TypeMap tp
yr) = do
(idxl ::> idx) :~: (idxl ::> idx)
Refl <- forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality Assignment TypeMap (idxl ::> idx)
xa Assignment TypeMap (idxl ::> idx)
ya
tp :~: tp
Refl <- forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality TypeMap tp
xr TypeMap tp
yr
forall a. a -> Maybe a
Just forall {k} (a :: k). a :~: a
Refl
testEquality (FnArrayTypeMap Assignment TypeMap (idxl ::> idx)
xa TypeMap tp
xr) (FnArrayTypeMap Assignment TypeMap (idxl ::> idx)
ya TypeMap tp
yr) = do
(idxl ::> idx) :~: (idxl ::> idx)
Refl <- forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality Assignment TypeMap (idxl ::> idx)
xa Assignment TypeMap (idxl ::> idx)
ya
tp :~: tp
Refl <- forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality TypeMap tp
xr TypeMap tp
yr
forall a. a -> Maybe a
Just forall {k} (a :: k). a :~: a
Refl
testEquality (StructTypeMap Assignment TypeMap idx
x) (StructTypeMap Assignment TypeMap idx
y) = do
idx :~: idx
Refl <- forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality Assignment TypeMap idx
x Assignment TypeMap idx
y
forall a. a -> Maybe a
Just forall {k} (a :: k). a :~: a
Refl
testEquality TypeMap a
_ TypeMap b
_ = forall a. Maybe a
Nothing
semiRingTypeMap :: SR.SemiRingRepr sr -> TypeMap (SR.SemiRingBase sr)
semiRingTypeMap :: forall (sr :: SemiRing).
SemiRingRepr sr -> TypeMap (SemiRingBase sr)
semiRingTypeMap SemiRingRepr sr
SR.SemiRingIntegerRepr = TypeMap 'BaseIntegerType
IntegerTypeMap
semiRingTypeMap SemiRingRepr sr
SR.SemiRingRealRepr = TypeMap 'BaseRealType
RealTypeMap
semiRingTypeMap (SR.SemiRingBVRepr BVFlavorRepr fv
_flv NatRepr w
w) = forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w
type ArrayConstantFn v
= [Some TypeMap]
-> Some TypeMap
-> v
-> v
class Num v => SupportTermOps v where
boolExpr :: Bool -> v
notExpr :: v -> v
andAll :: [v] -> v
orAll :: [v] -> v
(.&&) :: v -> v -> v
v
x .&& v
y = forall v. SupportTermOps v => [v] -> v
andAll [v
x, v
y]
(.||) :: v -> v -> v
v
x .|| v
y = forall v. SupportTermOps v => [v] -> v
orAll [v
x, v
y]
(.==) :: v -> v -> v
(./=) :: v -> v -> v
v
x ./= v
y = forall v. SupportTermOps v => v -> v
notExpr (v
x forall v. SupportTermOps v => v -> v -> v
.== v
y)
impliesExpr :: v -> v -> v
impliesExpr v
x v
y = forall v. SupportTermOps v => v -> v
notExpr v
x forall v. SupportTermOps v => v -> v -> v
.|| v
y
letExpr :: [(Text, v)] -> v -> v
ite :: v -> v -> v -> v
sumExpr :: [v] -> v
sumExpr [] = v
0
sumExpr (v
h:[v]
r) = forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall a. Num a => a -> a -> a
(+) v
h [v]
r
termIntegerToReal :: v -> v
termRealToInteger :: v -> v
integerTerm :: Integer -> v
rationalTerm :: Rational -> v
(.<=) :: v -> v -> v
(.<) :: v -> v -> v
v
x .< v
y = forall v. SupportTermOps v => v -> v
notExpr (v
y forall v. SupportTermOps v => v -> v -> v
.<= v
x)
(.>) :: v -> v -> v
v
x .> v
y = v
y forall v. SupportTermOps v => v -> v -> v
.< v
x
(.>=) :: v -> v -> v
v
x .>= v
y = v
y forall v. SupportTermOps v => v -> v -> v
.<= v
x
intAbs :: v -> v
intDiv :: v -> v -> v
intMod :: v -> v -> v
intDivisible :: v -> Natural -> v
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
bvConcat :: v -> v -> v
:: NatRepr w -> Natural -> Natural -> v -> v
bvTestBit :: NatRepr w -> Natural -> v -> v
bvTestBit NatRepr w
w Natural
i v
x = (forall v (w :: Natural).
SupportTermOps v =>
NatRepr w -> Natural -> Natural -> v -> v
bvExtract NatRepr w
w Natural
i Natural
1 v
x forall v. SupportTermOps v => v -> v -> v
.== forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr 1
w1 (forall (w :: Natural). (1 <= w) => NatRepr w -> BV w
BV.one NatRepr 1
w1))
where w1 :: NatRepr 1
w1 :: NatRepr 1
w1 = forall (n :: Natural). KnownNat n => NatRepr n
knownNat
bvSumExpr :: NatRepr w -> [v] -> v
bvSumExpr NatRepr w
w [] = forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (forall (w :: Natural). NatRepr w -> BV w
BV.zero NatRepr w
w)
bvSumExpr NatRepr w
_ (v
h:[v]
r) = forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall v. SupportTermOps v => v -> v -> v
bvAdd v
h [v]
r
floatTerm :: FloatPrecisionRepr fpp -> BigFloat -> v
floatNeg :: v -> v
floatAbs :: v -> v
floatSqrt :: RoundingMode -> v -> v
floatAdd :: RoundingMode -> v -> v -> v
floatSub :: RoundingMode -> v -> v -> v
floatMul :: RoundingMode -> v -> v -> v
floatDiv :: RoundingMode -> v -> v -> v
floatRem :: v -> v -> v
floatFMA :: RoundingMode -> v -> v -> v -> v
floatEq :: v -> v -> v
floatFpEq :: v -> v -> v
floatLe :: v -> v -> v
floatLt :: v -> v -> v
floatIsNaN :: v -> v
floatIsInf :: v -> v
floatIsZero :: v -> v
floatIsPos :: v -> v
floatIsNeg :: v -> v
floatIsSubnorm :: v -> v
floatIsNorm :: v -> v
floatCast :: FloatPrecisionRepr fpp -> RoundingMode -> v -> v
floatRound :: RoundingMode -> v -> v
floatFromBinary :: FloatPrecisionRepr fpp -> v -> v
bvToFloat :: FloatPrecisionRepr fpp -> RoundingMode -> v -> v
sbvToFloat :: FloatPrecisionRepr fpp -> RoundingMode -> v -> v
realToFloat :: FloatPrecisionRepr fpp -> RoundingMode -> v -> v
floatToBV :: Natural -> RoundingMode -> v -> v
floatToSBV :: Natural -> RoundingMode -> v -> v
floatToReal :: v -> v
realIsInteger :: v -> v
realDiv :: v -> v -> v
realSin :: v -> v
realCos :: v -> v
realTan :: v -> v
realATan2 :: v -> v -> v
realSinh :: v -> v
realCosh :: v -> v
realTanh :: v -> v
realExp :: v -> v
realLog :: v -> v
smtFnApp :: v -> [v] -> v
smtFnUpdate :: Maybe (v -> [v] -> v -> v)
smtFnUpdate = forall a. Maybe a
Nothing
lambdaTerm :: Maybe ([(Text, Some TypeMap)] -> v -> v)
lambdaTerm = forall a. Maybe a
Nothing
fromText :: Text -> v
infixr 3 .&&
infixr 2 .||
infix 4 .==
infix 4 ./=
infix 4 .>
infix 4 .>=
infix 4 .<
infix 4 .<=
structComplexRealPart :: forall h. SMTWriter h => Term h -> Term h
structComplexRealPart :: forall h. SMTWriter h => Term h -> Term h
structComplexRealPart Term h
c = forall h (args :: Ctx BaseType) (tp :: BaseType).
SMTWriter h =>
Assignment TypeMap args -> Index args tp -> Term h -> Term h
structProj @h (forall {k} (ctx :: Ctx k) (f :: k -> Type).
(ctx ~ EmptyCtx) =>
Assignment f ctx
Ctx.Empty forall {k} (ctx' :: Ctx k) (f :: k -> Type) (ctx :: Ctx k)
(tp :: k).
(ctx' ~ (ctx ::> tp)) =>
Assignment f ctx -> f tp -> Assignment f ctx'
Ctx.:> TypeMap 'BaseRealType
RealTypeMap forall {k} (ctx' :: Ctx k) (f :: k -> Type) (ctx :: Ctx k)
(tp :: k).
(ctx' ~ (ctx ::> tp)) =>
Assignment f ctx -> f tp -> Assignment f ctx'
Ctx.:> TypeMap 'BaseRealType
RealTypeMap) (forall {k} (n :: Natural) (ctx :: Ctx k) (r :: k).
Idx n ctx r =>
Index ctx r
Ctx.natIndex @0) Term h
c
structComplexImagPart :: forall h. SMTWriter h => Term h -> Term h
structComplexImagPart :: forall h. SMTWriter h => Term h -> Term h
structComplexImagPart Term h
c = forall h (args :: Ctx BaseType) (tp :: BaseType).
SMTWriter h =>
Assignment TypeMap args -> Index args tp -> Term h -> Term h
structProj @h (forall {k} (ctx :: Ctx k) (f :: k -> Type).
(ctx ~ EmptyCtx) =>
Assignment f ctx
Ctx.Empty forall {k} (ctx' :: Ctx k) (f :: k -> Type) (ctx :: Ctx k)
(tp :: k).
(ctx' ~ (ctx ::> tp)) =>
Assignment f ctx -> f tp -> Assignment f ctx'
Ctx.:> TypeMap 'BaseRealType
RealTypeMap forall {k} (ctx' :: Ctx k) (f :: k -> Type) (ctx :: Ctx k)
(tp :: k).
(ctx' ~ (ctx ::> tp)) =>
Assignment f ctx -> f tp -> Assignment f ctx'
Ctx.:> TypeMap 'BaseRealType
RealTypeMap) (forall {k} (n :: Natural) (ctx :: Ctx k) (r :: k).
Idx n ctx r =>
Index ctx r
Ctx.natIndex @1) Term h
c
arrayComplexRealPart :: forall h . SMTWriter h => Term h -> Term h
arrayComplexRealPart :: forall h. SMTWriter h => Term h -> Term h
arrayComplexRealPart Term h
c = forall h. SMTWriter h => Term h -> [Term h] -> Term h
arraySelect @h Term h
c [forall v. SupportTermOps v => Bool -> v
boolExpr Bool
False]
arrayComplexImagPart :: forall h . SMTWriter h => Term h -> Term h
arrayComplexImagPart :: forall h. SMTWriter h => Term h -> Term h
arrayComplexImagPart Term h
c = forall h. SMTWriter h => Term h -> [Term h] -> Term h
arraySelect @h Term h
c [forall v. SupportTermOps v => Bool -> v
boolExpr Bool
True]
app :: Builder -> [Builder] -> Builder
app :: Builder -> [Builder] -> Builder
app Builder
o [] = Builder
o
app Builder
o [Builder]
args = Builder -> [Builder] -> Builder
app_list Builder
o [Builder]
args
app_list :: Builder -> [Builder] -> Builder
app_list :: Builder -> [Builder] -> Builder
app_list Builder
o [Builder]
args = Builder
"(" forall a. Semigroup a => a -> a -> a
<> Builder
o forall a. Semigroup a => a -> a -> a
<> forall {a}. (IsString a, Semigroup a) => [a] -> a
go [Builder]
args
where go :: [a] -> a
go [] = a
")"
go (a
f:[a]
r) = a
" " forall a. Semigroup a => a -> a -> a
<> a
f forall a. Semigroup a => a -> a -> a
<> [a] -> a
go [a]
r
builder_list :: [Builder] -> Builder
builder_list :: [Builder] -> Builder
builder_list [] = Builder
"()"
builder_list (Builder
h:[Builder]
l) = Builder -> [Builder] -> Builder
app_list Builder
h [Builder]
l
type family Term (h :: Type) :: Type
data SMTExpr h (tp :: BaseType) where
SMTName :: !(TypeMap tp) -> !Text -> SMTExpr h tp
SMTExpr :: !(TypeMap tp) -> !(Term h) -> SMTExpr h tp
asBase :: SupportTermOps (Term h)
=> SMTExpr h tp
-> Term h
asBase :: forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase (SMTName TypeMap tp
_ Text
n) = forall v. SupportTermOps v => Text -> v
fromText Text
n
asBase (SMTExpr TypeMap tp
_ Term h
e) = Term h
e
smtExprType :: SMTExpr h tp -> TypeMap tp
smtExprType :: forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType (SMTName TypeMap tp
tp Text
_) = TypeMap tp
tp
smtExprType (SMTExpr TypeMap tp
tp Term h
_) = TypeMap tp
tp
data WriterState = WriterState { WriterState -> Word64
_nextTermIdx :: !Word64
, WriterState -> Position
_lastPosition :: !Position
, WriterState -> Position
_position :: !Position
}
nextTermIdx :: Lens' WriterState Word64
nextTermIdx :: Lens' WriterState Word64
nextTermIdx = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens WriterState -> Word64
_nextTermIdx (\WriterState
s Word64
v -> WriterState
s { _nextTermIdx :: Word64
_nextTermIdx = Word64
v })
lastPosition :: Lens' WriterState Position
lastPosition :: Lens' WriterState Position
lastPosition = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens WriterState -> Position
_lastPosition (\WriterState
s Position
v -> WriterState
s { _lastPosition :: Position
_lastPosition = Position
v })
position :: Lens' WriterState Position
position :: Lens' WriterState Position
position = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens WriterState -> Position
_position (\WriterState
s Position
v -> WriterState
s { _position :: Position
_position = Position
v })
emptyState :: WriterState
emptyState :: WriterState
emptyState = WriterState { _nextTermIdx :: Word64
_nextTermIdx = Word64
0
, _lastPosition :: Position
_lastPosition = Position
InternalPos
, _position :: Position
_position = Position
InternalPos
}
freshVarName :: State WriterState Text
freshVarName :: State WriterState Text
freshVarName = Builder -> State WriterState Text
freshVarName' Builder
"x!"
freshVarName' :: Builder -> State WriterState Text
freshVarName' :: Builder -> State WriterState Text
freshVarName' Builder
prefix = do
Word64
n <- forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
use Lens' WriterState Word64
nextTermIdx
Lens' WriterState Word64
nextTermIdx forall s (m :: Type -> Type) a.
(MonadState s m, Num a) =>
ASetter' s a -> a -> m ()
+= Word64
1
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (Text -> Text
Lazy.toStrict forall a b. (a -> b) -> a -> b
$ Builder -> Text
Builder.toLazyText forall a b. (a -> b) -> a -> b
$ Builder
prefix forall a. Semigroup a => a -> a -> a
<> forall a. Integral a => a -> Builder
Builder.decimal Word64
n)
data SMTSymFn ctx where
SMTSymFn :: !Text
-> !(Ctx.Assignment TypeMap args)
-> !(TypeMap ret)
-> SMTSymFn (args Ctx.::> ret)
data StackEntry t (h :: Type) = StackEntry
{ forall t h. StackEntry t h -> IdxCache t (SMTExpr h)
symExprCache :: !(IdxCache t (SMTExpr h))
, forall t h.
StackEntry t h -> HashTable RealWorld (Nonce t) SMTSymFn
symFnCache :: !(PH.HashTable PH.RealWorld (Nonce t) SMTSymFn)
}
data WriterConn t (h :: Type) =
WriterConn { forall t h. WriterConn t h -> String
smtWriterName :: !String
, forall t h. WriterConn t h -> OutputStream Text
connHandle :: !(OutputStream Text)
, forall t h. WriterConn t h -> InputStream Text
connInputHandle :: !(InputStream Text)
, forall t h. WriterConn t h -> Bool
supportFunctionDefs :: !Bool
, forall t h. WriterConn t h -> Bool
supportFunctionArguments :: !Bool
, forall t h. WriterConn t h -> Bool
supportQuantifiers :: !Bool
, forall t h. WriterConn t h -> ResponseStrictness
strictParsing :: !ResponseStrictness
, forall t h. WriterConn t h -> ProblemFeatures
supportedFeatures :: !ProblemFeatures
, forall t h. WriterConn t h -> IORef [StackEntry t h]
entryStack :: !(IORef [StackEntry t h])
, forall t h. WriterConn t h -> IORef WriterState
stateRef :: !(IORef WriterState)
, forall t h. WriterConn t h -> SymbolVarBimap t
varBindings :: !(SymbolVarBimap t)
, forall t h. WriterConn t h -> h
connState :: !h
, forall t h. WriterConn t h -> AcknowledgementAction t h
consumeAcknowledgement :: AcknowledgementAction t h
}
newtype AcknowledgementAction t h =
AckAction { forall t h.
AcknowledgementAction t h -> WriterConn t h -> Command h -> IO ()
runAckAction :: WriterConn t h -> Command h -> IO () }
nullAcknowledgementAction :: AcknowledgementAction t h
nullAcknowledgementAction :: forall t h. AcknowledgementAction t h
nullAcknowledgementAction = forall t h.
(WriterConn t h -> Command h -> IO ()) -> AcknowledgementAction t h
AckAction (\WriterConn t h
_ Command h
_ -> forall (m :: Type -> Type) a. Monad m => a -> m a
return ())
newStackEntry :: IO (StackEntry t h)
newStackEntry :: forall t h. IO (StackEntry t h)
newStackEntry = do
IdxCache t (SMTExpr h)
exprCache <- forall (m :: Type -> Type) t (f :: BaseType -> Type).
MonadIO m =>
m (IdxCache t f)
newIdxCache
HashTable RealWorld (Nonce t) SMTSymFn
fnCache <- forall a. ST RealWorld a -> IO a
stToIO forall a b. (a -> b) -> a -> b
$ forall {k} s (key :: k -> Type) (val :: k -> Type).
ST s (HashTable s key val)
PH.new
forall (m :: Type -> Type) a. Monad m => a -> m a
return StackEntry
{ symExprCache :: IdxCache t (SMTExpr h)
symExprCache = IdxCache t (SMTExpr h)
exprCache
, symFnCache :: HashTable RealWorld (Nonce t) SMTSymFn
symFnCache = HashTable RealWorld (Nonce t) SMTSymFn
fnCache
}
resetEntryStack :: WriterConn t h -> IO ()
resetEntryStack :: forall t h. WriterConn t h -> IO ()
resetEntryStack WriterConn t h
c = do
StackEntry t h
entry <- forall t h. IO (StackEntry t h)
newStackEntry
forall a. IORef a -> a -> IO ()
writeIORef (forall t h. WriterConn t h -> IORef [StackEntry t h]
entryStack WriterConn t h
c) [StackEntry t h
entry]
popEntryStackToTop :: WriterConn t h -> IO Int
popEntryStackToTop :: forall t h. WriterConn t h -> IO Int
popEntryStackToTop WriterConn t h
c = do
[StackEntry t h]
stk <- forall a. IORef a -> IO a
readIORef (forall t h. WriterConn t h -> IORef [StackEntry t h]
entryStack WriterConn t h
c)
if forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [StackEntry t h]
stk then
do StackEntry t h
entry <- forall t h. IO (StackEntry t h)
newStackEntry
forall a. IORef a -> a -> IO ()
writeIORef (forall t h. WriterConn t h -> IORef [StackEntry t h]
entryStack WriterConn t h
c) [StackEntry t h
entry]
forall (m :: Type -> Type) a. Monad m => a -> m a
return Int
0
else
do forall a. IORef a -> a -> IO ()
writeIORef (forall t h. WriterConn t h -> IORef [StackEntry t h]
entryStack WriterConn t h
c) [forall a. [a] -> a
last [StackEntry t h]
stk]
forall (m :: Type -> Type) a. Monad m => a -> m a
return (forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [StackEntry t h]
stk)
entryStackHeight :: WriterConn t h -> IO Int
entryStackHeight :: forall t h. WriterConn t h -> IO Int
entryStackHeight WriterConn t h
c =
do [StackEntry t h]
es <- forall a. IORef a -> IO a
readIORef (forall t h. WriterConn t h -> IORef [StackEntry t h]
entryStack WriterConn t h
c)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [StackEntry t h]
es forall a. Num a => a -> a -> a
- Int
1)
pushEntryStack :: WriterConn t h -> IO ()
pushEntryStack :: forall t h. WriterConn t h -> IO ()
pushEntryStack WriterConn t h
c = do
StackEntry t h
entry <- forall t h. IO (StackEntry t h)
newStackEntry
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (forall t h. WriterConn t h -> IORef [StackEntry t h]
entryStack WriterConn t h
c) forall a b. (a -> b) -> a -> b
$ (StackEntry t h
entryforall a. a -> [a] -> [a]
:)
popEntryStack :: WriterConn t h -> IO ()
popEntryStack :: forall t h. WriterConn t h -> IO ()
popEntryStack WriterConn t h
c = do
[StackEntry t h]
stk <- forall a. IORef a -> IO a
readIORef (forall t h. WriterConn t h -> IORef [StackEntry t h]
entryStack WriterConn t h
c)
case [StackEntry t h]
stk of
[] -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Could not pop from empty entry stack."
[StackEntry t h
_] -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Could not pop from empty entry stack."
(StackEntry t h
_:[StackEntry t h]
r) -> forall a. IORef a -> a -> IO ()
writeIORef (forall t h. WriterConn t h -> IORef [StackEntry t h]
entryStack WriterConn t h
c) [StackEntry t h]
r
newWriterConn :: OutputStream Text
-> InputStream Text
-> AcknowledgementAction t cs
-> String
-> ResponseStrictness
-> ProblemFeatures
-> SymbolVarBimap t
-> cs
-> IO (WriterConn t cs)
newWriterConn :: forall t cs.
OutputStream Text
-> InputStream Text
-> AcknowledgementAction t cs
-> String
-> ResponseStrictness
-> ProblemFeatures
-> SymbolVarBimap t
-> cs
-> IO (WriterConn t cs)
newWriterConn OutputStream Text
h InputStream Text
in_h AcknowledgementAction t cs
ack String
solver_name ResponseStrictness
beStrict ProblemFeatures
features SymbolVarBimap t
bindings cs
cs = do
StackEntry t cs
entry <- forall t h. IO (StackEntry t h)
newStackEntry
IORef [StackEntry t cs]
stk_ref <- forall a. a -> IO (IORef a)
newIORef [StackEntry t cs
entry]
IORef WriterState
r <- forall a. a -> IO (IORef a)
newIORef WriterState
emptyState
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! WriterConn { smtWriterName :: String
smtWriterName = String
solver_name
, connHandle :: OutputStream Text
connHandle = OutputStream Text
h
, connInputHandle :: InputStream Text
connInputHandle = InputStream Text
in_h
, supportFunctionDefs :: Bool
supportFunctionDefs = Bool
False
, supportFunctionArguments :: Bool
supportFunctionArguments = Bool
False
, supportQuantifiers :: Bool
supportQuantifiers = Bool
False
, strictParsing :: ResponseStrictness
strictParsing = ResponseStrictness
beStrict
, supportedFeatures :: ProblemFeatures
supportedFeatures = ProblemFeatures
features
, entryStack :: IORef [StackEntry t cs]
entryStack = IORef [StackEntry t cs]
stk_ref
, stateRef :: IORef WriterState
stateRef = IORef WriterState
r
, varBindings :: SymbolVarBimap t
varBindings = SymbolVarBimap t
bindings
, connState :: cs
connState = cs
cs
, consumeAcknowledgement :: AcknowledgementAction t cs
consumeAcknowledgement = AcknowledgementAction t cs
ack
}
data ResponseStrictness
= Lenient
| Strict
deriving (ResponseStrictness -> ResponseStrictness -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ResponseStrictness -> ResponseStrictness -> Bool
$c/= :: ResponseStrictness -> ResponseStrictness -> Bool
== :: ResponseStrictness -> ResponseStrictness -> Bool
$c== :: ResponseStrictness -> ResponseStrictness -> Bool
Eq, Int -> ResponseStrictness -> String -> String
[ResponseStrictness] -> String -> String
ResponseStrictness -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ResponseStrictness] -> String -> String
$cshowList :: [ResponseStrictness] -> String -> String
show :: ResponseStrictness -> String
$cshow :: ResponseStrictness -> String
showsPrec :: Int -> ResponseStrictness -> String -> String
$cshowsPrec :: Int -> ResponseStrictness -> String -> String
Show)
parserStrictness :: Maybe (CFG.ConfigOption BaseBoolType)
-> CFG.ConfigOption BaseBoolType
-> CFG.Config
-> IO ResponseStrictness
parserStrictness :: Maybe (ConfigOption BaseBoolType)
-> ConfigOption BaseBoolType -> Config -> IO ResponseStrictness
parserStrictness Maybe (ConfigOption BaseBoolType)
overrideOpt ConfigOption BaseBoolType
strictOpt Config
cfg = do
Maybe Bool
ovr <- case Maybe (ConfigOption BaseBoolType)
overrideOpt of
Maybe (ConfigOption BaseBoolType)
Nothing -> forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just ConfigOption BaseBoolType
o -> forall (tp :: BaseType) a.
Opt tp a =>
OptionSetting tp -> IO (Maybe a)
CFG.getMaybeOpt forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (tp :: BaseType).
ConfigOption tp -> Config -> IO (OptionSetting tp)
CFG.getOptionSetting ConfigOption BaseBoolType
o Config
cfg
Maybe Bool
optval <- case Maybe Bool
ovr of
Just Bool
v -> forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Bool
v
Maybe Bool
Nothing -> forall (tp :: BaseType) a.
Opt tp a =>
OptionSetting tp -> IO (Maybe a)
CFG.getMaybeOpt forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (tp :: BaseType).
ConfigOption tp -> Config -> IO (OptionSetting tp)
CFG.getOptionSetting ConfigOption BaseBoolType
strictOpt Config
cfg
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe ResponseStrictness
Strict (\Bool
c -> if Bool
c then ResponseStrictness
Strict else ResponseStrictness
Lenient) Maybe Bool
optval
data TermLifetime
= DeleteNever
| DeleteOnPop
deriving (TermLifetime -> TermLifetime -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TermLifetime -> TermLifetime -> Bool
$c/= :: TermLifetime -> TermLifetime -> Bool
== :: TermLifetime -> TermLifetime -> Bool
$c== :: TermLifetime -> TermLifetime -> Bool
Eq)
cacheValue
:: WriterConn t h
-> TermLifetime
-> (StackEntry t h -> IO ())
-> IO ()
cacheValue :: forall t h.
WriterConn t h
-> TermLifetime -> (StackEntry t h -> IO ()) -> IO ()
cacheValue WriterConn t h
conn TermLifetime
lifetime StackEntry t h -> IO ()
insert_action =
forall a. IORef a -> IO a
readIORef (forall t h. WriterConn t h -> IORef [StackEntry t h]
entryStack WriterConn t h
conn) forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
s :: [StackEntry t h]
s@(StackEntry t h
h:[StackEntry t h]
_) -> case TermLifetime
lifetime of
TermLifetime
DeleteOnPop -> StackEntry t h -> IO ()
insert_action StackEntry t h
h
TermLifetime
DeleteNever -> forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ StackEntry t h -> IO ()
insert_action [StackEntry t h]
s
[] -> forall a. HasCallStack => String -> a
error String
"cacheValue: empty cache stack!"
cacheLookup
:: WriterConn t h
-> (StackEntry t h -> IO (Maybe a))
-> IO (Maybe a)
cacheLookup :: forall t h a.
WriterConn t h -> (StackEntry t h -> IO (Maybe a)) -> IO (Maybe a)
cacheLookup WriterConn t h
conn StackEntry t h -> IO (Maybe a)
lookup_action =
forall a. IORef a -> IO a
readIORef (forall t h. WriterConn t h -> IORef [StackEntry t h]
entryStack WriterConn t h
conn) forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: Type -> Type) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m (Maybe b)
firstJustM StackEntry t h -> IO (Maybe a)
lookup_action
firstJustM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b)
firstJustM :: forall (m :: Type -> Type) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m (Maybe b)
firstJustM a -> m (Maybe b)
_ [] = forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
firstJustM a -> m (Maybe b)
p (a
x:[a]
xs) = forall (m :: Type -> Type) b a.
Monad m =>
m b -> (a -> m b) -> m (Maybe a) -> m b
maybeM (forall (m :: Type -> Type) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m (Maybe b)
firstJustM a -> m (Maybe b)
p [a]
xs) (forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) (a -> m (Maybe b)
p a
x)
{-# INLINE firstJustM #-}
maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b
maybeM :: forall (m :: Type -> Type) b a.
Monad m =>
m b -> (a -> m b) -> m (Maybe a) -> m b
maybeM m b
n a -> m b
j m (Maybe a)
x = forall b a. b -> (a -> b) -> Maybe a -> b
maybe m b
n a -> m b
j forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Maybe a)
x
{-# INLINE maybeM #-}
whenM :: Monad m => m Bool -> m () -> m ()
whenM :: forall (m :: Type -> Type). Monad m => m Bool -> m () -> m ()
whenM m Bool
b m ()
t = do Bool
b' <- m Bool
b; forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when Bool
b' m ()
t
{-# INLINE whenM #-}
cacheLookupExpr :: WriterConn t h -> Nonce t tp -> IO (Maybe (SMTExpr h tp))
cacheLookupExpr :: forall t h (tp :: BaseType).
WriterConn t h -> Nonce t tp -> IO (Maybe (SMTExpr h tp))
cacheLookupExpr WriterConn t h
c Nonce t tp
n = forall t h a.
WriterConn t h -> (StackEntry t h -> IO (Maybe a)) -> IO (Maybe a)
cacheLookup WriterConn t h
c forall a b. (a -> b) -> a -> b
$ \StackEntry t h
entry ->
forall (m :: Type -> Type) t (f :: BaseType -> Type)
(tp :: BaseType).
MonadIO m =>
IdxCache t f -> Nonce t tp -> m (Maybe (f tp))
lookupIdx (forall t h. StackEntry t h -> IdxCache t (SMTExpr h)
symExprCache StackEntry t h
entry) Nonce t tp
n
cacheLookupFn :: WriterConn t h -> Nonce t ctx -> IO (Maybe (SMTSymFn ctx))
cacheLookupFn :: forall t h (ctx :: Ctx BaseType).
WriterConn t h -> Nonce t ctx -> IO (Maybe (SMTSymFn ctx))
cacheLookupFn WriterConn t h
c Nonce t ctx
n = forall t h a.
WriterConn t h -> (StackEntry t h -> IO (Maybe a)) -> IO (Maybe a)
cacheLookup WriterConn t h
c forall a b. (a -> b) -> a -> b
$ \StackEntry t h
entry ->
forall a. ST RealWorld a -> IO a
stToIO forall a b. (a -> b) -> a -> b
$ forall {k} (key :: k -> Type) s (val :: k -> Type) (tp :: k).
(HashableF key, TestEquality key) =>
HashTable s key val -> key tp -> ST s (Maybe (val tp))
PH.lookup (forall t h.
StackEntry t h -> HashTable RealWorld (Nonce t) SMTSymFn
symFnCache StackEntry t h
entry) Nonce t ctx
n
cacheValueExpr
:: WriterConn t h -> Nonce t tp -> TermLifetime -> SMTExpr h tp -> IO ()
cacheValueExpr :: forall t h (tp :: BaseType).
WriterConn t h
-> Nonce t tp -> TermLifetime -> SMTExpr h tp -> IO ()
cacheValueExpr WriterConn t h
conn Nonce t tp
n TermLifetime
lifetime SMTExpr h tp
value = forall t h.
WriterConn t h
-> TermLifetime -> (StackEntry t h -> IO ()) -> IO ()
cacheValue WriterConn t h
conn TermLifetime
lifetime forall a b. (a -> b) -> a -> b
$ \StackEntry t h
entry ->
forall (m :: Type -> Type) t (f :: BaseType -> Type)
(tp :: BaseType).
MonadIO m =>
IdxCache t f -> Nonce t tp -> f tp -> m ()
insertIdxValue (forall t h. StackEntry t h -> IdxCache t (SMTExpr h)
symExprCache StackEntry t h
entry) Nonce t tp
n SMTExpr h tp
value
cacheValueFn
:: WriterConn t h -> Nonce t ctx -> TermLifetime -> SMTSymFn ctx -> IO ()
cacheValueFn :: forall t h (ctx :: Ctx BaseType).
WriterConn t h
-> Nonce t ctx -> TermLifetime -> SMTSymFn ctx -> IO ()
cacheValueFn WriterConn t h
conn Nonce t ctx
n TermLifetime
lifetime SMTSymFn ctx
value = forall t h.
WriterConn t h
-> TermLifetime -> (StackEntry t h -> IO ()) -> IO ()
cacheValue WriterConn t h
conn TermLifetime
lifetime forall a b. (a -> b) -> a -> b
$ \StackEntry t h
entry ->
forall a. ST RealWorld a -> IO a
stToIO forall a b. (a -> b) -> a -> b
$ forall k (key :: k -> Type) s (val :: k -> Type) (tp :: k).
(HashableF key, TestEquality key) =>
HashTable s key val -> key tp -> val tp -> ST s ()
PH.insert (forall t h.
StackEntry t h -> HashTable RealWorld (Nonce t) SMTSymFn
symFnCache StackEntry t h
entry) Nonce t ctx
n SMTSymFn ctx
value
cacheLookupFnNameBimap :: WriterConn t h -> [SomeExprSymFn t] -> IO (Bimap (SomeExprSymFn t) Text)
cacheLookupFnNameBimap :: forall t h.
WriterConn t h
-> [SomeExprSymFn t] -> IO (Bimap (SomeExprSymFn t) Text)
cacheLookupFnNameBimap WriterConn t h
conn [SomeExprSymFn t]
fns = forall a b. (Ord a, Ord b) => [(a, b)] -> Bimap a b
Bimap.fromList forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
(\some_fn :: SomeExprSymFn t
some_fn@(SomeExprSymFn ExprSymFn t args ret
fn) -> do
Maybe (SMTSymFn (args ::> ret))
maybe_smt_sym_fn <- forall t h (ctx :: Ctx BaseType).
WriterConn t h -> Nonce t ctx -> IO (Maybe (SMTSymFn ctx))
cacheLookupFn WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> Nonce t (args ::> ret)
symFnId ExprSymFn t args ret
fn
case Maybe (SMTSymFn (args ::> ret))
maybe_smt_sym_fn of
Just (SMTSymFn Text
nm Assignment TypeMap args
_ TypeMap ret
_) -> forall (m :: Type -> Type) a. Monad m => a -> m a
return (SomeExprSymFn t
some_fn, Text
nm)
Maybe (SMTSymFn (args ::> ret))
Nothing -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Could not find function in cache: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ExprSymFn t args ret
fn)
[SomeExprSymFn t]
fns
withWriterState :: WriterConn t h -> State WriterState a -> IO a
withWriterState :: forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
c State WriterState a
m = do
WriterState
s0 <- forall a. IORef a -> IO a
readIORef (forall t h. WriterConn t h -> IORef WriterState
stateRef WriterConn t h
c)
let (a
v,WriterState
s) = forall s a. State s a -> s -> (a, s)
runState State WriterState a
m WriterState
s0
forall a. IORef a -> a -> IO ()
writeIORef (forall t h. WriterConn t h -> IORef WriterState
stateRef WriterConn t h
c) forall a b. (a -> b) -> a -> b
$! WriterState
s
forall (m :: Type -> Type) a. Monad m => a -> m a
return a
v
updateProgramLoc :: WriterConn t h -> ProgramLoc -> IO ()
updateProgramLoc :: forall t h. WriterConn t h -> ProgramLoc -> IO ()
updateProgramLoc WriterConn t h
c ProgramLoc
l = forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
c forall a b. (a -> b) -> a -> b
$ Lens' WriterState Position
position forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= ProgramLoc -> Position
plSourceLoc ProgramLoc
l
type family Command (h :: Type) :: Type
class (SupportTermOps (Term h)) => SMTWriter h where
forallExpr :: [(Text, Some TypeMap)] -> Term h -> Term h
existsExpr :: [(Text, Some TypeMap)] -> Term h -> Term h
arrayConstant :: Maybe (ArrayConstantFn (Term h))
arrayConstant = forall a. Maybe a
Nothing
arraySelect :: Term h -> [Term h] -> Term h
arrayUpdate :: Term h -> [Term h] -> Term h -> Term h
commentCommand :: f h -> Builder -> Command h
assertCommand :: f h -> Term h -> Command h
assertNamedCommand :: f h -> Term h -> Text -> Command h
pushCommand :: f h -> Command h
popCommand :: f h -> Command h
push2Command :: f h -> Command h
pop2Command :: f h -> Command h
popManyCommands :: f h -> Int -> [Command h]
popManyCommands f h
w Int
n = forall a. Int -> a -> [a]
replicate Int
n (forall h (f :: Type -> Type). SMTWriter h => f h -> Command h
popCommand f h
w)
resetCommand :: f h -> Command h
checkCommands :: f h -> [Command h]
checkWithAssumptionsCommands :: f h -> [Text] -> [Command h]
getUnsatAssumptionsCommand :: f h -> Command h
getUnsatCoreCommand :: f h -> Command h
getAbductCommand :: f h -> Text -> Term h -> Command h
getAbductNextCommand :: f h -> Command h
setOptCommand :: f h -> Text -> Text -> Command h
declareCommand :: f h
-> Text
-> Ctx.Assignment TypeMap args
-> TypeMap rtp
-> Command h
defineCommand :: f h
-> Text
-> [(Text, Some TypeMap)]
-> TypeMap rtp
-> Term h
-> Command h
synthFunCommand :: f h
-> Text
-> [(Text, Some TypeMap)]
-> TypeMap tp
-> Command h
declareVarCommand :: f h
-> Text
-> TypeMap tp
-> Command h
constraintCommand :: f h -> Term h -> Command h
declareStructDatatype :: WriterConn t h -> Ctx.Assignment TypeMap args -> IO ()
structCtor :: Ctx.Assignment TypeMap args -> [Term h] -> Term h
structProj :: Ctx.Assignment TypeMap args -> Ctx.Index args tp -> Term h -> Term h
stringTerm :: Text -> Term h
stringLength :: Term h -> Term h
stringIndexOf :: Term h -> Term h -> Term h -> Term h
stringContains :: Term h -> Term h -> Term h
stringIsPrefixOf :: Term h -> Term h -> Term h
stringIsSuffixOf :: Term h -> Term h -> Term h
stringSubstring :: Term h -> Term h -> Term h -> Term h
stringAppend :: [Term h] -> Term h
resetDeclaredStructs :: WriterConn t h -> IO ()
writeCommand :: WriterConn t h -> Command h -> IO ()
addCommand :: SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommand :: forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommand WriterConn t h
conn Command h
cmd = do
forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommandNoAck WriterConn t h
conn Command h
cmd
forall t h.
AcknowledgementAction t h -> WriterConn t h -> Command h -> IO ()
runAckAction (forall t h. WriterConn t h -> AcknowledgementAction t h
consumeAcknowledgement WriterConn t h
conn) WriterConn t h
conn Command h
cmd
addCommandNoAck :: SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommandNoAck :: forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommandNoAck WriterConn t h
conn Command h
cmd = do
Position
las <- forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
use Lens' WriterState Position
lastPosition
Position
cur <- forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
use Lens' WriterState Position
position
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Position
las forall a. Eq a => a -> a -> Bool
/= Position
cur) forall a b. (a -> b) -> a -> b
$ do
forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
writeCommand WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ forall h (f :: Type -> Type).
SMTWriter h =>
f h -> Builder -> Command h
commentCommand WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ Text -> Builder
Builder.fromText forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty Position
cur
forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ Lens' WriterState Position
lastPosition forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Position
cur
forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
writeCommand WriterConn t h
conn Command h
cmd
addCommands :: SMTWriter h => WriterConn t h -> [Command h] -> IO ()
addCommands :: forall h t. SMTWriter h => WriterConn t h -> [Command h] -> IO ()
addCommands WriterConn t h
_ [] = forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"internal: empty list in addCommands"
addCommands WriterConn t h
conn [Command h]
cmds = do
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommand WriterConn t h
conn) (forall a. [a] -> [a]
init [Command h]
cmds)
forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommandNoAck WriterConn t h
conn (forall a. [a] -> a
last [Command h]
cmds)
mkFreeVar :: SMTWriter h
=> WriterConn t h
-> Ctx.Assignment TypeMap args
-> TypeMap rtp
-> IO Text
mkFreeVar :: forall h t (args :: Ctx BaseType) (rtp :: BaseType).
SMTWriter h =>
WriterConn t h -> Assignment TypeMap args -> TypeMap rtp -> IO Text
mkFreeVar WriterConn t h
conn Assignment TypeMap args
arg_types TypeMap rtp
return_type = do
Text
var <- forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ State WriterState Text
freshVarName
forall {k} {l} (t :: (k -> Type) -> l -> Type) (m :: Type -> Type)
(f :: k -> Type) a.
(FoldableFC t, Applicative m) =>
(forall (x :: k). f x -> m a) -> forall (x :: l). t f x -> m ()
traverseFC_ (forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn) Assignment TypeMap args
arg_types
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn TypeMap rtp
return_type
forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommand WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ forall h (f :: Type -> Type) (args :: Ctx BaseType)
(rtp :: BaseType).
SMTWriter h =>
f h -> Text -> Assignment TypeMap args -> TypeMap rtp -> Command h
declareCommand WriterConn t h
conn Text
var Assignment TypeMap args
arg_types TypeMap rtp
return_type
forall (m :: Type -> Type) a. Monad m => a -> m a
return Text
var
mkFreeVar' :: SMTWriter h => WriterConn t h -> TypeMap tp -> IO (SMTExpr h tp)
mkFreeVar' :: forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO (SMTExpr h tp)
mkFreeVar' WriterConn t h
conn TypeMap tp
tp = forall (tp :: BaseType) h. TypeMap tp -> Text -> SMTExpr h tp
SMTName TypeMap tp
tp forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h t (args :: Ctx BaseType) (rtp :: BaseType).
SMTWriter h =>
WriterConn t h -> Assignment TypeMap args -> TypeMap rtp -> IO Text
mkFreeVar WriterConn t h
conn forall {k} (f :: k -> Type). Assignment f EmptyCtx
Ctx.empty TypeMap tp
tp
bindVarAsFree :: SMTWriter h
=> WriterConn t h
-> ExprBoundVar t tp
-> IO ()
bindVarAsFree :: forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> ExprBoundVar t tp -> IO ()
bindVarAsFree WriterConn t h
conn ExprBoundVar t tp
var = do
forall t h (tp :: BaseType).
WriterConn t h -> Nonce t tp -> IO (Maybe (SMTExpr h tp))
cacheLookupExpr WriterConn t h
conn (forall t (tp :: BaseType). ExprBoundVar t tp -> Nonce t tp
bvarId ExprBoundVar t tp
var) forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just SMTExpr h tp
_ -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Internal error in SMTLIB exporter: bound variables cannot be made free."
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall t (tp :: BaseType). ExprBoundVar t tp -> Nonce t tp
bvarId ExprBoundVar t tp
var) forall a. [a] -> [a] -> [a]
++ String
" defined at "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (ProgramLoc -> Position
plSourceLoc (forall t (tp :: BaseType). ExprBoundVar t tp -> ProgramLoc
bvarLoc ExprBoundVar t tp
var)) forall a. [a] -> [a] -> [a]
++ String
"."
Maybe (SMTExpr h tp)
Nothing -> do
TypeMap tp
smt_type <- forall h t a.
SMTWriter h =>
WriterConn t h -> SMTCollector t h a -> IO a
runOnLiveConnection WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ do
forall n (tp :: BaseType) h.
ExprBoundVar n tp -> SMTCollector n h ()
checkVarTypeSupport ExprBoundVar t tp
var
forall t (tp :: BaseType) h.
ExprBoundVar t tp -> SMTCollector t h (TypeMap tp)
getBaseSMT_Type ExprBoundVar t tp
var
Text
var_name <- forall t h. WriterConn t h -> SymbolBinding t -> IO Text
getSymbolName WriterConn t h
conn (forall t (tp :: BaseType). ExprBoundVar t tp -> SymbolBinding t
VarSymbolBinding ExprBoundVar t tp
var)
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn TypeMap tp
smt_type
forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommand WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ forall h (f :: Type -> Type) (args :: Ctx BaseType)
(rtp :: BaseType).
SMTWriter h =>
f h -> Text -> Assignment TypeMap args -> TypeMap rtp -> Command h
declareCommand WriterConn t h
conn Text
var_name forall {k} (f :: k -> Type). Assignment f EmptyCtx
Ctx.empty TypeMap tp
smt_type
forall t h (tp :: BaseType).
WriterConn t h
-> Nonce t tp -> TermLifetime -> SMTExpr h tp -> IO ()
cacheValueExpr WriterConn t h
conn (forall t (tp :: BaseType). ExprBoundVar t tp -> Nonce t tp
bvarId ExprBoundVar t tp
var) TermLifetime
DeleteOnPop forall a b. (a -> b) -> a -> b
$ forall (tp :: BaseType) h. TypeMap tp -> Text -> SMTExpr h tp
SMTName TypeMap tp
smt_type Text
var_name
assumeFormula :: SMTWriter h => WriterConn t h -> Term h -> IO ()
assumeFormula :: forall h t. SMTWriter h => WriterConn t h -> Term h -> IO ()
assumeFormula WriterConn t h
c Term h
p = forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommand WriterConn t h
c (forall h (f :: Type -> Type).
SMTWriter h =>
f h -> Term h -> Command h
assertCommand WriterConn t h
c Term h
p)
assumeFormulaWithName :: SMTWriter h => WriterConn t h -> Term h -> Text -> IO ()
assumeFormulaWithName :: forall h t.
SMTWriter h =>
WriterConn t h -> Term h -> Text -> IO ()
assumeFormulaWithName WriterConn t h
conn Term h
p Text
nm =
do forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (forall t h. WriterConn t h -> ProblemFeatures
supportedFeatures WriterConn t h
conn ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useUnsatCores) forall a b. (a -> b) -> a -> b
$
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty (forall t h. WriterConn t h -> String
smtWriterName WriterConn t h
conn) forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Any
"is not configured to produce UNSAT cores"
forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommand WriterConn t h
conn (forall h (f :: Type -> Type).
SMTWriter h =>
f h -> Term h -> Text -> Command h
assertNamedCommand WriterConn t h
conn Term h
p Text
nm)
assumeFormulaWithFreshName :: SMTWriter h => WriterConn t h -> Term h -> IO Text
assumeFormulaWithFreshName :: forall h t. SMTWriter h => WriterConn t h -> Term h -> IO Text
assumeFormulaWithFreshName WriterConn t h
conn Term h
p =
do Text
var <- forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ State WriterState Text
freshVarName
forall h t.
SMTWriter h =>
WriterConn t h -> Term h -> Text -> IO ()
assumeFormulaWithName WriterConn t h
conn Term h
p Text
var
forall (m :: Type -> Type) a. Monad m => a -> m a
return Text
var
addSynthFun ::
SMTWriter h =>
WriterConn t h ->
ExprSymFn t args ret ->
IO ()
addSynthFun :: forall h t (args :: Ctx BaseType) (ret :: BaseType).
SMTWriter h =>
WriterConn t h -> ExprSymFn t args ret -> IO ()
addSynthFun WriterConn t h
conn ExprSymFn t args ret
fn =
forall t h (ctx :: Ctx BaseType).
WriterConn t h -> Nonce t ctx -> IO (Maybe (SMTSymFn ctx))
cacheLookupFn WriterConn t h
conn (forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> Nonce t (args ::> ret)
symFnId ExprSymFn t args ret
fn) forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just{} ->
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Internal error in SMTLIB exporter: function already declared."
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> Nonce t (args ::> ret)
symFnId ExprSymFn t args ret
fn) forall a. [a] -> [a] -> [a]
++ String
" declared at "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (ProgramLoc -> Position
plSourceLoc (forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> ProgramLoc
symFnLoc ExprSymFn t args ret
fn)) forall a. [a] -> [a] -> [a]
++ String
"."
Maybe (SMTSymFn (args ::> ret))
Nothing -> case forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> SymFnInfo t args ret
symFnInfo ExprSymFn t args ret
fn of
UninterpFnInfo Assignment BaseTypeRepr args
arg_types BaseTypeRepr ret
ret_type -> do
Text
nm <- forall t h. WriterConn t h -> SymbolBinding t -> IO Text
getSymbolName WriterConn t h
conn (forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> SymbolBinding t
FnSymbolBinding ExprSymFn t args ret
fn)
let fn_source :: SMTSource Any
fn_source = forall ann. SolverSymbol -> ProgramLoc -> SMTSource ann
fnSource (forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> SolverSymbol
symFnName ExprSymFn t args ret
fn) (forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> ProgramLoc
symFnLoc ExprSymFn t args ret
fn)
Assignment TypeMap args
smt_arg_types <- forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
(g :: k -> Type) (m :: Type -> Type).
(TraversableFC t, Applicative m) =>
(forall (x :: k). f x -> m (g x))
-> forall (x :: l). t f x -> m (t g x)
traverseFC (forall (m :: Type -> Type) t h ann (tp :: BaseType).
MonadFail m =>
WriterConn t h
-> SMTSource ann -> BaseTypeRepr tp -> m (TypeMap tp)
evalFirstClassTypeRepr WriterConn t h
conn SMTSource Any
fn_source) Assignment BaseTypeRepr args
arg_types
forall t h (args :: Ctx BaseType).
WriterConn t h -> Assignment TypeMap args -> IO ()
checkArgumentTypes WriterConn t h
conn Assignment TypeMap args
smt_arg_types
TypeMap ret
smt_ret_type <- forall (m :: Type -> Type) t h ann (tp :: BaseType).
MonadFail m =>
WriterConn t h
-> SMTSource ann -> BaseTypeRepr tp -> m (TypeMap tp)
evalFirstClassTypeRepr WriterConn t h
conn SMTSource Any
fn_source BaseTypeRepr ret
ret_type
forall {k} {l} (t :: (k -> Type) -> l -> Type) (m :: Type -> Type)
(f :: k -> Type) a.
(FoldableFC t, Applicative m) =>
(forall (x :: k). f x -> m a) -> forall (x :: l). t f x -> m ()
traverseFC_ (forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn) Assignment TypeMap args
smt_arg_types
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn TypeMap ret
smt_ret_type
[(Text, Some TypeMap)]
smt_args <- forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
(\(Some TypeMap x
tp) -> do
Text
var <- forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ State WriterState Text
freshVarName
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text
var, forall k (f :: k -> Type) (x :: k). f x -> Some f
Some TypeMap x
tp))
(forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type) a.
FoldableFC t =>
(forall (x :: k). f x -> a) -> forall (x :: l). t f x -> [a]
toListFC forall k (f :: k -> Type) (x :: k). f x -> Some f
Some Assignment TypeMap args
smt_arg_types)
forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommand WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ forall h (f :: Type -> Type) (tp :: BaseType).
SMTWriter h =>
f h -> Text -> [(Text, Some TypeMap)] -> TypeMap tp -> Command h
synthFunCommand WriterConn t h
conn Text
nm [(Text, Some TypeMap)]
smt_args TypeMap ret
smt_ret_type
forall t h (ctx :: Ctx BaseType).
WriterConn t h
-> Nonce t ctx -> TermLifetime -> SMTSymFn ctx -> IO ()
cacheValueFn WriterConn t h
conn (forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> Nonce t (args ::> ret)
symFnId ExprSymFn t args ret
fn) TermLifetime
DeleteNever forall a b. (a -> b) -> a -> b
$! forall (idx :: Ctx BaseType) (idx :: BaseType).
Text
-> Assignment TypeMap idx -> TypeMap idx -> SMTSymFn (idx ::> idx)
SMTSymFn Text
nm Assignment TypeMap args
smt_arg_types TypeMap ret
smt_ret_type
DefinedFnInfo{} ->
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Internal error in SMTLIB exporter: defined functions cannot be synthesized."
MatlabSolverFnInfo{} ->
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Internal error in SMTLIB exporter: MatlabSolver functions cannot be synthesized."
addDeclareVar ::
SMTWriter h =>
WriterConn t h ->
ExprBoundVar t tp ->
IO ()
addDeclareVar :: forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> ExprBoundVar t tp -> IO ()
addDeclareVar WriterConn t h
conn ExprBoundVar t tp
var =
forall t h (tp :: BaseType).
WriterConn t h -> Nonce t tp -> IO (Maybe (SMTExpr h tp))
cacheLookupExpr WriterConn t h
conn (forall t (tp :: BaseType). ExprBoundVar t tp -> Nonce t tp
bvarId ExprBoundVar t tp
var) forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just{} ->
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Internal error in SMTLIB exporter: variable already declared."
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall t (tp :: BaseType). ExprBoundVar t tp -> Nonce t tp
bvarId ExprBoundVar t tp
var) forall a. [a] -> [a] -> [a]
++ String
" declared at "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (ProgramLoc -> Position
plSourceLoc (forall t (tp :: BaseType). ExprBoundVar t tp -> ProgramLoc
bvarLoc ExprBoundVar t tp
var)) forall a. [a] -> [a] -> [a]
++ String
"."
Maybe (SMTExpr h tp)
Nothing -> do
Text
nm <- forall t h. WriterConn t h -> SymbolBinding t -> IO Text
getSymbolName WriterConn t h
conn (forall t (tp :: BaseType). ExprBoundVar t tp -> SymbolBinding t
VarSymbolBinding ExprBoundVar t tp
var)
let fn_source :: SMTSource Any
fn_source = forall ann. SolverSymbol -> ProgramLoc -> SMTSource ann
fnSource (forall t (tp :: BaseType). ExprBoundVar t tp -> SolverSymbol
bvarName ExprBoundVar t tp
var) (forall t (tp :: BaseType). ExprBoundVar t tp -> ProgramLoc
bvarLoc ExprBoundVar t tp
var)
TypeMap tp
smt_type <- forall (m :: Type -> Type) t h ann (tp :: BaseType).
MonadFail m =>
WriterConn t h
-> SMTSource ann -> BaseTypeRepr tp -> m (TypeMap tp)
evalFirstClassTypeRepr WriterConn t h
conn SMTSource Any
fn_source forall a b. (a -> b) -> a -> b
$ forall t (tp :: BaseType). ExprBoundVar t tp -> BaseTypeRepr tp
bvarType ExprBoundVar t tp
var
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn TypeMap tp
smt_type
forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommand WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ forall h (f :: Type -> Type) (tp :: BaseType).
SMTWriter h =>
f h -> Text -> TypeMap tp -> Command h
declareVarCommand WriterConn t h
conn Text
nm TypeMap tp
smt_type
forall t h (tp :: BaseType).
WriterConn t h
-> Nonce t tp -> TermLifetime -> SMTExpr h tp -> IO ()
cacheValueExpr WriterConn t h
conn (forall t (tp :: BaseType). ExprBoundVar t tp -> Nonce t tp
bvarId ExprBoundVar t tp
var) TermLifetime
DeleteNever forall a b. (a -> b) -> a -> b
$! forall (tp :: BaseType) h. TypeMap tp -> Text -> SMTExpr h tp
SMTName TypeMap tp
smt_type Text
nm
addConstraint :: SMTWriter h => WriterConn t h -> BoolExpr t -> IO ()
addConstraint :: forall h t. SMTWriter h => WriterConn t h -> BoolExpr t -> IO ()
addConstraint WriterConn t h
conn BoolExpr t
p = do
Term h
f <- forall h t.
SMTWriter h =>
WriterConn t h -> BoolExpr t -> IO (Term h)
mkFormula WriterConn t h
conn BoolExpr t
p
forall t h. WriterConn t h -> ProgramLoc -> IO ()
updateProgramLoc WriterConn t h
conn (forall t (tp :: BaseType). Expr t tp -> ProgramLoc
exprLoc BoolExpr t
p)
forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommand WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ forall h (f :: Type -> Type).
SMTWriter h =>
f h -> Term h -> Command h
constraintCommand WriterConn t h
conn Term h
f
declareTypes ::
SMTWriter h =>
WriterConn t h ->
TypeMap tp ->
IO ()
declareTypes :: forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn = \case
TypeMap tp
BoolTypeMap -> forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
TypeMap tp
IntegerTypeMap -> forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
TypeMap tp
RealTypeMap -> forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
BVTypeMap NatRepr w
_ -> forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
FloatTypeMap FloatPrecisionRepr fpp
_ -> forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
TypeMap tp
UnicodeTypeMap -> forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
TypeMap tp
ComplexToStructTypeMap -> forall h t (args :: Ctx BaseType).
SMTWriter h =>
WriterConn t h -> Assignment TypeMap args -> IO ()
declareStructDatatype WriterConn t h
conn (forall {k} (ctx :: Ctx k) (f :: k -> Type).
(ctx ~ EmptyCtx) =>
Assignment f ctx
Ctx.Empty forall {k} (ctx' :: Ctx k) (f :: k -> Type) (ctx :: Ctx k)
(tp :: k).
(ctx' ~ (ctx ::> tp)) =>
Assignment f ctx -> f tp -> Assignment f ctx'
Ctx.:> TypeMap 'BaseRealType
RealTypeMap forall {k} (ctx' :: Ctx k) (f :: k -> Type) (ctx :: Ctx k)
(tp :: k).
(ctx' ~ (ctx ::> tp)) =>
Assignment f ctx -> f tp -> Assignment f ctx'
Ctx.:> TypeMap 'BaseRealType
RealTypeMap)
TypeMap tp
ComplexToArrayTypeMap -> forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
PrimArrayTypeMap Assignment TypeMap (idxl ::> idx)
args TypeMap tp
ret ->
do forall {k} {l} (t :: (k -> Type) -> l -> Type) (m :: Type -> Type)
(f :: k -> Type) a.
(FoldableFC t, Applicative m) =>
(forall (x :: k). f x -> m a) -> forall (x :: l). t f x -> m ()
traverseFC_ (forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn) Assignment TypeMap (idxl ::> idx)
args
forall h t (args :: Ctx BaseType).
SMTWriter h =>
WriterConn t h -> Assignment TypeMap args -> IO ()
declareStructDatatype WriterConn t h
conn Assignment TypeMap (idxl ::> idx)
args
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn TypeMap tp
ret
FnArrayTypeMap Assignment TypeMap (idxl ::> idx)
args TypeMap tp
ret ->
do forall {k} {l} (t :: (k -> Type) -> l -> Type) (m :: Type -> Type)
(f :: k -> Type) a.
(FoldableFC t, Applicative m) =>
(forall (x :: k). f x -> m a) -> forall (x :: l). t f x -> m ()
traverseFC_ (forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn) Assignment TypeMap (idxl ::> idx)
args
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn TypeMap tp
ret
StructTypeMap Assignment TypeMap idx
flds ->
do forall {k} {l} (t :: (k -> Type) -> l -> Type) (m :: Type -> Type)
(f :: k -> Type) a.
(FoldableFC t, Applicative m) =>
(forall (x :: k). f x -> m a) -> forall (x :: l). t f x -> m ()
traverseFC_ (forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn) Assignment TypeMap idx
flds
forall h t (args :: Ctx BaseType).
SMTWriter h =>
WriterConn t h -> Assignment TypeMap args -> IO ()
declareStructDatatype WriterConn t h
conn Assignment TypeMap idx
flds
data DefineStyle
= FunctionDefinition
| EqualityDefinition
deriving (DefineStyle -> DefineStyle -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DefineStyle -> DefineStyle -> Bool
$c/= :: DefineStyle -> DefineStyle -> Bool
== :: DefineStyle -> DefineStyle -> Bool
$c== :: DefineStyle -> DefineStyle -> Bool
Eq, Int -> DefineStyle -> String -> String
[DefineStyle] -> String -> String
DefineStyle -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [DefineStyle] -> String -> String
$cshowList :: [DefineStyle] -> String -> String
show :: DefineStyle -> String
$cshow :: DefineStyle -> String
showsPrec :: Int -> DefineStyle -> String -> String
$cshowsPrec :: Int -> DefineStyle -> String -> String
Show)
defineSMTVar :: SMTWriter h
=> WriterConn t h
-> DefineStyle
-> Text
-> [(Text, Some TypeMap)]
-> TypeMap rtp
-> Term h
-> IO ()
defineSMTVar :: forall h t (rtp :: BaseType).
SMTWriter h =>
WriterConn t h
-> DefineStyle
-> Text
-> [(Text, Some TypeMap)]
-> TypeMap rtp
-> Term h
-> IO ()
defineSMTVar WriterConn t h
conn DefineStyle
defSty Text
var [(Text, Some TypeMap)]
args TypeMap rtp
return_type Term h
expr
| forall t h. WriterConn t h -> Bool
supportFunctionDefs WriterConn t h
conn Bool -> Bool -> Bool
&& DefineStyle
defSty forall a. Eq a => a -> a -> Bool
== DefineStyle
FunctionDefinition = do
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall {k} (f :: k -> Type) r.
(forall (tp :: k). f tp -> r) -> Some f -> r
viewSome (forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Text, Some TypeMap)]
args
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn TypeMap rtp
return_type
forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommand WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ forall h (f :: Type -> Type) (rtp :: BaseType).
SMTWriter h =>
f h
-> Text
-> [(Text, Some TypeMap)]
-> TypeMap rtp
-> Term h
-> Command h
defineCommand WriterConn t h
conn Text
var [(Text, Some TypeMap)]
args TypeMap rtp
return_type Term h
expr
| Bool
otherwise = do
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [(Text, Some TypeMap)]
args)) forall a b. (a -> b) -> a -> b
$ do
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall t h. WriterConn t h -> String
smtWriterName WriterConn t h
conn forall a. [a] -> [a] -> [a]
++ String
" interface does not support defined functions."
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn TypeMap rtp
return_type
forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommand WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ forall h (f :: Type -> Type) (args :: Ctx BaseType)
(rtp :: BaseType).
SMTWriter h =>
f h -> Text -> Assignment TypeMap args -> TypeMap rtp -> Command h
declareCommand WriterConn t h
conn Text
var forall {k} (f :: k -> Type). Assignment f EmptyCtx
Ctx.empty TypeMap rtp
return_type
forall h t. SMTWriter h => WriterConn t h -> Term h -> IO ()
assumeFormula WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => Text -> v
fromText Text
var forall v. SupportTermOps v => v -> v -> v
.== Term h
expr
freshBoundVarName :: SMTWriter h
=> WriterConn t h
-> DefineStyle
-> [(Text, Some TypeMap)]
-> TypeMap rtp
-> Term h
-> IO Text
freshBoundVarName :: forall h t (rtp :: BaseType).
SMTWriter h =>
WriterConn t h
-> DefineStyle
-> [(Text, Some TypeMap)]
-> TypeMap rtp
-> Term h
-> IO Text
freshBoundVarName WriterConn t h
conn DefineStyle
defSty [(Text, Some TypeMap)]
args TypeMap rtp
return_type Term h
expr = do
Text
var <- forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ State WriterState Text
freshVarName
forall h t (rtp :: BaseType).
SMTWriter h =>
WriterConn t h
-> DefineStyle
-> Text
-> [(Text, Some TypeMap)]
-> TypeMap rtp
-> Term h
-> IO ()
defineSMTVar WriterConn t h
conn DefineStyle
defSty Text
var [(Text, Some TypeMap)]
args TypeMap rtp
return_type Term h
expr
forall (m :: Type -> Type) a. Monad m => a -> m a
return Text
var
data FreshVarFn h = FreshVarFn (forall tp . TypeMap tp -> IO (SMTExpr h tp))
data SMTCollectorState t h
= SMTCollectorState
{ forall t h. SMTCollectorState t h -> WriterConn t h
scConn :: !(WriterConn t h)
, forall t h.
SMTCollectorState t h
-> forall (rtp :: BaseType).
Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> Term h -> IO ()
freshBoundTermFn :: !(forall rtp . Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> Term h -> IO ())
, forall t h. SMTCollectorState t h -> Maybe (FreshVarFn h)
freshConstantFn :: !(Maybe (FreshVarFn h))
, forall t h. SMTCollectorState t h -> Maybe (Term h -> IO ())
recordSideCondFn :: !(Maybe (Term h -> IO ()))
}
type SMTCollector t h = ReaderT (SMTCollectorState t h) IO
freshConstant :: String
-> TypeMap tp
-> SMTCollector t h (SMTExpr h tp)
freshConstant :: forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
nm TypeMap tp
tpr = do
Maybe (FreshVarFn h)
mf <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> Maybe (FreshVarFn h)
freshConstantFn
case Maybe (FreshVarFn h)
mf of
Maybe (FreshVarFn h)
Nothing -> do
WriterConn t h
conn <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> WriterConn t h
scConn
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Position
loc <- forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
use Lens' WriterState Position
position
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Cannot create the free constant within a function needed to define the "
forall a. [a] -> [a] -> [a]
++ String
nm forall a. [a] -> [a] -> [a]
++ String
" term created at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Position
loc forall a. [a] -> [a] -> [a]
++ String
"."
Just (FreshVarFn forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp)
f) ->
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp)
f TypeMap tp
tpr
data BaseTypeError = ComplexTypeUnsupported
| ArrayUnsupported
| StringTypeUnsupported (Some StringInfoRepr)
typeMap :: WriterConn t h -> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
typeMap :: forall t h (tp :: BaseType).
WriterConn t h
-> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
typeMap WriterConn t h
conn BaseTypeRepr tp
tp0 = do
case forall t h (tp :: BaseType).
WriterConn t h
-> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
typeMapFirstClass WriterConn t h
conn BaseTypeRepr tp
tp0 of
Right TypeMap tp
tm -> forall a b. b -> Either a b
Right TypeMap tp
tm
Left BaseTypeError
ArrayUnsupported
| forall t h. WriterConn t h -> Bool
supportFunctionDefs WriterConn t h
conn
, BaseArrayRepr Assignment BaseTypeRepr (idx ::> tp)
idxTp BaseTypeRepr xs
eltTp <- BaseTypeRepr tp
tp0 ->
forall (idx :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
Assignment TypeMap (idx ::> idx)
-> TypeMap tp -> TypeMap (BaseArrayType (idx ::> idx) tp)
FnArrayTypeMap forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
(g :: k -> Type) (m :: Type -> Type).
(TraversableFC t, Applicative m) =>
(forall (x :: k). f x -> m (g x))
-> forall (x :: l). t f x -> m (t g x)
traverseFC (forall t h (tp :: BaseType).
WriterConn t h
-> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
typeMapFirstClass WriterConn t h
conn) Assignment BaseTypeRepr (idx ::> tp)
idxTp
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> forall t h (tp :: BaseType).
WriterConn t h
-> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
typeMapFirstClass WriterConn t h
conn BaseTypeRepr xs
eltTp
Left BaseTypeError
e -> forall a b. a -> Either a b
Left BaseTypeError
e
typeMapFirstClass :: WriterConn t h -> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
typeMapFirstClass :: forall t h (tp :: BaseType).
WriterConn t h
-> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
typeMapFirstClass WriterConn t h
conn BaseTypeRepr tp
tp0 = do
let feat :: ProblemFeatures
feat = forall t h. WriterConn t h -> ProblemFeatures
supportedFeatures WriterConn t h
conn
case BaseTypeRepr tp
tp0 of
BaseTypeRepr tp
BaseBoolRepr -> forall a b. b -> Either a b
Right TypeMap BaseBoolType
BoolTypeMap
BaseBVRepr NatRepr w
w -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$! forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w
BaseFloatRepr FloatPrecisionRepr fpp
fpp -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$! forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp
BaseTypeRepr tp
BaseRealRepr -> forall a b. b -> Either a b
Right TypeMap 'BaseRealType
RealTypeMap
BaseTypeRepr tp
BaseIntegerRepr -> forall a b. b -> Either a b
Right TypeMap 'BaseIntegerType
IntegerTypeMap
BaseStringRepr StringInfoRepr si
UnicodeRepr -> forall a b. b -> Either a b
Right TypeMap ('BaseStringType Unicode)
UnicodeTypeMap
BaseStringRepr StringInfoRepr si
si -> forall a b. a -> Either a b
Left (Some StringInfoRepr -> BaseTypeError
StringTypeUnsupported (forall k (f :: k -> Type) (x :: k). f x -> Some f
Some StringInfoRepr si
si))
BaseTypeRepr tp
BaseComplexRepr
| ProblemFeatures
feat ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useStructs -> forall a b. b -> Either a b
Right TypeMap 'BaseComplexType
ComplexToStructTypeMap
| ProblemFeatures
feat ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useSymbolicArrays -> forall a b. b -> Either a b
Right TypeMap 'BaseComplexType
ComplexToArrayTypeMap
| Bool
otherwise -> forall a b. a -> Either a b
Left BaseTypeError
ComplexTypeUnsupported
BaseArrayRepr Assignment BaseTypeRepr (idx ::> tp)
idxTp BaseTypeRepr xs
eltTp -> do
let mkArray :: Assignment TypeMap (idx ::> tp)
-> TypeMap xs -> TypeMap ('BaseArrayType (idx ::> tp) xs)
mkArray = if ProblemFeatures
feat ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useSymbolicArrays
then forall (idx :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
Assignment TypeMap (idx ::> idx)
-> TypeMap tp -> TypeMap (BaseArrayType (idx ::> idx) tp)
PrimArrayTypeMap
else forall (idx :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
Assignment TypeMap (idx ::> idx)
-> TypeMap tp -> TypeMap (BaseArrayType (idx ::> idx) tp)
FnArrayTypeMap
Assignment TypeMap (idx ::> tp)
-> TypeMap xs -> TypeMap ('BaseArrayType (idx ::> tp) xs)
mkArray forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
(g :: k -> Type) (m :: Type -> Type).
(TraversableFC t, Applicative m) =>
(forall (x :: k). f x -> m (g x))
-> forall (x :: l). t f x -> m (t g x)
traverseFC (forall t h (tp :: BaseType).
WriterConn t h
-> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
typeMapFirstClass WriterConn t h
conn) Assignment BaseTypeRepr (idx ::> tp)
idxTp
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> forall t h (tp :: BaseType).
WriterConn t h
-> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
typeMapFirstClass WriterConn t h
conn BaseTypeRepr xs
eltTp
BaseStructRepr Assignment BaseTypeRepr ctx
flds ->
forall (idx :: Ctx BaseType).
Assignment TypeMap idx -> TypeMap (BaseStructType idx)
StructTypeMap forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
(g :: k -> Type) (m :: Type -> Type).
(TraversableFC t, Applicative m) =>
(forall (x :: k). f x -> m (g x))
-> forall (x :: l). t f x -> m (t g x)
traverseFC (forall t h (tp :: BaseType).
WriterConn t h
-> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
typeMapFirstClass WriterConn t h
conn) Assignment BaseTypeRepr ctx
flds
getBaseSMT_Type :: ExprBoundVar t tp -> SMTCollector t h (TypeMap tp)
getBaseSMT_Type :: forall t (tp :: BaseType) h.
ExprBoundVar t tp -> SMTCollector t h (TypeMap tp)
getBaseSMT_Type ExprBoundVar t tp
v = do
WriterConn t h
conn <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> WriterConn t h
scConn
let errMsg :: String -> String
errMsg String
typename =
forall a. Show a => a -> String
show
forall a b. (a -> b) -> a -> b
$ forall a ann. Show a => a -> Doc ann
viaShow (forall t (tp :: BaseType). ExprBoundVar t tp -> SolverSymbol
bvarName ExprBoundVar t tp
v)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Any
"is a"
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty String
typename
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Any
"variable, and we do not support this with"
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall t h. WriterConn t h -> String
smtWriterName WriterConn t h
conn forall a. [a] -> [a] -> [a]
++ String
".")
case forall t h (tp :: BaseType).
WriterConn t h
-> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
typeMap WriterConn t h
conn (forall t (tp :: BaseType). ExprBoundVar t tp -> BaseTypeRepr tp
bvarType ExprBoundVar t tp
v) of
Left (StringTypeUnsupported (Some StringInfoRepr x
si)) -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String -> String
errMsg (String
"string " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show StringInfoRepr x
si)
Left BaseTypeError
ComplexTypeUnsupported -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String -> String
errMsg String
"complex"
Left BaseTypeError
ArrayUnsupported -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String -> String
errMsg String
"array"
Right TypeMap tp
smtType -> forall (m :: Type -> Type) a. Monad m => a -> m a
return TypeMap tp
smtType
freshBoundFn :: [(Text, Some TypeMap)]
-> TypeMap rtp
-> Term h
-> SMTCollector t h Text
freshBoundFn :: forall (rtp :: BaseType) h t.
[(Text, Some TypeMap)]
-> TypeMap rtp -> Term h -> SMTCollector t h Text
freshBoundFn [(Text, Some TypeMap)]
args TypeMap rtp
tp Term h
t = do
WriterConn t h
conn <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> WriterConn t h
scConn
Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> Term h -> IO ()
f <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall a b. (a -> b) -> a -> b
$ \SMTCollectorState t h
x -> forall t h.
SMTCollectorState t h
-> forall (rtp :: BaseType).
Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> Term h -> IO ()
freshBoundTermFn SMTCollectorState t h
x
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Text
var <- forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ State WriterState Text
freshVarName
Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> Term h -> IO ()
f Text
var [(Text, Some TypeMap)]
args TypeMap rtp
tp Term h
t
forall (m :: Type -> Type) a. Monad m => a -> m a
return Text
var
freshBoundTerm :: TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm :: forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap tp
tp Term h
t = forall (tp :: BaseType) h. TypeMap tp -> Text -> SMTExpr h tp
SMTName TypeMap tp
tp forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (rtp :: BaseType) h t.
[(Text, Some TypeMap)]
-> TypeMap rtp -> Term h -> SMTCollector t h Text
freshBoundFn [] TypeMap tp
tp Term h
t
freshBoundTerm' :: SupportTermOps (Term h) => SMTExpr h tp -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm' :: forall h (tp :: BaseType) t.
SupportTermOps (Term h) =>
SMTExpr h tp -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm' SMTExpr h tp
t = forall (tp :: BaseType) h. TypeMap tp -> Text -> SMTExpr h tp
SMTName TypeMap tp
tp forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (rtp :: BaseType) h t.
[(Text, Some TypeMap)]
-> TypeMap rtp -> Term h -> SMTCollector t h Text
freshBoundFn [] TypeMap tp
tp (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h tp
t)
where tp :: TypeMap tp
tp = forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h tp
t
addSideCondition ::
String ->
Term h ->
SMTCollector t h ()
addSideCondition :: forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
nm Term h
t = do
WriterConn t h
conn <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> WriterConn t h
scConn
Maybe (Term h -> IO ())
mf <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> Maybe (Term h -> IO ())
recordSideCondFn
Position
loc <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
use Lens' WriterState Position
position
case Maybe (Term h -> IO ())
mf of
Just Term h -> IO ()
f ->
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Term h -> IO ()
f Term h
t
Maybe (Term h -> IO ())
Nothing -> do
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Cannot add a side condition within a function needed to define the "
forall a. [a] -> [a] -> [a]
++ String
nm forall a. [a] -> [a] -> [a]
++ String
" term created at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Position
loc forall a. [a] -> [a] -> [a]
++ String
"."
addPartialSideCond ::
forall t h tp.
SMTWriter h =>
WriterConn t h ->
Term h ->
TypeMap tp ->
Maybe (AbstractValue tp) ->
SMTCollector t h ()
addPartialSideCond :: forall t h (tp :: BaseType).
SMTWriter h =>
WriterConn t h
-> Term h
-> TypeMap tp
-> Maybe (AbstractValue tp)
-> SMTCollector t h ()
addPartialSideCond WriterConn t h
_ Term h
_ TypeMap tp
_ Maybe (AbstractValue tp)
Nothing = forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
addPartialSideCond WriterConn t h
_ Term h
_ TypeMap tp
BoolTypeMap (Just Maybe Bool
AbstractValue tp
Nothing) = forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
addPartialSideCond WriterConn t h
_ Term h
t TypeMap tp
BoolTypeMap (Just (Just Bool
b)) =
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"bool_val" forall a b. (a -> b) -> a -> b
$ Term h
t forall v. SupportTermOps v => v -> v -> v
.== forall v. SupportTermOps v => Bool -> v
boolExpr Bool
b
addPartialSideCond WriterConn t h
_ Term h
t TypeMap tp
IntegerTypeMap (Just AbstractValue tp
rng) =
do case forall tp. ValueRange tp -> ValueBound tp
rangeLowBound AbstractValue tp
rng of
ValueBound Integer
Unbounded -> forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
Inclusive Integer
lo -> forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"int_range" forall a b. (a -> b) -> a -> b
$ Term h
t forall v. SupportTermOps v => v -> v -> v
.>= forall v. SupportTermOps v => Integer -> v
integerTerm Integer
lo
case forall tp. ValueRange tp -> ValueBound tp
rangeHiBound AbstractValue tp
rng of
ValueBound Integer
Unbounded -> forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
Inclusive Integer
hi -> forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"int_range" forall a b. (a -> b) -> a -> b
$ Term h
t forall v. SupportTermOps v => v -> v -> v
.<= forall v. SupportTermOps v => Integer -> v
integerTerm Integer
hi
addPartialSideCond WriterConn t h
_ Term h
t TypeMap tp
RealTypeMap (Just AbstractValue tp
rng) =
do case forall tp. ValueRange tp -> ValueBound tp
rangeLowBound (RealAbstractValue -> ValueRange Rational
ravRange AbstractValue tp
rng) of
ValueBound Rational
Unbounded -> forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
Inclusive Rational
lo -> forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"real_range" forall a b. (a -> b) -> a -> b
$ Term h
t forall v. SupportTermOps v => v -> v -> v
.>= forall v. SupportTermOps v => Rational -> v
rationalTerm Rational
lo
case forall tp. ValueRange tp -> ValueBound tp
rangeHiBound (RealAbstractValue -> ValueRange Rational
ravRange AbstractValue tp
rng) of
ValueBound Rational
Unbounded -> forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
Inclusive Rational
hi -> forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"real_range" forall a b. (a -> b) -> a -> b
$ Term h
t forall v. SupportTermOps v => v -> v -> v
.<= forall v. SupportTermOps v => Rational -> v
rationalTerm Rational
hi
addPartialSideCond WriterConn t h
_ Term h
t (BVTypeMap NatRepr w
w) (Just (BVD.BVDArith Domain w
rng)) = Maybe (Integer, Integer) -> SMTCollector t h ()
assertRange (forall (w :: Natural). Domain w -> Maybe (Integer, Integer)
BVD.arithDomainData Domain w
rng)
where
assertRange :: Maybe (Integer, Integer) -> SMTCollector t h ()
assertRange Maybe (Integer, Integer)
Nothing = forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
assertRange (Just (Integer
lo, Integer
sz)) =
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"bv_range" forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
bvULe (forall v. SupportTermOps v => v -> v -> v
bvSub Term h
t (forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (forall (w :: Natural). NatRepr w -> Integer -> BV w
BV.mkBV NatRepr w
w Integer
lo))) (forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (forall (w :: Natural). NatRepr w -> Integer -> BV w
BV.mkBV NatRepr w
w Integer
sz))
addPartialSideCond WriterConn t h
_ Term h
t (BVTypeMap NatRepr w
w) (Just (BVD.BVDBitwise Domain w
rng)) = (Integer, Integer) -> SMTCollector t h ()
assertBitRange (forall (w :: Natural). Domain w -> (Integer, Integer)
BVD.bitbounds Domain w
rng)
where
assertBitRange :: (Integer, Integer) -> SMTCollector t h ()
assertBitRange (Integer
lo, Integer
hi) = do
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Integer
lo forall a. Ord a => a -> a -> Bool
> Integer
0) forall a b. (a -> b) -> a -> b
$
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"bv_bitrange" forall a b. (a -> b) -> a -> b
$ (forall v. SupportTermOps v => v -> v -> v
bvOr (forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (forall (w :: Natural). NatRepr w -> Integer -> BV w
BV.mkBV NatRepr w
w Integer
lo)) Term h
t) forall v. SupportTermOps v => v -> v -> v
.== Term h
t
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Integer
hi forall a. Ord a => a -> a -> Bool
< forall (w :: Natural). NatRepr w -> Integer
maxUnsigned NatRepr w
w) forall a b. (a -> b) -> a -> b
$
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"bv_bitrange" forall a b. (a -> b) -> a -> b
$ (forall v. SupportTermOps v => v -> v -> v
bvOr Term h
t (forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (forall (w :: Natural). NatRepr w -> Integer -> BV w
BV.mkBV NatRepr w
w Integer
hi))) forall v. SupportTermOps v => v -> v -> v
.== (forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (forall (w :: Natural). NatRepr w -> Integer -> BV w
BV.mkBV NatRepr w
w Integer
hi))
addPartialSideCond WriterConn t h
_ Term h
t (TypeMap tp
UnicodeTypeMap) (Just (StringAbs ValueRange Integer
len)) =
do case forall tp. ValueRange tp -> ValueBound tp
rangeLowBound ValueRange Integer
len of
Inclusive Integer
lo ->
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"string length low range" forall a b. (a -> b) -> a -> b
$
forall v. SupportTermOps v => Integer -> v
integerTerm (forall a. Ord a => a -> a -> a
max Integer
0 Integer
lo) forall v. SupportTermOps v => v -> v -> v
.<= forall h. SMTWriter h => Term h -> Term h
stringLength @h Term h
t
ValueBound Integer
Unbounded ->
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"string length low range" forall a b. (a -> b) -> a -> b
$
forall v. SupportTermOps v => Integer -> v
integerTerm Integer
0 forall v. SupportTermOps v => v -> v -> v
.<= forall h. SMTWriter h => Term h -> Term h
stringLength @h Term h
t
case forall tp. ValueRange tp -> ValueBound tp
rangeHiBound ValueRange Integer
len of
ValueBound Integer
Unbounded -> forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
Inclusive Integer
hi ->
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"string length high range" forall a b. (a -> b) -> a -> b
$
forall h. SMTWriter h => Term h -> Term h
stringLength @h Term h
t forall v. SupportTermOps v => v -> v -> v
.<= forall v. SupportTermOps v => Integer -> v
integerTerm Integer
hi
addPartialSideCond WriterConn t h
_ Term h
_ (FloatTypeMap FloatPrecisionRepr fpp
_) (Just ()) = forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
addPartialSideCond WriterConn t h
conn Term h
t TypeMap tp
ComplexToStructTypeMap (Just (RealAbstractValue
realRng :+ RealAbstractValue
imagRng)) =
do let r :: Term h
r = forall h. SMTWriter h => Term h -> Term h
arrayComplexRealPart @h Term h
t
let i :: Term h
i = forall h. SMTWriter h => Term h -> Term h
arrayComplexImagPart @h Term h
t
forall t h (tp :: BaseType).
SMTWriter h =>
WriterConn t h
-> Term h
-> TypeMap tp
-> Maybe (AbstractValue tp)
-> SMTCollector t h ()
addPartialSideCond WriterConn t h
conn Term h
r TypeMap 'BaseRealType
RealTypeMap (forall a. a -> Maybe a
Just RealAbstractValue
realRng)
forall t h (tp :: BaseType).
SMTWriter h =>
WriterConn t h
-> Term h
-> TypeMap tp
-> Maybe (AbstractValue tp)
-> SMTCollector t h ()
addPartialSideCond WriterConn t h
conn Term h
i TypeMap 'BaseRealType
RealTypeMap (forall a. a -> Maybe a
Just RealAbstractValue
imagRng)
addPartialSideCond WriterConn t h
conn Term h
t TypeMap tp
ComplexToArrayTypeMap (Just (RealAbstractValue
realRng :+ RealAbstractValue
imagRng)) =
do let r :: Term h
r = forall h. SMTWriter h => Term h -> Term h
arrayComplexRealPart @h Term h
t
let i :: Term h
i = forall h. SMTWriter h => Term h -> Term h
arrayComplexImagPart @h Term h
t
forall t h (tp :: BaseType).
SMTWriter h =>
WriterConn t h
-> Term h
-> TypeMap tp
-> Maybe (AbstractValue tp)
-> SMTCollector t h ()
addPartialSideCond WriterConn t h
conn Term h
r TypeMap 'BaseRealType
RealTypeMap (forall a. a -> Maybe a
Just RealAbstractValue
realRng)
forall t h (tp :: BaseType).
SMTWriter h =>
WriterConn t h
-> Term h
-> TypeMap tp
-> Maybe (AbstractValue tp)
-> SMTCollector t h ()
addPartialSideCond WriterConn t h
conn Term h
i TypeMap 'BaseRealType
RealTypeMap (forall a. a -> Maybe a
Just RealAbstractValue
imagRng)
addPartialSideCond WriterConn t h
conn Term h
t (StructTypeMap Assignment TypeMap idx
ctx) (Just AbstractValue tp
abvs) =
forall {k} (ctx :: Ctx k) r.
Size ctx -> (forall (tp :: k). r -> Index ctx tp -> r) -> r -> r
Ctx.forIndex (forall {k} (f :: k -> Type) (ctx :: Ctx k).
Assignment f ctx -> Size ctx
Ctx.size Assignment TypeMap idx
ctx)
(\SMTCollector t h ()
start Index idx tp
i ->
do SMTCollector t h ()
start
forall t h (tp :: BaseType).
SMTWriter h =>
WriterConn t h
-> Term h
-> TypeMap tp
-> Maybe (AbstractValue tp)
-> SMTCollector t h ()
addPartialSideCond WriterConn t h
conn
(forall h (args :: Ctx BaseType) (tp :: BaseType).
SMTWriter h =>
Assignment TypeMap args -> Index args tp -> Term h -> Term h
structProj @h Assignment TypeMap idx
ctx Index idx tp
i Term h
t)
(Assignment TypeMap idx
ctx forall {k} (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
Assignment f ctx -> Index ctx tp -> f tp
Ctx.! Index idx tp
i)
(forall a. a -> Maybe a
Just (forall (tp :: BaseType).
AbstractValueWrapper tp -> AbstractValue tp
unwrapAV (AbstractValue tp
abvs forall {k} (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
Assignment f ctx -> Index ctx tp -> f tp
Ctx.! Index idx tp
i))))
(forall (m :: Type -> Type) a. Monad m => a -> m a
return ())
addPartialSideCond WriterConn t h
_ Term h
_t (PrimArrayTypeMap Assignment TypeMap (idxl ::> idx)
_idxTp TypeMap tp
_resTp) (Just AbstractValue tp
_abv) =
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"SMTWriter.addPartialSideCond: bounds on array values not supported"
addPartialSideCond WriterConn t h
_ Term h
_t (FnArrayTypeMap Assignment TypeMap (idxl ::> idx)
_idxTp TypeMap tp
_resTp) (Just AbstractValue tp
_abv) =
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"SMTWriter.addPartialSideCond: bounds on array values not supported"
runOnLiveConnection :: SMTWriter h => WriterConn t h -> SMTCollector t h a -> IO a
runOnLiveConnection :: forall h t a.
SMTWriter h =>
WriterConn t h -> SMTCollector t h a -> IO a
runOnLiveConnection WriterConn t h
conn SMTCollector t h a
coll = forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT SMTCollector t h a
coll SMTCollectorState t h
s
where s :: SMTCollectorState t h
s = SMTCollectorState
{ scConn :: WriterConn t h
scConn = WriterConn t h
conn
, freshBoundTermFn :: forall (rtp :: BaseType).
Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> Term h -> IO ()
freshBoundTermFn = forall h t (rtp :: BaseType).
SMTWriter h =>
WriterConn t h
-> DefineStyle
-> Text
-> [(Text, Some TypeMap)]
-> TypeMap rtp
-> Term h
-> IO ()
defineSMTVar WriterConn t h
conn DefineStyle
FunctionDefinition
, freshConstantFn :: Maybe (FreshVarFn h)
freshConstantFn = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! forall h.
(forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp))
-> FreshVarFn h
FreshVarFn (forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO (SMTExpr h tp)
mkFreeVar' WriterConn t h
conn)
, recordSideCondFn :: Maybe (Term h -> IO ())
recordSideCondFn = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! forall h t. SMTWriter h => WriterConn t h -> Term h -> IO ()
assumeFormula WriterConn t h
conn
}
prependToRefList :: IORef [a] -> a -> IO ()
prependToRefList :: forall a. IORef [a] -> a -> IO ()
prependToRefList IORef [a]
r a
a = seq :: forall a b. a -> b -> b
seq a
a forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [a]
r (a
aforall a. a -> [a] -> [a]
:)
freshSandboxBoundTerm :: SupportTermOps v
=> IORef [(Text, v)]
-> Text
-> [(Text, Some TypeMap)]
-> TypeMap rtp
-> v
-> IO ()
freshSandboxBoundTerm :: forall v (rtp :: BaseType).
SupportTermOps v =>
IORef [(Text, v)]
-> Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> v -> IO ()
freshSandboxBoundTerm IORef [(Text, v)]
ref Text
var [] TypeMap rtp
_ v
t = do
forall a. IORef [a] -> a -> IO ()
prependToRefList IORef [(Text, v)]
ref (Text
var,v
t)
freshSandboxBoundTerm IORef [(Text, v)]
ref Text
var [(Text, Some TypeMap)]
args TypeMap rtp
_ v
t = do
case forall v.
SupportTermOps v =>
Maybe ([(Text, Some TypeMap)] -> v -> v)
lambdaTerm of
Maybe ([(Text, Some TypeMap)] -> v -> v)
Nothing -> do
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Cannot create terms with arguments inside defined functions."
Just [(Text, Some TypeMap)] -> v -> v
lambdaFn -> do
let r :: v
r = [(Text, Some TypeMap)] -> v -> v
lambdaFn [(Text, Some TypeMap)]
args v
t
seq :: forall a b. a -> b -> b
seq v
r forall a b. (a -> b) -> a -> b
$ forall a. IORef [a] -> a -> IO ()
prependToRefList IORef [(Text, v)]
ref (Text
var, v
r)
freshSandboxConstant :: WriterConn t h
-> IORef [(Text, Some TypeMap)]
-> TypeMap tp
-> IO (SMTExpr h tp)
freshSandboxConstant :: forall t h (tp :: BaseType).
WriterConn t h
-> IORef [(Text, Some TypeMap)] -> TypeMap tp -> IO (SMTExpr h tp)
freshSandboxConstant WriterConn t h
conn IORef [(Text, Some TypeMap)]
ref TypeMap tp
tp = do
Text
var <- forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ State WriterState Text
freshVarName
forall a. IORef [a] -> a -> IO ()
prependToRefList IORef [(Text, Some TypeMap)]
ref (Text
var, forall k (f :: k -> Type) (x :: k). f x -> Some f
Some TypeMap tp
tp)
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall (tp :: BaseType) h. TypeMap tp -> Text -> SMTExpr h tp
SMTName TypeMap tp
tp Text
var
data CollectorResults h a =
CollectorResults { forall h a. CollectorResults h a -> a
crResult :: !a
, forall h a. CollectorResults h a -> [(Text, Term h)]
crBindings :: !([(Text, Term h)])
, forall h a. CollectorResults h a -> [(Text, Some TypeMap)]
crFreeConstants :: !([(Text, Some TypeMap)])
, forall h a. CollectorResults h a -> [Term h]
crSideConds :: !([Term h])
}
forallResult :: forall h
. SMTWriter h
=> CollectorResults h (Term h)
-> Term h
forallResult :: forall h. SMTWriter h => CollectorResults h (Term h) -> Term h
forallResult CollectorResults h (Term h)
cr =
forall h. SMTWriter h => [(Text, Some TypeMap)] -> Term h -> Term h
forallExpr @h (forall h a. CollectorResults h a -> [(Text, Some TypeMap)]
crFreeConstants CollectorResults h (Term h)
cr) forall a b. (a -> b) -> a -> b
$
forall v. SupportTermOps v => [(Text, v)] -> v -> v
letExpr (forall h a. CollectorResults h a -> [(Text, Term h)]
crBindings CollectorResults h (Term h)
cr) forall a b. (a -> b) -> a -> b
$
forall v. SupportTermOps v => [v] -> v -> v
impliesAllExpr (forall h a. CollectorResults h a -> [Term h]
crSideConds CollectorResults h (Term h)
cr) (forall h a. CollectorResults h a -> a
crResult CollectorResults h (Term h)
cr)
impliesAllExpr :: SupportTermOps v => [v] -> v -> v
impliesAllExpr :: forall v. SupportTermOps v => [v] -> v -> v
impliesAllExpr [v]
l v
r = forall v. SupportTermOps v => [v] -> v
orAll ((forall v. SupportTermOps v => v -> v
notExpr forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [v]
l) forall a. [a] -> [a] -> [a]
++ [v
r])
existsResult :: forall h
. SMTWriter h
=> CollectorResults h (Term h)
-> Term h
existsResult :: forall h. SMTWriter h => CollectorResults h (Term h) -> Term h
existsResult CollectorResults h (Term h)
cr =
forall h. SMTWriter h => [(Text, Some TypeMap)] -> Term h -> Term h
existsExpr @h (forall h a. CollectorResults h a -> [(Text, Some TypeMap)]
crFreeConstants CollectorResults h (Term h)
cr) forall a b. (a -> b) -> a -> b
$
forall v. SupportTermOps v => [(Text, v)] -> v -> v
letExpr (forall h a. CollectorResults h a -> [(Text, Term h)]
crBindings CollectorResults h (Term h)
cr) forall a b. (a -> b) -> a -> b
$
forall v. SupportTermOps v => [v] -> v
andAll (forall h a. CollectorResults h a -> [Term h]
crSideConds CollectorResults h (Term h)
cr forall a. [a] -> [a] -> [a]
++ [forall h a. CollectorResults h a -> a
crResult CollectorResults h (Term h)
cr])
runInSandbox :: SupportTermOps (Term h)
=> WriterConn t h
-> SMTCollector t h a
-> IO (CollectorResults h a)
runInSandbox :: forall h t a.
SupportTermOps (Term h) =>
WriterConn t h -> SMTCollector t h a -> IO (CollectorResults h a)
runInSandbox WriterConn t h
conn SMTCollector t h a
sc = do
IORef [(Text, Term h)]
boundTermRef <- forall a. a -> IO (IORef a)
newIORef []
IORef [(Text, Some TypeMap)]
freeConstantRef <- (forall a. a -> IO (IORef a)
newIORef [] :: IO (IORef [(Text, Some TypeMap)]))
IORef [Term h]
sideCondRef <- forall a. a -> IO (IORef a)
newIORef []
let s :: SMTCollectorState t h
s = SMTCollectorState
{ scConn :: WriterConn t h
scConn = WriterConn t h
conn
, freshBoundTermFn :: forall (rtp :: BaseType).
Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> Term h -> IO ()
freshBoundTermFn = forall v (rtp :: BaseType).
SupportTermOps v =>
IORef [(Text, v)]
-> Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> v -> IO ()
freshSandboxBoundTerm IORef [(Text, Term h)]
boundTermRef
, freshConstantFn :: Maybe (FreshVarFn h)
freshConstantFn = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! forall h.
(forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp))
-> FreshVarFn h
FreshVarFn (forall t h (tp :: BaseType).
WriterConn t h
-> IORef [(Text, Some TypeMap)] -> TypeMap tp -> IO (SMTExpr h tp)
freshSandboxConstant WriterConn t h
conn IORef [(Text, Some TypeMap)]
freeConstantRef)
, recordSideCondFn :: Maybe (Term h -> IO ())
recordSideCondFn = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! forall a. IORef [a] -> a -> IO ()
prependToRefList IORef [Term h]
sideCondRef
}
a
r <- forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT SMTCollector t h a
sc SMTCollectorState t h
s
[(Text, Term h)]
boundTerms <- forall a. IORef a -> IO a
readIORef IORef [(Text, Term h)]
boundTermRef
[(Text, Some TypeMap)]
freeConstants <- forall a. IORef a -> IO a
readIORef IORef [(Text, Some TypeMap)]
freeConstantRef
[Term h]
sideConds <- forall a. IORef a -> IO a
readIORef IORef [Term h]
sideCondRef
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! CollectorResults { crResult :: a
crResult = a
r
, crBindings :: [(Text, Term h)]
crBindings = forall a. [a] -> [a]
reverse [(Text, Term h)]
boundTerms
, crFreeConstants :: [(Text, Some TypeMap)]
crFreeConstants = forall a. [a] -> [a]
reverse [(Text, Some TypeMap)]
freeConstants
, crSideConds :: [Term h]
crSideConds = forall a. [a] -> [a]
reverse [Term h]
sideConds
}
cacheWriterResult :: Nonce t tp
-> TermLifetime
-> SMTCollector t h (SMTExpr h tp)
-> SMTCollector t h (SMTExpr h tp)
cacheWriterResult :: forall t (tp :: BaseType) h.
Nonce t tp
-> TermLifetime
-> SMTCollector t h (SMTExpr h tp)
-> SMTCollector t h (SMTExpr h tp)
cacheWriterResult Nonce t tp
n TermLifetime
lifetime SMTCollector t h (SMTExpr h tp)
fallback = do
WriterConn t h
c <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> WriterConn t h
scConn
(forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall t h (tp :: BaseType).
WriterConn t h -> Nonce t tp -> IO (Maybe (SMTExpr h tp))
cacheLookupExpr WriterConn t h
c Nonce t tp
n) forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just SMTExpr h tp
x -> forall (m :: Type -> Type) a. Monad m => a -> m a
return SMTExpr h tp
x
Maybe (SMTExpr h tp)
Nothing -> do
SMTExpr h tp
x <- SMTCollector t h (SMTExpr h tp)
fallback
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall t h (tp :: BaseType).
WriterConn t h
-> Nonce t tp -> TermLifetime -> SMTExpr h tp -> IO ()
cacheValueExpr WriterConn t h
c Nonce t tp
n TermLifetime
lifetime SMTExpr h tp
x
forall (m :: Type -> Type) a. Monad m => a -> m a
return SMTExpr h tp
x
bindVar :: ExprBoundVar t tp
-> SMTExpr h tp
-> SMTCollector t h ()
bindVar :: forall t (tp :: BaseType) h.
ExprBoundVar t tp -> SMTExpr h tp -> SMTCollector t h ()
bindVar ExprBoundVar t tp
v SMTExpr h tp
x = do
let n :: Nonce t tp
n = forall t (tp :: BaseType). ExprBoundVar t tp -> Nonce t tp
bvarId ExprBoundVar t tp
v
WriterConn t h
c <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> WriterConn t h
scConn
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
forall (m :: Type -> Type). Monad m => m Bool -> m () -> m ()
whenM (forall a. Maybe a -> Bool
isJust forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t h (tp :: BaseType).
WriterConn t h -> Nonce t tp -> IO (Maybe (SMTExpr h tp))
cacheLookupExpr WriterConn t h
c Nonce t tp
n) forall a b. (a -> b) -> a -> b
$ forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Variable is already bound."
forall t h (tp :: BaseType).
WriterConn t h
-> Nonce t tp -> TermLifetime -> SMTExpr h tp -> IO ()
cacheValueExpr WriterConn t h
c Nonce t tp
n TermLifetime
DeleteOnPop SMTExpr h tp
x
bvIntTerm :: forall v w
. (SupportTermOps v, 1 <= w)
=> NatRepr w
-> v
-> v
bvIntTerm :: forall v (w :: Natural).
(SupportTermOps v, 1 <= w) =>
NatRepr w -> v -> v
bvIntTerm NatRepr w
w v
x = forall v. SupportTermOps v => [v] -> v
sumExpr ((\Natural
i -> Natural -> v
digit (Natural
iforall a. Num a => a -> a -> a
-Natural
1)) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Natural
1..forall (n :: Natural). NatRepr n -> Natural
natValue NatRepr w
w])
where digit :: Natural -> v
digit :: Natural -> v
digit Natural
d = forall v. SupportTermOps v => v -> v -> v -> v
ite (forall v (w :: Natural).
SupportTermOps v =>
NatRepr w -> Natural -> v -> v
bvTestBit NatRepr w
w Natural
d v
x)
(forall a. Num a => Integer -> a
fromInteger (Integer
2forall a b. (Num a, Integral b) => a -> b -> a
^Natural
d))
v
0
sbvIntTerm :: SupportTermOps v
=> NatRepr w
-> v
-> v
sbvIntTerm :: forall v (w :: Natural). SupportTermOps v => NatRepr w -> v -> v
sbvIntTerm NatRepr w
w0 v
x0 = forall v. SupportTermOps v => [v] -> v
sumExpr (v
signed_offset forall a. a -> [a] -> [a]
: forall v (w :: Natural).
SupportTermOps v =>
NatRepr w -> v -> Natural -> [v]
go NatRepr w
w0 v
x0 (forall (n :: Natural). NatRepr n -> Natural
natValue NatRepr w
w0 forall a. Num a => a -> a -> a
- Natural
2))
where signed_offset :: v
signed_offset = forall v. SupportTermOps v => v -> v -> v -> v
ite (forall v (w :: Natural).
SupportTermOps v =>
NatRepr w -> Natural -> v -> v
bvTestBit NatRepr w
w0 (forall (n :: Natural). NatRepr n -> Natural
natValue NatRepr w
w0 forall a. Num a => a -> a -> a
- Natural
1) v
x0)
(forall a. Num a => Integer -> a
fromInteger (forall a. Num a => a -> a
negate (Integer
2forall a b. (Num a, Integral b) => a -> b -> a
^(forall (n :: Natural). NatRepr n -> Int
widthVal NatRepr w
w0 forall a. Num a => a -> a -> a
- Int
1))))
v
0
go :: SupportTermOps v => NatRepr w -> v -> Natural -> [v]
go :: forall v (w :: Natural).
SupportTermOps v =>
NatRepr w -> v -> Natural -> [v]
go NatRepr w
w v
x Natural
n
| Natural
n forall a. Ord a => a -> a -> Bool
> Natural
0 = forall v (w :: Natural).
SupportTermOps v =>
NatRepr w -> v -> Natural -> v
digit NatRepr w
w v
x Natural
n forall a. a -> [a] -> [a]
: forall v (w :: Natural).
SupportTermOps v =>
NatRepr w -> v -> Natural -> [v]
go NatRepr w
w v
x (Natural
nforall a. Num a => a -> a -> a
-Natural
1)
| Natural
n forall a. Eq a => a -> a -> Bool
== Natural
0 = [forall v (w :: Natural).
SupportTermOps v =>
NatRepr w -> v -> Natural -> v
digit NatRepr w
w v
x Natural
0]
| Bool
otherwise = []
digit :: SupportTermOps v => NatRepr w -> v -> Natural -> v
digit :: forall v (w :: Natural).
SupportTermOps v =>
NatRepr w -> v -> Natural -> v
digit NatRepr w
w v
x Natural
d = forall v. SupportTermOps v => v -> v -> v -> v
ite (forall v (w :: Natural).
SupportTermOps v =>
NatRepr w -> Natural -> v -> v
bvTestBit NatRepr w
w Natural
d v
x)
(forall a. Num a => Integer -> a
fromInteger (Integer
2forall a b. (Num a, Integral b) => a -> b -> a
^Natural
d))
v
0
unsupportedTerm :: MonadFail m => Expr t tp -> m a
unsupportedTerm :: forall (m :: Type -> Type) t (tp :: BaseType) a.
MonadFail m =>
Expr t tp -> m a
unsupportedTerm Expr t tp
e =
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$
forall ann. [Doc ann] -> Doc ann
vcat
[ Doc Any
"Cannot generate solver output for term generated at"
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (ProgramLoc -> Position
plSourceLoc (forall t (tp :: BaseType). Expr t tp -> ProgramLoc
exprLoc Expr t tp
e)) forall a. Semigroup a => a -> a -> a
<> Doc Any
":"
, forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (forall a ann. Pretty a => a -> Doc ann
pretty Expr t tp
e)
]
checkVarTypeSupport :: ExprBoundVar n tp -> SMTCollector n h ()
checkVarTypeSupport :: forall n (tp :: BaseType) h.
ExprBoundVar n tp -> SMTCollector n h ()
checkVarTypeSupport ExprBoundVar n tp
var = do
let t :: Expr n tp
t = forall t (tp :: BaseType). ExprBoundVar t tp -> Expr t tp
BoundVarExpr ExprBoundVar n tp
var
case forall t (tp :: BaseType). ExprBoundVar t tp -> BaseTypeRepr tp
bvarType ExprBoundVar n tp
var of
BaseTypeRepr tp
BaseIntegerRepr -> forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkIntegerSupport Expr n tp
t
BaseTypeRepr tp
BaseRealRepr -> forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkLinearSupport Expr n tp
t
BaseTypeRepr tp
BaseComplexRepr -> forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkLinearSupport Expr n tp
t
BaseStringRepr StringInfoRepr si
_ -> forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkStringSupport Expr n tp
t
BaseFloatRepr FloatPrecisionRepr fpp
_ -> forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkFloatSupport Expr n tp
t
BaseBVRepr NatRepr w
_ -> forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkBitvectorSupport Expr n tp
t
BaseTypeRepr tp
_ -> forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
theoryUnsupported :: MonadFail m => WriterConn t h -> String -> Expr t tp -> m a
theoryUnsupported :: forall (m :: Type -> Type) t h (tp :: BaseType) a.
MonadFail m =>
WriterConn t h -> String -> Expr t tp -> m a
theoryUnsupported WriterConn t h
conn String
theory_name Expr t tp
t =
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$
forall a ann. Pretty a => a -> Doc ann
pretty (forall t h. WriterConn t h -> String
smtWriterName WriterConn t h
conn) forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Any
"does not support the" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty String
theory_name
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Any
"term generated at" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (ProgramLoc -> Position
plSourceLoc (forall t (tp :: BaseType). Expr t tp -> ProgramLoc
exprLoc Expr t tp
t))
checkIntegerSupport :: Expr t tp -> SMTCollector t h ()
checkIntegerSupport :: forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkIntegerSupport Expr t tp
t = do
WriterConn t h
conn <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> WriterConn t h
scConn
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (forall t h. WriterConn t h -> ProblemFeatures
supportedFeatures WriterConn t h
conn ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useIntegerArithmetic) forall a b. (a -> b) -> a -> b
$ do
forall (m :: Type -> Type) t h (tp :: BaseType) a.
MonadFail m =>
WriterConn t h -> String -> Expr t tp -> m a
theoryUnsupported WriterConn t h
conn String
"integer arithmetic" Expr t tp
t
checkStringSupport :: Expr t tp -> SMTCollector t h ()
checkStringSupport :: forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkStringSupport Expr t tp
t = do
WriterConn t h
conn <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> WriterConn t h
scConn
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (forall t h. WriterConn t h -> ProblemFeatures
supportedFeatures WriterConn t h
conn ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useStrings) forall a b. (a -> b) -> a -> b
$ do
forall (m :: Type -> Type) t h (tp :: BaseType) a.
MonadFail m =>
WriterConn t h -> String -> Expr t tp -> m a
theoryUnsupported WriterConn t h
conn String
"string" Expr t tp
t
checkBitvectorSupport :: Expr t tp -> SMTCollector t h ()
checkBitvectorSupport :: forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkBitvectorSupport Expr t tp
t = do
WriterConn t h
conn <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> WriterConn t h
scConn
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (forall t h. WriterConn t h -> ProblemFeatures
supportedFeatures WriterConn t h
conn ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useBitvectors) forall a b. (a -> b) -> a -> b
$ do
forall (m :: Type -> Type) t h (tp :: BaseType) a.
MonadFail m =>
WriterConn t h -> String -> Expr t tp -> m a
theoryUnsupported WriterConn t h
conn String
"bitvector" Expr t tp
t
checkFloatSupport :: Expr t tp -> SMTCollector t h ()
checkFloatSupport :: forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkFloatSupport Expr t tp
t = do
WriterConn t h
conn <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> WriterConn t h
scConn
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (forall t h. WriterConn t h -> ProblemFeatures
supportedFeatures WriterConn t h
conn ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useFloatingPoint) forall a b. (a -> b) -> a -> b
$ do
forall (m :: Type -> Type) t h (tp :: BaseType) a.
MonadFail m =>
WriterConn t h -> String -> Expr t tp -> m a
theoryUnsupported WriterConn t h
conn String
"floating-point arithmetic" Expr t tp
t
checkLinearSupport :: Expr t tp -> SMTCollector t h ()
checkLinearSupport :: forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkLinearSupport Expr t tp
t = do
WriterConn t h
conn <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> WriterConn t h
scConn
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (forall t h. WriterConn t h -> ProblemFeatures
supportedFeatures WriterConn t h
conn ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useLinearArithmetic) forall a b. (a -> b) -> a -> b
$ do
forall (m :: Type -> Type) t h (tp :: BaseType) a.
MonadFail m =>
WriterConn t h -> String -> Expr t tp -> m a
theoryUnsupported WriterConn t h
conn String
"linear arithmetic" Expr t tp
t
checkNonlinearSupport :: Expr t tp -> SMTCollector t h ()
checkNonlinearSupport :: forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkNonlinearSupport Expr t tp
t = do
WriterConn t h
conn <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> WriterConn t h
scConn
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (forall t h. WriterConn t h -> ProblemFeatures
supportedFeatures WriterConn t h
conn ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useNonlinearArithmetic) forall a b. (a -> b) -> a -> b
$ do
forall (m :: Type -> Type) t h (tp :: BaseType) a.
MonadFail m =>
WriterConn t h -> String -> Expr t tp -> m a
theoryUnsupported WriterConn t h
conn String
"non-linear arithmetic" Expr t tp
t
checkComputableSupport :: Expr t tp -> SMTCollector t h ()
checkComputableSupport :: forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkComputableSupport Expr t tp
t = do
WriterConn t h
conn <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> WriterConn t h
scConn
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (forall t h. WriterConn t h -> ProblemFeatures
supportedFeatures WriterConn t h
conn ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useComputableReals) forall a b. (a -> b) -> a -> b
$ do
forall (m :: Type -> Type) t h (tp :: BaseType) a.
MonadFail m =>
WriterConn t h -> String -> Expr t tp -> m a
theoryUnsupported WriterConn t h
conn String
"computable arithmetic" Expr t tp
t
checkQuantifierSupport :: String -> Expr t p -> SMTCollector t h ()
checkQuantifierSupport :: forall t (p :: BaseType) h.
String -> Expr t p -> SMTCollector t h ()
checkQuantifierSupport String
nm Expr t p
t = do
WriterConn t h
conn <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> WriterConn t h
scConn
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (forall t h. WriterConn t h -> Bool
supportQuantifiers WriterConn t h
conn forall a. Eq a => a -> a -> Bool
== Bool
False) forall a b. (a -> b) -> a -> b
$ do
forall (m :: Type -> Type) t h (tp :: BaseType) a.
MonadFail m =>
WriterConn t h -> String -> Expr t tp -> m a
theoryUnsupported WriterConn t h
conn String
nm Expr t p
t
checkArgumentTypes :: WriterConn t h -> Ctx.Assignment TypeMap args -> IO ()
checkArgumentTypes :: forall t h (args :: Ctx BaseType).
WriterConn t h -> Assignment TypeMap args -> IO ()
checkArgumentTypes WriterConn t h
conn Assignment TypeMap args
types = do
forall {k} {l} (t :: (k -> Type) -> l -> Type) (m :: Type -> Type)
(f :: k -> Type) (c :: l) a.
(FoldableFC t, Applicative m) =>
t f c -> (forall (x :: k). f x -> m a) -> m ()
forFC_ Assignment TypeMap args
types forall a b. (a -> b) -> a -> b
$ \TypeMap x
tp -> do
case TypeMap x
tp of
FnArrayTypeMap{} | forall t h. WriterConn t h -> Bool
supportFunctionArguments WriterConn t h
conn forall a. Eq a => a -> a -> Bool
== Bool
False -> do
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty (forall t h. WriterConn t h -> String
smtWriterName WriterConn t h
conn)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Any
"does not allow arrays encoded as functions to be function arguments."
TypeMap x
_ ->
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
type SMTSource ann = String -> BaseTypeError -> Doc ann
ppBaseTypeError :: BaseTypeError -> Doc ann
ppBaseTypeError :: forall ann. BaseTypeError -> Doc ann
ppBaseTypeError BaseTypeError
ComplexTypeUnsupported = Doc ann
"complex values"
ppBaseTypeError BaseTypeError
ArrayUnsupported = Doc ann
"arrays encoded as a functions"
ppBaseTypeError (StringTypeUnsupported (Some StringInfoRepr x
si)) = Doc ann
"string values" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow StringInfoRepr x
si
eltSource :: Expr t tp -> SMTSource ann
eltSource :: forall t (tp :: BaseType) ann. Expr t tp -> SMTSource ann
eltSource Expr t tp
e String
solver_name BaseTypeError
cause =
forall ann. [Doc ann] -> Doc ann
vcat
[ forall a ann. Pretty a => a -> Doc ann
pretty String
solver_name forall ann. Doc ann -> Doc ann -> Doc ann
<+>
Doc ann
"does not support" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. BaseTypeError -> Doc ann
ppBaseTypeError BaseTypeError
cause forall a. Semigroup a => a -> a -> a
<>
Doc ann
", and cannot interpret the term generated at" forall ann. Doc ann -> Doc ann -> Doc ann
<+>
forall a ann. Pretty a => a -> Doc ann
pretty (ProgramLoc -> Position
plSourceLoc (forall t (tp :: BaseType). Expr t tp -> ProgramLoc
exprLoc Expr t tp
e)) forall a. Semigroup a => a -> a -> a
<> Doc ann
":"
, forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (forall a ann. Pretty a => a -> Doc ann
pretty Expr t tp
e) forall a. Semigroup a => a -> a -> a
<> Doc ann
"."
]
fnSource :: SolverSymbol -> ProgramLoc -> SMTSource ann
fnSource :: forall ann. SolverSymbol -> ProgramLoc -> SMTSource ann
fnSource SolverSymbol
fn_name ProgramLoc
loc String
solver_name BaseTypeError
cause =
forall a ann. Pretty a => a -> Doc ann
pretty String
solver_name forall ann. Doc ann -> Doc ann -> Doc ann
<+>
Doc ann
"does not support" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. BaseTypeError -> Doc ann
ppBaseTypeError BaseTypeError
cause forall a. Semigroup a => a -> a -> a
<>
Doc ann
", and cannot interpret the function" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow SolverSymbol
fn_name forall ann. Doc ann -> Doc ann -> Doc ann
<+>
Doc ann
"generated at" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (ProgramLoc -> Position
plSourceLoc ProgramLoc
loc) forall a. Semigroup a => a -> a -> a
<> Doc ann
"."
evalFirstClassTypeRepr :: MonadFail m
=> WriterConn t h
-> SMTSource ann
-> BaseTypeRepr tp
-> m (TypeMap tp)
evalFirstClassTypeRepr :: forall (m :: Type -> Type) t h ann (tp :: BaseType).
MonadFail m =>
WriterConn t h
-> SMTSource ann -> BaseTypeRepr tp -> m (TypeMap tp)
evalFirstClassTypeRepr WriterConn t h
conn SMTSource ann
src BaseTypeRepr tp
base_tp =
case forall t h (tp :: BaseType).
WriterConn t h
-> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
typeMapFirstClass WriterConn t h
conn BaseTypeRepr tp
base_tp of
Left BaseTypeError
e -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ SMTSource ann
src (forall t h. WriterConn t h -> String
smtWriterName WriterConn t h
conn) BaseTypeError
e
Right TypeMap tp
smt_ret -> forall (m :: Type -> Type) a. Monad m => a -> m a
return TypeMap tp
smt_ret
withConnEntryStack :: WriterConn t h -> IO a -> IO a
withConnEntryStack :: forall t h a. WriterConn t h -> IO a -> IO a
withConnEntryStack WriterConn t h
conn = forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (forall t h. WriterConn t h -> IO ()
pushEntryStack WriterConn t h
conn) (forall t h. WriterConn t h -> IO ()
popEntryStack WriterConn t h
conn)
mkIndexLitTerm :: SupportTermOps v
=> IndexLit tp
-> v
mkIndexLitTerm :: forall v (tp :: BaseType). SupportTermOps v => IndexLit tp -> v
mkIndexLitTerm (IntIndexLit Integer
i) = forall a. Num a => Integer -> a
fromInteger Integer
i
mkIndexLitTerm (BVIndexLit NatRepr w
w BV w
i) = forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w BV w
i
mkIndexLitTerms :: SupportTermOps v
=> Ctx.Assignment IndexLit ctx
-> [v]
mkIndexLitTerms :: forall v (ctx :: Ctx BaseType).
SupportTermOps v =>
Assignment IndexLit ctx -> [v]
mkIndexLitTerms = forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type) a.
FoldableFC t =>
(forall (x :: k). f x -> a) -> forall (x :: l). t f x -> [a]
toListFC forall v (tp :: BaseType). SupportTermOps v => IndexLit tp -> v
mkIndexLitTerm
createTypeMapArgsForArray :: forall t h args
. WriterConn t h
-> Ctx.Assignment TypeMap args
-> IO [(Text, Some TypeMap)]
createTypeMapArgsForArray :: forall t h (args :: Ctx BaseType).
WriterConn t h
-> Assignment TypeMap args -> IO [(Text, Some TypeMap)]
createTypeMapArgsForArray WriterConn t h
conn Assignment TypeMap args
types = do
let mkIndexVar :: TypeMap utp -> IO (Text, Some TypeMap)
mkIndexVar :: forall (utp :: BaseType). TypeMap utp -> IO (Text, Some TypeMap)
mkIndexVar TypeMap utp
base_tp = do
Text
i_nm <- forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ Builder -> State WriterState Text
freshVarName' Builder
"i!"
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text
i_nm, forall k (f :: k -> Type) (x :: k). f x -> Some f
Some TypeMap utp
base_tp)
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type) a.
FoldableFC t =>
(forall (x :: k). f x -> a) -> forall (x :: l). t f x -> [a]
toListFC forall (utp :: BaseType). TypeMap utp -> IO (Text, Some TypeMap)
mkIndexVar Assignment TypeMap args
types
smt_array_select :: forall h idxl idx tp
. SMTWriter h
=> SMTExpr h (BaseArrayType (idxl Ctx.::> idx) tp)
-> [Term h]
-> SMTExpr h tp
smt_array_select :: forall h (idxl :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
SMTWriter h =>
SMTExpr h (BaseArrayType (idxl ::> idx) tp)
-> [Term h] -> SMTExpr h tp
smt_array_select SMTExpr h (BaseArrayType (idxl ::> idx) tp)
aexpr [Term h]
idxl =
case forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h (BaseArrayType (idxl ::> idx) tp)
aexpr of
PrimArrayTypeMap Assignment TypeMap (idxl ::> idx)
_ TypeMap tp
res_type ->
forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap tp
res_type forall a b. (a -> b) -> a -> b
$ forall h. SMTWriter h => Term h -> [Term h] -> Term h
arraySelect @h (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h (BaseArrayType (idxl ::> idx) tp)
aexpr) [Term h]
idxl
FnArrayTypeMap Assignment TypeMap (idxl ::> idx)
_ TypeMap tp
res_type ->
forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap tp
res_type forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> [v] -> v
smtFnApp (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h (BaseArrayType (idxl ::> idx) tp)
aexpr) [Term h]
idxl
getSymbolName :: WriterConn t h -> SymbolBinding t -> IO Text
getSymbolName :: forall t h. WriterConn t h -> SymbolBinding t -> IO Text
getSymbolName WriterConn t h
conn SymbolBinding t
b =
case forall t. SymbolBinding t -> SymbolVarBimap t -> Maybe SolverSymbol
lookupSymbolOfBinding SymbolBinding t
b (forall t h. WriterConn t h -> SymbolVarBimap t
varBindings WriterConn t h
conn) of
Just SolverSymbol
sym -> forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! SolverSymbol -> Text
solverSymbolAsText SolverSymbol
sym
Maybe SolverSymbol
Nothing -> forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ State WriterState Text
freshVarName
defineSMTFunction :: SMTWriter h
=> WriterConn t h
-> Text
-> (FreshVarFn h -> SMTCollector t h (SMTExpr h ret))
-> IO (TypeMap ret)
defineSMTFunction :: forall h t (ret :: BaseType).
SMTWriter h =>
WriterConn t h
-> Text
-> (FreshVarFn h -> SMTCollector t h (SMTExpr h ret))
-> IO (TypeMap ret)
defineSMTFunction WriterConn t h
conn Text
var FreshVarFn h -> SMTCollector t h (SMTExpr h ret)
action =
forall t h a. WriterConn t h -> IO a -> IO a
withConnEntryStack WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ do
IORef [(Text, Some TypeMap)]
freeConstantRef <- (forall a. a -> IO (IORef a)
newIORef [] :: IO (IORef [(Text, Some TypeMap)]))
IORef [(Text, Term h)]
boundTermRef <- forall a. a -> IO (IORef a)
newIORef []
let s :: SMTCollectorState t h
s = SMTCollectorState { scConn :: WriterConn t h
scConn = WriterConn t h
conn
, freshBoundTermFn :: forall (rtp :: BaseType).
Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> Term h -> IO ()
freshBoundTermFn = forall v (rtp :: BaseType).
SupportTermOps v =>
IORef [(Text, v)]
-> Text -> [(Text, Some TypeMap)] -> TypeMap rtp -> v -> IO ()
freshSandboxBoundTerm IORef [(Text, Term h)]
boundTermRef
, freshConstantFn :: Maybe (FreshVarFn h)
freshConstantFn = forall a. Maybe a
Nothing
, recordSideCondFn :: Maybe (Term h -> IO ())
recordSideCondFn = forall a. Maybe a
Nothing
}
let varFn :: FreshVarFn h
varFn = forall h.
(forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp))
-> FreshVarFn h
FreshVarFn (forall t h (tp :: BaseType).
WriterConn t h
-> IORef [(Text, Some TypeMap)] -> TypeMap tp -> IO (SMTExpr h tp)
freshSandboxConstant WriterConn t h
conn IORef [(Text, Some TypeMap)]
freeConstantRef)
SMTExpr h ret
pair <- forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT SMTCollectorState t h
s (FreshVarFn h -> SMTCollector t h (SMTExpr h ret)
action FreshVarFn h
varFn)
[(Text, Some TypeMap)]
args <- forall a. IORef a -> IO a
readIORef IORef [(Text, Some TypeMap)]
freeConstantRef
[(Text, Term h)]
boundTerms <- forall a. IORef a -> IO a
readIORef IORef [(Text, Term h)]
boundTermRef
let res :: Term h
res = forall v. SupportTermOps v => [(Text, v)] -> v -> v
letExpr (forall a. [a] -> [a]
reverse [(Text, Term h)]
boundTerms) (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h ret
pair)
forall h t (rtp :: BaseType).
SMTWriter h =>
WriterConn t h
-> DefineStyle
-> Text
-> [(Text, Some TypeMap)]
-> TypeMap rtp
-> Term h
-> IO ()
defineSMTVar WriterConn t h
conn DefineStyle
FunctionDefinition Text
var (forall a. [a] -> [a]
reverse [(Text, Some TypeMap)]
args) (forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h ret
pair) Term h
res
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h ret
pair
mkExpr :: forall h t tp. SMTWriter h => Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr :: forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr (BoolExpr Bool
b ProgramLoc
_) =
forall (m :: Type -> Type) a. Monad m => a -> m a
return (forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap BaseBoolType
BoolTypeMap (forall v. SupportTermOps v => Bool -> v
boolExpr Bool
b))
mkExpr t :: Expr t tp
t@(SemiRingLiteral SemiRingRepr sr
SR.SemiRingIntegerRepr Coefficient sr
i ProgramLoc
_) = do
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkLinearSupport Expr t tp
t
forall (m :: Type -> Type) a. Monad m => a -> m a
return (forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap 'BaseIntegerType
IntegerTypeMap (forall a b. (Integral a, Num b) => a -> b
fromIntegral Coefficient sr
i))
mkExpr t :: Expr t tp
t@(SemiRingLiteral SemiRingRepr sr
SR.SemiRingRealRepr Coefficient sr
r ProgramLoc
_) = do
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkLinearSupport Expr t tp
t
forall (m :: Type -> Type) a. Monad m => a -> m a
return (forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap 'BaseRealType
RealTypeMap (forall v. SupportTermOps v => Rational -> v
rationalTerm Coefficient sr
r))
mkExpr t :: Expr t tp
t@(SemiRingLiteral (SR.SemiRingBVRepr BVFlavorRepr fv
_flv NatRepr w
w) Coefficient sr
x ProgramLoc
_) = do
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkBitvectorSupport Expr t tp
t
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w) forall a b. (a -> b) -> a -> b
$ forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w Coefficient sr
x
mkExpr t :: Expr t tp
t@(FloatExpr FloatPrecisionRepr fpp
fpp BigFloat
f ProgramLoc
_) = do
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkFloatSupport Expr t tp
t
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr (forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp) forall a b. (a -> b) -> a -> b
$ forall v (fpp :: FloatPrecision).
SupportTermOps v =>
FloatPrecisionRepr fpp -> BigFloat -> v
floatTerm FloatPrecisionRepr fpp
fpp BigFloat
f
mkExpr t :: Expr t tp
t@(StringExpr StringLiteral si
l ProgramLoc
_) =
case StringLiteral si
l of
UnicodeLiteral Text
str -> do
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkStringSupport Expr t tp
t
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap ('BaseStringType Unicode)
UnicodeTypeMap forall a b. (a -> b) -> a -> b
$ forall h. SMTWriter h => Text -> Term h
stringTerm @h Text
str
StringLiteral si
_ -> do
WriterConn t h
conn <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> WriterConn t h
scConn
forall (m :: Type -> Type) t h (tp :: BaseType) a.
MonadFail m =>
WriterConn t h -> String -> Expr t tp -> m a
theoryUnsupported WriterConn t h
conn (String
"strings " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (si :: StringInfo). StringLiteral si -> StringInfoRepr si
stringLiteralInfo StringLiteral si
l)) Expr t tp
t
mkExpr (NonceAppExpr NonceAppExpr t tp
ea) =
forall t (tp :: BaseType) h.
Nonce t tp
-> TermLifetime
-> SMTCollector t h (SMTExpr h tp)
-> SMTCollector t h (SMTExpr h tp)
cacheWriterResult (forall t (tp :: BaseType). NonceAppExpr t tp -> Nonce t tp
nonceExprId NonceAppExpr t tp
ea) TermLifetime
DeleteOnPop forall a b. (a -> b) -> a -> b
$
forall t h (tp :: BaseType).
SMTWriter h =>
NonceAppExpr t tp -> SMTCollector t h (SMTExpr h tp)
predSMTExpr NonceAppExpr t tp
ea
mkExpr (AppExpr AppExpr t tp
ea) =
forall t (tp :: BaseType) h.
Nonce t tp
-> TermLifetime
-> SMTCollector t h (SMTExpr h tp)
-> SMTCollector t h (SMTExpr h tp)
cacheWriterResult (forall t (tp :: BaseType). AppExpr t tp -> Nonce t tp
appExprId AppExpr t tp
ea) TermLifetime
DeleteOnPop forall a b. (a -> b) -> a -> b
$ do
forall t h (tp :: BaseType).
SMTWriter h =>
AppExpr t tp -> SMTCollector t h (SMTExpr h tp)
appSMTExpr AppExpr t tp
ea
mkExpr (BoundVarExpr ExprBoundVar t tp
var) = do
case forall t (tp :: BaseType). ExprBoundVar t tp -> VarKind
bvarKind ExprBoundVar t tp
var of
VarKind
QuantifierVarKind -> do
WriterConn t h
conn <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> WriterConn t h
scConn
Maybe (SMTExpr h tp)
mr <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall t h (tp :: BaseType).
WriterConn t h -> Nonce t tp -> IO (Maybe (SMTExpr h tp))
cacheLookupExpr WriterConn t h
conn (forall t (tp :: BaseType). ExprBoundVar t tp -> Nonce t tp
bvarId ExprBoundVar t tp
var)
case Maybe (SMTExpr h tp)
mr of
Just SMTExpr h tp
x -> forall (m :: Type -> Type) a. Monad m => a -> m a
return SMTExpr h tp
x
Maybe (SMTExpr h tp)
Nothing -> do
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Internal error in SMTLIB exporter due to unbound variable "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall t (tp :: BaseType). ExprBoundVar t tp -> Nonce t tp
bvarId ExprBoundVar t tp
var) forall a. [a] -> [a] -> [a]
++ String
" defined at "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (ProgramLoc -> Position
plSourceLoc (forall t (tp :: BaseType). ExprBoundVar t tp -> ProgramLoc
bvarLoc ExprBoundVar t tp
var)) forall a. [a] -> [a] -> [a]
++ String
"."
VarKind
LatchVarKind ->
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"SMTLib exporter does not support the latch defined at "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (ProgramLoc -> Position
plSourceLoc (forall t (tp :: BaseType). ExprBoundVar t tp -> ProgramLoc
bvarLoc ExprBoundVar t tp
var)) forall a. [a] -> [a] -> [a]
++ String
"."
VarKind
UninterpVarKind -> do
WriterConn t h
conn <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> WriterConn t h
scConn
forall t (tp :: BaseType) h.
Nonce t tp
-> TermLifetime
-> SMTCollector t h (SMTExpr h tp)
-> SMTCollector t h (SMTExpr h tp)
cacheWriterResult (forall t (tp :: BaseType). ExprBoundVar t tp -> Nonce t tp
bvarId ExprBoundVar t tp
var) TermLifetime
DeleteNever forall a b. (a -> b) -> a -> b
$ do
forall n (tp :: BaseType) h.
ExprBoundVar n tp -> SMTCollector n h ()
checkVarTypeSupport ExprBoundVar t tp
var
Text
var_name <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall t h. WriterConn t h -> SymbolBinding t -> IO Text
getSymbolName WriterConn t h
conn (forall t (tp :: BaseType). ExprBoundVar t tp -> SymbolBinding t
VarSymbolBinding ExprBoundVar t tp
var)
TypeMap tp
smt_type <- forall t (tp :: BaseType) h.
ExprBoundVar t tp -> SMTCollector t h (TypeMap tp)
getBaseSMT_Type ExprBoundVar t tp
var
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
do forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn TypeMap tp
smt_type
forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommand WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ forall h (f :: Type -> Type) (args :: Ctx BaseType)
(rtp :: BaseType).
SMTWriter h =>
f h -> Text -> Assignment TypeMap args -> TypeMap rtp -> Command h
declareCommand WriterConn t h
conn Text
var_name forall {k} (f :: k -> Type). Assignment f EmptyCtx
Ctx.empty TypeMap tp
smt_type
forall t h (tp :: BaseType).
SMTWriter h =>
WriterConn t h
-> Term h
-> TypeMap tp
-> Maybe (AbstractValue tp)
-> SMTCollector t h ()
addPartialSideCond WriterConn t h
conn (forall v. SupportTermOps v => Text -> v
fromText Text
var_name) TypeMap tp
smt_type (forall t (tp :: BaseType).
ExprBoundVar t tp -> Maybe (AbstractValue tp)
bvarAbstractValue ExprBoundVar t tp
var)
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (tp :: BaseType) h. TypeMap tp -> Text -> SMTExpr h tp
SMTName TypeMap tp
smt_type Text
var_name
mkBaseExpr :: SMTWriter h => Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr :: forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t tp
e = forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t tp
e
{-# INLINE mkBaseExpr #-}
mkIndicesTerms :: SMTWriter h
=> Ctx.Assignment (Expr t) ctx
-> SMTCollector t h [Term h]
mkIndicesTerms :: forall h t (ctx :: Ctx BaseType).
SMTWriter h =>
Assignment (Expr t) ctx -> SMTCollector t h [Term h]
mkIndicesTerms = forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type) b.
FoldableFC t =>
(forall (x :: k). f x -> b -> b)
-> forall (x :: l). b -> t f x -> b
foldrFC (\Expr t x
e ReaderT (SMTCollectorState t h) IO [Term h]
r -> (:) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t x
e forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> ReaderT (SMTCollectorState t h) IO [Term h]
r) (forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [])
predSMTExpr :: forall t h tp
. SMTWriter h
=> NonceAppExpr t tp
-> SMTCollector t h (SMTExpr h tp)
predSMTExpr :: forall t h (tp :: BaseType).
SMTWriter h =>
NonceAppExpr t tp -> SMTCollector t h (SMTExpr h tp)
predSMTExpr NonceAppExpr t tp
e0 = do
WriterConn t h
conn <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> WriterConn t h
scConn
let i :: Expr t tp
i = forall t (tp :: BaseType). NonceAppExpr t tp -> Expr t tp
NonceAppExpr NonceAppExpr t tp
e0
WriterConn t h
h <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> WriterConn t h
scConn
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall t h. WriterConn t h -> ProgramLoc -> IO ()
updateProgramLoc WriterConn t h
h (forall t (tp :: BaseType). NonceAppExpr t tp -> ProgramLoc
nonceExprLoc NonceAppExpr t tp
e0)
case forall t (tp :: BaseType).
NonceAppExpr t tp -> NonceApp t (Expr t) tp
nonceExprApp NonceAppExpr t tp
e0 of
Annotation BaseTypeRepr tp
_tpr Nonce t tp
_n Expr t tp
e -> forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t tp
e
Forall ExprBoundVar t tp1
var Expr t BaseBoolType
e -> do
forall t (p :: BaseType) h.
String -> Expr t p -> SMTCollector t h ()
checkQuantifierSupport String
"universal quantifier" Expr t tp
i
TypeMap tp1
smtType <- forall t (tp :: BaseType) h.
ExprBoundVar t tp -> SMTCollector t h (TypeMap tp)
getBaseSMT_Type ExprBoundVar t tp1
var
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
h TypeMap tp1
smtType
CollectorResults h (Term h)
cr <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall t h a. WriterConn t h -> IO a -> IO a
withConnEntryStack WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ do
forall h t a.
SupportTermOps (Term h) =>
WriterConn t h -> SMTCollector t h a -> IO (CollectorResults h a)
runInSandbox WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ do
forall n (tp :: BaseType) h.
ExprBoundVar n tp -> SMTCollector n h ()
checkVarTypeSupport ExprBoundVar t tp1
var
Just (FreshVarFn forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp)
f) <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> Maybe (FreshVarFn h)
freshConstantFn
SMTExpr h tp1
t <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp)
f TypeMap tp1
smtType
forall t (tp :: BaseType) h.
ExprBoundVar t tp -> SMTExpr h tp -> SMTCollector t h ()
bindVar ExprBoundVar t tp1
var SMTExpr h tp1
t
forall t h (tp :: BaseType).
SMTWriter h =>
WriterConn t h
-> Term h
-> TypeMap tp
-> Maybe (AbstractValue tp)
-> SMTCollector t h ()
addPartialSideCond WriterConn t h
conn (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h tp1
t) TypeMap tp1
smtType (forall t (tp :: BaseType).
ExprBoundVar t tp -> Maybe (AbstractValue tp)
bvarAbstractValue ExprBoundVar t tp1
var)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseBoolType
e
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall h. SMTWriter h => CollectorResults h (Term h) -> Term h
forallResult CollectorResults h (Term h)
cr
Exists ExprBoundVar t tp1
var Expr t BaseBoolType
e -> do
forall t (p :: BaseType) h.
String -> Expr t p -> SMTCollector t h ()
checkQuantifierSupport String
"existential quantifiers" Expr t tp
i
TypeMap tp1
smtType <- forall t (tp :: BaseType) h.
ExprBoundVar t tp -> SMTCollector t h (TypeMap tp)
getBaseSMT_Type ExprBoundVar t tp1
var
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
h TypeMap tp1
smtType
CollectorResults h (Term h)
cr <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall t h a. WriterConn t h -> IO a -> IO a
withConnEntryStack WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ do
forall h t a.
SupportTermOps (Term h) =>
WriterConn t h -> SMTCollector t h a -> IO (CollectorResults h a)
runInSandbox WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ do
forall n (tp :: BaseType) h.
ExprBoundVar n tp -> SMTCollector n h ()
checkVarTypeSupport ExprBoundVar t tp1
var
Just (FreshVarFn forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp)
f) <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> Maybe (FreshVarFn h)
freshConstantFn
SMTExpr h tp1
t <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp)
f TypeMap tp1
smtType
forall t (tp :: BaseType) h.
ExprBoundVar t tp -> SMTExpr h tp -> SMTCollector t h ()
bindVar ExprBoundVar t tp1
var SMTExpr h tp1
t
forall t h (tp :: BaseType).
SMTWriter h =>
WriterConn t h
-> Term h
-> TypeMap tp
-> Maybe (AbstractValue tp)
-> SMTCollector t h ()
addPartialSideCond WriterConn t h
conn (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h tp1
t) TypeMap tp1
smtType (forall t (tp :: BaseType).
ExprBoundVar t tp -> Maybe (AbstractValue tp)
bvarAbstractValue ExprBoundVar t tp1
var)
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseBoolType
e
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall h. SMTWriter h => CollectorResults h (Term h) -> Term h
existsResult CollectorResults h (Term h)
cr
ArrayFromFn ExprSymFn t (idx ::> itp) ret
f -> do
Assignment TypeMap (idx ::> itp)
smt_arg_types <-
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
(g :: k -> Type) (m :: Type -> Type).
(TraversableFC t, Applicative m) =>
(forall (x :: k). f x -> m (g x))
-> forall (x :: l). t f x -> m (t g x)
traverseFC (forall (m :: Type -> Type) t h ann (tp :: BaseType).
MonadFail m =>
WriterConn t h
-> SMTSource ann -> BaseTypeRepr tp -> m (TypeMap tp)
evalFirstClassTypeRepr WriterConn t h
conn (forall t (tp :: BaseType) ann. Expr t tp -> SMTSource ann
eltSource Expr t tp
i))
(forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> Assignment BaseTypeRepr args
symFnArgTypes ExprSymFn t (idx ::> itp) ret
f)
(Text
smt_f, TypeMap ret
ret_tp) <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall h t (args :: Ctx BaseType) (ret :: BaseType).
SMTWriter h =>
WriterConn t h
-> ExprSymFn t args ret
-> Assignment TypeMap args
-> IO (Text, TypeMap ret)
getSMTSymFn WriterConn t h
conn ExprSymFn t (idx ::> itp) ret
f Assignment TypeMap (idx ::> itp)
smt_arg_types
let array_tp :: TypeMap ('BaseArrayType (idx ::> itp) ret)
array_tp = forall (idx :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
Assignment TypeMap (idx ::> idx)
-> TypeMap tp -> TypeMap (BaseArrayType (idx ::> idx) tp)
FnArrayTypeMap Assignment TypeMap (idx ::> itp)
smt_arg_types TypeMap ret
ret_tp
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall (tp :: BaseType) h. TypeMap tp -> Text -> SMTExpr h tp
SMTName TypeMap ('BaseArrayType (idx ::> itp) ret)
array_tp Text
smt_f
MapOverArrays ExprSymFn t (ctx ::> d) r
f Assignment BaseTypeRepr (idx ::> itp)
idx_types Assignment (ArrayResultWrapper (Expr t) (idx ::> itp)) (ctx ::> d)
arrays -> do
Assignment TypeMap (idx ::> itp)
smt_idx_types <- forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
(g :: k -> Type) (m :: Type -> Type).
(TraversableFC t, Applicative m) =>
(forall (x :: k). f x -> m (g x))
-> forall (x :: l). t f x -> m (t g x)
traverseFC (forall (m :: Type -> Type) t h ann (tp :: BaseType).
MonadFail m =>
WriterConn t h
-> SMTSource ann -> BaseTypeRepr tp -> m (TypeMap tp)
evalFirstClassTypeRepr WriterConn t h
conn (forall t (tp :: BaseType) ann. Expr t tp -> SMTSource ann
eltSource Expr t tp
i)) Assignment BaseTypeRepr (idx ::> itp)
idx_types
let evalArray :: forall idx itp etp
. ArrayResultWrapper (Expr t) (idx Ctx.::> itp) etp
-> SMTCollector t h (ArrayResultWrapper (SMTExpr h) (idx Ctx.::> itp) etp)
evalArray :: forall (idx :: Ctx BaseType) (itp :: BaseType) (etp :: BaseType).
ArrayResultWrapper (Expr t) (idx ::> itp) etp
-> SMTCollector
t h (ArrayResultWrapper (SMTExpr h) (idx ::> itp) etp)
evalArray (ArrayResultWrapper Expr t (BaseArrayType (idx ::> itp) etp)
a) = forall (f :: BaseType -> Type) (idx :: Ctx BaseType)
(tp :: BaseType).
f (BaseArrayType idx tp) -> ArrayResultWrapper f idx tp
ArrayResultWrapper forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t (BaseArrayType (idx ::> itp) etp)
a
Assignment
(ArrayResultWrapper (SMTExpr h) (idx ::> itp)) (ctx ::> d)
smt_arrays <- forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
(g :: k -> Type) (m :: Type -> Type).
(TraversableFC t, Applicative m) =>
(forall (x :: k). f x -> m (g x))
-> forall (x :: l). t f x -> m (t g x)
traverseFC forall (idx :: Ctx BaseType) (itp :: BaseType) (etp :: BaseType).
ArrayResultWrapper (Expr t) (idx ::> itp) etp
-> SMTCollector
t h (ArrayResultWrapper (SMTExpr h) (idx ::> itp) etp)
evalArray Assignment (ArrayResultWrapper (Expr t) (idx ::> itp)) (ctx ::> d)
arrays
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Text
nm <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall t h a. WriterConn t h -> State WriterState a -> IO a
withWriterState WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ State WriterState Text
freshVarName
TypeMap r
ret_type <-
forall h t (ret :: BaseType).
SMTWriter h =>
WriterConn t h
-> Text
-> (FreshVarFn h -> SMTCollector t h (SMTExpr h ret))
-> IO (TypeMap ret)
defineSMTFunction WriterConn t h
conn Text
nm forall a b. (a -> b) -> a -> b
$ \(FreshVarFn forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp)
freshVar) -> do
Assignment (SMTExpr h) (idx ::> itp)
smt_indices <- forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
(g :: k -> Type) (m :: Type -> Type).
(TraversableFC t, Applicative m) =>
(forall (x :: k). f x -> m (g x))
-> forall (x :: l). t f x -> m (t g x)
traverseFC (\TypeMap x
tp -> forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp)
freshVar TypeMap x
tp)) Assignment TypeMap (idx ::> itp)
smt_idx_types
let idxl :: [Term h]
idxl = forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type) a.
FoldableFC t =>
(forall (x :: k). f x -> a) -> forall (x :: l). t f x -> [a]
toListFC forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase Assignment (SMTExpr h) (idx ::> itp)
smt_indices
let select :: forall idxl idx etp
. ArrayResultWrapper (SMTExpr h) (idxl Ctx.::> idx) etp
-> SMTExpr h etp
select :: forall (idxl :: Ctx BaseType) (idx :: BaseType) (etp :: BaseType).
ArrayResultWrapper (SMTExpr h) (idxl ::> idx) etp -> SMTExpr h etp
select (ArrayResultWrapper SMTExpr h (BaseArrayType (idxl ::> idx) etp)
a) = forall h (idxl :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
SMTWriter h =>
SMTExpr h (BaseArrayType (idxl ::> idx) tp)
-> [Term h] -> SMTExpr h tp
smt_array_select SMTExpr h (BaseArrayType (idxl ::> idx) etp)
a [Term h]
idxl
let array_vals :: Assignment (SMTExpr h) (ctx ::> d)
array_vals = forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
(g :: k -> Type).
FunctorFC t =>
(forall (x :: k). f x -> g x) -> forall (x :: l). t f x -> t g x
fmapFC forall (idxl :: Ctx BaseType) (idx :: BaseType) (etp :: BaseType).
ArrayResultWrapper (SMTExpr h) (idxl ::> idx) etp -> SMTExpr h etp
select Assignment
(ArrayResultWrapper (SMTExpr h) (idx ::> itp)) (ctx ::> d)
smt_arrays
(Text
smt_f, TypeMap r
ret_type) <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall h t (args :: Ctx BaseType) (ret :: BaseType).
SMTWriter h =>
WriterConn t h
-> ExprSymFn t args ret
-> Assignment TypeMap args
-> IO (Text, TypeMap ret)
getSMTSymFn WriterConn t h
conn ExprSymFn t (ctx ::> d) r
f (forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
(g :: k -> Type).
FunctorFC t =>
(forall (x :: k). f x -> g x) -> forall (x :: l). t f x -> t g x
fmapFC forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType Assignment (SMTExpr h) (ctx ::> d)
array_vals)
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap r
ret_type forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> [v] -> v
smtFnApp (forall v. SupportTermOps v => Text -> v
fromText Text
smt_f) (forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type) a.
FoldableFC t =>
(forall (x :: k). f x -> a) -> forall (x :: l). t f x -> [a]
toListFC forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase Assignment (SMTExpr h) (ctx ::> d)
array_vals)
let array_tp :: TypeMap ('BaseArrayType (idx ::> itp) r)
array_tp = forall (idx :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
Assignment TypeMap (idx ::> idx)
-> TypeMap tp -> TypeMap (BaseArrayType (idx ::> idx) tp)
FnArrayTypeMap Assignment TypeMap (idx ::> itp)
smt_idx_types TypeMap r
ret_type
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall (tp :: BaseType) h. TypeMap tp -> Text -> SMTExpr h tp
SMTName TypeMap ('BaseArrayType (idx ::> itp) r)
array_tp Text
nm
ArrayTrueOnEntries{} -> do
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"SMTWriter does not yet support ArrayTrueOnEntries.\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Expr t tp
i
FnApp ExprSymFn t args tp
f Assignment (Expr t) args
args -> do
Assignment (SMTExpr h) args
smt_args <- forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
(g :: k -> Type) (m :: Type -> Type).
(TraversableFC t, Applicative m) =>
(forall (x :: k). f x -> m (g x))
-> forall (x :: l). t f x -> m (t g x)
traverseFC forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Assignment (Expr t) args
args
(Text
smt_f, TypeMap tp
ret_type) <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall h t (args :: Ctx BaseType) (ret :: BaseType).
SMTWriter h =>
WriterConn t h
-> ExprSymFn t args ret
-> Assignment TypeMap args
-> IO (Text, TypeMap ret)
getSMTSymFn WriterConn t h
conn ExprSymFn t args tp
f (forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
(g :: k -> Type).
FunctorFC t =>
(forall (x :: k). f x -> g x) -> forall (x :: l). t f x -> t g x
fmapFC forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType Assignment (SMTExpr h) args
smt_args)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap tp
ret_type forall a b. (a -> b) -> a -> b
$! forall v. SupportTermOps v => v -> [v] -> v
smtFnApp (forall v. SupportTermOps v => Text -> v
fromText Text
smt_f) (forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type) a.
FoldableFC t =>
(forall (x :: k). f x -> a) -> forall (x :: l). t f x -> [a]
toListFC forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase Assignment (SMTExpr h) args
smt_args)
appSMTExpr :: forall t h tp
. SMTWriter h
=> AppExpr t tp
-> SMTCollector t h (SMTExpr h tp)
appSMTExpr :: forall t h (tp :: BaseType).
SMTWriter h =>
AppExpr t tp -> SMTCollector t h (SMTExpr h tp)
appSMTExpr AppExpr t tp
ae = do
WriterConn t h
conn <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks forall t h. SMTCollectorState t h -> WriterConn t h
scConn
let i :: Expr t tp
i = forall t (tp :: BaseType). AppExpr t tp -> Expr t tp
AppExpr AppExpr t tp
ae
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall t h. WriterConn t h -> ProgramLoc -> IO ()
updateProgramLoc WriterConn t h
conn (forall t (tp :: BaseType). AppExpr t tp -> ProgramLoc
appExprLoc AppExpr t tp
ae)
case forall t (tp :: BaseType). AppExpr t tp -> App (Expr t) tp
appExprApp AppExpr t tp
ae of
BaseEq BaseTypeRepr tp1
_ Expr t tp1
x Expr t tp1
y ->
do SMTExpr h tp1
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t tp1
x
SMTExpr h tp1
ye <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t tp1
y
let xtp :: TypeMap tp1
xtp = forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h tp1
xe
let ytp :: TypeMap tp1
ytp = forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h tp1
ye
let checkArrayType :: Expr t tp1 -> TypeMap tp1 -> ReaderT (SMTCollectorState t h) IO ()
checkArrayType Expr t tp1
z (FnArrayTypeMap{}) = do
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$
forall ann. [Doc ann] -> Doc ann
vcat
[ forall a ann. Pretty a => a -> Doc ann
pretty (forall t h. WriterConn t h -> String
smtWriterName WriterConn t h
conn) forall ann. Doc ann -> Doc ann -> Doc ann
<+>
Doc Any
"does not support checking equality for the array generated at"
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (ProgramLoc -> Position
plSourceLoc (forall t (tp :: BaseType). Expr t tp -> ProgramLoc
exprLoc Expr t tp1
z)) forall a. Semigroup a => a -> a -> a
<> Doc Any
":"
, forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (forall a ann. Pretty a => a -> Doc ann
pretty Expr t tp1
z)
]
checkArrayType Expr t tp1
_ TypeMap tp1
_ = forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
Expr t tp1 -> TypeMap tp1 -> ReaderT (SMTCollectorState t h) IO ()
checkArrayType Expr t tp1
x TypeMap tp1
xtp
Expr t tp1 -> TypeMap tp1 -> ReaderT (SMTCollectorState t h) IO ()
checkArrayType Expr t tp1
y TypeMap tp1
ytp
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (TypeMap tp1
xtp forall a. Eq a => a -> a -> Bool
/= TypeMap tp1
ytp) forall a b. (a -> b) -> a -> b
$ do
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"Type representations are not equal:", forall a. Show a => a -> String
show TypeMap tp1
xtp, forall a. Show a => a -> String
show TypeMap tp1
ytp]
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h tp1
xe forall v. SupportTermOps v => v -> v -> v
.== forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h tp1
ye
BaseIte BaseTypeRepr tp
btp Integer
_ Expr t BaseBoolType
c Expr t tp
x Expr t tp
y -> do
let errMsg :: String -> String
errMsg String
typename =
forall a. Show a => a -> String
show
forall a b. (a -> b) -> a -> b
$ Doc Any
"we do not support if/then/else expressions at type"
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty String
typename
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Any
"with solver"
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall t h. WriterConn t h -> String
smtWriterName WriterConn t h
conn) forall a. Semigroup a => a -> a -> a
<> Doc Any
"."
case forall t h (tp :: BaseType).
WriterConn t h
-> BaseTypeRepr tp -> Either BaseTypeError (TypeMap tp)
typeMap WriterConn t h
conn BaseTypeRepr tp
btp of
Left (StringTypeUnsupported (Some StringInfoRepr x
si)) -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String -> String
errMsg (String
"string " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show StringInfoRepr x
si)
Left BaseTypeError
ComplexTypeUnsupported -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String -> String
errMsg String
"complex"
Left BaseTypeError
ArrayUnsupported -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String -> String
errMsg String
"array"
Right FnArrayTypeMap{} -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String -> String
errMsg String
"function-backed array"
Right TypeMap tp
tym ->
do Term h
cb <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseBoolType
c
Term h
xb <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t tp
x
Term h
yb <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t tp
y
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap tp
tym forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v -> v
ite Term h
cb Term h
xb Term h
yb
SemiRingLe OrderedSemiRingRepr sr
_sr Expr t (SemiRingBase sr)
x Expr t (SemiRingBase sr)
y -> do
Term h
xb <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (SemiRingBase sr)
x
Term h
yb <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (SemiRingBase sr)
y
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ Term h
xb forall v. SupportTermOps v => v -> v -> v
.<= Term h
yb
RealIsInteger Expr t 'BaseRealType
r -> do
Term h
rb <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t 'BaseRealType
r
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$! forall v. SupportTermOps v => v -> v
realIsInteger Term h
rb
BVTestBit Natural
n Expr t (BaseBVType w)
xe -> do
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
xe
let this_bit :: Term h
this_bit = forall v (w :: Natural).
SupportTermOps v =>
NatRepr w -> Natural -> Natural -> v -> v
bvExtract (forall (e :: BaseType -> Type) (w :: Natural).
IsExpr e =>
e (BaseBVType w) -> NatRepr w
bvWidth Expr t (BaseBVType w)
xe) Natural
n Natural
1 Term h
x
one :: Term h
one = forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm (forall (n :: Natural). KnownNat n => NatRepr n
knownNat :: NatRepr 1) (forall (w :: Natural). (1 <= w) => NatRepr w -> BV w
BV.one forall (n :: Natural). KnownNat n => NatRepr n
knownNat)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ Term h
this_bit forall v. SupportTermOps v => v -> v -> v
.== Term h
one
BVSlt Expr t (BaseBVType w)
xe Expr t (BaseBVType w)
ye -> do
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
xe
Term h
y <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
ye
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ Term h
x forall v. SupportTermOps v => v -> v -> v
`bvSLt` Term h
y
BVUlt Expr t (BaseBVType w)
xe Expr t (BaseBVType w)
ye -> do
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
xe
Term h
y <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
ye
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ Term h
x forall v. SupportTermOps v => v -> v -> v
`bvULt` Term h
y
IntDiv Expr t 'BaseIntegerType
xe Expr t 'BaseIntegerType
ye -> do
case Expr t 'BaseIntegerType
ye of
SemiRingLiteral SemiRingRepr sr
_ Coefficient sr
_ ProgramLoc
_ -> forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
Expr t 'BaseIntegerType
_ -> forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkNonlinearSupport Expr t tp
i
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t 'BaseIntegerType
xe
Term h
y <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t 'BaseIntegerType
ye
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap 'BaseIntegerType
IntegerTypeMap (forall v. SupportTermOps v => v -> v -> v
intDiv Term h
x Term h
y)
IntMod Expr t 'BaseIntegerType
xe Expr t 'BaseIntegerType
ye -> do
case Expr t 'BaseIntegerType
ye of
SemiRingLiteral SemiRingRepr sr
_ Coefficient sr
_ ProgramLoc
_ -> forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
Expr t 'BaseIntegerType
_ -> forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkNonlinearSupport Expr t tp
i
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t 'BaseIntegerType
xe
Term h
y <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t 'BaseIntegerType
ye
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap 'BaseIntegerType
IntegerTypeMap (forall v. SupportTermOps v => v -> v -> v
intMod Term h
x Term h
y)
IntAbs Expr t 'BaseIntegerType
xe -> do
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t 'BaseIntegerType
xe
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap 'BaseIntegerType
IntegerTypeMap (forall v. SupportTermOps v => v -> v
intAbs Term h
x)
IntDivisible Expr t 'BaseIntegerType
xe Natural
k -> do
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t 'BaseIntegerType
xe
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap (forall v. SupportTermOps v => v -> Natural -> v
intDivisible Term h
x Natural
k)
NotPred Expr t BaseBoolType
x -> forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. SupportTermOps v => v -> v
notExpr forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseBoolType
x
ConjPred BoolMap (Expr t)
xs ->
let pol :: (Expr t tp, Polarity) -> SMTCollector t h (Term h)
pol (Expr t tp
x,Polarity
Positive) = forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t tp
x
pol (Expr t tp
x,Polarity
Negative) = forall v. SupportTermOps v => v -> v
notExpr forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t tp
x
in
case forall (f :: BaseType -> Type). BoolMap f -> BoolMapView f
BM.viewBoolMap BoolMap (Expr t)
xs of
BoolMapView (Expr t)
BM.BoolMapUnit ->
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => Bool -> v
boolExpr Bool
True
BoolMapView (Expr t)
BM.BoolMapDualUnit ->
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => Bool -> v
boolExpr Bool
False
BM.BoolMapTerms ((Expr t BaseBoolType, Polarity)
t:|[]) ->
forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap BaseBoolType
BoolTypeMap forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {h} {t} {tp :: BaseType}.
SMTWriter h =>
(Expr t tp, Polarity) -> SMTCollector t h (Term h)
pol (Expr t BaseBoolType, Polarity)
t
BM.BoolMapTerms ((Expr t BaseBoolType, Polarity)
t:|[(Expr t BaseBoolType, Polarity)]
ts) ->
do Term h
cnj <- forall v. SupportTermOps v => [v] -> v
andAll forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {h} {t} {tp :: BaseType}.
SMTWriter h =>
(Expr t tp, Polarity) -> SMTCollector t h (Term h)
pol ((Expr t BaseBoolType, Polarity)
tforall a. a -> [a] -> [a]
:[(Expr t BaseBoolType, Polarity)]
ts)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap Term h
cnj
SemiRingProd SemiRingProduct (Expr t) sr
pd ->
case forall (f :: BaseType -> Type) (sr :: SemiRing).
SemiRingProduct f sr -> SemiRingRepr sr
WSum.prodRepr SemiRingProduct (Expr t) sr
pd of
SR.SemiRingBVRepr BVFlavorRepr fv
SR.BVArithRepr NatRepr w
w ->
do Maybe (Term h)
pd' <- forall (m :: Type -> Type) r (f :: BaseType -> Type)
(sr :: SemiRing).
Monad m =>
(r -> r -> m r)
-> (f (SemiRingBase sr) -> m r)
-> SemiRingProduct f sr
-> m (Maybe r)
WSum.prodEvalM (\Term h
a Term h
b -> forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (forall v. SupportTermOps v => v -> v -> v
bvMul Term h
a Term h
b)) forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr SemiRingProduct (Expr t) sr
pd
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w) forall a b. (a -> b) -> a -> b
$ forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (forall (w :: Natural). (1 <= w) => NatRepr w -> BV w
BV.one NatRepr w
w))
(forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w))
Maybe (Term h)
pd'
SR.SemiRingBVRepr BVFlavorRepr fv
SR.BVBitsRepr NatRepr w
w ->
do Maybe (Term h)
pd' <- forall (m :: Type -> Type) r (f :: BaseType -> Type)
(sr :: SemiRing).
Monad m =>
(r -> r -> m r)
-> (f (SemiRingBase sr) -> m r)
-> SemiRingProduct f sr
-> m (Maybe r)
WSum.prodEvalM (\Term h
a Term h
b -> forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (forall v. SupportTermOps v => v -> v -> v
bvAnd Term h
a Term h
b)) forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr SemiRingProduct (Expr t) sr
pd
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w) forall a b. (a -> b) -> a -> b
$ forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (forall (w :: Natural). NatRepr w -> BV w
BV.maxUnsigned NatRepr w
w))
(forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w))
Maybe (Term h)
pd'
SemiRingRepr sr
sr ->
do forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkNonlinearSupport Expr t tp
i
Maybe (Term h)
pd' <- forall (m :: Type -> Type) r (f :: BaseType -> Type)
(sr :: SemiRing).
Monad m =>
(r -> r -> m r)
-> (f (SemiRingBase sr) -> m r)
-> SemiRingProduct f sr
-> m (Maybe r)
WSum.prodEvalM (\Term h
a Term h
b -> forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Term h
a forall a. Num a => a -> a -> a
* Term h
b)) forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr SemiRingProduct (Expr t) sr
pd
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr (forall (sr :: SemiRing).
SemiRingRepr sr -> TypeMap (SemiRingBase sr)
semiRingTypeMap SemiRingRepr sr
sr) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => Integer -> v
integerTerm Integer
1)
(forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (sr :: SemiRing).
SemiRingRepr sr -> TypeMap (SemiRingBase sr)
semiRingTypeMap SemiRingRepr sr
sr))
Maybe (Term h)
pd'
SemiRingSum WeightedSum (Expr t) sr
s ->
case forall (f :: BaseType -> Type) (sr :: SemiRing).
WeightedSum f sr -> SemiRingRepr sr
WSum.sumRepr WeightedSum (Expr t) sr
s of
SemiRingRepr sr
SR.SemiRingIntegerRepr ->
let smul :: Integer -> Expr t tp -> ReaderT (SMTCollectorState t h) IO [Term h]
smul Integer
c Expr t tp
e
| Integer
c forall a. Eq a => a -> a -> Bool
== Integer
1 = (forall a. a -> [a] -> [a]
:[]) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t tp
e
| Integer
c forall a. Eq a => a -> a -> Bool
== -Integer
1 = (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a
negate forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t tp
e
| Bool
otherwise = (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall v. SupportTermOps v => Integer -> v
integerTerm Integer
c forall a. Num a => a -> a -> a
*) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t tp
e
cnst :: Integer -> [a]
cnst Integer
0 = []
cnst Integer
x = [forall v. SupportTermOps v => Integer -> v
integerTerm Integer
x]
add :: [a] -> [a] -> f [a]
add [a]
x [a]
y = forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([a]
y forall a. [a] -> [a] -> [a]
++ [a]
x)
in
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap 'BaseIntegerType
IntegerTypeMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. SupportTermOps v => [v] -> v
sumExpr
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: Type -> Type) r (sr :: SemiRing)
(f :: BaseType -> Type).
Monad m =>
(r -> r -> m r)
-> (Coefficient sr -> f (SemiRingBase sr) -> m r)
-> (Coefficient sr -> m r)
-> WeightedSum f sr
-> m r
WSum.evalM forall {f :: Type -> Type} {a}.
Applicative f =>
[a] -> [a] -> f [a]
add forall {h} {t} {tp :: BaseType}.
SMTWriter h =>
Integer -> Expr t tp -> ReaderT (SMTCollectorState t h) IO [Term h]
smul (forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. SupportTermOps a => Integer -> [a]
cnst) WeightedSum (Expr t) sr
s
SemiRingRepr sr
SR.SemiRingRealRepr ->
let smul :: Rational
-> Expr t tp -> ReaderT (SMTCollectorState t h) IO [Term h]
smul Rational
c Expr t tp
e
| Rational
c forall a. Eq a => a -> a -> Bool
== Rational
1 = (forall a. a -> [a] -> [a]
:[]) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t tp
e
| Rational
c forall a. Eq a => a -> a -> Bool
== -Rational
1 = (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a
negate forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t tp
e
| Bool
otherwise = (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall v. SupportTermOps v => Rational -> v
rationalTerm Rational
c forall a. Num a => a -> a -> a
*) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t tp
e
cnst :: Rational -> [a]
cnst Rational
0 = []
cnst Rational
x = [forall v. SupportTermOps v => Rational -> v
rationalTerm Rational
x]
add :: [a] -> [a] -> f [a]
add [a]
x [a]
y = forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([a]
y forall a. [a] -> [a] -> [a]
++ [a]
x)
in
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap 'BaseRealType
RealTypeMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. SupportTermOps v => [v] -> v
sumExpr
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: Type -> Type) r (sr :: SemiRing)
(f :: BaseType -> Type).
Monad m =>
(r -> r -> m r)
-> (Coefficient sr -> f (SemiRingBase sr) -> m r)
-> (Coefficient sr -> m r)
-> WeightedSum f sr
-> m r
WSum.evalM forall {f :: Type -> Type} {a}.
Applicative f =>
[a] -> [a] -> f [a]
add forall {h} {t} {tp :: BaseType}.
SMTWriter h =>
Rational
-> Expr t tp -> ReaderT (SMTCollectorState t h) IO [Term h]
smul (forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. SupportTermOps a => Rational -> [a]
cnst) WeightedSum (Expr t) sr
s
SR.SemiRingBVRepr BVFlavorRepr fv
SR.BVArithRepr NatRepr w
w ->
let smul :: BV w
-> Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO [Term h]
smul BV w
c Expr t (BaseBVType w)
e
| BV w
c forall a. Eq a => a -> a -> Bool
== forall (w :: Natural). (1 <= w) => NatRepr w -> BV w
BV.one NatRepr w
w = (forall a. a -> [a] -> [a]
:[]) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
e
| BV w
c forall a. Eq a => a -> a -> Bool
== forall (w :: Natural). NatRepr w -> BV w
BV.maxUnsigned NatRepr w
w = (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. SupportTermOps v => v -> v
bvNeg forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
e
| Bool
otherwise = (forall a. a -> [a] -> [a]
:[]) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall v. SupportTermOps v => v -> v -> v
bvMul (forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w BV w
c)) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
e
cnst :: BV w -> [Term h]
cnst (BV.BV Integer
0) = []
cnst BV w
x = [forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w BV w
x]
add :: [a] -> [a] -> f [a]
add [a]
x [a]
y = forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([a]
y forall a. [a] -> [a] -> [a]
++ [a]
x)
in
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v (w :: Natural). SupportTermOps v => NatRepr w -> [v] -> v
bvSumExpr NatRepr w
w
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: Type -> Type) r (sr :: SemiRing)
(f :: BaseType -> Type).
Monad m =>
(r -> r -> m r)
-> (Coefficient sr -> f (SemiRingBase sr) -> m r)
-> (Coefficient sr -> m r)
-> WeightedSum f sr
-> m r
WSum.evalM forall {f :: Type -> Type} {a}.
Applicative f =>
[a] -> [a] -> f [a]
add BV w
-> Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO [Term h]
smul (forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. BV w -> [Term h]
cnst) WeightedSum (Expr t) sr
s
SR.SemiRingBVRepr BVFlavorRepr fv
SR.BVBitsRepr NatRepr w
w ->
let smul :: BV w
-> Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO [Term h]
smul BV w
c Expr t (BaseBVType w)
e
| BV w
c forall a. Eq a => a -> a -> Bool
== forall (w :: Natural). NatRepr w -> BV w
BV.maxUnsigned NatRepr w
w = (forall a. a -> [a] -> [a]
:[]) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
e
| Bool
otherwise = (forall a. a -> [a] -> [a]
:[]) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall v. SupportTermOps v => v -> v -> v
bvAnd (forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w BV w
c)) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
e
cnst :: BV w -> [Term h]
cnst (BV.BV Integer
0) = []
cnst BV w
x = [forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w BV w
x]
add :: [a] -> [a] -> f [a]
add [a]
x [a]
y = forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([a]
y forall a. [a] -> [a] -> [a]
++ [a]
x)
xorsum :: [Term h] -> Term h
xorsum [] = forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (forall (w :: Natural). NatRepr w -> BV w
BV.zero NatRepr w
w)
xorsum [Term h]
xs = forall (t :: Type -> Type) a.
Foldable t =>
(a -> a -> a) -> t a -> a
foldr1 forall v. SupportTermOps v => v -> v -> v
bvXor [Term h]
xs
in
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Term h] -> Term h
xorsum
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: Type -> Type) r (sr :: SemiRing)
(f :: BaseType -> Type).
Monad m =>
(r -> r -> m r)
-> (Coefficient sr -> f (SemiRingBase sr) -> m r)
-> (Coefficient sr -> m r)
-> WeightedSum f sr
-> m r
WSum.evalM forall {f :: Type -> Type} {a}.
Applicative f =>
[a] -> [a] -> f [a]
add BV w
-> Expr t (BaseBVType w)
-> ReaderT (SMTCollectorState t h) IO [Term h]
smul (forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. BV w -> [Term h]
cnst) WeightedSum (Expr t) sr
s
RealDiv Expr t 'BaseRealType
xe Expr t 'BaseRealType
ye -> do
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t 'BaseRealType
xe
case Expr t 'BaseRealType
ye of
SemiRingLiteral SemiRingRepr sr
SR.SemiRingRealRepr Coefficient sr
r ProgramLoc
_ | Coefficient sr
r forall a. Eq a => a -> a -> Bool
/= Rational
0 -> do
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap 'BaseRealType
RealTypeMap forall a b. (a -> b) -> a -> b
$ Term h
x forall a. Num a => a -> a -> a
* forall v. SupportTermOps v => Rational -> v
rationalTerm (forall a. Fractional a => a -> a
recip Coefficient sr
r)
Expr t 'BaseRealType
_ -> do
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkNonlinearSupport Expr t tp
i
Term h
y <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t 'BaseRealType
ye
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap 'BaseRealType
RealTypeMap forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
realDiv Term h
x Term h
y
RealSqrt Expr t 'BaseRealType
xe -> do
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkNonlinearSupport Expr t tp
i
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t 'BaseRealType
xe
SMTExpr h 'BaseRealType
nm <- forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
"real sqrt" TypeMap 'BaseRealType
RealTypeMap
let v :: Term h
v = forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h 'BaseRealType
nm
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"real sqrt" forall a b. (a -> b) -> a -> b
$ Term h
v forall a. Num a => a -> a -> a
* Term h
v forall v. SupportTermOps v => v -> v -> v
.== Term h
x forall v. SupportTermOps v => v -> v -> v
.|| Term h
x forall v. SupportTermOps v => v -> v -> v
.< Term h
0
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"real sqrt" forall a b. (a -> b) -> a -> b
$ Term h
v forall v. SupportTermOps v => v -> v -> v
.>= Term h
0
forall (m :: Type -> Type) a. Monad m => a -> m a
return SMTExpr h 'BaseRealType
nm
RealSpecialFunction SpecialFunction args
fn (SFn.SpecialFnArgs Assignment (SpecialFnArg (Expr t) 'BaseRealType) args
args) -> do
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkComputableSupport Expr t tp
i
let sf1 :: (Term h -> Term h) ->
Ctx.Assignment (SFn.SpecialFnArg (Expr t) BaseRealType) (Ctx.EmptyCtx Ctx.::> SFn.R) ->
SMTCollector t h (SMTExpr h BaseRealType)
sf1 :: (Term h -> Term h)
-> Assignment
(SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
-> SMTCollector t h (SMTExpr h 'BaseRealType)
sf1 Term h -> Term h
tmfn (Assignment (SpecialFnArg (Expr t) 'BaseRealType) ctx
Ctx.Empty Ctx.:> SFn.SpecialFnArg Expr t 'BaseRealType
xe) =
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap 'BaseRealType
RealTypeMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term h -> Term h
tmfn forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t 'BaseRealType
xe
case SpecialFunction args
fn of
SpecialFunction args
SFn.Sin -> (Term h -> Term h)
-> Assignment
(SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
-> SMTCollector t h (SMTExpr h 'BaseRealType)
sf1 forall v. SupportTermOps v => v -> v
realSin Assignment (SpecialFnArg (Expr t) 'BaseRealType) args
args
SpecialFunction args
SFn.Cos -> (Term h -> Term h)
-> Assignment
(SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
-> SMTCollector t h (SMTExpr h 'BaseRealType)
sf1 forall v. SupportTermOps v => v -> v
realCos Assignment (SpecialFnArg (Expr t) 'BaseRealType) args
args
SpecialFunction args
SFn.Tan -> (Term h -> Term h)
-> Assignment
(SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
-> SMTCollector t h (SMTExpr h 'BaseRealType)
sf1 forall v. SupportTermOps v => v -> v
realTan Assignment (SpecialFnArg (Expr t) 'BaseRealType) args
args
SpecialFunction args
SFn.Sinh -> (Term h -> Term h)
-> Assignment
(SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
-> SMTCollector t h (SMTExpr h 'BaseRealType)
sf1 forall v. SupportTermOps v => v -> v
realSinh Assignment (SpecialFnArg (Expr t) 'BaseRealType) args
args
SpecialFunction args
SFn.Cosh -> (Term h -> Term h)
-> Assignment
(SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
-> SMTCollector t h (SMTExpr h 'BaseRealType)
sf1 forall v. SupportTermOps v => v -> v
realCosh Assignment (SpecialFnArg (Expr t) 'BaseRealType) args
args
SpecialFunction args
SFn.Tanh -> (Term h -> Term h)
-> Assignment
(SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
-> SMTCollector t h (SMTExpr h 'BaseRealType)
sf1 forall v. SupportTermOps v => v -> v
realTanh Assignment (SpecialFnArg (Expr t) 'BaseRealType) args
args
SpecialFunction args
SFn.Exp -> (Term h -> Term h)
-> Assignment
(SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
-> SMTCollector t h (SMTExpr h 'BaseRealType)
sf1 forall v. SupportTermOps v => v -> v
realExp Assignment (SpecialFnArg (Expr t) 'BaseRealType) args
args
SpecialFunction args
SFn.Log -> (Term h -> Term h)
-> Assignment
(SpecialFnArg (Expr t) 'BaseRealType) (EmptyCtx ::> R)
-> SMTCollector t h (SMTExpr h 'BaseRealType)
sf1 forall v. SupportTermOps v => v -> v
realLog Assignment (SpecialFnArg (Expr t) 'BaseRealType) args
args
SpecialFunction args
SFn.Arctan2 ->
case Assignment (SpecialFnArg (Expr t) 'BaseRealType) args
args of
Assignment (SpecialFnArg (Expr t) 'BaseRealType) ctx
Ctx.Empty Ctx.:> SFn.SpecialFnArg Expr t 'BaseRealType
ye Ctx.:> SFn.SpecialFnArg Expr t 'BaseRealType
xe ->
do Term h
y <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t 'BaseRealType
ye
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t 'BaseRealType
xe
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap 'BaseRealType
RealTypeMap forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
realATan2 Term h
y Term h
x
SpecialFunction args
_ -> forall (m :: Type -> Type) t (tp :: BaseType) a.
MonadFail m =>
Expr t tp -> m a
unsupportedTerm Expr t tp
i
BVUnaryTerm UnaryBV (Expr t BaseBoolType) n
t -> do
let w :: NatRepr n
w = forall p (n :: Natural). UnaryBV p n -> NatRepr n
UnaryBV.width UnaryBV (Expr t BaseBoolType) n
t
let entries :: [(Expr t BaseBoolType, Integer, Integer)]
entries = forall p (n :: Natural). UnaryBV p n -> [(p, Integer, Integer)]
UnaryBV.unsignedRanges UnaryBV (Expr t BaseBoolType) n
t
SMTExpr h ('BaseBVType n)
nm <- forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
"unary term" (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr n
w)
let nm_s :: Term h
nm_s = forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h ('BaseBVType n)
nm
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Expr t BaseBoolType, Integer, Integer)]
entries forall a b. (a -> b) -> a -> b
$ \(Expr t BaseBoolType
pr,Integer
l,Integer
u) -> do
Term h
q <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseBoolType
pr
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"unary term" forall a b. (a -> b) -> a -> b
$ Term h
q forall v. SupportTermOps v => v -> v -> v
.== Term h
nm_s forall v. SupportTermOps v => v -> v -> v
`bvULe` forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr n
w (forall (w :: Natural). NatRepr w -> Integer -> BV w
BV.mkBV NatRepr n
w Integer
l)
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"unary term" forall a b. (a -> b) -> a -> b
$ Term h
q forall v. SupportTermOps v => v -> v -> v
.== Term h
nm_s forall v. SupportTermOps v => v -> v -> v
`bvULe` forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr n
w (forall (w :: Natural). NatRepr w -> Integer -> BV w
BV.mkBV NatRepr n
w Integer
u)
case [(Expr t BaseBoolType, Integer, Integer)]
entries of
(Expr t BaseBoolType
_, Integer
l, Integer
_):[(Expr t BaseBoolType, Integer, Integer)]
_ | Integer
l forall a. Ord a => a -> a -> Bool
> Integer
0 -> do
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"unary term" forall a b. (a -> b) -> a -> b
$ forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr n
w (forall (w :: Natural). NatRepr w -> Integer -> BV w
BV.mkBV NatRepr n
w Integer
l) forall v. SupportTermOps v => v -> v -> v
`bvULe` Term h
nm_s
[(Expr t BaseBoolType, Integer, Integer)]
_ ->
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return SMTExpr h ('BaseBVType n)
nm
BVOrBits NatRepr w
w BVOrSet (Expr t) w
bs ->
do [Term h]
bs' <- forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr (forall (e :: BaseType -> Type) (w :: Natural).
BVOrSet e w -> [e (BaseBVType w)]
bvOrToList BVOrSet (Expr t) w
bs)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w) forall a b. (a -> b) -> a -> b
$!
case [Term h]
bs' of
[] -> forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (forall (w :: Natural). NatRepr w -> BV w
BV.zero NatRepr w
w)
Term h
x:[Term h]
xs -> forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall v. SupportTermOps v => v -> v -> v
bvOr Term h
x [Term h]
xs
BVConcat NatRepr (u + v)
w Expr t (BaseBVType u)
xe Expr t (BaseBVType v)
ye -> do
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType u)
xe
Term h
y <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType v)
ye
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr (u + v)
w) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
bvConcat Term h
x Term h
y
BVSelect NatRepr idx
idx NatRepr n
n Expr t (BaseBVType w)
xe -> do
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
xe
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr n
n) forall a b. (a -> b) -> a -> b
$ forall v (w :: Natural).
SupportTermOps v =>
NatRepr w -> Natural -> Natural -> v -> v
bvExtract (forall (e :: BaseType -> Type) (w :: Natural).
IsExpr e =>
e (BaseBVType w) -> NatRepr w
bvWidth Expr t (BaseBVType w)
xe) (forall (n :: Natural). NatRepr n -> Natural
natValue NatRepr idx
idx) (forall (n :: Natural). NatRepr n -> Natural
natValue NatRepr n
n) Term h
x
BVUdiv NatRepr w
w Expr t ('BaseBVType w)
xe Expr t ('BaseBVType w)
ye -> do
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseBVType w)
xe
Term h
y <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseBVType w)
ye
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
bvUDiv Term h
x Term h
y
BVUrem NatRepr w
w Expr t ('BaseBVType w)
xe Expr t ('BaseBVType w)
ye -> do
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseBVType w)
xe
Term h
y <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseBVType w)
ye
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
bvURem Term h
x Term h
y
BVSdiv NatRepr w
w Expr t ('BaseBVType w)
xe Expr t ('BaseBVType w)
ye -> do
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseBVType w)
xe
Term h
y <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseBVType w)
ye
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
bvSDiv Term h
x Term h
y
BVSrem NatRepr w
w Expr t ('BaseBVType w)
xe Expr t ('BaseBVType w)
ye -> do
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseBVType w)
xe
Term h
y <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseBVType w)
ye
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
bvSRem Term h
x Term h
y
BVShl NatRepr w
w Expr t ('BaseBVType w)
xe Expr t ('BaseBVType w)
ye -> do
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseBVType w)
xe
Term h
y <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseBVType w)
ye
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
bvShl Term h
x Term h
y
BVLshr NatRepr w
w Expr t ('BaseBVType w)
xe Expr t ('BaseBVType w)
ye -> do
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseBVType w)
xe
Term h
y <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseBVType w)
ye
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
bvLshr Term h
x Term h
y
BVAshr NatRepr w
w Expr t ('BaseBVType w)
xe Expr t ('BaseBVType w)
ye -> do
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseBVType w)
xe
Term h
y <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseBVType w)
ye
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
bvAshr Term h
x Term h
y
BVRol NatRepr w
w Expr t ('BaseBVType w)
xe Expr t ('BaseBVType w)
ye -> do
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseBVType w)
xe
Term h
y <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseBVType w)
ye
let w' :: Term h
w' = forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (forall (w :: Natural). NatRepr w -> BV w
BV.width NatRepr w
w)
Term h
y' <- forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
bvURem Term h
y Term h
w')
let lo :: Term h
lo = forall v. SupportTermOps v => v -> v -> v
bvLshr Term h
x (forall v. SupportTermOps v => v -> v -> v
bvSub Term h
w' Term h
y')
let hi :: Term h
hi = forall v. SupportTermOps v => v -> v -> v
bvShl Term h
x Term h
y'
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
bvXor Term h
hi Term h
lo
BVRor NatRepr w
w Expr t ('BaseBVType w)
xe Expr t ('BaseBVType w)
ye -> do
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseBVType w)
xe
Term h
y <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseBVType w)
ye
let w' :: Term h
w' = forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (forall (w :: Natural). NatRepr w -> BV w
BV.width NatRepr w
w)
Term h
y' <- forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
bvURem Term h
y Term h
w')
let lo :: Term h
lo = forall v. SupportTermOps v => v -> v -> v
bvLshr Term h
x Term h
y'
let hi :: Term h
hi = forall v. SupportTermOps v => v -> v -> v
bvShl Term h
x (forall v. SupportTermOps v => v -> v -> v
bvSub Term h
w' Term h
y')
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
bvXor Term h
hi Term h
lo
BVZext NatRepr r
w' Expr t (BaseBVType w)
xe -> do
let w :: NatRepr w
w = forall (e :: BaseType -> Type) (w :: Natural).
IsExpr e =>
e (BaseBVType w) -> NatRepr w
bvWidth Expr t (BaseBVType w)
xe
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
xe
let n :: Integer
n = forall (w :: Natural). NatRepr w -> Integer
intValue NatRepr r
w' forall a. Num a => a -> a -> a
- forall (w :: Natural). NatRepr w -> Integer
intValue NatRepr w
w
case forall a. Integral a => a -> Maybe (Some NatRepr)
someNat Integer
n of
Just (Some NatRepr x
w2) | Just LeqProof 1 r
LeqProof <- forall (n :: Natural). NatRepr n -> Maybe (LeqProof 1 n)
isPosNat NatRepr r
w' -> do
let zeros :: Term h
zeros = forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr x
w2 (forall (w :: Natural). NatRepr w -> BV w
BV.zero NatRepr x
w2)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr r
w') forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
bvConcat Term h
zeros Term h
x
Maybe (Some NatRepr)
_ -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"invalid zero extension"
BVSext NatRepr r
w' Expr t (BaseBVType w)
xe -> do
let w :: NatRepr w
w = forall (e :: BaseType -> Type) (w :: Natural).
IsExpr e =>
e (BaseBVType w) -> NatRepr w
bvWidth Expr t (BaseBVType w)
xe
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
xe
let n :: Integer
n = forall (w :: Natural). NatRepr w -> Integer
intValue NatRepr r
w' forall a. Num a => a -> a -> a
- forall (w :: Natural). NatRepr w -> Integer
intValue NatRepr w
w
case forall a. Integral a => a -> Maybe (Some NatRepr)
someNat Integer
n of
Just (Some NatRepr x
w2) | Just LeqProof 1 r
LeqProof <- forall (n :: Natural). NatRepr n -> Maybe (LeqProof 1 n)
isPosNat NatRepr r
w' -> do
let zeros :: Term h
zeros = forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr x
w2 (forall (w :: Natural). NatRepr w -> BV w
BV.zero NatRepr x
w2)
let ones :: Term h
ones = forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr x
w2 (forall (w :: Natural). NatRepr w -> BV w
BV.maxUnsigned NatRepr x
w2)
let sgn :: Term h
sgn = forall v (w :: Natural).
SupportTermOps v =>
NatRepr w -> Natural -> v -> v
bvTestBit NatRepr w
w (forall (n :: Natural). NatRepr n -> Natural
natValue NatRepr w
w forall a. Num a => a -> a -> a
- Natural
1) Term h
x
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr r
w') forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
bvConcat (forall v. SupportTermOps v => v -> v -> v -> v
ite Term h
sgn Term h
ones Term h
zeros) Term h
x
Maybe (Some NatRepr)
_ -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"invalid sign extension"
BVFill NatRepr w
w Expr t BaseBoolType
xe ->
do Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t BaseBoolType
xe
let zeros :: Term h
zeros = forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (forall (w :: Natural). NatRepr w -> BV w
BV.zero NatRepr w
w)
let ones :: Term h
ones = forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (forall (w :: Natural). NatRepr w -> BV w
BV.maxUnsigned NatRepr w
w)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v -> v
ite Term h
x Term h
ones Term h
zeros
BVPopcount NatRepr w
w Expr t ('BaseBVType w)
xe ->
do Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseBVType w)
xe
let zs :: [Term h]
zs = [ forall v. SupportTermOps v => v -> v -> v -> v
ite (forall v (w :: Natural).
SupportTermOps v =>
NatRepr w -> Natural -> v -> v
bvTestBit NatRepr w
w Natural
idx Term h
x) (forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (forall (w :: Natural). (1 <= w) => NatRepr w -> BV w
BV.one NatRepr w
w)) (forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (forall (w :: Natural). NatRepr w -> BV w
BV.zero NatRepr w
w))
| Natural
idx <- [ Natural
0 .. forall (n :: Natural). NatRepr n -> Natural
natValue NatRepr w
w forall a. Num a => a -> a -> a
- Natural
1 ]
]
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w) forall a b. (a -> b) -> a -> b
$! forall v (w :: Natural). SupportTermOps v => NatRepr w -> [v] -> v
bvSumExpr NatRepr w
w [Term h]
zs
BVCountLeadingZeros NatRepr w
w Expr t ('BaseBVType w)
xe ->
do Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseBVType w)
xe
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w) forall a b. (a -> b) -> a -> b
$! Natural -> Term h -> Term h
go Natural
0 Term h
x
where
go :: Natural -> Term h -> Term h
go !Natural
idx Term h
x
| Natural
idx forall a. Ord a => a -> a -> Bool
< forall (n :: Natural). NatRepr n -> Natural
natValue NatRepr w
w = forall v. SupportTermOps v => v -> v -> v -> v
ite (forall v (w :: Natural).
SupportTermOps v =>
NatRepr w -> Natural -> v -> v
bvTestBit NatRepr w
w (forall (n :: Natural). NatRepr n -> Natural
natValue NatRepr w
w forall a. Num a => a -> a -> a
- Natural
idx forall a. Num a => a -> a -> a
- Natural
1) Term h
x) (forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (forall (w :: Natural). NatRepr w -> Integer -> BV w
BV.mkBV NatRepr w
w (forall a. Integral a => a -> Integer
toInteger Natural
idx))) (Natural -> Term h -> Term h
go (Natural
idxforall a. Num a => a -> a -> a
+Natural
1) Term h
x)
| Bool
otherwise = forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (forall (w :: Natural). NatRepr w -> BV w
BV.width NatRepr w
w)
BVCountTrailingZeros NatRepr w
w Expr t ('BaseBVType w)
xe ->
do Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseBVType w)
xe
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w) forall a b. (a -> b) -> a -> b
$! Natural -> Term h -> Term h
go Natural
0 Term h
x
where
go :: Natural -> Term h -> Term h
go !Natural
idx Term h
x
| Natural
idx forall a. Ord a => a -> a -> Bool
< forall (n :: Natural). NatRepr n -> Natural
natValue NatRepr w
w = forall v. SupportTermOps v => v -> v -> v -> v
ite (forall v (w :: Natural).
SupportTermOps v =>
NatRepr w -> Natural -> v -> v
bvTestBit NatRepr w
w Natural
idx Term h
x) (forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (forall (w :: Natural). NatRepr w -> Integer -> BV w
BV.mkBV NatRepr w
w (forall a. Integral a => a -> Integer
toInteger Natural
idx))) (Natural -> Term h -> Term h
go (Natural
idxforall a. Num a => a -> a -> a
+Natural
1) Term h
x)
| Bool
otherwise = forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w (forall (w :: Natural). NatRepr w -> BV w
BV.width NatRepr w
w)
StringLength Expr t (BaseStringType si)
xe -> do
case forall (e :: BaseType -> Type) (si :: StringInfo).
IsExpr e =>
e (BaseStringType si) -> StringInfoRepr si
stringInfo Expr t (BaseStringType si)
xe of
StringInfoRepr si
UnicodeRepr -> do
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkStringSupport Expr t tp
i
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseStringType si)
xe
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap 'BaseIntegerType
IntegerTypeMap forall a b. (a -> b) -> a -> b
$ forall h. SMTWriter h => Term h -> Term h
stringLength @h Term h
x
StringInfoRepr si
si -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
"Unsupported symbolic string length operation " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show StringInfoRepr si
si)
StringIndexOf Expr t (BaseStringType si)
xe Expr t (BaseStringType si)
ye Expr t 'BaseIntegerType
ke ->
case forall (e :: BaseType -> Type) (si :: StringInfo).
IsExpr e =>
e (BaseStringType si) -> StringInfoRepr si
stringInfo Expr t (BaseStringType si)
xe of
StringInfoRepr si
UnicodeRepr -> do
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkStringSupport Expr t tp
i
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseStringType si)
xe
Term h
y <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseStringType si)
ye
Term h
k <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t 'BaseIntegerType
ke
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap 'BaseIntegerType
IntegerTypeMap forall a b. (a -> b) -> a -> b
$ forall h. SMTWriter h => Term h -> Term h -> Term h -> Term h
stringIndexOf @h Term h
x Term h
y Term h
k
StringInfoRepr si
si -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
"Unsupported symbolic string index-of operation " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show StringInfoRepr si
si)
StringSubstring StringInfoRepr si
_ Expr t ('BaseStringType si)
xe Expr t 'BaseIntegerType
offe Expr t 'BaseIntegerType
lene ->
case forall (e :: BaseType -> Type) (si :: StringInfo).
IsExpr e =>
e (BaseStringType si) -> StringInfoRepr si
stringInfo Expr t ('BaseStringType si)
xe of
StringInfoRepr si
UnicodeRepr -> do
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkStringSupport Expr t tp
i
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseStringType si)
xe
Term h
off <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t 'BaseIntegerType
offe
Term h
len <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t 'BaseIntegerType
lene
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap ('BaseStringType Unicode)
UnicodeTypeMap forall a b. (a -> b) -> a -> b
$ forall h. SMTWriter h => Term h -> Term h -> Term h -> Term h
stringSubstring @h Term h
x Term h
off Term h
len
StringInfoRepr si
si -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
"Unsupported symbolic string substring operation " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show StringInfoRepr si
si)
StringContains Expr t (BaseStringType si)
xe Expr t (BaseStringType si)
ye ->
case forall (e :: BaseType -> Type) (si :: StringInfo).
IsExpr e =>
e (BaseStringType si) -> StringInfoRepr si
stringInfo Expr t (BaseStringType si)
xe of
StringInfoRepr si
UnicodeRepr -> do
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkStringSupport Expr t tp
i
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseStringType si)
xe
Term h
y <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseStringType si)
ye
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall h. SMTWriter h => Term h -> Term h -> Term h
stringContains @h Term h
x Term h
y
StringInfoRepr si
si -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
"Unsupported symbolic string contains operation " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show StringInfoRepr si
si)
StringIsPrefixOf Expr t (BaseStringType si)
xe Expr t (BaseStringType si)
ye ->
case forall (e :: BaseType -> Type) (si :: StringInfo).
IsExpr e =>
e (BaseStringType si) -> StringInfoRepr si
stringInfo Expr t (BaseStringType si)
xe of
StringInfoRepr si
UnicodeRepr -> do
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkStringSupport Expr t tp
i
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseStringType si)
xe
Term h
y <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseStringType si)
ye
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall h. SMTWriter h => Term h -> Term h -> Term h
stringIsPrefixOf @h Term h
x Term h
y
StringInfoRepr si
si -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
"Unsupported symbolic string is-prefix-of operation " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show StringInfoRepr si
si)
StringIsSuffixOf Expr t (BaseStringType si)
xe Expr t (BaseStringType si)
ye ->
case forall (e :: BaseType -> Type) (si :: StringInfo).
IsExpr e =>
e (BaseStringType si) -> StringInfoRepr si
stringInfo Expr t (BaseStringType si)
xe of
StringInfoRepr si
UnicodeRepr -> do
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkStringSupport Expr t tp
i
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseStringType si)
xe
Term h
y <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseStringType si)
ye
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall h. SMTWriter h => Term h -> Term h -> Term h
stringIsSuffixOf @h Term h
x Term h
y
StringInfoRepr si
si -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
"Unsupported symbolic string is-suffix-of operation " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show StringInfoRepr si
si)
StringAppend StringInfoRepr si
si StringSeq (Expr t) si
xes ->
case StringInfoRepr si
si of
StringInfoRepr si
UnicodeRepr -> do
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkStringSupport Expr t tp
i
let f :: StringSeqEntry (Expr t) Unicode
-> ReaderT (SMTCollectorState t h) IO (Term h)
f (SSeq.StringSeqLiteral StringLiteral Unicode
l) = forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall h. SMTWriter h => Text -> Term h
stringTerm @h forall a b. (a -> b) -> a -> b
$ StringLiteral Unicode -> Text
fromUnicodeLit StringLiteral Unicode
l
f (SSeq.StringSeqTerm Expr t ('BaseStringType Unicode)
t) = forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseStringType Unicode)
t
[Term h]
xs <- forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM StringSeqEntry (Expr t) Unicode
-> ReaderT (SMTCollectorState t h) IO (Term h)
f forall a b. (a -> b) -> a -> b
$ forall (e :: BaseType -> Type) (si :: StringInfo).
StringSeq e si -> [StringSeqEntry e si]
SSeq.toList StringSeq (Expr t) si
xes
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap ('BaseStringType Unicode)
UnicodeTypeMap forall a b. (a -> b) -> a -> b
$ forall h. SMTWriter h => [Term h] -> Term h
stringAppend @h [Term h]
xs
StringInfoRepr si
_ -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
"Unsupported symbolic string append operation " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show StringInfoRepr si
si)
FloatNeg FloatPrecisionRepr fpp
fpp Expr t ('BaseFloatType fpp)
x -> do
Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
x
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v
floatNeg Term h
xe
FloatAbs FloatPrecisionRepr fpp
fpp Expr t ('BaseFloatType fpp)
x -> do
Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
x
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v
floatAbs Term h
xe
FloatSqrt FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t ('BaseFloatType fpp)
x -> do
Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
x
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => RoundingMode -> v -> v
floatSqrt RoundingMode
r Term h
xe
FloatAdd FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t ('BaseFloatType fpp)
x Expr t ('BaseFloatType fpp)
y -> do
Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
x
Term h
ye <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
y
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => RoundingMode -> v -> v -> v
floatAdd RoundingMode
r Term h
xe Term h
ye
FloatSub FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t ('BaseFloatType fpp)
x Expr t ('BaseFloatType fpp)
y -> do
Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
x
Term h
ye <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
y
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => RoundingMode -> v -> v -> v
floatSub RoundingMode
r Term h
xe Term h
ye
FloatMul FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t ('BaseFloatType fpp)
x Expr t ('BaseFloatType fpp)
y -> do
Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
x
Term h
ye <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
y
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => RoundingMode -> v -> v -> v
floatMul RoundingMode
r Term h
xe Term h
ye
FloatDiv FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t ('BaseFloatType fpp)
x Expr t ('BaseFloatType fpp)
y -> do
Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
x
Term h
ye <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
y
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => RoundingMode -> v -> v -> v
floatDiv RoundingMode
r Term h
xe Term h
ye
FloatRem FloatPrecisionRepr fpp
fpp Expr t ('BaseFloatType fpp)
x Expr t ('BaseFloatType fpp)
y -> do
Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
x
Term h
ye <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
y
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
floatRem Term h
xe Term h
ye
FloatFMA FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t ('BaseFloatType fpp)
x Expr t ('BaseFloatType fpp)
y Expr t ('BaseFloatType fpp)
z -> do
Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
x
Term h
ye <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
y
Term h
ze <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
z
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => RoundingMode -> v -> v -> v -> v
floatFMA RoundingMode
r Term h
xe Term h
ye Term h
ze
FloatFpEq Expr t (BaseFloatType fpp)
x Expr t (BaseFloatType fpp)
y -> do
Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
Term h
ye <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
y
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
floatFpEq Term h
xe Term h
ye
FloatLe Expr t (BaseFloatType fpp)
x Expr t (BaseFloatType fpp)
y -> do
Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
Term h
ye <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
y
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
floatLe Term h
xe Term h
ye
FloatLt Expr t (BaseFloatType fpp)
x Expr t (BaseFloatType fpp)
y -> do
Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
Term h
ye <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
y
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
floatLt Term h
xe Term h
ye
FloatIsNaN Expr t (BaseFloatType fpp)
x -> do
Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v
floatIsNaN Term h
xe
FloatIsInf Expr t (BaseFloatType fpp)
x -> do
Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v
floatIsInf Term h
xe
FloatIsZero Expr t (BaseFloatType fpp)
x -> do
Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v
floatIsZero Term h
xe
FloatIsPos Expr t (BaseFloatType fpp)
x -> do
Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v
floatIsPos Term h
xe
FloatIsNeg Expr t (BaseFloatType fpp)
x -> do
Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v
floatIsNeg Term h
xe
FloatIsSubnorm Expr t (BaseFloatType fpp)
x -> do
Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v
floatIsSubnorm Term h
xe
FloatIsNorm Expr t (BaseFloatType fpp)
x -> do
Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v
floatIsNorm Term h
xe
FloatCast FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t (BaseFloatType fpp')
x -> do
Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp')
x
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp) forall a b. (a -> b) -> a -> b
$
forall v (fpp :: FloatPrecision).
SupportTermOps v =>
FloatPrecisionRepr fpp -> RoundingMode -> v -> v
floatCast FloatPrecisionRepr fpp
fpp RoundingMode
r Term h
xe
FloatRound FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t ('BaseFloatType fpp)
x -> do
Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t ('BaseFloatType fpp)
x
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp)forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => RoundingMode -> v -> v
floatRound RoundingMode
r Term h
xe
FloatToBinary fpp :: FloatPrecisionRepr (FloatingPointPrecision eb sb)
fpp@(FloatingPointPrecisionRepr NatRepr eb
eb NatRepr sb
sb) Expr t (BaseFloatType (FloatingPointPrecision eb sb))
x -> do
Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType (FloatingPointPrecision eb sb))
x
Term h
val <- forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
"float_binary" forall a b. (a -> b) -> a -> b
$ forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap forall a b. (a -> b) -> a -> b
$ forall (m :: Natural) (n :: Natural).
NatRepr m -> NatRepr n -> NatRepr (m + n)
addNat NatRepr eb
eb NatRepr sb
sb)
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"float_binary" forall a b. (a -> b) -> a -> b
$
forall v (fpp :: FloatPrecision).
SupportTermOps v =>
FloatPrecisionRepr fpp -> v -> v
floatFromBinary FloatPrecisionRepr (FloatingPointPrecision eb sb)
fpp Term h
val forall v. SupportTermOps v => v -> v -> v
.== Term h
xe
let qnan :: Term h
qnan = forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm (forall (m :: Natural) (n :: Natural).
NatRepr m -> NatRepr n -> NatRepr (m + n)
addNat NatRepr eb
eb NatRepr sb
sb) forall a b. (a -> b) -> a -> b
$
forall (w :: Natural). NatRepr w -> Integer -> BV w
BV.mkBV (forall (m :: Natural) (n :: Natural).
NatRepr m -> NatRepr n -> NatRepr (m + n)
addNat NatRepr eb
eb NatRepr sb
sb) forall a b. (a -> b) -> a -> b
$
forall a. Bits a => a -> Int -> a
Bits.shiftL
(Integer
2 forall a b. (Num a, Integral b) => a -> b -> a
^ (forall (n :: Natural). NatRepr n -> Natural
natValue NatRepr eb
eb forall a. Num a => a -> a -> a
+ Natural
1) forall a. Num a => a -> a -> a
- Integer
1)
(forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (n :: Natural). NatRepr n -> Natural
natValue NatRepr sb
sb forall a. Num a => a -> a -> a
- Natural
2))
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap forall a b. (a -> b) -> a -> b
$ forall (m :: Natural) (n :: Natural).
NatRepr m -> NatRepr n -> NatRepr (m + n)
addNat NatRepr eb
eb NatRepr sb
sb) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v -> v
ite (forall v. SupportTermOps v => v -> v
floatIsNaN Term h
xe) Term h
qnan Term h
val
FloatFromBinary FloatPrecisionRepr (FloatingPointPrecision eb sb)
fpp Expr t (BaseBVType (eb + sb))
x -> do
Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType (eb + sb))
x
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr (FloatingPointPrecision eb sb)
fpp) forall a b. (a -> b) -> a -> b
$
forall v (fpp :: FloatPrecision).
SupportTermOps v =>
FloatPrecisionRepr fpp -> v -> v
floatFromBinary FloatPrecisionRepr (FloatingPointPrecision eb sb)
fpp Term h
xe
BVToFloat FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t (BaseBVType w)
x -> do
Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
x
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp) forall a b. (a -> b) -> a -> b
$
forall v (fpp :: FloatPrecision).
SupportTermOps v =>
FloatPrecisionRepr fpp -> RoundingMode -> v -> v
bvToFloat FloatPrecisionRepr fpp
fpp RoundingMode
r Term h
xe
SBVToFloat FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t (BaseBVType w)
x -> do
Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
x
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp) forall a b. (a -> b) -> a -> b
$
forall v (fpp :: FloatPrecision).
SupportTermOps v =>
FloatPrecisionRepr fpp -> RoundingMode -> v -> v
sbvToFloat FloatPrecisionRepr fpp
fpp RoundingMode
r Term h
xe
RealToFloat FloatPrecisionRepr fpp
fpp RoundingMode
r Expr t 'BaseRealType
x -> do
Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t 'BaseRealType
x
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: FloatPrecision).
FloatPrecisionRepr idx -> TypeMap (BaseFloatType idx)
FloatTypeMap FloatPrecisionRepr fpp
fpp) forall a b. (a -> b) -> a -> b
$
forall v (fpp :: FloatPrecision).
SupportTermOps v =>
FloatPrecisionRepr fpp -> RoundingMode -> v -> v
realToFloat FloatPrecisionRepr fpp
fpp RoundingMode
r Term h
xe
FloatToBV NatRepr w
w RoundingMode
r Expr t (BaseFloatType fpp)
x -> do
Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => Natural -> RoundingMode -> v -> v
floatToBV (forall (n :: Natural). NatRepr n -> Natural
natValue NatRepr w
w) RoundingMode
r Term h
xe
FloatToSBV NatRepr w
w RoundingMode
r Expr t (BaseFloatType fpp)
x -> do
Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w) forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => Natural -> RoundingMode -> v -> v
floatToSBV (forall (n :: Natural). NatRepr n -> Natural
natValue NatRepr w
w) RoundingMode
r Term h
xe
FloatToReal Expr t (BaseFloatType fpp)
x -> do
Term h
xe <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseFloatType fpp)
x
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap 'BaseRealType
RealTypeMap forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v
floatToReal Term h
xe
FloatSpecialFunction{} -> forall (m :: Type -> Type) t (tp :: BaseType) a.
MonadFail m =>
Expr t tp -> m a
unsupportedTerm Expr t tp
i
ArrayMap Assignment BaseTypeRepr (i ::> itp)
_ BaseTypeRepr tp1
_ ArrayUpdateMap (Expr t) (i ::> itp) tp1
elts Expr t ('BaseArrayType (i ::> itp) tp1)
def -> do
SMTExpr h ('BaseArrayType (i ::> itp) tp1)
base_array <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t ('BaseArrayType (i ::> itp) tp1)
def
[(Assignment IndexLit (i ::> itp), Term h)]
elt_exprs <- (forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverseforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s t a b. Field2 s t a b => Lens s t a b
_2) forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr (forall (e :: BaseType -> Type) (ctx :: Ctx BaseType)
(tp :: BaseType).
ArrayUpdateMap e ctx tp -> [(Assignment IndexLit ctx, e tp)]
AUM.toList ArrayUpdateMap (Expr t) (i ::> itp) tp1
elts)
let array_type :: TypeMap ('BaseArrayType (i ::> itp) tp1)
array_type = forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h ('BaseArrayType (i ::> itp) tp1)
base_array
case TypeMap ('BaseArrayType (i ::> itp) tp1)
array_type of
PrimArrayTypeMap{} -> do
let set_at_index :: Term h
-> (Ctx.Assignment IndexLit ctx, Term h)
-> Term h
set_at_index :: forall (ctx :: Ctx BaseType).
Term h -> (Assignment IndexLit ctx, Term h) -> Term h
set_at_index Term h
ma (Assignment IndexLit ctx
idx, Term h
elt) =
forall h. SMTWriter h => Term h -> [Term h] -> Term h -> Term h
arrayUpdate @h Term h
ma (forall v (ctx :: Ctx BaseType).
SupportTermOps v =>
Assignment IndexLit ctx -> [v]
mkIndexLitTerms Assignment IndexLit ctx
idx) Term h
elt
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap ('BaseArrayType (i ::> itp) tp1)
array_type forall a b. (a -> b) -> a -> b
$
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (ctx :: Ctx BaseType).
Term h -> (Assignment IndexLit ctx, Term h) -> Term h
set_at_index (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h ('BaseArrayType (i ::> itp) tp1)
base_array) [(Assignment IndexLit (i ::> itp), Term h)]
elt_exprs
FnArrayTypeMap Assignment TypeMap (idxl ::> idx)
idx_types TypeMap tp
resType -> do
case forall v. SupportTermOps v => Maybe (v -> [v] -> v -> v)
smtFnUpdate of
Just Term h -> [Term h] -> Term h -> Term h
updateFn -> do
let set_at_index :: Term h
-> (Ctx.Assignment IndexLit ctx, Term h)
-> Term h
set_at_index :: forall (ctx :: Ctx BaseType).
Term h -> (Assignment IndexLit ctx, Term h) -> Term h
set_at_index Term h
ma (Assignment IndexLit ctx
idx, Term h
elt) =
Term h -> [Term h] -> Term h -> Term h
updateFn Term h
ma (forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type) a.
FoldableFC t =>
(forall (x :: k). f x -> a) -> forall (x :: l). t f x -> [a]
toListFC forall v (tp :: BaseType). SupportTermOps v => IndexLit tp -> v
mkIndexLitTerm Assignment IndexLit ctx
idx) Term h
elt
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap ('BaseArrayType (i ::> itp) tp1)
array_type forall a b. (a -> b) -> a -> b
$
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (ctx :: Ctx BaseType).
Term h -> (Assignment IndexLit ctx, Term h) -> Term h
set_at_index (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h ('BaseArrayType (i ::> itp) tp1)
base_array) [(Assignment IndexLit (i ::> itp), Term h)]
elt_exprs
Maybe (Term h -> [Term h] -> Term h -> Term h)
Nothing -> do
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (forall t h. WriterConn t h -> Bool
supportFunctionDefs WriterConn t h
conn)) forall a b. (a -> b) -> a -> b
$ do
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty (forall t h. WriterConn t h -> String
smtWriterName WriterConn t h
conn) forall ann. Doc ann -> Doc ann -> Doc ann
<+>
Doc Any
"does not support arrays as functions."
[(Text, Some TypeMap)]
args <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall t h (args :: Ctx BaseType).
WriterConn t h
-> Assignment TypeMap args -> IO [(Text, Some TypeMap)]
createTypeMapArgsForArray WriterConn t h
conn Assignment TypeMap (idxl ::> idx)
idx_types
let idx_terms :: [Term h]
idx_terms = forall v. SupportTermOps v => Text -> v
fromText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Some TypeMap)]
args
let base_lookup :: Term h
base_lookup = forall v. SupportTermOps v => v -> [v] -> v
smtFnApp (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h ('BaseArrayType (i ::> itp) tp1)
base_array) [Term h]
idx_terms
let set_at_index :: Term h -> (Assignment IndexLit (i ::> itp), Term h) -> Term h
set_at_index Term h
prev_value (Assignment IndexLit (i ::> itp)
idx_lits, Term h
elt) =
let update_idx :: [Term h]
update_idx = forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type) a.
FoldableFC t =>
(forall (x :: k). f x -> a) -> forall (x :: l). t f x -> [a]
toListFC forall v (tp :: BaseType). SupportTermOps v => IndexLit tp -> v
mkIndexLitTerm Assignment IndexLit (i ::> itp)
idx_lits
cond :: Term h
cond = forall v. SupportTermOps v => [v] -> v
andAll (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall v. SupportTermOps v => v -> v -> v
(.==) [Term h]
update_idx [Term h]
idx_terms)
in forall v. SupportTermOps v => v -> v -> v -> v
ite Term h
cond Term h
elt Term h
prev_value
let expr :: Term h
expr = forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Term h -> (Assignment IndexLit (i ::> itp), Term h) -> Term h
set_at_index Term h
base_lookup [(Assignment IndexLit (i ::> itp), Term h)]
elt_exprs
forall (tp :: BaseType) h. TypeMap tp -> Text -> SMTExpr h tp
SMTName TypeMap ('BaseArrayType (i ::> itp) tp1)
array_type forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (rtp :: BaseType) h t.
[(Text, Some TypeMap)]
-> TypeMap rtp -> Term h -> SMTCollector t h Text
freshBoundFn [(Text, Some TypeMap)]
args TypeMap tp
resType Term h
expr
ConstantArray Assignment BaseTypeRepr (i ::> tp1)
idxRepr BaseTypeRepr b
_bRepr Expr t b
ve -> do
SMTExpr h b
v <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t b
ve
let value_type :: TypeMap b
value_type = forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h b
v
feat :: ProblemFeatures
feat = forall t h. WriterConn t h -> ProblemFeatures
supportedFeatures WriterConn t h
conn
mkArray :: Assignment TypeMap (i ::> tp1)
-> TypeMap b -> TypeMap ('BaseArrayType (i ::> tp1) b)
mkArray = if ProblemFeatures
feat ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useSymbolicArrays
then forall (idx :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
Assignment TypeMap (idx ::> idx)
-> TypeMap tp -> TypeMap (BaseArrayType (idx ::> idx) tp)
PrimArrayTypeMap
else forall (idx :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
Assignment TypeMap (idx ::> idx)
-> TypeMap tp -> TypeMap (BaseArrayType (idx ::> idx) tp)
FnArrayTypeMap
Assignment TypeMap (i ::> tp1)
idx_types <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
(g :: k -> Type) (m :: Type -> Type).
(TraversableFC t, Applicative m) =>
(forall (x :: k). f x -> m (g x))
-> forall (x :: l). t f x -> m (t g x)
traverseFC (forall (m :: Type -> Type) t h ann (tp :: BaseType).
MonadFail m =>
WriterConn t h
-> SMTSource ann -> BaseTypeRepr tp -> m (TypeMap tp)
evalFirstClassTypeRepr WriterConn t h
conn (forall t (tp :: BaseType) ann. Expr t tp -> SMTSource ann
eltSource Expr t tp
i)) Assignment BaseTypeRepr (i ::> tp1)
idxRepr
let tp :: TypeMap ('BaseArrayType (i ::> tp1) b)
tp = Assignment TypeMap (i ::> tp1)
-> TypeMap b -> TypeMap ('BaseArrayType (i ::> tp1) b)
mkArray Assignment TypeMap (i ::> tp1)
idx_types TypeMap b
value_type
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn TypeMap ('BaseArrayType (i ::> tp1) b)
tp)
case forall h. SMTWriter h => Maybe (ArrayConstantFn (Term h))
arrayConstant @h of
Just ArrayConstantFn (Term h)
constFn
| Bool
otherwise -> do
let idx_smt_types :: [Some TypeMap]
idx_smt_types = forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type) a.
FoldableFC t =>
(forall (x :: k). f x -> a) -> forall (x :: l). t f x -> [a]
toListFC forall k (f :: k -> Type) (x :: k). f x -> Some f
Some Assignment TypeMap (i ::> tp1)
idx_types
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap ('BaseArrayType (i ::> tp1) b)
tp forall a b. (a -> b) -> a -> b
$!
ArrayConstantFn (Term h)
constFn [Some TypeMap]
idx_smt_types (forall k (f :: k -> Type) (x :: k). f x -> Some f
Some TypeMap b
value_type) (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h b
v)
Maybe (ArrayConstantFn (Term h))
Nothing -> do
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (forall t h. WriterConn t h -> Bool
supportFunctionDefs WriterConn t h
conn)) forall a b. (a -> b) -> a -> b
$ do
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty (forall t h. WriterConn t h -> String
smtWriterName WriterConn t h
conn) forall ann. Doc ann -> Doc ann -> Doc ann
<+>
Doc Any
"cannot encode constant arrays."
[(Text, Some TypeMap)]
args <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall t h (args :: Ctx BaseType).
WriterConn t h
-> Assignment TypeMap args -> IO [(Text, Some TypeMap)]
createTypeMapArgsForArray WriterConn t h
conn Assignment TypeMap (i ::> tp1)
idx_types
forall (tp :: BaseType) h. TypeMap tp -> Text -> SMTExpr h tp
SMTName TypeMap ('BaseArrayType (i ::> tp1) b)
tp forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (rtp :: BaseType) h t.
[(Text, Some TypeMap)]
-> TypeMap rtp -> Term h -> SMTCollector t h Text
freshBoundFn [(Text, Some TypeMap)]
args TypeMap b
value_type (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h b
v)
SelectArray BaseTypeRepr tp
_bRepr Expr t (BaseArrayType (i ::> tp1) tp)
a Assignment (Expr t) (i ::> tp1)
idx -> do
SMTExpr h (BaseArrayType (i ::> tp1) tp)
aexpr <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t (BaseArrayType (i ::> tp1) tp)
a
[Term h]
idxl <- forall h t (ctx :: Ctx BaseType).
SMTWriter h =>
Assignment (Expr t) ctx -> SMTCollector t h [Term h]
mkIndicesTerms Assignment (Expr t) (i ::> tp1)
idx
forall h (tp :: BaseType) t.
SupportTermOps (Term h) =>
SMTExpr h tp -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm' forall a b. (a -> b) -> a -> b
$ forall h (idxl :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
SMTWriter h =>
SMTExpr h (BaseArrayType (idxl ::> idx) tp)
-> [Term h] -> SMTExpr h tp
smt_array_select SMTExpr h (BaseArrayType (i ::> tp1) tp)
aexpr [Term h]
idxl
UpdateArray BaseTypeRepr b
_bRepr Assignment BaseTypeRepr (i ::> tp1)
_ Expr t ('BaseArrayType (i ::> tp1) b)
a_elt Assignment (Expr t) (i ::> tp1)
idx Expr t b
ve -> do
SMTExpr h ('BaseArrayType (i ::> tp1) b)
a <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t ('BaseArrayType (i ::> tp1) b)
a_elt
[Term h]
updated_idx <- forall h t (ctx :: Ctx BaseType).
SMTWriter h =>
Assignment (Expr t) ctx -> SMTCollector t h [Term h]
mkIndicesTerms Assignment (Expr t) (i ::> tp1)
idx
Term h
value <- forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t b
ve
let array_type :: TypeMap ('BaseArrayType (i ::> tp1) b)
array_type = forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h ('BaseArrayType (i ::> tp1) b)
a
case TypeMap ('BaseArrayType (i ::> tp1) b)
array_type of
PrimArrayTypeMap Assignment TypeMap (idxl ::> idx)
_ TypeMap tp
_ -> do
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap ('BaseArrayType (i ::> tp1) b)
array_type forall a b. (a -> b) -> a -> b
$
forall h. SMTWriter h => Term h -> [Term h] -> Term h -> Term h
arrayUpdate @h (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h ('BaseArrayType (i ::> tp1) b)
a) [Term h]
updated_idx Term h
value
FnArrayTypeMap Assignment TypeMap (idxl ::> idx)
idxTypes TypeMap tp
resType -> do
case forall v. SupportTermOps v => Maybe (v -> [v] -> v -> v)
smtFnUpdate of
Just Term h -> [Term h] -> Term h -> Term h
updateFn -> do
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap ('BaseArrayType (i ::> tp1) b)
array_type forall a b. (a -> b) -> a -> b
$ Term h -> [Term h] -> Term h -> Term h
updateFn (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h ('BaseArrayType (i ::> tp1) b)
a) [Term h]
updated_idx Term h
value
Maybe (Term h -> [Term h] -> Term h -> Term h)
Nothing -> do
[(Text, Some TypeMap)]
args <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall t h (args :: Ctx BaseType).
WriterConn t h
-> Assignment TypeMap args -> IO [(Text, Some TypeMap)]
createTypeMapArgsForArray WriterConn t h
conn Assignment TypeMap (idxl ::> idx)
idxTypes
let idx_terms :: [Term h]
idx_terms = forall v. SupportTermOps v => Text -> v
fromText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Some TypeMap)]
args
let base_array_value :: Term h
base_array_value = forall v. SupportTermOps v => v -> [v] -> v
smtFnApp (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h ('BaseArrayType (i ::> tp1) b)
a) [Term h]
idx_terms
let cond :: Term h
cond = forall v. SupportTermOps v => [v] -> v
andAll (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall v. SupportTermOps v => v -> v -> v
(.==) [Term h]
updated_idx [Term h]
idx_terms)
let expr :: Term h
expr = forall v. SupportTermOps v => v -> v -> v -> v
ite Term h
cond Term h
value Term h
base_array_value
forall (tp :: BaseType) h. TypeMap tp -> Text -> SMTExpr h tp
SMTName TypeMap ('BaseArrayType (i ::> tp1) b)
array_type forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (rtp :: BaseType) h t.
[(Text, Some TypeMap)]
-> TypeMap rtp -> Term h -> SMTCollector t h Text
freshBoundFn [(Text, Some TypeMap)]
args TypeMap tp
resType Term h
expr
CopyArray NatRepr w
_w_repr BaseTypeRepr a
_a_repr Expr t ('BaseArrayType (SingleCtx (BaseBVType w)) a)
dest_arr Expr t (BaseBVType w)
dest_idx Expr t ('BaseArrayType (SingleCtx (BaseBVType w)) a)
src_arr Expr t (BaseBVType w)
src_idx Expr t (BaseBVType w)
len Expr t (BaseBVType w)
_dest_end_idx Expr t (BaseBVType w)
_src_end_idx -> do
SMTExpr h ('BaseArrayType (SingleCtx (BaseBVType w)) a)
dest_arr_typed_expr <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t ('BaseArrayType (SingleCtx (BaseBVType w)) a)
dest_arr
let arr_type :: TypeMap ('BaseArrayType (SingleCtx (BaseBVType w)) a)
arr_type = forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h ('BaseArrayType (SingleCtx (BaseBVType w)) a)
dest_arr_typed_expr
SMTExpr h (BaseBVType w)
dest_idx_typed_expr <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t (BaseBVType w)
dest_idx
let dest_idx_expr :: Term h
dest_idx_expr = forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h (BaseBVType w)
dest_idx_typed_expr
let idx_type :: TypeMap (BaseBVType w)
idx_type = forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h (BaseBVType w)
dest_idx_typed_expr
SMTExpr h ('BaseArrayType (SingleCtx (BaseBVType w)) a)
src_arr_typed_expr <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t ('BaseArrayType (SingleCtx (BaseBVType w)) a)
src_arr
Term h
src_idx_expr <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
src_idx
Term h
len_expr <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
len
SMTExpr h ('BaseArrayType (SingleCtx (BaseBVType w)) a)
res <- forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
"array_copy" TypeMap ('BaseArrayType (SingleCtx (BaseBVType w)) a)
arr_type
CollectorResults h (Term h)
cr <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall t h a. WriterConn t h -> IO a -> IO a
withConnEntryStack WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ forall h t a.
SupportTermOps (Term h) =>
WriterConn t h -> SMTCollector t h a -> IO (CollectorResults h a)
runInSandbox WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ do
Term h
i_expr <- forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
"i" TypeMap (BaseBVType w)
idx_type
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase (forall h (idxl :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
SMTWriter h =>
SMTExpr h (BaseArrayType (idxl ::> idx) tp)
-> [Term h] -> SMTExpr h tp
smt_array_select SMTExpr h ('BaseArrayType (SingleCtx (BaseBVType w)) a)
res [Term h
i_expr]) forall v. SupportTermOps v => v -> v -> v
.==
forall v. SupportTermOps v => v -> v -> v -> v
ite ((forall v. SupportTermOps v => v -> v -> v
bvULe Term h
dest_idx_expr Term h
i_expr) forall v. SupportTermOps v => v -> v -> v
.&& (forall v. SupportTermOps v => v -> v -> v
bvULt Term h
i_expr (forall v. SupportTermOps v => v -> v -> v
bvAdd Term h
dest_idx_expr Term h
len_expr)))
(forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase (forall h (idxl :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
SMTWriter h =>
SMTExpr h (BaseArrayType (idxl ::> idx) tp)
-> [Term h] -> SMTExpr h tp
smt_array_select SMTExpr h ('BaseArrayType (SingleCtx (BaseBVType w)) a)
src_arr_typed_expr [forall v. SupportTermOps v => v -> v -> v
bvAdd Term h
src_idx_expr (forall v. SupportTermOps v => v -> v -> v
bvSub Term h
i_expr Term h
dest_idx_expr)]))
(forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase (forall h (idxl :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
SMTWriter h =>
SMTExpr h (BaseArrayType (idxl ::> idx) tp)
-> [Term h] -> SMTExpr h tp
smt_array_select SMTExpr h ('BaseArrayType (SingleCtx (BaseBVType w)) a)
dest_arr_typed_expr [Term h
i_expr]))
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"array copy" forall a b. (a -> b) -> a -> b
$ forall h. SMTWriter h => CollectorResults h (Term h) -> Term h
forallResult CollectorResults h (Term h)
cr
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"array copy" forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
bvULt Term h
dest_idx_expr (forall v. SupportTermOps v => v -> v -> v
bvAdd Term h
dest_idx_expr Term h
len_expr)
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"array copy" forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
bvULt Term h
src_idx_expr (forall v. SupportTermOps v => v -> v -> v
bvAdd Term h
src_idx_expr Term h
len_expr)
forall (m :: Type -> Type) a. Monad m => a -> m a
return SMTExpr h ('BaseArrayType (SingleCtx (BaseBVType w)) a)
res
SetArray NatRepr w
_w_repr BaseTypeRepr a
_a_repr Expr t ('BaseArrayType (SingleCtx (BaseBVType w)) a)
arr Expr t (BaseBVType w)
idx Expr t a
val Expr t (BaseBVType w)
len Expr t (BaseBVType w)
_end_idx -> do
SMTExpr h ('BaseArrayType (SingleCtx (BaseBVType w)) a)
arr_typed_expr <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t ('BaseArrayType (SingleCtx (BaseBVType w)) a)
arr
let arr_type :: TypeMap ('BaseArrayType (SingleCtx (BaseBVType w)) a)
arr_type = forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h ('BaseArrayType (SingleCtx (BaseBVType w)) a)
arr_typed_expr
SMTExpr h (BaseBVType w)
idx_typed_expr <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t (BaseBVType w)
idx
let idx_expr :: Term h
idx_expr = forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h (BaseBVType w)
idx_typed_expr
let idx_type :: TypeMap (BaseBVType w)
idx_type = forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h (BaseBVType w)
idx_typed_expr
Term h
val_expr <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t a
val
Term h
len_expr <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
len
SMTExpr h ('BaseArrayType (SingleCtx (BaseBVType w)) a)
res <- forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
"array_set" TypeMap ('BaseArrayType (SingleCtx (BaseBVType w)) a)
arr_type
CollectorResults h (Term h)
cr <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall t h a. WriterConn t h -> IO a -> IO a
withConnEntryStack WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ forall h t a.
SupportTermOps (Term h) =>
WriterConn t h -> SMTCollector t h a -> IO (CollectorResults h a)
runInSandbox WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ do
Term h
i_expr <- forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
"i" TypeMap (BaseBVType w)
idx_type
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase (forall h (idxl :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
SMTWriter h =>
SMTExpr h (BaseArrayType (idxl ::> idx) tp)
-> [Term h] -> SMTExpr h tp
smt_array_select SMTExpr h ('BaseArrayType (SingleCtx (BaseBVType w)) a)
res [Term h
i_expr]) forall v. SupportTermOps v => v -> v -> v
.==
forall v. SupportTermOps v => v -> v -> v -> v
ite ((forall v. SupportTermOps v => v -> v -> v
bvULe Term h
idx_expr Term h
i_expr) forall v. SupportTermOps v => v -> v -> v
.&& (forall v. SupportTermOps v => v -> v -> v
bvULt Term h
i_expr (forall v. SupportTermOps v => v -> v -> v
bvAdd Term h
idx_expr Term h
len_expr)))
Term h
val_expr
(forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase (forall h (idxl :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
SMTWriter h =>
SMTExpr h (BaseArrayType (idxl ::> idx) tp)
-> [Term h] -> SMTExpr h tp
smt_array_select SMTExpr h ('BaseArrayType (SingleCtx (BaseBVType w)) a)
arr_typed_expr [Term h
i_expr]))
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"array set" forall a b. (a -> b) -> a -> b
$ forall h. SMTWriter h => CollectorResults h (Term h) -> Term h
forallResult CollectorResults h (Term h)
cr
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"array set" forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
bvULt Term h
idx_expr (forall v. SupportTermOps v => v -> v -> v
bvAdd Term h
idx_expr Term h
len_expr)
forall (m :: Type -> Type) a. Monad m => a -> m a
return SMTExpr h ('BaseArrayType (SingleCtx (BaseBVType w)) a)
res
EqualArrayRange NatRepr w
_w_repr BaseTypeRepr a
_a_repr Expr t (BaseArrayType (SingleCtx (BaseBVType w)) a)
x_arr Expr t (BaseBVType w)
x_idx Expr t (BaseArrayType (SingleCtx (BaseBVType w)) a)
y_arr Expr t (BaseBVType w)
y_idx Expr t (BaseBVType w)
len Expr t (BaseBVType w)
_x_end_idx Expr t (BaseBVType w)
_y_end_idx -> do
SMTExpr h (BaseArrayType (SingleCtx (BaseBVType w)) a)
x_arr_typed_expr <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t (BaseArrayType (SingleCtx (BaseBVType w)) a)
x_arr
SMTExpr h (BaseBVType w)
x_idx_typed_expr <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t (BaseBVType w)
x_idx
let x_idx_expr :: Term h
x_idx_expr = forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h (BaseBVType w)
x_idx_typed_expr
let idx_type :: TypeMap (BaseBVType w)
idx_type = forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h (BaseBVType w)
x_idx_typed_expr
SMTExpr h (BaseArrayType (SingleCtx (BaseBVType w)) a)
y_arr_typed_expr <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t (BaseArrayType (SingleCtx (BaseBVType w)) a)
y_arr
Term h
y_idx_expr <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
y_idx
Term h
len_expr <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t (BaseBVType w)
len
CollectorResults h (Term h)
cr <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall t h a. WriterConn t h -> IO a -> IO a
withConnEntryStack WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ forall h t a.
SupportTermOps (Term h) =>
WriterConn t h -> SMTCollector t h a -> IO (CollectorResults h a)
runInSandbox WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ do
Term h
i_expr <- forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
"i" TypeMap (BaseBVType w)
idx_type
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
impliesExpr ((forall v. SupportTermOps v => v -> v -> v
bvULe Term h
x_idx_expr Term h
i_expr) forall v. SupportTermOps v => v -> v -> v
.&& (forall v. SupportTermOps v => v -> v -> v
bvULt Term h
i_expr (forall v. SupportTermOps v => v -> v -> v
bvAdd Term h
x_idx_expr Term h
len_expr)))
((forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase (forall h (idxl :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
SMTWriter h =>
SMTExpr h (BaseArrayType (idxl ::> idx) tp)
-> [Term h] -> SMTExpr h tp
smt_array_select SMTExpr h (BaseArrayType (SingleCtx (BaseBVType w)) a)
x_arr_typed_expr [Term h
i_expr])) forall v. SupportTermOps v => v -> v -> v
.==
(forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase (forall h (idxl :: Ctx BaseType) (idx :: BaseType) (tp :: BaseType).
SMTWriter h =>
SMTExpr h (BaseArrayType (idxl ::> idx) tp)
-> [Term h] -> SMTExpr h tp
smt_array_select SMTExpr h (BaseArrayType (SingleCtx (BaseBVType w)) a)
y_arr_typed_expr [forall v. SupportTermOps v => v -> v -> v
bvAdd Term h
y_idx_expr (forall v. SupportTermOps v => v -> v -> v
bvSub Term h
i_expr Term h
x_idx_expr)])))
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"array range equal" forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
bvULt Term h
x_idx_expr (forall v. SupportTermOps v => v -> v -> v
bvAdd Term h
x_idx_expr Term h
len_expr)
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"array range equal" forall a b. (a -> b) -> a -> b
$ forall v. SupportTermOps v => v -> v -> v
bvULt Term h
y_idx_expr (forall v. SupportTermOps v => v -> v -> v
bvAdd Term h
y_idx_expr Term h
len_expr)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap BaseBoolType
BoolTypeMap forall a b. (a -> b) -> a -> b
$ forall h. SMTWriter h => CollectorResults h (Term h) -> Term h
forallResult CollectorResults h (Term h)
cr
IntegerToReal Expr t 'BaseIntegerType
xe -> do
SMTExpr h 'BaseIntegerType
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t 'BaseIntegerType
xe
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap 'BaseRealType
RealTypeMap (forall v. SupportTermOps v => v -> v
termIntegerToReal (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h 'BaseIntegerType
x))
RealToInteger Expr t 'BaseRealType
xe -> do
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkIntegerSupport Expr t tp
i
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t 'BaseRealType
xe
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (tp :: BaseType) h. TypeMap tp -> Term h -> SMTExpr h tp
SMTExpr TypeMap 'BaseIntegerType
IntegerTypeMap (forall v. SupportTermOps v => v -> v
termRealToInteger Term h
x)
RoundReal Expr t 'BaseRealType
xe -> do
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkIntegerSupport Expr t tp
i
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t 'BaseRealType
xe
SMTExpr h 'BaseIntegerType
nm <- forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
"round" TypeMap 'BaseIntegerType
IntegerTypeMap
let r :: Term h
r = forall v. SupportTermOps v => v -> v
termIntegerToReal (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h 'BaseIntegerType
nm)
let posExpr :: Term h
posExpr = (Term h
2forall a. Num a => a -> a -> a
*Term h
x forall a. Num a => a -> a -> a
- Term h
1 forall v. SupportTermOps v => v -> v -> v
.< Term h
2forall a. Num a => a -> a -> a
*Term h
r) forall v. SupportTermOps v => v -> v -> v
.&& (Term h
2forall a. Num a => a -> a -> a
*Term h
r forall v. SupportTermOps v => v -> v -> v
.<= Term h
2forall a. Num a => a -> a -> a
*Term h
x forall a. Num a => a -> a -> a
+ Term h
1)
let negExpr :: Term h
negExpr = (Term h
2forall a. Num a => a -> a -> a
*Term h
x forall a. Num a => a -> a -> a
- Term h
1 forall v. SupportTermOps v => v -> v -> v
.<= Term h
2forall a. Num a => a -> a -> a
*Term h
r) forall v. SupportTermOps v => v -> v -> v
.&& (Term h
2forall a. Num a => a -> a -> a
*Term h
r forall v. SupportTermOps v => v -> v -> v
.< Term h
2forall a. Num a => a -> a -> a
*Term h
x forall a. Num a => a -> a -> a
+ Term h
1)
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"round" forall a b. (a -> b) -> a -> b
$ Term h
x forall v. SupportTermOps v => v -> v -> v
.< Term h
0 forall v. SupportTermOps v => v -> v -> v
.|| Term h
posExpr
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"round" forall a b. (a -> b) -> a -> b
$ Term h
x forall v. SupportTermOps v => v -> v -> v
.>= Term h
0 forall v. SupportTermOps v => v -> v -> v
.|| Term h
negExpr
forall (m :: Type -> Type) a. Monad m => a -> m a
return SMTExpr h 'BaseIntegerType
nm
RoundEvenReal Expr t 'BaseRealType
xe -> do
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkIntegerSupport Expr t tp
i
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t 'BaseRealType
xe
Term h
nm <- forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
"roundEven" TypeMap 'BaseIntegerType
IntegerTypeMap
Term h
r <- forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap 'BaseRealType
RealTypeMap (forall v. SupportTermOps v => v -> v
termIntegerToReal Term h
nm)
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"roundEven" forall a b. (a -> b) -> a -> b
$ (Term h
r forall v. SupportTermOps v => v -> v -> v
.<= Term h
x) forall v. SupportTermOps v => v -> v -> v
.&& (Term h
x forall v. SupportTermOps v => v -> v -> v
.<= Term h
rforall a. Num a => a -> a -> a
+Term h
1)
Term h
diff <- forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap 'BaseRealType
RealTypeMap (Term h
x forall a. Num a => a -> a -> a
- Term h
r)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap 'BaseIntegerType
IntegerTypeMap forall a b. (a -> b) -> a -> b
$
forall v. SupportTermOps v => v -> v -> v -> v
ite (Term h
diff forall v. SupportTermOps v => v -> v -> v
.< forall v. SupportTermOps v => Rational -> v
rationalTerm Rational
0.5) Term h
nm forall a b. (a -> b) -> a -> b
$
forall v. SupportTermOps v => v -> v -> v -> v
ite (Term h
diff forall v. SupportTermOps v => v -> v -> v
.> forall v. SupportTermOps v => Rational -> v
rationalTerm Rational
0.5) (Term h
nmforall a. Num a => a -> a -> a
+Term h
1) forall a b. (a -> b) -> a -> b
$
forall v. SupportTermOps v => v -> v -> v -> v
ite (forall v. SupportTermOps v => v -> Natural -> v
intDivisible Term h
nm Natural
2) Term h
nm (Term h
nmforall a. Num a => a -> a -> a
+Term h
1)
FloorReal Expr t 'BaseRealType
xe -> do
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkIntegerSupport Expr t tp
i
Term h
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t 'BaseRealType
xe
SMTExpr h 'BaseIntegerType
nm <- forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
"floor" TypeMap 'BaseIntegerType
IntegerTypeMap
let floor_r :: Term h
floor_r = forall v. SupportTermOps v => v -> v
termIntegerToReal (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h 'BaseIntegerType
nm)
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"floor" forall a b. (a -> b) -> a -> b
$ (Term h
floor_r forall v. SupportTermOps v => v -> v -> v
.<= Term h
x) forall v. SupportTermOps v => v -> v -> v
.&& (Term h
x forall v. SupportTermOps v => v -> v -> v
.< Term h
floor_r forall a. Num a => a -> a -> a
+ Term h
1)
forall (m :: Type -> Type) a. Monad m => a -> m a
return SMTExpr h 'BaseIntegerType
nm
CeilReal Expr t 'BaseRealType
xe -> do
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkIntegerSupport Expr t tp
i
Term h
x <- forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t 'BaseRealType
xe
SMTExpr h 'BaseIntegerType
nm <- forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
"ceiling" TypeMap 'BaseIntegerType
IntegerTypeMap
let r :: Term h
r = forall v. SupportTermOps v => v -> v
termIntegerToReal (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h 'BaseIntegerType
nm)
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"ceiling" forall a b. (a -> b) -> a -> b
$ (Term h
x forall v. SupportTermOps v => v -> v -> v
.<= Term h
r) forall v. SupportTermOps v => v -> v -> v
.&& (Term h
r forall v. SupportTermOps v => v -> v -> v
.< Term h
x forall a. Num a => a -> a -> a
+ Term h
1)
forall (m :: Type -> Type) a. Monad m => a -> m a
return SMTExpr h 'BaseIntegerType
nm
BVToInteger Expr t (BaseBVType w)
xe -> do
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkLinearSupport Expr t tp
i
SMTExpr h (BaseBVType w)
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t (BaseBVType w)
xe
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap 'BaseIntegerType
IntegerTypeMap forall a b. (a -> b) -> a -> b
$ forall v (w :: Natural).
(SupportTermOps v, 1 <= w) =>
NatRepr w -> v -> v
bvIntTerm (forall (e :: BaseType -> Type) (w :: Natural).
IsExpr e =>
e (BaseBVType w) -> NatRepr w
bvWidth Expr t (BaseBVType w)
xe) (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h (BaseBVType w)
x)
SBVToInteger Expr t (BaseBVType w)
xe -> do
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkLinearSupport Expr t tp
i
SMTExpr h (BaseBVType w)
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t (BaseBVType w)
xe
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap 'BaseIntegerType
IntegerTypeMap forall a b. (a -> b) -> a -> b
$ forall v (w :: Natural). SupportTermOps v => NatRepr w -> v -> v
sbvIntTerm (forall (e :: BaseType -> Type) (w :: Natural).
IsExpr e =>
e (BaseBVType w) -> NatRepr w
bvWidth Expr t (BaseBVType w)
xe) (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h (BaseBVType w)
x)
IntegerToBV Expr t 'BaseIntegerType
xe NatRepr w
w -> do
forall t (tp :: BaseType) h. Expr t tp -> SMTCollector t h ()
checkLinearSupport Expr t tp
i
SMTExpr h 'BaseIntegerType
x <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t 'BaseIntegerType
xe
let xb :: Term h
xb = forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h 'BaseIntegerType
x
SMTExpr h ('BaseBVType w)
res <- forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
"integerToBV" (forall (idx :: Natural).
(1 <= idx) =>
NatRepr idx -> TypeMap (BaseBVType idx)
BVTypeMap NatRepr w
w)
SMTExpr h 'BaseIntegerType
bvint <- forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap 'BaseIntegerType
IntegerTypeMap forall a b. (a -> b) -> a -> b
$ forall v (w :: Natural).
(SupportTermOps v, 1 <= w) =>
NatRepr w -> v -> v
bvIntTerm NatRepr w
w (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h ('BaseBVType w)
res)
forall h t. String -> Term h -> SMTCollector t h ()
addSideCondition String
"integerToBV" forall a b. (a -> b) -> a -> b
$
(forall v. SupportTermOps v => v -> Natural -> v
intDivisible (Term h
xb forall a. Num a => a -> a -> a
- (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h 'BaseIntegerType
bvint)) (Natural
2forall a b. (Num a, Integral b) => a -> b -> a
^forall (n :: Natural). NatRepr n -> Natural
natValue NatRepr w
w))
forall (m :: Type -> Type) a. Monad m => a -> m a
return SMTExpr h ('BaseBVType w)
res
Cplx Complex (Expr t 'BaseRealType)
c -> do
(SMTExpr h 'BaseRealType
rl :+ SMTExpr h 'BaseRealType
img) <- forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Complex (Expr t 'BaseRealType)
c
ProblemFeatures
feat <- forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks (forall t h. WriterConn t h -> ProblemFeatures
supportedFeatures forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t h. SMTCollectorState t h -> WriterConn t h
scConn)
case () of
()
_ | ProblemFeatures
feat ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useStructs -> do
let tp :: TypeMap 'BaseComplexType
tp = TypeMap 'BaseComplexType
ComplexToStructTypeMap
let tm :: Term h
tm = forall h (args :: Ctx BaseType).
SMTWriter h =>
Assignment TypeMap args -> [Term h] -> Term h
structCtor @h (forall {k} (ctx :: Ctx k) (f :: k -> Type).
(ctx ~ EmptyCtx) =>
Assignment f ctx
Ctx.Empty forall {k} (ctx' :: Ctx k) (f :: k -> Type) (ctx :: Ctx k)
(tp :: k).
(ctx' ~ (ctx ::> tp)) =>
Assignment f ctx -> f tp -> Assignment f ctx'
Ctx.:> TypeMap 'BaseRealType
RealTypeMap forall {k} (ctx' :: Ctx k) (f :: k -> Type) (ctx :: Ctx k)
(tp :: k).
(ctx' ~ (ctx ::> tp)) =>
Assignment f ctx -> f tp -> Assignment f ctx'
Ctx.:> TypeMap 'BaseRealType
RealTypeMap) [forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h 'BaseRealType
rl, forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h 'BaseRealType
img]
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap 'BaseComplexType
tp Term h
tm
| ProblemFeatures
feat ProblemFeatures -> ProblemFeatures -> Bool
`hasProblemFeature` ProblemFeatures
useSymbolicArrays -> do
let tp :: TypeMap 'BaseComplexType
tp = TypeMap 'BaseComplexType
ComplexToArrayTypeMap
let r' :: Term h
r' = forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h 'BaseRealType
rl
let i' :: Term h
i' = forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h 'BaseRealType
img
Term h
ra <-
case forall h. SMTWriter h => Maybe (ArrayConstantFn (Term h))
arrayConstant @h of
Just ArrayConstantFn (Term h)
constFn ->
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ArrayConstantFn (Term h)
constFn [forall k (f :: k -> Type) (x :: k). f x -> Some f
Some TypeMap BaseBoolType
BoolTypeMap] (forall k (f :: k -> Type) (x :: k). f x -> Some f
Some TypeMap 'BaseRealType
RealTypeMap) Term h
r')
Maybe (ArrayConstantFn (Term h))
Nothing -> do
Term h
a <- forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (tp :: BaseType) t h.
String -> TypeMap tp -> SMTCollector t h (SMTExpr h tp)
freshConstant String
"complex lit" TypeMap 'BaseComplexType
tp
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall h. SMTWriter h => Term h -> [Term h] -> Term h -> Term h
arrayUpdate @h Term h
a [forall v. SupportTermOps v => Bool -> v
boolExpr Bool
False] Term h
r'
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap 'BaseComplexType
tp forall a b. (a -> b) -> a -> b
$! forall h. SMTWriter h => Term h -> [Term h] -> Term h -> Term h
arrayUpdate @h Term h
ra [forall v. SupportTermOps v => Bool -> v
boolExpr Bool
True] Term h
i'
| Bool
otherwise ->
forall (m :: Type -> Type) t h (tp :: BaseType) a.
MonadFail m =>
WriterConn t h -> String -> Expr t tp -> m a
theoryUnsupported WriterConn t h
conn String
"complex literals" Expr t tp
i
RealPart Expr t 'BaseComplexType
e -> do
SMTExpr h 'BaseComplexType
c <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t 'BaseComplexType
e
case forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h 'BaseComplexType
c of
TypeMap 'BaseComplexType
ComplexToStructTypeMap ->
do let prj :: Term h
prj = forall h. SMTWriter h => Term h -> Term h
structComplexRealPart @h (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h 'BaseComplexType
c)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap 'BaseRealType
RealTypeMap Term h
prj
TypeMap 'BaseComplexType
ComplexToArrayTypeMap ->
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap 'BaseRealType
RealTypeMap forall a b. (a -> b) -> a -> b
$ forall h. SMTWriter h => Term h -> Term h
arrayComplexRealPart @h (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h 'BaseComplexType
c)
ImagPart Expr t 'BaseComplexType
e -> do
SMTExpr h 'BaseComplexType
c <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t 'BaseComplexType
e
case forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h 'BaseComplexType
c of
TypeMap 'BaseComplexType
ComplexToStructTypeMap ->
do let prj :: Term h
prj = forall h. SMTWriter h => Term h -> Term h
structComplexImagPart @h (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h 'BaseComplexType
c)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap 'BaseRealType
RealTypeMap Term h
prj
TypeMap 'BaseComplexType
ComplexToArrayTypeMap ->
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap 'BaseRealType
RealTypeMap forall a b. (a -> b) -> a -> b
$ forall h. SMTWriter h => Term h -> Term h
arrayComplexImagPart @h (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h 'BaseComplexType
c)
StructCtor Assignment BaseTypeRepr flds
_ Assignment (Expr t) flds
vals -> do
Assignment (SMTExpr h) flds
exprs <- forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
(g :: k -> Type) (m :: Type -> Type).
(TraversableFC t, Applicative m) =>
(forall (x :: k). f x -> m (g x))
-> forall (x :: l). t f x -> m (t g x)
traverseFC forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Assignment (Expr t) flds
vals
let fld_types :: Assignment TypeMap flds
fld_types = forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type)
(g :: k -> Type).
FunctorFC t =>
(forall (x :: k). f x -> g x) -> forall (x :: l). t f x -> t g x
fmapFC forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType Assignment (SMTExpr h) flds
exprs
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall h t (args :: Ctx BaseType).
SMTWriter h =>
WriterConn t h -> Assignment TypeMap args -> IO ()
declareStructDatatype WriterConn t h
conn Assignment TypeMap flds
fld_types
let tm :: Term h
tm = forall h (args :: Ctx BaseType).
SMTWriter h =>
Assignment TypeMap args -> [Term h] -> Term h
structCtor @h Assignment TypeMap flds
fld_types (forall k l (t :: (k -> Type) -> l -> Type) (f :: k -> Type) a.
FoldableFC t =>
(forall (x :: k). f x -> a) -> forall (x :: l). t f x -> [a]
toListFC forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase Assignment (SMTExpr h) flds
exprs)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm (forall (idx :: Ctx BaseType).
Assignment TypeMap idx -> TypeMap (BaseStructType idx)
StructTypeMap Assignment TypeMap flds
fld_types) Term h
tm
StructField Expr t (BaseStructType flds)
s Index flds tp
idx BaseTypeRepr tp
_tp -> do
SMTExpr h (BaseStructType flds)
expr <- forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t (BaseStructType flds)
s
case forall h (tp :: BaseType). SMTExpr h tp -> TypeMap tp
smtExprType SMTExpr h (BaseStructType flds)
expr of
StructTypeMap Assignment TypeMap idx
flds -> do
let tp :: TypeMap tp
tp = Assignment TypeMap idx
flds forall {k} (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
Assignment f ctx -> Index ctx tp -> f tp
Ctx.! Index flds tp
idx
let tm :: Term h
tm = forall h (args :: Ctx BaseType) (tp :: BaseType).
SMTWriter h =>
Assignment TypeMap args -> Index args tp -> Term h -> Term h
structProj @h Assignment TypeMap idx
flds Index flds tp
idx (forall h (tp :: BaseType).
SupportTermOps (Term h) =>
SMTExpr h tp -> Term h
asBase SMTExpr h (BaseStructType flds)
expr)
forall (tp :: BaseType) h t.
TypeMap tp -> Term h -> SMTCollector t h (SMTExpr h tp)
freshBoundTerm TypeMap tp
tp Term h
tm
defineFn :: SMTWriter h
=> WriterConn t h
-> Text
-> Ctx.Assignment (ExprBoundVar t) a
-> Expr t r
-> Ctx.Assignment TypeMap a
-> IO (TypeMap r)
defineFn :: forall h t (a :: Ctx BaseType) (r :: BaseType).
SMTWriter h =>
WriterConn t h
-> Text
-> Assignment (ExprBoundVar t) a
-> Expr t r
-> Assignment TypeMap a
-> IO (TypeMap r)
defineFn WriterConn t h
conn Text
nm Assignment (ExprBoundVar t) a
arg_vars Expr t r
return_value Assignment TypeMap a
arg_types =
forall h t (ret :: BaseType).
SMTWriter h =>
WriterConn t h
-> Text
-> (FreshVarFn h -> SMTCollector t h (SMTExpr h ret))
-> IO (TypeMap ret)
defineSMTFunction WriterConn t h
conn Text
nm forall a b. (a -> b) -> a -> b
$ \(FreshVarFn forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp)
freshVar) -> do
forall {k} (ctx :: Ctx k) (m :: Type -> Type).
Applicative m =>
Size ctx -> (forall (tp :: k). Index ctx tp -> m ()) -> m ()
Ctx.forIndexM (forall {k} (f :: k -> Type) (ctx :: Ctx k).
Assignment f ctx -> Size ctx
Ctx.size Assignment (ExprBoundVar t) a
arg_vars) forall a b. (a -> b) -> a -> b
$ \Index a tp
i -> do
let v :: ExprBoundVar t tp
v = Assignment (ExprBoundVar t) a
arg_vars forall {k} (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
Assignment f ctx -> Index ctx tp -> f tp
Ctx.! Index a tp
i
let smtType :: TypeMap tp
smtType = Assignment TypeMap a
arg_types forall {k} (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
Assignment f ctx -> Index ctx tp -> f tp
Ctx.! Index a tp
i
forall n (tp :: BaseType) h.
ExprBoundVar n tp -> SMTCollector n h ()
checkVarTypeSupport ExprBoundVar t tp
v
SMTExpr h tp
x <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (tp :: BaseType). TypeMap tp -> IO (SMTExpr h tp)
freshVar TypeMap tp
smtType
forall t (tp :: BaseType) h.
ExprBoundVar t tp -> SMTExpr h tp -> SMTCollector t h ()
bindVar ExprBoundVar t tp
v SMTExpr h tp
x
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr Expr t r
return_value
mkSMTSymFn :: SMTWriter h
=> WriterConn t h
-> Text
-> ExprSymFn t args ret
-> Ctx.Assignment TypeMap args
-> IO (TypeMap ret)
mkSMTSymFn :: forall h t (args :: Ctx BaseType) (ret :: BaseType).
SMTWriter h =>
WriterConn t h
-> Text
-> ExprSymFn t args ret
-> Assignment TypeMap args
-> IO (TypeMap ret)
mkSMTSymFn WriterConn t h
conn Text
nm ExprSymFn t args ret
f Assignment TypeMap args
arg_types =
case forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> SymFnInfo t args ret
symFnInfo ExprSymFn t args ret
f of
UninterpFnInfo Assignment BaseTypeRepr args
_ BaseTypeRepr ret
return_type -> do
let fnm :: SolverSymbol
fnm = forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> SolverSymbol
symFnName ExprSymFn t args ret
f
let l :: ProgramLoc
l = forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> ProgramLoc
symFnLoc ExprSymFn t args ret
f
TypeMap ret
smt_ret <- forall (m :: Type -> Type) t h ann (tp :: BaseType).
MonadFail m =>
WriterConn t h
-> SMTSource ann -> BaseTypeRepr tp -> m (TypeMap tp)
evalFirstClassTypeRepr WriterConn t h
conn (forall ann. SolverSymbol -> ProgramLoc -> SMTSource ann
fnSource SolverSymbol
fnm ProgramLoc
l) BaseTypeRepr ret
return_type
forall {k} {l} (t :: (k -> Type) -> l -> Type) (m :: Type -> Type)
(f :: k -> Type) a.
(FoldableFC t, Applicative m) =>
(forall (x :: k). f x -> m a) -> forall (x :: l). t f x -> m ()
traverseFC_ (forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn) Assignment TypeMap args
arg_types
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> TypeMap tp -> IO ()
declareTypes WriterConn t h
conn TypeMap ret
smt_ret
forall h t. SMTWriter h => WriterConn t h -> Command h -> IO ()
addCommand WriterConn t h
conn forall a b. (a -> b) -> a -> b
$
forall h (f :: Type -> Type) (args :: Ctx BaseType)
(rtp :: BaseType).
SMTWriter h =>
f h -> Text -> Assignment TypeMap args -> TypeMap rtp -> Command h
declareCommand WriterConn t h
conn Text
nm Assignment TypeMap args
arg_types TypeMap ret
smt_ret
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! TypeMap ret
smt_ret
DefinedFnInfo Assignment (ExprBoundVar t) args
arg_vars Expr t ret
return_value UnfoldPolicy
_ -> do
forall h t (a :: Ctx BaseType) (r :: BaseType).
SMTWriter h =>
WriterConn t h
-> Text
-> Assignment (ExprBoundVar t) a
-> Expr t r
-> Assignment TypeMap a
-> IO (TypeMap r)
defineFn WriterConn t h
conn Text
nm Assignment (ExprBoundVar t) args
arg_vars Expr t ret
return_value Assignment TypeMap args
arg_types
MatlabSolverFnInfo MatlabSolverFn (Expr t) args ret
_ Assignment (ExprBoundVar t) args
arg_vars Expr t ret
return_value -> do
forall h t (a :: Ctx BaseType) (r :: BaseType).
SMTWriter h =>
WriterConn t h
-> Text
-> Assignment (ExprBoundVar t) a
-> Expr t r
-> Assignment TypeMap a
-> IO (TypeMap r)
defineFn WriterConn t h
conn Text
nm Assignment (ExprBoundVar t) args
arg_vars Expr t ret
return_value Assignment TypeMap args
arg_types
getSMTSymFn :: SMTWriter h
=> WriterConn t h
-> ExprSymFn t args ret
-> Ctx.Assignment TypeMap args
-> IO (Text, TypeMap ret)
getSMTSymFn :: forall h t (args :: Ctx BaseType) (ret :: BaseType).
SMTWriter h =>
WriterConn t h
-> ExprSymFn t args ret
-> Assignment TypeMap args
-> IO (Text, TypeMap ret)
getSMTSymFn WriterConn t h
conn ExprSymFn t args ret
fn Assignment TypeMap args
arg_types = do
let n :: Nonce t (args ::> ret)
n = forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> Nonce t (args ::> ret)
symFnId ExprSymFn t args ret
fn
forall t h (ctx :: Ctx BaseType).
WriterConn t h -> Nonce t ctx -> IO (Maybe (SMTSymFn ctx))
cacheLookupFn WriterConn t h
conn Nonce t (args ::> ret)
n forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just (SMTSymFn Text
nm Assignment TypeMap args
param_types TypeMap ret
ret) -> do
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Assignment TypeMap args
arg_types forall a. Eq a => a -> a -> Bool
/= Assignment TypeMap args
param_types) forall a b. (a -> b) -> a -> b
$ do
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Illegal arguments to function " forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack Text
nm forall a. [a] -> [a] -> [a]
++ String
".\n"
forall a. [a] -> [a] -> [a]
++ String
"\tExpected arguments: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Assignment TypeMap args
param_types forall a. [a] -> [a] -> [a]
++String
"\n"
forall a. [a] -> [a] -> [a]
++ String
"\tActual arguments: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Assignment TypeMap args
arg_types
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text
nm, TypeMap ret
ret)
Maybe (SMTSymFn (args ::> ret))
Nothing -> do
forall t h (args :: Ctx BaseType).
WriterConn t h -> Assignment TypeMap args -> IO ()
checkArgumentTypes WriterConn t h
conn Assignment TypeMap args
arg_types
Text
nm <- forall t h. WriterConn t h -> SymbolBinding t -> IO Text
getSymbolName WriterConn t h
conn (forall t (args :: Ctx BaseType) (ret :: BaseType).
ExprSymFn t args ret -> SymbolBinding t
FnSymbolBinding ExprSymFn t args ret
fn)
TypeMap ret
ret_type <- forall h t (args :: Ctx BaseType) (ret :: BaseType).
SMTWriter h =>
WriterConn t h
-> Text
-> ExprSymFn t args ret
-> Assignment TypeMap args
-> IO (TypeMap ret)
mkSMTSymFn WriterConn t h
conn Text
nm ExprSymFn t args ret
fn Assignment TypeMap args
arg_types
forall t h (ctx :: Ctx BaseType).
WriterConn t h
-> Nonce t ctx -> TermLifetime -> SMTSymFn ctx -> IO ()
cacheValueFn WriterConn t h
conn Nonce t (args ::> ret)
n TermLifetime
DeleteNever forall a b. (a -> b) -> a -> b
$! forall (idx :: Ctx BaseType) (idx :: BaseType).
Text
-> Assignment TypeMap idx -> TypeMap idx -> SMTSymFn (idx ::> idx)
SMTSymFn Text
nm Assignment TypeMap args
arg_types TypeMap ret
ret_type
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text
nm, TypeMap ret
ret_type)
mkSMTTerm :: SMTWriter h => WriterConn t h -> Expr t tp -> IO (Term h)
mkSMTTerm :: forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> Expr t tp -> IO (Term h)
mkSMTTerm WriterConn t h
conn Expr t tp
p = forall h t a.
SMTWriter h =>
WriterConn t h -> SMTCollector t h a -> IO a
runOnLiveConnection WriterConn t h
conn forall a b. (a -> b) -> a -> b
$ forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (Term h)
mkBaseExpr Expr t tp
p
mkFormula :: SMTWriter h => WriterConn t h -> BoolExpr t -> IO (Term h)
mkFormula :: forall h t.
SMTWriter h =>
WriterConn t h -> BoolExpr t -> IO (Term h)
mkFormula = forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h -> Expr t tp -> IO (Term h)
mkSMTTerm
mkAtomicFormula :: SMTWriter h => WriterConn t h -> BoolExpr t -> IO Text
mkAtomicFormula :: forall h t. SMTWriter h => WriterConn t h -> BoolExpr t -> IO Text
mkAtomicFormula WriterConn t h
conn BoolExpr t
p = forall h t a.
SMTWriter h =>
WriterConn t h -> SMTCollector t h a -> IO a
runOnLiveConnection WriterConn t h
conn forall a b. (a -> b) -> a -> b
$
forall h t (tp :: BaseType).
SMTWriter h =>
Expr t tp -> SMTCollector t h (SMTExpr h tp)
mkExpr BoolExpr t
p forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
SMTName TypeMap BaseBoolType
_ Text
nm -> forall (m :: Type -> Type) a. Monad m => a -> m a
return Text
nm
SMTExpr TypeMap BaseBoolType
ty Term h
tm -> forall (rtp :: BaseType) h t.
[(Text, Some TypeMap)]
-> TypeMap rtp -> Term h -> SMTCollector t h Text
freshBoundFn [] TypeMap BaseBoolType
ty Term h
tm
assume :: SMTWriter h => WriterConn t h -> BoolExpr t -> IO ()
assume :: forall h t. SMTWriter h => WriterConn t h -> BoolExpr t -> IO ()
assume WriterConn t h
c BoolExpr t
p = do
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall t. Expr t BaseBoolType -> [(Expr t BaseBoolType, Polarity)]
asConjunction BoolExpr t
p) forall a b. (a -> b) -> a -> b
$ \(BoolExpr t
v,Polarity
pl) -> do
Term h
f <- forall h t.
SMTWriter h =>
WriterConn t h -> BoolExpr t -> IO (Term h)
mkFormula WriterConn t h
c BoolExpr t
v
forall t h. WriterConn t h -> ProgramLoc -> IO ()
updateProgramLoc WriterConn t h
c (forall t (tp :: BaseType). Expr t tp -> ProgramLoc
exprLoc BoolExpr t
v)
case Polarity
pl of
Polarity
BM.Positive -> forall h t. SMTWriter h => WriterConn t h -> Term h -> IO ()
assumeFormula WriterConn t h
c Term h
f
Polarity
BM.Negative -> forall h t. SMTWriter h => WriterConn t h -> Term h -> IO ()
assumeFormula WriterConn t h
c (forall v. SupportTermOps v => v -> v
notExpr Term h
f)
type SMTEvalBVArrayFn h w v =
(1 <= w,
1 <= v)
=> NatRepr w
-> NatRepr v
-> Term h
-> IO (Maybe (GroundArray (Ctx.SingleCtx (BaseBVType w)) (BaseBVType v)))
newtype SMTEvalBVArrayWrapper h =
SMTEvalBVArrayWrapper { forall h.
SMTEvalBVArrayWrapper h
-> forall (w :: Natural) (v :: Natural). SMTEvalBVArrayFn h w v
unEvalBVArrayWrapper :: forall w v. SMTEvalBVArrayFn h w v }
data SMTEvalFunctions h
= SMTEvalFunctions { forall h. SMTEvalFunctions h -> Term h -> IO Bool
smtEvalBool :: Term h -> IO Bool
, forall h.
SMTEvalFunctions h
-> forall (w :: Natural). NatRepr w -> Term h -> IO (BV w)
smtEvalBV :: forall w . NatRepr w -> Term h -> IO (BV.BV w)
, forall h. SMTEvalFunctions h -> Term h -> IO Rational
smtEvalReal :: Term h -> IO Rational
, forall h.
SMTEvalFunctions h
-> forall (fpp :: FloatPrecision).
FloatPrecisionRepr fpp
-> Term h -> IO (BV (FloatPrecisionBits fpp))
smtEvalFloat :: forall fpp . FloatPrecisionRepr fpp -> Term h -> IO (BV.BV (FloatPrecisionBits fpp))
, forall h. SMTEvalFunctions h -> Maybe (SMTEvalBVArrayWrapper h)
smtEvalBvArray :: Maybe (SMTEvalBVArrayWrapper h)
, forall h. SMTEvalFunctions h -> Term h -> IO Text
smtEvalString :: Term h -> IO Text
}
class SMTWriter h => SMTReadWriter h where
smtEvalFuns ::
WriterConn t h -> Streams.InputStream Text -> SMTEvalFunctions h
smtSatResult :: f h -> WriterConn t h -> IO (SatResult () ())
smtUnsatCoreResult :: f h -> WriterConn t h -> IO [Text]
smtAbductResult :: f h -> WriterConn t h -> Text -> Term h -> IO String
smtAbductNextResult :: f h -> WriterConn t h -> IO String
smtUnsatAssumptionsResult :: f h -> WriterConn t h -> IO [(Bool,Text)]
smtIndicesTerms :: forall v idx
. SupportTermOps v
=> Ctx.Assignment TypeMap idx
-> Ctx.Assignment GroundValueWrapper idx
-> [v]
smtIndicesTerms :: forall v (idx :: Ctx BaseType).
SupportTermOps v =>
Assignment TypeMap idx -> Assignment GroundValueWrapper idx -> [v]
smtIndicesTerms Assignment TypeMap idx
tps Assignment GroundValueWrapper idx
vals = forall {k} (ctx :: Ctx k) r.
Int
-> Size ctx -> (forall (tp :: k). Index ctx tp -> r -> r) -> r -> r
Ctx.forIndexRange Int
0 Size idx
sz forall (tp :: BaseType). Index idx tp -> [v] -> [v]
f []
where sz :: Size idx
sz = forall {k} (f :: k -> Type) (ctx :: Ctx k).
Assignment f ctx -> Size ctx
Ctx.size Assignment TypeMap idx
tps
f :: Ctx.Index idx tp -> [v] -> [v]
f :: forall (tp :: BaseType). Index idx tp -> [v] -> [v]
f Index idx tp
i [v]
l = (v
rforall a. a -> [a] -> [a]
:[v]
l)
where GVW GroundValue tp
v = Assignment GroundValueWrapper idx
vals forall {k} (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
Assignment f ctx -> Index ctx tp -> f tp
Ctx.! Index idx tp
i
r :: v
r = case Assignment TypeMap idx
tps forall {k} (f :: k -> Type) (ctx :: Ctx k) (tp :: k).
Assignment f ctx -> Index ctx tp -> f tp
Ctx.! Index idx tp
i of
TypeMap tp
IntegerTypeMap -> forall v. SupportTermOps v => Integer -> v
integerTerm GroundValue tp
v
BVTypeMap NatRepr w
w -> forall v (w :: Natural). SupportTermOps v => NatRepr w -> BV w -> v
bvTerm NatRepr w
w GroundValue tp
v
TypeMap tp
_ -> forall a. HasCallStack => String -> a
error String
"Do not yet support other index types."
getSolverVal :: forall h t tp
. SMTWriter h
=> WriterConn t h
-> SMTEvalFunctions h
-> TypeMap tp
-> Term h
-> IO (GroundValue tp)
getSolverVal :: forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h
-> SMTEvalFunctions h
-> TypeMap tp
-> Term h
-> IO (GroundValue tp)
getSolverVal WriterConn t h
_ SMTEvalFunctions h
smtFns TypeMap tp
BoolTypeMap Term h
tm = forall h. SMTEvalFunctions h -> Term h -> IO Bool
smtEvalBool SMTEvalFunctions h
smtFns Term h
tm
getSolverVal WriterConn t h
_ SMTEvalFunctions h
smtFns (BVTypeMap NatRepr w
w) Term h
tm = forall h.
SMTEvalFunctions h
-> forall (w :: Natural). NatRepr w -> Term h -> IO (BV w)
smtEvalBV SMTEvalFunctions h
smtFns NatRepr w
w Term h
tm
getSolverVal WriterConn t h
_ SMTEvalFunctions h
smtFns TypeMap tp
RealTypeMap Term h
tm = forall h. SMTEvalFunctions h -> Term h -> IO Rational
smtEvalReal SMTEvalFunctions h
smtFns Term h
tm
getSolverVal WriterConn t h
_ SMTEvalFunctions h
smtFns (FloatTypeMap FloatPrecisionRepr fpp
fpp) Term h
tm =
BFOpts -> Integer -> BigFloat
bfFromBits (forall (fpp :: FloatPrecision).
FloatPrecisionRepr fpp -> RoundingMode -> BFOpts
fppOpts FloatPrecisionRepr fpp
fpp RoundingMode
RNE) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (w :: Natural). BV w -> Integer
BV.asUnsigned forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h.
SMTEvalFunctions h
-> forall (fpp :: FloatPrecision).
FloatPrecisionRepr fpp
-> Term h -> IO (BV (FloatPrecisionBits fpp))
smtEvalFloat SMTEvalFunctions h
smtFns FloatPrecisionRepr fpp
fpp Term h
tm
getSolverVal WriterConn t h
_ SMTEvalFunctions h
smtFns TypeMap tp
UnicodeTypeMap Term h
tm = Text -> StringLiteral Unicode
UnicodeLiteral forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h. SMTEvalFunctions h -> Term h -> IO Text
smtEvalString SMTEvalFunctions h
smtFns Term h
tm
getSolverVal WriterConn t h
_ SMTEvalFunctions h
smtFns TypeMap tp
IntegerTypeMap Term h
tm = do
Rational
r <- forall h. SMTEvalFunctions h -> Term h -> IO Rational
smtEvalReal SMTEvalFunctions h
smtFns Term h
tm
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (forall a. Ratio a -> a
denominator Rational
r forall a. Eq a => a -> a -> Bool
/= Integer
1) forall a b. (a -> b) -> a -> b
$ forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Expected integer value."
forall (m :: Type -> Type) a. Monad m => a -> m a
return (forall a. Ratio a -> a
numerator Rational
r)
getSolverVal WriterConn t h
_ SMTEvalFunctions h
smtFns TypeMap tp
ComplexToStructTypeMap Term h
tm =
forall a. a -> a -> Complex a
(:+) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h. SMTEvalFunctions h -> Term h -> IO Rational
smtEvalReal SMTEvalFunctions h
smtFns (forall h. SMTWriter h => Term h -> Term h
structComplexRealPart @h Term h
tm)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> forall h. SMTEvalFunctions h -> Term h -> IO Rational
smtEvalReal SMTEvalFunctions h
smtFns (forall h. SMTWriter h => Term h -> Term h
structComplexImagPart @h Term h
tm)
getSolverVal WriterConn t h
_ SMTEvalFunctions h
smtFns TypeMap tp
ComplexToArrayTypeMap Term h
tm =
forall a. a -> a -> Complex a
(:+) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h. SMTEvalFunctions h -> Term h -> IO Rational
smtEvalReal SMTEvalFunctions h
smtFns (forall h. SMTWriter h => Term h -> Term h
arrayComplexRealPart @h Term h
tm)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> forall h. SMTEvalFunctions h -> Term h -> IO Rational
smtEvalReal SMTEvalFunctions h
smtFns (forall h. SMTWriter h => Term h -> Term h
arrayComplexImagPart @h Term h
tm)
getSolverVal WriterConn t h
conn SMTEvalFunctions h
smtFns (PrimArrayTypeMap Assignment TypeMap (idxl ::> idx)
idx_types TypeMap tp
eltTp) Term h
tm
| Just (SMTEvalBVArrayWrapper forall (w :: Natural) (v :: Natural). SMTEvalBVArrayFn h w v
evalBVArray) <- forall h. SMTEvalFunctions h -> Maybe (SMTEvalBVArrayWrapper h)
smtEvalBvArray SMTEvalFunctions h
smtFns
, Assignment TypeMap ctx
Ctx.Empty Ctx.:> (BVTypeMap NatRepr w
w) <- Assignment TypeMap (idxl ::> idx)
idx_types
, BVTypeMap NatRepr w
v <- TypeMap tp
eltTp =
forall a. a -> Maybe a -> a
fromMaybe GroundArray (idxl ::> idx) tp
byIndex forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (w :: Natural) (v :: Natural). SMTEvalBVArrayFn h w v
evalBVArray NatRepr w
w NatRepr w
v Term h
tm
| Bool
otherwise = forall (m :: Type -> Type) a. Monad m => a -> m a
return GroundArray (idxl ::> idx) tp
byIndex
where byIndex :: GroundArray (idxl ::> idx) tp
byIndex = forall (idx :: Ctx BaseType) (b :: BaseType).
(Assignment GroundValueWrapper idx -> IO (GroundValue b))
-> GroundArray idx b
ArrayMapping forall a b. (a -> b) -> a -> b
$ \Assignment GroundValueWrapper (idxl ::> idx)
i -> do
let res :: Term h
res = forall h. SMTWriter h => Term h -> [Term h] -> Term h
arraySelect @h Term h
tm (forall v (idx :: Ctx BaseType).
SupportTermOps v =>
Assignment TypeMap idx -> Assignment GroundValueWrapper idx -> [v]
smtIndicesTerms Assignment TypeMap (idxl ::> idx)
idx_types Assignment GroundValueWrapper (idxl ::> idx)
i)
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h
-> SMTEvalFunctions h
-> TypeMap tp
-> Term h
-> IO (GroundValue tp)
getSolverVal WriterConn t h
conn SMTEvalFunctions h
smtFns TypeMap tp
eltTp Term h
res
getSolverVal WriterConn t h
conn SMTEvalFunctions h
smtFns (FnArrayTypeMap Assignment TypeMap (idxl ::> idx)
idx_types TypeMap tp
eltTp) Term h
tm = forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (idx :: Ctx BaseType) (b :: BaseType).
(Assignment GroundValueWrapper idx -> IO (GroundValue b))
-> GroundArray idx b
ArrayMapping forall a b. (a -> b) -> a -> b
$ \Assignment GroundValueWrapper (idxl ::> idx)
i -> do
let term :: Term h
term = forall v. SupportTermOps v => v -> [v] -> v
smtFnApp Term h
tm (forall v (idx :: Ctx BaseType).
SupportTermOps v =>
Assignment TypeMap idx -> Assignment GroundValueWrapper idx -> [v]
smtIndicesTerms Assignment TypeMap (idxl ::> idx)
idx_types Assignment GroundValueWrapper (idxl ::> idx)
i)
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h
-> SMTEvalFunctions h
-> TypeMap tp
-> Term h
-> IO (GroundValue tp)
getSolverVal WriterConn t h
conn SMTEvalFunctions h
smtFns TypeMap tp
eltTp Term h
term
getSolverVal WriterConn t h
conn SMTEvalFunctions h
smtFns (StructTypeMap Assignment TypeMap idx
flds0) Term h
tm =
forall {k} (m :: Type -> Type) (ctx :: Ctx k) (f :: k -> Type)
(g :: k -> Type).
Applicative m =>
(forall (tp :: k). Index ctx tp -> f tp -> m (g tp))
-> Assignment f ctx -> m (Assignment g ctx)
Ctx.traverseWithIndex (forall (ctx :: Ctx BaseType) (utp :: BaseType).
Assignment TypeMap ctx
-> Index ctx utp -> TypeMap utp -> IO (GroundValueWrapper utp)
f Assignment TypeMap idx
flds0) Assignment TypeMap idx
flds0
where f :: Ctx.Assignment TypeMap ctx
-> Ctx.Index ctx utp
-> TypeMap utp
-> IO (GroundValueWrapper utp)
f :: forall (ctx :: Ctx BaseType) (utp :: BaseType).
Assignment TypeMap ctx
-> Index ctx utp -> TypeMap utp -> IO (GroundValueWrapper utp)
f Assignment TypeMap ctx
flds Index ctx utp
i TypeMap utp
tp = forall (tp :: BaseType). GroundValue tp -> GroundValueWrapper tp
GVW forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h
-> SMTEvalFunctions h
-> TypeMap tp
-> Term h
-> IO (GroundValue tp)
getSolverVal WriterConn t h
conn SMTEvalFunctions h
smtFns TypeMap utp
tp Term h
v
where v :: Term h
v = forall h (args :: Ctx BaseType) (tp :: BaseType).
SMTWriter h =>
Assignment TypeMap args -> Index args tp -> Term h -> Term h
structProj @h Assignment TypeMap ctx
flds Index ctx utp
i Term h
tm
smtExprGroundEvalFn :: forall t h
. SMTWriter h
=> WriterConn t h
-> SMTEvalFunctions h
-> IO (GroundEvalFn t)
smtExprGroundEvalFn :: forall t h.
SMTWriter h =>
WriterConn t h -> SMTEvalFunctions h -> IO (GroundEvalFn t)
smtExprGroundEvalFn WriterConn t h
conn SMTEvalFunctions h
smtFns = do
IdxCache t GroundValueWrapper
groundCache <- forall (m :: Type -> Type) t (f :: BaseType -> Type).
MonadIO m =>
m (IdxCache t f)
newIdxCache
let cachedEval :: Expr t tp -> IO (GroundValue tp)
cachedEval :: forall (tp :: BaseType). Expr t tp -> IO (GroundValue tp)
cachedEval Expr t tp
e =
case forall t (tp :: BaseType). Expr t tp -> Maybe (Nonce t tp)
exprMaybeId Expr t tp
e of
Maybe (Nonce t tp)
Nothing -> forall t (tp :: BaseType).
(forall (u :: BaseType). Expr t u -> IO (GroundValue u))
-> Expr t tp -> IO (GroundValue tp)
evalGroundExpr forall (tp :: BaseType). Expr t tp -> IO (GroundValue tp)
cachedEval Expr t tp
e
Just Nonce t tp
e_id -> forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (tp :: BaseType). GroundValueWrapper tp -> GroundValue tp
unGVW forall a b. (a -> b) -> a -> b
$ forall (m :: Type -> Type) t (f :: BaseType -> Type)
(tp :: BaseType).
MonadIO m =>
IdxCache t f -> Nonce t tp -> m (f tp) -> m (f tp)
idxCacheEval' IdxCache t GroundValueWrapper
groundCache Nonce t tp
e_id forall a b. (a -> b) -> a -> b
$ forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (tp :: BaseType). GroundValue tp -> GroundValueWrapper tp
GVW forall a b. (a -> b) -> a -> b
$ do
Maybe (SMTExpr h tp)
me <- forall t h (tp :: BaseType).
WriterConn t h -> Nonce t tp -> IO (Maybe (SMTExpr h tp))
cacheLookupExpr WriterConn t h
conn Nonce t tp
e_id
case Maybe (SMTExpr h tp)
me of
Maybe (SMTExpr h tp)
Nothing -> forall t (tp :: BaseType).
(forall (u :: BaseType). Expr t u -> IO (GroundValue u))
-> Expr t tp -> IO (GroundValue tp)
evalGroundExpr forall (tp :: BaseType). Expr t tp -> IO (GroundValue tp)
cachedEval Expr t tp
e
Just (SMTName TypeMap tp
tp Text
nm) ->
forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h
-> SMTEvalFunctions h
-> TypeMap tp
-> Term h
-> IO (GroundValue tp)
getSolverVal WriterConn t h
conn SMTEvalFunctions h
smtFns TypeMap tp
tp (forall v. SupportTermOps v => Text -> v
fromText Text
nm)
Just (SMTExpr TypeMap tp
tp Term h
expr) ->
forall (m :: Type -> Type) a. MaybeT m a -> m (Maybe a)
runMaybeT (forall t (tp :: BaseType).
(forall (u :: BaseType). Expr t u -> MaybeT IO (GroundValue u))
-> Expr t tp -> MaybeT IO (GroundValue tp)
tryEvalGroundExpr (forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (tp :: BaseType). Expr t tp -> IO (GroundValue tp)
cachedEval) Expr t tp
e) forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just GroundValue tp
x -> forall (m :: Type -> Type) a. Monad m => a -> m a
return GroundValue tp
x
Maybe (GroundValue tp)
Nothing -> forall h t (tp :: BaseType).
SMTWriter h =>
WriterConn t h
-> SMTEvalFunctions h
-> TypeMap tp
-> Term h
-> IO (GroundValue tp)
getSolverVal WriterConn t h
conn SMTEvalFunctions h
smtFns TypeMap tp
tp Term h
expr
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall t.
(forall (tp :: BaseType). Expr t tp -> IO (GroundValue tp))
-> GroundEvalFn t
GroundEvalFn forall (tp :: BaseType). Expr t tp -> IO (GroundValue tp)
cachedEval