{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}
module Data.SBV.Control.Utils (
io
, ask, send, getValue, getFunction, getUninterpretedValue
, getValueCV, getUICVal, getUIFunCVAssoc, getUnsatAssumptions
, SMTFunction(..), registerUISMTFunction
, getQueryState, modifyQueryState, getConfig, getObjectives, getUIs
, getSBVAssertions, getSBVPgm, getObservables
, checkSat, checkSatUsing, getAllSatResult
, inNewContext, freshVar, freshVar_, freshArray, freshArray_, freshLambdaArray, freshLambdaArray_
, getTopLevelInputs, parse, unexpected
, timeout, queryDebug, retrieveResponse, recoverKindedValue, runProofOn, executeQuery
) where
import Data.List (sortBy, sortOn, elemIndex, partition, groupBy, tails, intercalate, nub, sort, isPrefixOf, isSuffixOf)
import Data.Char (isPunctuation, isSpace, isDigit)
import Data.Function (on)
import Data.Bifunctor (first)
import Data.Proxy
import qualified Data.Foldable as F (toList)
import qualified Data.Map.Strict as Map
import qualified Data.IntMap.Strict as IMap
import qualified Data.Sequence as S
import qualified Data.Text as T
import Control.Monad (join, unless, zipWithM, when, replicateM, forM_)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans (lift)
import Control.Monad.Reader (runReaderT)
import Data.Maybe (isNothing, isJust, mapMaybe)
import Data.IORef (readIORef, writeIORef, IORef, newIORef, modifyIORef')
import Data.Time (getZonedTime)
import Data.Ratio
import Data.SBV.Core.Data ( SV(..), trueSV, falseSV, CV(..), trueCV, falseCV, SBV, sbvToSV, kindOf, Kind(..)
, HasKind(..), mkConstCV, CVal(..), SMTResult(..)
, NamedSymVar, SMTConfig(..), SMTModel(..)
, QueryState(..), SVal(..), cache
, newExpr, SBVExpr(..), Op(..), FPOp(..), SBV(..), SymArray(..)
, SolverContext(..), SBool, Objective(..), SolverCapabilities(..), capabilities
, Result(..), SMTProblem(..), trueSV, SymVal(..), SBVPgm(..), SMTSolver(..), SBVRunMode(..)
, SBVType(..), forceSVArg, RoundingMode(RoundNearestTiesToEven), (.=>)
, RCSet(..), Lambda(..), QuantifiedBool(..)
)
import Data.SBV.Core.Symbolic ( IncState(..), withNewIncState, State(..), svToSV, symbolicEnv, SymbolicT
, MonadQuery(..), QueryContext(..), Queriable(..), Fresh(..), VarContext(..)
, registerLabel, svMkSymVar, validationRequested
, isSafetyCheckingIStage, isSetupIStage, isRunIStage, IStage(..), QueryT(..)
, extractSymbolicSimulationState, MonadSymbolic(..), newUninterpreted
, UserInputs, getSV, NamedSymVar(..), lookupInput, getUserName'
, Name, CnstMap, UICodeKind(UINone), smtDefGivenName, Inputs(..), ProgInfo(..)
, mustIgnoreVar
)
import Data.SBV.Core.AlgReals (mergeAlgReals, AlgReal(..), RealPoint(..))
import Data.SBV.Core.SizedFloats (fpZero, fpFromInteger, fpFromFloat, fpFromDouble)
import Data.SBV.Core.Kind (smtType, hasUninterpretedSorts)
import Data.SBV.Core.Operations (svNot, svNotEqual, svOr, svEqual)
import Data.SBV.SMT.SMT (showModel, parseCVs, SatModel, AllSatResult(..))
import Data.SBV.SMT.SMTLib (toIncSMTLib, toSMTLib)
import Data.SBV.SMT.Utils (showTimeoutValue, addAnnotations, alignPlain, debug, mergeSExpr, SBVException(..))
import Data.SBV.Utils.ExtractIO
import Data.SBV.Utils.Lib (qfsToString)
import Data.SBV.Utils.SExpr
import Data.SBV.Utils.PrettyNum (cvToSMTLib)
import Data.SBV.Lambda
import Data.SBV.Control.Types
import qualified Data.Set as Set (empty, fromList, toAscList)
import qualified Control.Exception as C
import GHC.Stack
instance MonadIO m => SolverContext (QueryT m) where
constrain :: forall a. QuantifiedBool a => a -> QueryT m ()
constrain = Bool -> [([Char], [Char])] -> SBool -> QueryT m ()
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Bool -> [([Char], [Char])] -> SBool -> m ()
addQueryConstraint Bool
False [] (SBool -> QueryT m ()) -> (a -> SBool) -> a -> QueryT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SBool
forall a. QuantifiedBool a => a -> SBool
quantifiedBool
softConstrain :: forall a. QuantifiedBool a => a -> QueryT m ()
softConstrain = Bool -> [([Char], [Char])] -> SBool -> QueryT m ()
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Bool -> [([Char], [Char])] -> SBool -> m ()
addQueryConstraint Bool
True [] (SBool -> QueryT m ()) -> (a -> SBool) -> a -> QueryT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SBool
forall a. QuantifiedBool a => a -> SBool
quantifiedBool
namedConstraint :: forall a. QuantifiedBool a => [Char] -> a -> QueryT m ()
namedConstraint [Char]
nm = Bool -> [([Char], [Char])] -> SBool -> QueryT m ()
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Bool -> [([Char], [Char])] -> SBool -> m ()
addQueryConstraint Bool
False [([Char]
":named", [Char]
nm)] (SBool -> QueryT m ()) -> (a -> SBool) -> a -> QueryT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SBool
forall a. QuantifiedBool a => a -> SBool
quantifiedBool
constrainWithAttribute :: forall a.
QuantifiedBool a =>
[([Char], [Char])] -> a -> QueryT m ()
constrainWithAttribute [([Char], [Char])]
attr = Bool -> [([Char], [Char])] -> SBool -> QueryT m ()
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Bool -> [([Char], [Char])] -> SBool -> m ()
addQueryConstraint Bool
False [([Char], [Char])]
attr (SBool -> QueryT m ()) -> (a -> SBool) -> a -> QueryT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SBool
forall a. QuantifiedBool a => a -> SBool
quantifiedBool
contextState :: QueryT m State
contextState = QueryT m State
forall (m :: * -> *). MonadQuery m => m State
queryState
setOption :: SMTOption -> QueryT m ()
setOption SMTOption
o
| SMTOption -> Bool
isStartModeOption SMTOption
o = [Char] -> QueryT m ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> QueryT m ()) -> [Char] -> QueryT m ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [ [Char]
""
, [Char]
"*** Data.SBV: '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SMTOption -> [Char]
forall a. Show a => a -> [Char]
show SMTOption
o [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"' can only be set at start-up time."
, [Char]
"*** Hint: Move the call to 'setOption' before the query."
]
| Bool
True = Bool -> [Char] -> QueryT m ()
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Bool -> [Char] -> m ()
send Bool
True ([Char] -> QueryT m ()) -> [Char] -> QueryT m ()
forall a b. (a -> b) -> a -> b
$ SMTOption -> [Char]
setSMTOption SMTOption
o
addQueryConstraint :: (MonadIO m, MonadQuery m) => Bool -> [(String, String)] -> SBool -> m ()
addQueryConstraint :: forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Bool -> [([Char], [Char])] -> SBool -> m ()
addQueryConstraint Bool
isSoft [([Char], [Char])]
atts SBool
b = do SV
sv <- (State -> IO SV) -> m SV
forall (m :: * -> *) a.
(MonadIO m, MonadQuery m) =>
(State -> IO a) -> m a
inNewContext (\State
st -> IO SV -> IO SV
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SV -> IO SV) -> IO SV -> IO SV
forall a b. (a -> b) -> a -> b
$ do ([Char] -> IO ()) -> [[Char]] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([Char] -> State -> [Char] -> IO ()
registerLabel [Char]
"Constraint" State
st) [[Char]
nm | ([Char]
":named", [Char]
nm) <- [([Char], [Char])]
atts]
State -> SBool -> IO SV
forall a. State -> SBV a -> IO SV
sbvToSV State
st SBool
b)
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([([Char], [Char])] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [([Char], [Char])]
atts Bool -> Bool -> Bool
&& SV
sv SV -> SV -> Bool
forall a. Eq a => a -> a -> Bool
== SV
trueSV) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
Bool -> [Char] -> m ()
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Bool -> [Char] -> m ()
send Bool
True ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
asrt [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [([Char], [Char])] -> [Char] -> [Char]
addAnnotations [([Char], [Char])]
atts (SV -> [Char]
forall a. Show a => a -> [Char]
show SV
sv) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
where asrt :: [Char]
asrt | Bool
isSoft = [Char]
"assert-soft"
| Bool
True = [Char]
"assert"
getConfig :: (MonadIO m, MonadQuery m) => m SMTConfig
getConfig :: forall (m :: * -> *). (MonadIO m, MonadQuery m) => m SMTConfig
getConfig = QueryState -> SMTConfig
queryConfig (QueryState -> SMTConfig) -> m QueryState -> m SMTConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m QueryState
forall (m :: * -> *). (MonadIO m, MonadQuery m) => m QueryState
getQueryState
getObjectives :: (MonadIO m, MonadQuery m) => m [Objective (SV, SV)]
getObjectives :: forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
m [Objective (SV, SV)]
getObjectives = do State{IORef [Objective (SV, SV)]
rOptGoals :: IORef [Objective (SV, SV)]
rOptGoals :: State -> IORef [Objective (SV, SV)]
rOptGoals} <- m State
forall (m :: * -> *). MonadQuery m => m State
queryState
IO [Objective (SV, SV)] -> m [Objective (SV, SV)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO [Objective (SV, SV)] -> m [Objective (SV, SV)])
-> IO [Objective (SV, SV)] -> m [Objective (SV, SV)]
forall a b. (a -> b) -> a -> b
$ [Objective (SV, SV)] -> [Objective (SV, SV)]
forall a. [a] -> [a]
reverse ([Objective (SV, SV)] -> [Objective (SV, SV)])
-> IO [Objective (SV, SV)] -> IO [Objective (SV, SV)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [Objective (SV, SV)] -> IO [Objective (SV, SV)]
forall a. IORef a -> IO a
readIORef IORef [Objective (SV, SV)]
rOptGoals
getSBVPgm :: (MonadIO m, MonadQuery m) => m SBVPgm
getSBVPgm :: forall (m :: * -> *). (MonadIO m, MonadQuery m) => m SBVPgm
getSBVPgm = do State{IORef SBVPgm
spgm :: IORef SBVPgm
spgm :: State -> IORef SBVPgm
spgm} <- m State
forall (m :: * -> *). MonadQuery m => m State
queryState
IO SBVPgm -> m SBVPgm
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO SBVPgm -> m SBVPgm) -> IO SBVPgm -> m SBVPgm
forall a b. (a -> b) -> a -> b
$ IORef SBVPgm -> IO SBVPgm
forall a. IORef a -> IO a
readIORef IORef SBVPgm
spgm
getSBVAssertions :: (MonadIO m, MonadQuery m) => m [(String, Maybe CallStack, SV)]
getSBVAssertions :: forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
m [([Char], Maybe CallStack, SV)]
getSBVAssertions = do State{IORef [([Char], Maybe CallStack, SV)]
rAsserts :: IORef [([Char], Maybe CallStack, SV)]
rAsserts :: State -> IORef [([Char], Maybe CallStack, SV)]
rAsserts} <- m State
forall (m :: * -> *). MonadQuery m => m State
queryState
IO [([Char], Maybe CallStack, SV)]
-> m [([Char], Maybe CallStack, SV)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO [([Char], Maybe CallStack, SV)]
-> m [([Char], Maybe CallStack, SV)])
-> IO [([Char], Maybe CallStack, SV)]
-> m [([Char], Maybe CallStack, SV)]
forall a b. (a -> b) -> a -> b
$ [([Char], Maybe CallStack, SV)] -> [([Char], Maybe CallStack, SV)]
forall a. [a] -> [a]
reverse ([([Char], Maybe CallStack, SV)]
-> [([Char], Maybe CallStack, SV)])
-> IO [([Char], Maybe CallStack, SV)]
-> IO [([Char], Maybe CallStack, SV)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [([Char], Maybe CallStack, SV)]
-> IO [([Char], Maybe CallStack, SV)]
forall a. IORef a -> IO a
readIORef IORef [([Char], Maybe CallStack, SV)]
rAsserts
io :: MonadIO m => IO a -> m a
io :: forall (m :: * -> *) a. MonadIO m => IO a -> m a
io = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
syncUpSolver :: (MonadIO m, MonadQuery m) => ProgInfo -> IORef CnstMap -> IncState -> m ()
syncUpSolver :: forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
ProgInfo -> IORef CnstMap -> IncState -> m ()
syncUpSolver ProgInfo
progInfo IORef CnstMap
rGlobalConsts IncState
is = do
SMTConfig
cfg <- m SMTConfig
forall (m :: * -> *). (MonadIO m, MonadQuery m) => m SMTConfig
getConfig
(CnstMap
newConsts, CnstMap
allConsts) <- IO (CnstMap, CnstMap) -> m (CnstMap, CnstMap)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (CnstMap, CnstMap) -> m (CnstMap, CnstMap))
-> IO (CnstMap, CnstMap) -> m (CnstMap, CnstMap)
forall a b. (a -> b) -> a -> b
$ do CnstMap
nc <- IORef CnstMap -> IO CnstMap
forall a. IORef a -> IO a
readIORef (IncState -> IORef CnstMap
rNewConsts IncState
is)
CnstMap
oc <- IORef CnstMap -> IO CnstMap
forall a. IORef a -> IO a
readIORef IORef CnstMap
rGlobalConsts
let allConsts :: CnstMap
allConsts = CnstMap -> CnstMap -> CnstMap
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union CnstMap
nc CnstMap
oc
IORef CnstMap -> CnstMap -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef CnstMap
rGlobalConsts CnstMap
allConsts
(CnstMap, CnstMap) -> IO (CnstMap, CnstMap)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CnstMap
nc, CnstMap
allConsts)
[[Char]]
ls <- IO [[Char]] -> m [[Char]]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO [[Char]] -> m [[Char]]) -> IO [[Char]] -> m [[Char]]
forall a b. (a -> b) -> a -> b
$ do let swap :: (b, a) -> (a, b)
swap (b
a, a
b) = (a
b, b
a)
cmp :: (a, b) -> (a, b) -> Ordering
cmp (a
a, b
_) (a
b, b
_) = a
a a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` a
b
arrange :: (a, (b, c, b)) -> ((a, b, c), b)
arrange (a
i, (b
at, c
rt, b
es)) = ((a
i, b
at, c
rt), b
es)
[NamedSymVar]
inps <- [NamedSymVar] -> [NamedSymVar]
forall a. [a] -> [a]
reverse ([NamedSymVar] -> [NamedSymVar])
-> IO [NamedSymVar] -> IO [NamedSymVar]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [NamedSymVar] -> IO [NamedSymVar]
forall a. IORef a -> IO a
readIORef (IncState -> IORef [NamedSymVar]
rNewInps IncState
is)
KindSet
ks <- IORef KindSet -> IO KindSet
forall a. IORef a -> IO a
readIORef (IncState -> IORef KindSet
rNewKinds IncState
is)
[(Int, ArrayInfo)]
arrs <- IntMap ArrayInfo -> [(Int, ArrayInfo)]
forall a. IntMap a -> [(Int, a)]
IMap.toAscList (IntMap ArrayInfo -> [(Int, ArrayInfo)])
-> IO (IntMap ArrayInfo) -> IO [(Int, ArrayInfo)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (IntMap ArrayInfo) -> IO (IntMap ArrayInfo)
forall a. IORef a -> IO a
readIORef (IncState -> IORef (IntMap ArrayInfo)
rNewArrs IncState
is)
[((Int, Kind, Kind), [SV])]
tbls <- ((Int, (Kind, Kind, [SV])) -> ((Int, Kind, Kind), [SV]))
-> [(Int, (Kind, Kind, [SV]))] -> [((Int, Kind, Kind), [SV])]
forall a b. (a -> b) -> [a] -> [b]
map (Int, (Kind, Kind, [SV])) -> ((Int, Kind, Kind), [SV])
forall {a} {b} {c} {b}. (a, (b, c, b)) -> ((a, b, c), b)
arrange ([(Int, (Kind, Kind, [SV]))] -> [((Int, Kind, Kind), [SV])])
-> (Map (Kind, Kind, [SV]) Int -> [(Int, (Kind, Kind, [SV]))])
-> Map (Kind, Kind, [SV]) Int
-> [((Int, Kind, Kind), [SV])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, (Kind, Kind, [SV]))
-> (Int, (Kind, Kind, [SV])) -> Ordering)
-> [(Int, (Kind, Kind, [SV]))] -> [(Int, (Kind, Kind, [SV]))]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Int, (Kind, Kind, [SV])) -> (Int, (Kind, Kind, [SV])) -> Ordering
forall {a} {b} {b}. Ord a => (a, b) -> (a, b) -> Ordering
cmp ([(Int, (Kind, Kind, [SV]))] -> [(Int, (Kind, Kind, [SV]))])
-> (Map (Kind, Kind, [SV]) Int -> [(Int, (Kind, Kind, [SV]))])
-> Map (Kind, Kind, [SV]) Int
-> [(Int, (Kind, Kind, [SV]))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((Kind, Kind, [SV]), Int) -> (Int, (Kind, Kind, [SV])))
-> [((Kind, Kind, [SV]), Int)] -> [(Int, (Kind, Kind, [SV]))]
forall a b. (a -> b) -> [a] -> [b]
map ((Kind, Kind, [SV]), Int) -> (Int, (Kind, Kind, [SV]))
forall {b} {a}. (b, a) -> (a, b)
swap ([((Kind, Kind, [SV]), Int)] -> [(Int, (Kind, Kind, [SV]))])
-> (Map (Kind, Kind, [SV]) Int -> [((Kind, Kind, [SV]), Int)])
-> Map (Kind, Kind, [SV]) Int
-> [(Int, (Kind, Kind, [SV]))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (Kind, Kind, [SV]) Int -> [((Kind, Kind, [SV]), Int)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map (Kind, Kind, [SV]) Int -> [((Int, Kind, Kind), [SV])])
-> IO (Map (Kind, Kind, [SV]) Int)
-> IO [((Int, Kind, Kind), [SV])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map (Kind, Kind, [SV]) Int)
-> IO (Map (Kind, Kind, [SV]) Int)
forall a. IORef a -> IO a
readIORef (IncState -> IORef (Map (Kind, Kind, [SV]) Int)
rNewTbls IncState
is)
[([Char], (Bool, Maybe [[Char]], SBVType))]
uis <- Map [Char] (Bool, Maybe [[Char]], SBVType)
-> [([Char], (Bool, Maybe [[Char]], SBVType))]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Map [Char] (Bool, Maybe [[Char]], SBVType)
-> [([Char], (Bool, Maybe [[Char]], SBVType))])
-> IO (Map [Char] (Bool, Maybe [[Char]], SBVType))
-> IO [([Char], (Bool, Maybe [[Char]], SBVType))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map [Char] (Bool, Maybe [[Char]], SBVType))
-> IO (Map [Char] (Bool, Maybe [[Char]], SBVType))
forall a. IORef a -> IO a
readIORef (IncState -> IORef (Map [Char] (Bool, Maybe [[Char]], SBVType))
rNewUIs IncState
is)
SBVPgm
as <- IORef SBVPgm -> IO SBVPgm
forall a. IORef a -> IO a
readIORef (IncState -> IORef SBVPgm
rNewAsgns IncState
is)
Seq (Bool, [([Char], [Char])], SV)
constraints <- IORef (Seq (Bool, [([Char], [Char])], SV))
-> IO (Seq (Bool, [([Char], [Char])], SV))
forall a. IORef a -> IO a
readIORef (IncState -> IORef (Seq (Bool, [([Char], [Char])], SV))
rNewConstraints IncState
is)
let cnsts :: [(SV, CV)]
cnsts = ((SV, CV) -> (SV, CV) -> Ordering) -> [(SV, CV)] -> [(SV, CV)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (SV, CV) -> (SV, CV) -> Ordering
forall {a} {b} {b}. Ord a => (a, b) -> (a, b) -> Ordering
cmp ([(SV, CV)] -> [(SV, CV)])
-> (CnstMap -> [(SV, CV)]) -> CnstMap -> [(SV, CV)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((CV, SV) -> (SV, CV)) -> [(CV, SV)] -> [(SV, CV)]
forall a b. (a -> b) -> [a] -> [b]
map (CV, SV) -> (SV, CV)
forall {b} {a}. (b, a) -> (a, b)
swap ([(CV, SV)] -> [(SV, CV)])
-> (CnstMap -> [(CV, SV)]) -> CnstMap -> [(SV, CV)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CnstMap -> [(CV, SV)]
forall k a. Map k a -> [(k, a)]
Map.toList (CnstMap -> [(SV, CV)]) -> CnstMap -> [(SV, CV)]
forall a b. (a -> b) -> a -> b
$ CnstMap
newConsts
[[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Char]] -> IO [[Char]]) -> [[Char]] -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$ SMTConfig -> SMTLibIncConverter [[Char]]
toIncSMTLib SMTConfig
cfg ProgInfo
progInfo [NamedSymVar]
inps KindSet
ks (CnstMap
allConsts, [(SV, CV)]
cnsts) [(Int, ArrayInfo)]
arrs [((Int, Kind, Kind), [SV])]
tbls [([Char], (Bool, Maybe [[Char]], SBVType))]
uis SBVPgm
as Seq (Bool, [([Char], [Char])], SV)
constraints SMTConfig
cfg
([Char] -> m ()) -> [[Char]] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool -> [Char] -> m ()
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Bool -> [Char] -> m ()
send Bool
True) ([[Char]] -> m ()) -> [[Char]] -> m ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [[Char]]
mergeSExpr [[Char]]
ls
getQueryState :: (MonadIO m, MonadQuery m) => m QueryState
getQueryState :: forall (m :: * -> *). (MonadIO m, MonadQuery m) => m QueryState
getQueryState = do State
state <- m State
forall (m :: * -> *). MonadQuery m => m State
queryState
Maybe QueryState
mbQS <- IO (Maybe QueryState) -> m (Maybe QueryState)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Maybe QueryState) -> m (Maybe QueryState))
-> IO (Maybe QueryState) -> m (Maybe QueryState)
forall a b. (a -> b) -> a -> b
$ IORef (Maybe QueryState) -> IO (Maybe QueryState)
forall a. IORef a -> IO a
readIORef (State -> IORef (Maybe QueryState)
rQueryState State
state)
case Maybe QueryState
mbQS of
Maybe QueryState
Nothing -> [Char] -> m QueryState
forall a. HasCallStack => [Char] -> a
error ([Char] -> m QueryState) -> [Char] -> m QueryState
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [ [Char]
""
, [Char]
"*** Data.SBV: Impossible happened: Query context required in a non-query mode."
, [Char]
"Please report this as a bug!"
]
Just QueryState
qs -> QueryState -> m QueryState
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return QueryState
qs
modifyQueryState :: (MonadIO m, MonadQuery m) => (QueryState -> QueryState) -> m ()
modifyQueryState :: forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
(QueryState -> QueryState) -> m ()
modifyQueryState QueryState -> QueryState
f = do State
state <- m State
forall (m :: * -> *). MonadQuery m => m State
queryState
Maybe QueryState
mbQS <- IO (Maybe QueryState) -> m (Maybe QueryState)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Maybe QueryState) -> m (Maybe QueryState))
-> IO (Maybe QueryState) -> m (Maybe QueryState)
forall a b. (a -> b) -> a -> b
$ IORef (Maybe QueryState) -> IO (Maybe QueryState)
forall a. IORef a -> IO a
readIORef (State -> IORef (Maybe QueryState)
rQueryState State
state)
case Maybe QueryState
mbQS of
Maybe QueryState
Nothing -> [Char] -> m ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [ [Char]
""
, [Char]
"*** Data.SBV: Impossible happened: Query context required in a non-query mode."
, [Char]
"Please report this as a bug!"
]
Just QueryState
qs -> let fqs :: QueryState
fqs = QueryState -> QueryState
f QueryState
qs
in QueryState
fqs QueryState -> m () -> m ()
forall a b. a -> b -> b
`seq` IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe QueryState) -> Maybe QueryState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (State -> IORef (Maybe QueryState)
rQueryState State
state) (Maybe QueryState -> IO ()) -> Maybe QueryState -> IO ()
forall a b. (a -> b) -> a -> b
$ QueryState -> Maybe QueryState
forall a. a -> Maybe a
Just QueryState
fqs
inNewContext :: (MonadIO m, MonadQuery m) => (State -> IO a) -> m a
inNewContext :: forall (m :: * -> *) a.
(MonadIO m, MonadQuery m) =>
(State -> IO a) -> m a
inNewContext State -> IO a
act = do st :: State
st@State{IORef CnstMap
rconstMap :: IORef CnstMap
rconstMap :: State -> IORef CnstMap
rconstMap, IORef ProgInfo
rProgInfo :: IORef ProgInfo
rProgInfo :: State -> IORef ProgInfo
rProgInfo} <- m State
forall (m :: * -> *). MonadQuery m => m State
queryState
(IncState
is, a
r) <- IO (IncState, a) -> m (IncState, a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (IncState, a) -> m (IncState, a))
-> IO (IncState, a) -> m (IncState, a)
forall a b. (a -> b) -> a -> b
$ State -> (State -> IO a) -> IO (IncState, a)
forall a. State -> (State -> IO a) -> IO (IncState, a)
withNewIncState State
st State -> IO a
act
ProgInfo
progInfo <- IO ProgInfo -> m ProgInfo
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO ProgInfo -> m ProgInfo) -> IO ProgInfo -> m ProgInfo
forall a b. (a -> b) -> a -> b
$ IORef ProgInfo -> IO ProgInfo
forall a. IORef a -> IO a
readIORef IORef ProgInfo
rProgInfo
ProgInfo -> IORef CnstMap -> IncState -> m ()
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
ProgInfo -> IORef CnstMap -> IncState -> m ()
syncUpSolver ProgInfo
progInfo IORef CnstMap
rconstMap IncState
is
a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
instance (MonadIO m, SymVal a) => Queriable m (SBV a) where
type QueryResult (SBV a) = a
create :: QueryT m (SBV a)
create = QueryT m (SBV a)
forall a (m :: * -> *).
(MonadIO m, MonadQuery m, SymVal a) =>
m (SBV a)
freshVar_
project :: SBV a -> QueryT m (QueryResult (SBV a))
project = SBV a -> QueryT m a
SBV a -> QueryT m (QueryResult (SBV a))
forall (m :: * -> *) a.
(MonadIO m, MonadQuery m, SymVal a) =>
SBV a -> m a
getValue
embed :: QueryResult (SBV a) -> QueryT m (SBV a)
embed = SBV a -> QueryT m (SBV a)
forall a. a -> QueryT m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SBV a -> QueryT m (SBV a))
-> (a -> SBV a) -> a -> QueryT m (SBV a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SBV a
forall a. SymVal a => a -> SBV a
literal
instance (MonadIO m, SymVal a, Foldable t, Traversable t, Fresh m (t (SBV a))) => Queriable m (t (SBV a)) where
type QueryResult (t (SBV a)) = t a
create :: QueryT m (t (SBV a))
create = QueryT m (t (SBV a))
forall (m :: * -> *) a. Fresh m a => QueryT m a
fresh
project :: t (SBV a) -> QueryT m (QueryResult (t (SBV a)))
project = (SBV a -> QueryT m a) -> t (SBV a) -> QueryT m (t a)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> t a -> m (t b)
mapM SBV a -> QueryT m a
forall (m :: * -> *) a.
(MonadIO m, MonadQuery m, SymVal a) =>
SBV a -> m a
getValue
embed :: QueryResult (t (SBV a)) -> QueryT m (t (SBV a))
embed = t (SBV a) -> QueryT m (t (SBV a))
forall a. a -> QueryT m a
forall (m :: * -> *) a. Monad m => a -> m a
return (t (SBV a) -> QueryT m (t (SBV a)))
-> (t a -> t (SBV a)) -> t a -> QueryT m (t (SBV a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> SBV a) -> t a -> t (SBV a)
forall a b. (a -> b) -> t a -> t b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> SBV a
forall a. SymVal a => a -> SBV a
literal
freshVar_ :: forall a m. (MonadIO m, MonadQuery m, SymVal a) => m (SBV a)
freshVar_ :: forall a (m :: * -> *).
(MonadIO m, MonadQuery m, SymVal a) =>
m (SBV a)
freshVar_ = (State -> IO (SBV a)) -> m (SBV a)
forall (m :: * -> *) a.
(MonadIO m, MonadQuery m) =>
(State -> IO a) -> m a
inNewContext ((State -> IO (SBV a)) -> m (SBV a))
-> (State -> IO (SBV a)) -> m (SBV a)
forall a b. (a -> b) -> a -> b
$ (SVal -> SBV a) -> IO SVal -> IO (SBV a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SVal -> SBV a
forall a. SVal -> SBV a
SBV (IO SVal -> IO (SBV a))
-> (State -> IO SVal) -> State -> IO (SBV a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarContext -> Kind -> Maybe [Char] -> State -> IO SVal
svMkSymVar VarContext
QueryVar Kind
k Maybe [Char]
forall a. Maybe a
Nothing
where k :: Kind
k = Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)
freshVar :: forall a m. (MonadIO m, MonadQuery m, SymVal a) => String -> m (SBV a)
freshVar :: forall a (m :: * -> *).
(MonadIO m, MonadQuery m, SymVal a) =>
[Char] -> m (SBV a)
freshVar [Char]
nm = (State -> IO (SBV a)) -> m (SBV a)
forall (m :: * -> *) a.
(MonadIO m, MonadQuery m) =>
(State -> IO a) -> m a
inNewContext ((State -> IO (SBV a)) -> m (SBV a))
-> (State -> IO (SBV a)) -> m (SBV a)
forall a b. (a -> b) -> a -> b
$ (SVal -> SBV a) -> IO SVal -> IO (SBV a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SVal -> SBV a
forall a. SVal -> SBV a
SBV (IO SVal -> IO (SBV a))
-> (State -> IO SVal) -> State -> IO (SBV a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarContext -> Kind -> Maybe [Char] -> State -> IO SVal
svMkSymVar VarContext
QueryVar Kind
k ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
nm)
where k :: Kind
k = Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)
freshArray_ :: (MonadIO m, MonadQuery m, SymArray array, HasKind a, HasKind b) => Maybe (SBV b) -> m (array a b)
freshArray_ :: forall (m :: * -> *) (array :: * -> * -> *) a b.
(MonadIO m, MonadQuery m, SymArray array, HasKind a, HasKind b) =>
Maybe (SBV b) -> m (array a b)
freshArray_ = Maybe [Char] -> Maybe (SBV b) -> m (array a b)
forall (m :: * -> *) (array :: * -> * -> *) a b.
(MonadIO m, MonadQuery m, SymArray array, HasKind a, HasKind b) =>
Maybe [Char] -> Maybe (SBV b) -> m (array a b)
mkFreshArray Maybe [Char]
forall a. Maybe a
Nothing
freshArray :: (MonadIO m, MonadQuery m, SymArray array, HasKind a, HasKind b) => String -> Maybe (SBV b) -> m (array a b)
freshArray :: forall (m :: * -> *) (array :: * -> * -> *) a b.
(MonadIO m, MonadQuery m, SymArray array, HasKind a, HasKind b) =>
[Char] -> Maybe (SBV b) -> m (array a b)
freshArray [Char]
nm = Maybe [Char] -> Maybe (SBV b) -> m (array a b)
forall (m :: * -> *) (array :: * -> * -> *) a b.
(MonadIO m, MonadQuery m, SymArray array, HasKind a, HasKind b) =>
Maybe [Char] -> Maybe (SBV b) -> m (array a b)
mkFreshArray ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
nm)
mkFreshArray :: (MonadIO m, MonadQuery m, SymArray array, HasKind a, HasKind b) => Maybe String -> Maybe (SBV b) -> m (array a b)
mkFreshArray :: forall (m :: * -> *) (array :: * -> * -> *) a b.
(MonadIO m, MonadQuery m, SymArray array, HasKind a, HasKind b) =>
Maybe [Char] -> Maybe (SBV b) -> m (array a b)
mkFreshArray Maybe [Char]
mbNm Maybe (SBV b)
mbVal = (State -> IO (array a b)) -> m (array a b)
forall (m :: * -> *) a.
(MonadIO m, MonadQuery m) =>
(State -> IO a) -> m a
inNewContext ((State -> IO (array a b)) -> m (array a b))
-> (State -> IO (array a b)) -> m (array a b)
forall a b. (a -> b) -> a -> b
$ Maybe [Char]
-> Either (Maybe (SBV b)) [Char] -> State -> IO (array a b)
forall a b.
(HasKind a, HasKind b) =>
Maybe [Char]
-> Either (Maybe (SBV b)) [Char] -> State -> IO (array a b)
forall (array :: * -> * -> *) a b.
(SymArray array, HasKind a, HasKind b) =>
Maybe [Char]
-> Either (Maybe (SBV b)) [Char] -> State -> IO (array a b)
newArrayInState Maybe [Char]
mbNm (Maybe (SBV b) -> Either (Maybe (SBV b)) [Char]
forall a b. a -> Either a b
Left Maybe (SBV b)
mbVal)
freshLambdaArray_ :: (MonadIO m, MonadQuery m, SymArray array, HasKind a, HasKind b, Lambda (SymbolicT IO) (a -> b)) => (a -> b) -> m (array a b)
freshLambdaArray_ :: forall (m :: * -> *) (array :: * -> * -> *) a b.
(MonadIO m, MonadQuery m, SymArray array, HasKind a, HasKind b,
Lambda (SymbolicT IO) (a -> b)) =>
(a -> b) -> m (array a b)
freshLambdaArray_ = Maybe [Char] -> (a -> b) -> m (array a b)
forall (m :: * -> *) (array :: * -> * -> *) a b.
(MonadIO m, MonadQuery m, SymArray array, HasKind a, HasKind b,
Lambda (SymbolicT IO) (a -> b)) =>
Maybe [Char] -> (a -> b) -> m (array a b)
mkFreshLambdaArray Maybe [Char]
forall a. Maybe a
Nothing
freshLambdaArray :: (MonadIO m, MonadQuery m, SymArray array, HasKind a, HasKind b, Lambda (SymbolicT IO) (a -> b)) => String -> (a -> b) -> m (array a b)
freshLambdaArray :: forall (m :: * -> *) (array :: * -> * -> *) a b.
(MonadIO m, MonadQuery m, SymArray array, HasKind a, HasKind b,
Lambda (SymbolicT IO) (a -> b)) =>
[Char] -> (a -> b) -> m (array a b)
freshLambdaArray [Char]
nm = Maybe [Char] -> (a -> b) -> m (array a b)
forall (m :: * -> *) (array :: * -> * -> *) a b.
(MonadIO m, MonadQuery m, SymArray array, HasKind a, HasKind b,
Lambda (SymbolicT IO) (a -> b)) =>
Maybe [Char] -> (a -> b) -> m (array a b)
mkFreshLambdaArray ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
nm)
mkFreshLambdaArray :: forall m array a b. (MonadIO m, MonadQuery m, SymArray array, HasKind a, HasKind b, Lambda (SymbolicT IO) (a -> b)) => Maybe String -> (a -> b) -> m (array a b)
mkFreshLambdaArray :: forall (m :: * -> *) (array :: * -> * -> *) a b.
(MonadIO m, MonadQuery m, SymArray array, HasKind a, HasKind b,
Lambda (SymbolicT IO) (a -> b)) =>
Maybe [Char] -> (a -> b) -> m (array a b)
mkFreshLambdaArray Maybe [Char]
mbNm a -> b
f = (State -> IO (array a b)) -> m (array a b)
forall (m :: * -> *) a.
(MonadIO m, MonadQuery m) =>
(State -> IO a) -> m a
inNewContext ((State -> IO (array a b)) -> m (array a b))
-> (State -> IO (array a b)) -> m (array a b)
forall a b. (a -> b) -> a -> b
$ \State
st -> do
[Char]
lam <- State -> Kind -> (a -> b) -> IO [Char]
forall (m :: * -> *) a.
(MonadIO m, Lambda (SymbolicT m) a) =>
State -> Kind -> a -> m [Char]
lambdaStr State
st (Proxy b -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b)) a -> b
f
Maybe [Char]
-> Either (Maybe (SBV b)) [Char] -> State -> IO (array a b)
forall a b.
(HasKind a, HasKind b) =>
Maybe [Char]
-> Either (Maybe (SBV b)) [Char] -> State -> IO (array a b)
forall (array :: * -> * -> *) a b.
(SymArray array, HasKind a, HasKind b) =>
Maybe [Char]
-> Either (Maybe (SBV b)) [Char] -> State -> IO (array a b)
newArrayInState Maybe [Char]
mbNm ([Char] -> Either (Maybe (SBV b)) [Char]
forall a b. b -> Either a b
Right [Char]
lam) State
st
queryDebug :: (MonadIO m, MonadQuery m) => [String] -> m ()
queryDebug :: forall (m :: * -> *). (MonadIO m, MonadQuery m) => [[Char]] -> m ()
queryDebug [[Char]]
msgs = do QueryState{SMTConfig
queryConfig :: QueryState -> SMTConfig
queryConfig :: SMTConfig
queryConfig} <- m QueryState
forall (m :: * -> *). (MonadIO m, MonadQuery m) => m QueryState
getQueryState
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ SMTConfig -> [[Char]] -> IO ()
forall (m :: * -> *). MonadIO m => SMTConfig -> [[Char]] -> m ()
debug SMTConfig
queryConfig [[Char]]
msgs
ask :: (MonadIO m, MonadQuery m) => String -> m String
ask :: forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
[Char] -> m [Char]
ask [Char]
s = do QueryState{Maybe Int -> [Char] -> IO [Char]
queryAsk :: Maybe Int -> [Char] -> IO [Char]
queryAsk :: QueryState -> Maybe Int -> [Char] -> IO [Char]
queryAsk, Maybe Int
queryTimeOutValue :: Maybe Int
queryTimeOutValue :: QueryState -> Maybe Int
queryTimeOutValue} <- m QueryState
forall (m :: * -> *). (MonadIO m, MonadQuery m) => m QueryState
getQueryState
case Maybe Int
queryTimeOutValue of
Maybe Int
Nothing -> [[Char]] -> m ()
forall (m :: * -> *). (MonadIO m, MonadQuery m) => [[Char]] -> m ()
queryDebug [[Char]
"[SEND] " [Char] -> [Char] -> [Char]
`alignPlain` [Char]
s]
Just Int
i -> [[Char]] -> m ()
forall (m :: * -> *). (MonadIO m, MonadQuery m) => [[Char]] -> m ()
queryDebug [[Char]
"[SEND, TimeOut: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
showTimeoutValue Int
i [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"] " [Char] -> [Char] -> [Char]
`alignPlain` [Char]
s]
[Char]
r <- IO [Char] -> m [Char]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO [Char] -> m [Char]) -> IO [Char] -> m [Char]
forall a b. (a -> b) -> a -> b
$ Maybe Int -> [Char] -> IO [Char]
queryAsk Maybe Int
queryTimeOutValue [Char]
s
[[Char]] -> m ()
forall (m :: * -> *). (MonadIO m, MonadQuery m) => [[Char]] -> m ()
queryDebug [[Char]
"[RECV] " [Char] -> [Char] -> [Char]
`alignPlain` [Char]
r]
[Char] -> m [Char]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
r
askIgnoring :: (MonadIO m, MonadQuery m) => String -> [String] -> m String
askIgnoring :: forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
[Char] -> [[Char]] -> m [Char]
askIgnoring [Char]
s [[Char]]
ignoreList = do
QueryState{Maybe Int -> [Char] -> IO [Char]
queryAsk :: QueryState -> Maybe Int -> [Char] -> IO [Char]
queryAsk :: Maybe Int -> [Char] -> IO [Char]
queryAsk, Maybe Int -> IO [Char]
queryRetrieveResponse :: Maybe Int -> IO [Char]
queryRetrieveResponse :: QueryState -> Maybe Int -> IO [Char]
queryRetrieveResponse, Maybe Int
queryTimeOutValue :: QueryState -> Maybe Int
queryTimeOutValue :: Maybe Int
queryTimeOutValue} <- m QueryState
forall (m :: * -> *). (MonadIO m, MonadQuery m) => m QueryState
getQueryState
case Maybe Int
queryTimeOutValue of
Maybe Int
Nothing -> [[Char]] -> m ()
forall (m :: * -> *). (MonadIO m, MonadQuery m) => [[Char]] -> m ()
queryDebug [[Char]
"[SEND] " [Char] -> [Char] -> [Char]
`alignPlain` [Char]
s]
Just Int
i -> [[Char]] -> m ()
forall (m :: * -> *). (MonadIO m, MonadQuery m) => [[Char]] -> m ()
queryDebug [[Char]
"[SEND, TimeOut: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
showTimeoutValue Int
i [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"] " [Char] -> [Char] -> [Char]
`alignPlain` [Char]
s]
[Char]
r <- IO [Char] -> m [Char]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO [Char] -> m [Char]) -> IO [Char] -> m [Char]
forall a b. (a -> b) -> a -> b
$ Maybe Int -> [Char] -> IO [Char]
queryAsk Maybe Int
queryTimeOutValue [Char]
s
[[Char]] -> m ()
forall (m :: * -> *). (MonadIO m, MonadQuery m) => [[Char]] -> m ()
queryDebug [[Char]
"[RECV] " [Char] -> [Char] -> [Char]
`alignPlain` [Char]
r]
let loop :: [Char] -> m [Char]
loop [Char]
currentResponse
| [Char]
currentResponse [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [[Char]]
ignoreList
= [Char] -> m [Char]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
currentResponse
| Bool
True
= do [[Char]] -> m ()
forall (m :: * -> *). (MonadIO m, MonadQuery m) => [[Char]] -> m ()
queryDebug [[Char]
"[WARN] Previous response is explicitly ignored, beware!"]
[Char]
newResponse <- IO [Char] -> m [Char]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO [Char] -> m [Char]) -> IO [Char] -> m [Char]
forall a b. (a -> b) -> a -> b
$ Maybe Int -> IO [Char]
queryRetrieveResponse Maybe Int
queryTimeOutValue
[[Char]] -> m ()
forall (m :: * -> *). (MonadIO m, MonadQuery m) => [[Char]] -> m ()
queryDebug [[Char]
"[RECV] " [Char] -> [Char] -> [Char]
`alignPlain` [Char]
newResponse]
[Char] -> m [Char]
loop [Char]
newResponse
[Char] -> m [Char]
loop [Char]
r
send :: (MonadIO m, MonadQuery m) => Bool -> String -> m ()
send :: forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Bool -> [Char] -> m ()
send Bool
requireSuccess [Char]
s = do
QueryState{Maybe Int -> [Char] -> IO [Char]
queryAsk :: QueryState -> Maybe Int -> [Char] -> IO [Char]
queryAsk :: Maybe Int -> [Char] -> IO [Char]
queryAsk, Maybe Int -> [Char] -> IO ()
querySend :: Maybe Int -> [Char] -> IO ()
querySend :: QueryState -> Maybe Int -> [Char] -> IO ()
querySend, SMTConfig
queryConfig :: QueryState -> SMTConfig
queryConfig :: SMTConfig
queryConfig, Maybe Int
queryTimeOutValue :: QueryState -> Maybe Int
queryTimeOutValue :: Maybe Int
queryTimeOutValue} <- m QueryState
forall (m :: * -> *). (MonadIO m, MonadQuery m) => m QueryState
getQueryState
if Bool
requireSuccess Bool -> Bool -> Bool
&& SolverCapabilities -> Bool
supportsCustomQueries (SMTSolver -> SolverCapabilities
capabilities (SMTConfig -> SMTSolver
solver SMTConfig
queryConfig))
then do [Char]
r <- IO [Char] -> m [Char]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO [Char] -> m [Char]) -> IO [Char] -> m [Char]
forall a b. (a -> b) -> a -> b
$ Maybe Int -> [Char] -> IO [Char]
queryAsk Maybe Int
queryTimeOutValue [Char]
s
case [Char] -> [[Char]]
words [Char]
r of
[[Char]
"success"] -> [[Char]] -> m ()
forall (m :: * -> *). (MonadIO m, MonadQuery m) => [[Char]] -> m ()
queryDebug [[Char]
"[GOOD] " [Char] -> [Char] -> [Char]
`alignPlain` [Char]
s]
[[Char]]
_ -> do case Maybe Int
queryTimeOutValue of
Maybe Int
Nothing -> [[Char]] -> m ()
forall (m :: * -> *). (MonadIO m, MonadQuery m) => [[Char]] -> m ()
queryDebug [[Char]
"[FAIL] " [Char] -> [Char] -> [Char]
`alignPlain` [Char]
s]
Just Int
i -> [[Char]] -> m ()
forall (m :: * -> *). (MonadIO m, MonadQuery m) => [[Char]] -> m ()
queryDebug [([Char]
"[FAIL, TimeOut: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
showTimeoutValue Int
i [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"] ") [Char] -> [Char] -> [Char]
`alignPlain` [Char]
s]
let cmd :: [Char]
cmd = case [Char] -> [[Char]]
words ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\Char
c -> Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
|| Char -> Bool
isPunctuation Char
c) [Char]
s) of
([Char]
c:[[Char]]
_) -> [Char]
c
[[Char]]
_ -> [Char]
"Command"
[Char]
-> [Char]
-> [Char]
-> Maybe [[Char]]
-> [Char]
-> Maybe [[Char]]
-> m ()
forall (m :: * -> *) a.
(MonadIO m, MonadQuery m) =>
[Char]
-> [Char]
-> [Char]
-> Maybe [[Char]]
-> [Char]
-> Maybe [[Char]]
-> m a
unexpected [Char]
cmd [Char]
s [Char]
"success" Maybe [[Char]]
forall a. Maybe a
Nothing [Char]
r Maybe [[Char]]
forall a. Maybe a
Nothing
else do
[[Char]] -> m ()
forall (m :: * -> *). (MonadIO m, MonadQuery m) => [[Char]] -> m ()
queryDebug [[Char]
"[FIRE] " [Char] -> [Char] -> [Char]
`alignPlain` [Char]
s]
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe Int -> [Char] -> IO ()
querySend Maybe Int
queryTimeOutValue [Char]
s
retrieveResponse :: (MonadIO m, MonadQuery m) => String -> Maybe Int -> m [String]
retrieveResponse :: forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
[Char] -> Maybe Int -> m [[Char]]
retrieveResponse [Char]
userTag Maybe Int
mbTo = do
[Char]
ts <- IO [Char] -> m [Char]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (ZonedTime -> [Char]
forall a. Show a => a -> [Char]
show (ZonedTime -> [Char]) -> IO ZonedTime -> IO [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ZonedTime
getZonedTime)
let synchTag :: [Char]
synchTag = [Char] -> [Char]
forall a. Show a => a -> [Char]
show ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
userTag [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (at: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ts [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
cmd :: [Char]
cmd = [Char]
"(echo " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
synchTag [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
[[Char]] -> m ()
forall (m :: * -> *). (MonadIO m, MonadQuery m) => [[Char]] -> m ()
queryDebug [[Char]
"[SYNC] Attempting to synchronize with tag: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
synchTag]
Bool -> [Char] -> m ()
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Bool -> [Char] -> m ()
send Bool
False [Char]
cmd
QueryState{Maybe Int -> IO [Char]
queryRetrieveResponse :: QueryState -> Maybe Int -> IO [Char]
queryRetrieveResponse :: Maybe Int -> IO [Char]
queryRetrieveResponse} <- m QueryState
forall (m :: * -> *). (MonadIO m, MonadQuery m) => m QueryState
getQueryState
let loop :: [[Char]] -> m [[Char]]
loop [[Char]]
sofar = do
[Char]
s <- IO [Char] -> m [Char]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO [Char] -> m [Char]) -> IO [Char] -> m [Char]
forall a b. (a -> b) -> a -> b
$ Maybe Int -> IO [Char]
queryRetrieveResponse Maybe Int
mbTo
if [Char]
s [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
synchTag Bool -> Bool -> Bool
|| [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
s [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
synchTag
then do [[Char]] -> m ()
forall (m :: * -> *). (MonadIO m, MonadQuery m) => [[Char]] -> m ()
queryDebug [[Char]
"[SYNC] Synchronization achieved using tag: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
synchTag]
[[Char]] -> m [[Char]]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Char]] -> m [[Char]]) -> [[Char]] -> m [[Char]]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [[Char]]
forall a. [a] -> [a]
reverse [[Char]]
sofar
else do [[Char]] -> m ()
forall (m :: * -> *). (MonadIO m, MonadQuery m) => [[Char]] -> m ()
queryDebug [[Char]
"[RECV] " [Char] -> [Char] -> [Char]
`alignPlain` [Char]
s]
[[Char]] -> m [[Char]]
loop ([Char]
s [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
sofar)
[[Char]] -> m [[Char]]
loop []
getValue :: (MonadIO m, MonadQuery m, SymVal a) => SBV a -> m a
getValue :: forall (m :: * -> *) a.
(MonadIO m, MonadQuery m, SymVal a) =>
SBV a -> m a
getValue SBV a
s = do SV
sv <- (State -> IO SV) -> m SV
forall (m :: * -> *) a.
(MonadIO m, MonadQuery m) =>
(State -> IO a) -> m a
inNewContext (State -> SBV a -> IO SV
forall a. State -> SBV a -> IO SV
`sbvToSV` SBV a
s)
CV
cv <- Maybe Int -> SV -> m CV
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Maybe Int -> SV -> m CV
getValueCV Maybe Int
forall a. Maybe a
Nothing SV
sv
a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$ CV -> a
forall a. SymVal a => CV -> a
fromCV CV
cv
class (HasKind r, SatModel r) => SMTFunction fun a r | fun -> a r where
sexprToArg :: fun -> [SExpr] -> Maybe a
smtFunName :: (MonadIO m, SolverContext m, MonadSymbolic m) => fun -> m ((String, Maybe [String]), Bool)
smtFunSaturate :: fun -> SBV r
smtFunType :: fun -> SBVType
smtFunDefault :: fun -> Maybe r
sexprToFun :: (MonadIO m, SolverContext m, MonadQuery m, MonadSymbolic m, SymVal r) => fun -> (String, SExpr) -> m (Either String ([(a, r)], r))
{-# MINIMAL sexprToArg, smtFunSaturate, smtFunType #-}
smtFunDefault fun
_
| let v :: CV
v = Kind -> CV
defaultKindedValue (Proxy r -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @r)), Just (r
res, []) <- [CV] -> Maybe (r, [CV])
forall a. SatModel a => [CV] -> Maybe (a, [CV])
parseCVs [CV
v]
= r -> Maybe r
forall a. a -> Maybe a
Just r
res
| Bool
True
= Maybe r
forall a. Maybe a
Nothing
smtFunName fun
f = do st :: State
st@State{IORef (Map [Char] (Bool, Maybe [[Char]], SBVType))
rUIMap :: IORef (Map [Char] (Bool, Maybe [[Char]], SBVType))
rUIMap :: State -> IORef (Map [Char] (Bool, Maybe [[Char]], SBVType))
rUIMap} <- m State
forall (m :: * -> *). SolverContext m => m State
contextState
Map [Char] (Bool, Maybe [[Char]], SBVType)
uiMap <- IO (Map [Char] (Bool, Maybe [[Char]], SBVType))
-> m (Map [Char] (Bool, Maybe [[Char]], SBVType))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map [Char] (Bool, Maybe [[Char]], SBVType))
-> m (Map [Char] (Bool, Maybe [[Char]], SBVType)))
-> IO (Map [Char] (Bool, Maybe [[Char]], SBVType))
-> m (Map [Char] (Bool, Maybe [[Char]], SBVType))
forall a b. (a -> b) -> a -> b
$ IORef (Map [Char] (Bool, Maybe [[Char]], SBVType))
-> IO (Map [Char] (Bool, Maybe [[Char]], SBVType))
forall a. IORef a -> IO a
readIORef IORef (Map [Char] (Bool, Maybe [[Char]], SBVType))
rUIMap
[Char]
nm <- State -> Map [Char] (Bool, Maybe [[Char]], SBVType) -> m [Char]
findName State
st Map [Char] (Bool, Maybe [[Char]], SBVType)
uiMap
Map [Char] (Bool, Maybe [[Char]], SBVType)
newUIMap <- IO (Map [Char] (Bool, Maybe [[Char]], SBVType))
-> m (Map [Char] (Bool, Maybe [[Char]], SBVType))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map [Char] (Bool, Maybe [[Char]], SBVType))
-> m (Map [Char] (Bool, Maybe [[Char]], SBVType)))
-> IO (Map [Char] (Bool, Maybe [[Char]], SBVType))
-> m (Map [Char] (Bool, Maybe [[Char]], SBVType))
forall a b. (a -> b) -> a -> b
$ IORef (Map [Char] (Bool, Maybe [[Char]], SBVType))
-> IO (Map [Char] (Bool, Maybe [[Char]], SBVType))
forall a. IORef a -> IO a
readIORef IORef (Map [Char] (Bool, Maybe [[Char]], SBVType))
rUIMap
case [Char]
nm [Char]
-> Map [Char] (Bool, Maybe [[Char]], SBVType)
-> Maybe (Bool, Maybe [[Char]], SBVType)
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map [Char] (Bool, Maybe [[Char]], SBVType)
newUIMap of
Maybe (Bool, Maybe [[Char]], SBVType)
Nothing -> Map [Char] (Bool, Maybe [[Char]], SBVType)
-> m (([Char], Maybe [[Char]]), Bool)
forall {b} {a}. Map [Char] b -> a
cantFind Map [Char] (Bool, Maybe [[Char]], SBVType)
newUIMap
Just (Bool
isCurried, Maybe [[Char]]
mbArgs, SBVType
_) -> (([Char], Maybe [[Char]]), Bool)
-> m (([Char], Maybe [[Char]]), Bool)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([Char]
nm, Maybe [[Char]]
mbArgs), Bool
isCurried)
where cantFind :: Map [Char] b -> a
cantFind Map [Char] b
uiMap = [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [ [Char]
""
, [Char]
"*** Data.SBV.getFunction: Must be called on an uninterpreted function!"
, [Char]
"***"
, [Char]
"*** Expected to receive a function created by \"uninterpret\""
]
[[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
tag
[[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [ [Char]
"***"
, [Char]
"*** Make sure to call getFunction on uninterpreted functions only!"
, [Char]
"*** If that is already the case, please report this as a bug."
]
where tag :: [[Char]]
tag = case (([Char], b) -> [Char]) -> [([Char], b)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], b) -> [Char]
forall a b. (a, b) -> a
fst (Map [Char] b -> [([Char], b)]
forall k a. Map k a -> [(k, a)]
Map.toList Map [Char] b
uiMap) of
[] -> [ [Char]
"*** But, there are no matching uninterpreted functions in the context." ]
[[Char]
x] -> [ [Char]
"*** The only possible candidate is: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
x ]
[[Char]]
cands -> [ [Char]
"*** Candidates are:"
, [Char]
"*** " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " [[Char]]
cands
]
findName :: State -> Map [Char] (Bool, Maybe [[Char]], SBVType) -> m [Char]
findName st :: State
st@State{IORef SBVPgm
spgm :: State -> IORef SBVPgm
spgm :: IORef SBVPgm
spgm} Map [Char] (Bool, Maybe [[Char]], SBVType)
uiMap = do
SV
r <- IO SV -> m SV
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SV -> m SV) -> IO SV -> m SV
forall a b. (a -> b) -> a -> b
$ State -> SBV r -> IO SV
forall a. State -> SBV a -> IO SV
sbvToSV State
st (fun -> SBV r
forall fun a r. SMTFunction fun a r => fun -> SBV r
smtFunSaturate fun
f)
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ SV -> IO ()
forceSVArg SV
r
SBVPgm Seq (SV, SBVExpr)
asgns <- IO SBVPgm -> m SBVPgm
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SBVPgm -> m SBVPgm) -> IO SBVPgm -> m SBVPgm
forall a b. (a -> b) -> a -> b
$ IORef SBVPgm -> IO SBVPgm
forall a. IORef a -> IO a
readIORef IORef SBVPgm
spgm
case ((SV, SBVExpr) -> Bool) -> Seq (SV, SBVExpr) -> Maybe Int
forall a. (a -> Bool) -> Seq a -> Maybe Int
S.findIndexR ((SV -> SV -> Bool
forall a. Eq a => a -> a -> Bool
== SV
r) (SV -> Bool) -> ((SV, SBVExpr) -> SV) -> (SV, SBVExpr) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SV, SBVExpr) -> SV
forall a b. (a, b) -> a
fst) Seq (SV, SBVExpr)
asgns of
Maybe Int
Nothing -> Map [Char] (Bool, Maybe [[Char]], SBVType) -> m [Char]
forall {b} {a}. Map [Char] b -> a
cantFind Map [Char] (Bool, Maybe [[Char]], SBVType)
uiMap
Just Int
i -> case Seq (SV, SBVExpr)
asgns Seq (SV, SBVExpr) -> Int -> (SV, SBVExpr)
forall a. Seq a -> Int -> a
`S.index` Int
i of
(SV
sv, SBVApp (Uninterpreted [Char]
nm) [SV]
_) | SV
r SV -> SV -> Bool
forall a. Eq a => a -> a -> Bool
== SV
sv -> [Char] -> m [Char]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
nm
(SV, SBVExpr)
_ -> Map [Char] (Bool, Maybe [[Char]], SBVType) -> m [Char]
forall {b} {a}. Map [Char] b -> a
cantFind Map [Char] (Bool, Maybe [[Char]], SBVType)
uiMap
sexprToFun fun
f ([Char]
s, SExpr
e) = do [Char]
nm <- ([Char], Maybe [[Char]]) -> [Char]
forall a b. (a, b) -> a
fst (([Char], Maybe [[Char]]) -> [Char])
-> ((([Char], Maybe [[Char]]), Bool) -> ([Char], Maybe [[Char]]))
-> (([Char], Maybe [[Char]]), Bool)
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char], Maybe [[Char]]), Bool) -> ([Char], Maybe [[Char]])
forall a b. (a, b) -> a
fst ((([Char], Maybe [[Char]]), Bool) -> [Char])
-> m (([Char], Maybe [[Char]]), Bool) -> m [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> fun -> m (([Char], Maybe [[Char]]), Bool)
forall fun a r (m :: * -> *).
(SMTFunction fun a r, MonadIO m, SolverContext m,
MonadSymbolic m) =>
fun -> m (([Char], Maybe [[Char]]), Bool)
forall (m :: * -> *).
(MonadIO m, SolverContext m, MonadSymbolic m) =>
fun -> m (([Char], Maybe [[Char]]), Bool)
smtFunName fun
f
Maybe ([(a, r)], r)
mbRes <- case SExpr -> Maybe (Either [Char] ([([SExpr], SExpr)], SExpr))
parseSExprFunction SExpr
e of
Just (Left [Char]
nm') -> case ([Char]
nm [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
nm', fun -> Maybe r
forall fun a r. SMTFunction fun a r => fun -> Maybe r
smtFunDefault fun
f) of
(Bool
True, Just r
v) -> Maybe ([(a, r)], r) -> m (Maybe ([(a, r)], r))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ([(a, r)], r) -> m (Maybe ([(a, r)], r)))
-> Maybe ([(a, r)], r) -> m (Maybe ([(a, r)], r))
forall a b. (a -> b) -> a -> b
$ ([(a, r)], r) -> Maybe ([(a, r)], r)
forall a. a -> Maybe a
Just ([], r
v)
(Bool, Maybe r)
_ -> [Char] -> m (Maybe ([(a, r)], r))
forall {a} {a}. Show a => a -> a
bailOut [Char]
nm
Just (Right ([([SExpr], SExpr)], SExpr)
v) -> Maybe ([(a, r)], r) -> m (Maybe ([(a, r)], r))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ([(a, r)], r) -> m (Maybe ([(a, r)], r)))
-> Maybe ([(a, r)], r) -> m (Maybe ([(a, r)], r))
forall a b. (a -> b) -> a -> b
$ ([([SExpr], SExpr)], SExpr) -> Maybe ([(a, r)], r)
convert ([([SExpr], SExpr)], SExpr)
v
Maybe (Either [Char] ([([SExpr], SExpr)], SExpr))
Nothing -> do Maybe ([([SExpr], SExpr)], SExpr)
mbPVS <- [Char] -> SBVType -> m (Maybe ([([SExpr], SExpr)], SExpr))
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
[Char] -> SBVType -> m (Maybe ([([SExpr], SExpr)], SExpr))
pointWiseExtract [Char]
nm (fun -> SBVType
forall fun a r. SMTFunction fun a r => fun -> SBVType
smtFunType fun
f)
Maybe ([(a, r)], r) -> m (Maybe ([(a, r)], r))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ([(a, r)], r) -> m (Maybe ([(a, r)], r)))
-> Maybe ([(a, r)], r) -> m (Maybe ([(a, r)], r))
forall a b. (a -> b) -> a -> b
$ Maybe ([([SExpr], SExpr)], SExpr)
mbPVS Maybe ([([SExpr], SExpr)], SExpr)
-> (([([SExpr], SExpr)], SExpr) -> Maybe ([(a, r)], r))
-> Maybe ([(a, r)], r)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([([SExpr], SExpr)], SExpr) -> Maybe ([(a, r)], r)
convert
Either [Char] ([(a, r)], r) -> m (Either [Char] ([(a, r)], r))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [Char] ([(a, r)], r) -> m (Either [Char] ([(a, r)], r)))
-> Either [Char] ([(a, r)], r) -> m (Either [Char] ([(a, r)], r))
forall a b. (a -> b) -> a -> b
$ Either [Char] ([(a, r)], r)
-> (([(a, r)], r) -> Either [Char] ([(a, r)], r))
-> Maybe ([(a, r)], r)
-> Either [Char] ([(a, r)], r)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> Either [Char] ([(a, r)], r)
forall a b. a -> Either a b
Left [Char]
s) ([(a, r)], r) -> Either [Char] ([(a, r)], r)
forall a b. b -> Either a b
Right Maybe ([(a, r)], r)
mbRes
where convert :: ([([SExpr], SExpr)], SExpr) -> Maybe ([(a, r)], r)
convert ([([SExpr], SExpr)]
vs, SExpr
d) = (,) ([(a, r)] -> r -> ([(a, r)], r))
-> Maybe [(a, r)] -> Maybe (r -> ([(a, r)], r))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (([SExpr], SExpr) -> Maybe (a, r))
-> [([SExpr], SExpr)] -> Maybe [(a, r)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([SExpr], SExpr) -> Maybe (a, r)
sexprPoint [([SExpr], SExpr)]
vs Maybe (r -> ([(a, r)], r)) -> Maybe r -> Maybe ([(a, r)], r)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe r
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
d
sexprPoint :: ([SExpr], SExpr) -> Maybe (a, r)
sexprPoint ([SExpr]
as, SExpr
v) = (,) (a -> r -> (a, r)) -> Maybe a -> Maybe (r -> (a, r))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> fun -> [SExpr] -> Maybe a
forall fun a r. SMTFunction fun a r => fun -> [SExpr] -> Maybe a
sexprToArg fun
f [SExpr]
as Maybe (r -> (a, r)) -> Maybe r -> Maybe (a, r)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe r
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
v
bailOut :: a -> a
bailOut a
nm = [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [ [Char]
""
, [Char]
"*** Data.SBV.getFunction: Unable to extract an interpretation for function " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
nm
, [Char]
"***"
, [Char]
"*** Failed while trying to extract a pointwise interpretation."
, [Char]
"***"
, [Char]
"*** This could be a bug with SBV or the backend solver. Please report!"
]
registerUISMTFunction :: (MonadIO m, SolverContext m, MonadSymbolic m) => SMTFunction fun a r => fun -> m ()
registerUISMTFunction :: forall (m :: * -> *) fun a r.
(MonadIO m, SolverContext m, MonadSymbolic m,
SMTFunction fun a r) =>
fun -> m ()
registerUISMTFunction fun
f = do State
st <- m State
forall (m :: * -> *). SolverContext m => m State
contextState
(([Char], Maybe [[Char]])
nmas, Bool
isCurried) <- fun -> m (([Char], Maybe [[Char]]), Bool)
forall fun a r (m :: * -> *).
(SMTFunction fun a r, MonadIO m, SolverContext m,
MonadSymbolic m) =>
fun -> m (([Char], Maybe [[Char]]), Bool)
forall (m :: * -> *).
(MonadIO m, SolverContext m, MonadSymbolic m) =>
fun -> m (([Char], Maybe [[Char]]), Bool)
smtFunName fun
f
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ State -> ([Char], Maybe [[Char]]) -> SBVType -> UICodeKind -> IO ()
newUninterpreted State
st ([Char], Maybe [[Char]])
nmas (fun -> SBVType
forall fun a r. SMTFunction fun a r => fun -> SBVType
smtFunType fun
f) (Bool -> UICodeKind
UINone Bool
isCurried)
pointWiseExtract :: forall m. (MonadIO m, MonadQuery m) => String -> SBVType -> m (Maybe ([([SExpr], SExpr)], SExpr))
[Char]
nm SBVType
typ = m (Maybe ([([SExpr], SExpr)], SExpr))
tryPointWise
where trueSExpr :: SExpr
trueSExpr = (Integer, Maybe Int) -> SExpr
ENum (Integer
1, Maybe Int
forall a. Maybe a
Nothing)
falseSExpr :: SExpr
falseSExpr = (Integer, Maybe Int) -> SExpr
ENum (Integer
0, Maybe Int
forall a. Maybe a
Nothing)
isTrueSExpr :: SExpr -> Bool
isTrueSExpr (ENum (Integer
1, Maybe Int
Nothing)) = Bool
True
isTrueSExpr (ENum (Integer
0, Maybe Int
Nothing)) = Bool
False
isTrueSExpr SExpr
s = [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error ([Char] -> Bool) -> [Char] -> Bool
forall a b. (a -> b) -> a -> b
$ [Char]
"Data.SBV.pointWiseExtract: Impossible happened: Received: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SExpr -> [Char]
forall a. Show a => a -> [Char]
show SExpr
s
(Int
nArgs, Bool
isBoolFunc) = case SBVType
typ of
SBVType [Kind]
ts -> ([Kind] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Kind]
ts Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, (Kind -> Bool) -> [Kind] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
KBool) [Kind]
ts)
getBVal :: [SExpr] -> m ([SExpr], SExpr)
getBVal :: [SExpr] -> m ([SExpr], SExpr)
getBVal [SExpr]
args = do let shc :: SExpr -> a
shc SExpr
c | SExpr -> Bool
isTrueSExpr SExpr
c = a
"true"
| Bool
True = a
"false"
as :: [Char]
as = [[Char]] -> [Char]
unwords ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ (SExpr -> [Char]) -> [SExpr] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map SExpr -> [Char]
forall {a}. IsString a => SExpr -> a
shc [SExpr]
args
cmd :: [Char]
cmd = [Char]
"(get-value ((" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
nm [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
as [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")))"
bad :: [Char] -> Maybe [[Char]] -> m ([SExpr], SExpr)
bad = [Char]
-> [Char]
-> [Char]
-> Maybe [[Char]]
-> [Char]
-> Maybe [[Char]]
-> m ([SExpr], SExpr)
forall (m :: * -> *) a.
(MonadIO m, MonadQuery m) =>
[Char]
-> [Char]
-> [Char]
-> Maybe [[Char]]
-> [Char]
-> Maybe [[Char]]
-> m a
unexpected [Char]
"get-value" [Char]
cmd ([Char]
"pointwise value of boolean function " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
nm [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" on " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
as) Maybe [[Char]]
forall a. Maybe a
Nothing
[Char]
r <- [Char] -> m [Char]
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
[Char] -> m [Char]
ask [Char]
cmd
[Char]
-> ([Char] -> Maybe [[Char]] -> m ([SExpr], SExpr))
-> (SExpr -> m ([SExpr], SExpr))
-> m ([SExpr], SExpr)
forall a.
[Char] -> ([Char] -> Maybe [[Char]] -> a) -> (SExpr -> a) -> a
parse [Char]
r [Char] -> Maybe [[Char]] -> m ([SExpr], SExpr)
bad ((SExpr -> m ([SExpr], SExpr)) -> m ([SExpr], SExpr))
-> (SExpr -> m ([SExpr], SExpr)) -> m ([SExpr], SExpr)
forall a b. (a -> b) -> a -> b
$ \case EApp [EApp [SExpr
_, SExpr
e]] -> ([SExpr], SExpr) -> m ([SExpr], SExpr)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([SExpr]
args, SExpr
e)
SExpr
_ -> [Char] -> Maybe [[Char]] -> m ([SExpr], SExpr)
bad [Char]
r Maybe [[Char]]
forall a. Maybe a
Nothing
getBVals :: m [([SExpr], SExpr)]
getBVals :: m [([SExpr], SExpr)]
getBVals = ([SExpr] -> m ([SExpr], SExpr))
-> [[SExpr]] -> m [([SExpr], SExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [SExpr] -> m ([SExpr], SExpr)
getBVal ([[SExpr]] -> m [([SExpr], SExpr)])
-> [[SExpr]] -> m [([SExpr], SExpr)]
forall a b. (a -> b) -> a -> b
$ Int -> [SExpr] -> [[SExpr]]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
nArgs [SExpr
falseSExpr, SExpr
trueSExpr]
tryPointWise :: m (Maybe ([([SExpr], SExpr)], SExpr))
tryPointWise
| Bool -> Bool
not Bool
isBoolFunc
= Maybe ([([SExpr], SExpr)], SExpr)
-> m (Maybe ([([SExpr], SExpr)], SExpr))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ([([SExpr], SExpr)], SExpr)
forall a. Maybe a
Nothing
| Int
nArgs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1
= [Char] -> m (Maybe ([([SExpr], SExpr)], SExpr))
forall a. HasCallStack => [Char] -> a
error ([Char] -> m (Maybe ([([SExpr], SExpr)], SExpr)))
-> [Char] -> m (Maybe ([([SExpr], SExpr)], SExpr))
forall a b. (a -> b) -> a -> b
$ [Char]
"Data.SBV.pointWiseExtract: Impossible happened, nArgs < 1: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
nArgs [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" type: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SBVType -> [Char]
forall a. Show a => a -> [Char]
show SBVType
typ
| Bool
True
= do [([SExpr], SExpr)]
vs <- m [([SExpr], SExpr)]
getBVals
let ([([SExpr], SExpr)]
trues, [([SExpr], SExpr)]
falses) = (([SExpr], SExpr) -> Bool)
-> [([SExpr], SExpr)] -> ([([SExpr], SExpr)], [([SExpr], SExpr)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\([SExpr]
_, SExpr
v) -> SExpr -> Bool
isTrueSExpr SExpr
v) [([SExpr], SExpr)]
vs
Maybe ([([SExpr], SExpr)], SExpr)
-> m (Maybe ([([SExpr], SExpr)], SExpr))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ([([SExpr], SExpr)], SExpr)
-> m (Maybe ([([SExpr], SExpr)], SExpr)))
-> Maybe ([([SExpr], SExpr)], SExpr)
-> m (Maybe ([([SExpr], SExpr)], SExpr))
forall a b. (a -> b) -> a -> b
$ ([([SExpr], SExpr)], SExpr) -> Maybe ([([SExpr], SExpr)], SExpr)
forall a. a -> Maybe a
Just (([([SExpr], SExpr)], SExpr) -> Maybe ([([SExpr], SExpr)], SExpr))
-> ([([SExpr], SExpr)], SExpr) -> Maybe ([([SExpr], SExpr)], SExpr)
forall a b. (a -> b) -> a -> b
$ if [([SExpr], SExpr)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [([SExpr], SExpr)]
trues Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= [([SExpr], SExpr)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [([SExpr], SExpr)]
falses
then ([([SExpr], SExpr)]
trues, SExpr
falseSExpr)
else ([([SExpr], SExpr)]
falses, SExpr
trueSExpr)
mkSaturatingArg :: forall a. Kind -> SBV a
mkSaturatingArg :: forall a. Kind -> SBV a
mkSaturatingArg Kind
k = SVal -> SBV a
forall a. SVal -> SBV a
SBV (SVal -> SBV a) -> SVal -> SBV a
forall a b. (a -> b) -> a -> b
$ Kind -> Either CV (Cached SV) -> SVal
SVal Kind
k (CV -> Either CV (Cached SV)
forall a b. a -> Either a b
Left (Kind -> CV
defaultKindedValue Kind
k))
instance ( SymVal a, HasKind a
, SatModel r, HasKind r
) => SMTFunction (SBV a -> SBV r) a r
where
sexprToArg :: (SBV a -> SBV r) -> [SExpr] -> Maybe a
sexprToArg SBV a -> SBV r
_ [SExpr
a0] = SExpr -> Maybe a
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a0
sexprToArg SBV a -> SBV r
_ [SExpr]
_ = Maybe a
forall a. Maybe a
Nothing
smtFunType :: (SBV a -> SBV r) -> SBVType
smtFunType SBV a -> SBV r
_ = [Kind] -> SBVType
SBVType [Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a), Proxy r -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @r)]
smtFunSaturate :: (SBV a -> SBV r) -> SBV r
smtFunSaturate SBV a -> SBV r
f = SBV a -> SBV r
f (SBV a -> SBV r) -> SBV a -> SBV r
forall a b. (a -> b) -> a -> b
$ Kind -> SBV a
forall a. Kind -> SBV a
mkSaturatingArg (Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a))
instance ( SymVal a, HasKind a
, SymVal b, HasKind b
, SatModel r, HasKind r
) => SMTFunction (SBV a -> SBV b -> SBV r) (a, b) r
where
sexprToArg :: (SBV a -> SBV b -> SBV r) -> [SExpr] -> Maybe (a, b)
sexprToArg SBV a -> SBV b -> SBV r
_ [SExpr
a0, SExpr
a1] = (,) (a -> b -> (a, b)) -> Maybe a -> Maybe (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SExpr -> Maybe a
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a0 Maybe (b -> (a, b)) -> Maybe b -> Maybe (a, b)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe b
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a1
sexprToArg SBV a -> SBV b -> SBV r
_ [SExpr]
_ = Maybe (a, b)
forall a. Maybe a
Nothing
smtFunType :: (SBV a -> SBV b -> SBV r) -> SBVType
smtFunType SBV a -> SBV b -> SBV r
_ = [Kind] -> SBVType
SBVType [Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a), Proxy b -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b), Proxy r -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @r)]
smtFunSaturate :: (SBV a -> SBV b -> SBV r) -> SBV r
smtFunSaturate SBV a -> SBV b -> SBV r
f = SBV a -> SBV b -> SBV r
f (Kind -> SBV a
forall a. Kind -> SBV a
mkSaturatingArg (Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)))
(Kind -> SBV b
forall a. Kind -> SBV a
mkSaturatingArg (Proxy b -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b)))
instance ( SymVal a, HasKind a
, SymVal b, HasKind b
, SymVal c, HasKind c
, SatModel r, HasKind r
) => SMTFunction (SBV a -> SBV b -> SBV c -> SBV r) (a, b, c) r
where
sexprToArg :: (SBV a -> SBV b -> SBV c -> SBV r) -> [SExpr] -> Maybe (a, b, c)
sexprToArg SBV a -> SBV b -> SBV c -> SBV r
_ [SExpr
a0, SExpr
a1, SExpr
a2] = (,,) (a -> b -> c -> (a, b, c))
-> Maybe a -> Maybe (b -> c -> (a, b, c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SExpr -> Maybe a
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a0 Maybe (b -> c -> (a, b, c)) -> Maybe b -> Maybe (c -> (a, b, c))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe b
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a1 Maybe (c -> (a, b, c)) -> Maybe c -> Maybe (a, b, c)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe c
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a2
sexprToArg SBV a -> SBV b -> SBV c -> SBV r
_ [SExpr]
_ = Maybe (a, b, c)
forall a. Maybe a
Nothing
smtFunType :: (SBV a -> SBV b -> SBV c -> SBV r) -> SBVType
smtFunType SBV a -> SBV b -> SBV c -> SBV r
_ = [Kind] -> SBVType
SBVType [Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a), Proxy b -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b), Proxy c -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c), Proxy r -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @r)]
smtFunSaturate :: (SBV a -> SBV b -> SBV c -> SBV r) -> SBV r
smtFunSaturate SBV a -> SBV b -> SBV c -> SBV r
f = SBV a -> SBV b -> SBV c -> SBV r
f (Kind -> SBV a
forall a. Kind -> SBV a
mkSaturatingArg (Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)))
(Kind -> SBV b
forall a. Kind -> SBV a
mkSaturatingArg (Proxy b -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b)))
(Kind -> SBV c
forall a. Kind -> SBV a
mkSaturatingArg (Proxy c -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c)))
instance ( SymVal a, HasKind a
, SymVal b, HasKind b
, SymVal c, HasKind c
, SymVal d, HasKind d
, SatModel r, HasKind r
) => SMTFunction (SBV a -> SBV b -> SBV c -> SBV d -> SBV r) (a, b, c, d) r
where
sexprToArg :: (SBV a -> SBV b -> SBV c -> SBV d -> SBV r)
-> [SExpr] -> Maybe (a, b, c, d)
sexprToArg SBV a -> SBV b -> SBV c -> SBV d -> SBV r
_ [SExpr
a0, SExpr
a1, SExpr
a2, SExpr
a3] = (,,,) (a -> b -> c -> d -> (a, b, c, d))
-> Maybe a -> Maybe (b -> c -> d -> (a, b, c, d))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SExpr -> Maybe a
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a0 Maybe (b -> c -> d -> (a, b, c, d))
-> Maybe b -> Maybe (c -> d -> (a, b, c, d))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe b
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a1 Maybe (c -> d -> (a, b, c, d))
-> Maybe c -> Maybe (d -> (a, b, c, d))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe c
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a2 Maybe (d -> (a, b, c, d)) -> Maybe d -> Maybe (a, b, c, d)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe d
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a3
sexprToArg SBV a -> SBV b -> SBV c -> SBV d -> SBV r
_ [SExpr]
_ = Maybe (a, b, c, d)
forall a. Maybe a
Nothing
smtFunType :: (SBV a -> SBV b -> SBV c -> SBV d -> SBV r) -> SBVType
smtFunType SBV a -> SBV b -> SBV c -> SBV d -> SBV r
_ = [Kind] -> SBVType
SBVType [Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a), Proxy b -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b), Proxy c -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c), Proxy d -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @d), Proxy r -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @r)]
smtFunSaturate :: (SBV a -> SBV b -> SBV c -> SBV d -> SBV r) -> SBV r
smtFunSaturate SBV a -> SBV b -> SBV c -> SBV d -> SBV r
f = SBV a -> SBV b -> SBV c -> SBV d -> SBV r
f (Kind -> SBV a
forall a. Kind -> SBV a
mkSaturatingArg (Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)))
(Kind -> SBV b
forall a. Kind -> SBV a
mkSaturatingArg (Proxy b -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b)))
(Kind -> SBV c
forall a. Kind -> SBV a
mkSaturatingArg (Proxy c -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c)))
(Kind -> SBV d
forall a. Kind -> SBV a
mkSaturatingArg (Proxy d -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @d)))
instance ( SymVal a, HasKind a
, SymVal b, HasKind b
, SymVal c, HasKind c
, SymVal d, HasKind d
, SymVal e, HasKind e
, SatModel r, HasKind r
) => SMTFunction (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV r) (a, b, c, d, e) r
where
sexprToArg :: (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV r)
-> [SExpr] -> Maybe (a, b, c, d, e)
sexprToArg SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV r
_ [SExpr
a0, SExpr
a1, SExpr
a2, SExpr
a3, SExpr
a4] = (,,,,) (a -> b -> c -> d -> e -> (a, b, c, d, e))
-> Maybe a -> Maybe (b -> c -> d -> e -> (a, b, c, d, e))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SExpr -> Maybe a
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a0 Maybe (b -> c -> d -> e -> (a, b, c, d, e))
-> Maybe b -> Maybe (c -> d -> e -> (a, b, c, d, e))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe b
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a1 Maybe (c -> d -> e -> (a, b, c, d, e))
-> Maybe c -> Maybe (d -> e -> (a, b, c, d, e))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe c
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a2 Maybe (d -> e -> (a, b, c, d, e))
-> Maybe d -> Maybe (e -> (a, b, c, d, e))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe d
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a3 Maybe (e -> (a, b, c, d, e)) -> Maybe e -> Maybe (a, b, c, d, e)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe e
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a4
sexprToArg SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV r
_ [SExpr]
_ = Maybe (a, b, c, d, e)
forall a. Maybe a
Nothing
smtFunType :: (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV r) -> SBVType
smtFunType SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV r
_ = [Kind] -> SBVType
SBVType [Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a), Proxy b -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b), Proxy c -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c), Proxy d -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @d), Proxy e -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @e), Proxy r -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @r)]
smtFunSaturate :: (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV r) -> SBV r
smtFunSaturate SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV r
f = SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV r
f (Kind -> SBV a
forall a. Kind -> SBV a
mkSaturatingArg (Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)))
(Kind -> SBV b
forall a. Kind -> SBV a
mkSaturatingArg (Proxy b -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b)))
(Kind -> SBV c
forall a. Kind -> SBV a
mkSaturatingArg (Proxy c -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c)))
(Kind -> SBV d
forall a. Kind -> SBV a
mkSaturatingArg (Proxy d -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @d)))
(Kind -> SBV e
forall a. Kind -> SBV a
mkSaturatingArg (Proxy e -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @e)))
instance ( SymVal a, HasKind a
, SymVal b, HasKind b
, SymVal c, HasKind c
, SymVal d, HasKind d
, SymVal e, HasKind e
, SymVal f, HasKind f
, SatModel r, HasKind r
) => SMTFunction (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> SBV r) (a, b, c, d, e, f) r
where
sexprToArg :: (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> SBV r)
-> [SExpr] -> Maybe (a, b, c, d, e, f)
sexprToArg SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> SBV r
_ [SExpr
a0, SExpr
a1, SExpr
a2, SExpr
a3, SExpr
a4, SExpr
a5] = (,,,,,) (a -> b -> c -> d -> e -> f -> (a, b, c, d, e, f))
-> Maybe a -> Maybe (b -> c -> d -> e -> f -> (a, b, c, d, e, f))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SExpr -> Maybe a
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a0 Maybe (b -> c -> d -> e -> f -> (a, b, c, d, e, f))
-> Maybe b -> Maybe (c -> d -> e -> f -> (a, b, c, d, e, f))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe b
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a1 Maybe (c -> d -> e -> f -> (a, b, c, d, e, f))
-> Maybe c -> Maybe (d -> e -> f -> (a, b, c, d, e, f))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe c
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a2 Maybe (d -> e -> f -> (a, b, c, d, e, f))
-> Maybe d -> Maybe (e -> f -> (a, b, c, d, e, f))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe d
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a3 Maybe (e -> f -> (a, b, c, d, e, f))
-> Maybe e -> Maybe (f -> (a, b, c, d, e, f))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe e
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a4 Maybe (f -> (a, b, c, d, e, f))
-> Maybe f -> Maybe (a, b, c, d, e, f)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe f
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a5
sexprToArg SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> SBV r
_ [SExpr]
_ = Maybe (a, b, c, d, e, f)
forall a. Maybe a
Nothing
smtFunType :: (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> SBV r)
-> SBVType
smtFunType SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> SBV r
_ = [Kind] -> SBVType
SBVType [Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a), Proxy b -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b), Proxy c -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c), Proxy d -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @d), Proxy e -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @e), Proxy f -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @f), Proxy r -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @r)]
smtFunSaturate :: (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> SBV r)
-> SBV r
smtFunSaturate SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> SBV r
f = SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> SBV r
f (Kind -> SBV a
forall a. Kind -> SBV a
mkSaturatingArg (Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)))
(Kind -> SBV b
forall a. Kind -> SBV a
mkSaturatingArg (Proxy b -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b)))
(Kind -> SBV c
forall a. Kind -> SBV a
mkSaturatingArg (Proxy c -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c)))
(Kind -> SBV d
forall a. Kind -> SBV a
mkSaturatingArg (Proxy d -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @d)))
(Kind -> SBV e
forall a. Kind -> SBV a
mkSaturatingArg (Proxy e -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @e)))
(Kind -> SBV f
forall a. Kind -> SBV a
mkSaturatingArg (Proxy f -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @f)))
instance ( SymVal a, HasKind a
, SymVal b, HasKind b
, SymVal c, HasKind c
, SymVal d, HasKind d
, SymVal e, HasKind e
, SymVal f, HasKind f
, SymVal g, HasKind g
, SatModel r, HasKind r
) => SMTFunction (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> SBV g -> SBV r) (a, b, c, d, e, f, g) r
where
sexprToArg :: (SBV a
-> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> SBV g -> SBV r)
-> [SExpr] -> Maybe (a, b, c, d, e, f, g)
sexprToArg SBV a
-> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> SBV g -> SBV r
_ [SExpr
a0, SExpr
a1, SExpr
a2, SExpr
a3, SExpr
a4, SExpr
a5, SExpr
a6] = (,,,,,,) (a -> b -> c -> d -> e -> f -> g -> (a, b, c, d, e, f, g))
-> Maybe a
-> Maybe (b -> c -> d -> e -> f -> g -> (a, b, c, d, e, f, g))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SExpr -> Maybe a
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a0 Maybe (b -> c -> d -> e -> f -> g -> (a, b, c, d, e, f, g))
-> Maybe b
-> Maybe (c -> d -> e -> f -> g -> (a, b, c, d, e, f, g))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe b
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a1 Maybe (c -> d -> e -> f -> g -> (a, b, c, d, e, f, g))
-> Maybe c -> Maybe (d -> e -> f -> g -> (a, b, c, d, e, f, g))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe c
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a2 Maybe (d -> e -> f -> g -> (a, b, c, d, e, f, g))
-> Maybe d -> Maybe (e -> f -> g -> (a, b, c, d, e, f, g))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe d
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a3 Maybe (e -> f -> g -> (a, b, c, d, e, f, g))
-> Maybe e -> Maybe (f -> g -> (a, b, c, d, e, f, g))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe e
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a4 Maybe (f -> g -> (a, b, c, d, e, f, g))
-> Maybe f -> Maybe (g -> (a, b, c, d, e, f, g))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe f
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a5 Maybe (g -> (a, b, c, d, e, f, g))
-> Maybe g -> Maybe (a, b, c, d, e, f, g)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe g
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a6
sexprToArg SBV a
-> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> SBV g -> SBV r
_ [SExpr]
_ = Maybe (a, b, c, d, e, f, g)
forall a. Maybe a
Nothing
smtFunType :: (SBV a
-> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> SBV g -> SBV r)
-> SBVType
smtFunType SBV a
-> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> SBV g -> SBV r
_ = [Kind] -> SBVType
SBVType [Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a), Proxy b -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b), Proxy c -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c), Proxy d -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @d), Proxy e -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @e), Proxy f -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @f), Proxy g -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @g), Proxy r -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @r)]
smtFunSaturate :: (SBV a
-> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> SBV g -> SBV r)
-> SBV r
smtFunSaturate SBV a
-> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> SBV g -> SBV r
f = SBV a
-> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> SBV g -> SBV r
f (Kind -> SBV a
forall a. Kind -> SBV a
mkSaturatingArg (Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)))
(Kind -> SBV b
forall a. Kind -> SBV a
mkSaturatingArg (Proxy b -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b)))
(Kind -> SBV c
forall a. Kind -> SBV a
mkSaturatingArg (Proxy c -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c)))
(Kind -> SBV d
forall a. Kind -> SBV a
mkSaturatingArg (Proxy d -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @d)))
(Kind -> SBV e
forall a. Kind -> SBV a
mkSaturatingArg (Proxy e -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @e)))
(Kind -> SBV f
forall a. Kind -> SBV a
mkSaturatingArg (Proxy f -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @f)))
(Kind -> SBV g
forall a. Kind -> SBV a
mkSaturatingArg (Proxy g -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @g)))
instance ( SymVal a, HasKind a
, SymVal b, HasKind b
, SymVal c, HasKind c
, SymVal d, HasKind d
, SymVal e, HasKind e
, SymVal f, HasKind f
, SymVal g, HasKind g
, SymVal h, HasKind h
, SatModel r, HasKind r
) => SMTFunction (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> SBV g -> SBV h -> SBV r) (a, b, c, d, e, f, g, h) r
where
sexprToArg :: (SBV a
-> SBV b
-> SBV c
-> SBV d
-> SBV e
-> SBV f
-> SBV g
-> SBV h
-> SBV r)
-> [SExpr] -> Maybe (a, b, c, d, e, f, g, h)
sexprToArg SBV a
-> SBV b
-> SBV c
-> SBV d
-> SBV e
-> SBV f
-> SBV g
-> SBV h
-> SBV r
_ [SExpr
a0, SExpr
a1, SExpr
a2, SExpr
a3, SExpr
a4, SExpr
a5, SExpr
a6, SExpr
a7] = (,,,,,,,) (a -> b -> c -> d -> e -> f -> g -> h -> (a, b, c, d, e, f, g, h))
-> Maybe a
-> Maybe
(b -> c -> d -> e -> f -> g -> h -> (a, b, c, d, e, f, g, h))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SExpr -> Maybe a
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a0 Maybe (b -> c -> d -> e -> f -> g -> h -> (a, b, c, d, e, f, g, h))
-> Maybe b
-> Maybe (c -> d -> e -> f -> g -> h -> (a, b, c, d, e, f, g, h))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe b
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a1 Maybe (c -> d -> e -> f -> g -> h -> (a, b, c, d, e, f, g, h))
-> Maybe c
-> Maybe (d -> e -> f -> g -> h -> (a, b, c, d, e, f, g, h))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe c
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a2 Maybe (d -> e -> f -> g -> h -> (a, b, c, d, e, f, g, h))
-> Maybe d -> Maybe (e -> f -> g -> h -> (a, b, c, d, e, f, g, h))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe d
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a3 Maybe (e -> f -> g -> h -> (a, b, c, d, e, f, g, h))
-> Maybe e -> Maybe (f -> g -> h -> (a, b, c, d, e, f, g, h))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe e
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a4 Maybe (f -> g -> h -> (a, b, c, d, e, f, g, h))
-> Maybe f -> Maybe (g -> h -> (a, b, c, d, e, f, g, h))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe f
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a5 Maybe (g -> h -> (a, b, c, d, e, f, g, h))
-> Maybe g -> Maybe (h -> (a, b, c, d, e, f, g, h))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe g
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a6 Maybe (h -> (a, b, c, d, e, f, g, h))
-> Maybe h -> Maybe (a, b, c, d, e, f, g, h)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe h
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a7
sexprToArg SBV a
-> SBV b
-> SBV c
-> SBV d
-> SBV e
-> SBV f
-> SBV g
-> SBV h
-> SBV r
_ [SExpr]
_ = Maybe (a, b, c, d, e, f, g, h)
forall a. Maybe a
Nothing
smtFunType :: (SBV a
-> SBV b
-> SBV c
-> SBV d
-> SBV e
-> SBV f
-> SBV g
-> SBV h
-> SBV r)
-> SBVType
smtFunType SBV a
-> SBV b
-> SBV c
-> SBV d
-> SBV e
-> SBV f
-> SBV g
-> SBV h
-> SBV r
_ = [Kind] -> SBVType
SBVType [Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a), Proxy b -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b), Proxy c -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c), Proxy d -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @d), Proxy e -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @e), Proxy f -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @f), Proxy g -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @g), Proxy h -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @h), Proxy r -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @r)]
smtFunSaturate :: (SBV a
-> SBV b
-> SBV c
-> SBV d
-> SBV e
-> SBV f
-> SBV g
-> SBV h
-> SBV r)
-> SBV r
smtFunSaturate SBV a
-> SBV b
-> SBV c
-> SBV d
-> SBV e
-> SBV f
-> SBV g
-> SBV h
-> SBV r
f = SBV a
-> SBV b
-> SBV c
-> SBV d
-> SBV e
-> SBV f
-> SBV g
-> SBV h
-> SBV r
f (Kind -> SBV a
forall a. Kind -> SBV a
mkSaturatingArg (Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)))
(Kind -> SBV b
forall a. Kind -> SBV a
mkSaturatingArg (Proxy b -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b)))
(Kind -> SBV c
forall a. Kind -> SBV a
mkSaturatingArg (Proxy c -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c)))
(Kind -> SBV d
forall a. Kind -> SBV a
mkSaturatingArg (Proxy d -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @d)))
(Kind -> SBV e
forall a. Kind -> SBV a
mkSaturatingArg (Proxy e -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @e)))
(Kind -> SBV f
forall a. Kind -> SBV a
mkSaturatingArg (Proxy f -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @f)))
(Kind -> SBV g
forall a. Kind -> SBV a
mkSaturatingArg (Proxy g -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @g)))
(Kind -> SBV h
forall a. Kind -> SBV a
mkSaturatingArg (Proxy h -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @h)))
instance ( SymVal a, HasKind a
, SymVal b, HasKind b
, SatModel r, HasKind r
) => SMTFunction ((SBV a, SBV b) -> SBV r) (a, b) r
where
sexprToArg :: ((SBV a, SBV b) -> SBV r) -> [SExpr] -> Maybe (a, b)
sexprToArg (SBV a, SBV b) -> SBV r
_ [SExpr
a0, SExpr
a1] = (,) (a -> b -> (a, b)) -> Maybe a -> Maybe (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SExpr -> Maybe a
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a0 Maybe (b -> (a, b)) -> Maybe b -> Maybe (a, b)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe b
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a1
sexprToArg (SBV a, SBV b) -> SBV r
_ [SExpr]
_ = Maybe (a, b)
forall a. Maybe a
Nothing
smtFunType :: ((SBV a, SBV b) -> SBV r) -> SBVType
smtFunType (SBV a, SBV b) -> SBV r
_ = [Kind] -> SBVType
SBVType [Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a), Proxy b -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b), Proxy r -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @r)]
smtFunSaturate :: ((SBV a, SBV b) -> SBV r) -> SBV r
smtFunSaturate (SBV a, SBV b) -> SBV r
f = (SBV a, SBV b) -> SBV r
f ( Kind -> SBV a
forall a. Kind -> SBV a
mkSaturatingArg (Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a))
, Kind -> SBV b
forall a. Kind -> SBV a
mkSaturatingArg (Proxy b -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b))
)
instance ( SymVal a, HasKind a
, SymVal b, HasKind b
, SymVal c, HasKind c
, SatModel r, HasKind r
) => SMTFunction ((SBV a, SBV b, SBV c) -> SBV r) (a, b, c) r
where
sexprToArg :: ((SBV a, SBV b, SBV c) -> SBV r) -> [SExpr] -> Maybe (a, b, c)
sexprToArg (SBV a, SBV b, SBV c) -> SBV r
_ [SExpr
a0, SExpr
a1, SExpr
a2] = (,,) (a -> b -> c -> (a, b, c))
-> Maybe a -> Maybe (b -> c -> (a, b, c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SExpr -> Maybe a
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a0 Maybe (b -> c -> (a, b, c)) -> Maybe b -> Maybe (c -> (a, b, c))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe b
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a1 Maybe (c -> (a, b, c)) -> Maybe c -> Maybe (a, b, c)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe c
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a2
sexprToArg (SBV a, SBV b, SBV c) -> SBV r
_ [SExpr]
_ = Maybe (a, b, c)
forall a. Maybe a
Nothing
smtFunType :: ((SBV a, SBV b, SBV c) -> SBV r) -> SBVType
smtFunType (SBV a, SBV b, SBV c) -> SBV r
_ = [Kind] -> SBVType
SBVType [Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a), Proxy b -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b), Proxy c -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c), Proxy r -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @r)]
smtFunSaturate :: ((SBV a, SBV b, SBV c) -> SBV r) -> SBV r
smtFunSaturate (SBV a, SBV b, SBV c) -> SBV r
f = (SBV a, SBV b, SBV c) -> SBV r
f ( Kind -> SBV a
forall a. Kind -> SBV a
mkSaturatingArg (Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a))
, Kind -> SBV b
forall a. Kind -> SBV a
mkSaturatingArg (Proxy b -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b))
, Kind -> SBV c
forall a. Kind -> SBV a
mkSaturatingArg (Proxy c -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c))
)
instance ( SymVal a, HasKind a
, SymVal b, HasKind b
, SymVal c, HasKind c
, SymVal d, HasKind d
, SatModel r, HasKind r
) => SMTFunction ((SBV a, SBV b, SBV c, SBV d) -> SBV r) (a, b, c, d) r
where
sexprToArg :: ((SBV a, SBV b, SBV c, SBV d) -> SBV r)
-> [SExpr] -> Maybe (a, b, c, d)
sexprToArg (SBV a, SBV b, SBV c, SBV d) -> SBV r
_ [SExpr
a0, SExpr
a1, SExpr
a2, SExpr
a3] = (,,,) (a -> b -> c -> d -> (a, b, c, d))
-> Maybe a -> Maybe (b -> c -> d -> (a, b, c, d))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SExpr -> Maybe a
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a0 Maybe (b -> c -> d -> (a, b, c, d))
-> Maybe b -> Maybe (c -> d -> (a, b, c, d))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe b
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a1 Maybe (c -> d -> (a, b, c, d))
-> Maybe c -> Maybe (d -> (a, b, c, d))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe c
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a2 Maybe (d -> (a, b, c, d)) -> Maybe d -> Maybe (a, b, c, d)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe d
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a3
sexprToArg (SBV a, SBV b, SBV c, SBV d) -> SBV r
_ [SExpr]
_ = Maybe (a, b, c, d)
forall a. Maybe a
Nothing
smtFunType :: ((SBV a, SBV b, SBV c, SBV d) -> SBV r) -> SBVType
smtFunType (SBV a, SBV b, SBV c, SBV d) -> SBV r
_ = [Kind] -> SBVType
SBVType [Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a), Proxy b -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b), Proxy c -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c), Proxy d -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @d), Proxy r -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @r)]
smtFunSaturate :: ((SBV a, SBV b, SBV c, SBV d) -> SBV r) -> SBV r
smtFunSaturate (SBV a, SBV b, SBV c, SBV d) -> SBV r
f = (SBV a, SBV b, SBV c, SBV d) -> SBV r
f ( Kind -> SBV a
forall a. Kind -> SBV a
mkSaturatingArg (Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a))
, Kind -> SBV b
forall a. Kind -> SBV a
mkSaturatingArg (Proxy b -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b))
, Kind -> SBV c
forall a. Kind -> SBV a
mkSaturatingArg (Proxy c -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c))
, Kind -> SBV d
forall a. Kind -> SBV a
mkSaturatingArg (Proxy d -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @d))
)
instance ( SymVal a, HasKind a
, SymVal b, HasKind b
, SymVal c, HasKind c
, SymVal d, HasKind d
, SymVal e, HasKind e
, SatModel r, HasKind r
) => SMTFunction ((SBV a, SBV b, SBV c, SBV d, SBV e) -> SBV r) (a, b, c, d, e) r
where
sexprToArg :: ((SBV a, SBV b, SBV c, SBV d, SBV e) -> SBV r)
-> [SExpr] -> Maybe (a, b, c, d, e)
sexprToArg (SBV a, SBV b, SBV c, SBV d, SBV e) -> SBV r
_ [SExpr
a0, SExpr
a1, SExpr
a2, SExpr
a3, SExpr
a4] = (,,,,) (a -> b -> c -> d -> e -> (a, b, c, d, e))
-> Maybe a -> Maybe (b -> c -> d -> e -> (a, b, c, d, e))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SExpr -> Maybe a
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a0 Maybe (b -> c -> d -> e -> (a, b, c, d, e))
-> Maybe b -> Maybe (c -> d -> e -> (a, b, c, d, e))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe b
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a1 Maybe (c -> d -> e -> (a, b, c, d, e))
-> Maybe c -> Maybe (d -> e -> (a, b, c, d, e))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe c
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a2 Maybe (d -> e -> (a, b, c, d, e))
-> Maybe d -> Maybe (e -> (a, b, c, d, e))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe d
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a3 Maybe (e -> (a, b, c, d, e)) -> Maybe e -> Maybe (a, b, c, d, e)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe e
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a4
sexprToArg (SBV a, SBV b, SBV c, SBV d, SBV e) -> SBV r
_ [SExpr]
_ = Maybe (a, b, c, d, e)
forall a. Maybe a
Nothing
smtFunType :: ((SBV a, SBV b, SBV c, SBV d, SBV e) -> SBV r) -> SBVType
smtFunType (SBV a, SBV b, SBV c, SBV d, SBV e) -> SBV r
_ = [Kind] -> SBVType
SBVType [Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a), Proxy b -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b), Proxy c -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c), Proxy d -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @d), Proxy e -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @e), Proxy r -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @r)]
smtFunSaturate :: ((SBV a, SBV b, SBV c, SBV d, SBV e) -> SBV r) -> SBV r
smtFunSaturate (SBV a, SBV b, SBV c, SBV d, SBV e) -> SBV r
f = (SBV a, SBV b, SBV c, SBV d, SBV e) -> SBV r
f ( Kind -> SBV a
forall a. Kind -> SBV a
mkSaturatingArg (Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a))
, Kind -> SBV b
forall a. Kind -> SBV a
mkSaturatingArg (Proxy b -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b))
, Kind -> SBV c
forall a. Kind -> SBV a
mkSaturatingArg (Proxy c -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c))
, Kind -> SBV d
forall a. Kind -> SBV a
mkSaturatingArg (Proxy d -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @d))
, Kind -> SBV e
forall a. Kind -> SBV a
mkSaturatingArg (Proxy e -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @e))
)
instance ( SymVal a, HasKind a
, SymVal b, HasKind b
, SymVal c, HasKind c
, SymVal d, HasKind d
, SymVal e, HasKind e
, SymVal f, HasKind f
, SatModel r, HasKind r
) => SMTFunction ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f) -> SBV r) (a, b, c, d, e, f) r
where
sexprToArg :: ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f) -> SBV r)
-> [SExpr] -> Maybe (a, b, c, d, e, f)
sexprToArg (SBV a, SBV b, SBV c, SBV d, SBV e, SBV f) -> SBV r
_ [SExpr
a0, SExpr
a1, SExpr
a2, SExpr
a3, SExpr
a4, SExpr
a5] = (,,,,,) (a -> b -> c -> d -> e -> f -> (a, b, c, d, e, f))
-> Maybe a -> Maybe (b -> c -> d -> e -> f -> (a, b, c, d, e, f))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SExpr -> Maybe a
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a0 Maybe (b -> c -> d -> e -> f -> (a, b, c, d, e, f))
-> Maybe b -> Maybe (c -> d -> e -> f -> (a, b, c, d, e, f))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe b
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a1 Maybe (c -> d -> e -> f -> (a, b, c, d, e, f))
-> Maybe c -> Maybe (d -> e -> f -> (a, b, c, d, e, f))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe c
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a2 Maybe (d -> e -> f -> (a, b, c, d, e, f))
-> Maybe d -> Maybe (e -> f -> (a, b, c, d, e, f))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe d
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a3 Maybe (e -> f -> (a, b, c, d, e, f))
-> Maybe e -> Maybe (f -> (a, b, c, d, e, f))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe e
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a4 Maybe (f -> (a, b, c, d, e, f))
-> Maybe f -> Maybe (a, b, c, d, e, f)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe f
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a5
sexprToArg (SBV a, SBV b, SBV c, SBV d, SBV e, SBV f) -> SBV r
_ [SExpr]
_ = Maybe (a, b, c, d, e, f)
forall a. Maybe a
Nothing
smtFunType :: ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f) -> SBV r) -> SBVType
smtFunType (SBV a, SBV b, SBV c, SBV d, SBV e, SBV f) -> SBV r
_ = [Kind] -> SBVType
SBVType [Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a), Proxy b -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b), Proxy c -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c), Proxy d -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @d), Proxy e -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @e), Proxy f -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @f), Proxy r -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @r)]
smtFunSaturate :: ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f) -> SBV r) -> SBV r
smtFunSaturate (SBV a, SBV b, SBV c, SBV d, SBV e, SBV f) -> SBV r
f = (SBV a, SBV b, SBV c, SBV d, SBV e, SBV f) -> SBV r
f ( Kind -> SBV a
forall a. Kind -> SBV a
mkSaturatingArg (Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a))
, Kind -> SBV b
forall a. Kind -> SBV a
mkSaturatingArg (Proxy b -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b))
, Kind -> SBV c
forall a. Kind -> SBV a
mkSaturatingArg (Proxy c -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c))
, Kind -> SBV d
forall a. Kind -> SBV a
mkSaturatingArg (Proxy d -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @d))
, Kind -> SBV e
forall a. Kind -> SBV a
mkSaturatingArg (Proxy e -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @e))
, Kind -> SBV f
forall a. Kind -> SBV a
mkSaturatingArg (Proxy f -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @f))
)
instance ( SymVal a, HasKind a
, SymVal b, HasKind b
, SymVal c, HasKind c
, SymVal d, HasKind d
, SymVal e, HasKind e
, SymVal f, HasKind f
, SymVal g, HasKind g
, SatModel r, HasKind r
) => SMTFunction ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g) -> SBV r) (a, b, c, d, e, f, g) r
where
sexprToArg :: ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g) -> SBV r)
-> [SExpr] -> Maybe (a, b, c, d, e, f, g)
sexprToArg (SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g) -> SBV r
_ [SExpr
a0, SExpr
a1, SExpr
a2, SExpr
a3, SExpr
a4, SExpr
a5, SExpr
a6] = (,,,,,,) (a -> b -> c -> d -> e -> f -> g -> (a, b, c, d, e, f, g))
-> Maybe a
-> Maybe (b -> c -> d -> e -> f -> g -> (a, b, c, d, e, f, g))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SExpr -> Maybe a
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a0 Maybe (b -> c -> d -> e -> f -> g -> (a, b, c, d, e, f, g))
-> Maybe b
-> Maybe (c -> d -> e -> f -> g -> (a, b, c, d, e, f, g))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe b
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a1 Maybe (c -> d -> e -> f -> g -> (a, b, c, d, e, f, g))
-> Maybe c -> Maybe (d -> e -> f -> g -> (a, b, c, d, e, f, g))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe c
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a2 Maybe (d -> e -> f -> g -> (a, b, c, d, e, f, g))
-> Maybe d -> Maybe (e -> f -> g -> (a, b, c, d, e, f, g))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe d
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a3 Maybe (e -> f -> g -> (a, b, c, d, e, f, g))
-> Maybe e -> Maybe (f -> g -> (a, b, c, d, e, f, g))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe e
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a4 Maybe (f -> g -> (a, b, c, d, e, f, g))
-> Maybe f -> Maybe (g -> (a, b, c, d, e, f, g))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe f
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a5 Maybe (g -> (a, b, c, d, e, f, g))
-> Maybe g -> Maybe (a, b, c, d, e, f, g)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe g
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a6
sexprToArg (SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g) -> SBV r
_ [SExpr]
_ = Maybe (a, b, c, d, e, f, g)
forall a. Maybe a
Nothing
smtFunType :: ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g) -> SBV r)
-> SBVType
smtFunType (SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g) -> SBV r
_ = [Kind] -> SBVType
SBVType [Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a), Proxy b -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b), Proxy c -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c), Proxy d -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @d), Proxy e -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @e), Proxy f -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @f), Proxy g -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @g), Proxy r -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @r)]
smtFunSaturate :: ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g) -> SBV r)
-> SBV r
smtFunSaturate (SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g) -> SBV r
f = (SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g) -> SBV r
f ( Kind -> SBV a
forall a. Kind -> SBV a
mkSaturatingArg (Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a))
, Kind -> SBV b
forall a. Kind -> SBV a
mkSaturatingArg (Proxy b -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b))
, Kind -> SBV c
forall a. Kind -> SBV a
mkSaturatingArg (Proxy c -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c))
, Kind -> SBV d
forall a. Kind -> SBV a
mkSaturatingArg (Proxy d -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @d))
, Kind -> SBV e
forall a. Kind -> SBV a
mkSaturatingArg (Proxy e -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @e))
, Kind -> SBV f
forall a. Kind -> SBV a
mkSaturatingArg (Proxy f -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @f))
, Kind -> SBV g
forall a. Kind -> SBV a
mkSaturatingArg (Proxy g -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @g))
)
instance ( SymVal a, HasKind a
, SymVal b, HasKind b
, SymVal c, HasKind c
, SymVal d, HasKind d
, SymVal e, HasKind e
, SymVal f, HasKind f
, SymVal g, HasKind g
, SymVal h, HasKind h
, SatModel r, HasKind r
) => SMTFunction ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g, SBV h) -> SBV r) (a, b, c, d, e, f, g, h) r
where
sexprToArg :: ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g, SBV h) -> SBV r)
-> [SExpr] -> Maybe (a, b, c, d, e, f, g, h)
sexprToArg (SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g, SBV h) -> SBV r
_ [SExpr
a0, SExpr
a1, SExpr
a2, SExpr
a3, SExpr
a4, SExpr
a5, SExpr
a6, SExpr
a7] = (,,,,,,,) (a -> b -> c -> d -> e -> f -> g -> h -> (a, b, c, d, e, f, g, h))
-> Maybe a
-> Maybe
(b -> c -> d -> e -> f -> g -> h -> (a, b, c, d, e, f, g, h))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SExpr -> Maybe a
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a0 Maybe (b -> c -> d -> e -> f -> g -> h -> (a, b, c, d, e, f, g, h))
-> Maybe b
-> Maybe (c -> d -> e -> f -> g -> h -> (a, b, c, d, e, f, g, h))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe b
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a1 Maybe (c -> d -> e -> f -> g -> h -> (a, b, c, d, e, f, g, h))
-> Maybe c
-> Maybe (d -> e -> f -> g -> h -> (a, b, c, d, e, f, g, h))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe c
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a2 Maybe (d -> e -> f -> g -> h -> (a, b, c, d, e, f, g, h))
-> Maybe d -> Maybe (e -> f -> g -> h -> (a, b, c, d, e, f, g, h))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe d
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a3 Maybe (e -> f -> g -> h -> (a, b, c, d, e, f, g, h))
-> Maybe e -> Maybe (f -> g -> h -> (a, b, c, d, e, f, g, h))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe e
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a4 Maybe (f -> g -> h -> (a, b, c, d, e, f, g, h))
-> Maybe f -> Maybe (g -> h -> (a, b, c, d, e, f, g, h))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe f
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a5 Maybe (g -> h -> (a, b, c, d, e, f, g, h))
-> Maybe g -> Maybe (h -> (a, b, c, d, e, f, g, h))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe g
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a6 Maybe (h -> (a, b, c, d, e, f, g, h))
-> Maybe h -> Maybe (a, b, c, d, e, f, g, h)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe h
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
a7
sexprToArg (SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g, SBV h) -> SBV r
_ [SExpr]
_ = Maybe (a, b, c, d, e, f, g, h)
forall a. Maybe a
Nothing
smtFunType :: ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g, SBV h) -> SBV r)
-> SBVType
smtFunType (SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g, SBV h) -> SBV r
_ = [Kind] -> SBVType
SBVType [Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a), Proxy b -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b), Proxy c -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c), Proxy d -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @d), Proxy e -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @e), Proxy f -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @f), Proxy g -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @g), Proxy h -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @h), Proxy r -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @r)]
smtFunSaturate :: ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g, SBV h) -> SBV r)
-> SBV r
smtFunSaturate (SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g, SBV h) -> SBV r
f = (SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g, SBV h) -> SBV r
f ( Kind -> SBV a
forall a. Kind -> SBV a
mkSaturatingArg (Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a))
, Kind -> SBV b
forall a. Kind -> SBV a
mkSaturatingArg (Proxy b -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b))
, Kind -> SBV c
forall a. Kind -> SBV a
mkSaturatingArg (Proxy c -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c))
, Kind -> SBV d
forall a. Kind -> SBV a
mkSaturatingArg (Proxy d -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @d))
, Kind -> SBV e
forall a. Kind -> SBV a
mkSaturatingArg (Proxy e -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @e))
, Kind -> SBV f
forall a. Kind -> SBV a
mkSaturatingArg (Proxy f -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @f))
, Kind -> SBV g
forall a. Kind -> SBV a
mkSaturatingArg (Proxy g -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @g))
, Kind -> SBV h
forall a. Kind -> SBV a
mkSaturatingArg (Proxy h -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @h))
)
trimFunctionResponse :: String -> String -> Bool -> Maybe [String] -> String
trimFunctionResponse :: [Char] -> [Char] -> Bool -> Maybe [[Char]] -> [Char]
trimFunctionResponse [Char]
resp [Char]
nm Bool
isCurried Maybe [[Char]]
mbArgs
| Just [Char]
parsed <- [Char] -> [Char] -> Bool -> Maybe [[Char]] -> Maybe [Char]
makeHaskellFunction [Char]
resp [Char]
nm Bool
isCurried Maybe [[Char]]
mbArgs
= [Char]
parsed
| Bool
True
= [Char] -> [Char]
def ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ case [Char] -> [Char]
trim [Char]
resp of
Char
'(':Char
'(':[Char]
rest | [Char]
nm [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
rest -> [Char] -> [Char]
forall a. [a] -> [a]
butLast2 ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
trim (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
nm) [Char]
rest)
[Char]
_ -> [Char]
resp
where trim :: [Char] -> [Char]
trim = (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace
butLast2 :: [a] -> [a]
butLast2 = [a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
2 ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
forall a. [a] -> [a]
reverse
def :: [Char] -> [Char]
def [Char]
x = [Char]
nm [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" = fromSMTLib " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
x
getFunction :: (MonadIO m, MonadQuery m, SolverContext m, MonadSymbolic m, SymVal a, SymVal r, SMTFunction fun a r)
=> fun -> m (Either (String, (Bool, Maybe [String], SExpr)) ([(a, r)], r))
getFunction :: forall (m :: * -> *) a r fun.
(MonadIO m, MonadQuery m, SolverContext m, MonadSymbolic m,
SymVal a, SymVal r, SMTFunction fun a r) =>
fun
-> m (Either ([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r))
getFunction fun
f = do (([Char]
nm, Maybe [[Char]]
args), Bool
isCurried) <- fun -> m (([Char], Maybe [[Char]]), Bool)
forall fun a r (m :: * -> *).
(SMTFunction fun a r, MonadIO m, SolverContext m,
MonadSymbolic m) =>
fun -> m (([Char], Maybe [[Char]]), Bool)
forall (m :: * -> *).
(MonadIO m, SolverContext m, MonadSymbolic m) =>
fun -> m (([Char], Maybe [[Char]]), Bool)
smtFunName fun
f
let cmd :: [Char]
cmd = [Char]
"(get-value (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
nm [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"))"
bad :: [Char]
-> Maybe [[Char]]
-> m (Either ([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r))
bad = [Char]
-> [Char]
-> [Char]
-> Maybe [[Char]]
-> [Char]
-> Maybe [[Char]]
-> m (Either ([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r))
forall (m :: * -> *) a.
(MonadIO m, MonadQuery m) =>
[Char]
-> [Char]
-> [Char]
-> Maybe [[Char]]
-> [Char]
-> Maybe [[Char]]
-> m a
unexpected [Char]
"getFunction" [Char]
cmd [Char]
"a function value" Maybe [[Char]]
forall a. Maybe a
Nothing
[Char]
r <- [Char] -> m [Char]
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
[Char] -> m [Char]
ask [Char]
cmd
[Char]
-> ([Char]
-> Maybe [[Char]]
-> m (Either
([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r)))
-> (SExpr
-> m (Either
([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r)))
-> m (Either ([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r))
forall a.
[Char] -> ([Char] -> Maybe [[Char]] -> a) -> (SExpr -> a) -> a
parse [Char]
r [Char]
-> Maybe [[Char]]
-> m (Either ([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r))
bad ((SExpr
-> m (Either
([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r)))
-> m (Either
([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r)))
-> (SExpr
-> m (Either
([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r)))
-> m (Either ([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r))
forall a b. (a -> b) -> a -> b
$ \case EApp [EApp [ECon [Char]
o, SExpr
e]] | [Char]
o [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
nm -> do Either [Char] ([(a, r)], r)
mbAssocs <- fun -> ([Char], SExpr) -> m (Either [Char] ([(a, r)], r))
forall fun a r (m :: * -> *).
(SMTFunction fun a r, MonadIO m, SolverContext m, MonadQuery m,
MonadSymbolic m, SymVal r) =>
fun -> ([Char], SExpr) -> m (Either [Char] ([(a, r)], r))
forall (m :: * -> *).
(MonadIO m, SolverContext m, MonadQuery m, MonadSymbolic m,
SymVal r) =>
fun -> ([Char], SExpr) -> m (Either [Char] ([(a, r)], r))
sexprToFun fun
f ([Char] -> [Char] -> Bool -> Maybe [[Char]] -> [Char]
trimFunctionResponse [Char]
r [Char]
nm Bool
isCurried Maybe [[Char]]
args, SExpr
e)
case Either [Char] ([(a, r)], r)
mbAssocs of
Right ([(a, r)], r)
assocs -> Either ([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r)
-> m (Either ([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r)
-> m (Either
([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r)))
-> Either ([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r)
-> m (Either ([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r))
forall a b. (a -> b) -> a -> b
$ ([(a, r)], r)
-> Either ([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r)
forall a b. b -> Either a b
Right ([(a, r)], r)
assocs
Left [Char]
raw -> do Maybe ([([SExpr], SExpr)], SExpr)
mbPVS <- [Char] -> SBVType -> m (Maybe ([([SExpr], SExpr)], SExpr))
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
[Char] -> SBVType -> m (Maybe ([([SExpr], SExpr)], SExpr))
pointWiseExtract [Char]
nm (fun -> SBVType
forall fun a r. SMTFunction fun a r => fun -> SBVType
smtFunType fun
f)
case Maybe ([([SExpr], SExpr)], SExpr)
mbPVS Maybe ([([SExpr], SExpr)], SExpr)
-> (([([SExpr], SExpr)], SExpr) -> Maybe ([(a, r)], r))
-> Maybe ([(a, r)], r)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([([SExpr], SExpr)], SExpr) -> Maybe ([(a, r)], r)
convert of
Just ([(a, r)], r)
x -> Either ([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r)
-> m (Either ([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r)
-> m (Either
([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r)))
-> Either ([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r)
-> m (Either ([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r))
forall a b. (a -> b) -> a -> b
$ ([(a, r)], r)
-> Either ([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r)
forall a b. b -> Either a b
Right ([(a, r)], r)
x
Maybe ([(a, r)], r)
Nothing -> Either ([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r)
-> m (Either ([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r)
-> m (Either
([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r)))
-> Either ([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r)
-> m (Either ([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r))
forall a b. (a -> b) -> a -> b
$ ([Char], (Bool, Maybe [[Char]], SExpr))
-> Either ([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r)
forall a b. a -> Either a b
Left ([Char]
raw, (Bool
isCurried, Maybe [[Char]]
args, SExpr
e))
SExpr
_ -> [Char]
-> Maybe [[Char]]
-> m (Either ([Char], (Bool, Maybe [[Char]], SExpr)) ([(a, r)], r))
bad [Char]
r Maybe [[Char]]
forall a. Maybe a
Nothing
where convert :: ([([SExpr], SExpr)], SExpr) -> Maybe ([(a, r)], r)
convert ([([SExpr], SExpr)]
vs, SExpr
d) = (,) ([(a, r)] -> r -> ([(a, r)], r))
-> Maybe [(a, r)] -> Maybe (r -> ([(a, r)], r))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (([SExpr], SExpr) -> Maybe (a, r))
-> [([SExpr], SExpr)] -> Maybe [(a, r)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([SExpr], SExpr) -> Maybe (a, r)
sexprPoint [([SExpr], SExpr)]
vs Maybe (r -> ([(a, r)], r)) -> Maybe r -> Maybe ([(a, r)], r)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe r
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
d
sexprPoint :: ([SExpr], SExpr) -> Maybe (a, r)
sexprPoint ([SExpr]
as, SExpr
v) = (,) (a -> r -> (a, r)) -> Maybe a -> Maybe (r -> (a, r))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> fun -> [SExpr] -> Maybe a
forall fun a r. SMTFunction fun a r => fun -> [SExpr] -> Maybe a
sexprToArg fun
f [SExpr]
as Maybe (r -> (a, r)) -> Maybe r -> Maybe (a, r)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe r
forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
v
getUninterpretedValue :: (MonadIO m, MonadQuery m, HasKind a) => SBV a -> m String
getUninterpretedValue :: forall (m :: * -> *) a.
(MonadIO m, MonadQuery m, HasKind a) =>
SBV a -> m [Char]
getUninterpretedValue SBV a
s =
case SBV a -> Kind
forall a. HasKind a => a -> Kind
kindOf SBV a
s of
KUserSort [Char]
_ Maybe [[Char]]
Nothing -> do SV
sv <- (State -> IO SV) -> m SV
forall (m :: * -> *) a.
(MonadIO m, MonadQuery m) =>
(State -> IO a) -> m a
inNewContext (State -> SBV a -> IO SV
forall a. State -> SBV a -> IO SV
`sbvToSV` SBV a
s)
let nm :: [Char]
nm = SV -> [Char]
forall a. Show a => a -> [Char]
show SV
sv
cmd :: [Char]
cmd = [Char]
"(get-value (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
nm [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"))"
bad :: [Char] -> Maybe [[Char]] -> m [Char]
bad = [Char]
-> [Char]
-> [Char]
-> Maybe [[Char]]
-> [Char]
-> Maybe [[Char]]
-> m [Char]
forall (m :: * -> *) a.
(MonadIO m, MonadQuery m) =>
[Char]
-> [Char]
-> [Char]
-> Maybe [[Char]]
-> [Char]
-> Maybe [[Char]]
-> m a
unexpected [Char]
"getValue" [Char]
cmd [Char]
"a model value" Maybe [[Char]]
forall a. Maybe a
Nothing
[Char]
r <- [Char] -> m [Char]
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
[Char] -> m [Char]
ask [Char]
cmd
[Char]
-> ([Char] -> Maybe [[Char]] -> m [Char])
-> (SExpr -> m [Char])
-> m [Char]
forall a.
[Char] -> ([Char] -> Maybe [[Char]] -> a) -> (SExpr -> a) -> a
parse [Char]
r [Char] -> Maybe [[Char]] -> m [Char]
bad ((SExpr -> m [Char]) -> m [Char])
-> (SExpr -> m [Char]) -> m [Char]
forall a b. (a -> b) -> a -> b
$ \case EApp [EApp [ECon [Char]
o, ECon [Char]
v]] | [Char]
o [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== SV -> [Char]
forall a. Show a => a -> [Char]
show SV
sv -> [Char] -> m [Char]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
v
SExpr
_ -> [Char] -> Maybe [[Char]] -> m [Char]
bad [Char]
r Maybe [[Char]]
forall a. Maybe a
Nothing
Kind
k -> [Char] -> m [Char]
forall a. HasCallStack => [Char] -> a
error ([Char] -> m [Char]) -> [Char] -> m [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [[Char]
""
, [Char]
"*** SBV.getUninterpretedValue: Called on an 'interpreted' kind"
, [Char]
"*** "
, [Char]
"*** Kind: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Kind -> [Char]
forall a. Show a => a -> [Char]
show Kind
k
, [Char]
"*** Hint: Use 'getValue' to extract value for interpreted kinds."
, [Char]
"*** "
, [Char]
"*** Only truly uninterpreted sorts should be used with 'getUninterpretedValue.'"
]
getValueCVHelper :: (MonadIO m, MonadQuery m) => Maybe Int -> SV -> m CV
getValueCVHelper :: forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Maybe Int -> SV -> m CV
getValueCVHelper Maybe Int
mbi SV
s
| SV
s SV -> SV -> Bool
forall a. Eq a => a -> a -> Bool
== SV
trueSV
= CV -> m CV
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return CV
trueCV
| SV
s SV -> SV -> Bool
forall a. Eq a => a -> a -> Bool
== SV
falseSV
= CV -> m CV
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return CV
falseCV
| Bool
True
= Maybe Int -> [Char] -> Kind -> m CV
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Maybe Int -> [Char] -> Kind -> m CV
extractValue Maybe Int
mbi (SV -> [Char]
forall a. Show a => a -> [Char]
show SV
s) (SV -> Kind
forall a. HasKind a => a -> Kind
kindOf SV
s)
defaultKindedValue :: Kind -> CV
defaultKindedValue :: Kind -> CV
defaultKindedValue Kind
k = Kind -> CVal -> CV
CV Kind
k (CVal -> CV) -> CVal -> CV
forall a b. (a -> b) -> a -> b
$ Kind -> CVal
cvt Kind
k
where cvt :: Kind -> CVal
cvt :: Kind -> CVal
cvt Kind
KBool = Integer -> CVal
CInteger Integer
0
cvt KBounded{} = Integer -> CVal
CInteger Integer
0
cvt Kind
KUnbounded = Integer -> CVal
CInteger Integer
0
cvt Kind
KReal = AlgReal -> CVal
CAlgReal AlgReal
0
cvt (KUserSort [Char]
s Maybe [[Char]]
ui) = [Char] -> Maybe [[Char]] -> CVal
uninterp [Char]
s Maybe [[Char]]
ui
cvt Kind
KFloat = Float -> CVal
CFloat Float
0
cvt Kind
KDouble = Double -> CVal
CDouble Double
0
cvt Kind
KRational = Rational -> CVal
CRational Rational
0
cvt (KFP Int
eb Int
sb) = FP -> CVal
CFP (Bool -> Int -> Int -> FP
fpZero Bool
False Int
eb Int
sb)
cvt Kind
KChar = Char -> CVal
CChar Char
'\NUL'
cvt Kind
KString = [Char] -> CVal
CString [Char]
""
cvt (KList Kind
_) = [CVal] -> CVal
CList []
cvt (KSet Kind
_) = RCSet CVal -> CVal
CSet (RCSet CVal -> CVal) -> RCSet CVal -> CVal
forall a b. (a -> b) -> a -> b
$ Set CVal -> RCSet CVal
forall a. Set a -> RCSet a
RegularSet Set CVal
forall a. Set a
Set.empty
cvt (KTuple [Kind]
ks) = [CVal] -> CVal
CTuple ([CVal] -> CVal) -> [CVal] -> CVal
forall a b. (a -> b) -> a -> b
$ (Kind -> CVal) -> [Kind] -> [CVal]
forall a b. (a -> b) -> [a] -> [b]
map Kind -> CVal
cvt [Kind]
ks
cvt (KMaybe Kind
_) = Maybe CVal -> CVal
CMaybe Maybe CVal
forall a. Maybe a
Nothing
cvt (KEither Kind
k1 Kind
_) = Either CVal CVal -> CVal
CEither (Either CVal CVal -> CVal)
-> (CVal -> Either CVal CVal) -> CVal -> CVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CVal -> Either CVal CVal
forall a b. a -> Either a b
Left (CVal -> CVal) -> CVal -> CVal
forall a b. (a -> b) -> a -> b
$ Kind -> CVal
cvt Kind
k1
uninterp :: [Char] -> Maybe [[Char]] -> CVal
uninterp [Char]
_ (Just ([Char]
c:[[Char]]
_)) = (Maybe Int, [Char]) -> CVal
CUserSort (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1, [Char]
c)
uninterp [Char]
_ (Just []) = [Char] -> CVal
forall a. HasCallStack => [Char] -> a
error [Char]
"defaultKindedValue: enumerated kind with no constructors!"
uninterp [Char]
s Maybe [[Char]]
Nothing = (Maybe Int, [Char]) -> CVal
CUserSort (Maybe Int
forall a. Maybe a
Nothing, [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_witness")
sexprToVal :: forall a. SymVal a => SExpr -> Maybe a
sexprToVal :: forall a. SymVal a => SExpr -> Maybe a
sexprToVal SExpr
e = CV -> a
forall a. SymVal a => CV -> a
fromCV (CV -> a) -> Maybe CV -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Kind -> SExpr -> Maybe CV
recoverKindedValue (Proxy a -> Kind
forall a. HasKind a => a -> Kind
kindOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)) SExpr
e
recoverKindedValue :: Kind -> SExpr -> Maybe CV
recoverKindedValue :: Kind -> SExpr -> Maybe CV
recoverKindedValue Kind
k SExpr
e = case Kind
k of
Kind
KBool | ENum (Integer
i, Maybe Int
_) <- SExpr
e -> CV -> Maybe CV
forall a. a -> Maybe a
Just (CV -> Maybe CV) -> CV -> Maybe CV
forall a b. (a -> b) -> a -> b
$ Kind -> Integer -> CV
forall a. Integral a => Kind -> a -> CV
mkConstCV Kind
k Integer
i
| Bool
True -> Maybe CV
forall a. Maybe a
Nothing
KBounded{} | ENum (Integer
i, Maybe Int
_) <- SExpr
e -> CV -> Maybe CV
forall a. a -> Maybe a
Just (CV -> Maybe CV) -> CV -> Maybe CV
forall a b. (a -> b) -> a -> b
$ Kind -> Integer -> CV
forall a. Integral a => Kind -> a -> CV
mkConstCV Kind
k Integer
i
| Bool
True -> Maybe CV
forall a. Maybe a
Nothing
Kind
KUnbounded | ENum (Integer
i, Maybe Int
_) <- SExpr
e -> CV -> Maybe CV
forall a. a -> Maybe a
Just (CV -> Maybe CV) -> CV -> Maybe CV
forall a b. (a -> b) -> a -> b
$ Kind -> Integer -> CV
forall a. Integral a => Kind -> a -> CV
mkConstCV Kind
k Integer
i
| Bool
True -> Maybe CV
forall a. Maybe a
Nothing
Kind
KReal | ENum (Integer
i, Maybe Int
_) <- SExpr
e -> CV -> Maybe CV
forall a. a -> Maybe a
Just (CV -> Maybe CV) -> CV -> Maybe CV
forall a b. (a -> b) -> a -> b
$ Kind -> Integer -> CV
forall a. Integral a => Kind -> a -> CV
mkConstCV Kind
k Integer
i
| EReal AlgReal
i <- SExpr
e -> CV -> Maybe CV
forall a. a -> Maybe a
Just (CV -> Maybe CV) -> CV -> Maybe CV
forall a b. (a -> b) -> a -> b
$ Kind -> CVal -> CV
CV Kind
KReal (AlgReal -> CVal
CAlgReal AlgReal
i)
| Bool
True -> SExpr -> Maybe CV
interpretInterval SExpr
e
KUserSort{} | ECon [Char]
s <- SExpr
e -> CV -> Maybe CV
forall a. a -> Maybe a
Just (CV -> Maybe CV) -> CV -> Maybe CV
forall a b. (a -> b) -> a -> b
$ Kind -> CVal -> CV
CV Kind
k (CVal -> CV) -> CVal -> CV
forall a b. (a -> b) -> a -> b
$ (Maybe Int, [Char]) -> CVal
CUserSort (Kind -> [Char] -> Maybe Int
getUIIndex Kind
k [Char]
s, [Char]
s)
| Bool
True -> Maybe CV
forall a. Maybe a
Nothing
Kind
KFloat | ENum (Integer
i, Maybe Int
_) <- SExpr
e -> CV -> Maybe CV
forall a. a -> Maybe a
Just (CV -> Maybe CV) -> CV -> Maybe CV
forall a b. (a -> b) -> a -> b
$ Kind -> Integer -> CV
forall a. Integral a => Kind -> a -> CV
mkConstCV Kind
k Integer
i
| EFloat Float
i <- SExpr
e -> CV -> Maybe CV
forall a. a -> Maybe a
Just (CV -> Maybe CV) -> CV -> Maybe CV
forall a b. (a -> b) -> a -> b
$ Kind -> CVal -> CV
CV Kind
KFloat (Float -> CVal
CFloat Float
i)
| Bool
True -> Maybe CV
forall a. Maybe a
Nothing
Kind
KDouble | ENum (Integer
i, Maybe Int
_) <- SExpr
e -> CV -> Maybe CV
forall a. a -> Maybe a
Just (CV -> Maybe CV) -> CV -> Maybe CV
forall a b. (a -> b) -> a -> b
$ Kind -> Integer -> CV
forall a. Integral a => Kind -> a -> CV
mkConstCV Kind
k Integer
i
| EDouble Double
i <- SExpr
e -> CV -> Maybe CV
forall a. a -> Maybe a
Just (CV -> Maybe CV) -> CV -> Maybe CV
forall a b. (a -> b) -> a -> b
$ Kind -> CVal -> CV
CV Kind
KDouble (Double -> CVal
CDouble Double
i)
| Bool
True -> Maybe CV
forall a. Maybe a
Nothing
KFP Int
eb Int
sb | ENum (Integer
i, Maybe Int
_) <- SExpr
e -> CV -> Maybe CV
forall a. a -> Maybe a
Just (CV -> Maybe CV) -> CV -> Maybe CV
forall a b. (a -> b) -> a -> b
$ Kind -> CVal -> CV
CV Kind
k (CVal -> CV) -> CVal -> CV
forall a b. (a -> b) -> a -> b
$ FP -> CVal
CFP (FP -> CVal) -> FP -> CVal
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Integer -> FP
fpFromInteger Int
eb Int
sb Integer
i
| EFloat Float
f <- SExpr
e -> CV -> Maybe CV
forall a. a -> Maybe a
Just (CV -> Maybe CV) -> CV -> Maybe CV
forall a b. (a -> b) -> a -> b
$ Kind -> CVal -> CV
CV Kind
k (CVal -> CV) -> CVal -> CV
forall a b. (a -> b) -> a -> b
$ FP -> CVal
CFP (FP -> CVal) -> FP -> CVal
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Float -> FP
fpFromFloat Int
eb Int
sb Float
f
| EDouble Double
d <- SExpr
e -> CV -> Maybe CV
forall a. a -> Maybe a
Just (CV -> Maybe CV) -> CV -> Maybe CV
forall a b. (a -> b) -> a -> b
$ Kind -> CVal -> CV
CV Kind
k (CVal -> CV) -> CVal -> CV
forall a b. (a -> b) -> a -> b
$ FP -> CVal
CFP (FP -> CVal) -> FP -> CVal
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Double -> FP
fpFromDouble Int
eb Int
sb Double
d
| EFloatingPoint FP
c <- SExpr
e -> CV -> Maybe CV
forall a. a -> Maybe a
Just (CV -> Maybe CV) -> CV -> Maybe CV
forall a b. (a -> b) -> a -> b
$ Kind -> CVal -> CV
CV Kind
k (CVal -> CV) -> CVal -> CV
forall a b. (a -> b) -> a -> b
$ FP -> CVal
CFP FP
c
| Bool
True -> Maybe CV
forall a. Maybe a
Nothing
Kind
KChar | ECon [Char]
s <- SExpr
e -> CV -> Maybe CV
forall a. a -> Maybe a
Just (CV -> Maybe CV) -> CV -> Maybe CV
forall a b. (a -> b) -> a -> b
$ Kind -> CVal -> CV
CV Kind
KChar (CVal -> CV) -> CVal -> CV
forall a b. (a -> b) -> a -> b
$ Char -> CVal
CChar (Char -> CVal) -> Char -> CVal
forall a b. (a -> b) -> a -> b
$ [Char] -> Char
interpretChar [Char]
s
| Bool
True -> Maybe CV
forall a. Maybe a
Nothing
Kind
KString | ECon [Char]
s <- SExpr
e -> CV -> Maybe CV
forall a. a -> Maybe a
Just (CV -> Maybe CV) -> CV -> Maybe CV
forall a b. (a -> b) -> a -> b
$ Kind -> CVal -> CV
CV Kind
KString (CVal -> CV) -> CVal -> CV
forall a b. (a -> b) -> a -> b
$ [Char] -> CVal
CString ([Char] -> CVal) -> [Char] -> CVal
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
interpretString [Char]
s
| Bool
True -> Maybe CV
forall a. Maybe a
Nothing
Kind
KRational -> CV -> Maybe CV
forall a. a -> Maybe a
Just (CV -> Maybe CV) -> CV -> Maybe CV
forall a b. (a -> b) -> a -> b
$ Kind -> CVal -> CV
CV Kind
k (CVal -> CV) -> CVal -> CV
forall a b. (a -> b) -> a -> b
$ Rational -> CVal
CRational (Rational -> CVal) -> Rational -> CVal
forall a b. (a -> b) -> a -> b
$ SExpr -> Rational
interpretRational SExpr
e
KList Kind
ek -> CV -> Maybe CV
forall a. a -> Maybe a
Just (CV -> Maybe CV) -> CV -> Maybe CV
forall a b. (a -> b) -> a -> b
$ Kind -> CVal -> CV
CV Kind
k (CVal -> CV) -> CVal -> CV
forall a b. (a -> b) -> a -> b
$ [CVal] -> CVal
CList ([CVal] -> CVal) -> [CVal] -> CVal
forall a b. (a -> b) -> a -> b
$ Kind -> SExpr -> [CVal]
interpretList Kind
ek SExpr
e
KSet Kind
ek -> CV -> Maybe CV
forall a. a -> Maybe a
Just (CV -> Maybe CV) -> CV -> Maybe CV
forall a b. (a -> b) -> a -> b
$ Kind -> CVal -> CV
CV Kind
k (CVal -> CV) -> CVal -> CV
forall a b. (a -> b) -> a -> b
$ RCSet CVal -> CVal
CSet (RCSet CVal -> CVal) -> RCSet CVal -> CVal
forall a b. (a -> b) -> a -> b
$ Kind -> SExpr -> RCSet CVal
interpretSet Kind
ek SExpr
e
KTuple{} -> CV -> Maybe CV
forall a. a -> Maybe a
Just (CV -> Maybe CV) -> CV -> Maybe CV
forall a b. (a -> b) -> a -> b
$ Kind -> CVal -> CV
CV Kind
k (CVal -> CV) -> CVal -> CV
forall a b. (a -> b) -> a -> b
$ [CVal] -> CVal
CTuple ([CVal] -> CVal) -> [CVal] -> CVal
forall a b. (a -> b) -> a -> b
$ SExpr -> [CVal]
interpretTuple SExpr
e
KMaybe{} -> CV -> Maybe CV
forall a. a -> Maybe a
Just (CV -> Maybe CV) -> CV -> Maybe CV
forall a b. (a -> b) -> a -> b
$ Kind -> CVal -> CV
CV Kind
k (CVal -> CV) -> CVal -> CV
forall a b. (a -> b) -> a -> b
$ Maybe CVal -> CVal
CMaybe (Maybe CVal -> CVal) -> Maybe CVal -> CVal
forall a b. (a -> b) -> a -> b
$ Kind -> SExpr -> Maybe CVal
interpretMaybe Kind
k SExpr
e
KEither{} -> CV -> Maybe CV
forall a. a -> Maybe a
Just (CV -> Maybe CV) -> CV -> Maybe CV
forall a b. (a -> b) -> a -> b
$ Kind -> CVal -> CV
CV Kind
k (CVal -> CV) -> CVal -> CV
forall a b. (a -> b) -> a -> b
$ Either CVal CVal -> CVal
CEither (Either CVal CVal -> CVal) -> Either CVal CVal -> CVal
forall a b. (a -> b) -> a -> b
$ Kind -> SExpr -> Either CVal CVal
interpretEither Kind
k SExpr
e
where getUIIndex :: Kind -> [Char] -> Maybe Int
getUIIndex (KUserSort [Char]
_ (Just [[Char]]
xs)) [Char]
i = [Char]
i [Char] -> [[Char]] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
`elemIndex` [[Char]]
xs
getUIIndex Kind
_ [Char]
_ = Maybe Int
forall a. Maybe a
Nothing
stringLike :: [Char] -> Bool
stringLike [Char]
xs = [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
xs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 Bool -> Bool -> Bool
&& [Char]
"\"" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
xs Bool -> Bool -> Bool
&& [Char]
"\"" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
xs
interpretString :: [Char] -> [Char]
interpretString [Char]
xs
| Bool -> Bool
not ([Char] -> Bool
stringLike [Char]
xs)
= [Char] -> [Char]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"Expected a string constant with quotes, received: <" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
xs [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
">"
| Bool
True
= [Char] -> [Char]
qfsToString ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
1 ([Char] -> [Char]
forall a. HasCallStack => [a] -> [a]
init [Char]
xs)
interpretChar :: [Char] -> Char
interpretChar [Char]
xs = case [Char] -> [Char]
interpretString [Char]
xs of
[Char
c] -> Char
c
[Char]
_ -> [Char] -> Char
forall a. HasCallStack => [Char] -> a
error ([Char] -> Char) -> [Char] -> Char
forall a b. (a -> b) -> a -> b
$ [Char]
"Expected a singleton char constant, received: <" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
xs [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
">"
interpretRational :: SExpr -> Rational
interpretRational (EApp [ECon [Char]
"SBV.Rational", SExpr
v1, SExpr
v2])
| Just (CV Kind
_ (CInteger Integer
n)) <- Kind -> SExpr -> Maybe CV
recoverKindedValue Kind
KUnbounded SExpr
v1
, Just (CV Kind
_ (CInteger Integer
d)) <- Kind -> SExpr -> Maybe CV
recoverKindedValue Kind
KUnbounded SExpr
v2
= Integer
n Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
d
interpretRational SExpr
xs = [Char] -> Rational
forall a. HasCallStack => [Char] -> a
error ([Char] -> Rational) -> [Char] -> Rational
forall a b. (a -> b) -> a -> b
$ [Char]
"Expected a rational constant, received: <" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SExpr -> [Char]
forall a. Show a => a -> [Char]
show SExpr
xs [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
">"
interpretList :: Kind -> SExpr -> [CVal]
interpretList Kind
ek SExpr
topExpr = SExpr -> [CVal]
walk SExpr
topExpr
where walk :: SExpr -> [CVal]
walk (EApp [ECon [Char]
"as", ECon [Char]
"seq.empty", SExpr
_]) = []
walk (EApp [ECon [Char]
"seq.unit", SExpr
v]) = case Kind -> SExpr -> Maybe CV
recoverKindedValue Kind
ek SExpr
v of
Just CV
w -> [CV -> CVal
cvVal CV
w]
Maybe CV
Nothing -> [Char] -> [CVal]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [CVal]) -> [Char] -> [CVal]
forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot parse a sequence item of kind " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Kind -> [Char]
forall a. Show a => a -> [Char]
show Kind
ek [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" from: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SExpr -> [Char]
forall a. Show a => a -> [Char]
show SExpr
v [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SExpr -> [Char]
extra SExpr
v
walk (EApp (ECon [Char]
"seq.++" : [SExpr]
rest)) = (SExpr -> [CVal]) -> [SExpr] -> [CVal]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SExpr -> [CVal]
walk [SExpr]
rest
walk SExpr
cur = [Char] -> [CVal]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [CVal]) -> [Char] -> [CVal]
forall a b. (a -> b) -> a -> b
$ [Char]
"Expected a sequence constant, but received: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SExpr -> [Char]
forall a. Show a => a -> [Char]
show SExpr
cur [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SExpr -> [Char]
extra SExpr
cur
extra :: SExpr -> [Char]
extra SExpr
cur | SExpr -> [Char]
forall a. Show a => a -> [Char]
show SExpr
cur [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
t = [Char]
""
| Bool
True = [Char]
"\nWhile parsing: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
t
where t :: [Char]
t = SExpr -> [Char]
forall a. Show a => a -> [Char]
show SExpr
topExpr
interpretSet :: Kind -> SExpr -> RCSet CVal
interpretSet Kind
ke SExpr
setExpr
| SExpr -> Bool
isUniversal SExpr
setExpr = Set CVal -> RCSet CVal
forall a. Set a -> RCSet a
ComplementSet Set CVal
forall a. Set a
Set.empty
| SExpr -> Bool
isEmpty SExpr
setExpr = Set CVal -> RCSet CVal
forall a. Set a -> RCSet a
RegularSet Set CVal
forall a. Set a
Set.empty
| Just (Right ([([SExpr], SExpr)], SExpr)
assocs) <- Maybe (Either [Char] ([([SExpr], SExpr)], SExpr))
mbAssocs = ([([SExpr], SExpr)], SExpr) -> RCSet CVal
decode ([([SExpr], SExpr)], SExpr)
assocs
| Bool
True = [Char] -> RCSet CVal
forall a. [Char] -> a
tbd [Char]
"Expected a set value, but couldn't decipher the solver output."
where tbd :: String -> a
tbd :: forall a. [Char] -> a
tbd [Char]
w = [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [ [Char]
""
, [Char]
"*** Data.SBV.interpretSet: Unable to process solver output."
, [Char]
"***"
, [Char]
"*** Kind : " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Kind -> [Char]
forall a. Show a => a -> [Char]
show (Kind -> Kind
KSet Kind
ke)
, [Char]
"*** Received: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SExpr -> [Char]
forall a. Show a => a -> [Char]
show SExpr
setExpr
, [Char]
"*** Reason : " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
w
, [Char]
"***"
, [Char]
"*** This is either a bug or something SBV currently does not support."
, [Char]
"*** Please report this as a feature request!"
]
isTrue :: SExpr -> Bool
isTrue (ENum (Integer
1, Maybe Int
Nothing)) = Bool
True
isTrue (ENum (Integer
0, Maybe Int
Nothing)) = Bool
False
isTrue SExpr
bad = [Char] -> Bool
forall a. [Char] -> a
tbd ([Char] -> Bool) -> [Char] -> Bool
forall a b. (a -> b) -> a -> b
$ [Char]
"Non-boolean membership value seen: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SExpr -> [Char]
forall a. Show a => a -> [Char]
show SExpr
bad
isUniversal :: SExpr -> Bool
isUniversal (EApp [EApp [ECon [Char]
"as", ECon [Char]
"const", EApp [ECon [Char]
"Array", SExpr
_, ECon [Char]
"Bool"]], SExpr
r]) = SExpr -> Bool
isTrue SExpr
r
isUniversal SExpr
_ = Bool
False
isEmpty :: SExpr -> Bool
isEmpty (EApp [EApp [ECon [Char]
"as", ECon [Char]
"const", EApp [ECon [Char]
"Array", SExpr
_, ECon [Char]
"Bool"]], SExpr
r]) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ SExpr -> Bool
isTrue SExpr
r
isEmpty SExpr
_ = Bool
False
mbAssocs :: Maybe (Either [Char] ([([SExpr], SExpr)], SExpr))
mbAssocs = SExpr -> Maybe (Either [Char] ([([SExpr], SExpr)], SExpr))
parseSExprFunction SExpr
setExpr
decode :: ([([SExpr], SExpr)], SExpr) -> RCSet CVal
decode ([([SExpr], SExpr)]
args, SExpr
r) | SExpr -> Bool
isTrue SExpr
r = Set CVal -> RCSet CVal
forall a. Set a -> RCSet a
ComplementSet (Set CVal -> RCSet CVal) -> Set CVal -> RCSet CVal
forall a b. (a -> b) -> a -> b
$ [CVal] -> Set CVal
forall a. Ord a => [a] -> Set a
Set.fromList [CVal
x | (CVal
x, Bool
False) <- (([SExpr], SExpr) -> [(CVal, Bool)])
-> [([SExpr], SExpr)] -> [(CVal, Bool)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Bool -> ([SExpr], SExpr) -> [(CVal, Bool)]
contents Bool
True) [([SExpr], SExpr)]
args]
| Bool
True = Set CVal -> RCSet CVal
forall a. Set a -> RCSet a
RegularSet (Set CVal -> RCSet CVal) -> Set CVal -> RCSet CVal
forall a b. (a -> b) -> a -> b
$ [CVal] -> Set CVal
forall a. Ord a => [a] -> Set a
Set.fromList [CVal
x | (CVal
x, Bool
True) <- (([SExpr], SExpr) -> [(CVal, Bool)])
-> [([SExpr], SExpr)] -> [(CVal, Bool)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Bool -> ([SExpr], SExpr) -> [(CVal, Bool)]
contents Bool
False) [([SExpr], SExpr)]
args]
contents :: Bool -> ([SExpr], SExpr) -> [(CVal, Bool)]
contents Bool
cvt ([SExpr
v], SExpr
r) = let t :: Bool
t = SExpr -> Bool
isTrue SExpr
r in (CVal -> (CVal, Bool)) -> [CVal] -> [(CVal, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (, Bool
t) (Bool -> SExpr -> [CVal]
element Bool
cvt SExpr
v)
contents Bool
_ ([SExpr], SExpr)
bad = [Char] -> [(CVal, Bool)]
forall a. [Char] -> a
tbd ([Char] -> [(CVal, Bool)]) -> [Char] -> [(CVal, Bool)]
forall a b. (a -> b) -> a -> b
$ [Char]
"Multi-valued set member seen: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ([SExpr], SExpr) -> [Char]
forall a. Show a => a -> [Char]
show ([SExpr], SExpr)
bad
element :: Bool -> SExpr -> [CVal]
element Bool
cvt SExpr
x = case (Bool
cvt, Kind
ke) of
(Bool
True, Kind
KChar) -> case Kind -> SExpr -> Maybe CV
recoverKindedValue Kind
KString SExpr
x of
Just CV
v -> case CV -> CVal
cvVal CV
v of
CString [Char
c] -> [Char -> CVal
CChar Char
c]
CString [Char]
_ -> []
CVal
_ -> [Char] -> [CVal]
forall a. [Char] -> a
tbd ([Char] -> [CVal]) -> [Char] -> [CVal]
forall a b. (a -> b) -> a -> b
$ [Char]
"Unexpected value for kind: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (SExpr, Kind) -> [Char]
forall a. Show a => a -> [Char]
show (SExpr
x, Kind
ke)
Maybe CV
Nothing -> [Char] -> [CVal]
forall a. [Char] -> a
tbd ([Char] -> [CVal]) -> [Char] -> [CVal]
forall a b. (a -> b) -> a -> b
$ [Char]
"Unexpected value for kind: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (SExpr, Kind) -> [Char]
forall a. Show a => a -> [Char]
show (SExpr
x, Kind
ke)
(Bool, Kind)
_ -> case Kind -> SExpr -> Maybe CV
recoverKindedValue Kind
ke SExpr
x of
Just CV
v -> [CV -> CVal
cvVal CV
v]
Maybe CV
Nothing -> [Char] -> [CVal]
forall a. [Char] -> a
tbd ([Char] -> [CVal]) -> [Char] -> [CVal]
forall a b. (a -> b) -> a -> b
$ [Char]
"Unexpected value for kind: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (SExpr, Kind) -> [Char]
forall a. Show a => a -> [Char]
show (SExpr
x, Kind
ke)
interpretTuple :: SExpr -> [CVal]
interpretTuple SExpr
te = Int -> [Maybe CV] -> [CVal] -> [CVal]
walk (Int
1 :: Int) ((Kind -> SExpr -> Maybe CV) -> [Kind] -> [SExpr] -> [Maybe CV]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Kind -> SExpr -> Maybe CV
recoverKindedValue [Kind]
ks [SExpr]
args) []
where ([Kind]
ks, Int
n) = case Kind
k of
KTuple [Kind]
eks -> ([Kind]
eks, [Kind] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Kind]
eks)
Kind
_ -> [Char] -> ([Kind], Int)
forall a. HasCallStack => [Char] -> a
error ([Char] -> ([Kind], Int)) -> [Char] -> ([Kind], Int)
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [ [Char]
"Impossible: Expected a tuple kind, but got: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Kind -> [Char]
forall a. Show a => a -> [Char]
show Kind
k
, [Char]
"While trying to parse: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SExpr -> [Char]
forall a. Show a => a -> [Char]
show SExpr
te
]
args :: [SExpr]
args = SExpr -> [SExpr]
try SExpr
te
where
try :: SExpr -> [SExpr]
try (EApp (ECon [Char]
f : [SExpr]
as)) = case Int -> [Char] -> ([Char], [Char])
forall a. Int -> [a] -> ([a], [a])
splitAt (Text -> Int
T.length Text
"mkSBVTuple") [Char]
f of
([Char]
"mkSBVTuple", [Char]
c) | (Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit [Char]
c Bool -> Bool -> Bool
&& [Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n Bool -> Bool -> Bool
&& [SExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SExpr]
as Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n -> [SExpr]
as
([Char], [Char])
_ -> [SExpr]
bad
try (EApp (EApp [ECon [Char]
"as", ECon [Char]
f, SExpr
_] : [SExpr]
as)) = SExpr -> [SExpr]
try ([SExpr] -> SExpr
EApp ([Char] -> SExpr
ECon [Char]
f SExpr -> [SExpr] -> [SExpr]
forall a. a -> [a] -> [a]
: [SExpr]
as))
try SExpr
_ = [SExpr]
bad
bad :: [SExpr]
bad = [Char] -> [SExpr]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [SExpr]) -> [Char] -> [SExpr]
forall a b. (a -> b) -> a -> b
$ [Char]
"Data.SBV.sexprToTuple: Impossible: Expected a constructor for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" tuple, but got: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SExpr -> [Char]
forall a. Show a => a -> [Char]
show SExpr
te
walk :: Int -> [Maybe CV] -> [CVal] -> [CVal]
walk Int
_ [] [CVal]
sofar = [CVal] -> [CVal]
forall a. [a] -> [a]
reverse [CVal]
sofar
walk Int
i (Just CV
el:[Maybe CV]
es) [CVal]
sofar = Int -> [Maybe CV] -> [CVal] -> [CVal]
walk (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [Maybe CV]
es (CV -> CVal
cvVal CV
el CVal -> [CVal] -> [CVal]
forall a. a -> [a] -> [a]
: [CVal]
sofar)
walk Int
i (Maybe CV
Nothing:[Maybe CV]
_) [CVal]
_ = [Char] -> [CVal]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [CVal]) -> [Char] -> [CVal]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [ [Char]
"Couldn't parse a tuple element at position " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i
, [Char]
"Kind: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Kind -> [Char]
forall a. Show a => a -> [Char]
show Kind
k
, [Char]
"Expr: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SExpr -> [Char]
forall a. Show a => a -> [Char]
show SExpr
te
]
interpretMaybe :: Kind -> SExpr -> Maybe CVal
interpretMaybe (KMaybe Kind
_) (ECon [Char]
"nothing_SBVMaybe") = Maybe CVal
forall a. Maybe a
Nothing
interpretMaybe (KMaybe Kind
ek) (EApp [ECon [Char]
"just_SBVMaybe", SExpr
a]) = case Kind -> SExpr -> Maybe CV
recoverKindedValue Kind
ek SExpr
a of
Just (CV Kind
_ CVal
v) -> CVal -> Maybe CVal
forall a. a -> Maybe a
Just CVal
v
Maybe CV
Nothing -> [Char] -> Maybe CVal
forall a. HasCallStack => [Char] -> a
error ([Char] -> Maybe CVal) -> [Char] -> Maybe CVal
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [ [Char]
"Couldn't parse a maybe just value"
, [Char]
"Kind: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Kind -> [Char]
forall a. Show a => a -> [Char]
show Kind
ek
, [Char]
"Expr: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SExpr -> [Char]
forall a. Show a => a -> [Char]
show SExpr
a
]
interpretMaybe Kind
_ ( EApp [ECon [Char]
"as", ECon [Char]
"nothing_SBVMaybe", SExpr
_]) = Maybe CVal
forall a. Maybe a
Nothing
interpretMaybe Kind
mk (EApp [EApp [ECon [Char]
"as", ECon [Char]
"just_SBVMaybe", SExpr
_], SExpr
a]) = Kind -> SExpr -> Maybe CVal
interpretMaybe Kind
mk ([SExpr] -> SExpr
EApp [[Char] -> SExpr
ECon [Char]
"just_SBVMaybe", SExpr
a])
interpretMaybe Kind
_ SExpr
other = [Char] -> Maybe CVal
forall a. HasCallStack => [Char] -> a
error ([Char] -> Maybe CVal) -> [Char] -> Maybe CVal
forall a b. (a -> b) -> a -> b
$ [Char]
"Expected an SMaybe sexpr, but received: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Kind, SExpr) -> [Char]
forall a. Show a => a -> [Char]
show (Kind
k, SExpr
other)
interpretEither :: Kind -> SExpr -> Either CVal CVal
interpretEither (KEither Kind
k1 Kind
_) (EApp [ECon [Char]
"left_SBVEither", SExpr
a]) = case Kind -> SExpr -> Maybe CV
recoverKindedValue Kind
k1 SExpr
a of
Just (CV Kind
_ CVal
v) -> CVal -> Either CVal CVal
forall a b. a -> Either a b
Left CVal
v
Maybe CV
Nothing -> [Char] -> Either CVal CVal
forall a. HasCallStack => [Char] -> a
error ([Char] -> Either CVal CVal) -> [Char] -> Either CVal CVal
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [ [Char]
"Couldn't parse an either value on the left"
, [Char]
"Kind: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Kind -> [Char]
forall a. Show a => a -> [Char]
show Kind
k1
, [Char]
"Expr: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SExpr -> [Char]
forall a. Show a => a -> [Char]
show SExpr
a
]
interpretEither (KEither Kind
_ Kind
k2) (EApp [ECon [Char]
"right_SBVEither", SExpr
b]) = case Kind -> SExpr -> Maybe CV
recoverKindedValue Kind
k2 SExpr
b of
Just (CV Kind
_ CVal
v) -> CVal -> Either CVal CVal
forall a b. b -> Either a b
Right CVal
v
Maybe CV
Nothing -> [Char] -> Either CVal CVal
forall a. HasCallStack => [Char] -> a
error ([Char] -> Either CVal CVal) -> [Char] -> Either CVal CVal
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [ [Char]
"Couldn't parse an either value on the right"
, [Char]
"Kind: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Kind -> [Char]
forall a. Show a => a -> [Char]
show Kind
k2
, [Char]
"Expr: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SExpr -> [Char]
forall a. Show a => a -> [Char]
show SExpr
b
]
interpretEither Kind
ek (EApp [EApp [ECon [Char]
"as", ECon [Char]
"left_SBVEither", SExpr
_], SExpr
a]) = Kind -> SExpr -> Either CVal CVal
interpretEither Kind
ek ([SExpr] -> SExpr
EApp [[Char] -> SExpr
ECon [Char]
"left_SBVEither", SExpr
a])
interpretEither Kind
ek (EApp [EApp [ECon [Char]
"as", ECon [Char]
"right_SBVEither", SExpr
_], SExpr
b]) = Kind -> SExpr -> Either CVal CVal
interpretEither Kind
ek ([SExpr] -> SExpr
EApp [[Char] -> SExpr
ECon [Char]
"right_SBVEither", SExpr
b])
interpretEither Kind
_ SExpr
other = [Char] -> Either CVal CVal
forall a. HasCallStack => [Char] -> a
error ([Char] -> Either CVal CVal) -> [Char] -> Either CVal CVal
forall a b. (a -> b) -> a -> b
$ [Char]
"Expected an SEither sexpr, but received: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Kind, SExpr) -> [Char]
forall a. Show a => a -> [Char]
show (Kind
k, SExpr
other)
interpretInterval :: SExpr -> Maybe CV
interpretInterval SExpr
expr = case SExpr
expr of
EApp [ECon [Char]
"interval", SExpr
lo, SExpr
hi] -> do RealPoint Rational
vlo <- SExpr -> Maybe (RealPoint Rational)
getBorder SExpr
lo
RealPoint Rational
vhi <- SExpr -> Maybe (RealPoint Rational)
getBorder SExpr
hi
CV -> Maybe CV
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CV -> Maybe CV) -> CV -> Maybe CV
forall a b. (a -> b) -> a -> b
$ Kind -> CVal -> CV
CV Kind
KReal (AlgReal -> CVal
CAlgReal (RealPoint Rational -> RealPoint Rational -> AlgReal
AlgInterval RealPoint Rational
vlo RealPoint Rational
vhi))
SExpr
_ -> Maybe CV
forall a. Maybe a
Nothing
where getBorder :: SExpr -> Maybe (RealPoint Rational)
getBorder (EApp [ECon [Char]
"open", SExpr
v]) = Kind -> SExpr -> Maybe CV
recoverKindedValue Kind
KReal SExpr
v Maybe CV
-> (CV -> Maybe (RealPoint Rational)) -> Maybe (RealPoint Rational)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Rational -> RealPoint Rational)
-> CV -> Maybe (RealPoint Rational)
forall {f :: * -> *} {a}.
Applicative f =>
(Rational -> a) -> CV -> f a
border Rational -> RealPoint Rational
forall a. a -> RealPoint a
OpenPoint
getBorder (EApp [ECon [Char]
"closed", SExpr
v]) = Kind -> SExpr -> Maybe CV
recoverKindedValue Kind
KReal SExpr
v Maybe CV
-> (CV -> Maybe (RealPoint Rational)) -> Maybe (RealPoint Rational)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Rational -> RealPoint Rational)
-> CV -> Maybe (RealPoint Rational)
forall {f :: * -> *} {a}.
Applicative f =>
(Rational -> a) -> CV -> f a
border Rational -> RealPoint Rational
forall a. a -> RealPoint a
ClosedPoint
getBorder SExpr
_ = Maybe (RealPoint Rational)
forall a. Maybe a
Nothing
border :: (Rational -> a) -> CV -> f a
border Rational -> a
b (CV Kind
KReal (CAlgReal (AlgRational Bool
True Rational
v))) = a -> f a
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> f a) -> a -> f a
forall a b. (a -> b) -> a -> b
$ Rational -> a
b Rational
v
border Rational -> a
_ CV
other = [Char] -> f a
forall a. HasCallStack => [Char] -> a
error ([Char] -> f a) -> [Char] -> f a
forall a b. (a -> b) -> a -> b
$ [Char]
"Data.SBV.interpretInterval.border: Expected a real-valued sexp, but received: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CV -> [Char]
forall a. Show a => a -> [Char]
show CV
other
getValueCV :: (MonadIO m, MonadQuery m) => Maybe Int -> SV -> m CV
getValueCV :: forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Maybe Int -> SV -> m CV
getValueCV Maybe Int
mbi SV
s
| SV -> Kind
forall a. HasKind a => a -> Kind
kindOf SV
s Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
/= Kind
KReal
= Maybe Int -> SV -> m CV
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Maybe Int -> SV -> m CV
getValueCVHelper Maybe Int
mbi SV
s
| Bool
True
= do SMTConfig
cfg <- m SMTConfig
forall (m :: * -> *). (MonadIO m, MonadQuery m) => m SMTConfig
getConfig
if Bool -> Bool
not (SolverCapabilities -> Bool
supportsApproxReals (SMTSolver -> SolverCapabilities
capabilities (SMTConfig -> SMTSolver
solver SMTConfig
cfg)))
then Maybe Int -> SV -> m CV
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Maybe Int -> SV -> m CV
getValueCVHelper Maybe Int
mbi SV
s
else do Bool -> [Char] -> m ()
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Bool -> [Char] -> m ()
send Bool
True [Char]
"(set-option :pp.decimal false)"
CV
rep1 <- Maybe Int -> SV -> m CV
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Maybe Int -> SV -> m CV
getValueCVHelper Maybe Int
mbi SV
s
Bool -> [Char] -> m ()
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Bool -> [Char] -> m ()
send Bool
True [Char]
"(set-option :pp.decimal true)"
Bool -> [Char] -> m ()
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Bool -> [Char] -> m ()
send Bool
True ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"(set-option :pp.decimal_precision " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (SMTConfig -> Int
printRealPrec SMTConfig
cfg) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
CV
rep2 <- Maybe Int -> SV -> m CV
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Maybe Int -> SV -> m CV
getValueCVHelper Maybe Int
mbi SV
s
let bad :: m CV
bad = [Char]
-> [Char]
-> [Char]
-> Maybe [[Char]]
-> [Char]
-> Maybe [[Char]]
-> m CV
forall (m :: * -> *) a.
(MonadIO m, MonadQuery m) =>
[Char]
-> [Char]
-> [Char]
-> Maybe [[Char]]
-> [Char]
-> Maybe [[Char]]
-> m a
unexpected [Char]
"getValueCV" [Char]
"get-value" ([Char]
"a real-valued binding for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SV -> [Char]
forall a. Show a => a -> [Char]
show SV
s) Maybe [[Char]]
forall a. Maybe a
Nothing ((CV, CV) -> [Char]
forall a. Show a => a -> [Char]
show (CV
rep1, CV
rep2)) Maybe [[Char]]
forall a. Maybe a
Nothing
case (CV
rep1, CV
rep2) of
(CV Kind
KReal (CAlgReal AlgReal
a), CV Kind
KReal (CAlgReal AlgReal
b)) -> CV -> m CV
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CV -> m CV) -> CV -> m CV
forall a b. (a -> b) -> a -> b
$ Kind -> CVal -> CV
CV Kind
KReal (AlgReal -> CVal
CAlgReal ([Char] -> AlgReal -> AlgReal -> AlgReal
mergeAlgReals ([Char]
"Cannot merge real-values for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SV -> [Char]
forall a. Show a => a -> [Char]
show SV
s) AlgReal
a AlgReal
b))
(CV, CV)
_ -> m CV
bad
extractValue :: forall m. (MonadIO m, MonadQuery m) => Maybe Int -> String -> Kind -> m CV
Maybe Int
mbi [Char]
nm Kind
k = do
let modelIndex :: [Char]
modelIndex = case Maybe Int
mbi of
Maybe Int
Nothing -> [Char]
""
Just Int
i -> [Char]
" :model_index " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i
cmd :: [Char]
cmd = [Char]
"(get-value (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
nm [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
modelIndex [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
bad :: [Char] -> Maybe [[Char]] -> m CV
bad = [Char]
-> [Char]
-> [Char]
-> Maybe [[Char]]
-> [Char]
-> Maybe [[Char]]
-> m CV
forall (m :: * -> *) a.
(MonadIO m, MonadQuery m) =>
[Char]
-> [Char]
-> [Char]
-> Maybe [[Char]]
-> [Char]
-> Maybe [[Char]]
-> m a
unexpected [Char]
"getModel" [Char]
cmd ([Char]
"a value binding for kind: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Kind -> [Char]
forall a. Show a => a -> [Char]
show Kind
k) Maybe [[Char]]
forall a. Maybe a
Nothing
[Char]
r <- [Char] -> m [Char]
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
[Char] -> m [Char]
ask [Char]
cmd
let recover :: SExpr -> m CV
recover SExpr
val = case Kind -> SExpr -> Maybe CV
recoverKindedValue Kind
k SExpr
val of
Just CV
cv -> CV -> m CV
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return CV
cv
Maybe CV
Nothing -> [Char] -> Maybe [[Char]] -> m CV
bad [Char]
r Maybe [[Char]]
forall a. Maybe a
Nothing
[Char]
-> ([Char] -> Maybe [[Char]] -> m CV) -> (SExpr -> m CV) -> m CV
forall a.
[Char] -> ([Char] -> Maybe [[Char]] -> a) -> (SExpr -> a) -> a
parse [Char]
r [Char] -> Maybe [[Char]] -> m CV
bad ((SExpr -> m CV) -> m CV) -> (SExpr -> m CV) -> m CV
forall a b. (a -> b) -> a -> b
$ \case EApp [EApp [ECon [Char]
v, SExpr
val]] | [Char]
v [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
nm -> SExpr -> m CV
recover SExpr
val
SExpr
_ -> [Char] -> Maybe [[Char]] -> m CV
bad [Char]
r Maybe [[Char]]
forall a. Maybe a
Nothing
getUICVal :: forall m. (MonadIO m, MonadQuery m) => Maybe Int -> (String, (Bool, Maybe [String], SBVType)) -> m CV
getUICVal :: forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Maybe Int -> ([Char], (Bool, Maybe [[Char]], SBVType)) -> m CV
getUICVal Maybe Int
mbi ([Char]
nm, (Bool
_, Maybe [[Char]]
_, SBVType
t)) = case SBVType
t of
SBVType [Kind
k] -> Maybe Int -> [Char] -> Kind -> m CV
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Maybe Int -> [Char] -> Kind -> m CV
extractValue Maybe Int
mbi [Char]
nm Kind
k
SBVType
_ -> [Char] -> m CV
forall a. HasCallStack => [Char] -> a
error ([Char] -> m CV) -> [Char] -> m CV
forall a b. (a -> b) -> a -> b
$ [Char]
"SBV.getUICVal: Expected to be called on an uninterpeted value of a base type, received something else: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ([Char], SBVType) -> [Char]
forall a. Show a => a -> [Char]
show ([Char]
nm, SBVType
t)
getUIFunCVAssoc :: forall m. (MonadIO m, MonadQuery m) => Maybe Int -> (String, (Bool, Maybe [String], SBVType)) -> m (Either String ([([CV], CV)], CV))
getUIFunCVAssoc :: forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Maybe Int
-> ([Char], (Bool, Maybe [[Char]], SBVType))
-> m (Either [Char] ([([CV], CV)], CV))
getUIFunCVAssoc Maybe Int
mbi ([Char]
nm, (Bool
isCurried, Maybe [[Char]]
mbArgs, SBVType
typ)) = do
let modelIndex :: [Char]
modelIndex = case Maybe Int
mbi of
Maybe Int
Nothing -> [Char]
""
Just Int
i -> [Char]
" :model_index " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i
cmd :: [Char]
cmd = [Char]
"(get-value (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
nm [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
modelIndex [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
bad :: [Char] -> Maybe [[Char]] -> m (Either [Char] ([([CV], CV)], CV))
bad = [Char]
-> [Char]
-> [Char]
-> Maybe [[Char]]
-> [Char]
-> Maybe [[Char]]
-> m (Either [Char] ([([CV], CV)], CV))
forall (m :: * -> *) a.
(MonadIO m, MonadQuery m) =>
[Char]
-> [Char]
-> [Char]
-> Maybe [[Char]]
-> [Char]
-> Maybe [[Char]]
-> m a
unexpected [Char]
"get-value" [Char]
cmd [Char]
"a function value" Maybe [[Char]]
forall a. Maybe a
Nothing
[Char]
r <- [Char] -> m [Char]
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
[Char] -> m [Char]
ask [Char]
cmd
let ([Kind]
ats, Kind
rt) = case SBVType
typ of
SBVType [Kind]
as | [Kind] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Kind]
as Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 -> ([Kind] -> [Kind]
forall a. HasCallStack => [a] -> [a]
init [Kind]
as, [Kind] -> Kind
forall a. HasCallStack => [a] -> a
last [Kind]
as)
SBVType
_ -> [Char] -> ([Kind], Kind)
forall a. HasCallStack => [Char] -> a
error ([Char] -> ([Kind], Kind)) -> [Char] -> ([Kind], Kind)
forall a b. (a -> b) -> a -> b
$ [Char]
"Data.SBV.getUIFunCVAssoc: Expected a function type, got: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SBVType -> [Char]
forall a. Show a => a -> [Char]
show SBVType
typ
let convert :: ([([SExpr], SExpr)], SExpr) -> Maybe ([([CV], CV)], CV)
convert ([([SExpr], SExpr)]
vs, SExpr
d) = (,) ([([CV], CV)] -> CV -> ([([CV], CV)], CV))
-> Maybe [([CV], CV)] -> Maybe (CV -> ([([CV], CV)], CV))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (([SExpr], SExpr) -> Maybe ([CV], CV))
-> [([SExpr], SExpr)] -> Maybe [([CV], CV)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([SExpr], SExpr) -> Maybe ([CV], CV)
toPoint [([SExpr], SExpr)]
vs Maybe (CV -> ([([CV], CV)], CV))
-> Maybe CV -> Maybe ([([CV], CV)], CV)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe CV
toRes SExpr
d
toPoint :: ([SExpr], SExpr) -> Maybe ([CV], CV)
toPoint ([SExpr]
as, SExpr
v)
| [SExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SExpr]
as Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Kind] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Kind]
ats = (,) ([CV] -> CV -> ([CV], CV))
-> Maybe [CV] -> Maybe (CV -> ([CV], CV))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Kind -> SExpr -> Maybe CV) -> [Kind] -> [SExpr] -> Maybe [CV]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Kind -> SExpr -> Maybe CV
recoverKindedValue [Kind]
ats [SExpr]
as Maybe (CV -> ([CV], CV)) -> Maybe CV -> Maybe ([CV], CV)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr -> Maybe CV
toRes SExpr
v
| Bool
True = [Char] -> Maybe ([CV], CV)
forall a. HasCallStack => [Char] -> a
error ([Char] -> Maybe ([CV], CV)) -> [Char] -> Maybe ([CV], CV)
forall a b. (a -> b) -> a -> b
$ [Char]
"Data.SBV.getUIFunCVAssoc: Mismatching type/value arity, got: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ([SExpr], [Kind]) -> [Char]
forall a. Show a => a -> [Char]
show ([SExpr]
as, [Kind]
ats)
toRes :: SExpr -> Maybe CV
toRes :: SExpr -> Maybe CV
toRes = Kind -> SExpr -> Maybe CV
recoverKindedValue Kind
rt
fallBack :: [Char]
fallBack = [Char] -> [Char] -> Bool -> Maybe [[Char]] -> [Char]
trimFunctionResponse [Char]
r [Char]
nm Bool
isCurried Maybe [[Char]]
mbArgs
tryPointWise :: m (Either [Char] ([([CV], CV)], CV))
tryPointWise = do Maybe ([([SExpr], SExpr)], SExpr)
mbSExprs <- [Char] -> SBVType -> m (Maybe ([([SExpr], SExpr)], SExpr))
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
[Char] -> SBVType -> m (Maybe ([([SExpr], SExpr)], SExpr))
pointWiseExtract [Char]
nm SBVType
typ
case Maybe ([([SExpr], SExpr)], SExpr)
mbSExprs of
Maybe ([([SExpr], SExpr)], SExpr)
Nothing -> Either [Char] ([([CV], CV)], CV)
-> m (Either [Char] ([([CV], CV)], CV))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [Char] ([([CV], CV)], CV)
-> m (Either [Char] ([([CV], CV)], CV)))
-> Either [Char] ([([CV], CV)], CV)
-> m (Either [Char] ([([CV], CV)], CV))
forall a b. (a -> b) -> a -> b
$ [Char] -> Either [Char] ([([CV], CV)], CV)
forall a b. a -> Either a b
Left [Char]
fallBack
Just ([([SExpr], SExpr)], SExpr)
sExprs -> Either [Char] ([([CV], CV)], CV)
-> m (Either [Char] ([([CV], CV)], CV))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [Char] ([([CV], CV)], CV)
-> m (Either [Char] ([([CV], CV)], CV)))
-> Either [Char] ([([CV], CV)], CV)
-> m (Either [Char] ([([CV], CV)], CV))
forall a b. (a -> b) -> a -> b
$ Either [Char] ([([CV], CV)], CV)
-> (([([CV], CV)], CV) -> Either [Char] ([([CV], CV)], CV))
-> Maybe ([([CV], CV)], CV)
-> Either [Char] ([([CV], CV)], CV)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> Either [Char] ([([CV], CV)], CV)
forall a b. a -> Either a b
Left [Char]
fallBack) ([([CV], CV)], CV) -> Either [Char] ([([CV], CV)], CV)
forall a b. b -> Either a b
Right (([([SExpr], SExpr)], SExpr) -> Maybe ([([CV], CV)], CV)
convert ([([SExpr], SExpr)], SExpr)
sExprs)
[Char]
-> ([Char]
-> Maybe [[Char]] -> m (Either [Char] ([([CV], CV)], CV)))
-> (SExpr -> m (Either [Char] ([([CV], CV)], CV)))
-> m (Either [Char] ([([CV], CV)], CV))
forall a.
[Char] -> ([Char] -> Maybe [[Char]] -> a) -> (SExpr -> a) -> a
parse [Char]
r [Char] -> Maybe [[Char]] -> m (Either [Char] ([([CV], CV)], CV))
bad ((SExpr -> m (Either [Char] ([([CV], CV)], CV)))
-> m (Either [Char] ([([CV], CV)], CV)))
-> (SExpr -> m (Either [Char] ([([CV], CV)], CV)))
-> m (Either [Char] ([([CV], CV)], CV))
forall a b. (a -> b) -> a -> b
$ \case EApp [EApp [ECon [Char]
o, SExpr
e]] | [Char]
o [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
nm -> case SExpr -> Maybe (Either [Char] ([([SExpr], SExpr)], SExpr))
parseSExprFunction SExpr
e of
Just (Right ([([SExpr], SExpr)], SExpr)
assocs) | Just ([([CV], CV)], CV)
res <- ([([SExpr], SExpr)], SExpr) -> Maybe ([([CV], CV)], CV)
convert ([([SExpr], SExpr)], SExpr)
assocs -> Either [Char] ([([CV], CV)], CV)
-> m (Either [Char] ([([CV], CV)], CV))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (([([CV], CV)], CV) -> Either [Char] ([([CV], CV)], CV)
forall a b. b -> Either a b
Right ([([CV], CV)], CV)
res)
| Bool
True -> m (Either [Char] ([([CV], CV)], CV))
tryPointWise
Just (Left [Char]
nm') | [Char]
nm [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
nm', let res :: CV
res = Kind -> CV
defaultKindedValue Kind
rt -> Either [Char] ([([CV], CV)], CV)
-> m (Either [Char] ([([CV], CV)], CV))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (([([CV], CV)], CV) -> Either [Char] ([([CV], CV)], CV)
forall a b. b -> Either a b
Right ([], CV
res))
| Bool
True -> [Char] -> Maybe [[Char]] -> m (Either [Char] ([([CV], CV)], CV))
bad [Char]
r Maybe [[Char]]
forall a. Maybe a
Nothing
Maybe (Either [Char] ([([SExpr], SExpr)], SExpr))
Nothing -> m (Either [Char] ([([CV], CV)], CV))
tryPointWise
SExpr
_ -> [Char] -> Maybe [[Char]] -> m (Either [Char] ([([CV], CV)], CV))
bad [Char]
r Maybe [[Char]]
forall a. Maybe a
Nothing
checkSat :: (MonadIO m, MonadQuery m) => m CheckSatResult
checkSat :: forall (m :: * -> *). (MonadIO m, MonadQuery m) => m CheckSatResult
checkSat = do SMTConfig
cfg <- m SMTConfig
forall (m :: * -> *). (MonadIO m, MonadQuery m) => m SMTConfig
getConfig
[Char] -> m CheckSatResult
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
[Char] -> m CheckSatResult
checkSatUsing ([Char] -> m CheckSatResult) -> [Char] -> m CheckSatResult
forall a b. (a -> b) -> a -> b
$ SMTConfig -> [Char]
satCmd SMTConfig
cfg
checkSatUsing :: (MonadIO m, MonadQuery m) => String -> m CheckSatResult
checkSatUsing :: forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
[Char] -> m CheckSatResult
checkSatUsing [Char]
cmd = do let bad :: [Char] -> Maybe [[Char]] -> m CheckSatResult
bad = [Char]
-> [Char]
-> [Char]
-> Maybe [[Char]]
-> [Char]
-> Maybe [[Char]]
-> m CheckSatResult
forall (m :: * -> *) a.
(MonadIO m, MonadQuery m) =>
[Char]
-> [Char]
-> [Char]
-> Maybe [[Char]]
-> [Char]
-> Maybe [[Char]]
-> m a
unexpected [Char]
"checkSat" [Char]
cmd [Char]
"one of sat/unsat/unknown" Maybe [[Char]]
forall a. Maybe a
Nothing
ignoreList :: [[Char]]
ignoreList = [[Char]
"WARNING: optimization with quantified constraints is not supported"]
[Char]
r <- [Char] -> [[Char]] -> m [Char]
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
[Char] -> [[Char]] -> m [Char]
askIgnoring [Char]
cmd [[Char]]
ignoreList
let getPrecision :: m (Maybe [Char])
getPrecision = do SMTConfig
cfg <- m SMTConfig
forall (m :: * -> *). (MonadIO m, MonadQuery m) => m SMTConfig
getConfig
case SolverCapabilities -> Maybe [Char]
supportsDeltaSat (SMTSolver -> SolverCapabilities
capabilities (SMTConfig -> SMTSolver
solver SMTConfig
cfg)) of
Maybe [Char]
Nothing -> Maybe [Char] -> m (Maybe [Char])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [Char]
forall a. Maybe a
Nothing
Just [Char]
o -> [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> m [Char] -> m (Maybe [Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> m [Char]
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
[Char] -> m [Char]
ask [Char]
o
[Char]
-> ([Char] -> Maybe [[Char]] -> m CheckSatResult)
-> (SExpr -> m CheckSatResult)
-> m CheckSatResult
forall a.
[Char] -> ([Char] -> Maybe [[Char]] -> a) -> (SExpr -> a) -> a
parse [Char]
r [Char] -> Maybe [[Char]] -> m CheckSatResult
bad ((SExpr -> m CheckSatResult) -> m CheckSatResult)
-> (SExpr -> m CheckSatResult) -> m CheckSatResult
forall a b. (a -> b) -> a -> b
$ \case ECon [Char]
"sat" -> CheckSatResult -> m CheckSatResult
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return CheckSatResult
Sat
ECon [Char]
"unsat" -> CheckSatResult -> m CheckSatResult
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return CheckSatResult
Unsat
ECon [Char]
"unknown" -> CheckSatResult -> m CheckSatResult
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return CheckSatResult
Unk
ECon [Char]
"delta-sat" -> Maybe [Char] -> CheckSatResult
DSat (Maybe [Char] -> CheckSatResult)
-> m (Maybe [Char]) -> m CheckSatResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Maybe [Char])
getPrecision
SExpr
_ -> [Char] -> Maybe [[Char]] -> m CheckSatResult
bad [Char]
r Maybe [[Char]]
forall a. Maybe a
Nothing
getTopLevelInputs :: (MonadIO m, MonadQuery m) => m UserInputs
getTopLevelInputs :: forall (m :: * -> *). (MonadIO m, MonadQuery m) => m UserInputs
getTopLevelInputs = do State{IORef Inputs
rinps :: IORef Inputs
rinps :: State -> IORef Inputs
rinps} <- m State
forall (m :: * -> *). MonadQuery m => m State
queryState
Inputs{UserInputs
userInputs :: UserInputs
userInputs :: Inputs -> UserInputs
userInputs, UserInputs
internInputs :: UserInputs
internInputs :: Inputs -> UserInputs
internInputs} <- IO Inputs -> m Inputs
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Inputs -> m Inputs) -> IO Inputs -> m Inputs
forall a b. (a -> b) -> a -> b
$ IORef Inputs -> IO Inputs
forall a. IORef a -> IO a
readIORef IORef Inputs
rinps
UserInputs -> m UserInputs
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UserInputs -> m UserInputs) -> UserInputs -> m UserInputs
forall a b. (a -> b) -> a -> b
$ UserInputs
userInputs UserInputs -> UserInputs -> UserInputs
forall a. Semigroup a => a -> a -> a
<> UserInputs
internInputs
getObservables :: (MonadIO m, MonadQuery m) => m [(Name, CV)]
getObservables :: forall (m :: * -> *). (MonadIO m, MonadQuery m) => m [(Text, CV)]
getObservables = do State{IORef (Seq (Text, CV -> Bool, SV))
rObservables :: IORef (Seq (Text, CV -> Bool, SV))
rObservables :: State -> IORef (Seq (Text, CV -> Bool, SV))
rObservables} <- m State
forall (m :: * -> *). MonadQuery m => m State
queryState
Seq (Text, CV -> Bool, SV)
rObs <- IO (Seq (Text, CV -> Bool, SV)) -> m (Seq (Text, CV -> Bool, SV))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Seq (Text, CV -> Bool, SV)) -> m (Seq (Text, CV -> Bool, SV)))
-> IO (Seq (Text, CV -> Bool, SV))
-> m (Seq (Text, CV -> Bool, SV))
forall a b. (a -> b) -> a -> b
$ IORef (Seq (Text, CV -> Bool, SV))
-> IO (Seq (Text, CV -> Bool, SV))
forall a. IORef a -> IO a
readIORef IORef (Seq (Text, CV -> Bool, SV))
rObservables
let walk :: [(a, CV -> Bool, SV)] -> [(a, CV)] -> m [(a, CV)]
walk [] ![(a, CV)]
sofar = [(a, CV)] -> m [(a, CV)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [(a, CV)]
sofar
walk ((a
n, CV -> Bool
f, SV
s):[(a, CV -> Bool, SV)]
os) ![(a, CV)]
sofar = do CV
cv <- Maybe Int -> SV -> m CV
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Maybe Int -> SV -> m CV
getValueCV Maybe Int
forall a. Maybe a
Nothing SV
s
if CV -> Bool
f CV
cv
then [(a, CV -> Bool, SV)] -> [(a, CV)] -> m [(a, CV)]
walk [(a, CV -> Bool, SV)]
os ((a
n, CV
cv) (a, CV) -> [(a, CV)] -> [(a, CV)]
forall a. a -> [a] -> [a]
: [(a, CV)]
sofar)
else [(a, CV -> Bool, SV)] -> [(a, CV)] -> m [(a, CV)]
walk [(a, CV -> Bool, SV)]
os [(a, CV)]
sofar
[(Text, CV -> Bool, SV)] -> [(Text, CV)] -> m [(Text, CV)]
forall {m :: * -> *} {a}.
(MonadIO m, MonadQuery m) =>
[(a, CV -> Bool, SV)] -> [(a, CV)] -> m [(a, CV)]
walk (Seq (Text, CV -> Bool, SV) -> [(Text, CV -> Bool, SV)]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Seq (Text, CV -> Bool, SV)
rObs) []
getUIs :: forall m. (MonadIO m, MonadQuery m) => m [(String, (Bool, Maybe [String], SBVType))]
getUIs :: forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
m [([Char], (Bool, Maybe [[Char]], SBVType))]
getUIs = do State{IORef (Map [Char] (Bool, Maybe [[Char]], SBVType))
rUIMap :: State -> IORef (Map [Char] (Bool, Maybe [[Char]], SBVType))
rUIMap :: IORef (Map [Char] (Bool, Maybe [[Char]], SBVType))
rUIMap, IORef [(SMTDef, SBVType)]
rDefns :: IORef [(SMTDef, SBVType)]
rDefns :: State -> IORef [(SMTDef, SBVType)]
rDefns, IORef IncState
rIncState :: IORef IncState
rIncState :: State -> IORef IncState
rIncState} <- m State
forall (m :: * -> *). MonadQuery m => m State
queryState
[[Char]]
defines <- do [(SMTDef, SBVType)]
allDefs <- IO [(SMTDef, SBVType)] -> m [(SMTDef, SBVType)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO [(SMTDef, SBVType)] -> m [(SMTDef, SBVType)])
-> IO [(SMTDef, SBVType)] -> m [(SMTDef, SBVType)]
forall a b. (a -> b) -> a -> b
$ IORef [(SMTDef, SBVType)] -> IO [(SMTDef, SBVType)]
forall a. IORef a -> IO a
readIORef IORef [(SMTDef, SBVType)]
rDefns
[[Char]] -> m [[Char]]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Char]] -> m [[Char]]) -> [[Char]] -> m [[Char]]
forall a b. (a -> b) -> a -> b
$ ((SMTDef, SBVType) -> Maybe [Char])
-> [(SMTDef, SBVType)] -> [[Char]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (SMTDef -> Maybe [Char]
smtDefGivenName (SMTDef -> Maybe [Char])
-> ((SMTDef, SBVType) -> SMTDef)
-> (SMTDef, SBVType)
-> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SMTDef, SBVType) -> SMTDef
forall a b. (a, b) -> a
fst) [(SMTDef, SBVType)]
allDefs
Map [Char] (Bool, Maybe [[Char]], SBVType)
prior <- IO (Map [Char] (Bool, Maybe [[Char]], SBVType))
-> m (Map [Char] (Bool, Maybe [[Char]], SBVType))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Map [Char] (Bool, Maybe [[Char]], SBVType))
-> m (Map [Char] (Bool, Maybe [[Char]], SBVType)))
-> IO (Map [Char] (Bool, Maybe [[Char]], SBVType))
-> m (Map [Char] (Bool, Maybe [[Char]], SBVType))
forall a b. (a -> b) -> a -> b
$ IORef (Map [Char] (Bool, Maybe [[Char]], SBVType))
-> IO (Map [Char] (Bool, Maybe [[Char]], SBVType))
forall a. IORef a -> IO a
readIORef IORef (Map [Char] (Bool, Maybe [[Char]], SBVType))
rUIMap
Map [Char] (Bool, Maybe [[Char]], SBVType)
new <- IO (Map [Char] (Bool, Maybe [[Char]], SBVType))
-> m (Map [Char] (Bool, Maybe [[Char]], SBVType))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Map [Char] (Bool, Maybe [[Char]], SBVType))
-> m (Map [Char] (Bool, Maybe [[Char]], SBVType)))
-> IO (Map [Char] (Bool, Maybe [[Char]], SBVType))
-> m (Map [Char] (Bool, Maybe [[Char]], SBVType))
forall a b. (a -> b) -> a -> b
$ IORef IncState -> IO IncState
forall a. IORef a -> IO a
readIORef IORef IncState
rIncState IO IncState
-> (IncState -> IO (Map [Char] (Bool, Maybe [[Char]], SBVType)))
-> IO (Map [Char] (Bool, Maybe [[Char]], SBVType))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IORef (Map [Char] (Bool, Maybe [[Char]], SBVType))
-> IO (Map [Char] (Bool, Maybe [[Char]], SBVType))
forall a. IORef a -> IO a
readIORef (IORef (Map [Char] (Bool, Maybe [[Char]], SBVType))
-> IO (Map [Char] (Bool, Maybe [[Char]], SBVType)))
-> (IncState -> IORef (Map [Char] (Bool, Maybe [[Char]], SBVType)))
-> IncState
-> IO (Map [Char] (Bool, Maybe [[Char]], SBVType))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IncState -> IORef (Map [Char] (Bool, Maybe [[Char]], SBVType))
rNewUIs
[([Char], (Bool, Maybe [[Char]], SBVType))]
-> m [([Char], (Bool, Maybe [[Char]], SBVType))]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([([Char], (Bool, Maybe [[Char]], SBVType))]
-> m [([Char], (Bool, Maybe [[Char]], SBVType))])
-> [([Char], (Bool, Maybe [[Char]], SBVType))]
-> m [([Char], (Bool, Maybe [[Char]], SBVType))]
forall a b. (a -> b) -> a -> b
$ [([Char], (Bool, Maybe [[Char]], SBVType))]
-> [([Char], (Bool, Maybe [[Char]], SBVType))]
forall a. Eq a => [a] -> [a]
nub ([([Char], (Bool, Maybe [[Char]], SBVType))]
-> [([Char], (Bool, Maybe [[Char]], SBVType))])
-> [([Char], (Bool, Maybe [[Char]], SBVType))]
-> [([Char], (Bool, Maybe [[Char]], SBVType))]
forall a b. (a -> b) -> a -> b
$ [([Char], (Bool, Maybe [[Char]], SBVType))]
-> [([Char], (Bool, Maybe [[Char]], SBVType))]
forall a. Ord a => [a] -> [a]
sort [([Char], (Bool, Maybe [[Char]], SBVType))
p | p :: ([Char], (Bool, Maybe [[Char]], SBVType))
p@([Char]
n, (Bool, Maybe [[Char]], SBVType)
_) <- Map [Char] (Bool, Maybe [[Char]], SBVType)
-> [([Char], (Bool, Maybe [[Char]], SBVType))]
forall k a. Map k a -> [(k, a)]
Map.toList Map [Char] (Bool, Maybe [[Char]], SBVType)
prior [([Char], (Bool, Maybe [[Char]], SBVType))]
-> [([Char], (Bool, Maybe [[Char]], SBVType))]
-> [([Char], (Bool, Maybe [[Char]], SBVType))]
forall a. [a] -> [a] -> [a]
++ Map [Char] (Bool, Maybe [[Char]], SBVType)
-> [([Char], (Bool, Maybe [[Char]], SBVType))]
forall k a. Map k a -> [(k, a)]
Map.toList Map [Char] (Bool, Maybe [[Char]], SBVType)
new, [Char]
n [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [[Char]]
defines]
getAllSatResult :: forall m. (MonadIO m, MonadQuery m, SolverContext m) => m AllSatResult
getAllSatResult :: forall (m :: * -> *).
(MonadIO m, MonadQuery m, SolverContext m) =>
m AllSatResult
getAllSatResult = do [[Char]] -> m ()
forall (m :: * -> *). (MonadIO m, MonadQuery m) => [[Char]] -> m ()
queryDebug [[Char]
"*** Checking Satisfiability, all solutions.."]
SMTConfig
cfg <- m SMTConfig
forall (m :: * -> *). (MonadIO m, MonadQuery m) => m SMTConfig
getConfig
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SolverCapabilities -> Bool
supportsCustomQueries (SMTSolver -> SolverCapabilities
capabilities (SMTConfig -> SMTSolver
solver SMTConfig
cfg))) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
[Char] -> m ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [ [Char]
""
, [Char]
"*** Data.SBV: Backend solver " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Solver -> [Char]
forall a. Show a => a -> [Char]
show (SMTSolver -> Solver
name (SMTConfig -> SMTSolver
solver SMTConfig
cfg)) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" does not support custom queries."
, [Char]
"***"
, [Char]
"*** Custom query support is needed for allSat functionality."
, [Char]
"*** Please use a solver that supports this feature."
]
topState :: State
topState@State{IORef KindSet
rUsedKinds :: IORef KindSet
rUsedKinds :: State -> IORef KindSet
rUsedKinds, IORef [[Char]]
rPartitionVars :: IORef [[Char]]
rPartitionVars :: State -> IORef [[Char]]
rPartitionVars, IORef ProgInfo
rProgInfo :: State -> IORef ProgInfo
rProgInfo :: IORef ProgInfo
rProgInfo} <- m State
forall (m :: * -> *). MonadQuery m => m State
queryState
ProgInfo
progInfo <- IO ProgInfo -> m ProgInfo
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProgInfo -> m ProgInfo) -> IO ProgInfo -> m ProgInfo
forall a b. (a -> b) -> a -> b
$ IORef ProgInfo -> IO ProgInfo
forall a. IORef a -> IO a
readIORef IORef ProgInfo
rProgInfo
KindSet
ki <- IO KindSet -> m KindSet
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO KindSet -> m KindSet) -> IO KindSet -> m KindSet
forall a b. (a -> b) -> a -> b
$ IORef KindSet -> IO KindSet
forall a. IORef a -> IO a
readIORef IORef KindSet
rUsedKinds
UserInputs
allModelInputs <- m UserInputs
forall (m :: * -> *). (MonadIO m, MonadQuery m) => m UserInputs
getTopLevelInputs
[([Char], (Bool, Maybe [[Char]], SBVType))]
allUninterpreteds <- m [([Char], (Bool, Maybe [[Char]], SBVType))]
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
m [([Char], (Bool, Maybe [[Char]], SBVType))]
getUIs
[[Char]]
partitionVars <- IO [[Char]] -> m [[Char]]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [[Char]] -> m [[Char]]) -> IO [[Char]] -> m [[Char]]
forall a b. (a -> b) -> a -> b
$ IORef [[Char]] -> IO [[Char]]
forall a. IORef a -> IO a
readIORef IORef [[Char]]
rPartitionVars
let allUiFuns :: [([Char], (Bool, Maybe [[Char]], SBVType))]
allUiFuns = [([Char], (Bool, Maybe [[Char]], SBVType))
u | SMTConfig -> Bool
allSatTrackUFs SMTConfig
cfg
, u :: ([Char], (Bool, Maybe [[Char]], SBVType))
u@([Char]
nm, (Bool
_, Maybe [[Char]]
_, SBVType [Kind]
as)) <- [([Char], (Bool, Maybe [[Char]], SBVType))]
allUninterpreteds, [Kind] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Kind]
as Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
, Bool -> Bool
not (SMTConfig -> [Char] -> Bool
mustIgnoreVar SMTConfig
cfg [Char]
nm)
]
allUiRegs :: [([Char], (Bool, Maybe [[Char]], SBVType))]
allUiRegs = [([Char], (Bool, Maybe [[Char]], SBVType))
u | u :: ([Char], (Bool, Maybe [[Char]], SBVType))
u@([Char]
nm, (Bool
_, Maybe [[Char]]
_, SBVType [Kind]
as)) <- [([Char], (Bool, Maybe [[Char]], SBVType))]
allUninterpreteds, [Kind] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Kind]
as Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
, Bool -> Bool
not (SMTConfig -> [Char] -> Bool
mustIgnoreVar SMTConfig
cfg [Char]
nm)
]
collectAcceptable :: [([Char], (a, b, SBVType))] -> [[Char]] -> m [[Char]]
collectAcceptable [] [[Char]]
sofar = [[Char]] -> m [[Char]]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [[Char]]
sofar
collectAcceptable (([Char]
nm, (a
_, b
_, t :: SBVType
t@(SBVType [Kind]
ats))):[([Char], (a, b, SBVType))]
rest) [[Char]]
sofar
| Bool -> Bool
not ((Kind -> Bool) -> [Kind] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Kind -> Bool
hasUninterpretedSorts [Kind]
ats)
= [([Char], (a, b, SBVType))] -> [[Char]] -> m [[Char]]
collectAcceptable [([Char], (a, b, SBVType))]
rest ([Char]
nm [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
sofar)
| Bool
True
= do [[Char]] -> m ()
forall (m :: * -> *). (MonadIO m, MonadQuery m) => [[Char]] -> m ()
queryDebug [ [Char]
"*** SBV.allSat: Uninterpreted function: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
nm [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" :: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SBVType -> [Char]
forall a. Show a => a -> [Char]
show SBVType
t
, [Char]
"*** Will *not* be used in allSat considerations since its type"
, [Char]
"*** has uninterpreted sorts present."
]
[([Char], (a, b, SBVType))] -> [[Char]] -> m [[Char]]
collectAcceptable [([Char], (a, b, SBVType))]
rest [[Char]]
sofar
[[Char]]
uiFuns <- [[Char]] -> [[Char]]
forall a. [a] -> [a]
reverse ([[Char]] -> [[Char]]) -> m [[Char]] -> m [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [([Char], (Bool, Maybe [[Char]], SBVType))]
-> [[Char]] -> m [[Char]]
forall {m :: * -> *} {a} {b}.
(MonadIO m, MonadQuery m) =>
[([Char], (a, b, SBVType))] -> [[Char]] -> m [[Char]]
collectAcceptable [([Char], (Bool, Maybe [[Char]], SBVType))]
allUiFuns []
[[Char]]
_ <- [([Char], (Bool, Maybe [[Char]], SBVType))]
-> [[Char]] -> m [[Char]]
forall {m :: * -> *} {a} {b}.
(MonadIO m, MonadQuery m) =>
[([Char], (a, b, SBVType))] -> [[Char]] -> m [[Char]]
collectAcceptable [([Char], (Bool, Maybe [[Char]], SBVType))]
allUiRegs []
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
uiFuns) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
let solverCaps :: SolverCapabilities
solverCaps = SMTSolver -> SolverCapabilities
capabilities (SMTConfig -> SMTSolver
solver SMTConfig
cfg)
in case SolverCapabilities -> Maybe [[Char]]
supportsFlattenedModels SolverCapabilities
solverCaps of
Maybe [[Char]]
Nothing -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just [[Char]]
cmds -> ([Char] -> m ()) -> [[Char]] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool -> [Char] -> m ()
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Bool -> [Char] -> m ()
send Bool
True) [[Char]]
cmds
let usorts :: [[Char]]
usorts = [[Char]
s | us :: Kind
us@(KUserSort [Char]
s Maybe [[Char]]
_) <- KindSet -> [Kind]
forall a. Set a -> [a]
Set.toAscList KindSet
ki, Kind -> Bool
isFree Kind
us]
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
usorts) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> m ()
forall (m :: * -> *). (MonadIO m, MonadQuery m) => [[Char]] -> m ()
queryDebug [ [Char]
"*** SBV.allSat: Uninterpreted sorts present: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords [[Char]]
usorts
, [Char]
"*** SBV will use equivalence classes to generate all-satisfying instances."
]
let mkSVal :: NamedSymVar -> (SVal, NamedSymVar)
mkSVal nm :: NamedSymVar
nm@(NamedSymVar -> SV
getSV -> SV
sv) = (Kind -> Either CV (Cached SV) -> SVal
SVal (SV -> Kind
forall a. HasKind a => a -> Kind
kindOf SV
sv) (Cached SV -> Either CV (Cached SV)
forall a b. b -> Either a b
Right ((State -> IO SV) -> Cached SV
forall a. (State -> IO a) -> Cached a
cache (IO SV -> State -> IO SV
forall a b. a -> b -> a
const (SV -> IO SV
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SV
sv)))), NamedSymVar
nm)
let extractVars :: S.Seq (SVal, NamedSymVar)
extractVars :: Seq (SVal, NamedSymVar)
extractVars = NamedSymVar -> (SVal, NamedSymVar)
mkSVal (NamedSymVar -> (SVal, NamedSymVar))
-> UserInputs -> Seq (SVal, NamedSymVar)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NamedSymVar -> Bool) -> UserInputs -> UserInputs
forall a. (a -> Bool) -> Seq a -> Seq a
S.filter (Bool -> Bool
not (Bool -> Bool) -> (NamedSymVar -> Bool) -> NamedSymVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMTConfig -> [Char] -> Bool
mustIgnoreVar SMTConfig
cfg ([Char] -> Bool) -> (NamedSymVar -> [Char]) -> NamedSymVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedSymVar -> [Char]
getUserName') UserInputs
allModelInputs
vars :: S.Seq (SVal, NamedSymVar)
vars :: Seq (SVal, NamedSymVar)
vars = case [[Char]]
partitionVars of
[] -> Seq (SVal, NamedSymVar)
extractVars
[[Char]]
pv -> NamedSymVar -> (SVal, NamedSymVar)
mkSVal (NamedSymVar -> (SVal, NamedSymVar))
-> UserInputs -> Seq (SVal, NamedSymVar)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NamedSymVar -> Bool) -> UserInputs -> UserInputs
forall a. (a -> Bool) -> Seq a -> Seq a
S.filter (\NamedSymVar
k -> NamedSymVar -> [Char]
getUserName' NamedSymVar
k [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
pv) UserInputs
allModelInputs
let isSimple :: Bool
isSimple = [([Char], (Bool, Maybe [[Char]], SBVType))] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [([Char], (Bool, Maybe [[Char]], SBVType))]
allUiFuns Bool -> Bool -> Bool
&& [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
usorts Bool -> Bool -> Bool
&& Bool -> Bool
not (ProgInfo -> Bool
hasQuants ProgInfo
progInfo)
start :: AllSatResult
start = AllSatResult { allSatMaxModelCountReached :: Bool
allSatMaxModelCountReached = Bool
False
, allSatSolverReturnedUnknown :: Bool
allSatSolverReturnedUnknown = Bool
False
, allSatSolverReturnedDSat :: Bool
allSatSolverReturnedDSat = Bool
False
, allSatResults :: [SMTResult]
allSatResults = []
}
case [[Char]]
partitionVars of
[] -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
[[Char]]
xs -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isSimple (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> m ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [ [Char]
""
, [Char]
"Data.SBV: Unsupported complex allSat call in the presence of partition-variables"
, [Char]
""
, [Char]
"Partition variables are only supported when there are no uninterpreted"
, [Char]
"functions or uninterpreted sorts."
, [Char]
""
, [Char]
"Saw parition vars: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords [[Char]]
xs
]
if Bool
isSimple
then do let mkVar :: (String, (Bool, Maybe [String], SBVType)) -> IO (SVal, NamedSymVar)
mkVar :: ([Char], (Bool, Maybe [[Char]], SBVType)) -> IO (SVal, NamedSymVar)
mkVar ([Char]
nm, (Bool
_, Maybe [[Char]]
_, SBVType [Kind
k])) = do SV
sv <- State -> Kind -> SBVExpr -> IO SV
newExpr State
topState Kind
k (Op -> [SV] -> SBVExpr
SBVApp ([Char] -> Op
Uninterpreted [Char]
nm) [])
let sval :: SVal
sval = Kind -> Either CV (Cached SV) -> SVal
SVal Kind
k (Either CV (Cached SV) -> SVal) -> Either CV (Cached SV) -> SVal
forall a b. (a -> b) -> a -> b
$ Cached SV -> Either CV (Cached SV)
forall a b. b -> Either a b
Right (Cached SV -> Either CV (Cached SV))
-> Cached SV -> Either CV (Cached SV)
forall a b. (a -> b) -> a -> b
$ (State -> IO SV) -> Cached SV
forall a. (State -> IO a) -> Cached a
cache ((State -> IO SV) -> Cached SV) -> (State -> IO SV) -> Cached SV
forall a b. (a -> b) -> a -> b
$ \State
_ -> SV -> IO SV
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SV
sv
nsv :: NamedSymVar
nsv = SV -> Text -> NamedSymVar
NamedSymVar SV
sv ([Char] -> Text
T.pack [Char]
nm)
(SVal, NamedSymVar) -> IO (SVal, NamedSymVar)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SVal
sval, NamedSymVar
nsv)
mkVar ([Char], (Bool, Maybe [[Char]], SBVType))
nmt = [Char] -> IO (SVal, NamedSymVar)
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO (SVal, NamedSymVar))
-> [Char] -> IO (SVal, NamedSymVar)
forall a b. (a -> b) -> a -> b
$ [Char]
"Data.SBV: Impossible happened; allSat.mkVar. Unexpected: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ([Char], (Bool, Maybe [[Char]], SBVType)) -> [Char]
forall a. Show a => a -> [Char]
show ([Char], (Bool, Maybe [[Char]], SBVType))
nmt
Seq (SVal, NamedSymVar)
uiVars <- IO (Seq (SVal, NamedSymVar)) -> m (Seq (SVal, NamedSymVar))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Seq (SVal, NamedSymVar)) -> m (Seq (SVal, NamedSymVar)))
-> IO (Seq (SVal, NamedSymVar)) -> m (Seq (SVal, NamedSymVar))
forall a b. (a -> b) -> a -> b
$ [(SVal, NamedSymVar)] -> Seq (SVal, NamedSymVar)
forall a. [a] -> Seq a
S.fromList ([(SVal, NamedSymVar)] -> Seq (SVal, NamedSymVar))
-> IO [(SVal, NamedSymVar)] -> IO (Seq (SVal, NamedSymVar))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (([Char], (Bool, Maybe [[Char]], SBVType))
-> IO (SVal, NamedSymVar))
-> [([Char], (Bool, Maybe [[Char]], SBVType))]
-> IO [(SVal, NamedSymVar)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([Char], (Bool, Maybe [[Char]], SBVType)) -> IO (SVal, NamedSymVar)
mkVar [([Char], (Bool, Maybe [[Char]], SBVType))]
allUiRegs
UserInputs
-> Seq (SVal, NamedSymVar)
-> Seq (SVal, NamedSymVar)
-> SMTConfig
-> AllSatResult
-> m AllSatResult
fastAllSat UserInputs
allModelInputs (Seq (SVal, NamedSymVar)
uiVars Seq (SVal, NamedSymVar)
-> Seq (SVal, NamedSymVar) -> Seq (SVal, NamedSymVar)
forall a. Seq a -> Seq a -> Seq a
S.>< Seq (SVal, NamedSymVar)
extractVars) (Seq (SVal, NamedSymVar)
uiVars Seq (SVal, NamedSymVar)
-> Seq (SVal, NamedSymVar) -> Seq (SVal, NamedSymVar)
forall a. Seq a -> Seq a -> Seq a
S.>< Seq (SVal, NamedSymVar)
vars) SMTConfig
cfg AllSatResult
start
else State
-> ([([Char], (Bool, Maybe [[Char]], SBVType))], [[Char]])
-> [([Char], (Bool, Maybe [[Char]], SBVType))]
-> UserInputs
-> Seq (SVal, NamedSymVar)
-> SMTConfig
-> AllSatResult
-> m AllSatResult
loop State
topState ([([Char], (Bool, Maybe [[Char]], SBVType))]
allUiFuns, [[Char]]
uiFuns) [([Char], (Bool, Maybe [[Char]], SBVType))]
allUiRegs UserInputs
allModelInputs Seq (SVal, NamedSymVar)
vars SMTConfig
cfg AllSatResult
start
where isFree :: Kind -> Bool
isFree (KUserSort [Char]
_ Maybe [[Char]]
Nothing) = Bool
True
isFree Kind
_ = Bool
False
finalize :: a -> SMTConfig -> AllSatResult -> Maybe [Char] -> f ()
finalize a
cnt SMTConfig
cfg AllSatResult
sofar Maybe [Char]
extra
= Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SMTConfig -> Bool
allSatPrintAlong SMTConfig
cfg Bool -> Bool -> Bool
&& Bool -> Bool
not ([SMTResult] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (AllSatResult -> [SMTResult]
allSatResults AllSatResult
sofar))) (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ do
let msg :: a -> [Char]
msg a
0 = [Char]
"No solutions found."
msg a
1 = [Char]
"This is the only solution."
msg a
n = [Char]
"Found " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" different solutions."
IO () -> f ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> f ()) -> ([Char] -> IO ()) -> [Char] -> f ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
putStrLn ([Char] -> f ()) -> [Char] -> f ()
forall a b. (a -> b) -> a -> b
$ a -> [Char]
forall {a}. (Eq a, Num a, Show a) => a -> [Char]
msg (a
cnt a -> a -> a
forall a. Num a => a -> a -> a
- a
1)
case Maybe [Char]
extra of
Maybe [Char]
Nothing -> () -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just [Char]
m -> IO () -> f ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> f ()) -> IO () -> f ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
m
fastAllSat :: S.Seq NamedSymVar -> S.Seq (SVal, NamedSymVar) -> S.Seq (SVal, NamedSymVar) -> SMTConfig -> AllSatResult -> m AllSatResult
fastAllSat :: UserInputs
-> Seq (SVal, NamedSymVar)
-> Seq (SVal, NamedSymVar)
-> SMTConfig
-> AllSatResult
-> m AllSatResult
fastAllSat UserInputs
allInputs Seq (SVal, NamedSymVar)
extractVars Seq (SVal, NamedSymVar)
vars SMTConfig
cfg AllSatResult
start = do
IORef (Int, AllSatResult, Bool, Maybe [Char])
result <- IO (IORef (Int, AllSatResult, Bool, Maybe [Char]))
-> m (IORef (Int, AllSatResult, Bool, Maybe [Char]))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (IORef (Int, AllSatResult, Bool, Maybe [Char]))
-> m (IORef (Int, AllSatResult, Bool, Maybe [Char])))
-> IO (IORef (Int, AllSatResult, Bool, Maybe [Char]))
-> m (IORef (Int, AllSatResult, Bool, Maybe [Char]))
forall a b. (a -> b) -> a -> b
$ (Int, AllSatResult, Bool, Maybe [Char])
-> IO (IORef (Int, AllSatResult, Bool, Maybe [Char]))
forall a. a -> IO (IORef a)
newIORef (Int
0, AllSatResult
start, Bool
False, Maybe [Char]
forall a. Maybe a
Nothing)
IORef (Int, AllSatResult, Bool, Maybe [Char])
-> Seq (SVal, NamedSymVar) -> m ()
go IORef (Int, AllSatResult, Bool, Maybe [Char])
result Seq (SVal, NamedSymVar)
vars
(Int
found, AllSatResult
sofar, Bool
_, Maybe [Char]
extra) <- IO (Int, AllSatResult, Bool, Maybe [Char])
-> m (Int, AllSatResult, Bool, Maybe [Char])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Int, AllSatResult, Bool, Maybe [Char])
-> m (Int, AllSatResult, Bool, Maybe [Char]))
-> IO (Int, AllSatResult, Bool, Maybe [Char])
-> m (Int, AllSatResult, Bool, Maybe [Char])
forall a b. (a -> b) -> a -> b
$ IORef (Int, AllSatResult, Bool, Maybe [Char])
-> IO (Int, AllSatResult, Bool, Maybe [Char])
forall a. IORef a -> IO a
readIORef IORef (Int, AllSatResult, Bool, Maybe [Char])
result
Int -> SMTConfig -> AllSatResult -> Maybe [Char] -> m ()
forall {f :: * -> *} {a}.
(Eq a, Num a, Show a, MonadIO f) =>
a -> SMTConfig -> AllSatResult -> Maybe [Char] -> f ()
finalize (Int
foundInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) SMTConfig
cfg AllSatResult
sofar Maybe [Char]
extra
AllSatResult -> m AllSatResult
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AllSatResult
sofar
where haveEnough :: Int -> Bool
haveEnough Int
have = case SMTConfig -> Maybe Int
allSatMaxModelCount SMTConfig
cfg of
Just Int
maxModels -> Int
have Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxModels
Maybe Int
_ -> Bool
False
go :: IORef (Int, AllSatResult, Bool, Maybe String) -> S.Seq (SVal, NamedSymVar) -> m ()
go :: IORef (Int, AllSatResult, Bool, Maybe [Char])
-> Seq (SVal, NamedSymVar) -> m ()
go IORef (Int, AllSatResult, Bool, Maybe [Char])
finalResult = Bool -> Seq (SVal, NamedSymVar) -> m ()
walk Bool
True
where shouldContinue :: m Bool
shouldContinue = do (Int
have, AllSatResult
_, Bool
exitLoop, Maybe [Char]
_) <- IO (Int, AllSatResult, Bool, Maybe [Char])
-> m (Int, AllSatResult, Bool, Maybe [Char])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Int, AllSatResult, Bool, Maybe [Char])
-> m (Int, AllSatResult, Bool, Maybe [Char]))
-> IO (Int, AllSatResult, Bool, Maybe [Char])
-> m (Int, AllSatResult, Bool, Maybe [Char])
forall a b. (a -> b) -> a -> b
$ IORef (Int, AllSatResult, Bool, Maybe [Char])
-> IO (Int, AllSatResult, Bool, Maybe [Char])
forall a. IORef a -> IO a
readIORef IORef (Int, AllSatResult, Bool, Maybe [Char])
finalResult
Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool
exitLoop Bool -> Bool -> Bool
|| Int -> Bool
haveEnough Int
have)
walk :: Bool -> S.Seq (SVal, NamedSymVar) -> m ()
walk :: Bool -> Seq (SVal, NamedSymVar) -> m ()
walk Bool
firstRun Seq (SVal, NamedSymVar)
terms
| Bool -> Bool
not Bool
firstRun Bool -> Bool -> Bool
&& Seq (SVal, NamedSymVar) -> Bool
forall a. Seq a -> Bool
S.null Seq (SVal, NamedSymVar)
terms
= () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
| Bool
True
= do Maybe Int
mbCont <- do (Int
have, AllSatResult
sofar, Bool
exitLoop, Maybe [Char]
_) <- IO (Int, AllSatResult, Bool, Maybe [Char])
-> m (Int, AllSatResult, Bool, Maybe [Char])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Int, AllSatResult, Bool, Maybe [Char])
-> m (Int, AllSatResult, Bool, Maybe [Char]))
-> IO (Int, AllSatResult, Bool, Maybe [Char])
-> m (Int, AllSatResult, Bool, Maybe [Char])
forall a b. (a -> b) -> a -> b
$ IORef (Int, AllSatResult, Bool, Maybe [Char])
-> IO (Int, AllSatResult, Bool, Maybe [Char])
forall a. IORef a -> IO a
readIORef IORef (Int, AllSatResult, Bool, Maybe [Char])
finalResult
if Bool
exitLoop
then Maybe Int -> m (Maybe Int)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
forall a. Maybe a
Nothing
else case SMTConfig -> Maybe Int
allSatMaxModelCount SMTConfig
cfg of
Just Int
maxModels
| Int
have Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxModels -> do Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (AllSatResult -> Bool
allSatMaxModelCountReached AllSatResult
sofar) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
[[Char]] -> m ()
forall (m :: * -> *). (MonadIO m, MonadQuery m) => [[Char]] -> m ()
queryDebug [[Char]
"*** Maximum model count request of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
maxModels [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" reached, stopping the search."]
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SMTConfig -> Bool
allSatPrintAlong SMTConfig
cfg) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"Search stopped since model count request was reached."
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef (Int, AllSatResult, Bool, Maybe [Char])
-> ((Int, AllSatResult, Bool, Maybe [Char])
-> (Int, AllSatResult, Bool, Maybe [Char]))
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Int, AllSatResult, Bool, Maybe [Char])
finalResult (((Int, AllSatResult, Bool, Maybe [Char])
-> (Int, AllSatResult, Bool, Maybe [Char]))
-> IO ())
-> ((Int, AllSatResult, Bool, Maybe [Char])
-> (Int, AllSatResult, Bool, Maybe [Char]))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(Int
h, AllSatResult
s, Bool
_, Maybe [Char]
m) -> (Int
h, AllSatResult
s{ allSatMaxModelCountReached = True }, Bool
True, Maybe [Char]
m)
Maybe Int -> m (Maybe Int)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
forall a. Maybe a
Nothing
Maybe Int
_ -> Maybe Int -> m (Maybe Int)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Int -> m (Maybe Int)) -> Maybe Int -> m (Maybe Int)
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int
haveInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1
case Maybe Int
mbCont of
Maybe Int
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just Int
cnt -> do
[[Char]] -> m ()
forall (m :: * -> *). (MonadIO m, MonadQuery m) => [[Char]] -> m ()
queryDebug [[Char]
"Fast allSat, Looking for solution " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
cnt]
CheckSatResult
cs <- m CheckSatResult
forall (m :: * -> *). (MonadIO m, MonadQuery m) => m CheckSatResult
checkSat
case CheckSatResult
cs of
CheckSatResult
Unsat -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
CheckSatResult
Unk -> do let m :: [Char]
m = [Char]
"Solver returned unknown, terminating query."
[[Char]] -> m ()
forall (m :: * -> *). (MonadIO m, MonadQuery m) => [[Char]] -> m ()
queryDebug [[Char]
"*** " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
m]
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef (Int, AllSatResult, Bool, Maybe [Char])
-> ((Int, AllSatResult, Bool, Maybe [Char])
-> (Int, AllSatResult, Bool, Maybe [Char]))
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Int, AllSatResult, Bool, Maybe [Char])
finalResult (((Int, AllSatResult, Bool, Maybe [Char])
-> (Int, AllSatResult, Bool, Maybe [Char]))
-> IO ())
-> ((Int, AllSatResult, Bool, Maybe [Char])
-> (Int, AllSatResult, Bool, Maybe [Char]))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(Int
h, AllSatResult
s, Bool
_, Maybe [Char]
_) -> (Int
h, AllSatResult
s{allSatSolverReturnedUnknown = True}, Bool
True, [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char]
"[" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
m [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"]"))
DSat Maybe [Char]
_ -> do let m :: [Char]
m = [Char]
"Solver returned delta-sat, terminating query."
[[Char]] -> m ()
forall (m :: * -> *). (MonadIO m, MonadQuery m) => [[Char]] -> m ()
queryDebug [[Char]
"*** " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
m]
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef (Int, AllSatResult, Bool, Maybe [Char])
-> ((Int, AllSatResult, Bool, Maybe [Char])
-> (Int, AllSatResult, Bool, Maybe [Char]))
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Int, AllSatResult, Bool, Maybe [Char])
finalResult (((Int, AllSatResult, Bool, Maybe [Char])
-> (Int, AllSatResult, Bool, Maybe [Char]))
-> IO ())
-> ((Int, AllSatResult, Bool, Maybe [Char])
-> (Int, AllSatResult, Bool, Maybe [Char]))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(Int
h, AllSatResult
s, Bool
_, Maybe [Char]
_) -> (Int
h, AllSatResult
s{allSatSolverReturnedDSat = True}, Bool
True, [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char]
"[" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
m [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"]"))
CheckSatResult
Sat -> do Seq (SV, (Text, (SVal, CV)))
assocs <- ((SVal, NamedSymVar) -> m (SV, (Text, (SVal, CV))))
-> Seq (SVal, NamedSymVar) -> m (Seq (SV, (Text, (SVal, CV))))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Seq a -> m (Seq b)
mapM (\(SVal
sval, NamedSymVar SV
sv Text
n) -> do !CV
cv <- Maybe Int -> SV -> m CV
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Maybe Int -> SV -> m CV
getValueCV Maybe Int
forall a. Maybe a
Nothing SV
sv
(SV, (Text, (SVal, CV))) -> m (SV, (Text, (SVal, CV)))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SV
sv, (Text
n, (SVal
sval, CV
cv)))) Seq (SVal, NamedSymVar)
extractVars
Maybe (Seq (NamedSymVar, CV))
bindings <- let grab :: NamedSymVar -> m (NamedSymVar, CV)
grab i :: NamedSymVar
i@(NamedSymVar -> SV
getSV -> SV
sv) = case ((SV, (Text, (SVal, CV))) -> SV)
-> SV
-> Seq (SV, (Text, (SVal, CV)))
-> Maybe (SV, (Text, (SVal, CV)))
forall a. Eq a => (a -> SV) -> SV -> Seq a -> Maybe a
lookupInput (SV, (Text, (SVal, CV))) -> SV
forall a b. (a, b) -> a
fst SV
sv Seq (SV, (Text, (SVal, CV)))
assocs of
Just (SV
_, (Text
_, (SVal
_, CV
cv))) -> (NamedSymVar, CV) -> m (NamedSymVar, CV)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (NamedSymVar
i, CV
cv)
Maybe (SV, (Text, (SVal, CV)))
Nothing -> do !CV
cv <- Maybe Int -> SV -> m CV
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Maybe Int -> SV -> m CV
getValueCV Maybe Int
forall a. Maybe a
Nothing SV
sv
(NamedSymVar, CV) -> m (NamedSymVar, CV)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (NamedSymVar
i, CV
cv)
in if SMTConfig -> Bool
validationRequested SMTConfig
cfg
then Seq (NamedSymVar, CV) -> Maybe (Seq (NamedSymVar, CV))
forall a. a -> Maybe a
Just (Seq (NamedSymVar, CV) -> Maybe (Seq (NamedSymVar, CV)))
-> m (Seq (NamedSymVar, CV)) -> m (Maybe (Seq (NamedSymVar, CV)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NamedSymVar -> m (NamedSymVar, CV))
-> UserInputs -> m (Seq (NamedSymVar, CV))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Seq a -> m (Seq b)
mapM NamedSymVar -> m (NamedSymVar, CV)
grab UserInputs
allInputs
else Maybe (Seq (NamedSymVar, CV)) -> m (Maybe (Seq (NamedSymVar, CV)))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Seq (NamedSymVar, CV))
forall a. Maybe a
Nothing
[(Text, CV)]
obsvs <- m [(Text, CV)]
forall (m :: * -> *). (MonadIO m, MonadQuery m) => m [(Text, CV)]
getObservables
let lassocs :: [(SV, (Text, (SVal, CV)))]
lassocs = Seq (SV, (Text, (SVal, CV))) -> [(SV, (Text, (SVal, CV)))]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Seq (SV, (Text, (SVal, CV)))
assocs
model :: SMTModel
model = SMTModel { modelObjectives :: [([Char], GeneralizedCV)]
modelObjectives = []
, modelBindings :: Maybe [(NamedSymVar, CV)]
modelBindings = Seq (NamedSymVar, CV) -> [(NamedSymVar, CV)]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq (NamedSymVar, CV) -> [(NamedSymVar, CV)])
-> Maybe (Seq (NamedSymVar, CV)) -> Maybe [(NamedSymVar, CV)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Seq (NamedSymVar, CV))
bindings
, modelAssocs :: [([Char], CV)]
modelAssocs = ((Text -> [Char]) -> (Text, CV) -> ([Char], CV)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> [Char]
T.unpack ((Text, CV) -> ([Char], CV)) -> [(Text, CV)] -> [([Char], CV)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Text, CV) -> Text) -> [(Text, CV)] -> [(Text, CV)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Text, CV) -> Text
forall a b. (a, b) -> a
fst [(Text, CV)]
obsvs)
[([Char], CV)] -> [([Char], CV)] -> [([Char], CV)]
forall a. Semigroup a => a -> a -> a
<> [(Text -> [Char]
T.unpack Text
n, CV
cv) | (SV
_, (Text
n, (SVal
_, CV
cv))) <- [(SV, (Text, (SVal, CV)))]
lassocs]
, modelUIFuns :: [([Char], (Bool, SBVType, Either [Char] ([([CV], CV)], CV)))]
modelUIFuns = []
}
currentResult :: SMTResult
currentResult = SMTConfig -> SMTModel -> SMTResult
Satisfiable SMTConfig
cfg SMTModel
model
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef (Int, AllSatResult, Bool, Maybe [Char])
-> ((Int, AllSatResult, Bool, Maybe [Char])
-> (Int, AllSatResult, Bool, Maybe [Char]))
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Int, AllSatResult, Bool, Maybe [Char])
finalResult (((Int, AllSatResult, Bool, Maybe [Char])
-> (Int, AllSatResult, Bool, Maybe [Char]))
-> IO ())
-> ((Int, AllSatResult, Bool, Maybe [Char])
-> (Int, AllSatResult, Bool, Maybe [Char]))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(Int
h, AllSatResult
s, Bool
e, Maybe [Char]
m) -> let h' :: Int
h' = Int
hInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 in Int
h' Int
-> (Int, AllSatResult, Bool, Maybe [Char])
-> (Int, AllSatResult, Bool, Maybe [Char])
forall a b. a -> b -> b
`seq` (Int
h', AllSatResult
s{allSatResults = currentResult : allSatResults s}, Bool
e, Maybe [Char]
m)
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SMTConfig -> Bool
allSatPrintAlong SMTConfig
cfg) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Solution #" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
cnt [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
":"
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ SMTConfig -> SMTModel -> [Char]
showModel SMTConfig
cfg SMTModel
model
let findVal :: (SVal, NamedSymVar) -> (SVal, CV)
findVal :: (SVal, NamedSymVar) -> (SVal, CV)
findVal (SVal
_, NamedSymVar SV
sv Text
nm) = case Seq (SV, (Text, (SVal, CV))) -> [(SV, (Text, (SVal, CV)))]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (((SV, (Text, (SVal, CV))) -> Bool)
-> Seq (SV, (Text, (SVal, CV))) -> Seq (SV, (Text, (SVal, CV)))
forall a. (a -> Bool) -> Seq a -> Seq a
S.filter (\(SV
sv', (Text, (SVal, CV))
_) -> SV
sv SV -> SV -> Bool
forall a. Eq a => a -> a -> Bool
== SV
sv') Seq (SV, (Text, (SVal, CV)))
assocs) of
[(SV
_, (Text
_, (SVal, CV)
scv))] -> (SVal, CV)
scv
[(SV, (Text, (SVal, CV)))]
_ -> [Char] -> (SVal, CV)
forall a. HasCallStack => [Char] -> a
error ([Char] -> (SVal, CV)) -> [Char] -> (SVal, CV)
forall a b. (a -> b) -> a -> b
$ [Char]
"Data.SBV: Cannot uniquely determine " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show Text
nm [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" in " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Seq (SV, (Text, (SVal, CV))) -> [Char]
forall a. Show a => a -> [Char]
show Seq (SV, (Text, (SVal, CV)))
assocs
cstr :: Bool -> (SVal, CV) -> m ()
cstr :: Bool -> (SVal, CV) -> m ()
cstr Bool
shouldReject (SVal
sv, CV
cv) = SBool -> m ()
forall a. QuantifiedBool a => a -> m ()
forall (m :: * -> *) a.
(SolverContext m, QuantifiedBool a) =>
a -> m ()
constrain (SVal -> SBool
forall a. SVal -> SBV a
SBV (SVal -> SBool) -> SVal -> SBool
forall a b. (a -> b) -> a -> b
$ Kind -> SVal -> SVal -> SVal
mkEq (SVal -> Kind
forall a. HasKind a => a -> Kind
kindOf SVal
sv) SVal
sv (Kind -> Either CV (Cached SV) -> SVal
SVal (SVal -> Kind
forall a. HasKind a => a -> Kind
kindOf SVal
sv) (CV -> Either CV (Cached SV)
forall a b. a -> Either a b
Left CV
cv)) :: SBool)
where mkEq :: Kind -> SVal -> SVal -> SVal
mkEq :: Kind -> SVal -> SVal -> SVal
mkEq Kind
k SVal
a SVal
b
| Kind -> Bool
forall a. HasKind a => a -> Bool
isDouble Kind
k Bool -> Bool -> Bool
|| Kind -> Bool
forall a. HasKind a => a -> Bool
isFloat Kind
k Bool -> Bool -> Bool
|| Kind -> Bool
forall a. HasKind a => a -> Bool
isFP Kind
k
= if Bool
shouldReject
then SVal -> SVal
svNot (SVal
a SVal -> SVal -> SVal
`fpEq` SVal
b)
else SVal
a SVal -> SVal -> SVal
`fpEq` SVal
b
| Bool
True
= if Bool
shouldReject
then SVal
a SVal -> SVal -> SVal
`svNotEqual` SVal
b
else SVal
a SVal -> SVal -> SVal
`svEqual` SVal
b
fpEq :: SVal -> SVal -> SVal
fpEq SVal
a SVal
b = Kind -> Either CV (Cached SV) -> SVal
SVal Kind
KBool (Either CV (Cached SV) -> SVal) -> Either CV (Cached SV) -> SVal
forall a b. (a -> b) -> a -> b
$ Cached SV -> Either CV (Cached SV)
forall a b. b -> Either a b
Right (Cached SV -> Either CV (Cached SV))
-> Cached SV -> Either CV (Cached SV)
forall a b. (a -> b) -> a -> b
$ (State -> IO SV) -> Cached SV
forall a. (State -> IO a) -> Cached a
cache State -> IO SV
r
where r :: State -> IO SV
r State
st = do SV
sva <- State -> SVal -> IO SV
svToSV State
st SVal
a
SV
svb <- State -> SVal -> IO SV
svToSV State
st SVal
b
State -> Kind -> SBVExpr -> IO SV
newExpr State
st Kind
KBool (Op -> [SV] -> SBVExpr
SBVApp (FPOp -> Op
IEEEFP FPOp
FP_ObjEqual) [SV
sva, SV
svb])
reject, accept :: (SVal, NamedSymVar) -> m ()
reject :: (SVal, NamedSymVar) -> m ()
reject = Bool -> (SVal, CV) -> m ()
cstr Bool
True ((SVal, CV) -> m ())
-> ((SVal, NamedSymVar) -> (SVal, CV))
-> (SVal, NamedSymVar)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SVal, NamedSymVar) -> (SVal, CV)
findVal
accept :: (SVal, NamedSymVar) -> m ()
accept = Bool -> (SVal, CV) -> m ()
cstr Bool
False ((SVal, CV) -> m ())
-> ((SVal, NamedSymVar) -> (SVal, CV))
-> (SVal, NamedSymVar)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SVal, NamedSymVar) -> (SVal, CV)
findVal
scope :: (SVal, NamedSymVar) -> S.Seq (SVal, NamedSymVar) -> m () -> m ()
scope :: (SVal, NamedSymVar) -> Seq (SVal, NamedSymVar) -> m () -> m ()
scope (SVal, NamedSymVar)
cur Seq (SVal, NamedSymVar)
pres m ()
c = do
Bool -> [Char] -> m ()
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Bool -> [Char] -> m ()
send Bool
True [Char]
"(push 1)"
(SVal, NamedSymVar) -> m ()
reject (SVal, NamedSymVar)
cur
((SVal, NamedSymVar) -> m ()) -> Seq (SVal, NamedSymVar) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SVal, NamedSymVar) -> m ()
accept Seq (SVal, NamedSymVar)
pres
()
r <- m ()
c
Bool -> [Char] -> m ()
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Bool -> [Char] -> m ()
send Bool
True [Char]
"(pop 1)"
() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
r
[Int] -> (Int -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Seq (SVal, NamedSymVar) -> Int
forall a. Seq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq (SVal, NamedSymVar)
terms Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> m ()) -> m ()) -> (Int -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
Bool
sc <- m Bool
shouldContinue
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
sc (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do case Int
-> Seq (SVal, NamedSymVar)
-> (Seq (SVal, NamedSymVar), Seq (SVal, NamedSymVar))
forall a. Int -> Seq a -> (Seq a, Seq a)
S.splitAt Int
i Seq (SVal, NamedSymVar)
terms of
(Seq (SVal, NamedSymVar)
pre, rest :: Seq (SVal, NamedSymVar)
rest@((SVal, NamedSymVar)
cur S.:<| Seq (SVal, NamedSymVar)
_)) -> (SVal, NamedSymVar) -> Seq (SVal, NamedSymVar) -> m () -> m ()
scope (SVal, NamedSymVar)
cur Seq (SVal, NamedSymVar)
pre (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> Seq (SVal, NamedSymVar) -> m ()
walk Bool
False Seq (SVal, NamedSymVar)
rest
(Seq (SVal, NamedSymVar), Seq (SVal, NamedSymVar))
_ -> [Char] -> m ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Data.SBV.allSat: Impossible happened, ran out of terms!"
loop :: State
-> ([([Char], (Bool, Maybe [[Char]], SBVType))], [[Char]])
-> [([Char], (Bool, Maybe [[Char]], SBVType))]
-> UserInputs
-> Seq (SVal, NamedSymVar)
-> SMTConfig
-> AllSatResult
-> m AllSatResult
loop State
topState ([([Char], (Bool, Maybe [[Char]], SBVType))]
allUiFuns, [[Char]]
uiFunsToReject) [([Char], (Bool, Maybe [[Char]], SBVType))]
allUiRegs UserInputs
allInputs Seq (SVal, NamedSymVar)
vars SMTConfig
cfg = Int -> AllSatResult -> m AllSatResult
go (Int
1::Int)
where go :: Int -> AllSatResult -> m AllSatResult
go :: Int -> AllSatResult -> m AllSatResult
go !Int
cnt !AllSatResult
sofar
| Just Int
maxModels <- SMTConfig -> Maybe Int
allSatMaxModelCount SMTConfig
cfg, Int
cnt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxModels
= do [[Char]] -> m ()
forall (m :: * -> *). (MonadIO m, MonadQuery m) => [[Char]] -> m ()
queryDebug [[Char]
"*** Maximum model count request of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
maxModels [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" reached, stopping the search."]
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SMTConfig -> Bool
allSatPrintAlong SMTConfig
cfg) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"Search stopped since model count request was reached."
AllSatResult -> m AllSatResult
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (AllSatResult -> m AllSatResult) -> AllSatResult -> m AllSatResult
forall a b. (a -> b) -> a -> b
$! AllSatResult
sofar { allSatMaxModelCountReached = True }
| Bool
True
= do [[Char]] -> m ()
forall (m :: * -> *). (MonadIO m, MonadQuery m) => [[Char]] -> m ()
queryDebug [[Char]
"Looking for solution " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
cnt]
CheckSatResult
cs <- m CheckSatResult
forall (m :: * -> *). (MonadIO m, MonadQuery m) => m CheckSatResult
checkSat
let endMsg :: Maybe [Char] -> m ()
endMsg = Int -> SMTConfig -> AllSatResult -> Maybe [Char] -> m ()
forall {f :: * -> *} {a}.
(Eq a, Num a, Show a, MonadIO f) =>
a -> SMTConfig -> AllSatResult -> Maybe [Char] -> f ()
finalize Int
cnt SMTConfig
cfg AllSatResult
sofar
case CheckSatResult
cs of
CheckSatResult
Unsat -> do Maybe [Char] -> m ()
endMsg Maybe [Char]
forall a. Maybe a
Nothing
AllSatResult -> m AllSatResult
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return AllSatResult
sofar
CheckSatResult
Unk -> do let m :: [Char]
m = [Char]
"Solver returned unknown, terminating query."
[[Char]] -> m ()
forall (m :: * -> *). (MonadIO m, MonadQuery m) => [[Char]] -> m ()
queryDebug [[Char]
"*** " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
m]
Maybe [Char] -> m ()
endMsg (Maybe [Char] -> m ()) -> Maybe [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"[" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
m [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"]"
AllSatResult -> m AllSatResult
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return AllSatResult
sofar{ allSatSolverReturnedUnknown = True }
DSat Maybe [Char]
_ -> do let m :: [Char]
m = [Char]
"Solver returned delta-sat, terminating query."
[[Char]] -> m ()
forall (m :: * -> *). (MonadIO m, MonadQuery m) => [[Char]] -> m ()
queryDebug [[Char]
"*** " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
m]
Maybe [Char] -> m ()
endMsg (Maybe [Char] -> m ()) -> Maybe [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"[" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
m [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"]"
AllSatResult -> m AllSatResult
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return AllSatResult
sofar{ allSatSolverReturnedDSat = True }
CheckSatResult
Sat -> do Seq (SV, (Text, (SVal, CV)))
assocs <- ((SVal, NamedSymVar) -> m (SV, (Text, (SVal, CV))))
-> Seq (SVal, NamedSymVar) -> m (Seq (SV, (Text, (SVal, CV))))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Seq a -> m (Seq b)
mapM (\(SVal
sval, NamedSymVar SV
sv Text
n) -> do !CV
cv <- Maybe Int -> SV -> m CV
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Maybe Int -> SV -> m CV
getValueCV Maybe Int
forall a. Maybe a
Nothing SV
sv
(SV, (Text, (SVal, CV))) -> m (SV, (Text, (SVal, CV)))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SV
sv, (Text
n, (SVal
sval, CV
cv)))) Seq (SVal, NamedSymVar)
vars
let getUIFun :: ([Char], (Bool, Maybe [[Char]], SBVType))
-> m ([Char], (Bool, SBVType, Either [Char] ([([CV], CV)], CV)))
getUIFun ui :: ([Char], (Bool, Maybe [[Char]], SBVType))
ui@([Char]
nm, (Bool
isCurried, Maybe [[Char]]
_, SBVType
t)) = do Either [Char] ([([CV], CV)], CV)
cvs <- Maybe Int
-> ([Char], (Bool, Maybe [[Char]], SBVType))
-> m (Either [Char] ([([CV], CV)], CV))
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Maybe Int
-> ([Char], (Bool, Maybe [[Char]], SBVType))
-> m (Either [Char] ([([CV], CV)], CV))
getUIFunCVAssoc Maybe Int
forall a. Maybe a
Nothing ([Char], (Bool, Maybe [[Char]], SBVType))
ui
([Char], (Bool, SBVType, Either [Char] ([([CV], CV)], CV)))
-> m ([Char], (Bool, SBVType, Either [Char] ([([CV], CV)], CV)))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
nm, (Bool
isCurried, SBVType
t, Either [Char] ([([CV], CV)], CV)
cvs))
[([Char], (Bool, SBVType, Either [Char] ([([CV], CV)], CV)))]
uiFunVals <- (([Char], (Bool, Maybe [[Char]], SBVType))
-> m ([Char], (Bool, SBVType, Either [Char] ([([CV], CV)], CV))))
-> [([Char], (Bool, Maybe [[Char]], SBVType))]
-> m [([Char], (Bool, SBVType, Either [Char] ([([CV], CV)], CV)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([Char], (Bool, Maybe [[Char]], SBVType))
-> m ([Char], (Bool, SBVType, Either [Char] ([([CV], CV)], CV)))
forall {m :: * -> *}.
(MonadIO m, MonadQuery m) =>
([Char], (Bool, Maybe [[Char]], SBVType))
-> m ([Char], (Bool, SBVType, Either [Char] ([([CV], CV)], CV)))
getUIFun [([Char], (Bool, Maybe [[Char]], SBVType))]
allUiFuns
[([Char], CV)]
uiRegVals <- (([Char], (Bool, Maybe [[Char]], SBVType)) -> m ([Char], CV))
-> [([Char], (Bool, Maybe [[Char]], SBVType))] -> m [([Char], CV)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\ui :: ([Char], (Bool, Maybe [[Char]], SBVType))
ui@([Char]
nm, (Bool, Maybe [[Char]], SBVType)
_) -> ([Char]
nm,) (CV -> ([Char], CV)) -> m CV -> m ([Char], CV)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int -> ([Char], (Bool, Maybe [[Char]], SBVType)) -> m CV
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Maybe Int -> ([Char], (Bool, Maybe [[Char]], SBVType)) -> m CV
getUICVal Maybe Int
forall a. Maybe a
Nothing ([Char], (Bool, Maybe [[Char]], SBVType))
ui) [([Char], (Bool, Maybe [[Char]], SBVType))]
allUiRegs
[(Text, CV)]
obsvs <- m [(Text, CV)]
forall (m :: * -> *). (MonadIO m, MonadQuery m) => m [(Text, CV)]
getObservables
Maybe (Seq (NamedSymVar, CV))
bindings <- let grab :: NamedSymVar -> m (NamedSymVar, CV)
grab i :: NamedSymVar
i@(NamedSymVar -> SV
getSV -> SV
sv) = case ((SV, (Text, (SVal, CV))) -> SV)
-> SV
-> Seq (SV, (Text, (SVal, CV)))
-> Maybe (SV, (Text, (SVal, CV)))
forall a. Eq a => (a -> SV) -> SV -> Seq a -> Maybe a
lookupInput (SV, (Text, (SVal, CV))) -> SV
forall a b. (a, b) -> a
fst SV
sv Seq (SV, (Text, (SVal, CV)))
assocs of
Just (SV
_, (Text
_, (SVal
_, CV
cv))) -> (NamedSymVar, CV) -> m (NamedSymVar, CV)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (NamedSymVar
i, CV
cv)
Maybe (SV, (Text, (SVal, CV)))
Nothing -> do !CV
cv <- Maybe Int -> SV -> m CV
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Maybe Int -> SV -> m CV
getValueCV Maybe Int
forall a. Maybe a
Nothing SV
sv
(NamedSymVar, CV) -> m (NamedSymVar, CV)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (NamedSymVar
i, CV
cv)
in if SMTConfig -> Bool
validationRequested SMTConfig
cfg
then Seq (NamedSymVar, CV) -> Maybe (Seq (NamedSymVar, CV))
forall a. a -> Maybe a
Just (Seq (NamedSymVar, CV) -> Maybe (Seq (NamedSymVar, CV)))
-> m (Seq (NamedSymVar, CV)) -> m (Maybe (Seq (NamedSymVar, CV)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NamedSymVar -> m (NamedSymVar, CV))
-> UserInputs -> m (Seq (NamedSymVar, CV))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Seq a -> m (Seq b)
mapM NamedSymVar -> m (NamedSymVar, CV)
grab UserInputs
allInputs
else Maybe (Seq (NamedSymVar, CV)) -> m (Maybe (Seq (NamedSymVar, CV)))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Seq (NamedSymVar, CV))
forall a. Maybe a
Nothing
let model :: SMTModel
model = SMTModel { modelObjectives :: [([Char], GeneralizedCV)]
modelObjectives = []
, modelBindings :: Maybe [(NamedSymVar, CV)]
modelBindings = Seq (NamedSymVar, CV) -> [(NamedSymVar, CV)]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq (NamedSymVar, CV) -> [(NamedSymVar, CV)])
-> Maybe (Seq (NamedSymVar, CV)) -> Maybe [(NamedSymVar, CV)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Seq (NamedSymVar, CV))
bindings
, modelAssocs :: [([Char], CV)]
modelAssocs = [([Char], CV)]
uiRegVals
[([Char], CV)] -> [([Char], CV)] -> [([Char], CV)]
forall a. Semigroup a => a -> a -> a
<> ((Text -> [Char]) -> (Text, CV) -> ([Char], CV)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> [Char]
T.unpack ((Text, CV) -> ([Char], CV)) -> [(Text, CV)] -> [([Char], CV)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Text, CV) -> Text) -> [(Text, CV)] -> [(Text, CV)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Text, CV) -> Text
forall a b. (a, b) -> a
fst [(Text, CV)]
obsvs)
[([Char], CV)] -> [([Char], CV)] -> [([Char], CV)]
forall a. Semigroup a => a -> a -> a
<> [(Text -> [Char]
T.unpack Text
n, CV
cv) | (SV
_, (Text
n, (SVal
_, CV
cv))) <- Seq (SV, (Text, (SVal, CV))) -> [(SV, (Text, (SVal, CV)))]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Seq (SV, (Text, (SVal, CV)))
assocs]
, modelUIFuns :: [([Char], (Bool, SBVType, Either [Char] ([([CV], CV)], CV)))]
modelUIFuns = [([Char], (Bool, SBVType, Either [Char] ([([CV], CV)], CV)))]
uiFunVals
}
m :: SMTResult
m = SMTConfig -> SMTModel -> SMTResult
Satisfiable SMTConfig
cfg SMTModel
model
(Seq (SVal, CV)
interpreteds, Seq (SVal, CV)
uninterpreteds) = ((SVal, CV) -> Bool)
-> Seq (SVal, CV) -> (Seq (SVal, CV), Seq (SVal, CV))
forall a. (a -> Bool) -> Seq a -> (Seq a, Seq a)
S.partition (Bool -> Bool
not (Bool -> Bool) -> ((SVal, CV) -> Bool) -> (SVal, CV) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> Bool
isFree (Kind -> Bool) -> ((SVal, CV) -> Kind) -> (SVal, CV) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SVal -> Kind
forall a. HasKind a => a -> Kind
kindOf (SVal -> Kind) -> ((SVal, CV) -> SVal) -> (SVal, CV) -> Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SVal, CV) -> SVal
forall a b. (a, b) -> a
fst) (((SV, (Text, (SVal, CV))) -> (SVal, CV))
-> Seq (SV, (Text, (SVal, CV))) -> Seq (SVal, CV)
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text, (SVal, CV)) -> (SVal, CV)
forall a b. (a, b) -> b
snd ((Text, (SVal, CV)) -> (SVal, CV))
-> ((SV, (Text, (SVal, CV))) -> (Text, (SVal, CV)))
-> (SV, (Text, (SVal, CV)))
-> (SVal, CV)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SV, (Text, (SVal, CV))) -> (Text, (SVal, CV))
forall a b. (a, b) -> b
snd) Seq (SV, (Text, (SVal, CV)))
assocs)
interpretedRegUis :: [([Char], CV)]
interpretedRegUis = (([Char], CV) -> Bool) -> [([Char], CV)] -> [([Char], CV)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (([Char], CV) -> Bool) -> ([Char], CV) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> Bool
isFree (Kind -> Bool) -> (([Char], CV) -> Kind) -> ([Char], CV) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CV -> Kind
forall a. HasKind a => a -> Kind
kindOf (CV -> Kind) -> (([Char], CV) -> CV) -> ([Char], CV) -> Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], CV) -> CV
forall a b. (a, b) -> b
snd) [([Char], CV)]
uiRegVals
interpretedRegUiSVs :: [(SVal, CV)]
interpretedRegUiSVs = [([Char] -> Kind -> SVal
cvt [Char]
n (CV -> Kind
forall a. HasKind a => a -> Kind
kindOf CV
cv), CV
cv) | ([Char]
n, CV
cv) <- [([Char], CV)]
interpretedRegUis]
where cvt :: String -> Kind -> SVal
cvt :: [Char] -> Kind -> SVal
cvt [Char]
nm Kind
k = Kind -> Either CV (Cached SV) -> SVal
SVal Kind
k (Either CV (Cached SV) -> SVal) -> Either CV (Cached SV) -> SVal
forall a b. (a -> b) -> a -> b
$ Cached SV -> Either CV (Cached SV)
forall a b. b -> Either a b
Right (Cached SV -> Either CV (Cached SV))
-> Cached SV -> Either CV (Cached SV)
forall a b. (a -> b) -> a -> b
$ (State -> IO SV) -> Cached SV
forall a. (State -> IO a) -> Cached a
cache State -> IO SV
r
where r :: State -> IO SV
r State
st = State -> Kind -> SBVExpr -> IO SV
newExpr State
st Kind
k (Op -> [SV] -> SBVExpr
SBVApp ([Char] -> Op
Uninterpreted [Char]
nm) [])
interpretedEqs :: [SVal]
interpretedEqs :: [SVal]
interpretedEqs = [Kind -> SVal -> SVal -> SVal
forall {a}. HasKind a => a -> SVal -> SVal -> SVal
mkNotEq (SVal -> Kind
forall a. HasKind a => a -> Kind
kindOf SVal
sv) SVal
sv (Kind -> Either CV (Cached SV) -> SVal
SVal (SVal -> Kind
forall a. HasKind a => a -> Kind
kindOf SVal
sv) (CV -> Either CV (Cached SV)
forall a b. a -> Either a b
Left CV
cv)) | (SVal
sv, CV
cv) <- [(SVal, CV)]
interpretedRegUiSVs [(SVal, CV)] -> [(SVal, CV)] -> [(SVal, CV)]
forall a. Semigroup a => a -> a -> a
<> Seq (SVal, CV) -> [(SVal, CV)]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Seq (SVal, CV)
interpreteds]
where mkNotEq :: a -> SVal -> SVal -> SVal
mkNotEq a
k SVal
a SVal
b
| a -> Bool
forall a. HasKind a => a -> Bool
isDouble a
k Bool -> Bool -> Bool
|| a -> Bool
forall a. HasKind a => a -> Bool
isFloat a
k Bool -> Bool -> Bool
|| a -> Bool
forall a. HasKind a => a -> Bool
isFP a
k
= SVal -> SVal
svNot (SVal
a SVal -> SVal -> SVal
`fpEq` SVal
b)
| Bool
True
= SVal
a SVal -> SVal -> SVal
`svNotEqual` SVal
b
fpEq :: SVal -> SVal -> SVal
fpEq SVal
a SVal
b = Kind -> Either CV (Cached SV) -> SVal
SVal Kind
KBool (Either CV (Cached SV) -> SVal) -> Either CV (Cached SV) -> SVal
forall a b. (a -> b) -> a -> b
$ Cached SV -> Either CV (Cached SV)
forall a b. b -> Either a b
Right (Cached SV -> Either CV (Cached SV))
-> Cached SV -> Either CV (Cached SV)
forall a b. (a -> b) -> a -> b
$ (State -> IO SV) -> Cached SV
forall a. (State -> IO a) -> Cached a
cache State -> IO SV
r
where r :: State -> IO SV
r State
st = do SV
sva <- State -> SVal -> IO SV
svToSV State
st SVal
a
SV
svb <- State -> SVal -> IO SV
svToSV State
st SVal
b
State -> Kind -> SBVExpr -> IO SV
newExpr State
st Kind
KBool (Op -> [SV] -> SBVExpr
SBVApp (FPOp -> Op
IEEEFP FPOp
FP_ObjEqual) [SV
sva, SV
svb])
uninterpretedEqs :: [SVal]
uninterpretedEqs :: [SVal]
uninterpretedEqs = ([SVal] -> [SVal]) -> [[SVal]] -> [SVal]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [SVal] -> [SVal]
pwDistinct
([[SVal]] -> [SVal])
-> ([(SVal, CV)] -> [[SVal]]) -> [(SVal, CV)] -> [SVal]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([SVal] -> Bool) -> [[SVal]] -> [[SVal]]
forall a. (a -> Bool) -> [a] -> [a]
filter (\[SVal]
l -> [SVal] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SVal]
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1)
([[SVal]] -> [[SVal]])
-> ([(SVal, CV)] -> [[SVal]]) -> [(SVal, CV)] -> [[SVal]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(SVal, CV)] -> [SVal]) -> [[(SVal, CV)]] -> [[SVal]]
forall a b. (a -> b) -> [a] -> [b]
map (((SVal, CV) -> SVal) -> [(SVal, CV)] -> [SVal]
forall a b. (a -> b) -> [a] -> [b]
map (SVal, CV) -> SVal
forall a b. (a, b) -> a
fst)
([[(SVal, CV)]] -> [[SVal]])
-> ([(SVal, CV)] -> [[(SVal, CV)]]) -> [(SVal, CV)] -> [[SVal]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((SVal, CV) -> (SVal, CV) -> Bool)
-> [(SVal, CV)] -> [[(SVal, CV)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (CV -> CV -> Bool
forall a. Eq a => a -> a -> Bool
(==) (CV -> CV -> Bool)
-> ((SVal, CV) -> CV) -> (SVal, CV) -> (SVal, CV) -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (SVal, CV) -> CV
forall a b. (a, b) -> b
snd)
([(SVal, CV)] -> [[(SVal, CV)]])
-> ([(SVal, CV)] -> [(SVal, CV)]) -> [(SVal, CV)] -> [[(SVal, CV)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((SVal, CV) -> CV) -> [(SVal, CV)] -> [(SVal, CV)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (SVal, CV) -> CV
forall a b. (a, b) -> b
snd
([(SVal, CV)] -> [SVal]) -> [(SVal, CV)] -> [SVal]
forall a b. (a -> b) -> a -> b
$ Seq (SVal, CV) -> [(SVal, CV)]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Seq (SVal, CV)
uninterpreteds
where pwDistinct :: [SVal] -> [SVal]
pwDistinct :: [SVal] -> [SVal]
pwDistinct [SVal]
ss = [SVal
x SVal -> SVal -> SVal
`svNotEqual` SVal
y | (SVal
x:[SVal]
ys) <- [SVal] -> [[SVal]]
forall a. [a] -> [[a]]
tails [SVal]
ss, SVal
y <- [SVal]
ys]
uninterpretedReject :: Maybe [String]
uninterpretedFuns :: [String]
(Maybe [[Char]]
uninterpretedReject, [[Char]]
uninterpretedFuns) = (Maybe [[Char]]
uiReject, [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[[Char]]]
defs)
where uiReject :: Maybe [[Char]]
uiReject = case [[Char]]
rejects of
[] -> Maybe [[Char]]
forall a. Maybe a
Nothing
[[Char]]
xs -> [[Char]] -> Maybe [[Char]]
forall a. a -> Maybe a
Just [[Char]]
xs
([[Char]]
rejects, [[[Char]]]
defs) = [([Char], [[Char]])] -> ([[Char]], [[[Char]]])
forall a b. [(a, b)] -> ([a], [b])
unzip [([Char], (Bool, SBVType, Either [Char] ([([CV], CV)], CV)))
-> ([Char], [[Char]])
mkNotEq ([Char], (Bool, SBVType, Either [Char] ([([CV], CV)], CV)))
ui | ui :: ([Char], (Bool, SBVType, Either [Char] ([([CV], CV)], CV)))
ui@([Char]
nm, (Bool, SBVType, Either [Char] ([([CV], CV)], CV))
_) <- [([Char], (Bool, SBVType, Either [Char] ([([CV], CV)], CV)))]
uiFunVals, [Char]
nm [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
uiFunsToReject]
mkNotEq :: ([Char], (Bool, SBVType, Either [Char] ([([CV], CV)], CV)))
-> ([Char], [[Char]])
mkNotEq ([Char]
nm, (Bool
_, SBVType
typ, Left [Char]
def)) =
[Char] -> ([Char], [[Char]])
forall a. HasCallStack => [Char] -> a
error ([Char] -> ([Char], [[Char]])) -> [Char] -> ([Char], [[Char]])
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [
[Char]
""
, [Char]
"*** allSat: Unsupported: Building a rejecting instance for:"
, [Char]
"***"
, [Char]
"*** " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
nm [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" :: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SBVType -> [Char]
forall a. Show a => a -> [Char]
show SBVType
typ
, [Char]
"*** " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
def
, [Char]
"***"
, [Char]
"*** At this time, SBV cannot compute allSat when the model has a non-table definition."
, [Char]
"***"
, [Char]
"*** You can ignore specific functions via the 'isNonModelVar' filter:"
, [Char]
"***"
, [Char]
"*** allSatWith z3{isNonModelVar = (`elem` [" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
nm [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"])} ..."
, [Char]
"***"
, [Char]
"*** Or you can ignore all uninterpreted functions for all-sat purposes using the 'allSatTrackUFs' parameter:"
, [Char]
"***"
, [Char]
"*** allSatWith z3{allSatTrackUFs = False} ..."
, [Char]
"***"
, [Char]
"*** You can see the response from the solver by running with the '{verbose = True}' option."
, [Char]
"***"
, [Char]
"*** NB. If this is a use case you'd like SBV to support, please get in touch!"
]
mkNotEq ([Char]
nm, (Bool
_, SBVType [Kind]
ts, Right ([([CV], CV)], CV)
vs)) = ([Char]
reject, [[Char]]
def [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
dif)
where nm' :: [Char]
nm' = [Char]
nm [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_model" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
cnt
reject :: [Char]
reject = [Char]
nm' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_reject"
scv :: CV -> [Char]
scv = RoundingMode -> CV -> [Char]
cvToSMTLib RoundingMode
RoundNearestTiesToEven
([Kind]
ats, Kind
rt) = ([Kind] -> [Kind]
forall a. HasCallStack => [a] -> [a]
init [Kind]
ts, [Kind] -> Kind
forall a. HasCallStack => [a] -> a
last [Kind]
ts)
args :: [Char]
args = [[Char]] -> [Char]
unwords [[Char]
"(x!" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Kind -> [Char]
smtType Kind
t [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")" | (Kind
t, Int
i) <- [Kind] -> [Int] -> [(Kind, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Kind]
ats [(Int
0::Int)..]]
res :: [Char]
res = Kind -> [Char]
smtType Kind
rt
params :: [[Char]]
params = [[Char]
"x!" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i | (Kind
_, Int
i) <- [Kind] -> [Int] -> [(Kind, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Kind]
ats [(Int
0::Int)..]]
uparams :: [Char]
uparams = [[Char]] -> [Char]
unwords [[Char]]
params
chain :: ([([CV], CV)], CV) -> [[Char]]
chain ([([CV], CV)]
vals, CV
fallThru) = [([CV], CV)] -> [[Char]]
walk [([CV], CV)]
vals
where walk :: [([CV], CV)] -> [[Char]]
walk [] = [[Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CV -> [Char]
scv CV
fallThru [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate ([([CV], CV)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [([CV], CV)]
vals) Char
')']
walk (([CV]
as, CV
r) : [([CV], CV)]
rest) = ([Char]
" (ite " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [CV] -> [Char]
cond [CV]
as [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CV -> [Char]
scv CV
r) [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [([CV], CV)] -> [[Char]]
walk [([CV], CV)]
rest
cond :: [CV] -> [Char]
cond [CV]
as = [Char]
"(and " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords (([Char] -> CV -> [Char]) -> [[Char]] -> [CV] -> [[Char]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [Char] -> CV -> [Char]
eq [[Char]]
params [CV]
as) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
eq :: [Char] -> CV -> [Char]
eq [Char]
p CV
a = [Char]
"(= " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
p [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CV -> [Char]
scv CV
a [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
def :: [[Char]]
def = ([Char]
"(define-fun " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
nm' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
args [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
") " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
res)
[Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: ([([CV], CV)], CV) -> [[Char]]
chain ([([CV], CV)], CV)
vs
[[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
")"]
pad :: [Char]
pad = Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
nm' Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
nm) Char
' '
dif :: [[Char]]
dif = [ [Char]
"(define-fun " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
reject [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" () Bool"
, [Char]
" (exists (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
args [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
, [Char]
" (distinct (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
nm [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
pad [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
uparams [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
, [Char]
" (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
nm' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
uparams [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"))))"
]
eqs :: [SVal]
eqs = [SVal]
interpretedEqs [SVal] -> [SVal] -> [SVal]
forall a. [a] -> [a] -> [a]
++ [SVal]
uninterpretedEqs
disallow :: Maybe (SBV a)
disallow = case [SVal]
eqs of
[] -> Maybe (SBV a)
forall a. Maybe a
Nothing
[SVal]
_ -> SBV a -> Maybe (SBV a)
forall a. a -> Maybe a
Just (SBV a -> Maybe (SBV a)) -> SBV a -> Maybe (SBV a)
forall a b. (a -> b) -> a -> b
$ SVal -> SBV a
forall a. SVal -> SBV a
SBV (SVal -> SBV a) -> SVal -> SBV a
forall a b. (a -> b) -> a -> b
$ (SVal -> SVal -> SVal) -> [SVal] -> SVal
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 SVal -> SVal -> SVal
svOr [SVal]
eqs
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SMTConfig -> Bool
allSatPrintAlong SMTConfig
cfg) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Solution #" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
cnt [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
":"
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ SMTConfig -> SMTModel -> [Char]
showModel SMTConfig
cfg SMTModel
model
let resultsSoFar :: AllSatResult
resultsSoFar = AllSatResult
sofar { allSatResults = m : allSatResults sofar }
needMoreIterations :: Bool
needMoreIterations
| Just Int
maxModels <- SMTConfig -> Maybe Int
allSatMaxModelCount SMTConfig
cfg, (Int
cntInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxModels = Bool
False
| Bool
True = Bool
True
if Bool -> Bool
not Bool
needMoreIterations
then Int -> AllSatResult -> m AllSatResult
go (Int
cntInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) AllSatResult
resultsSoFar
else do let uiFunRejector :: [Char]
uiFunRejector = [Char]
"uiFunRejector_model_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
cnt
header :: [Char]
header = [Char]
"define-fun " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
uiFunRejector [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" () Bool "
defineRejector :: [[Char]] -> m ()
defineRejector [] = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
defineRejector [[Char]
x] = Bool -> [Char] -> m ()
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Bool -> [Char] -> m ()
send Bool
True ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
header [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
defineRejector ([Char]
x:[[Char]]
xs) = ([Char] -> m ()) -> [[Char]] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool -> [Char] -> m ()
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Bool -> [Char] -> m ()
send Bool
True) ([[Char]] -> m ()) -> [[Char]] -> m ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [[Char]]
mergeSExpr ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ([Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
header)
[Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: ([Char]
" (or " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
x)
[Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
e | [Char]
e <- [[Char]]
xs]
[[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
" ))"]
Maybe [Char]
rejectFuncs <- case Maybe [[Char]]
uninterpretedReject of
Maybe [[Char]]
Nothing -> Maybe [Char] -> m (Maybe [Char])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Char]
forall a. Maybe a
Nothing
Just [[Char]]
fs -> do ([Char] -> m ()) -> [[Char]] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool -> [Char] -> m ()
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Bool -> [Char] -> m ()
send Bool
True) ([[Char]] -> m ()) -> [[Char]] -> m ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [[Char]]
mergeSExpr [[Char]]
uninterpretedFuns
[[Char]] -> m ()
defineRejector [[Char]]
fs
Maybe [Char] -> m (Maybe [Char])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char] -> m (Maybe [Char]))
-> Maybe [Char] -> m (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
uiFunRejector
case (Maybe SBool
forall {a}. Maybe (SBV a)
disallow, Maybe [Char]
rejectFuncs) of
(Maybe SBool
Nothing, Maybe [Char]
Nothing) -> AllSatResult -> m AllSatResult
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AllSatResult
resultsSoFar
(Just SBool
d, Maybe [Char]
Nothing) -> do SBool -> m ()
forall a. QuantifiedBool a => a -> m ()
forall (m :: * -> *) a.
(SolverContext m, QuantifiedBool a) =>
a -> m ()
constrain SBool
d
Int -> AllSatResult -> m AllSatResult
go (Int
cntInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) AllSatResult
resultsSoFar
(Maybe SBool
Nothing, Just [Char]
f) -> do Bool -> [Char] -> m ()
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Bool -> [Char] -> m ()
send Bool
True ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"(assert " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
f [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
Int -> AllSatResult -> m AllSatResult
go (Int
cntInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) AllSatResult
resultsSoFar
(Just SBool
d, Just [Char]
f) ->
do SBool -> m ()
forall a. QuantifiedBool a => a -> m ()
forall (m :: * -> *) a.
(SolverContext m, QuantifiedBool a) =>
a -> m ()
constrain (SBool -> m ()) -> SBool -> m ()
forall a b. (a -> b) -> a -> b
$ SBool
d SBool -> SBool -> SBool
.=> SBool
d
SV
svd <- IO SV -> m SV
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO SV -> m SV) -> IO SV -> m SV
forall a b. (a -> b) -> a -> b
$ State -> SVal -> IO SV
svToSV State
topState (SBool -> SVal
forall a. SBV a -> SVal
unSBV SBool
d)
Bool -> [Char] -> m ()
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Bool -> [Char] -> m ()
send Bool
True ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"(assert (or " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
f [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SV -> [Char]
forall a. Show a => a -> [Char]
show SV
svd [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"))"
Int -> AllSatResult -> m AllSatResult
go (Int
cntInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) AllSatResult
resultsSoFar
getUnsatAssumptions :: (MonadIO m, MonadQuery m) => [String] -> [(String, a)] -> m [a]
getUnsatAssumptions :: forall (m :: * -> *) a.
(MonadIO m, MonadQuery m) =>
[[Char]] -> [([Char], a)] -> m [a]
getUnsatAssumptions [[Char]]
originals [([Char], a)]
proxyMap = do
let cmd :: [Char]
cmd = [Char]
"(get-unsat-assumptions)"
bad :: [Char] -> Maybe [[Char]] -> m [a]
bad = [Char]
-> [Char]
-> [Char]
-> Maybe [[Char]]
-> [Char]
-> Maybe [[Char]]
-> m [a]
forall (m :: * -> *) a.
(MonadIO m, MonadQuery m) =>
[Char]
-> [Char]
-> [Char]
-> Maybe [[Char]]
-> [Char]
-> Maybe [[Char]]
-> m a
unexpected [Char]
"getUnsatAssumptions" [Char]
cmd [Char]
"a list of unsatisfiable assumptions"
(Maybe [[Char]] -> [Char] -> Maybe [[Char]] -> m [a])
-> Maybe [[Char]] -> [Char] -> Maybe [[Char]] -> m [a]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> Maybe [[Char]]
forall a. a -> Maybe a
Just [ [Char]
"Make sure you use:"
, [Char]
""
, [Char]
" setOption $ ProduceUnsatAssumptions True"
, [Char]
""
, [Char]
"to make sure the solver is ready for producing unsat assumptions,"
, [Char]
"and that there is a model by first issuing a 'checkSat' call."
]
fromECon :: SExpr -> Maybe [Char]
fromECon (ECon [Char]
s) = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
s
fromECon SExpr
_ = Maybe [Char]
forall a. Maybe a
Nothing
[Char]
r <- [Char] -> m [Char]
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
[Char] -> m [Char]
ask [Char]
cmd
let walk :: [[Char]] -> [a] -> m [a]
walk [] [a]
sofar = [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> m [a]) -> [a] -> m [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. [a] -> [a]
reverse [a]
sofar
walk ([Char]
a:[[Char]]
as) [a]
sofar = case [Char]
a [Char] -> [([Char], a)] -> Maybe a
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [([Char], a)]
proxyMap of
Just a
v -> [[Char]] -> [a] -> m [a]
walk [[Char]]
as (a
va -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
sofar)
Maybe a
Nothing -> do [[Char]] -> m ()
forall (m :: * -> *). (MonadIO m, MonadQuery m) => [[Char]] -> m ()
queryDebug [ [Char]
"*** In call to 'getUnsatAssumptions'"
, [Char]
"***"
, [Char]
"*** Unexpected assumption named: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
a
, [Char]
"*** Was expecting one of : " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall a. Show a => a -> [Char]
show [[Char]]
originals
, [Char]
"***"
, [Char]
"*** This can happen if unsat-cores are also enabled. Ignoring."
]
[[Char]] -> [a] -> m [a]
walk [[Char]]
as [a]
sofar
[Char]
-> ([Char] -> Maybe [[Char]] -> m [a]) -> (SExpr -> m [a]) -> m [a]
forall a.
[Char] -> ([Char] -> Maybe [[Char]] -> a) -> (SExpr -> a) -> a
parse [Char]
r [Char] -> Maybe [[Char]] -> m [a]
bad ((SExpr -> m [a]) -> m [a]) -> (SExpr -> m [a]) -> m [a]
forall a b. (a -> b) -> a -> b
$ \case
EApp [SExpr]
es | Just [[Char]]
xs <- (SExpr -> Maybe [Char]) -> [SExpr] -> Maybe [[Char]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM SExpr -> Maybe [Char]
fromECon [SExpr]
es -> [[Char]] -> [a] -> m [a]
walk [[Char]]
xs []
SExpr
_ -> [Char] -> Maybe [[Char]] -> m [a]
bad [Char]
r Maybe [[Char]]
forall a. Maybe a
Nothing
timeout :: (MonadIO m, MonadQuery m) => Int -> m a -> m a
timeout :: forall (m :: * -> *) a.
(MonadIO m, MonadQuery m) =>
Int -> m a -> m a
timeout Int
n m a
q = do (QueryState -> QueryState) -> m ()
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
(QueryState -> QueryState) -> m ()
modifyQueryState (\QueryState
qs -> QueryState
qs {queryTimeOutValue = Just n})
a
r <- m a
q
(QueryState -> QueryState) -> m ()
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
(QueryState -> QueryState) -> m ()
modifyQueryState (\QueryState
qs -> QueryState
qs {queryTimeOutValue = Nothing})
a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
parse :: String -> (String -> Maybe [String] -> a) -> (SExpr -> a) -> a
parse :: forall a.
[Char] -> ([Char] -> Maybe [[Char]] -> a) -> (SExpr -> a) -> a
parse [Char]
r [Char] -> Maybe [[Char]] -> a
fCont SExpr -> a
sCont = case [Char] -> Either [Char] SExpr
parseSExpr [Char]
r of
Left [Char]
e -> [Char] -> Maybe [[Char]] -> a
fCont [Char]
r ([[Char]] -> Maybe [[Char]]
forall a. a -> Maybe a
Just [[Char]
e])
Right SExpr
res -> SExpr -> a
sCont SExpr
res
unexpected :: (MonadIO m, MonadQuery m) => String -> String -> String -> Maybe [String] -> String -> Maybe [String] -> m a
unexpected :: forall (m :: * -> *) a.
(MonadIO m, MonadQuery m) =>
[Char]
-> [Char]
-> [Char]
-> Maybe [[Char]]
-> [Char]
-> Maybe [[Char]]
-> m a
unexpected [Char]
ctx [Char]
sent [Char]
expected Maybe [[Char]]
mbHint [Char]
received Maybe [[Char]]
mbReason = do
[[Char]]
extras <- [Char] -> Maybe Int -> m [[Char]]
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
[Char] -> Maybe Int -> m [[Char]]
retrieveResponse [Char]
"terminating upon unexpected response" (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
5000000)
SMTConfig
cfg <- m SMTConfig
forall (m :: * -> *). (MonadIO m, MonadQuery m) => m SMTConfig
getConfig
let exc :: SBVException
exc = SBVException { sbvExceptionDescription :: [Char]
sbvExceptionDescription = [Char]
"Unexpected response from the solver, context: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ctx
, sbvExceptionSent :: Maybe [Char]
sbvExceptionSent = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
sent
, sbvExceptionExpected :: Maybe [Char]
sbvExceptionExpected = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
expected
, sbvExceptionReceived :: Maybe [Char]
sbvExceptionReceived = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
received
, sbvExceptionStdOut :: Maybe [Char]
sbvExceptionStdOut = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [[Char]]
extras
, sbvExceptionStdErr :: Maybe [Char]
sbvExceptionStdErr = Maybe [Char]
forall a. Maybe a
Nothing
, sbvExceptionExitCode :: Maybe ExitCode
sbvExceptionExitCode = Maybe ExitCode
forall a. Maybe a
Nothing
, sbvExceptionConfig :: SMTConfig
sbvExceptionConfig = SMTConfig
cfg
, sbvExceptionReason :: Maybe [[Char]]
sbvExceptionReason = Maybe [[Char]]
mbReason
, sbvExceptionHint :: Maybe [[Char]]
sbvExceptionHint = Maybe [[Char]]
mbHint
}
IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ SBVException -> IO a
forall e a. Exception e => e -> IO a
C.throwIO SBVException
exc
runProofOn :: SBVRunMode -> QueryContext -> [String] -> Result -> SMTProblem
runProofOn :: SBVRunMode -> QueryContext -> [[Char]] -> Result -> SMTProblem
runProofOn SBVRunMode
rm QueryContext
context [[Char]]
comments res :: Result
res@(Result ProgInfo
progInfo KindSet
ki [([Char], CV)]
_qcInfo [([Char], CV -> Bool, SV)]
_observables [([Char], [[Char]])]
_codeSegs ResultInp
is (CnstMap, [(SV, CV)])
consts [((Int, Kind, Kind), [SV])]
tbls [(Int, ArrayInfo)]
arrs [([Char], (Bool, Maybe [[Char]], SBVType))]
uis [(SMTDef, SBVType)]
defns SBVPgm
pgm Seq (Bool, [([Char], [Char])], SV)
cstrs [([Char], Maybe CallStack, SV)]
_assertions [SV]
outputs) =
let (SMTConfig
config, Bool
isSat, Bool
isSafe, Bool
isSetup) = case SBVRunMode
rm of
SMTMode QueryContext
_ IStage
stage Bool
s SMTConfig
c -> (SMTConfig
c, Bool
s, IStage -> Bool
isSafetyCheckingIStage IStage
stage, IStage -> Bool
isSetupIStage IStage
stage)
SBVRunMode
_ -> [Char] -> (SMTConfig, Bool, Bool, Bool)
forall a. HasCallStack => [Char] -> a
error ([Char] -> (SMTConfig, Bool, Bool, Bool))
-> [Char] -> (SMTConfig, Bool, Bool, Bool)
forall a b. (a -> b) -> a -> b
$ [Char]
"runProofOn: Unexpected run mode: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SBVRunMode -> [Char]
forall a. Show a => a -> [Char]
show SBVRunMode
rm
o :: SV
o | Bool
isSafe = SV
trueSV
| Bool
True = case [SV]
outputs of
[] | Bool
isSetup -> SV
trueSV
[SV
so] -> case SV
so of
SV Kind
KBool NodeId
_ -> SV
so
SV
_ -> [Char] -> SV
forall a. HasCallStack => [Char] -> a
error ([Char] -> SV) -> [Char] -> SV
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [ [Char]
"Impossible happened, non-boolean output: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SV -> [Char]
forall a. Show a => a -> [Char]
show SV
so
, [Char]
"Detected while generating the trace:\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Result -> [Char]
forall a. Show a => a -> [Char]
show Result
res
]
[SV]
os -> [Char] -> SV
forall a. HasCallStack => [Char] -> a
error ([Char] -> SV) -> [Char] -> SV
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [ [Char]
"User error: Multiple output values detected: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [SV] -> [Char]
forall a. Show a => a -> [Char]
show [SV]
os
, [Char]
"Detected while generating the trace:\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Result -> [Char]
forall a. Show a => a -> [Char]
show Result
res
, [Char]
"*** Check calls to \"output\", they are typically not needed!"
]
in SMTProblem { smtLibPgm :: SMTConfig -> SMTLibPgm
smtLibPgm = SMTConfig -> SMTLibConverter SMTLibPgm
toSMTLib SMTConfig
config QueryContext
context ProgInfo
progInfo KindSet
ki Bool
isSat [[Char]]
comments ResultInp
is (CnstMap, [(SV, CV)])
consts [((Int, Kind, Kind), [SV])]
tbls [(Int, ArrayInfo)]
arrs [([Char], (Bool, Maybe [[Char]], SBVType))]
uis [(SMTDef, SBVType)]
defns SBVPgm
pgm Seq (Bool, [([Char], [Char])], SV)
cstrs SV
o }
executeQuery :: forall m a. ExtractIO m => QueryContext -> QueryT m a -> SymbolicT m a
executeQuery :: forall (m :: * -> *) a.
ExtractIO m =>
QueryContext -> QueryT m a -> SymbolicT m a
executeQuery QueryContext
queryContext (QueryT ReaderT State m a
userQuery) = do
State
st <- SymbolicT m State
forall (m :: * -> *). MonadSymbolic m => m State
symbolicEnv
SBVRunMode
rm <- IO SBVRunMode -> SymbolicT m SBVRunMode
forall a. IO a -> SymbolicT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SBVRunMode -> SymbolicT m SBVRunMode)
-> IO SBVRunMode -> SymbolicT m SBVRunMode
forall a b. (a -> b) -> a -> b
$ IORef SBVRunMode -> IO SBVRunMode
forall a. IORef a -> IO a
readIORef (State -> IORef SBVRunMode
runMode State
st)
() <- IO () -> SymbolicT m ()
forall a. IO a -> SymbolicT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SymbolicT m ()) -> IO () -> SymbolicT m ()
forall a b. (a -> b) -> a -> b
$ case (QueryContext
queryContext, SBVRunMode
rm) of
(QueryContext
QueryInternal, SBVRunMode
_) -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(QueryContext
QueryExternal, SMTMode QueryContext
QueryExternal IStage
ISetup Bool
_ SMTConfig
_) -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(QueryContext, SBVRunMode)
_ -> SBVRunMode -> IO ()
forall {a} {a}. Show a => a -> a
invalidQuery SBVRunMode
rm
case SBVRunMode
rm of
SMTMode QueryContext
qc IStage
stage Bool
isSAT SMTConfig
cfg | Bool -> Bool
not (IStage -> Bool
isRunIStage IStage
stage) -> do
let slvr :: SMTSolver
slvr = SMTConfig -> SMTSolver
solver SMTConfig
cfg
backend :: SMTConfig -> State -> [Char] -> (State -> IO (m a)) -> IO (m a)
backend = SMTSolver -> SMTEngine
engine SMTSolver
slvr
let dsatOK :: Bool
dsatOK = Maybe Double -> Bool
forall a. Maybe a -> Bool
isNothing (SMTConfig -> Maybe Double
dsatPrecision SMTConfig
cfg)
Bool -> Bool -> Bool
|| Maybe [Char] -> Bool
forall a. Maybe a -> Bool
isJust (SolverCapabilities -> Maybe [Char]
supportsDeltaSat (SMTSolver -> SolverCapabilities
capabilities SMTSolver
slvr))
Bool -> SymbolicT m () -> SymbolicT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
dsatOK (SymbolicT m () -> SymbolicT m ())
-> SymbolicT m () -> SymbolicT m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> SymbolicT m ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> SymbolicT m ()) -> [Char] -> SymbolicT m ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines
[ [Char]
""
, [Char]
"*** Data.SBV: Delta-sat precision is specified."
, [Char]
"*** But the chosen solver (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Solver -> [Char]
forall a. Show a => a -> [Char]
show (SMTSolver -> Solver
name SMTSolver
slvr) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
") does not support"
, [Char]
"*** delta-satisfiability."
]
Result
res <- IO Result -> SymbolicT m Result
forall a. IO a -> SymbolicT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Result -> SymbolicT m Result)
-> IO Result -> SymbolicT m Result
forall a b. (a -> b) -> a -> b
$ State -> IO Result
extractSymbolicSimulationState State
st
[SMTOption]
setOpts <- IO [SMTOption] -> SymbolicT m [SMTOption]
forall a. IO a -> SymbolicT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [SMTOption] -> SymbolicT m [SMTOption])
-> IO [SMTOption] -> SymbolicT m [SMTOption]
forall a b. (a -> b) -> a -> b
$ [SMTOption] -> [SMTOption]
forall a. [a] -> [a]
reverse ([SMTOption] -> [SMTOption]) -> IO [SMTOption] -> IO [SMTOption]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [SMTOption] -> IO [SMTOption]
forall a. IORef a -> IO a
readIORef (State -> IORef [SMTOption]
rSMTOptions State
st)
let SMTProblem{SMTConfig -> SMTLibPgm
smtLibPgm :: SMTProblem -> SMTConfig -> SMTLibPgm
smtLibPgm :: SMTConfig -> SMTLibPgm
smtLibPgm} = SBVRunMode -> QueryContext -> [[Char]] -> Result -> SMTProblem
runProofOn SBVRunMode
rm QueryContext
queryContext [] Result
res
cfg' :: SMTConfig
cfg' = SMTConfig
cfg { solverSetOptions = solverSetOptions cfg ++ setOpts }
pgm :: SMTLibPgm
pgm = SMTConfig -> SMTLibPgm
smtLibPgm SMTConfig
cfg'
IO () -> SymbolicT m ()
forall a. IO a -> SymbolicT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SymbolicT m ()) -> IO () -> SymbolicT m ()
forall a b. (a -> b) -> a -> b
$ IORef SBVRunMode -> SBVRunMode -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (State -> IORef SBVRunMode
runMode State
st) (SBVRunMode -> IO ()) -> SBVRunMode -> IO ()
forall a b. (a -> b) -> a -> b
$ QueryContext -> IStage -> Bool -> SMTConfig -> SBVRunMode
SMTMode QueryContext
qc IStage
IRun Bool
isSAT SMTConfig
cfg
m a -> SymbolicT m a
forall (m :: * -> *) a. Monad m => m a -> SymbolicT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> SymbolicT m a) -> m a -> SymbolicT m a
forall a b. (a -> b) -> a -> b
$ m (m a) -> m a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m a) -> m a) -> m (m a) -> m a
forall a b. (a -> b) -> a -> b
$ IO (m a) -> m (m a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (m a) -> m (m a)) -> IO (m a) -> m (m a)
forall a b. (a -> b) -> a -> b
$ SMTConfig -> State -> [Char] -> (State -> IO (m a)) -> IO (m a)
backend SMTConfig
cfg' State
st (SMTLibPgm -> [Char]
forall a. Show a => a -> [Char]
show SMTLibPgm
pgm) ((State -> IO (m a)) -> IO (m a))
-> (State -> IO (m a)) -> IO (m a)
forall a b. (a -> b) -> a -> b
$ m a -> IO (m a)
forall a. m a -> IO (m a)
forall (m :: * -> *) a. ExtractIO m => m a -> IO (m a)
extractIO (m a -> IO (m a)) -> (State -> m a) -> State -> IO (m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT State m a -> State -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT State m a
userQuery
SMTMode QueryContext
_ IStage
IRun Bool
_ SMTConfig
_ -> [Char] -> SymbolicT m a
forall a. HasCallStack => [Char] -> a
error ([Char] -> SymbolicT m a) -> [Char] -> SymbolicT m a
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [ [Char]
""
, [Char]
"*** Data.SBV: Unsupported nested query is detected."
, [Char]
"***"
, [Char]
"*** Please group your queries into one block. Note that this"
, [Char]
"*** can also arise if you have a call to 'query' not within 'runSMT'"
, [Char]
"*** For instance, within 'sat'/'prove' calls with custom user queries."
, [Char]
"*** The solution is to do the sat/prove part in the query directly."
, [Char]
"***"
, [Char]
"*** While multiple/nested queries should not be necessary in general,"
, [Char]
"*** please do get in touch if your use case does require such a feature,"
, [Char]
"*** to see how we can accommodate such scenarios."
]
SBVRunMode
_ -> SBVRunMode -> SymbolicT m a
forall {a} {a}. Show a => a -> a
invalidQuery SBVRunMode
rm
where invalidQuery :: a -> a
invalidQuery a
rm = [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [ [Char]
""
, [Char]
"*** Data.SBV: Invalid query call."
, [Char]
"***"
, [Char]
"*** Current mode: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
rm
, [Char]
"***"
, [Char]
"*** Query calls are only valid within runSMT/runSMTWith calls,"
, [Char]
"*** and each call to runSMT should have only one query call inside."
]