-----------------------------------------------------------------------------
-- |
-- Module    : Data.SBV.Control.Utils
-- Copyright : (c) Levent Erkok
-- License   : BSD3
-- Maintainer: erkokl@gmail.com
-- Stability : experimental
--
-- Query related utils.
-----------------------------------------------------------------------------

{-# LANGUAGE BangPatterns           #-}
{-# LANGUAGE InstanceSigs           #-}
{-# 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(..), getQueryState, modifyQueryState, getConfig, getObjectives, getUIs
     , getSBVAssertions, getSBVPgm, getObservables
     , checkSat, checkSatUsing, getAllSatResult
     , inNewContext, freshVar, freshVar_
     , 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.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(..)
                              , SolverContext(..), SBool, Objective(..), SolverCapabilities(..), capabilities
                              , Result(..), SMTProblem(..), trueSV, SymVal(..), SBVPgm(..), SMTSolver(..), SBVRunMode(..)
                              , SBVType(..), forceSVArg, RoundingMode(RoundNearestTiesToEven), (.=>)
                              , RCSet(..), QuantifiedBool(..), ArrayModel(..)
                              )

import Data.SBV.Core.Symbolic ( IncState(..), withNewIncState, State(..), svToSV, symbolicEnv, SymbolicT
                              , MonadQuery(..), QueryContext(..), VarContext(..)
                              , registerLabel, svMkSymVar, validationRequested
                              , isSafetyCheckingIStage, isSetupIStage, isRunIStage, IStage(..), QueryT(..)
                              , extractSymbolicSimulationState, MonadSymbolic(..)
                              , UserInputs, getSV, NamedSymVar(..), lookupInput, getUserName'
                              , Name, CnstMap, smtDefGivenName, Inputs(..), ProgInfo(..)
                              , mustIgnoreVar, newInternalVariable
                              )

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.SMTLib2 (setSMTOption)
import Data.SBV.SMT.Utils   ( showTimeoutValue, addAnnotations, alignPlain, debug
                            , mergeSExpr, SBVException(..), recordTranscript, TranscriptMsg(..)
                            , witnessName
                            )

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.Control.Types

import qualified Data.Set as Set (empty, fromList, toAscList)

import qualified Control.Exception as C

import GHC.Stack

-- | 'Data.SBV.Trans.Control.QueryT' as a 'SolverContext'.
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

   internalVariable :: forall a. Kind -> QueryT m (SBV a)
   internalVariable :: forall a. Kind -> QueryT m (SBV a)
internalVariable Kind
k = QueryT m State
forall (m :: * -> *). SolverContext m => m State
contextState QueryT m State -> (State -> QueryT m (SBV a)) -> QueryT m (SBV a)
forall a b. QueryT m a -> (a -> QueryT m b) -> QueryT m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \State
st -> IO (SBV a) -> QueryT m (SBV a)
forall a. IO a -> QueryT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (SBV a) -> QueryT m (SBV a)) -> IO (SBV a) -> QueryT m (SBV a)
forall a b. (a -> b) -> a -> b
$ do
       sv  <- State -> Kind -> IO SV
newInternalVariable State
st Kind
k
       pure $ SBV $ SVal k (Right (cache (const (pure sv))))

   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                = do State{stCfg} <- QueryT m State
forall (m :: * -> *). SolverContext m => m State
contextState
                                send True $ setSMTOption stCfg o

-- | Adding a constraint, possibly with attributes and possibly soft. Only used internally.
-- Use 'constrain' and 'namedConstraint' from user programs.
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 <- (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)

                                      unless (null atts && sv == trueSV) $
                                             send True $ "(" ++ asrt ++ " " ++ addAnnotations atts (show sv)  ++ ")"
   where asrt :: [Char]
asrt | Bool
isSoft = [Char]
"assert-soft"
              | Bool
True   = [Char]
"assert"

-- | Get the current configuration
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

-- | Get the objectives
getObjectives :: (MonadIO m, MonadQuery m) => m [Objective (SV, SV)]
getObjectives :: forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
m [Objective (SV, SV)]
getObjectives = do State{rOptGoals} <- m State
forall (m :: * -> *). MonadQuery m => m State
queryState
                   io $ reverse <$> readIORef rOptGoals

-- | Get the program
getSBVPgm :: (MonadIO m, MonadQuery m) => m SBVPgm
getSBVPgm :: forall (m :: * -> *). (MonadIO m, MonadQuery m) => m SBVPgm
getSBVPgm = do State{spgm} <- m State
forall (m :: * -> *). MonadQuery m => m State
queryState
               io $ readIORef spgm

-- | Get the assertions put in via 'Data.SBV.sAssert'
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{rAsserts} <- m State
forall (m :: * -> *). MonadQuery m => m State
queryState
                      io $ reverse <$> readIORef rAsserts

-- | Generalization of 'Data.SBV.Control.io'
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

-- | Sync-up the external solver with new context we have generated
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
        cfg <- m SMTConfig
forall (m :: * -> *). (MonadIO m, MonadQuery m) => m SMTConfig
getConfig

        -- update global consts to have the new ones
        (newConsts, allConsts) <- liftIO $ do nc <- readIORef (rNewConsts is)
                                              oc <- readIORef rGlobalConsts
                                              let allConsts = CnstMap -> CnstMap -> CnstMap
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union CnstMap
nc CnstMap
oc
                                              writeIORef rGlobalConsts allConsts
                                              pure (nc, allConsts)

        ls  <- io $ do let swap  (b
a, a
b)        = (a
b, b
a)
                           cmp   (a
a, b
_) (a
b, b
_) = a
a a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` a
b
                           arrange (a
i, (b
at, c
rt, b
es)) = ((a
i, b
at, c
rt), b
es)
                       inps        <- reverse <$> readIORef (rNewInps is)
                       ks          <- readIORef (rNewKinds is)
                       tbls        <- map arrange . sortBy cmp . map swap . Map.toList <$> readIORef (rNewTbls is)
                       uis         <- Map.toAscList <$> readIORef (rNewUIs is)
                       as          <- readIORef (rNewAsgns is)
                       constraints <- readIORef (rNewConstraints is)

                       let 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

                       return $ toIncSMTLib cfg progInfo inps ks (allConsts, cnsts) tbls uis as constraints cfg

        mapM_ (send True) $ mergeSExpr ls

-- | Retrieve the query context
getQueryState :: (MonadIO m, MonadQuery m) => m QueryState
getQueryState :: forall (m :: * -> *). (MonadIO m, MonadQuery m) => m QueryState
getQueryState = do state <- m State
forall (m :: * -> *). MonadQuery m => m State
queryState
                   mbQS  <- io $ readIORef (rQueryState state)
                   case 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

-- | Generalization of 'Data.SBV.Control.modifyQueryState'
modifyQueryState :: (MonadIO m, MonadQuery m) => (QueryState -> QueryState) -> m ()
modifyQueryState :: forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
(QueryState -> QueryState) -> m ()
modifyQueryState QueryState -> QueryState
f = do state <- m State
forall (m :: * -> *). MonadQuery m => m State
queryState
                        mbQS  <- io $ readIORef (rQueryState state)
                        case 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

-- | Generalization of 'Data.SBV.Control.inNewContext'
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{rconstMap, rProgInfo} <- m State
forall (m :: * -> *). MonadQuery m => m State
queryState
                      (is, r)  <- io $ withNewIncState st act
                      progInfo <- io $ readIORef rProgInfo
                      syncUpSolver progInfo rconstMap is
                      return r

-- | Generalization of 'Data.SBV.Control.freshVar_'
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)

-- | Generalization of 'Data.SBV.Control.freshVar'
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)

-- | Generalization of 'Data.SBV.Control.queryDebug'
queryDebug :: (MonadIO m, MonadQuery m) => [String] -> m ()
queryDebug :: forall (m :: * -> *). (MonadIO m, MonadQuery m) => [[Char]] -> m ()
queryDebug [[Char]]
msgs = do QueryState{queryConfig} <- m QueryState
forall (m :: * -> *). (MonadIO m, MonadQuery m) => m QueryState
getQueryState
                     io $ do debug queryConfig msgs
                             -- If we're doing a transcript, record it there too
                             recordTranscript (transcript queryConfig) (DebugMsg (unlines msgs))

-- | We need to track sent asserts/check-sat calls so we can issue an extra check-sat call if needed
trackAsserts :: (MonadIO m, MonadQuery m) => String -> m ()
trackAsserts :: forall (m :: * -> *). (MonadIO m, MonadQuery m) => [Char] -> m ()
trackAsserts [Char]
s
   | Bool
isCheckSat Bool -> Bool -> Bool
|| Bool
isAssert
   = do State{rOutstandingAsserts} <- m State
forall (m :: * -> *). MonadQuery m => m State
queryState
        liftIO $ writeIORef rOutstandingAsserts isAssert
   | Bool
True
   = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where trimmedS :: [Char]
trimmedS   = (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace [Char]
s
        isCheckSat :: Bool
isCheckSat = [Char]
"(check-sat" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
trimmedS
        isAssert :: Bool
isAssert   = [Char]
"(assert"    [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
trimmedS

-- | Generalization of 'Data.SBV.Control.ask'
ask :: (MonadIO m, MonadQuery m) => String -> m String
ask :: forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
[Char] -> m [Char]
ask [Char]
s = [Char] -> [[Char]] -> m [Char]
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
[Char] -> [[Char]] -> m [Char]
askIgnoring [Char]
s []

-- | Send a string to the solver, and return the response. Except, if the response
-- is one of the "ignore" ones, keep querying.
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

           [Char] -> m ()
forall (m :: * -> *). (MonadIO m, MonadQuery m) => [Char] -> m ()
trackAsserts [Char]
s

           QueryState{queryAsk, queryRetrieveResponse, queryTimeOutValue} <- m QueryState
forall (m :: * -> *). (MonadIO m, MonadQuery m) => m QueryState
getQueryState

           case 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]
           r <- io $ queryAsk queryTimeOutValue s
           queryDebug ["[RECV] " `alignPlain` r]

           let 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!"]
                      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
                      queryDebug ["[RECV] " `alignPlain` newResponse]
                      loop newResponse

           loop r

-- | Generalization of 'Data.SBV.Control.send'
send :: (MonadIO m, MonadQuery m) => Bool -> String -> m ()
send :: forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Bool -> [Char] -> m ()
send Bool
requireSuccess [Char]
s = do

            [Char] -> m ()
forall (m :: * -> *). (MonadIO m, MonadQuery m) => [Char] -> m ()
trackAsserts [Char]
s

            QueryState{queryAsk, querySend, queryConfig, queryTimeOutValue} <- m QueryState
forall (m :: * -> *). (MonadIO m, MonadQuery m) => m QueryState
getQueryState

            if requireSuccess && supportsCustomQueries (capabilities (solver queryConfig))
               then do r <- io $ queryAsk queryTimeOutValue s

                       case words 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 -- fire and forget. if you use this, you're on your own!
                       queryDebug ["[FIRE] " `alignPlain` s]
                       io $ querySend queryTimeOutValue s

-- | Generalization of 'Data.SBV.Control.retrieveResponse'
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
             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] -> [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]
"(echo " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
synchTag [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"

             queryDebug ["[SYNC] Attempting to synchronize with tag: " ++ synchTag]

             send False cmd

             QueryState{queryRetrieveResponse} <- getQueryState

             let loop [[Char]]
sofar = do
                  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

                  -- strictly speaking SMTLib requires solvers to print quotes around
                  -- echo'ed strings, but they don't always do. Accommodate for that
                  -- here, though I wish we didn't have to.
                  if s == synchTag || show s == synchTag
                     then do queryDebug ["[SYNC] Synchronization achieved using tag: " ++ synchTag]
                             return $ reverse sofar
                     else do queryDebug ["[RECV] " `alignPlain` s]
                             loop (s : sofar)

             loop []

-- | Generalization of 'Data.SBV.Control.getValue'
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 <- (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)

      -- If we're issuing get-value, we gotta make sure there are no outstanding asserts
      -- This can happen if we sent some ourselves. See https://github.com/LeventErkok/sbv/issues/682
      outstandingAsserts <- do State{rOutstandingAsserts} <- queryState
                               liftIO $ readIORef rOutstandingAsserts

      when outstandingAsserts $ do
        queryDebug ["[NOTE] getValue: There are outstanding asserts. Ensuring we're still sat."]
        r <- checkSat
        let bad = [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]
"checkSat" [Char]
"check-sat" [Char]
"one of sat/unsat/unknown" Maybe [[Char]]
forall a. Maybe a
Nothing (CheckSatResult -> [Char]
forall a. Show a => a -> [Char]
show CheckSatResult
r) Maybe [[Char]]
forall a. Maybe a
Nothing
        case r of
          CheckSatResult
Sat    -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          DSat{} -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          CheckSatResult
Unk    -> m ()
bad
          CheckSatResult
Unsat  -> m ()
bad

      cv <- getValueCV Nothing sv
      return $ fromCV cv

-- | A class which allows for sexpr-conversion to functions
class (HasKind r, SatModel r) => SMTFunction fun a r | fun -> a r where
  sexprToArg     :: fun -> [SExpr] -> Maybe a
  smtFunName     :: (MonadIO m, SolverContext 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  #-}

  -- Given the function, figure out a default "return value"
  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

  -- Given the function, determine what its name is and do some sanity checks
  smtFunName fun
f = do st@State{rUIMap} <- m State
forall (m :: * -> *). SolverContext m => m State
contextState
                    uiMap <- liftIO $ readIORef rUIMap
                    nm    <- findName st uiMap

                    -- Read the uiMap again here. Why? Because the act of finding the name might've
                    -- introduced it as an uninterperted name!
                    newUIMap <- liftIO $ readIORef rUIMap
                    case nm `Map.lookup` newUIMap of
                      Maybe (Bool, Maybe [[Char]], SBVType)
Nothing                     -> Map [Char] (Bool, Maybe [[Char]], SBVType)
-> m (([Char], Maybe [[Char]]), Bool)
forall {b} {b}. Map [Char] b -> b
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 -> b
cantFind Map [Char] b
uiMap = [Char] -> b
forall a. HasCallStack => [Char] -> a
error ([Char] -> b) -> [Char] -> b
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
             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)
             liftIO $ forceSVArg r
             SBVPgm asgns <- liftIO $ readIORef spgm


             case S.findIndexR ((== r) . fst) asgns of
               Maybe Int
Nothing -> Map [Char] (Bool, Maybe [[Char]], SBVType) -> m [Char]
forall {b} {b}. Map [Char] b -> b
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} {b}. Map [Char] b -> b
cantFind Map [Char] (Bool, Maybe [[Char]], SBVType)
uiMap

  sexprToFun fun
f ([Char]
s, SExpr
e) = do 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) =>
fun -> m (([Char], Maybe [[Char]]), Bool)
forall (m :: * -> *).
(MonadIO m, SolverContext m) =>
fun -> m (([Char], Maybe [[Char]]), Bool)
smtFunName fun
f
                           mbRes <- case parseSExprFunction 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} {b}. Show a => a -> b
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 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)
                                                            return $ mbPVS >>= convert
                           pure $ maybe (Left s) Right 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 -> b
bailOut a
nm = [Char] -> b
forall a. HasCallStack => [Char] -> a
error ([Char] -> b) -> [Char] -> b
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!"
                                       ]

-- | Pointwise function value extraction. If we get unlucky and can't parse z3's output (happens
-- when we have all booleans and z3 decides to spit out an expression), just brute force our
-- way out of it. Note that we only do this if we have a pure boolean type, as otherwise we'd blow
-- up. And I think it'll only be necessary then, I haven't seen z3 try anything smarter in other scenarios.
pointWiseExtract ::  forall m. (MonadIO m, MonadQuery m) => String -> SBVType -> m (Maybe ([([SExpr], SExpr)], SExpr))
pointWiseExtract :: forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
[Char] -> SBVType -> m (Maybe ([([SExpr], SExpr)], SExpr))
pointWiseExtract [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

                          r <- [Char] -> m [Char]
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
[Char] -> m [Char]
ask [Char]
cmd

                          parse r bad $ \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 vs <- m [([SExpr], SExpr)]
getBVals
               -- Pick the value that will give us the fewer entries
               let (trues, falses) = partition (\([SExpr]
_, SExpr
v) -> SExpr -> Bool
isTrueSExpr SExpr
v) vs
               return $ Just $ if length trues <= length falses
                               then (trues,  falseSExpr)
                               else (falses, trueSExpr)

-- | For saturation purposes, get a proper argument. The forall quantification
-- is safe here since we only use in smtFunSaturate calls, which looks at the
-- kind stored inside only.
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))

-- | Functions of arity 1
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))

-- | Functions of arity 2
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)))

-- | Functions of arity 3
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)))

-- | Functions of arity 4
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)))

-- | Functions of arity 5
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)))

-- | Functions of arity 6
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)))

-- | Functions of arity 7
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)))

-- | Functions of arity 8
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)))

-- | Curried functions of arity 2
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))
                       )

-- | Curried functions of arity 3
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))
                       )

-- | Curried functions of arity 4
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))
                       )

-- | Curried functions of arity 5
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))
                       )

-- | Curried functions of arity 6
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))
                       )

-- | Curried functions of arity 7
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))
                       )

-- | Curried functions of arity 8
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))
                       )

-- Turn "((F (lambda ((x!1 Int)) (+ 3 (* 2 x!1)))))"
-- into something more palatable.
-- If we can't do that, we simply return the input unchanged
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

-- | Generalization of 'Data.SBV.Control.getFunction'
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 ((nm, args), isCurried) <- fun -> m (([Char], Maybe [[Char]]), Bool)
forall fun a r (m :: * -> *).
(SMTFunction fun a r, MonadIO m, SolverContext m) =>
fun -> m (([Char], Maybe [[Char]]), Bool)
forall (m :: * -> *).
(MonadIO m, SolverContext m) =>
fun -> m (([Char], Maybe [[Char]]), Bool)
smtFunName fun
f

                   let 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]
-> [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

                   r <- ask cmd

                   parse r bad $ \case EApp [EApp [ECon [Char]
o, SExpr
e]] | [Char]
o [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
nm -> do 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 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 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 mbPVS >>= 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

-- | Generalization of 'Data.SBV.Control.getUninterpretedValue'
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 <- (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  = SV -> [Char]
forall a. Show a => a -> [Char]
show SV
sv
                                        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]
-> [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

                                    r <- ask cmd

                                    parse r bad $ \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.'"
                                                 ]

-- | Get the value of a term, but in CV form. Used internally. The model-index, in particular is extremely Z3 specific!
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)

-- | "Make up" a CV for this type. Like zero, but smarter.
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'                -- why not?
        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 -- why not? Arguably, could be the universal set
        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     -- why not?
        cvt (KArray  Kind
_  Kind
k2)  = ArrayModel CVal CVal -> CVal
CArray (ArrayModel CVal CVal -> CVal) -> ArrayModel CVal CVal -> CVal
forall a b. (a -> b) -> a -> b
$ [(CVal, CVal)] -> CVal -> ArrayModel CVal CVal
forall a b. [(a, b)] -> b -> ArrayModel a b
ArrayModel [] (Kind -> CVal
cvt Kind
k2)

        -- Tricky case of uninterpreted
        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
0, [Char]
c)
        uninterp [Char]
_ (Just [])    = [Char] -> CVal
forall a. HasCallStack => [Char] -> a
error [Char]
"defaultKindedValue: enumerated kind with no constructors!"

        -- A completely uninterpreted sort, i.e., no elements. Return the witness element for it.
        uninterp [Char]
s Maybe [[Char]]
Nothing      = (Maybe Int, [Char]) -> CVal
CUserSort (Maybe Int
forall a. Maybe a
Nothing, [Char] -> [Char]
witnessName [Char]
s)

-- | Go from an SExpr directly to a value
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

-- | Recover a given solver-printed value with a possible interpretation
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] -> [Char]
simplifyECon [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
                           KArray Kind
k1 Kind
k2                        -> 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
$ ArrayModel CVal CVal -> CVal
CArray    (ArrayModel CVal CVal -> CVal) -> ArrayModel CVal CVal -> CVal
forall a b. (a -> b) -> a -> b
$ Kind -> Kind -> SExpr -> ArrayModel CVal CVal
interpretArray    Kind
k1 Kind
k2 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

        -- Make sure strings are really strings
        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", SExpr
v, SExpr
_])      = SExpr -> [CVal]
walk SExpr
v
                walk (ECon [Char]
"seq.empty")            = []
                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

        -- Essentially treat sets as functions, since we do allow for store associations
        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]  -- deletions from universal
                                  | 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]  -- additions to empty

                 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
                                                                ]

                      -- | Convert a sexpr of n-tuple to constituent sexprs. Z3 and CVC4 differ here on how they
                      -- present tuples, so we accommodate both:
                      args :: [SExpr]
args = SExpr -> [SExpr]
try SExpr
te
                        where -- Z3 way
                              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
                              -- CVC4 way
                              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
                                                                  ]

        -- SMaybe
        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
                                                                                                         ]
        -- CVC4 puts in full ascriptions, handle those:
        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)

        -- SEither
        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
                                                                                                               ]

        -- CVC4 puts full ascriptions:
        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)

        -- Intervals, for dReal
        interpretInterval :: SExpr -> Maybe CV
interpretInterval SExpr
expr = case SExpr
expr of
                                   EApp [ECon [Char]
"interval", SExpr
lo, SExpr
hi] -> do vlo <- SExpr -> Maybe (RealPoint Rational)
getBorder SExpr
lo
                                                                        vhi <- getBorder hi
                                                                        pure $ CV KReal (CAlgReal (AlgInterval vlo 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

        -- Essentially treat sets as functions, since we do allow for store associations
        interpretArray :: Kind -> Kind -> SExpr -> ArrayModel CVal CVal
interpretArray Kind
k1 Kind
k2 SExpr
expr = case SExpr -> Maybe (Either [Char] ([([SExpr], SExpr)], SExpr))
parseSExprFunction SExpr
expr of
                                      Just (Right ([([SExpr], SExpr)], SExpr)
ascs) -> ([([SExpr], SExpr)], SExpr) -> ArrayModel CVal CVal
decode ([([SExpr], SExpr)], SExpr)
ascs
                                      Maybe (Either [Char] ([([SExpr], SExpr)], SExpr))
_                 -> [Char] -> ArrayModel CVal 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.interpretArray: 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
k
                                         , [Char]
"*** Received: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SExpr -> [Char]
forall a. Show a => a -> [Char]
show SExpr
e
                                         , [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!"
                                         ]

                 decode :: ([([SExpr], SExpr)], SExpr) -> ArrayModel CVal CVal
decode ([([SExpr], SExpr)]
args, SExpr
d) = [(CVal, CVal)] -> CVal -> ArrayModel CVal CVal
forall a b. [(a, b)] -> b -> ArrayModel a b
ArrayModel [(Kind -> [SExpr] -> CVal
cvt Kind
k1 [SExpr]
l, Kind -> [SExpr] -> CVal
cvt Kind
k2 [SExpr
r]) | ([SExpr]
l, SExpr
r) <- [([SExpr], SExpr)]
args] (Kind -> [SExpr] -> CVal
cvt Kind
k2 [SExpr
d])
                   where cvt :: Kind -> [SExpr] -> CVal
cvt Kind
ek [SExpr
v] = case Kind -> SExpr -> Maybe CV
recoverKindedValue Kind
ek SExpr
v of
                                         Just (CV Kind
_ CVal
x) -> CVal
x
                                         Maybe CV
_             -> [Char] -> CVal
forall a. [Char] -> a
tbd ([Char] -> CVal) -> [Char] -> CVal
forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot convert value: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SExpr -> [Char]
forall a. Show a => a -> [Char]
show SExpr
v
                         cvt Kind
_ [SExpr]
vs   = [Char] -> CVal
forall a. [Char] -> a
tbd ([Char] -> CVal) -> [Char] -> CVal
forall a b. (a -> b) -> a -> b
$ [Char]
"Unexpected function-like-value as array index" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [SExpr] -> [Char]
forall a. Show a => a -> [Char]
show [SExpr]
vs

-- | Generalization of 'Data.SBV.Control.getValueCV'
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 cfg <- m SMTConfig
forall (m :: * -> *). (MonadIO m, MonadQuery m) => m SMTConfig
getConfig
       if not (supportsApproxReals (capabilities (solver cfg)))
          then getValueCVHelper mbi s
          else do send True "(set-option :pp.decimal false)"
                  rep1 <- getValueCVHelper mbi s
                  send True   "(set-option :pp.decimal true)"
                  send True $ "(set-option :pp.decimal_precision " ++ show (printRealPrec cfg) ++ ")"
                  rep2 <- getValueCVHelper mbi s

                  let 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 (rep1, 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

-- | Retrieve value from the solver
extractValue :: forall m. (MonadIO m, MonadQuery m) => Maybe Int -> String -> Kind -> m CV
extractValue :: forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
Maybe Int -> [Char] -> Kind -> m CV
extractValue 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]
"get-value" [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

       r <- [Char] -> m [Char]
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
[Char] -> m [Char]
ask [Char]
cmd

       let 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

       parse r bad $ \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

-- | Generalization of 'Data.SBV.Control.getUICVal'
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)

-- | Generalization of 'Data.SBV.Control.getUIFunCVAssoc'
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

  r <- [Char] -> m [Char]
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
[Char] -> m [Char]
ask [Char]
cmd

  let (ats, rt) = case 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)]
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]
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 = Kind -> SExpr -> Maybe CV
recoverKindedValue Kind
rt

      -- if we fail to parse, we'll return this answer as the string
      fallBack = [Char] -> [Char] -> Bool -> Maybe [[Char]] -> [Char]
trimFunctionResponse [Char]
r [Char]
nm Bool
isCurried Maybe [[Char]]
mbArgs

      -- In case we end up in the pointwise scenario, boolify the result
      -- as that's the only type we support here.
      tryPointWise = do 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 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)

  parse r bad $ \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

-- | Generalization of 'Data.SBV.Control.checkSat'
checkSat :: (MonadIO m, MonadQuery m) => m CheckSatResult
checkSat :: forall (m :: * -> *). (MonadIO m, MonadQuery m) => m CheckSatResult
checkSat = do cfg <- m SMTConfig
forall (m :: * -> *). (MonadIO m, MonadQuery m) => m SMTConfig
getConfig
              checkSatUsing $ satCmd cfg

-- | Generalization of 'Data.SBV.Control.checkSatUsing'
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

                           -- Sigh.. Ignore some of the pesky warnings. We only do it as an exception here.
                           ignoreList :: [[Char]]
ignoreList = [[Char]
"WARNING: optimization with quantified constraints is not supported"]

                       r <- [Char] -> [[Char]] -> m [Char]
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
[Char] -> [[Char]] -> m [Char]
askIgnoring [Char]
cmd [[Char]]
ignoreList

                       -- query for the precision if supported
                       let getPrecision = do cfg <- m SMTConfig
forall (m :: * -> *). (MonadIO m, MonadQuery m) => m SMTConfig
getConfig
                                             case supportsDeltaSat (capabilities (solver 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

                       parse r bad $ \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

-- | What are the top level inputs? Trackers are returned as top level existentials
getTopLevelInputs :: (MonadIO m, MonadQuery m) => m UserInputs
getTopLevelInputs :: forall (m :: * -> *). (MonadIO m, MonadQuery m) => m UserInputs
getTopLevelInputs = do State{rinps}                     <- m State
forall (m :: * -> *). MonadQuery m => m State
queryState
                       Inputs{userInputs, internInputs} <- liftIO $ readIORef rinps

                       pure $ userInputs <> internInputs

-- | Get observables, i.e., those explicitly labeled by the user with a call to 'Data.SBV.observe'.
getObservables :: (MonadIO m, MonadQuery m) => m [(Name, CV)]
getObservables :: forall (m :: * -> *). (MonadIO m, MonadQuery m) => m [(Text, CV)]
getObservables = do State{rObservables} <- m State
forall (m :: * -> *). MonadQuery m => m State
queryState

                    rObs <- liftIO $ readIORef rObservables

                    -- This intentionally reverses the result; since 'rObs' stores in reversed order
                    let 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 <- 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 f cv
                                                          then walk os ((n, cv) : sofar)
                                                          else walk os            sofar

                    walk (F.toList rObs) []

-- | Get UIs, both constants and functions. This call returns both the before and after query ones.
-- Generalization of 'Data.SBV.Control.getUIs'.
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{rUIMap, rDefns, rIncState} <- m State
forall (m :: * -> *). MonadQuery m => m State
queryState
            -- NB. no need to worry about new-defines, because we don't allow definitions once query mode starts
            defines <- do allDefs <- io $ readIORef rDefns
                          pure $ mapMaybe (smtDefGivenName . fst) allDefs

            prior <- io $ readIORef rUIMap
            new   <- io $ readIORef rIncState >>= readIORef . rNewUIs
            return $ nub $ sort [p | p@(n, _) <- Map.toList prior ++ Map.toList new, n `notElem` defines]

-- | Return all satisfying models.
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.."]

                     cfg <- m SMTConfig
forall (m :: * -> *). (MonadIO m, MonadQuery m) => m SMTConfig
getConfig
                     unless (supportsCustomQueries (capabilities (solver cfg))) $
                        error $ unlines [ ""
                                        , "*** Data.SBV: Backend solver " ++ show (name (solver cfg)) ++ " does not support custom queries."
                                        , "***"
                                        , "*** Custom query support is needed for allSat functionality."
                                        , "*** Please use a solver that supports this feature."
                                        ]

                     topState@State{rUsedKinds, rPartitionVars, rProgInfo} <- queryState

                     progInfo <- liftIO $ readIORef rProgInfo
                     ki       <- liftIO $ readIORef rUsedKinds

                     allModelInputs    <- getTopLevelInputs
                     allUninterpreteds <- getUIs
                     partitionVars     <- liftIO $ readIORef rPartitionVars

                      -- Functions have at least two kinds in their type and all components must be "interpreted"
                     let allUiFuns = [([Char], (Bool, Maybe [[Char]], SBVType))
u | SMTConfig -> Bool
allSatTrackUFs SMTConfig
cfg                                              -- config says consider UIFs
                                        , 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  -- get the function ones
                                        , Bool -> Bool
not (SMTConfig -> [Char] -> Bool
mustIgnoreVar SMTConfig
cfg [Char]
nm)                                      -- make sure they aren't explicitly ignored
                                     ]

                         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 -- non-function ones
                                        , Bool -> Bool
not (SMTConfig -> [Char] -> Bool
mustIgnoreVar SMTConfig
cfg [Char]
nm)                                      -- make sure they aren't explicitly ignored
                                     ]

                         -- We can only "allSat" if all component types themselves are interpreted. (Otherwise
                         -- there is no way to reflect back the values to the solver.)
                         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

                     uiFuns <- reverse <$> collectAcceptable allUiFuns []
                     _      <- collectAcceptable allUiRegs [] -- only done to get the queryDebug output. Actual result not needed/used

                     -- If there are uninterpreted functions, arrange so that z3's pretty-printer flattens things out
                     -- as cex's tend to get larger
                     unless (null uiFuns) $
                        let solverCaps = SMTSolver -> SolverCapabilities
capabilities (SMTConfig -> SMTSolver
solver SMTConfig
cfg)
                        in case supportsFlattenedModels 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]
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]

                     unless (null usorts) $ queryDebug [ "*** SBV.allSat: Uninterpreted sorts present: " ++ unwords usorts
                                                       , "***             SBV will use equivalence classes to generate all-satisfying instances."
                                                       ]

                     -- Drop the things that are not model vars or internal
                     let 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 = 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 = 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

                     -- We can go fast using the disjoint model trick if things are simple enough:
                     --     - No uninterpreted functions (uninterpreted values are OK)
                     --     - No uninterpreted sorts
                     --     - No quantifiers
                     --
                     -- Why can't we support the above?
                     --     - Uninterpreted functions: There is no (standard) way to define a function as a literal in SMTLib.
                     --     Some solvers support lambda, but this isn't common/reliable yet.
                     --     - Uninterpreted sort: There's no way to access the value the solver assigns to an uninterpreted sort.
                     --     - Quantifiers: Too complicated!
                     --
                     -- So, if these two things are present, we go the "slow" route, by repeatedly rejecting the
                     -- previous model and asking for a new one. If they don't exist (which is the common case anyhow)
                     -- we use an idea due to z3 folks <http://theory.stanford.edu/%7Enikolaj/programmingz3.html#sec-blocking-evaluations>
                     -- which splits the search space into disjoint models and can produce results much more quickly.
                     let 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 { allSatMaxModelCountReached :: Bool
allSatMaxModelCountReached  = Bool
False
                                              , allSatSolverReturnedUnknown :: Bool
allSatSolverReturnedUnknown = Bool
False
                                              , allSatSolverReturnedDSat :: Bool
allSatSolverReturnedDSat    = Bool
False
                                              , allSatResults :: [SMTResult]
allSatResults               = []
                                              }

                     -- partition-variables are only supported if simple
                     case 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 isSimple
                        then do let mkVar :: (String, (Bool, Maybe [String], SBVType)) -> IO (SVal, NamedSymVar)
                                    mkVar ([Char]
nm, (Bool
_, Maybe [[Char]]
_, SBVType [Kind
k])) = do sv <- State -> Kind -> SBVExpr -> IO SV
newExpr State
topState Kind
k (Op -> [SV] -> SBVExpr
SBVApp ([Char] -> Op
Uninterpreted [Char]
nm) [])
                                                                         let 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  = SV -> Text -> NamedSymVar
NamedSymVar SV
sv ([Char] -> Text
T.pack [Char]
nm)
                                                                         pure (sval, 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
                                uiVars <- io $ S.fromList <$> mapM mkVar allUiRegs
                                fastAllSat                                        allModelInputs (uiVars S.>< extractVars) (uiVars S.>< vars) cfg start
                        else    loop       topState (allUiFuns, uiFuns) allUiRegs allModelInputs                                        vars  cfg 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
                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)
                go result vars
                (found, sofar, _, extra) <- io $ readIORef result
                finalize (found+1) cfg sofar extra
                pure 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 (have, _, exitLoop, _) <- 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
                                             pure $ not (exitLoop || haveEnough 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 mbCont <- do (have, sofar, exitLoop, _) <- 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 exitLoop
                                                then pure Nothing
                                                else case allSatMaxModelCount 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 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]

                                    cs <- m CheckSatResult
forall (m :: * -> *). (MonadIO m, MonadQuery m) => m CheckSatResult
checkSat

                                    case 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 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 <- 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
                                                                                                   return (sv, (n, (sval, cv)))) Seq (SVal, NamedSymVar)
extractVars

                                                   bindings <- let 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 <- 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
                                                                                                                         return (i, cv)
                                                               in if validationRequested cfg
                                                                  then Just <$> mapM grab allInputs
                                                                  else return Nothing

                                                   obsvs <- getObservables

                                                   let 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 { 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 = SMTConfig -> SMTModel -> SMTResult
Satisfiable SMTConfig
cfg SMTModel
model

                                                   io $ modifyIORef' finalResult $ \(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)

                                                   when (allSatPrintAlong cfg) $ do
                                                        io $ putStrLn $ "Solution #" ++ show cnt ++ ":"
                                                        io $ putStrLn $ showModel cfg model

                                                   let 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
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 sva <- State -> SVal -> IO SV
svToSV State
st SVal
a
                                                                                   svb <- svToSV st b
                                                                                   newExpr st KBool (SBVApp (IEEEFP FP_ObjEqual) [sva, svb])

                                                       reject, accept :: (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 = 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)
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
                                                                send True "(pop 1)"
                                                                pure r

                                                   forM_ [0 .. length terms - 1] $ \Int
i -> do
                                                        sc <- m Bool
shouldContinue
                                                        when sc $ do case S.splitAt i 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!"

         -- All sat loop. This is slower, as it implements the reject-the-previous model and loop around logic. But
         -- it can handle uninterpreted sorts; so we keep it here as a fall-back.
         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]

                        cs <- m CheckSatResult
forall (m :: * -> *). (MonadIO m, MonadQuery m) => m CheckSatResult
checkSat

                        let endMsg = Int -> SMTConfig -> AllSatResult -> Maybe [Char] -> m ()
forall {f :: * -> *} {a}.
(MonadIO f, Eq a, Num a, Show a) =>
a -> SMTConfig -> AllSatResult -> Maybe [Char] -> f ()
finalize Int
cnt SMTConfig
cfg AllSatResult
sofar

                        case 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 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 <- 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
                                                                                       return (sv, (n, (sval, cv)))) Seq (SVal, NamedSymVar)
vars

                                       let getUIFun ui :: ([Char], (Bool, Maybe [[Char]], SBVType))
ui@([Char]
nm, (Bool
isCurried, Maybe [[Char]]
_, SBVType
t)) = do 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
                                                                                    return (nm, (isCurried, t, cvs))
                                       uiFunVals <- mapM getUIFun allUiFuns

                                       uiRegVals <- 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) allUiRegs

                                       obsvs <- getObservables

                                       bindings <- let 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 <- 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
                                                                                                             return (i, cv)
                                                   in if validationRequested cfg
                                                         then Just <$> mapM grab allInputs
                                                         else return Nothing

                                       let 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 = SMTConfig -> SMTModel -> SMTResult
Satisfiable SMTConfig
cfg SMTModel
model

                                           (interpreteds, uninterpreteds) = S.partition (not . isFree . kindOf . fst) (fmap (snd . snd) assocs)

                                           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 = [([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) [])

                                           -- For each interpreted variable, figure out the model equivalence
                                           -- NB. When the kind is floating, we *have* to be careful, since +/- zero, and NaN's
                                           -- and equality don't get along!
                                           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 sva <- State -> SVal -> IO SV
svToSV State
st SVal
a
                                                                        svb <- svToSV st b
                                                                        newExpr st KBool (SBVApp (IEEEFP FP_ObjEqual) [sva, svb])

                                           -- For each uninterpreted constant, use equivalence class
                                           uninterpretedEqs :: [SVal]
                                           uninterpretedEqs = ([SVal] -> [SVal]) -> [[SVal]] -> [SVal]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [SVal] -> [SVal]
pwDistinct         -- Assert that they are pairwise distinct
                                                            ([[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)  -- Only need this class if it has at least two members
                                                            ([[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)                -- throw away values, we only need svals
                                                            ([[(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)      -- make sure they belong to the same sort and have the same value
                                                            ([(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                   -- sort them according to their CV (i.e., sort/value)
                                                            ([(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]

                                           -- For each uninterpreted function, create a disqualifying equation
                                           -- We do this rather brute-force, since we need to create a new function
                                           -- and do an existential assertion.
                                           uninterpretedReject :: Maybe [String]
                                           uninterpretedFuns   :: [String]
                                           (uninterpretedReject, uninterpretedFuns) = (uiReject, concat defs)
                                               where 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

                                                     (rejects, defs) = unzip [mkNotEq ui | ui@(nm, _) <- uiFunVals, nm `elem` uiFunsToReject]

                                                     -- Otherwise, we have things to refute, go for it if we have a good interpretation for it
                                                     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"

                                                             -- rounding mode doesn't matter here, just pick one
                                                             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]
interpretedEqs [SVal] -> [SVal] -> [SVal]
forall a. [a] -> [a] -> [a]
++ [SVal]
uninterpretedEqs

                                           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

                                       when (allSatPrintAlong cfg) $ do
                                         io $ putStrLn $ "Solution #" ++ show cnt ++ ":"
                                         io $ putStrLn $ showModel cfg model

                                       let resultsSoFar = AllSatResult
sofar { allSatResults = m : allSatResults sofar }

                                           -- This is clunky, but let's not generate a rejector unless we really need it
                                           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

                                       -- Send function disequalities, if any:
                                       if not needMoreIterations
                                          then go (cnt+1) resultsSoFar
                                          else do let 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]
"define-fun " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
uiFunRejector [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" () Bool "

                                                      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]
"        ))"]
                                                  rejectFuncs <- case 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

                                                  -- send the disallow clause and the uninterpreted rejector:
                                                  case (disallow, 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)  -> -- This is where it gets ugly. We have an SBV and a string and we need to "or" them.
                                                                           -- But we need a way to force 'd' to be produced. So, go ahead and force it:
                                                                           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  -- NB: Redundant, but it makes sure the corresponding constraint gets shown
                                                                              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)
                                                                              send True $ "(assert (or " ++ f ++ " " ++ show svd ++ "))"
                                                                              go (cnt+1) resultsSoFar

-- | Generalization of 'Data.SBV.Control.getUnsatAssumptions'
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

        r <- [Char] -> m [Char]
forall (m :: * -> *).
(MonadIO m, MonadQuery m) =>
[Char] -> m [Char]
ask [Char]
cmd

        -- If unsat-cores are enabled, z3 might end-up printing an assumption that wasn't
        -- in the original list of assumptions for `check-sat-assuming`. So, we walk over
        -- and ignore those that weren't in the original list, and put a warning for those
        -- we couldn't find.
        let 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

        parse r bad $ \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 a query action, typically a command call to the underlying SMT solver.
-- The duration is in microseconds (@1\/10^6@ seconds). If the duration
-- is negative, then no timeout is imposed. When specifying long timeouts, be careful not to exceed
-- @maxBound :: Int@. (On a 64 bit machine, this bound is practically infinite. But on a 32 bit
-- machine, it corresponds to about 36 minutes!)
--
-- Semantics: The call @timeout n q@ causes the timeout value to be applied to all interactive calls that take place
-- as we execute the query @q@. That is, each call that happens during the execution of @q@ gets a separate
-- time-out value, as opposed to one timeout value that limits the whole query. This is typically the intended behavior.
-- It is advisable to apply this combinator to calls that involve a single call to the solver for
-- finer control, as opposed to an entire set of interactions. However, different use cases might call for different scenarios.
--
-- If the solver responds within the time-out specified, then we continue as usual. However, if the backend solver times-out
-- using this mechanism, there is no telling what the state of the solver will be. Thus, we raise an error in this case.
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})
                 r <- m a
q
                 modifyQueryState (\QueryState
qs -> QueryState
qs {queryTimeOutValue = Nothing})
                 return r

-- | Bail out if a parse goes bad
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

-- | Generalization of 'Data.SBV.Control.unexpected'
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
        -- empty the response channel first
        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)

        cfg <- getConfig

        let 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 $ C.throwIO exc

-- | Convert a query result to an SMT Problem
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 [([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 [([Char], (Bool, Maybe [[Char]], SBVType))]
uis [(SMTDef, SBVType)]
defns SBVPgm
pgm Seq (Bool, [([Char], [Char])], SV)
cstrs SV
o }

-- | Generalization of 'Data.SBV.Control.executeQuery'
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
     st <- SymbolicT m State
forall (m :: * -> *). MonadSymbolic m => m State
symbolicEnv
     rm <- liftIO $ readIORef (runMode st)

     -- Make sure the phases match:
     () <- liftIO $ case (queryContext, rm) of
                      (QueryContext
QueryInternal, SBVRunMode
_)                                -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- no worries, internal
                      (QueryContext
QueryExternal, SMTMode QueryContext
QueryExternal IStage
ISetup Bool
_ SMTConfig
_) -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- legitimate runSMT call
                      (QueryContext, SBVRunMode)
_                                                 -> SBVRunMode -> IO ()
forall {a} {b}. Show a => a -> b
invalidQuery SBVRunMode
rm

     case rm of
        -- Transitioning from setup
        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

                  -- make sure if we have dsat precision, then solver supports it
                  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."
                                     ]

                  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
                  setOpts <- liftIO $ reverse <$> readIORef (rSMTOptions st)

                  let SMTProblem{smtLibPgm} = runProofOn rm queryContext [] res
                      cfg' = SMTConfig
cfg { solverSetOptions = solverSetOptions cfg ++ setOpts }
                      pgm  = SMTConfig -> SMTLibPgm
smtLibPgm SMTConfig
cfg'

                  liftIO $ writeIORef (runMode st) $ SMTMode qc IRun isSAT cfg

                  let terminateSolver Maybe SomeException
maybeForwardedException = do
                         qs <- IORef (Maybe QueryState) -> IO (Maybe QueryState)
forall a. IORef a -> IO a
readIORef (IORef (Maybe QueryState) -> IO (Maybe QueryState))
-> IORef (Maybe QueryState) -> IO (Maybe QueryState)
forall a b. (a -> b) -> a -> b
$ State -> IORef (Maybe QueryState)
rQueryState State
st
                         case qs of
                           Maybe QueryState
Nothing                         -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                           Just QueryState{Maybe SomeException -> IO ()
queryTerminate :: Maybe SomeException -> IO ()
queryTerminate :: QueryState -> Maybe SomeException -> IO ()
queryTerminate} -> Maybe SomeException -> IO ()
queryTerminate Maybe SomeException
maybeForwardedException

                  lift $ join $ liftIO $ C.mask $ \forall a. IO a -> IO a
restore -> do
                    r <- IO (m a) -> IO (m a)
forall a. IO a -> IO a
restore (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)) -> m a -> IO (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)
                          IO (m a) -> (SomeException -> IO (m a)) -> IO (m a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`C.catch` \SomeException
e -> Maybe SomeException -> IO ()
terminateSolver (SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e) IO () -> IO (m a) -> IO (m a)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> IO (m a)
forall e a. (HasCallStack, Exception e) => e -> IO a
C.throwIO (SomeException
e :: C.SomeException)
                    terminateSolver Nothing
                    return r

        -- Already in a query, in theory we can just continue, but that causes use-case issues
        -- so we reject it. TODO: Review if we should actually support this. The issue arises with
        -- expressions like this:
        --
        -- In the following t0's output doesn't get recorded, as the output call is too late when we get
        -- here. (The output field isn't "incremental.") So, t0/t1 behave differently!
        --
        --   t0 = satWith z3{verbose=True, transcript=Just "t.smt2"} $ query (return (false::SBool))
        --   t1 = satWith z3{verbose=True, transcript=Just "t.smt2"} $ ((return (false::SBool)) :: Predicate)
        --
        -- Also, not at all clear what it means to go in an out of query mode:
        --
        -- r = runSMTWith z3{verbose=True} $ do
        --         a' <- sInteger "a"
        --
        --        (a, av) <- query $ do _ <- checkSat
        --                              av <- getValue a'
        --                              return (a', av)
        --
        --        liftIO $ putStrLn $ "Got: " ++ show av
        --        -- constrain $ a .> literal av + 1      -- Can't do this since we're "out" of query. Sigh.
        --
        --        bv <- query $ do constrain $ a .> literal av + 1
        --                         _ <- checkSat
        --                         getValue a
        --
        --        return $ a' .== a' + 1
        --
        -- This would be one possible implementation, alas it has the problems above:
        --
        --    SMTMode IRun _ _ -> liftIO $ evalStateT userQuery st
        --
        -- So, we just reject it.

        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."
                                              ]

        -- Otherwise choke!
        SBVRunMode
_ -> SBVRunMode -> SymbolicT m a
forall {a} {b}. Show a => a -> b
invalidQuery SBVRunMode
rm

  where invalidQuery :: a -> b
invalidQuery a
rm = [Char] -> b
forall a. HasCallStack => [Char] -> a
error ([Char] -> b) -> [Char] -> b
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."
                                          ]

{- HLint ignore module          "Reduce duplication" -}
{- HLint ignore getAllSatResult "Use forM_"          -}