{-# LANGUAGE Safe #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE PatternGuards #-}
module SimpleSMT
(
Solver(..)
, newSolver
, ackCommand
, simpleCommand
, simpleCommandMaybe
, loadFile
, loadString
, SExpr(..)
, showsSExpr, ppSExpr, readSExpr
, Logger(..)
, newLogger
, withLogLevel
, logMessageAt
, logIndented
, setLogic, setLogicMaybe
, setOption, setOptionMaybe
, produceUnsatCores
, named
, push, pushMany
, pop, popMany
, inNewScope
, declare
, declareFun
, declareDatatype
, define
, defineFun
, assert
, check
, Result(..)
, getExprs, getExpr
, getConsts, getConst
, getUnsatCore
, Value(..)
, sexprToVal
, fam
, fun
, const
, tInt
, tBool
, tReal
, tArray
, tBits
, int
, real
, bool
, bvBin
, bvHex
, value
, not
, and
, andMany
, or
, orMany
, xor
, implies
, ite
, eq
, distinct
, gt
, lt
, geq
, leq
, bvULt
, bvULeq
, bvSLt
, bvSLeq
, add
, addMany
, sub
, neg
, mul
, abs
, div
, mod
, divisible
, realDiv
, toInt
, toReal
, concat
, extract
, bvNot
, bvNeg
, bvAnd
, bvXOr
, bvOr
, bvAdd
, bvSub
, bvMul
, bvUDiv
, bvURem
, bvSDiv
, bvSRem
, bvShl
, bvLShr
, bvAShr
, signExtend
, zeroExtend
, select
, store
) where
import Prelude hiding (not, and, or, abs, div, mod, concat, const)
import qualified Prelude as P
import Data.Char(isSpace)
import Data.List(unfoldr,intersperse)
import Data.Bits(testBit)
import Data.IORef(newIORef, atomicModifyIORef, modifyIORef', readIORef,
writeIORef)
import System.Process(runInteractiveProcess, waitForProcess)
import System.IO (hFlush, hGetLine, hGetContents, hPutStrLn, stdout, hClose)
import System.Exit(ExitCode)
import qualified Control.Exception as X
import Control.Concurrent(forkIO)
import Control.Monad(forever,when)
import Text.Read(readMaybe)
import Data.Ratio((%), numerator, denominator)
import Numeric(showHex, readHex, showFFloat)
data Result = Sat
| Unsat
| Unknown
deriving (Result -> Result -> Bool
(Result -> Result -> Bool)
-> (Result -> Result -> Bool) -> Eq Result
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Result -> Result -> Bool
$c/= :: Result -> Result -> Bool
== :: Result -> Result -> Bool
$c== :: Result -> Result -> Bool
Eq,Int -> Result -> ShowS
[Result] -> ShowS
Result -> String
(Int -> Result -> ShowS)
-> (Result -> String) -> ([Result] -> ShowS) -> Show Result
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Result] -> ShowS
$cshowList :: [Result] -> ShowS
show :: Result -> String
$cshow :: Result -> String
showsPrec :: Int -> Result -> ShowS
$cshowsPrec :: Int -> Result -> ShowS
Show)
data Value = Bool !Bool
| Int !Integer
| Real !Rational
| Bits !Int !Integer
| Other !SExpr
deriving (Value -> Value -> Bool
(Value -> Value -> Bool) -> (Value -> Value -> Bool) -> Eq Value
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c== :: Value -> Value -> Bool
Eq,Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
(Int -> Value -> ShowS)
-> (Value -> String) -> ([Value] -> ShowS) -> Show Value
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Value] -> ShowS
$cshowList :: [Value] -> ShowS
show :: Value -> String
$cshow :: Value -> String
showsPrec :: Int -> Value -> ShowS
$cshowsPrec :: Int -> Value -> ShowS
Show)
data SExpr = Atom String
| List [SExpr]
deriving (SExpr -> SExpr -> Bool
(SExpr -> SExpr -> Bool) -> (SExpr -> SExpr -> Bool) -> Eq SExpr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SExpr -> SExpr -> Bool
$c/= :: SExpr -> SExpr -> Bool
== :: SExpr -> SExpr -> Bool
$c== :: SExpr -> SExpr -> Bool
Eq, Eq SExpr
Eq SExpr =>
(SExpr -> SExpr -> Ordering)
-> (SExpr -> SExpr -> Bool)
-> (SExpr -> SExpr -> Bool)
-> (SExpr -> SExpr -> Bool)
-> (SExpr -> SExpr -> Bool)
-> (SExpr -> SExpr -> SExpr)
-> (SExpr -> SExpr -> SExpr)
-> Ord SExpr
SExpr -> SExpr -> Bool
SExpr -> SExpr -> Ordering
SExpr -> SExpr -> SExpr
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SExpr -> SExpr -> SExpr
$cmin :: SExpr -> SExpr -> SExpr
max :: SExpr -> SExpr -> SExpr
$cmax :: SExpr -> SExpr -> SExpr
>= :: SExpr -> SExpr -> Bool
$c>= :: SExpr -> SExpr -> Bool
> :: SExpr -> SExpr -> Bool
$c> :: SExpr -> SExpr -> Bool
<= :: SExpr -> SExpr -> Bool
$c<= :: SExpr -> SExpr -> Bool
< :: SExpr -> SExpr -> Bool
$c< :: SExpr -> SExpr -> Bool
compare :: SExpr -> SExpr -> Ordering
$ccompare :: SExpr -> SExpr -> Ordering
$cp1Ord :: Eq SExpr
Ord, Int -> SExpr -> ShowS
[SExpr] -> ShowS
SExpr -> String
(Int -> SExpr -> ShowS)
-> (SExpr -> String) -> ([SExpr] -> ShowS) -> Show SExpr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SExpr] -> ShowS
$cshowList :: [SExpr] -> ShowS
show :: SExpr -> String
$cshow :: SExpr -> String
showsPrec :: Int -> SExpr -> ShowS
$cshowsPrec :: Int -> SExpr -> ShowS
Show)
showsSExpr :: SExpr -> ShowS
showsSExpr :: SExpr -> ShowS
showsSExpr ex :: SExpr
ex =
case SExpr
ex of
Atom x :: String
x -> String -> ShowS
showString String
x
List es :: [SExpr]
es -> Char -> ShowS
showChar '(' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(SExpr -> ShowS -> ShowS) -> ShowS -> [SExpr] -> ShowS
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\e :: SExpr
e m :: ShowS
m -> SExpr -> ShowS
showsSExpr SExpr
e ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar ' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
m)
(Char -> ShowS
showChar ')') [SExpr]
es
ppSExpr :: SExpr -> ShowS
ppSExpr :: SExpr -> ShowS
ppSExpr = Int -> SExpr -> ShowS
go 0
where
tab :: Int -> ShowS
tab n :: Int
n = String -> ShowS
showString (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n ' ')
many :: [b -> b] -> b -> b
many = ((b -> b) -> (b -> b) -> b -> b) -> (b -> b) -> [b -> b] -> b -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (b -> b) -> (b -> b) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) b -> b
forall a. a -> a
id
new :: Int -> SExpr -> ShowS
new n :: Int
n e :: SExpr
e = Char -> ShowS
showChar '\n' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
tab Int
n ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> SExpr -> ShowS
go Int
n SExpr
e
small :: t -> [SExpr] -> Maybe [ShowS]
small n :: t
n es :: [SExpr]
es =
case [SExpr]
es of
[] -> [ShowS] -> Maybe [ShowS]
forall a. a -> Maybe a
Just []
e :: SExpr
e : more :: [SExpr]
more
| t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 -> Maybe [ShowS]
forall a. Maybe a
Nothing
| Bool
otherwise -> case SExpr
e of
Atom x :: String
x -> (String -> ShowS
showString String
x ShowS -> [ShowS] -> [ShowS]
forall a. a -> [a] -> [a]
:) ([ShowS] -> [ShowS]) -> Maybe [ShowS] -> Maybe [ShowS]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> [SExpr] -> Maybe [ShowS]
small (t
nt -> t -> t
forall a. Num a => a -> a -> a
-1) [SExpr]
more
_ -> Maybe [ShowS]
forall a. Maybe a
Nothing
go :: Int -> SExpr -> ShowS
go :: Int -> SExpr -> ShowS
go n :: Int
n ex :: SExpr
ex =
case SExpr
ex of
Atom x :: String
x -> String -> ShowS
showString String
x
List es :: [SExpr]
es
| Just fs :: [ShowS]
fs <- Integer -> [SExpr] -> Maybe [ShowS]
forall t. (Ord t, Num t) => t -> [SExpr] -> Maybe [ShowS]
small 5 [SExpr]
es ->
Char -> ShowS
showChar '(' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ShowS] -> ShowS
forall b. [b -> b] -> b -> b
many (ShowS -> [ShowS] -> [ShowS]
forall a. a -> [a] -> [a]
intersperse (Char -> ShowS
showChar ' ') [ShowS]
fs) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar ')'
List (Atom x :: String
x : es :: [SExpr]
es) -> String -> ShowS
showString "(" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
x ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
[ShowS] -> ShowS
forall b. [b -> b] -> b -> b
many ((SExpr -> ShowS) -> [SExpr] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> SExpr -> ShowS
new (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+3)) [SExpr]
es) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString ")"
List es :: [SExpr]
es -> String -> ShowS
showString "(" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ShowS] -> ShowS
forall b. [b -> b] -> b -> b
many ((SExpr -> ShowS) -> [SExpr] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> SExpr -> ShowS
new (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+2)) [SExpr]
es) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString ")"
readSExpr :: String -> Maybe (SExpr, String)
readSExpr :: String -> Maybe (SExpr, String)
readSExpr (c :: Char
c : more :: String
more) | Char -> Bool
isSpace Char
c = String -> Maybe (SExpr, String)
readSExpr String
more
readSExpr (';' : more :: String
more) = String -> Maybe (SExpr, String)
readSExpr (String -> Maybe (SExpr, String))
-> String -> Maybe (SExpr, String)
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Int -> [a] -> [a]
drop 1 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '\n') String
more
readSExpr ('(' : more :: String
more) = do (xs :: [SExpr]
xs,more1 :: String
more1) <- String -> Maybe ([SExpr], String)
list String
more
(SExpr, String) -> Maybe (SExpr, String)
forall (m :: * -> *) a. Monad m => a -> m a
return ([SExpr] -> SExpr
List [SExpr]
xs, String
more1)
where
list :: String -> Maybe ([SExpr], String)
list (c :: Char
c : txt :: String
txt) | Char -> Bool
isSpace Char
c = String -> Maybe ([SExpr], String)
list String
txt
list (')' : txt :: String
txt) = ([SExpr], String) -> Maybe ([SExpr], String)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], String
txt)
list txt :: String
txt = do (v :: SExpr
v,txt1 :: String
txt1) <- String -> Maybe (SExpr, String)
readSExpr String
txt
(vs :: [SExpr]
vs,txt2 :: String
txt2) <- String -> Maybe ([SExpr], String)
list String
txt1
([SExpr], String) -> Maybe ([SExpr], String)
forall (m :: * -> *) a. Monad m => a -> m a
return (SExpr
vSExpr -> [SExpr] -> [SExpr]
forall a. a -> [a] -> [a]
:[SExpr]
vs, String
txt2)
readSExpr txt :: String
txt = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
end String
txt of
(as :: String
as,bs :: String
bs) | Bool -> Bool
P.not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
as) -> (SExpr, String) -> Maybe (SExpr, String)
forall a. a -> Maybe a
Just (String -> SExpr
Atom String
as, String
bs)
_ -> Maybe (SExpr, String)
forall a. Maybe a
Nothing
where end :: Char -> Bool
end x :: Char
x = Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ')' Bool -> Bool -> Bool
|| Char -> Bool
isSpace Char
x
data Solver = Solver
{ Solver -> SExpr -> IO SExpr
command :: SExpr -> IO SExpr
, Solver -> IO ExitCode
stop :: IO ExitCode
}
newSolver :: String ->
[String] ->
Maybe Logger ->
IO Solver
newSolver :: String -> [String] -> Maybe Logger -> IO Solver
newSolver exe :: String
exe opts :: [String]
opts mbLog :: Maybe Logger
mbLog =
do (hIn :: Handle
hIn, hOut :: Handle
hOut, hErr :: Handle
hErr, h :: ProcessHandle
h) <- String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> IO (Handle, Handle, Handle, ProcessHandle)
runInteractiveProcess String
exe [String]
opts Maybe String
forall a. Maybe a
Nothing Maybe [(String, String)]
forall a. Maybe a
Nothing
let info :: String -> IO ()
info a :: String
a = case Maybe Logger
mbLog of
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just l :: Logger
l -> Logger -> String -> IO ()
logMessage Logger
l String
a
ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (do String
errs <- Handle -> IO String
hGetLine Handle
hErr
String -> IO ()
info ("[stderr] " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
errs))
IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`X.catch` \X.SomeException {} -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
IO (Maybe SExpr)
getResponse <-
do String
txt <- Handle -> IO String
hGetContents Handle
hOut
IORef [SExpr]
ref <- [SExpr] -> IO (IORef [SExpr])
forall a. a -> IO (IORef a)
newIORef ((String -> Maybe (SExpr, String)) -> String -> [SExpr]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr String -> Maybe (SExpr, String)
readSExpr String
txt)
IO (Maybe SExpr) -> IO (IO (Maybe SExpr))
forall (m :: * -> *) a. Monad m => a -> m a
return (IO (Maybe SExpr) -> IO (IO (Maybe SExpr)))
-> IO (Maybe SExpr) -> IO (IO (Maybe SExpr))
forall a b. (a -> b) -> a -> b
$ IORef [SExpr]
-> ([SExpr] -> ([SExpr], Maybe SExpr)) -> IO (Maybe SExpr)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [SExpr]
ref (([SExpr] -> ([SExpr], Maybe SExpr)) -> IO (Maybe SExpr))
-> ([SExpr] -> ([SExpr], Maybe SExpr)) -> IO (Maybe SExpr)
forall a b. (a -> b) -> a -> b
$ \xs :: [SExpr]
xs ->
case [SExpr]
xs of
[] -> ([SExpr]
xs, Maybe SExpr
forall a. Maybe a
Nothing)
y :: SExpr
y : ys :: [SExpr]
ys -> ([SExpr]
ys, SExpr -> Maybe SExpr
forall a. a -> Maybe a
Just SExpr
y)
let cmd :: SExpr -> IO ()
cmd c :: SExpr
c = do let txt :: String
txt = SExpr -> ShowS
showsSExpr SExpr
c ""
String -> IO ()
info ("[send->] " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
txt)
Handle -> String -> IO ()
hPutStrLn Handle
hIn String
txt
Handle -> IO ()
hFlush Handle
hIn
command :: SExpr -> IO SExpr
command c :: SExpr
c =
do SExpr -> IO ()
cmd SExpr
c
Maybe SExpr
mb <- IO (Maybe SExpr)
getResponse
case Maybe SExpr
mb of
Just res :: SExpr
res -> do String -> IO ()
info ("[<-recv] " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SExpr -> ShowS
showsSExpr SExpr
res "")
SExpr -> IO SExpr
forall (m :: * -> *) a. Monad m => a -> m a
return SExpr
res
Nothing -> String -> IO SExpr
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Missing response from solver"
stop :: IO ExitCode
stop =
do SExpr -> IO ()
cmd ([SExpr] -> SExpr
List [String -> SExpr
Atom "exit"])
ExitCode
ec <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
h
IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
X.catch (do Handle -> IO ()
hClose Handle
hIn
Handle -> IO ()
hClose Handle
hOut
Handle -> IO ()
hClose Handle
hErr)
(\ex :: IOException
ex -> String -> IO ()
info (IOException -> String
forall a. Show a => a -> String
show (IOException
ex::X.IOException)))
ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ec
solver :: Solver
solver = Solver :: (SExpr -> IO SExpr) -> IO ExitCode -> Solver
Solver { .. }
Solver -> String -> String -> IO ()
setOption Solver
solver ":print-success" "true"
Solver -> String -> String -> IO ()
setOption Solver
solver ":produce-models" "true"
Solver -> IO Solver
forall (m :: * -> *) a. Monad m => a -> m a
return Solver
solver
loadFile :: Solver -> FilePath -> IO ()
loadFile :: Solver -> String -> IO ()
loadFile s :: Solver
s file :: String
file = Solver -> String -> IO ()
loadString Solver
s (String -> IO ()) -> IO String -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO String
readFile String
file
loadString :: Solver -> String -> IO ()
loadString :: Solver -> String -> IO ()
loadString s :: Solver
s str :: String
str = String -> IO ()
go (ShowS
dropComments String
str)
where
go :: String -> IO ()
go txt :: String
txt
| (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
txt = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise =
case String -> Maybe (SExpr, String)
readSExpr String
txt of
Just (e :: SExpr
e,rest :: String
rest) -> Solver -> SExpr -> IO SExpr
command Solver
s SExpr
e IO SExpr -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
go String
rest
Nothing -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [ "Failed to parse SMT file."
, String
txt
]
dropComments :: ShowS
dropComments = [String] -> String
unlines ([String] -> String) -> (String -> [String]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
dropComment ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
dropComment :: ShowS
dropComment xs :: String
xs = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ';') String
xs of
(as :: String
as,_:_) -> String
as
_ -> String
xs
ackCommand :: Solver -> SExpr -> IO ()
ackCommand :: Solver -> SExpr -> IO ()
ackCommand proc :: Solver
proc c :: SExpr
c =
do SExpr
res <- Solver -> SExpr -> IO SExpr
command Solver
proc SExpr
c
case SExpr
res of
Atom "success" -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
_ -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
[ "Unexpected result from the SMT solver:"
, " Expected: success"
, " Result: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SExpr -> ShowS
showsSExpr SExpr
res ""
]
simpleCommand :: Solver -> [String] -> IO ()
simpleCommand :: Solver -> [String] -> IO ()
simpleCommand proc :: Solver
proc = Solver -> SExpr -> IO ()
ackCommand Solver
proc (SExpr -> IO ()) -> ([String] -> SExpr) -> [String] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SExpr] -> SExpr
List ([SExpr] -> SExpr) -> ([String] -> [SExpr]) -> [String] -> SExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> SExpr) -> [String] -> [SExpr]
forall a b. (a -> b) -> [a] -> [b]
map String -> SExpr
Atom
simpleCommandMaybe :: Solver -> [String] -> IO Bool
simpleCommandMaybe :: Solver -> [String] -> IO Bool
simpleCommandMaybe proc :: Solver
proc c :: [String]
c =
do SExpr
res <- Solver -> SExpr -> IO SExpr
command Solver
proc ([SExpr] -> SExpr
List ((String -> SExpr) -> [String] -> [SExpr]
forall a b. (a -> b) -> [a] -> [b]
map String -> SExpr
Atom [String]
c))
case SExpr
res of
Atom "success" -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Atom "unsupported" -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
_ -> String -> IO Bool
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO Bool) -> String -> IO Bool
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
[ "Unexpected result from the SMT solver:"
, " Expected: success or unsupported"
, " Result: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SExpr -> ShowS
showsSExpr SExpr
res ""
]
setOption :: Solver -> String -> String -> IO ()
setOption :: Solver -> String -> String -> IO ()
setOption s :: Solver
s x :: String
x y :: String
y = Solver -> [String] -> IO ()
simpleCommand Solver
s [ "set-option", String
x, String
y ]
setOptionMaybe :: Solver -> String -> String -> IO Bool
setOptionMaybe :: Solver -> String -> String -> IO Bool
setOptionMaybe s :: Solver
s x :: String
x y :: String
y = Solver -> [String] -> IO Bool
simpleCommandMaybe Solver
s [ "set-option", String
x, String
y ]
setLogic :: Solver -> String -> IO ()
setLogic :: Solver -> String -> IO ()
setLogic s :: Solver
s x :: String
x = Solver -> [String] -> IO ()
simpleCommand Solver
s [ "set-logic", String
x ]
setLogicMaybe :: Solver -> String -> IO Bool
setLogicMaybe :: Solver -> String -> IO Bool
setLogicMaybe s :: Solver
s x :: String
x = Solver -> [String] -> IO Bool
simpleCommandMaybe Solver
s [ "set-logic", String
x ]
produceUnsatCores :: Solver -> IO Bool
produceUnsatCores :: Solver -> IO Bool
produceUnsatCores s :: Solver
s = Solver -> String -> String -> IO Bool
setOptionMaybe Solver
s ":produce-unsat-cores" "true"
push :: Solver -> IO ()
push :: Solver -> IO ()
push proc :: Solver
proc = Solver -> Integer -> IO ()
pushMany Solver
proc 1
pop :: Solver -> IO ()
pop :: Solver -> IO ()
pop proc :: Solver
proc = Solver -> Integer -> IO ()
popMany Solver
proc 1
pushMany :: Solver -> Integer -> IO ()
pushMany :: Solver -> Integer -> IO ()
pushMany proc :: Solver
proc n :: Integer
n = Solver -> [String] -> IO ()
simpleCommand Solver
proc [ "push", Integer -> String
forall a. Show a => a -> String
show Integer
n ]
popMany :: Solver -> Integer -> IO ()
popMany :: Solver -> Integer -> IO ()
popMany proc :: Solver
proc n :: Integer
n = Solver -> [String] -> IO ()
simpleCommand Solver
proc [ "pop", Integer -> String
forall a. Show a => a -> String
show Integer
n ]
inNewScope :: Solver -> IO a -> IO a
inNewScope :: Solver -> IO a -> IO a
inNewScope s :: Solver
s m :: IO a
m =
do Solver -> IO ()
push Solver
s
IO a
m IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`X.finally` Solver -> IO ()
pop Solver
s
declare :: Solver -> String -> SExpr -> IO SExpr
declare :: Solver -> String -> SExpr -> IO SExpr
declare proc :: Solver
proc f :: String
f t :: SExpr
t = Solver -> String -> [SExpr] -> SExpr -> IO SExpr
declareFun Solver
proc String
f [] SExpr
t
declareFun :: Solver -> String -> [SExpr] -> SExpr -> IO SExpr
declareFun :: Solver -> String -> [SExpr] -> SExpr -> IO SExpr
declareFun proc :: Solver
proc f :: String
f as :: [SExpr]
as r :: SExpr
r =
do Solver -> SExpr -> IO ()
ackCommand Solver
proc (SExpr -> IO ()) -> SExpr -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> [SExpr] -> SExpr
fun "declare-fun" [ String -> SExpr
Atom String
f, [SExpr] -> SExpr
List [SExpr]
as, SExpr
r ]
SExpr -> IO SExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> SExpr
const String
f)
declareDatatype ::
Solver ->
String ->
[String] ->
[(String, [(String, SExpr)])] ->
IO ()
declareDatatype :: Solver
-> String -> [String] -> [(String, [(String, SExpr)])] -> IO ()
declareDatatype proc :: Solver
proc t :: String
t [] cs :: [(String, [(String, SExpr)])]
cs =
Solver -> SExpr -> IO ()
ackCommand Solver
proc (SExpr -> IO ()) -> SExpr -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> [SExpr] -> SExpr
fun "declare-datatype" ([SExpr] -> SExpr) -> [SExpr] -> SExpr
forall a b. (a -> b) -> a -> b
$
[ String -> SExpr
Atom String
t
, [SExpr] -> SExpr
List [ [SExpr] -> SExpr
List (String -> SExpr
Atom String
c SExpr -> [SExpr] -> [SExpr]
forall a. a -> [a] -> [a]
: [ [SExpr] -> SExpr
List [String -> SExpr
Atom String
s, SExpr
argTy] | (s :: String
s, argTy :: SExpr
argTy) <- [(String, SExpr)]
args]) | (c :: String
c, args :: [(String, SExpr)]
args) <- [(String, [(String, SExpr)])]
cs ]
]
declareDatatype proc :: Solver
proc t :: String
t ps :: [String]
ps cs :: [(String, [(String, SExpr)])]
cs =
Solver -> SExpr -> IO ()
ackCommand Solver
proc (SExpr -> IO ()) -> SExpr -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> [SExpr] -> SExpr
fun "declare-datatype" ([SExpr] -> SExpr) -> [SExpr] -> SExpr
forall a b. (a -> b) -> a -> b
$
[ String -> SExpr
Atom String
t
, String -> [SExpr] -> SExpr
fun "par" ([SExpr] -> SExpr) -> [SExpr] -> SExpr
forall a b. (a -> b) -> a -> b
$
[ [SExpr] -> SExpr
List ((String -> SExpr) -> [String] -> [SExpr]
forall a b. (a -> b) -> [a] -> [b]
map String -> SExpr
Atom [String]
ps)
, [SExpr] -> SExpr
List [ [SExpr] -> SExpr
List (String -> SExpr
Atom String
c SExpr -> [SExpr] -> [SExpr]
forall a. a -> [a] -> [a]
: [ [SExpr] -> SExpr
List [String -> SExpr
Atom String
s, SExpr
argTy] | (s :: String
s, argTy :: SExpr
argTy) <- [(String, SExpr)]
args]) | (c :: String
c, args :: [(String, SExpr)]
args) <- [(String, [(String, SExpr)])]
cs ]
]
]
define :: Solver ->
String ->
SExpr ->
SExpr ->
IO SExpr
define :: Solver -> String -> SExpr -> SExpr -> IO SExpr
define proc :: Solver
proc f :: String
f t :: SExpr
t e :: SExpr
e = Solver -> String -> [(String, SExpr)] -> SExpr -> SExpr -> IO SExpr
defineFun Solver
proc String
f [] SExpr
t SExpr
e
defineFun :: Solver ->
String ->
[(String,SExpr)] ->
SExpr ->
SExpr ->
IO SExpr
defineFun :: Solver -> String -> [(String, SExpr)] -> SExpr -> SExpr -> IO SExpr
defineFun proc :: Solver
proc f :: String
f as :: [(String, SExpr)]
as t :: SExpr
t e :: SExpr
e =
do Solver -> SExpr -> IO ()
ackCommand Solver
proc (SExpr -> IO ()) -> SExpr -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> [SExpr] -> SExpr
fun "define-fun"
([SExpr] -> SExpr) -> [SExpr] -> SExpr
forall a b. (a -> b) -> a -> b
$ [ String -> SExpr
Atom String
f, [SExpr] -> SExpr
List [ [SExpr] -> SExpr
List [String -> SExpr
const String
x,SExpr
a] | (x :: String
x,a :: SExpr
a) <- [(String, SExpr)]
as ], SExpr
t, SExpr
e]
SExpr -> IO SExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> SExpr
const String
f)
assert :: Solver -> SExpr -> IO ()
assert :: Solver -> SExpr -> IO ()
assert proc :: Solver
proc e :: SExpr
e = Solver -> SExpr -> IO ()
ackCommand Solver
proc (SExpr -> IO ()) -> SExpr -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> [SExpr] -> SExpr
fun "assert" [SExpr
e]
check :: Solver -> IO Result
check :: Solver -> IO Result
check proc :: Solver
proc =
do SExpr
res <- Solver -> SExpr -> IO SExpr
command Solver
proc ([SExpr] -> SExpr
List [ String -> SExpr
Atom "check-sat" ])
case SExpr
res of
Atom "unsat" -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
Unsat
Atom "unknown" -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
Unknown
Atom "sat" -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
Sat
_ -> String -> IO Result
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO Result) -> String -> IO Result
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
[ "Unexpected result from the SMT solver:"
, " Expected: unsat, unknown, or sat"
, " Result: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SExpr -> ShowS
showsSExpr SExpr
res ""
]
sexprToVal :: SExpr -> Value
sexprToVal :: SExpr -> Value
sexprToVal expr :: SExpr
expr =
case SExpr
expr of
Atom "true" -> Bool -> Value
Bool Bool
True
Atom "false" -> Bool -> Value
Bool Bool
False
Atom ('#' : 'b' : ds :: String
ds)
| Just n :: Integer
n <- String -> Maybe Integer
binLit String
ds -> Int -> Integer -> Value
Bits (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
ds) Integer
n
Atom ('#' : 'x' : ds :: String
ds)
| [(n :: Integer
n,[])] <- ReadS Integer
forall a. (Eq a, Num a) => ReadS a
readHex String
ds -> Int -> Integer -> Value
Bits (4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
ds) Integer
n
Atom txt :: String
txt
| Just n :: Integer
n <- String -> Maybe Integer
forall a. Read a => String -> Maybe a
readMaybe String
txt -> Integer -> Value
Int Integer
n
List [ Atom "-", x :: SExpr
x ]
| Int a :: Integer
a <- SExpr -> Value
sexprToVal SExpr
x -> Integer -> Value
Int (Integer -> Integer
forall a. Num a => a -> a
negate Integer
a)
List [ Atom "/", x :: SExpr
x, y :: SExpr
y ]
| Int a :: Integer
a <- SExpr -> Value
sexprToVal SExpr
x
, Int b :: Integer
b <- SExpr -> Value
sexprToVal SExpr
y -> Rational -> Value
Real (Integer
a Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
b)
_ -> SExpr -> Value
Other SExpr
expr
where
binLit :: String -> Maybe Integer
binLit cs :: String
cs = do [Integer]
ds <- (Char -> Maybe Integer) -> String -> Maybe [Integer]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Char -> Maybe Integer
forall a. Num a => Char -> Maybe a
binDigit String
cs
Integer -> Maybe Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ [Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Integer] -> Integer) -> [Integer] -> Integer
forall a b. (a -> b) -> a -> b
$ (Integer -> Integer -> Integer)
-> [Integer] -> [Integer] -> [Integer]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*) ([Integer] -> [Integer]
forall a. [a] -> [a]
reverse [Integer]
ds) [Integer]
powers2
powers2 :: [Integer]
powers2 = 1 Integer -> [Integer] -> [Integer]
forall a. a -> [a] -> [a]
: (Integer -> Integer) -> [Integer] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map (2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*) [Integer]
powers2
binDigit :: Char -> Maybe a
binDigit '0' = a -> Maybe a
forall a. a -> Maybe a
Just 0
binDigit '1' = a -> Maybe a
forall a. a -> Maybe a
Just 1
binDigit _ = Maybe a
forall a. Maybe a
Nothing
getExprs :: Solver -> [SExpr] -> IO [(SExpr, Value)]
getExprs :: Solver -> [SExpr] -> IO [(SExpr, Value)]
getExprs proc :: Solver
proc vals :: [SExpr]
vals =
do SExpr
res <- Solver -> SExpr -> IO SExpr
command Solver
proc (SExpr -> IO SExpr) -> SExpr -> IO SExpr
forall a b. (a -> b) -> a -> b
$ [SExpr] -> SExpr
List [ String -> SExpr
Atom "get-value", [SExpr] -> SExpr
List [SExpr]
vals ]
case SExpr
res of
List xs :: [SExpr]
xs -> (SExpr -> IO (SExpr, Value)) -> [SExpr] -> IO [(SExpr, Value)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM SExpr -> IO (SExpr, Value)
forall (m :: * -> *). MonadFail m => SExpr -> m (SExpr, Value)
getAns [SExpr]
xs
_ -> String -> IO [(SExpr, Value)]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO [(SExpr, Value)]) -> String -> IO [(SExpr, Value)]
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
[ "Unexpected response from the SMT solver:"
, " Exptected: a list"
, " Result: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SExpr -> ShowS
showsSExpr SExpr
res ""
]
where
getAns :: SExpr -> m (SExpr, Value)
getAns expr :: SExpr
expr =
case SExpr
expr of
List [ e :: SExpr
e, v :: SExpr
v ] -> (SExpr, Value) -> m (SExpr, Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (SExpr
e, SExpr -> Value
sexprToVal SExpr
v)
_ -> String -> m (SExpr, Value)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m (SExpr, Value)) -> String -> m (SExpr, Value)
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
[ "Unexpected response from the SMT solver:"
, " Expected: (expr val)"
, " Result: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SExpr -> ShowS
showsSExpr SExpr
expr ""
]
getConsts :: Solver -> [String] -> IO [(String, Value)]
getConsts :: Solver -> [String] -> IO [(String, Value)]
getConsts proc :: Solver
proc xs :: [String]
xs =
do [(SExpr, Value)]
ans <- Solver -> [SExpr] -> IO [(SExpr, Value)]
getExprs Solver
proc ((String -> SExpr) -> [String] -> [SExpr]
forall a b. (a -> b) -> [a] -> [b]
map String -> SExpr
Atom [String]
xs)
[(String, Value)] -> IO [(String, Value)]
forall (m :: * -> *) a. Monad m => a -> m a
return [ (String
x,Value
e) | (Atom x :: String
x, e :: Value
e) <- [(SExpr, Value)]
ans ]
getExpr :: Solver -> SExpr -> IO Value
getExpr :: Solver -> SExpr -> IO Value
getExpr proc :: Solver
proc x :: SExpr
x =
do [ (_,v :: Value
v) ] <- Solver -> [SExpr] -> IO [(SExpr, Value)]
getExprs Solver
proc [SExpr
x]
Value -> IO Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v
getConst :: Solver -> String -> IO Value
getConst :: Solver -> String -> IO Value
getConst proc :: Solver
proc x :: String
x = Solver -> SExpr -> IO Value
getExpr Solver
proc (String -> SExpr
Atom String
x)
getUnsatCore :: Solver -> IO [String]
getUnsatCore :: Solver -> IO [String]
getUnsatCore s :: Solver
s =
do SExpr
res <- Solver -> SExpr -> IO SExpr
command Solver
s (SExpr -> IO SExpr) -> SExpr -> IO SExpr
forall a b. (a -> b) -> a -> b
$ [SExpr] -> SExpr
List [ String -> SExpr
Atom "get-unsat-core" ]
case SExpr
res of
List xs :: [SExpr]
xs -> (SExpr -> IO String) -> [SExpr] -> IO [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM SExpr -> IO String
forall (m :: * -> *). MonadFail m => SExpr -> m String
fromAtom [SExpr]
xs
_ -> String -> SExpr -> IO [String]
forall (m :: * -> *) a. MonadFail m => String -> SExpr -> m a
unexpected "a list of atoms" SExpr
res
where
fromAtom :: SExpr -> m String
fromAtom x :: SExpr
x =
case SExpr
x of
Atom a :: String
a -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
a
_ -> String -> SExpr -> m String
forall (m :: * -> *) a. MonadFail m => String -> SExpr -> m a
unexpected "an atom" SExpr
x
unexpected :: String -> SExpr -> m a
unexpected x :: String
x e :: SExpr
e =
String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [ "Unexpected response from the SMT Solver:"
, " Expected: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
x
, " Result: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SExpr -> ShowS
showsSExpr SExpr
e ""
]
fam :: String -> [Integer] -> SExpr
fam :: String -> [Integer] -> SExpr
fam f :: String
f is :: [Integer]
is = [SExpr] -> SExpr
List (String -> SExpr
Atom "_" SExpr -> [SExpr] -> [SExpr]
forall a. a -> [a] -> [a]
: String -> SExpr
Atom String
f SExpr -> [SExpr] -> [SExpr]
forall a. a -> [a] -> [a]
: (Integer -> SExpr) -> [Integer] -> [SExpr]
forall a b. (a -> b) -> [a] -> [b]
map (String -> SExpr
Atom (String -> SExpr) -> (Integer -> String) -> Integer -> SExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
forall a. Show a => a -> String
show) [Integer]
is)
fun :: String -> [SExpr] -> SExpr
fun :: String -> [SExpr] -> SExpr
fun f :: String
f [] = String -> SExpr
Atom String
f
fun f :: String
f as :: [SExpr]
as = [SExpr] -> SExpr
List (String -> SExpr
Atom String
f SExpr -> [SExpr] -> [SExpr]
forall a. a -> [a] -> [a]
: [SExpr]
as)
const :: String -> SExpr
const :: String -> SExpr
const f :: String
f = String -> [SExpr] -> SExpr
fun String
f []
tInt :: SExpr
tInt :: SExpr
tInt = String -> SExpr
const "Int"
tBool :: SExpr
tBool :: SExpr
tBool = String -> SExpr
const "Bool"
tReal :: SExpr
tReal :: SExpr
tReal = String -> SExpr
const "Real"
tArray :: SExpr ->
SExpr ->
SExpr
tArray :: SExpr -> SExpr -> SExpr
tArray x :: SExpr
x y :: SExpr
y = String -> [SExpr] -> SExpr
fun "Array" [SExpr
x,SExpr
y]
tBits :: Integer ->
SExpr
tBits :: Integer -> SExpr
tBits w :: Integer
w = String -> [Integer] -> SExpr
fam "BitVec" [Integer
w]
bool :: Bool -> SExpr
bool :: Bool -> SExpr
bool b :: Bool
b = String -> SExpr
const (if Bool
b then "true" else "false")
int :: Integer -> SExpr
int :: Integer -> SExpr
int x :: Integer
x | Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< 0 = SExpr -> SExpr
neg (Integer -> SExpr
int (Integer -> Integer
forall a. Num a => a -> a
negate Integer
x))
| Bool
otherwise = String -> SExpr
Atom (Integer -> String
forall a. Show a => a -> String
show Integer
x)
real :: Rational -> SExpr
real :: Rational -> SExpr
real x :: Rational
x
| Double -> Rational
forall a. Real a => a -> Rational
toRational Double
y Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
x = String -> SExpr
Atom (Maybe Int -> Double -> ShowS
forall a. RealFloat a => Maybe Int -> a -> ShowS
showFFloat Maybe Int
forall a. Maybe a
Nothing Double
y "")
| Bool
otherwise = SExpr -> SExpr -> SExpr
realDiv (Integer -> SExpr
int (Rational -> Integer
forall a. Ratio a -> a
numerator Rational
x)) (Integer -> SExpr
int (Rational -> Integer
forall a. Ratio a -> a
denominator Rational
x))
where y :: Double
y = Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
x :: Double
bvBin :: Int -> Integer -> SExpr
bvBin :: Int -> Integer -> SExpr
bvBin w :: Int
w v :: Integer
v = String -> SExpr
const ("#b" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
bits)
where
bits :: String
bits = ShowS
forall a. [a] -> [a]
reverse [ if Integer -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Integer
v Int
n then '1' else '0' | Int
n <- [ 0 .. Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1 ] ]
bvHex :: Int -> Integer -> SExpr
bvHex :: Int -> Integer -> SExpr
bvHex w :: Int
w v :: Integer
v
| Integer
v Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= 0 = String -> SExpr
const ("#x" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
padding String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
hex)
| Bool
otherwise = Int -> Integer -> SExpr
bvHex Int
w (2Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^Int
w Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
v)
where
hex :: String
hex = Integer -> ShowS
forall a. (Integral a, Show a) => a -> ShowS
showHex Integer
v ""
padding :: String
padding = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int -> Int -> Int
forall a. Integral a => a -> a -> a
P.div (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 3) 4 Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
hex) '0'
value :: Value -> SExpr
value :: Value -> SExpr
value val :: Value
val =
case Value
val of
Bool b :: Bool
b -> Bool -> SExpr
bool Bool
b
Int n :: Integer
n -> Integer -> SExpr
int Integer
n
Real r :: Rational
r -> Rational -> SExpr
real Rational
r
Bits w :: Int
w v :: Integer
v | Int -> Int -> Int
forall a. Integral a => a -> a -> a
P.mod Int
w 4 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 -> Int -> Integer -> SExpr
bvHex Int
w Integer
v
| Bool
otherwise -> Int -> Integer -> SExpr
bvBin Int
w Integer
v
Other o :: SExpr
o -> SExpr
o
not :: SExpr -> SExpr
not :: SExpr -> SExpr
not p :: SExpr
p = String -> [SExpr] -> SExpr
fun "not" [SExpr
p]
and :: SExpr -> SExpr -> SExpr
and :: SExpr -> SExpr -> SExpr
and p :: SExpr
p q :: SExpr
q = String -> [SExpr] -> SExpr
fun "and" [SExpr
p,SExpr
q]
andMany :: [SExpr] -> SExpr
andMany :: [SExpr] -> SExpr
andMany xs :: [SExpr]
xs = if [SExpr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SExpr]
xs then Bool -> SExpr
bool Bool
True else String -> [SExpr] -> SExpr
fun "and" [SExpr]
xs
or :: SExpr -> SExpr -> SExpr
or :: SExpr -> SExpr -> SExpr
or p :: SExpr
p q :: SExpr
q = String -> [SExpr] -> SExpr
fun "or" [SExpr
p,SExpr
q]
orMany :: [SExpr] -> SExpr
orMany :: [SExpr] -> SExpr
orMany xs :: [SExpr]
xs = if [SExpr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SExpr]
xs then Bool -> SExpr
bool Bool
False else String -> [SExpr] -> SExpr
fun "or" [SExpr]
xs
xor :: SExpr -> SExpr -> SExpr
xor :: SExpr -> SExpr -> SExpr
xor p :: SExpr
p q :: SExpr
q = String -> [SExpr] -> SExpr
fun "xor" [SExpr
p,SExpr
q]
implies :: SExpr -> SExpr -> SExpr
implies :: SExpr -> SExpr -> SExpr
implies p :: SExpr
p q :: SExpr
q = String -> [SExpr] -> SExpr
fun "=>" [SExpr
p,SExpr
q]
ite :: SExpr -> SExpr -> SExpr -> SExpr
ite :: SExpr -> SExpr -> SExpr -> SExpr
ite x :: SExpr
x y :: SExpr
y z :: SExpr
z = String -> [SExpr] -> SExpr
fun "ite" [SExpr
x,SExpr
y,SExpr
z]
eq :: SExpr -> SExpr -> SExpr
eq :: SExpr -> SExpr -> SExpr
eq x :: SExpr
x y :: SExpr
y = String -> [SExpr] -> SExpr
fun "=" [SExpr
x,SExpr
y]
distinct :: [SExpr] -> SExpr
distinct :: [SExpr] -> SExpr
distinct xs :: [SExpr]
xs = if [SExpr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SExpr]
xs then Bool -> SExpr
bool Bool
True else String -> [SExpr] -> SExpr
fun "distinct" [SExpr]
xs
gt :: SExpr -> SExpr -> SExpr
gt :: SExpr -> SExpr -> SExpr
gt x :: SExpr
x y :: SExpr
y = String -> [SExpr] -> SExpr
fun ">" [SExpr
x,SExpr
y]
lt :: SExpr -> SExpr -> SExpr
lt :: SExpr -> SExpr -> SExpr
lt x :: SExpr
x y :: SExpr
y = String -> [SExpr] -> SExpr
fun "<" [SExpr
x,SExpr
y]
geq :: SExpr -> SExpr -> SExpr
geq :: SExpr -> SExpr -> SExpr
geq x :: SExpr
x y :: SExpr
y = String -> [SExpr] -> SExpr
fun ">=" [SExpr
x,SExpr
y]
leq :: SExpr -> SExpr -> SExpr
leq :: SExpr -> SExpr -> SExpr
leq x :: SExpr
x y :: SExpr
y = String -> [SExpr] -> SExpr
fun "<=" [SExpr
x,SExpr
y]
bvULt :: SExpr -> SExpr -> SExpr
bvULt :: SExpr -> SExpr -> SExpr
bvULt x :: SExpr
x y :: SExpr
y = String -> [SExpr] -> SExpr
fun "bvult" [SExpr
x,SExpr
y]
bvULeq :: SExpr -> SExpr -> SExpr
bvULeq :: SExpr -> SExpr -> SExpr
bvULeq x :: SExpr
x y :: SExpr
y = String -> [SExpr] -> SExpr
fun "bvule" [SExpr
x,SExpr
y]
bvSLt :: SExpr -> SExpr -> SExpr
bvSLt :: SExpr -> SExpr -> SExpr
bvSLt x :: SExpr
x y :: SExpr
y = String -> [SExpr] -> SExpr
fun "bvslt" [SExpr
x,SExpr
y]
bvSLeq :: SExpr -> SExpr -> SExpr
bvSLeq :: SExpr -> SExpr -> SExpr
bvSLeq x :: SExpr
x y :: SExpr
y = String -> [SExpr] -> SExpr
fun "bvsle" [SExpr
x,SExpr
y]
add :: SExpr -> SExpr -> SExpr
add :: SExpr -> SExpr -> SExpr
add x :: SExpr
x y :: SExpr
y = String -> [SExpr] -> SExpr
fun "+" [SExpr
x,SExpr
y]
addMany :: [SExpr] -> SExpr
addMany :: [SExpr] -> SExpr
addMany xs :: [SExpr]
xs = if [SExpr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SExpr]
xs then Integer -> SExpr
int 0 else String -> [SExpr] -> SExpr
fun "+" [SExpr]
xs
sub :: SExpr -> SExpr -> SExpr
sub :: SExpr -> SExpr -> SExpr
sub x :: SExpr
x y :: SExpr
y = String -> [SExpr] -> SExpr
fun "-" [SExpr
x,SExpr
y]
neg :: SExpr -> SExpr
neg :: SExpr -> SExpr
neg x :: SExpr
x = String -> [SExpr] -> SExpr
fun "-" [SExpr
x]
mul :: SExpr -> SExpr -> SExpr
mul :: SExpr -> SExpr -> SExpr
mul x :: SExpr
x y :: SExpr
y = String -> [SExpr] -> SExpr
fun "*" [SExpr
x,SExpr
y]
abs :: SExpr -> SExpr
abs :: SExpr -> SExpr
abs x :: SExpr
x = String -> [SExpr] -> SExpr
fun "abs" [SExpr
x]
div :: SExpr -> SExpr -> SExpr
div :: SExpr -> SExpr -> SExpr
div x :: SExpr
x y :: SExpr
y = String -> [SExpr] -> SExpr
fun "div" [SExpr
x,SExpr
y]
mod :: SExpr -> SExpr -> SExpr
mod :: SExpr -> SExpr -> SExpr
mod x :: SExpr
x y :: SExpr
y = String -> [SExpr] -> SExpr
fun "mod" [SExpr
x,SExpr
y]
divisible :: SExpr -> Integer -> SExpr
divisible :: SExpr -> Integer -> SExpr
divisible x :: SExpr
x n :: Integer
n = [SExpr] -> SExpr
List [ String -> [Integer] -> SExpr
fam "divisible" [Integer
n], SExpr
x ]
realDiv :: SExpr -> SExpr -> SExpr
realDiv :: SExpr -> SExpr -> SExpr
realDiv x :: SExpr
x y :: SExpr
y = String -> [SExpr] -> SExpr
fun "/" [SExpr
x,SExpr
y]
concat :: SExpr -> SExpr -> SExpr
concat :: SExpr -> SExpr -> SExpr
concat x :: SExpr
x y :: SExpr
y = String -> [SExpr] -> SExpr
fun "concat" [SExpr
x,SExpr
y]
signExtend :: Integer -> SExpr -> SExpr
signExtend :: Integer -> SExpr -> SExpr
signExtend i :: Integer
i x :: SExpr
x = [SExpr] -> SExpr
List [ String -> [Integer] -> SExpr
fam "sign_extend" [Integer
i], SExpr
x ]
zeroExtend :: Integer -> SExpr -> SExpr
zeroExtend :: Integer -> SExpr -> SExpr
zeroExtend i :: Integer
i x :: SExpr
x = [SExpr] -> SExpr
List [ String -> [Integer] -> SExpr
fam "zero_extend" [Integer
i], SExpr
x ]
toInt :: SExpr -> SExpr
toInt :: SExpr -> SExpr
toInt e :: SExpr
e = String -> [SExpr] -> SExpr
fun "to_int" [SExpr
e]
toReal :: SExpr -> SExpr
toReal :: SExpr -> SExpr
toReal e :: SExpr
e = String -> [SExpr] -> SExpr
fun "to_real" [SExpr
e]
extract :: SExpr -> Integer -> Integer -> SExpr
x :: SExpr
x y :: Integer
y z :: Integer
z = [SExpr] -> SExpr
List [ String -> [Integer] -> SExpr
fam "extract" [Integer
y,Integer
z], SExpr
x ]
bvNot :: SExpr -> SExpr
bvNot :: SExpr -> SExpr
bvNot x :: SExpr
x = String -> [SExpr] -> SExpr
fun "bvnot" [SExpr
x]
bvAnd :: SExpr -> SExpr -> SExpr
bvAnd :: SExpr -> SExpr -> SExpr
bvAnd x :: SExpr
x y :: SExpr
y = String -> [SExpr] -> SExpr
fun "bvand" [SExpr
x,SExpr
y]
bvOr :: SExpr -> SExpr -> SExpr
bvOr :: SExpr -> SExpr -> SExpr
bvOr x :: SExpr
x y :: SExpr
y = String -> [SExpr] -> SExpr
fun "bvor" [SExpr
x,SExpr
y]
bvXOr :: SExpr -> SExpr -> SExpr
bvXOr :: SExpr -> SExpr -> SExpr
bvXOr x :: SExpr
x y :: SExpr
y = String -> [SExpr] -> SExpr
fun "bvxor" [SExpr
x,SExpr
y]
bvNeg :: SExpr -> SExpr
bvNeg :: SExpr -> SExpr
bvNeg x :: SExpr
x = String -> [SExpr] -> SExpr
fun "bvneg" [SExpr
x]
bvAdd :: SExpr -> SExpr -> SExpr
bvAdd :: SExpr -> SExpr -> SExpr
bvAdd x :: SExpr
x y :: SExpr
y = String -> [SExpr] -> SExpr
fun "bvadd" [SExpr
x,SExpr
y]
bvSub :: SExpr -> SExpr -> SExpr
bvSub :: SExpr -> SExpr -> SExpr
bvSub x :: SExpr
x y :: SExpr
y = String -> [SExpr] -> SExpr
fun "bvsub" [SExpr
x,SExpr
y]
bvMul :: SExpr -> SExpr -> SExpr
bvMul :: SExpr -> SExpr -> SExpr
bvMul x :: SExpr
x y :: SExpr
y = String -> [SExpr] -> SExpr
fun "bvmul" [SExpr
x,SExpr
y]
bvUDiv :: SExpr -> SExpr -> SExpr
bvUDiv :: SExpr -> SExpr -> SExpr
bvUDiv x :: SExpr
x y :: SExpr
y = String -> [SExpr] -> SExpr
fun "bvudiv" [SExpr
x,SExpr
y]
bvURem :: SExpr -> SExpr -> SExpr
bvURem :: SExpr -> SExpr -> SExpr
bvURem x :: SExpr
x y :: SExpr
y = String -> [SExpr] -> SExpr
fun "bvurem" [SExpr
x,SExpr
y]
bvSDiv :: SExpr -> SExpr -> SExpr
bvSDiv :: SExpr -> SExpr -> SExpr
bvSDiv x :: SExpr
x y :: SExpr
y = String -> [SExpr] -> SExpr
fun "bvsdiv" [SExpr
x,SExpr
y]
bvSRem :: SExpr -> SExpr -> SExpr
bvSRem :: SExpr -> SExpr -> SExpr
bvSRem x :: SExpr
x y :: SExpr
y = String -> [SExpr] -> SExpr
fun "bvsrem" [SExpr
x,SExpr
y]
bvShl :: SExpr -> SExpr -> SExpr
bvShl :: SExpr -> SExpr -> SExpr
bvShl x :: SExpr
x y :: SExpr
y = String -> [SExpr] -> SExpr
fun "bvshl" [SExpr
x,SExpr
y]
bvLShr :: SExpr -> SExpr -> SExpr
bvLShr :: SExpr -> SExpr -> SExpr
bvLShr x :: SExpr
x y :: SExpr
y = String -> [SExpr] -> SExpr
fun "bvlshr" [SExpr
x,SExpr
y]
bvAShr :: SExpr -> SExpr -> SExpr
bvAShr :: SExpr -> SExpr -> SExpr
bvAShr x :: SExpr
x y :: SExpr
y = String -> [SExpr] -> SExpr
fun "bvashr" [SExpr
x,SExpr
y]
select :: SExpr -> SExpr -> SExpr
select :: SExpr -> SExpr -> SExpr
select x :: SExpr
x y :: SExpr
y = String -> [SExpr] -> SExpr
fun "select" [SExpr
x,SExpr
y]
store :: SExpr ->
SExpr ->
SExpr ->
SExpr
store :: SExpr -> SExpr -> SExpr -> SExpr
store x :: SExpr
x y :: SExpr
y z :: SExpr
z = String -> [SExpr] -> SExpr
fun "store" [SExpr
x,SExpr
y,SExpr
z]
named :: String -> SExpr -> SExpr
named :: String -> SExpr -> SExpr
named x :: String
x e :: SExpr
e = String -> [SExpr] -> SExpr
fun "!" [SExpr
e, String -> SExpr
Atom ":named", String -> SExpr
Atom String
x ]
data Logger = Logger
{ Logger -> String -> IO ()
logMessage :: String -> IO ()
, Logger -> IO Int
logLevel :: IO Int
, Logger -> Int -> IO ()
logSetLevel:: Int -> IO ()
, Logger -> IO ()
logTab :: IO ()
, Logger -> IO ()
logUntab :: IO ()
}
withLogLevel :: Logger -> Int -> IO a -> IO a
withLogLevel :: Logger -> Int -> IO a -> IO a
withLogLevel Logger { .. } l :: Int
l m :: IO a
m =
do Int
l0 <- IO Int
logLevel
IO () -> IO () -> IO a -> IO a
forall a b c. IO a -> IO b -> IO c -> IO c
X.bracket_ (Int -> IO ()
logSetLevel Int
l) (Int -> IO ()
logSetLevel Int
l0) IO a
m
logIndented :: Logger -> IO a -> IO a
logIndented :: Logger -> IO a -> IO a
logIndented Logger { .. } = IO () -> IO () -> IO a -> IO a
forall a b c. IO a -> IO b -> IO c -> IO c
X.bracket_ IO ()
logTab IO ()
logUntab
logMessageAt :: Logger -> Int -> String -> IO ()
logMessageAt :: Logger -> Int -> String -> IO ()
logMessageAt logger :: Logger
logger l :: Int
l msg :: String
msg = Logger -> Int -> IO () -> IO ()
forall a. Logger -> Int -> IO a -> IO a
withLogLevel Logger
logger Int
l (Logger -> String -> IO ()
logMessage Logger
logger String
msg)
newLogger :: Int -> IO Logger
newLogger :: Int -> IO Logger
newLogger l :: Int
l =
do IORef Int
tab <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef 0
IORef Int
lev <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef 0
let logLevel :: IO Int
logLevel = IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
lev
logSetLevel :: Int -> IO ()
logSetLevel = IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
lev
shouldLog :: IO () -> IO ()
shouldLog m :: IO ()
m =
do Int
cl <- IO Int
logLevel
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
cl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
l) IO ()
m
logMessage :: String -> IO ()
logMessage x :: String
x = IO () -> IO ()
shouldLog (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
do let ls :: [String]
ls = String -> [String]
lines String
x
Int
t <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
tab
String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
t ' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
l | String
l <- [String]
ls ]
Handle -> IO ()
hFlush Handle
stdout
logTab :: IO ()
logTab = IO () -> IO ()
shouldLog (IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Int
tab (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2))
logUntab :: IO ()
logUntab = IO () -> IO ()
shouldLog (IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Int
tab (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract 2))
Logger -> IO Logger
forall (m :: * -> *) a. Monad m => a -> m a
return Logger :: (String -> IO ())
-> IO Int -> (Int -> IO ()) -> IO () -> IO () -> Logger
Logger { .. }