smtlib2 0.3.1 → 1.0
raw patch · 24 files changed
+5934/−5843 lines, 24 filesdep +dependent-mapdep +dependent-sumdep +template-haskelldep −arraydep −atto-lispdep −attoparsecdep ~base
Dependencies added: dependent-map, dependent-sum, template-haskell
Dependencies removed: array, atto-lisp, attoparsec, blaze-builder, bytestring, data-fix, process, tagged, text, transformers
Dependency ranges changed: base
Files
- Data/Unit.hs +0/−29
- Language/SMTLib2.hs +440/−105
- Language/SMTLib2/Connection.hs +0/−65
- Language/SMTLib2/Internals.hs +0/−1200
- Language/SMTLib2/Internals/Backend.hs +232/−0
- Language/SMTLib2/Internals/Embed.hs +291/−0
- Language/SMTLib2/Internals/Evaluate.hs +482/−0
- Language/SMTLib2/Internals/Expression.hs +1155/−0
- Language/SMTLib2/Internals/Instances.hs +0/−1658
- Language/SMTLib2/Internals/Interface.hs +1045/−677
- Language/SMTLib2/Internals/Monad.hs +101/−0
- Language/SMTLib2/Internals/Operators.hs +0/−58
- Language/SMTLib2/Internals/Optimize.hs +0/−247
- Language/SMTLib2/Internals/Proof.hs +89/−0
- Language/SMTLib2/Internals/Proof/Verify.hs +82/−0
- Language/SMTLib2/Internals/Type.hs +1126/−0
- Language/SMTLib2/Internals/Type/List.hs +346/−0
- Language/SMTLib2/Internals/Type/Nat.hs +253/−0
- Language/SMTLib2/Internals/Type/Struct.hs +187/−0
- Language/SMTLib2/Pipe.hs +0/−1743
- Language/SMTLib2/Solver.hs +0/−23
- Language/SMTLib2/Strategy.hs +20/−3
- README.org +43/−0
- smtlib2.cabal +42/−35
− Data/Unit.hs
@@ -1,29 +0,0 @@-{- | This module is used to express the fact that any tuple which is composed- only from empty tuples holds the same amount of information as an empty- tuple. -}-module Data.Unit where--{- | The unit class expresses the fact that all tuples composed from only empty- tuples hold the same amount of information as the empty tuple and can thus- all be constructed by a call to 'unit'. -}-class Unit t where- -- | Constructs a unit type- unit :: t--instance Unit () where- unit = ()--instance (Unit a,Unit b) => Unit (a,b) where- unit = (unit,unit)--instance (Unit a,Unit b,Unit c) => Unit (a,b,c) where- unit = (unit,unit,unit)--instance (Unit a,Unit b,Unit c,Unit d) => Unit (a,b,c,d) where- unit = (unit,unit,unit,unit)--instance (Unit a,Unit b,Unit c,Unit d,Unit e) => Unit (a,b,c,d,e) where- unit = (unit,unit,unit,unit,unit)--instance (Unit a,Unit b,Unit c,Unit d,Unit e,Unit f) => Unit (a,b,c,d,e,f) where- unit = (unit,unit,unit,unit,unit,unit)
Language/SMTLib2.hs view
@@ -1,117 +1,452 @@-{-# LANGUAGE OverloadedStrings,GADTs,FlexibleInstances,MultiParamTypeClasses,CPP #-} {- | Example usage: This program tries to find two numbers greater than zero which sum up to 5. @+{-# LANGUAGE GADTs #-} import Language.SMTLib2-import Language.SMTLib2.Solver+import Language.SMTLib2.Pipe -program :: SMT (Integer,Integer)+program :: Backend b => SMT b (Integer,Integer) program = do- x <- var- y <- var- assert $ (plus [x,y]) .==. (constant 5)- assert $ x .>. (constant 0)- assert $ y .>. (constant 0)+ x <- declareVar int+ y <- declareVar int+ assert $ x .+. y .==. cint 5+ assert $ x .>. cint 0+ assert $ y .>. cint 0 checkSat- vx <- getValue x- vy <- getValue y+ IntValue vx <- getValue x+ IntValue vy <- getValue y return (vx,vy) -main = withZ3 program >>= print+main = withBackend (createPipe "z3" ["-smt2","-in"]) program >>= print @ -}-module Language.SMTLib2 - (-- * Data types- SMT'(),SMT,- SMTBackend(),AnyBackend(..),- SMTType,- SMTAnnotation,- SMTValue,- SMTArith,- SMTOrd(..),- SMTExpr,- SMTFunction,- SMTOption(..),- SMTArray,- Constructor,- Field,- Args(..),LiftArgs(..),- -- * Environment- withSMTBackend,withSMTBackendExitCleanly,- setOption,getInfo,setLogic,- SMTInfo(..),- assert,push,pop,stack,- checkSat,checkSat',checkSatUsing,apply,- CheckSatResult(..),- CheckSatLimits(..),noLimits,- getValue,getValues,getModel,- comment,- getProof,- simplify,- -- ** Unsatisfiable Core- ClauseId(),- assertId,- getUnsatCore,- -- ** Interpolation- InterpolationGroup(),- interpolationGroup,- assertInterp,- getInterpolant,- interpolate,- -- * Expressions- var,varNamed,varNamedAnn,varAnn,argVars,argVarsAnn,argVarsAnnNamed,- untypedVar,untypedNamedVar,- constant,constantAnn,- extractAnnotation,- let',lets,letAnn,- named,named',- optimizeExpr,optimizeExpr',- foldExpr,foldExprM,- foldArgs,foldArgsM,- -- ** Basic logic- (.==.),argEq,- distinct,- ite,- (.&&.),(.||.),and',or',xor,not',not'',(.=>.),- forAll,exists,- forAllAnn,existsAnn,- forAllList,existsList,- -- ** Arithmetic- plus,minus,mult,div',mod',rem',neg,divide,toReal,toInt,- -- ** Arrays- select,store,arrayEquals,unmangleArray,asArray,constArray,- -- ** Bitvectors- bvand,bvor,bvxor,bvnot,bvneg,- bvadd,bvsub,bvmul,bvurem,bvsrem,bvudiv,bvsdiv,- bvule,bvult,bvuge,bvugt,- bvsle,bvslt,bvsge,bvsgt,- bvshl,bvlshr,bvashr,- BitVector(..),-#ifdef SMTLIB2_WITH_DATAKINDS- BVKind(..),-#else- BVTyped,BVUntyped,-#endif- BV8,BV16,BV32,BV64,- N0,N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15,N16,N17,N18,N19,N20,N21,N22,N23,N24,N25,N26,N27,N28,N29,N30,N31,N32,N33,N34,N35,N36,N37,N38,N39,N40,N41,N42,N43,N44,N45,N46,N47,N48,N49,N50,N51,N52,N53,N54,N55,N56,N57,N58,N59,N60,N61,N62,N63,N64,- bvconcat,--bvextract,bvextractUnsafe,- bvsplitu16to8,- bvsplitu32to16,bvsplitu32to8,- bvsplitu64to32,bvsplitu64to16,bvsplitu64to8,- bvextract,bvextract',- -- ** Functions- funAnn,funAnnNamed,funAnnRet,fun,app,defFun,defConst,defConstNamed,defFunAnn,defFunAnnNamed,map',- -- ** Data types- is,(.#),- -- ** Lists- head',tail',insert',isNil,isInsert,- -- * Untyped expressions- Untyped,UntypedValue,- entype,entypeValue,- castUntypedExpr,castUntypedExprValue- )- where+module Language.SMTLib2 (+ -- * SMT Monad+ SMT(),Embed(),+ B.Backend(SMTMonad),+ withBackend,+ withBackendExitCleanly,+ -- * Setting options+ setOption,B.SMTOption(..),+ -- * Getting informations about the solver+ getInfo,B.SMTInfo(..),+ -- * Expressions+ B.Expr(),+ -- ** Declaring variables+ declareVar,declareVarNamed,+ -- ** Defining variables+ defineVar,defineVarNamed,+ -- ** Declaring functions+ declareFun,declareFunNamed,+ -- ** Defining functions+ defineFun,defineFunNamed,+ -- ** Constants+ constant,Value(..),+ -- *** Boolean constants+ pattern ConstBool,cbool,true,false,+ -- *** Integer constants+ pattern ConstInt,cint,+ -- *** Real constants+ pattern ConstReal,creal,+ -- *** Bitvector constants+ BitWidth(),bw,pattern ConstBV,cbv,cbvUntyped,+ -- *** Datatype constants+ cdt,+ -- ** Quantification+ exists, forall,+ -- ** Functions+ pattern Fun,app,fun,+ -- *** Equality+ pattern EqLst,pattern Eq,pattern (:==:),+ eq,(.==.),+ pattern DistinctLst,pattern Distinct,pattern (:/=:),+ distinct,(./=.),+ -- *** Map+ map',+ -- *** Comparison+ pattern Ord,pattern (:>=:),pattern (:>:),pattern (:<=:),pattern (:<:),+ ord,(.>=.),(.>.),(.<=.),(.<.),+ -- *** Arithmetic+ pattern ArithLst,pattern Arith,arith,+ pattern PlusLst,pattern Plus,pattern (:+:),plus,(.+.),+ pattern MultLst,pattern Mult,pattern (:*:),mult,(.*.),+ pattern MinusLst,pattern Minus,pattern (:-:),pattern Neg,minus,(.-.),neg,+ pattern Div,pattern Mod,pattern Rem,div',mod',rem',+ pattern (:/:),(./.),+ pattern Abs,abs',+ -- *** Logic+ pattern Not,not',+ pattern LogicLst,pattern Logic,logic,+ pattern AndLst,pattern And,pattern (:&:),and',(.&.),+ pattern OrLst,pattern Or,pattern (:|:),or',(.|.),+ pattern XOrLst,pattern XOr,xor',+ pattern ImpliesLst,pattern Implies,pattern (:=>:),implies,(.=>.),+ -- *** Conversion+ pattern ToReal,pattern ToInt,toReal,toInt,+ -- *** If-then-else+ pattern ITE,ite,+ -- *** Bitvectors+ pattern BVComp,pattern BVULE,pattern BVULT,pattern BVUGE,pattern BVUGT,pattern BVSLE,pattern BVSLT,pattern BVSGE,pattern BVSGT,bvcomp,bvule,bvult,bvuge,bvugt,bvsle,bvslt,bvsge,bvsgt,+ pattern BVBin,pattern BVAdd,pattern BVSub,pattern BVMul,pattern BVURem,pattern BVSRem,pattern BVUDiv,pattern BVSDiv,pattern BVSHL,pattern BVLSHR,pattern BVASHR,pattern BVXor,pattern BVAnd,pattern BVOr,bvbin,bvadd,bvsub,bvmul,bvurem,bvsrem,bvudiv,bvsdiv,bvshl,bvlshr,bvashr,bvxor,bvand,bvor,+ pattern BVUn,pattern BVNot,pattern BVNeg,+ bvun,bvnot,bvneg,+ pattern Concat,pattern Extract,concat',extract',extractChecked,extractUntypedStart,extractUntyped,+ -- *** Arrays+ pattern Select,pattern Store,pattern ConstArray,select,select1,store,store1,constArray,+ -- *** Datatypes+ pattern Mk,mk,pattern Is,is,(.#.),+ -- *** Misc+ pattern Divisible,divisible,+ -- ** Analyzation+ getExpr,+ -- * Satisfiability+ assert,checkSat,checkSatWith,+ B.CheckSatResult(..),+ B.CheckSatLimits(..),noLimits,+ -- ** Unsatisfiable core+ assertId,getUnsatCore,B.ClauseId(),+ -- ** Interpolation+ assertPartition,B.Partition(..),+ getInterpolant,+ -- ** Proofs+ getProof,analyzeProof,+ -- ** Stack+ push,pop,stack,+ -- ** Models+ getValue,+ getModel,+ B.Model(),+ modelEvaluate,+ -- * Types+ registerDatatype,+ Type(..),Repr(..),GetType(..),bool,int,real,bitvec,array,dt,dt',+ -- ** Numbers+ Nat(..),Natural(..),nat,natT,reifyNat,+ -- ** Lists+ List(..),reifyList,(.:.),nil,+ -- * Misc+ comment,simplify+ ) where -import Language.SMTLib2.Internals-import Language.SMTLib2.Internals.Instances-import Language.SMTLib2.Internals.Optimize+import Language.SMTLib2.Internals.Type+import Language.SMTLib2.Internals.Type.Nat+import Language.SMTLib2.Internals.Type.List hiding (nil)+import qualified Language.SMTLib2.Internals.Type.List as List+import Language.SMTLib2.Internals.Monad+import qualified Language.SMTLib2.Internals.Expression as E+import qualified Language.SMTLib2.Internals.Proof as P+import qualified Language.SMTLib2.Internals.Backend as B import Language.SMTLib2.Internals.Interface+import Language.SMTLib2.Internals.Embed+import Language.SMTLib2.Strategy++import Control.Monad.State.Strict++-- | Set an option controlling the behaviour of the SMT solver.+-- Many solvers require you to specify what kind of queries you'll ask them+-- after the model is specified.+--+-- For example, when using interpolation, it is often required to do the+-- following:+--+-- @+-- do+-- setOption (ProduceInterpolants True)+-- -- Declare model+-- interp <- getInterpolant+-- -- Use interpolant+-- @+setOption :: B.Backend b => B.SMTOption -> SMT b ()+setOption opt = embedSMT $ B.setOption opt++-- | Query the solver for information about itself.+--+-- Example:+--+-- > isZ3Solver :: Backend b => SMT b Bool+-- > isZ3Solver = do+-- > name <- getInfo SMTSolverName+-- > return $ name=="Z3"+getInfo :: B.Backend b => B.SMTInfo i -> SMT b i+getInfo info = embedSMT $ B.getInfo info++-- | Asserts a boolean expression to be true.+-- A successive successful `checkSat` calls mean that the generated model is consistent with the assertion.+assert :: (B.Backend b,HasMonad expr,MatchMonad expr (SMT b),MonadResult expr ~ B.Expr b BoolType)+ => expr -> SMT b ()+assert e = embedM e >>= embedSMT . B.assert++-- | Works like `assert`, but additionally allows the user to find the+-- unsatisfiable core of a set of assignments using `getUnsatCore`.+assertId :: (B.Backend b,HasMonad expr,MatchMonad expr (SMT b),MonadResult expr ~ B.Expr b BoolType)+ => expr -> SMT b (B.ClauseId b)+assertId e = embedM e >>= embedSMT . B.assertId++-- | When using interpolation, use this function to specify if an assertion is+-- part of the A-partition or the B-partition of the original formula.+assertPartition :: (B.Backend b,HasMonad expr,MatchMonad expr (SMT b),+ MonadResult expr ~ B.Expr b BoolType)+ => expr -> B.Partition -> SMT b ()+assertPartition e p = do+ e' <- embedM e+ embedSMT (B.assertPartition e' p)++-- | Checks if the set of asserted expressions is satisfiable.+checkSat :: B.Backend b => SMT b B.CheckSatResult+checkSat = embedSMT (B.checkSat Nothing noLimits)++-- | The same as `checkSat`, but can specify an optional `Tactic` that is used+-- to give hints to the SMT solver on how to solve the problem and limits on+-- the amount of time and memory that the solver is allowed to use.+-- If the limits are exhausted, the solver must return `Unknown`.+checkSatWith :: B.Backend b => Maybe Tactic -> B.CheckSatLimits -> SMT b B.CheckSatResult+checkSatWith tactic limits = embedSMT (B.checkSat tactic limits)++noLimits :: B.CheckSatLimits+noLimits = B.CheckSatLimits Nothing Nothing++-- | After a successful `checkSat` query, query the concrete value for a given+-- expression that the SMT solver assigned to it.+getValue :: (B.Backend b,HasMonad expr,MatchMonad expr (SMT b),+ MonadResult expr ~ B.Expr b t)+ => expr -> SMT b (Value t)+getValue e = embedM e >>= embedSMT . B.getValue++-- | After a successful `checkSat` query, return a satisfying assignment that makes all asserted formula true.+getModel :: B.Backend b => SMT b (B.Model b)+getModel = embedSMT B.getModel++-- | Evaluate an expression in a model, yielding a concrete value.+modelEvaluate :: (B.Backend b,HasMonad expr,MatchMonad expr (SMT b),+ MonadResult expr ~ B.Expr b t)+ => B.Model b -> expr -> SMT b (Value t)+modelEvaluate mdl e = embedM e >>= embedSMT . B.modelEvaluate mdl++-- | Push a fresh frame on the solver stack.+-- All variable definitions and assertions made in a frame are forgotten when+-- it is `pop`'ed.+push :: B.Backend b => SMT b ()+push = embedSMT B.push++-- | Pop a frame from the solver stack.+pop :: B.Backend b => SMT b ()+pop = embedSMT B.pop++-- | Perform an SMT action by executing it in a fresh stack frame. The frame is+-- `pop`'ed once the action has been performed.+stack :: B.Backend b => SMT b a -> SMT b a+stack act = do+ push+ res <- act+ pop+ return res++-- | Create a fresh variable of a given type.+--+-- Example:+--+-- @+-- do+-- -- Declare a single integer variable+-- v <- declareVar int+-- -- Use variable v+-- @+declareVar :: B.Backend b => Repr t -- ^ The type of the variable+ -> SMT b (B.Expr b t)+declareVar tp = declareVar' tp >>= embedSMT . B.toBackend . E.Var++-- | Create a fresh variable (like `declareVar`), but also give it a name.+-- Note that the name is a hint to the SMT solver that it may ignore.+--+-- Example:+--+-- @+-- do+-- -- Declare a single boolean variable called "x"+-- x <- declareVarNamed bool "x"+-- -- Use variable x+-- @+declareVarNamed :: B.Backend b => Repr t -- ^ Type of the variable+ -> String -- ^ Name of the variable+ -> SMT b (B.Expr b t)+declareVarNamed tp name = declareVarNamed' tp name >>= embedSMT . B.toBackend . E.Var++-- | Create a new variable that is defined by a given expression.+--+-- Example:+--+-- @+-- do+-- -- x is an integer+-- x <- declareVar int+-- -- y is defined to be x+5+-- y <- defineVar $ x .+. cint 5+-- -- Use x and y+-- @+defineVar :: (B.Backend b,HasMonad expr,MatchMonad expr (SMT b),+ MonadResult expr ~ B.Expr b t)+ => expr -- ^ The definition expression+ -> SMT b (B.Expr b t)+defineVar e = embedM e >>= defineVar' >>= embedSMT . B.toBackend . E.Var++-- | Create a new named variable that is defined by a given expression (like+-- `defineVar`).+defineVarNamed :: (B.Backend b,HasMonad expr,MatchMonad expr (SMT b),+ MonadResult expr ~ B.Expr b t)+ => String -- ^ Name of the resulting variable+ -> expr -- ^ Definition of the variable+ -> SMT b (B.Expr b t)+defineVarNamed name e = embedM e >>= defineVarNamed' name >>= embedSMT . B.toBackend . E.Var++-- | Create a new uninterpreted function by specifying its signature.+--+-- Example:+--+-- @+-- do+-- -- Create a function from (int,bool) to int+-- f <- declareFun (int ::: bool ::: Nil) int+-- -- Use f+-- @+declareFun :: B.Backend b+ => List Repr args -- ^ Function argument types+ -> Repr res -- ^ Function result type+ -> SMT b (B.Fun b '(args,res))+declareFun args res = embedSMT $ B.declareFun args res Nothing++-- | Create a new uninterpreted function by specifying its signature (like+-- `declareFun`), but also give it a name.+declareFunNamed :: B.Backend b => List Repr args -- ^ Function argument types+ -> Repr res -- ^ Function result type+ -> String -- ^ Function name+ -> SMT b (B.Fun b '(args,res))+declareFunNamed args res name = embedSMT $ B.declareFun args res (Just name)++-- | Create a new interpreted function with a definition.+-- Given a signature and a (haskell) function from the arguments to the+-- resulting expression.+--+-- Example:+--+-- @+-- do+-- -- Create a function from (int,int) to int that calculates the maximum+-- max <- defineFun (int ::: int ::: Nil) $+-- \(x ::: y ::: Nil) -> ite (x .>. y) x y+-- -- Use max function+-- @+defineFun :: (B.Backend b,HasMonad def,MatchMonad def (SMT b),+ MonadResult def ~ B.Expr b res)+ => List Repr args -- ^ Function argument types+ -> (List (B.Expr b) args -> def) -- ^ Function definition+ -> SMT b (B.Fun b '(args,res))+defineFun tps f = do+ args <- List.mapM (\tp -> embedSMT $ B.createFunArg tp Nothing) tps+ args' <- List.mapM (embedSMT . B.toBackend . E.FVar) args+ res <- embedM $ f args'+ embedSMT $ B.defineFun Nothing args res++-- | Create a new interpreted function with a definition (like `defineFun`) but+-- also give it a name.+defineFunNamed :: (B.Backend b,HasMonad def,MatchMonad def (SMT b),+ MonadResult def ~ B.Expr b res)+ => String+ -> List Repr args+ -> (List (B.Expr b) args -> def)+ -> SMT b (B.Fun b '(args,res))+defineFunNamed name tps f = do+ args <- List.mapM (\tp -> embedSMT $ B.createFunArg tp Nothing) tps+ args' <- List.mapM (embedSMT . B.toBackend . E.FVar) args+ res <- embedM $ f args'+ embedSMT $ B.defineFun (Just name) args res++-- | After a `checkSat` query that returned 'Unsat', we can ask the SMT solver+-- for a subset of the assertions that are enough to make the specified+-- problem unsatisfiable. These assertions have to be created using+-- `assertId`.+--+-- Example:+--+-- > do+-- > setOption (ProduceUnsatCores True)+-- > x <- declareVar int+-- > y <- declareVar int+-- > cl1 <- assertId $ x .>. y+-- > cl2 <- assertId $ x .>. cint 5+-- > cl3 <- assertId $ y .>. x+-- > checkSat+-- > core <- getUnsatCore+-- > -- core will contain cl1 and cl3+getUnsatCore :: B.Backend b => SMT b [B.ClauseId b]+getUnsatCore = embedSMT B.getUnsatCore++-- | After a `checkSat` query that returned 'Unsat', we can ask the SMT solver+-- for a formula /C/ such that /A/ (the A-partition) and /(not C)/ is+-- unsatisfiable while /B/ (the B-partition) and /C/ is unsatisfiable.+-- Furthermore, /C/ will only mention variables that occur in both /A/ and+-- /B/.+--+-- Example:+--+-- @+-- do+-- setOption (ProduceInterpolants True)+-- p <- declareVar bool+-- q <- declareVar bool+-- r <- declareVar bool+-- t <- declareVar bool+-- assertPartition ((not' (p .&. q)) .=>. ((not' r) .&. q)) PartitionA+-- assertPartition t PartitionB+-- assertPartition r PartitionB+-- assertPartition (not' p) PartitionB+-- checkSat+-- getInterpolant+-- @+getInterpolant :: B.Backend b => SMT b (B.Expr b BoolType)+getInterpolant = embedSMT B.interpolate++-- | Convert an expression in the SMT solver-specific format into a more+-- general, pattern-matchable format.+--+-- Example:+--+-- @+-- isGE :: Backend b => Expr b tp -> SMT b Bool+-- isGE e = do+-- e' <- getExpr e+-- case e' of+-- _ :>=: _ -> return True+-- _ -> return False+-- @+getExpr :: (B.Backend b) => B.Expr b tp+ -> SMT b (E.Expression+ (B.Var b)+ (B.QVar b)+ (B.Fun b)+ (B.FunArg b)+ (B.LVar b)+ (B.Expr b) tp)+getExpr e = do+ st <- get+ return $ B.fromBackend (backend st) e++-- | Inject a comment into the SMT command stream.+-- Only useful when using the /smtlib2-debug/ package to inspect the command+-- stream.+comment :: (B.Backend b) => String -> SMT b ()+comment msg = embedSMT $ B.comment msg++-- | Use the SMT solver to simplify a given expression.+simplify :: B.Backend b => B.Expr b tp -> SMT b (B.Expr b tp)+simplify e = embedSMT $ B.simplify e++-- | After a `checkSat` query that returned 'Unsat', we can ask the solver for+-- a proof that the given instance is indeed unsatisfiable.+getProof :: B.Backend b => SMT b (B.Proof b)+getProof = embedSMT B.getProof++-- | Convert the solver-specific proof encoding into a more general,+-- pattern-matchable format.+analyzeProof :: B.Backend b => B.Proof b -> SMT b (P.Proof String (B.Expr b) (B.Proof b))+analyzeProof pr = do+ st <- get+ return $ B.analyzeProof (backend st) pr
− Language/SMTLib2/Connection.hs
@@ -1,65 +0,0 @@-{- | This module can be used if the simple 'Language.SMTLib2.withSMTSolver'-interface isn't- sufficient, e.g. if you don't want to wrap your whole program into one big- 'Language.SMTLib2.MonadSMT' or you want to run multiple solvers side by side. -}-module Language.SMTLib2.Connection- (SMTConnection()- ,open- ,close- ,withConnection- ,performSMT- ,performSMTExitCleanly- ) where--import Language.SMTLib2.Internals-import Control.Concurrent.MVar-import Control.Monad.Trans (MonadIO,liftIO)-import Control.Exception-import Prelude (($),IO,return)---- | Represents a connection to an SMT solver.--- The SMT solver runs in a seperate thread and communication is handled via handles.-data SMTConnection b = SMTConnection { backend :: MVar b- }---- | Create a new connection to a SMT solver by spawning a shell command.--- The solver must be able to read from stdin and write to stdout.-open :: (MonadIO m,SMTBackend b m) => b -- ^ The backend for the SMT solver.- -> m (SMTConnection b)-open solver = do- st <- liftIO $ newMVar solver- return (SMTConnection { backend = st })---- | Closes an open SMT connection. Do not use the connection afterwards.-close :: (MonadIO m,SMTBackend b m) => SMTConnection b -> m ()-close conn = do- st <- liftIO $ takeMVar (backend conn)- smtHandle st SMTExit- return ()--withConnection :: MonadIO m => SMTConnection b -> (b -> m (a,b)) -> m a-withConnection conn f = do- b <- liftIO $ takeMVar (backend conn)- (res,nb) <- f b- liftIO $ putMVar (backend conn) nb- return res---- | Perform an action in the SMT solver associated with this connection and return the result.-performSMT :: (MonadIO m,SMTBackend b m)- => SMTConnection b -- ^ The connection to the SMT solver to use- -> SMT' m a -- ^ The action to perform- -> m a-performSMT conn act = withConnection conn (runSMT act)--performSMTExitCleanly :: SMTBackend b IO- => SMTConnection b- -> SMT' IO a- -> IO a-performSMTExitCleanly conn act = do- b <- takeMVar (backend conn)- catch (do- (res,nb) <- runSMT act b- putMVar (backend conn) nb- return res)- (\e -> do- smtHandle b SMTExit- throw (e :: SomeException))
− Language/SMTLib2/Internals.hs
@@ -1,1200 +0,0 @@-{-# LANGUAGE OverloadedStrings,GADTs,FlexibleInstances,MultiParamTypeClasses,RankNTypes,DeriveDataTypeable,TypeSynonymInstances,TypeFamilies,FlexibleContexts,CPP,ScopedTypeVariables,GeneralizedNewtypeDeriving #-}-module Language.SMTLib2.Internals where--import Language.SMTLib2.Internals.Operators-import Language.SMTLib2.Strategy--import Data.Typeable-import Data.Map as Map hiding (assocs,foldl)-import Data.Ratio-import Data.Proxy-#ifdef SMTLIB2_WITH_CONSTRAINTS-import Data.Constraint-#endif-#ifdef SMTLIB2_WITH_DATAKINDS-import Data.Tagged-import Data.List as List (genericReplicate)-#endif-import Data.Fix-import Prelude hiding (mapM,mapM_,foldl,all,maximum)-import Data.Foldable-import Data.Traversable-import Control.Exception-import Data.Functor.Identity-import Data.Char (isDigit)---- Monad stuff-import Control.Applicative (Applicative(..))-import Control.Monad.Trans-import Control.Monad.Fix-import Control.Monad (ap,when)--data SMTRequest response where- SMTSetLogic :: String -> SMTRequest ()- SMTGetInfo :: SMTInfo i -> SMTRequest i- SMTSetOption :: SMTOption -> SMTRequest ()- SMTAssert :: SMTExpr Bool -> Maybe InterpolationGroup -> Maybe ClauseId -> SMTRequest ()- SMTCheckSat :: Maybe Tactic -> CheckSatLimits -> SMTRequest CheckSatResult- SMTDeclaredDataTypes :: SMTRequest DataTypeInfo- SMTDeclareDataTypes :: TypeCollection -> SMTRequest ()- SMTDeclareSort :: String -> Integer -> SMTRequest ()- SMTPush :: SMTRequest ()- SMTPop :: SMTRequest ()- SMTDefineFun :: (Args arg,SMTType res) => Maybe String -> Proxy arg -> ArgAnnotation arg -> SMTExpr res -> SMTRequest Integer- SMTDeclareFun :: FunInfo -> SMTRequest Integer- SMTGetValue :: SMTValue t => SMTExpr t -> SMTRequest t- SMTGetModel :: SMTRequest SMTModel- SMTGetProof :: SMTRequest (SMTExpr Bool)- SMTGetUnsatCore :: SMTRequest [ClauseId]- SMTSimplify :: SMTType t => SMTExpr t -> SMTRequest (SMTExpr t)- SMTGetInterpolant :: [InterpolationGroup] -> SMTRequest (SMTExpr Bool)- SMTInterpolate :: [SMTExpr Bool] -> SMTRequest [SMTExpr Bool]- SMTComment :: String -> SMTRequest ()- SMTExit :: SMTRequest ()- SMTApply :: Tactic -> SMTRequest [SMTExpr Bool]- SMTNameExpr :: SMTType t => String -> SMTExpr t -> SMTRequest Integer- SMTNewInterpolationGroup :: SMTRequest InterpolationGroup- SMTNewClauseId :: SMTRequest ClauseId- deriving Typeable--data SMTModel = SMTModel { modelFunctions :: Map Integer (Integer,[ProxyArg],SMTExpr Untyped)- } deriving (Show,Typeable)---- | Describe limits on the ressources that an SMT-solver can use-data CheckSatLimits = CheckSatLimits { limitTime :: Maybe Integer -- ^ A limit on the amount of time the solver can spend on the problem (in milliseconds)- , limitMemory :: Maybe Integer -- ^ A limit on the amount of memory the solver can use (in megabytes)- } deriving (Show,Eq,Ord,Typeable)---- | The result of a check-sat query-data CheckSatResult- = Sat -- ^ The formula is satisfiable- | Unsat -- ^ The formula is unsatisfiable- | Unknown -- ^ The solver cannot determine the satisfiability of a formula- deriving (Show,Eq,Ord,Typeable)--class Monad m => SMTBackend a m where- smtHandle :: Typeable response => a -> SMTRequest response -> m (response,a)- smtGetNames :: a -> m (Integer -> String)- smtNextName :: a -> m (Maybe String -> String)---- | Haskell types which can be represented in SMT-class (Ord t,Typeable t,- Ord (SMTAnnotation t),Typeable (SMTAnnotation t),Show (SMTAnnotation t))- => SMTType t where- type SMTAnnotation t- getSort :: t -> SMTAnnotation t -> Sort- asDataType :: t -> SMTAnnotation t -> Maybe (String,TypeCollection)- asDataType _ _ = Nothing- asValueType :: t -> SMTAnnotation t -> (forall v. SMTValue v => v -> SMTAnnotation v -> r) -> Maybe r- getProxyArgs :: t -> SMTAnnotation t -> [ProxyArg]- getProxyArgs _ _ = []- additionalConstraints :: t -> SMTAnnotation t -> Maybe (SMTExpr t -> [SMTExpr Bool])- additionalConstraints _ _ = Nothing- annotationFromSort :: t -> Sort -> SMTAnnotation t- defaultExpr :: SMTAnnotation t -> SMTExpr t--data ArgumentSort' a = ArgumentSort Integer- | NormalSort (Sort' a)--type ArgumentSort = Fix ArgumentSort'--data Unmangling a = PrimitiveUnmangling (Value -> SMTAnnotation a -> Maybe a)- | ComplexUnmangling (forall m s. Monad m => (forall b. SMTValue b => s -> SMTExpr b -> SMTAnnotation b -> m (b,s)) -> s -> SMTExpr a -> SMTAnnotation a -> m (Maybe a,s))--data Mangling a = PrimitiveMangling (a -> SMTAnnotation a -> Value)- | ComplexMangling (a -> SMTAnnotation a -> SMTExpr a)---- | Haskell values which can be represented as SMT constants-class (SMTType t,Show t) => SMTValue t where- unmangle :: Unmangling t- mangle :: Mangling t---- | A type class for all types which support arithmetic operations in SMT-class (SMTValue t,Num t,SMTAnnotation t ~ ()) => SMTArith t---- | Lifts the 'Ord' class into SMT-class (SMTType t) => SMTOrd t where- (.<.) :: SMTExpr t -> SMTExpr t -> SMTExpr Bool- (.>=.) :: SMTExpr t -> SMTExpr t -> SMTExpr Bool- (.>.) :: SMTExpr t -> SMTExpr t -> SMTExpr Bool- (.<=.) :: SMTExpr t -> SMTExpr t -> SMTExpr Bool--infix 4 .<., .<=., .>=., .>.---- | An array which maps indices of type /i/ to elements of type /v/.-data SMTArray (i :: *) (v :: *) = SMTArray deriving (Eq,Ord,Typeable)--data FunInfo = forall arg r. (Args arg,SMTType r) => FunInfo { funInfoProxy :: Proxy (arg,r)- , funInfoArgAnn :: ArgAnnotation arg- , funInfoResAnn :: SMTAnnotation r- , funInfoName :: Maybe String- }--data AnyBackend m = forall b. SMTBackend b m => AnyBackend b---- | The SMT monad used for communating with the SMT solver-data SMT' m a = SMT { runSMT :: forall b. SMTBackend b m => b -> m (a,b) }--type SMT = SMT' IO--instance Functor m => Functor (SMT' m) where- fmap f (SMT g) = SMT $ \b -> fmap (\(r,b) -> (f r,b)) (g b)--instance Monad m => Monad (SMT' m) where- return x = SMT $ \b -> return (x,b)- (SMT f) >>= g = SMT $ \b -> do- (r,b1) <- f b- case g r of- SMT act -> act b1--instance MonadIO m => MonadIO (SMT' m) where- liftIO act = SMT $ \b -> do- res <- liftIO act- return (res,b)--instance MonadFix m => MonadFix (SMT' m) where- mfix f = SMT $ \b -> mfix (\(~(res,_)) -> case f res of- ~(SMT act) -> act b)--instance (Monad m,Functor m) => Applicative (SMT' m) where- pure = return- (<*>) = ap--smtBackend :: Monad m => (forall b. SMTBackend b m => b -> m (res,b)) -> SMT' m res-smtBackend f = SMT f--instance MonadTrans SMT' where- lift act = SMT $ \b -> do- res <- act- return (res,b)--data Untyped = forall t. SMTType t => Untyped t deriving Typeable--data UntypedValue = forall t. SMTValue t => UntypedValue t deriving Typeable--instance Eq Untyped where- (Untyped x) == (Untyped y) = case cast y of- Just y' -> x==y'- Nothing -> False--instance Ord Untyped where- compare (Untyped x) (Untyped y) = case compare (typeOf x) (typeOf y) of- EQ -> case cast y of- Just y' -> compare x y'- r -> r--instance Eq UntypedValue where- (UntypedValue x) == (UntypedValue y) = case cast y of- Just y' -> x==y'- Nothing -> False--instance Ord UntypedValue where- compare (UntypedValue x) (UntypedValue y) = case compare (typeOf x) (typeOf y) of- EQ -> case cast y of- Just y' -> compare x y'- r -> r--instance Show UntypedValue where- showsPrec p (UntypedValue x) = showsPrec p x---- | An abstract SMT expression-data SMTExpr t where- Var :: SMTType t => Integer -> SMTAnnotation t -> SMTExpr t- QVar :: SMTType t => Integer -> Integer -> SMTAnnotation t -> SMTExpr t- FunArg :: SMTType t => Integer -> SMTAnnotation t -> SMTExpr t- Const :: SMTValue t => t -> SMTAnnotation t -> SMTExpr t- AsArray :: (Args arg,SMTType res) => SMTFunction arg res -> ArgAnnotation arg- -> SMTExpr (SMTArray arg res)- Forall :: Integer -> [ProxyArg] -> SMTExpr Bool -> SMTExpr Bool- Exists :: Integer -> [ProxyArg] -> SMTExpr Bool -> SMTExpr Bool- Let :: Integer -> [SMTExpr Untyped] -> SMTExpr b -> SMTExpr b- App :: (Args arg,SMTType res) => SMTFunction arg res -> arg -> SMTExpr res- Named :: SMTExpr a -> Integer -> SMTExpr a- InternalObj :: (SMTType t,Typeable a,Ord a,Show a) => a -> SMTAnnotation t -> SMTExpr t- UntypedExpr :: SMTType t => SMTExpr t -> SMTExpr Untyped- UntypedExprValue :: SMTValue t => SMTExpr t -> SMTExpr UntypedValue- deriving Typeable--data Sort' a = BoolSort- | IntSort- | RealSort- | BVSort { bvSortWidth :: Integer- , bvSortUntyped :: Bool }- | ArraySort [a] a- | NamedSort String [a]- deriving (Eq,Ord,Show,Functor,Foldable,Traversable)--type Sort = Fix Sort'--data Value = BoolValue Bool- | IntValue Integer- | RealValue (Ratio Integer)- | BVValue { bvValueWidth :: Integer- , bvValueValue :: Integer }- | ConstrValue String [Value] (Maybe (String,[Sort]))- deriving (Eq,Ord,Show)--data SMTFunction arg res where- SMTEq :: SMTType a => SMTFunction [SMTExpr a] Bool- SMTMap :: (Liftable arg,SMTType res,Args i) => SMTFunction arg res -> SMTFunction (Lifted arg i) (SMTArray i res)- SMTFun :: (Args arg,SMTType res) => Integer -> SMTAnnotation res -> SMTFunction arg res- SMTBuiltIn :: (Liftable arg,SMTType res) => String -> SMTAnnotation res -> SMTFunction arg res- SMTOrd :: (SMTArith a) => SMTOrdOp -> SMTFunction (SMTExpr a,SMTExpr a) Bool- SMTArith :: (SMTArith a) => SMTArithOp -> SMTFunction [SMTExpr a] a- SMTMinus :: (SMTArith a) => SMTFunction (SMTExpr a,SMTExpr a) a- SMTIntArith :: SMTIntArithOp -> SMTFunction (SMTExpr Integer,SMTExpr Integer) Integer- SMTDivide :: SMTFunction (SMTExpr Rational,SMTExpr Rational) Rational- SMTNeg :: (SMTType a,Num a) => SMTFunction (SMTExpr a) a- SMTAbs :: (SMTType a,Num a) => SMTFunction (SMTExpr a) a- SMTNot :: SMTFunction (SMTExpr Bool) Bool- SMTLogic :: SMTLogicOp -> SMTFunction [SMTExpr Bool] Bool- SMTDistinct :: SMTType a => SMTFunction [SMTExpr a] Bool- SMTToReal :: SMTFunction (SMTExpr Integer) Rational- SMTToInt :: SMTFunction (SMTExpr Rational) Integer- SMTITE :: SMTType a => SMTFunction (SMTExpr Bool,SMTExpr a,SMTExpr a) a- SMTBVComp :: IsBitVector a => SMTBVCompOp -> SMTFunction (SMTExpr (BitVector a),SMTExpr (BitVector a)) Bool- SMTBVBin :: IsBitVector a => SMTBVBinOp -> SMTFunction (SMTExpr (BitVector a),SMTExpr (BitVector a)) (BitVector a)- SMTBVUn :: IsBitVector a => SMTBVUnOp -> SMTFunction (SMTExpr (BitVector a)) (BitVector a)- SMTSelect :: (Liftable i,SMTType v) => SMTFunction (SMTExpr (SMTArray i v),i) v- SMTStore :: (Liftable i,SMTType v) => SMTFunction (SMTExpr (SMTArray i v),i,SMTExpr v) (SMTArray i v)- SMTConstArray :: (Args i,SMTType v) => ArgAnnotation i -> SMTFunction (SMTExpr v) (SMTArray i v)- SMTConcat :: (Concatable a b) => SMTFunction (SMTExpr (BitVector a),SMTExpr (BitVector b)) (BitVector (ConcatResult a b))- SMTExtract :: (TypeableNat start,TypeableNat len,- Extractable from len')- => Proxy start -> Proxy len -> SMTFunction (SMTExpr (BitVector from)) (BitVector len')- SMTConstructor :: (Args arg,SMTType dt) => Constructor arg dt -> SMTFunction arg dt- SMTConTest :: (Args arg,SMTType dt) => Constructor arg dt -> SMTFunction (SMTExpr dt) Bool- SMTFieldSel :: (SMTType a,SMTType f) => Field a f -> SMTFunction (SMTExpr a) f- SMTDivisible :: Integer -> SMTFunction (SMTExpr Integer) Bool- deriving (Typeable)--class (SMTValue (BitVector a)) => IsBitVector a where- getBVSize :: Proxy a -> SMTAnnotation (BitVector a) -> Integer--class (IsBitVector a,IsBitVector b,IsBitVector (ConcatResult a b))- => Concatable a b where- type ConcatResult a b- concatAnnotation :: a -> b- -> SMTAnnotation (BitVector a)- -> SMTAnnotation (BitVector b)- -> SMTAnnotation (BitVector (ConcatResult a b))--class (IsBitVector a,IsBitVector b) => Extractable a b where- extractAnn :: a -> b -> Integer -> SMTAnnotation (BitVector a) -> SMTAnnotation (BitVector b)- getExtractLen :: a -> b -> SMTAnnotation (BitVector b) -> Integer---- | Represents a constructor of a datatype /a/--- Can be obtained by using the template haskell extension module-data Constructor arg res = Constructor [ProxyArg] DataType Constr deriving (Typeable)---- | Represents a field of the datatype /a/ of the type /f/-data Field a f = Field [ProxyArg] DataType Constr DataField deriving (Typeable)--newtype InterpolationGroup = InterpolationGroup Integer deriving (Typeable,Eq,Ord,Show)---- | Identifies a clause in an unsatisfiable core-newtype ClauseId = ClauseId Integer deriving (Typeable,Eq,Ord,Show)---- | Options controling the behaviour of the SMT solver-data SMTOption- = PrintSuccess Bool -- ^ Whether or not to print \"success\" after each operation- | ProduceModels Bool -- ^ Produce a satisfying assignment after each successful checkSat- | ProduceProofs Bool -- ^ Produce a proof of unsatisfiability after each failed checkSat- | ProduceUnsatCores Bool -- ^ Enable the querying of unsatisfiable cores after a failed checkSat- | ProduceInterpolants Bool -- ^ Enable the generation of craig interpolants- deriving (Show,Eq,Ord)--data SMTInfo i where- SMTSolverName :: SMTInfo String- SMTSolverVersion :: SMTInfo String---- | Instances of this class may be used as arguments for constructed functions and quantifiers.-class (Ord a,Typeable a,Show a,- Ord (ArgAnnotation a),Typeable (ArgAnnotation a),Show (ArgAnnotation a))- => Args a where- type ArgAnnotation a- foldExprs :: Monad m => (forall t. SMTType t => s -> SMTExpr t -> SMTAnnotation t -> m (s,SMTExpr t))- -> s -> a -> ArgAnnotation a -> m (s,a)- foldExprs f s x ann = do- (s',_,r) <- foldsExprs (\cs [(expr,_)] ann' -> do- (cs',cr) <- f cs expr ann'- return (cs',[cr],cr)- ) s [(x,())] ann- return (s',r)- foldsExprs :: Monad m => (forall t. SMTType t => s -> [(SMTExpr t,b)] -> SMTAnnotation t -> m (s,[SMTExpr t],SMTExpr t))- -> s -> [(a,b)] -> ArgAnnotation a -> m (s,[a],a)- extractArgAnnotation :: a -> ArgAnnotation a- toArgs :: ArgAnnotation a -> [SMTExpr Untyped] -> Maybe (a,[SMTExpr Untyped])- - fromArgs :: a -> [SMTExpr Untyped]- fromArgs arg = fst $ foldExprsId (\lst expr ann -> (lst++[UntypedExpr expr],expr)- ) [] arg (extractArgAnnotation arg)- getTypes :: a -> ArgAnnotation a -> [ProxyArg]- getArgAnnotation :: a -> [Sort] -> (ArgAnnotation a,[Sort])--getSorts :: Args a => a -> ArgAnnotation a -> [Sort]-getSorts u ann = fmap (\prx -> withProxyArg prx getSort) (getTypes u ann)--instance Args () where- type ArgAnnotation () = ()- foldExprs _ s _ _ = return (s,())- foldsExprs _ s args _ = return (s,fmap (const ()) args,())- extractArgAnnotation _ = ()- toArgs _ x = Just ((),x)- fromArgs _ = []- getTypes _ _ = []- getArgAnnotation _ xs = ((),xs)--foldExprsId :: Args a => (forall t. SMTType t => s -> SMTExpr t -> SMTAnnotation t -> (s,SMTExpr t))- -> s -> a -> ArgAnnotation a -> (s,a)-foldExprsId f st arg ann = runIdentity $ foldExprs (\st' expr ann' -> return $ f st' expr ann') st arg ann--foldsExprsId :: Args a => (forall t. SMTType t => s -> [(SMTExpr t,b)] -> SMTAnnotation t -> (s,[SMTExpr t],SMTExpr t))- -> s -> [(a,b)] -> ArgAnnotation a -> (s,[a],a)-foldsExprsId f st exprs anns = runIdentity $ foldsExprs (\st' exprs' anns' -> return $ f st' exprs' anns'- ) st exprs anns--class (Args a) => Liftable a where- type Lifted a i- getLiftedArgumentAnn :: a -> i -> ArgAnnotation a -> ArgAnnotation i -> ArgAnnotation (Lifted a i)- inferLiftedAnnotation :: a -> i -> ArgAnnotation (Lifted a i) -> (ArgAnnotation i,ArgAnnotation a)-#ifdef SMTLIB2_WITH_CONSTRAINTS- getConstraint :: Args i => p (a,i) -> Dict (Liftable (Lifted a i))-#endif--argSorts :: Args a => a -> ArgAnnotation a -> [Sort]-argSorts arg ann = Prelude.reverse res- where- (res,_) = foldExprsId (\tps e ann' -> ((getSort (getUndef e) ann'):tps,e)) [] arg ann--unpackArgs :: Args a => (forall t. SMTType t => SMTExpr t -> SMTAnnotation t -> s -> (c,s)) -> a -> ArgAnnotation a -> s -> ([c],s)-unpackArgs f x ann i = fst $ foldExprsId (\(res,ci) e ann' -> let (p,ni) = f e ann' ci- in ((res++[p],ni),e)- ) ([],i) x ann---- | An extension of the `Args` class: Instances of this class can be represented as native haskell data types.-class Args a => LiftArgs a where- type Unpacked a- -- | Converts a haskell value into its SMT representation.- liftArgs :: Unpacked a -> ArgAnnotation a -> a- -- | Converts a SMT representation back into a haskell value.- unliftArgs :: Monad m => a -> (forall t. SMTValue t => SMTExpr t -> m t) -> m (Unpacked a)--firstJust :: [Maybe a] -> Maybe a-firstJust [] = Nothing-firstJust ((Just x):_) = Just x-firstJust (Nothing:xs) = firstJust xs--getUndef :: SMTExpr t -> t-getUndef _ = error "Don't evaluate the result of 'getUndef'"--getFunUndef :: SMTFunction arg res -> (arg,res)-getFunUndef _ = (error "Don't evaluate the first result of 'getFunUndef'",- error "Don't evaluate the second result of 'getFunUndef'")--getArrayUndef :: Args i => SMTExpr (SMTArray i v) -> (i,Unpacked i,v)-getArrayUndef _ = (undefined,undefined,undefined)--withSMTBackendExitCleanly :: SMTBackend b IO => b -> SMT a -> IO a-withSMTBackendExitCleanly backend act- = bracket- (return backend)- (\backend -> smtHandle backend SMTExit)- (\backend -> withSMTBackend' backend False act)--withSMTBackend :: SMTBackend a m => a -> SMT' m b -> m b-withSMTBackend b = withSMTBackend' b True--withSMTBackend' :: SMTBackend a m => a -> Bool -> SMT' m b -> m b-withSMTBackend' backend mustExit f = do- (res,nbackend) <- runSMT f backend- when mustExit (smtHandle nbackend SMTExit >> return ())- return res--funInfoSort :: FunInfo -> Sort-funInfoSort (FunInfo { funInfoProxy = _::Proxy (a,t)- , funInfoResAnn = ann})- = getSort (undefined::t) ann--funInfoArgSorts :: FunInfo -> [Sort]-funInfoArgSorts (FunInfo { funInfoProxy = _::Proxy (a,t)- , funInfoArgAnn = ann })- = getSorts (undefined::a) ann--{-newVariableId :: (Monad m) => Maybe String -> (Integer -> Maybe Integer -> (r,FunInfo)) -> SMT' m r-newVariableId name f = do- st <- getSMT- let idx = nextVar st- (nc,st') = case name of- Nothing -> (Nothing,st)- Just name' -> let nc = Map.findWithDefault 0 name' (nameCount st)- in (Just nc,st { namedVars = Map.insert (name',nc) idx (namedVars st)- , nameCount = Map.insert name' (nc+1) (nameCount st) })- (res,info) = f idx nc- putSMT $ st' { nextVar = succ idx- , allVars = Map.insert idx info (allVars st') }- return res--newVariable :: (Monad m,SMTType t) => Maybe String -> SMTAnnotation t -> SMT' m (SMTExpr t,FunInfo)-newVariable name (ann::SMTAnnotation t)- = newVariableId name- (\idx nc -> let info = FunInfo { funInfoId = idx- , funInfoProxy = Proxy :: Proxy ((),t)- , funInfoArgAnn = ()- , funInfoResAnn = ann- , funInfoName = case (name,nc) of- (Nothing,Nothing) -> Nothing- (Just name',Just nc') -> Just (name',nc') }- in ((Var idx ann::SMTExpr t,info),info))--newFunction :: (Monad m,Args arg,SMTType r) => Maybe String -> ArgAnnotation arg -> SMTAnnotation r -> SMT' m (SMTFunction arg r,FunInfo)-newFunction name (ann_arg::ArgAnnotation arg) (ann_res::SMTAnnotation r)- = newVariableId name- (\idx nc -> let info = FunInfo { funInfoId = idx- , funInfoProxy = Proxy :: Proxy (arg,r)- , funInfoArgAnn = ann_arg- , funInfoResAnn = ann_res- , funInfoName = case (name,nc) of- (Nothing,Nothing) -> Nothing- (Just name',Just nc') -> Just (name',nc') }- in ((SMTFun idx ann_res::SMTFunction arg r,info),info))--createArgs :: Args a => ArgAnnotation a -> Integer -> Map Integer FunInfo -> (a,[FunInfo],Integer,Map Integer FunInfo)-createArgs ann i mp- = let ((tps,ni,nmp),res)- = foldExprsId (\(tps',ci,mp') (_::SMTExpr t) ann'- -> let info = FunInfo { funInfoId = ci- , funInfoProxy = Proxy :: Proxy ((),t)- , funInfoArgAnn = ()- , funInfoResAnn = ann'- , funInfoName = Nothing }- in ((tps'++[info],ci+1,Map.insert ci info mp'),Var ci ann')- ) ([],i,mp) (error "Evaluated the argument to createArgs") ann- in (res,tps,ni,nmp)--createArgs' :: (Args a,Monad m) => ArgAnnotation a -> SMT' m (a,[FunInfo])-createArgs' ann = do- (tps,res) <- foldExprs (\tps' (_::SMTExpr t) ann' -> do- (expr',info) <- newVariable Nothing ann'- return (tps'++[info],expr')- ) [] (error "Evaluated the argument to createArgs") ann- return (res,tps)--nameVariable :: Monad m => Integer -> String -> SMT' m ()-nameVariable var name = do- st <- getSMT- let c = Map.findWithDefault 0 name (nameCount st)- putSMT $ st { nameCount = Map.insert name (c+1) (nameCount st) }-}--argsSignature :: Args a => a -> ArgAnnotation a -> [Sort]-argsSignature arg ann- = reverse $ fst $- foldExprsId (\sigs e ann' -> ((getSort (getUndef e) ann'):sigs,e))- [] arg ann--{--functionGetSignature :: (SMTFunction f)- => f- -> ArgAnnotation (SMTFunArg f)- -> SMTAnnotation (SMTFunRes f)- -> ([Sort],Sort)-functionGetSignature fun arg_ann res_ann- = let ~(uarg,ures) = getFunUndef fun- in (argsSignature uarg arg_ann,getSort ures res_ann)-}--{--getSortParser :: Monad m => SMT' m SortParser-getSortParser = do- st <- getSMT- return $ mconcat $ fmap (withDeclaredType (\u _ -> fromSort u)) (Map.elems $ declaredTyCons st)--}--argumentSortToSort :: Monad m => (Integer -> m Sort) -> ArgumentSort -> m Sort-argumentSortToSort f (Fix (ArgumentSort i)) = f i-argumentSortToSort f (Fix (NormalSort s)) = do- res <- mapM (argumentSortToSort f) s- return (Fix res)--sortToArgumentSort :: Sort -> ArgumentSort-sortToArgumentSort (Fix s) = Fix (NormalSort (fmap sortToArgumentSort s))--declareType :: (Monad m,SMTType t) => t -> SMTAnnotation t -> SMT' m ()-declareType (_::t) ann = smtBackend $ \b0 -> do- (dts,b1) <- smtHandle b0 SMTDeclaredDataTypes- let (colls,ndts) = getNewTypeCollections (Proxy::Proxy t) ann dts- b2 <- foldlM (\backend coll -> do- ((),nbackend) <- smtHandle backend (SMTDeclareDataTypes coll)- return nbackend- ) b1 colls- return ((),b2)---- Data type info--data DataTypeInfo = DataTypeInfo { structures :: [TypeCollection]- , datatypes :: Map String (DataType,TypeCollection)- , constructors :: Map String (Constr,DataType,TypeCollection)- , fields :: Map String (DataField,Constr,DataType,TypeCollection) }- deriving Typeable--data TypeCollection = TypeCollection { argCount :: Integer- , dataTypes :: [DataType]- }--data ProxyArg = forall t. SMTType t => ProxyArg t (SMTAnnotation t) deriving Typeable--data ProxyArgValue = forall t. SMTValue t => ProxyArgValue t (SMTAnnotation t) deriving Typeable--withProxyArg :: ProxyArg -> (forall t. SMTType t => t -> SMTAnnotation t -> a) -> a-withProxyArg (ProxyArg x ann) f = f x ann--withProxyArgValue :: ProxyArgValue -> (forall t. SMTValue t => t -> SMTAnnotation t -> a) -> a-withProxyArgValue (ProxyArgValue x ann) f = f x ann--instance Show ProxyArg where- showsPrec p (ProxyArg u ann) = showParen (p>10) $- showString "ProxyArg " .- showsPrec 11 (typeOf u) .- showChar ' ' .- showsPrec 11 ann--instance Eq ProxyArg where- (ProxyArg (u1::t) ann1) == (ProxyArg u2 ann2) = case cast (u2,ann2) of- Just (_::t,ann2') -> ann1==ann2'- Nothing -> False--instance Ord ProxyArg where- compare (ProxyArg u1 ann1) (ProxyArg u2 ann2) = case compare (typeOf u1) (typeOf u2) of- EQ -> case cast ann2 of- Just ann2' -> compare ann1 ann2'- x -> x--instance Show ProxyArgValue where- showsPrec p (ProxyArgValue u ann) = showParen (p>10) $- showString "ProxyArg " .- showsPrec 11 (typeOf u) .- showChar ' ' .- showsPrec 11 ann--instance Eq ProxyArgValue where- (ProxyArgValue (u1::t) ann1) == (ProxyArgValue u2 ann2) = case cast (u2,ann2) of- Just (_::t,ann2') -> ann1==ann2'- Nothing -> False--instance Ord ProxyArgValue where- compare (ProxyArgValue u1 ann1) (ProxyArgValue u2 ann2) = case compare (typeOf u1) (typeOf u2) of- EQ -> case cast ann2 of- Just ann2' -> compare ann1 ann2'- x -> x--data AnyValue = forall t. SMTType t => AnyValue [ProxyArg] t (SMTAnnotation t)--withAnyValue :: AnyValue -> (forall t. SMTType t => [ProxyArg] -> t -> SMTAnnotation t -> a) -> a-withAnyValue (AnyValue p x ann) f = f p x ann--castAnyValue :: SMTType t => AnyValue -> Maybe (t,SMTAnnotation t)-castAnyValue (AnyValue _ x ann) = cast (x,ann)--data DataType = DataType { dataTypeName :: String- , dataTypeConstructors :: [Constr]- , dataTypeGetUndefined- :: forall r. [ProxyArg]- -> (forall t. SMTType t => t -> SMTAnnotation t -> r)- -> r- }--data Constr = Constr { conName :: String- , conFields :: [DataField]- , construct :: forall r. [Maybe ProxyArg] -> [AnyValue]- -> (forall t. SMTType t => [ProxyArg] -> t -> SMTAnnotation t -> r)- -> r- , conUndefinedArgs :: forall r. [ProxyArg] -> (forall arg. Args arg => arg -> ArgAnnotation arg -> r) -> r- , conTest :: forall t. SMTType t => [ProxyArg] -> t -> Bool- }--data DataField = DataField { fieldName :: String- , fieldSort :: ArgumentSort- , fieldGet :: forall r t. SMTType t => [ProxyArg] -> t- -> (forall f. SMTType f => f -> SMTAnnotation f -> r)- -> r- }--emptyDataTypeInfo :: DataTypeInfo-emptyDataTypeInfo = DataTypeInfo { structures = []- , datatypes = Map.empty- , constructors = Map.empty- , fields = Map.empty }--containsTypeCollection :: TypeCollection -> DataTypeInfo -> Bool-containsTypeCollection struct dts = case dataTypes struct of- dt:_ -> Map.member (dataTypeName dt) (datatypes dts)- [] -> False--addDataTypeStructure :: TypeCollection -> DataTypeInfo -> DataTypeInfo-addDataTypeStructure struct dts- = foldl (\cdts dt- -> foldl (\cdts con- -> foldl (\cdts field- -> cdts { fields = Map.insert (fieldName field) (field,con,dt,struct) (fields cdts) }- ) (cdts { constructors = Map.insert (conName con) (con,dt,struct) (constructors cdts) })- (conFields con)- ) (cdts { datatypes = Map.insert (dataTypeName dt) (dt,struct) (datatypes cdts) })- (dataTypeConstructors dt)- ) (dts { structures = struct:(structures dts) }) (dataTypes struct)---- | Get all the type collections which are not yet declared from a type.-getNewTypeCollections :: SMTType t => Proxy t -> SMTAnnotation t -> DataTypeInfo- -> ([TypeCollection],DataTypeInfo)-getNewTypeCollections (_::Proxy t) ann dts- = case asDataType (undefined::t) ann of- Nothing -> ([],dts) -- This is no declarable data type- Just (name,coll)- -> let isKnown = Map.member name (datatypes dts) -- Is the datatype already known?- proxies = getProxyArgs (undefined::t) ann- (tps1,dts1) = if isKnown- then ([],dts)- else ([coll],addDataTypeStructure coll dts)- (tps2,dts2) = foldl (\(tps,dts) prx -- Check all the data type parameters- -> withProxyArg prx $- \(_::a) ann'- -> let (ntps,ndts) = getNewTypeCollections- (Proxy::Proxy a)- ann' dts- in (ntps++tps,ndts)- ) ([],dts1) proxies- (tps3,dts3) = if isKnown- then ([],dts2)- else foldl- (\cur dt- -> dataTypeGetUndefined dt proxies $- \dtUndef dtAnn- -> foldl- (\cur con- -> foldl- (\(tps,dts) field- -> fieldGet field proxies dtUndef $- \(_::f) fAnn- -> let (ntps,ndts) = getNewTypeCollections- (Proxy::Proxy f)- fAnn dts- in (ntps++tps,ndts)- ) cur (conFields con)- ) cur (dataTypeConstructors dt)- ) ([],dts2) (dataTypes coll) -- Declare all field types- in (tps2++tps3++tps1,dts3)--asNamedSort :: Sort -> Maybe (String,[Sort])-asNamedSort (Fix (NamedSort name args)) = Just (name,args)-asNamedSort _ = Nothing--escapeName :: Either (String,Integer) Integer -> String-escapeName (Right i) = "var"++(if i==0- then ""- else "_"++show i)-escapeName (Left (c:cs,nc))- = (if isDigit c- then "num"++escapeName' (c:cs)- else escapeName' (c:cs))++(if nc==0- then ""- else "_"++show nc)-escapeName (Left ([],0)) = "no_name"-escapeName (Left ([],n)) = "no_name"++show n--escapeName' :: String -> String-escapeName' [] = []-escapeName' ('_':xs) = '_':'_':escapeName' xs-escapeName' (x:xs) = x:escapeName' xs--unescapeName :: String -> Maybe (Either (String,Integer) Integer)-unescapeName "var" = Just (Right 0)-unescapeName ('v':'a':'r':'_':rest) = if all isDigit rest- then Just (Right (read rest))- else Nothing-unescapeName xs = do- res <- unescapeName' xs- return $ Left res--unescapeName' :: String -> Maybe (String,Integer)-unescapeName' ('n':'o':'_':'n':'a':'m':'e':rest) = case rest of- [] -> Just ("",0)- xs -> if all isDigit xs- then Just ("",read xs)- else Nothing-unescapeName' ('_':'_':rest) = do- (name,nc) <- unescapeName' rest- return ('_':name,nc)-unescapeName' ('_':rest) = if all isDigit rest- then return ("",read rest)- else Nothing-unescapeName' (x:xs) = do- (name,nc) <- unescapeName' xs- return (x:name,nc)-unescapeName' "" = Just ("",0)--data SMTState = SMTState { nextVar :: Integer- , nextInterpolationGroup :: Integer- , nextClauseId :: Integer- , allVars :: Map Integer (FunInfo,Integer)- , namedVars :: Map (String,Integer) Integer- , nameCount :: Map String Integer- , declaredDataTypes :: DataTypeInfo }--emptySMTState :: SMTState-emptySMTState = SMTState { nextVar = 0- , nextInterpolationGroup = 0- , nextClauseId = 0- , allVars = Map.empty- , namedVars = Map.empty- , nameCount = Map.empty- , declaredDataTypes = emptyDataTypeInfo- }--smtStateAddFun :: FunInfo -> SMTState -> (Integer,String,SMTState)-smtStateAddFun finfo st- = (v,name',nst)- where- v = nextVar st- nameBase = case funInfoName finfo of- Nothing -> "var"- Just n -> n- nc = case Map.lookup nameBase (nameCount st) of- Just n -> n- Nothing -> 0- name' = if nc==0- then nameBase- else nameBase++"_"++show nc- nst = st { nextVar = v+1- , allVars = Map.insert v (finfo,nc) (allVars st)- , namedVars = Map.insert (nameBase,nc) v (namedVars st)- , nameCount = Map.insert nameBase (nc+1) (nameCount st)- }---- BitVectors--#ifdef SMTLIB2_WITH_DATAKINDS-data Nat = Z | S Nat deriving Typeable--data BVKind = BVUntyped- | BVTyped Nat--class TypeableNat n where- typeOfNat :: Proxy n -> TypeRep- typeOfNat p = foldl- (\c _ -> mkTyConApp (mkTyCon3 "smtlib2" "Language.SMTLib2.Internals" "'S") [c])- (mkTyConApp (mkTyCon3 "smtlib2" "Language.SMTLib2.Internals" "'Z") [])- (genericReplicate (reflectNat p 0) ())- reflectNat :: Proxy n -> Integer -> Integer--instance TypeableNat Z where- typeOfNat _ = mkTyConApp- (mkTyCon3 "smtlib2" "Language.SMTLib2.Internals" "'Z")- []- reflectNat _ x = x--instance TypeableNat n => TypeableNat (S n) where- typeOfNat _ = mkTyConApp- (mkTyCon3 "smtlib2" "Language.SMTLib2.Internals" "'S")- [typeOfNat (Proxy::Proxy n)]- reflectNat _ x = reflectNat (Proxy::Proxy n) (x+1)--class TypeableBVKind n where- typeOfBVKind :: Proxy n -> TypeRep--instance TypeableBVKind BVUntyped where- typeOfBVKind _ = mkTyConApp- (mkTyCon3 "smtlib2" "Language.SMTLib2.Internals" "'BVUntyped")- []--instance TypeableNat n => TypeableBVKind (BVTyped n) where- typeOfBVKind _ = mkTyConApp- (mkTyCon3 "smtlib2" "Language.SMTLib2.Internals" "'BVTyped")- [typeOfNat (Proxy::Proxy n)]--type family Add (n1 :: Nat) (n2 :: Nat) :: Nat-type instance Add Z n = n-type instance Add (S n1) n2 = S (Add n1 n2)--reifySum :: (Num a,Ord a) => a -> a -> (forall n1 n2. (TypeableNat n1,TypeableNat n2,TypeableNat (Add n1 n2))- => Proxy (n1::Nat) -> Proxy (n2::Nat) -> Proxy (Add n1 n2) -> r) -> r-reifySum n1 n2 f- | n1 < 0 || n2 < 0 = error "smtlib2: Cann only reify numbers >= 0."- | otherwise = reifySum' n1 n2 f- where- reifySum' :: (Num a,Ord a) => a -> a- -> (forall n1 n2. (TypeableNat n1,TypeableNat n2,TypeableNat (Add n1 n2))- => Proxy (n1::Nat) -> Proxy (n2::Nat) -> Proxy (Add n1 n2) -> r) -> r- reifySum' 0 n2 f = reifyNat n2 $ \(_::Proxy i) -> f (Proxy::Proxy Z) (Proxy::Proxy i) (Proxy::Proxy i)- reifySum' n1 n2 f = reifySum' (n1-1) n2 $ \(_::Proxy i1) (_::Proxy i2) (_::Proxy i3)- -> f (Proxy::Proxy (S i1)) (Proxy::Proxy i2) (Proxy::Proxy (S i3))--reifyExtract :: (Num a,Ord a) => a -> a -> a- -> (forall n1 n2 n3 n4. (TypeableNat n1,TypeableNat n2,TypeableNat n3,TypeableNat n4,Add n4 n2 ~ S n3)- => Proxy (n1::Nat) -> Proxy (n2::Nat) -> Proxy (n3::Nat) -> Proxy (n4::Nat) -> r) -> r-reifyExtract t l u f- | t <= u || l > u || l < 0 = error "smtlib2: Invalid extract parameters."- | otherwise = reifyExtract' t l u (u - l + 1) f- where- reifyExtract' :: (Num a,Ord a) => a -> a -> a -> a- -> (forall n1 n2 n3 n4. (TypeableNat n1,TypeableNat n2,TypeableNat n3,TypeableNat n4,Add n4 n2 ~ S n3)- => Proxy (n1::Nat) -> Proxy (n2::Nat) -> Proxy (n3::Nat) -> Proxy (n4::Nat) -> r) -> r- reifyExtract' t 0 0 1 f- = reifyNat t $- \(_::Proxy n1) -> f (Proxy::Proxy n1) (Proxy::Proxy Z) (Proxy::Proxy Z) (Proxy::Proxy (S Z))- reifyExtract' t l u 0 f- = reifyNat t $- \(_::Proxy n1)- -> reifyNat u $- \(_::Proxy n3)- -> f (Proxy::Proxy n1) (Proxy::Proxy (S n3)) (Proxy::Proxy n3) (Proxy::Proxy Z)- reifyExtract' t l u r f = reifyExtract' t l (u-1) (r-1) $- \(_::Proxy n1) (_::Proxy n2) (_::Proxy n3) (_::Proxy n4)- -> f (Proxy::Proxy n1) (Proxy::Proxy n2) (Proxy::Proxy (S n3)) (Proxy::Proxy (S n4))---reifyNat :: (Num a,Ord a) => a -> (forall n. TypeableNat n => Proxy (n::Nat) -> r) -> r-reifyNat x f- | x < 0 = error "smtlib2: Can only reify numbers >= 0."- | otherwise = reifyNat' x f- where- reifyNat' :: (Num a,Ord a) => a -> (forall n. TypeableNat n => Proxy (n::Nat) -> r) -> r- reifyNat' 0 f = f (Proxy :: Proxy Z)- reifyNat' n f = reifyNat' (n-1) (\(_::Proxy n) -> f (Proxy::Proxy (S n)))--data BitVector (b :: BVKind) = BitVector Integer deriving (Eq,Ord,Typeable)--instance TypeableBVKind k => Typeable (BitVector k) where- typeOf _ = mkTyConApp- (mkTyCon3 "smtlib2" "Language.SMTLib2.Internals" "BitVector")- [typeOfBVKind (Proxy::Proxy k)]-#else-data Z = Z deriving (Typeable)-data S a = S deriving (Typeable)--class Typeable a => TypeableNat a where- reflectNat :: Proxy a -> Integer -> Integer--instance TypeableNat Z where- reflectNat _ = id--instance TypeableNat n => TypeableNat (S n) where- reflectNat _ x = reflectNat (Proxy::Proxy n) (x+1)--type family Add n1 n2-type instance Add Z n = n-type instance Add (S n1) n2 = S (Add n1 n2)--data BVUntyped = BVUntyped deriving (Eq,Ord,Show,Typeable)-data BVTyped n = BVTyped deriving (Eq,Ord,Show,Typeable)--reifyNat :: (Num a,Ord a) => a -> (forall n. TypeableNat n => Proxy n -> r) -> r-reifyNat n f- | n < 0 = error "smtlib2: Can only reify numbers >= 0."- | otherwise = reifyNat' n f- where- reifyNat' :: (Num a,Eq a) => a -> (forall n. TypeableNat n => Proxy n -> r) -> r- reifyNat' 0 f' = f' (Proxy::Proxy Z)- reifyNat' n' f' = reifyNat' (n'-1) (f'.g)-- g :: Proxy n -> Proxy (S n)- g _ = Proxy--reifySum :: (Num a,Ord a) => a -> a -> (forall n1 n2. (TypeableNat n1,TypeableNat n2,TypeableNat (Add n1 n2))- => Proxy n1 -> Proxy n2 -> Proxy (Add n1 n2) -> r) -> r-reifySum n1 n2 f- | n1 < 0 || n2 < 0 = error "smtlib2: Can only reify numbers >= 0."- | otherwise = reifySum' n1 n2 f- where- reifySum' :: (Num a,Ord a) => a -> a- -> (forall n1 n2. (TypeableNat n1,TypeableNat n2,TypeableNat (Add n1 n2))- => Proxy n1 -> Proxy n2 -> Proxy (Add n1 n2) -> r) -> r- reifySum' 0 n2' f' = reifyNat n2' $ \(_::Proxy i) -> f' (Proxy::Proxy Z) (Proxy::Proxy i) (Proxy::Proxy i)- reifySum' n1' n2' f' = reifySum' (n1'-1) n2' $- \(_::Proxy i1) (_::Proxy i2) (_::Proxy (Add i1 i2))- -> f' (Proxy::Proxy (S i1)) (Proxy::Proxy i2) (Proxy::Proxy (S (Add i1 i2)))--reifyExtract :: (Num a,Ord a) => a -> a -> a- -> (forall n1 n2 n3 n4. (TypeableNat n1,TypeableNat n2,TypeableNat n3,TypeableNat n4,Add n4 n2 ~ S n3)- => Proxy n1 -> Proxy n2 -> Proxy n3 -> Proxy n4 -> r) -> r-reifyExtract t l u f- | t <= u || l > u || l < 0 = error "smtlib2: Invalid extract parameters."- | otherwise = reifyExtract' t l u (u - l + 1) f- where- reifyExtract' :: (Num a,Ord a) => a -> a -> a -> a- -> (forall n1 n2 n3 n4. (TypeableNat n1,TypeableNat n2,TypeableNat n3,TypeableNat n4,Add n4 n2 ~ S n3)- => Proxy n1 -> Proxy n2 -> Proxy n3 -> Proxy n4 -> r) -> r- reifyExtract' t' 0 0 1 f'- = reifyNat t' $- \(_::Proxy n1) -> f' (Proxy::Proxy n1) (Proxy::Proxy Z) (Proxy::Proxy Z) (Proxy::Proxy (S Z))- reifyExtract' t' _ u' 0 f' = reifyNat t' $- \(_::Proxy n1)- -> reifyNat u' $- \(_::Proxy n3)- -> f' (Proxy::Proxy n1) (Proxy::Proxy (S n3)) (Proxy::Proxy n3) (Proxy::Proxy Z)- reifyExtract' t' l' u' r' f' = reifyExtract' t' l' (u'-1) (r'-1) $- \(_::Proxy n1) (_::Proxy n2) (_::Proxy n3) (_::Proxy n4)- -> f' (Proxy::Proxy n1) (Proxy::Proxy n2) (Proxy::Proxy (S n3)) (Proxy::Proxy (S n4))--data BitVector (b :: *) = BitVector Integer deriving (Eq,Ord,Typeable)-#endif--instance Show (BitVector a) where- show (BitVector x) = show x--instance Enum (BitVector a) where- succ (BitVector x) = BitVector (succ x)- pred (BitVector x) = BitVector (pred x)- toEnum x = BitVector (toEnum x)- fromEnum (BitVector x) = fromEnum x- enumFrom (BitVector x) = [ BitVector y | y <- enumFrom x ]- enumFromThen (BitVector x) (BitVector y)- = [ BitVector z | z <- enumFromThen x y ]- enumFromTo (BitVector x) (BitVector y)- = [ BitVector z | z <- enumFromTo x y ]- enumFromThenTo (BitVector x) (BitVector y) (BitVector z)- = [ BitVector p | p <- enumFromThenTo x y z ]--type N0 = Z-type N1 = S N0-type N2 = S N1-type N3 = S N2-type N4 = S N3-type N5 = S N4-type N6 = S N5-type N7 = S N6-type N8 = S N7-type N9 = S N8-type N10 = S N9-type N11 = S N10-type N12 = S N11-type N13 = S N12-type N14 = S N13-type N15 = S N14-type N16 = S N15-type N17 = S N16-type N18 = S N17-type N19 = S N18-type N20 = S N19-type N21 = S N20-type N22 = S N21-type N23 = S N22-type N24 = S N23-type N25 = S N24-type N26 = S N25-type N27 = S N26-type N28 = S N27-type N29 = S N28-type N30 = S N29-type N31 = S N30-type N32 = S N31-type N33 = S N32-type N34 = S N33-type N35 = S N34-type N36 = S N35-type N37 = S N36-type N38 = S N37-type N39 = S N38-type N40 = S N39-type N41 = S N40-type N42 = S N41-type N43 = S N42-type N44 = S N43-type N45 = S N44-type N46 = S N45-type N47 = S N46-type N48 = S N47-type N49 = S N48-type N50 = S N49-type N51 = S N50-type N52 = S N51-type N53 = S N52-type N54 = S N53-type N55 = S N54-type N56 = S N55-type N57 = S N56-type N58 = S N57-type N59 = S N58-type N60 = S N59-type N61 = S N60-type N62 = S N61-type N63 = S N62-type N64 = S N63--type BV8 = BitVector (BVTyped N8)-type BV16 = BitVector (BVTyped N16)-type BV32 = BitVector (BVTyped N32)-type BV64 = BitVector (BVTyped N64)--instance Monad m => SMTBackend (AnyBackend m) m where- smtHandle (AnyBackend b) req = do- (res,nb) <- smtHandle b req- return (res,AnyBackend nb)- smtGetNames (AnyBackend b) = smtGetNames b- smtNextName (AnyBackend b) = smtNextName b--instance Show (SMTExpr t) where- showsPrec = showExpr--newtype Bound = Bound Integer deriving (Typeable,Eq,Ord,Show)--showExpr :: Int -> SMTExpr t -> ShowS-showExpr p (Var v ann) = showParen (p>10) (showString "Var " .- showsPrec 11 v .- showChar ' ' .- showsPrec 11 ann)-showExpr p (QVar lvl v ann) = showParen (p>10) (showString "QVar " .- showsPrec 11 lvl .- showChar ' ' .- showsPrec 11 v .- showChar ' ' .- showsPrec 11 ann)-showExpr p (FunArg v ann) = showParen (p>10) (showString "FunArg " .- showsPrec 11 v .- showChar ' ' .- showsPrec 11 ann)-showExpr p (Const c ann) = showParen (p>10) (showString "Const " .- showsPrec 11 c .- showChar ' ' .- showsPrec 11 ann)-showExpr p (AsArray fun ann) = showParen (p>10) (showString "AsArray " .- showsPrec 11 fun .- showChar ' ' .- showsPrec 11 ann)-showExpr p (Forall lvl args f) = showParen (p>10) (showString "Forall " .- showsPrec 11 lvl .- showChar ' ' .- showsPrec 11 args .- showString " ~> " .- showsPrec 11 f)-showExpr p (Exists lvl args f) = showParen (p>10) (showString "Exists " .- showsPrec 11 lvl .- showChar ' ' .- showsPrec 11 args .- showString " ~> " .- showsPrec 11 f)-showExpr p (Let lvl arg f) = showParen (p>10) (showString "Let " .- showsPrec 11 lvl .- showChar ' ' .- showsPrec 11 arg .- showChar ' ' .- showsPrec 11 f)-showExpr p (App fun arg) = let strArgs = showsPrec 11 arg- in showParen (p>10) (showString "App " .- showsPrec 11 fun .- showChar ' ' .- strArgs)-showExpr p (Named expr i) = let strExpr = showExpr 11 expr- in showParen (p>10) (showString "Named " .- strExpr .- showChar ' ' .- showsPrec 11 i)-showExpr p (InternalObj obj ann) = showParen (p>10) (showString "InternalObj " .- showsPrec 11 obj .- showChar ' ' .- showsPrec 11 ann)-showExpr p (UntypedExpr e) = showParen (p>10) (showString "UntypedExpr " .- showExpr 11 e)-showExpr p (UntypedExprValue e) = showParen (p>10) (showString "UntypedExprValue " .- showExpr 11 e)--instance Show (SMTFunction arg res) where- showsPrec _ SMTEq = showString "SMTEq"- showsPrec p (SMTMap fun) = showParen (p>10) (showString "SMTMap " .- showsPrec 11 fun)- showsPrec p (SMTFun i ann) = showParen (p>10) (showString "SMTFun " .- showsPrec 11 i .- showChar ' ' .- showsPrec 11 ann)- showsPrec p (SMTBuiltIn name ann) = showParen (p>10) (showString "SMTBuiltIn " .- showsPrec 11 name .- showChar ' ' .- showsPrec 11 ann)- showsPrec p (SMTOrd op) = showParen (p>10) (showString "SMTOrd " .- showsPrec 11 op)- showsPrec p (SMTArith op) = showParen (p>10) (showString "SMTArith " .- showsPrec 11 op)- showsPrec p SMTMinus = showString "SMTMinus"- showsPrec p (SMTIntArith op) = showParen (p>10) (showString "SMTIntArith " .- showsPrec 11 op)- showsPrec p SMTDivide = showString "SMTDivide"- showsPrec p SMTNeg = showString "SMTNeg"- showsPrec p SMTAbs = showString "SMTAbs"- showsPrec p SMTNot = showString "SMTNot"- showsPrec p (SMTLogic op) = showParen (p>10) (showString "SMTLogic " .- showsPrec 11 op)- showsPrec p SMTDistinct = showString "SMTDistinct"- showsPrec p SMTToReal = showString "SMTToReal"- showsPrec p SMTToInt = showString "SMTToInt"- showsPrec p SMTITE = showString "SMTITE"- showsPrec p (SMTBVComp op) = showParen (p>10) (showString "SMTBVComp " .- showsPrec 11 op)- showsPrec p (SMTBVBin op) = showParen (p>10) (showString "SMTBVBin " .- showsPrec 11 op)- showsPrec p (SMTBVUn op) = showParen (p>10) (showString "SMTBVUn " .- showsPrec 11 op)- showsPrec p SMTSelect = showString "SMTSelect"- showsPrec p SMTStore = showString "SMTStore"- showsPrec p (SMTConstArray ann) = showParen (p>10) (showString "SMTConstArray " .- showsPrec 11 ann)- showsPrec p SMTConcat = showString "SMTConcat"- showsPrec p (SMTExtract start len) = showParen (p>10) (showString "SMTExtract " .- showsPrec 11 (reflectNat start 0) .- showChar ' ' .- showsPrec 11 (reflectNat len 0))- showsPrec p (SMTConstructor con) = showParen (p>10) (showString "SMTConstructor " .- showsPrec 11 con)- showsPrec p (SMTConTest con) = showParen (p>10) (showString "SMTConTest " .- showsPrec 11 con)- showsPrec p (SMTFieldSel field) = showParen (p>10) (showString "SMTFieldSel " .- showsPrec 11 field)- showsPrec p (SMTDivisible i) = showParen (p>10) (showString "SMTDivisible " .- showsPrec 11 i)--instance Show (Field a f) where- showsPrec p (Field _ _ _ f) = showParen (p>10)- (showString "Field " .- showsPrec 11 (fieldName f))--instance Show (Constructor arg res) where- showsPrec p (Constructor _ _ con) = showParen (p>10)- (showString "Constructor " .- showsPrec 11 (conName con))--noLimits :: CheckSatLimits-noLimits = CheckSatLimits { limitTime = Nothing- , limitMemory = Nothing }--newtype Quantified = Quantified Integer deriving (Typeable,Show,Eq,Ord)--quantificationLevel :: SMTExpr t -> Integer-quantificationLevel (QVar lvl _ _) = lvl+1-quantificationLevel (Forall lvl _ _) = lvl+1-quantificationLevel (Exists lvl _ _) = lvl+1-quantificationLevel (Let lvl _ _) = lvl+1-quantificationLevel (App _ arg) = maximum $ fmap quantificationLevel $ fromArgs arg-quantificationLevel (Named expr _) = quantificationLevel expr-quantificationLevel (UntypedExpr e) = quantificationLevel e-quantificationLevel (UntypedExprValue e) = quantificationLevel e-quantificationLevel _ = 0--inferSorts :: ArgumentSort -> Sort -> Map Integer Sort -> Map Integer Sort-inferSorts (Fix (ArgumentSort i)) s mp = Map.insert i s mp-inferSorts (Fix (NormalSort (ArraySort xs x))) (Fix (ArraySort ys y)) mp- = foldl (\cmp (x,y) -> inferSorts x y cmp- ) (inferSorts x y mp) (zip xs ys)-inferSorts (Fix (NormalSort (NamedSort n1 xs))) (Fix (NamedSort n2 ys)) mp- | n1==n2 = foldl (\cmp (x,y) -> inferSorts x y cmp- ) mp (zip xs ys)-inferSorts _ _ mp = mp--valueSort :: DataTypeInfo -> Value -> Sort-valueSort _ (BoolValue _) = Fix BoolSort-valueSort _ (IntValue _) = Fix IntSort-valueSort _ (RealValue _) = Fix RealSort-valueSort _ (BVValue w _) = Fix (BVSort w False)-valueSort dts (ConstrValue _ _ (Just (sname,sargs))) = Fix $ NamedSort sname sargs-valueSort dts (ConstrValue name args Nothing) = case Map.lookup name (constructors dts) of- Just (con,dt,tc) -> Fix $ NamedSort (dataTypeName dt) (fmap snd $ Map.toAscList infMp)- where- argTps = fmap (valueSort dts) args- conTps = fmap fieldSort (conFields con)- infMp = foldl (\cinf (tp,argTp) -> inferSorts tp argTp cinf- ) Map.empty (zip conTps argTps)
+ Language/SMTLib2/Internals/Backend.hs view
@@ -0,0 +1,232 @@+module Language.SMTLib2.Internals.Backend where++import Language.SMTLib2.Internals.Type+import Language.SMTLib2.Internals.Type.List (List(..))+import qualified Language.SMTLib2.Internals.Type.List as List+import Language.SMTLib2.Internals.Expression hiding (Map)+import qualified Language.SMTLib2.Internals.Proof as P+import Language.SMTLib2.Strategy++import Data.Typeable+import Data.GADT.Compare+import Data.GADT.Show+import Data.Functor.Identity+import Text.Show++type SMTAction b r = b -> SMTMonad b (r,b)++mapAction :: Backend b => (r -> r') -> SMTAction b r -> SMTAction b r'+mapAction f act b = do+ (r,nb) <- act b+ return (f r,nb)++-- | A backend represents a specific type of SMT solver.+class (Typeable b,Functor (SMTMonad b),Monad (SMTMonad b),+ GetType (Expr b),GetType (Var b),GetType (QVar b),+ GetFunType (Fun b),+ GetType (FunArg b),+ GetType (LVar b),+ Typeable (Expr b),+ Typeable (Var b),+ Typeable (QVar b),+ Typeable (Fun b),+ Typeable (FunArg b),+ Typeable (LVar b),+ Typeable (ClauseId b),+ GCompare (Expr b),GShow (Expr b),+ GCompare (Var b),GShow (Var b),+ GCompare (QVar b),GShow (QVar b),+ GCompare (Fun b),GShow (Fun b),+ GCompare (FunArg b),GShow (FunArg b),+ GCompare (LVar b),GShow (LVar b),+ Ord (ClauseId b),Show (ClauseId b),+ Ord (Proof b),Show (Proof b),+ Show (Model b)) => Backend b where+ -- | The monad in which the backend executes queries.+ type SMTMonad b :: * -> *+ -- | The internal type of expressions.+ data Expr b :: Type -> *+ -- | The internal type of variables.+ type Var b :: Type -> *+ -- | The internal type of quantified variables.+ type QVar b :: Type -> *+ -- | The internal type of user-defined functions.+ type Fun b :: ([Type],Type) -> *+ type FunArg b :: Type -> *+ type LVar b :: Type -> *+ type ClauseId b :: *+ type Model b :: *+ type Proof b :: *+ setOption :: SMTOption -> SMTAction b ()+ getInfo :: SMTInfo i -> SMTAction b i+ comment :: String -> SMTAction b ()+ comment _ b = return ((),b)+ push :: SMTAction b ()+ pop :: SMTAction b ()+ declareVar :: Repr t -> Maybe String -> SMTAction b (Var b t)+ createQVar :: Repr t -> Maybe String -> SMTAction b (QVar b t)+ createFunArg :: Repr t -> Maybe String -> SMTAction b (FunArg b t)+ defineVar :: Maybe String -> Expr b t -> SMTAction b (Var b t)+ declareFun :: List Repr arg -> Repr t -> Maybe String -> SMTAction b (Fun b '(arg,t))+ defineFun :: Maybe String -> List (FunArg b) arg -> Expr b r -> SMTAction b (Fun b '(arg,r))+ assert :: Expr b BoolType -> SMTAction b ()+ assertId :: Expr b BoolType -> SMTAction b (ClauseId b)+ assertPartition :: Expr b BoolType -> Partition -> SMTAction b ()+ checkSat :: Maybe Tactic -> CheckSatLimits -> SMTAction b CheckSatResult+ getUnsatCore :: SMTAction b [ClauseId b]+ getValue :: Expr b t -> SMTAction b (Value t)+ getModel :: SMTAction b (Model b)+ modelEvaluate :: Model b -> Expr b t -> SMTAction b (Value t)+ getProof :: SMTAction b (Proof b)+ analyzeProof :: b -> Proof b -> P.Proof String (Expr b) (Proof b)+ simplify :: Expr b t -> SMTAction b (Expr b t)+ toBackend :: Expression (Var b) (QVar b) (Fun b) (FunArg b) (LVar b) (Expr b) t -> SMTAction b (Expr b t)+ fromBackend :: b -> Expr b t+ -> Expression (Var b) (QVar b) (Fun b) (FunArg b) (LVar b) (Expr b) t+ declareDatatypes :: [AnyDatatype] -> SMTAction b ()+ interpolate :: SMTAction b (Expr b BoolType)+ exit :: SMTAction b ()++-- | The interpolation partition+data Partition = PartitionA+ | PartitionB+ deriving (Show,Eq,Ord,Typeable)++-- | The result of a check-sat query+data CheckSatResult+ = Sat -- ^ The formula is satisfiable+ | Unsat -- ^ The formula is unsatisfiable+ | Unknown -- ^ The solver cannot determine the satisfiability of a formula+ deriving (Show,Eq,Ord,Typeable)++-- | Describe limits on the ressources that an SMT-solver can use+data CheckSatLimits = CheckSatLimits { limitTime :: Maybe Integer -- ^ A limit on the amount of time the solver can spend on the problem (in milliseconds)+ , limitMemory :: Maybe Integer -- ^ A limit on the amount of memory the solver can use (in megabytes)+ } deriving (Show,Eq,Ord,Typeable)++newtype AssignmentModel b+ = AssignmentModel { assignments :: [Assignment b] }++data Assignment b+ = forall (t :: Type). VarAssignment (Var b t) (Expr b t)+ | forall (arg :: [Type]) (t :: Type).+ FunAssignment (Fun b '(arg,t)) (List (FunArg b) arg) (Expr b t)++-- | Options controling the behaviour of the SMT solver+data SMTOption+ = PrintSuccess Bool -- ^ Whether or not to print \"success\" after each operation+ | ProduceModels Bool -- ^ Produce a satisfying assignment after each successful checkSat+ | ProduceProofs Bool -- ^ Produce a proof of unsatisfiability after each failed checkSat+ | ProduceUnsatCores Bool -- ^ Enable the querying of unsatisfiable cores after a failed checkSat+ | ProduceInterpolants Bool -- ^ Enable the generation of craig interpolants+ | SMTLogic String+ deriving (Show,Eq,Ord)++-- | Solver information query type. Used with `Language.SMTLib2.getInfo`.+data SMTInfo i where+ SMTSolverName :: SMTInfo String+ SMTSolverVersion :: SMTInfo String++data UntypedVar v (t :: Type) = UntypedVar v (Repr t) deriving Typeable+ +data UntypedFun v (sig::([Type],Type)) where+ UntypedFun :: v -> List Repr arg -> Repr ret -> UntypedFun v '(arg,ret)+ deriving Typeable++data RenderedSubExpr t = RenderedSubExpr (Int -> ShowS)++instance GShow RenderedSubExpr where+ gshowsPrec p (RenderedSubExpr f) = f p++showsBackendExpr :: (Backend b) => b -> Int -> Expr b t -> ShowS+showsBackendExpr b p expr = showsPrec p recE+ where+ recE = runIdentity $ mapExpr return return return return return+ (\e -> return $ RenderedSubExpr (\p -> showsBackendExpr b p e)) load+ load = fromBackend b expr++instance Eq v => Eq (UntypedVar v t) where+ (==) (UntypedVar x _) (UntypedVar y _) = x==y++instance Eq v => Eq (UntypedFun v sig) where+ (==) (UntypedFun x _ _) (UntypedFun y _ _) = x==y++instance Ord v => Ord (UntypedVar v t) where+ compare (UntypedVar x _) (UntypedVar y _) = compare x y++instance Ord v => Ord (UntypedFun v sig) where+ compare (UntypedFun x _ _) (UntypedFun y _ _) = compare x y++instance Eq v => GEq (UntypedVar v) where+ geq (UntypedVar v1 tp1) (UntypedVar v2 tp2) = do+ Refl <- geq tp1 tp2+ if v1==v2+ then return Refl+ else Nothing++instance Eq v => GEq (UntypedFun v) where+ geq (UntypedFun v1 a1 r1) (UntypedFun v2 a2 r2) = do+ Refl <- geq a1 a2+ Refl <- geq r1 r2+ if v1==v2+ then return Refl+ else Nothing++instance Ord v => GCompare (UntypedVar v) where+ gcompare (UntypedVar v1 t1) (UntypedVar v2 t2)+ = case gcompare t1 t2 of+ GEQ -> case compare v1 v2 of+ EQ -> GEQ+ LT -> GLT+ GT -> GGT+ r -> r++instance Ord v => GCompare (UntypedFun v) where+ gcompare (UntypedFun v1 a1 t1) (UntypedFun v2 a2 t2)+ = case gcompare a1 a2 of+ GEQ -> case gcompare t1 t2 of+ GEQ -> case compare v1 v2 of+ EQ -> GEQ+ LT -> GLT+ GT -> GGT+ GLT -> GLT+ GGT -> GGT+ GLT -> GLT+ GGT -> GGT++instance Show v => Show (UntypedVar v t) where+ showsPrec p (UntypedVar v _) = showsPrec p v++instance Show v => Show (UntypedFun v sig) where+ showsPrec p (UntypedFun v _ _) = showsPrec p v++instance Show v => GShow (UntypedVar v) where+ gshowsPrec = showsPrec++instance Show v => GShow (UntypedFun v) where+ gshowsPrec = showsPrec++instance GetType (UntypedVar v) where+ getType (UntypedVar _ tp) = tp++instance GetFunType (UntypedFun v) where+ getFunType (UntypedFun _ arg tp) = (arg,tp)++instance (GShow (Var b),GShow (Expr b),GShow (Fun b),GShow (FunArg b))+ => Show (Assignment b) where+ showsPrec p (VarAssignment var expr)+ = showParen (p>10) $+ gshowsPrec 9 var .+ showString " = " .+ gshowsPrec 9 expr+ showsPrec p (FunAssignment fun args body)+ = showParen (p>10) $+ gshowsPrec 9 fun .+ showListWith id (runIdentity $ List.toList (return . gshowsPrec 0) args) .+ showString " = " .+ gshowsPrec 9 body++instance (GShow (Var b),GShow (Expr b),GShow (Fun b),GShow (FunArg b))+ => Show (AssignmentModel b) where+ showsPrec p (AssignmentModel assign)+ = showsPrec p assign
+ Language/SMTLib2/Internals/Embed.hs view
@@ -0,0 +1,291 @@+module Language.SMTLib2.Internals.Embed where++import Language.SMTLib2.Internals.Expression+import Language.SMTLib2.Internals.Type hiding (Constr,Field)+import Language.SMTLib2.Internals.Type.List (List(..))+import qualified Language.SMTLib2.Internals.Type.List as List+import Language.SMTLib2.Internals.Monad+import Language.SMTLib2.Internals.Backend+import Language.SMTLib2.Internals.Evaluate++import Data.Functor.Identity+import Control.Monad.State+import Control.Monad.Except+import Data.GADT.Compare+import Data.GADT.Show+import qualified Data.Dependent.Map as DMap++type EmbedExpr m e tp = Expression (EmVar m e) (EmQVar m e) (EmFun m e) (EmFunArg m e) (EmLVar m e) e tp++-- | A class of 'Monad's that can be used to form SMTLib expressions.+-- The default instance of this class is the 'SMT' monad, together with its+-- associated 'Expr' type. An interesting instance is the 'Identity' monad+-- with the 'Value' type, which allows evaluation of SMTLib expressions.+class (Applicative m,+ GCompare (EmVar m e),+ GCompare (EmQVar m e),+ GCompare (EmFun m e),+ GCompare (EmFunArg m e),+ GCompare (EmLVar m e)+ ) => Embed m e where+ type EmVar m e :: Type -> *+ type EmQVar m e :: Type -> *+ type EmFun m e :: ([Type],Type) -> *+ type EmFunArg m e :: Type -> *+ type EmLVar m e :: Type -> *+ embed :: m (EmbedExpr m e tp)+ -> m (e tp)+ embedQuantifier :: Quantifier+ -> List Repr arg+ -> (forall m e. (Embed m e,Monad m) => List (EmQVar m e) arg -> m (e BoolType))+ -> m (e BoolType)+ embedTypeOf :: m (e tp -> Repr tp)++class (GCompare (ExVar i e),+ GCompare (ExQVar i e),+ GCompare (ExFun i e),+ GCompare (ExFunArg i e),+ GCompare (ExLVar i e)) => Extract i e where+ type ExVar i e :: Type -> *+ type ExQVar i e :: Type -> *+ type ExFun i e :: ([Type],Type) -> *+ type ExFunArg i e :: Type -> *+ type ExLVar i e :: Type -> *+ extract :: i -> e tp+ -> Maybe (Expression (ExVar i e) (ExQVar i e) (ExFun i e) (ExFunArg i e) (ExLVar i e) e tp)++instance (Backend b) => Embed (SMT b) (Expr b) where+ type EmVar (SMT b) (Expr b) = Var b+ type EmQVar (SMT b) (Expr b) = QVar b+ type EmFun (SMT b) (Expr b) = Fun b+ type EmFunArg (SMT b) (Expr b) = FunArg b+ type EmLVar (SMT b) (Expr b) = LVar b+ embed x = do+ rx <- x+ embedSMT (toBackend rx)+ embedQuantifier quant tps f = do+ args <- List.mapM (\tp -> embedSMT (createQVar tp Nothing)) tps+ body <- f args+ embedSMT $ toBackend (Quantification quant args body)+ embedTypeOf = pure getType++instance Embed Identity Repr where+ type EmVar Identity Repr = Repr+ type EmQVar Identity Repr = Repr+ type EmFun Identity Repr = FunRepr+ type EmFunArg Identity Repr = Repr+ type EmLVar Identity Repr = Repr+ embed e = pure f <*> e+ where+ f e = runIdentity $ expressionType return return (\(FunRepr arg tp) -> return (arg,tp)) return return return e+ embedQuantifier _ _ _ = pure bool+ embedTypeOf = pure id++-- | A user-supplied function.+-- Can be used in embedding 'Value's or 'EvalResult's.+-- Since we don't have function equality in haskell, an integer is provided to distinguish functions.+data UserFun (m :: * -> *) (e :: Type -> *) (sig :: ([Type],Type)) where+ UserFun :: List Repr arg -- Argument types+ -> Repr res -- Result type+ -> Int -- Number to distinguish functions+ -> (List e arg -> m (e res)) -- The function implementation+ -> UserFun m e '(arg,res)++instance GEq (UserFun m e) where+ geq (UserFun arg1 res1 n1 _) (UserFun arg2 res2 n2 _) = do+ Refl <- geq arg1 arg2+ Refl <- geq res1 res2+ if n1==n2+ then return Refl+ else Nothing++instance GCompare (UserFun m e) where+ gcompare (UserFun arg1 res1 n1 _) (UserFun arg2 res2 n2 _) = case gcompare arg1 arg2 of+ GLT -> GLT+ GGT -> GGT+ GEQ -> case gcompare res1 res2 of+ GLT -> GLT+ GGT -> GGT+ GEQ -> case compare n1 n2 of+ LT -> GLT+ GT -> GGT+ EQ -> GEQ++instance GetFunType (UserFun m e) where+ getFunType (UserFun arg res _ _) = (arg,res)++instance GShow (UserFun m e) where+ gshowsPrec p (UserFun idx res n _)+ = showParen (p>10) $ showsPrec 11 n . showString " : " .+ showsPrec 11 idx . showString " -> " .+ showsPrec 11 res++instance Embed Identity Value where+ type EmVar Identity Value = NoVar+ type EmQVar Identity Value = NoVar+ type EmFun Identity Value = UserFun Identity Value+ type EmFunArg Identity Value = NoVar+ type EmLVar Identity Value = NoVar+ embed e = do+ re <- e+ res <- evaluateExpr+ (error "embed: No variables in embedded values")+ (error "embed: No quantified variables in embedded values")+ (error "embed: No function variables in embedded values")+ (\(UserFun _ _ _ f) lst -> do+ lst' <- List.mapM (\res -> case res of+ ValueResult v -> return v) lst+ fmap ValueResult $ f lst')+ (error "embed: No fields in embedded values")+ (error "embed: No quantifier in embedded values")+ DMap.empty+ (\_ val -> return $ ValueResult val) re+ case res of+ ValueResult v -> return v+ embedTypeOf = pure getType++newtype ValueExt m tp = ValueExt { valueExt :: EvalResult (UserFun m (ValueExt m)) tp }++instance GetType (ValueExt m) where+ getType (ValueExt e) = getType e++instance GShow (ValueExt m) where+ gshowsPrec p (ValueExt e) = gshowsPrec p e++instance GEq (ValueExt m) where+ geq (ValueExt e1) (ValueExt e2) = geq e1 e2++instance GCompare (ValueExt m) where+ gcompare (ValueExt e1) (ValueExt e2) = gcompare e1 e2++instance Embed Identity (ValueExt Identity) where+ type EmVar Identity (ValueExt Identity) = NoVar+ type EmQVar Identity (ValueExt Identity) = NoVar+ type EmFun Identity (ValueExt Identity) = UserFun Identity (ValueExt Identity)+ type EmFunArg Identity (ValueExt Identity) = NoVar+ type EmLVar Identity (ValueExt Identity) = NoVar+ embed e = do+ re <- e+ fmap ValueExt $ evaluateExpr+ (error "embed: No variables in embedded values")+ (error "embed: No quantified variables in embedded values")+ (error "embed: No function variables in embedded values")+ (\(UserFun _ _ _ f) lst -> do+ lst' <- List.mapM (return.ValueExt) lst+ fmap valueExt $ f lst')+ (error "embed: No fields in embedded values")+ (error "embed: No quantifier in embedded values")+ DMap.empty+ (\_ val -> return $ valueExt val) re+ embedTypeOf = pure getType++newtype BackendInfo b = BackendInfo b++instance (Backend b) => Extract (BackendInfo b) (Expr b) where+ type ExVar (BackendInfo b) (Expr b) = Var b+ type ExQVar (BackendInfo b) (Expr b) = QVar b+ type ExFun (BackendInfo b) (Expr b) = Fun b+ type ExFunArg (BackendInfo b) (Expr b) = FunArg b+ type ExLVar (BackendInfo b) (Expr b) = LVar b+ extract (BackendInfo b) e = Just (fromBackend b e)++data SMTExpr var qvar fun farg lvar tp where+ SMTExpr :: Expression var qvar fun farg lvar+ (SMTExpr var qvar fun farg lvar)+ tp -> SMTExpr var qvar fun farg lvar tp+ SMTQuant :: Quantifier+ -> List Repr args+ -> (List qvar args+ -> SMTExpr var qvar fun farg lvar BoolType)+ -> SMTExpr var qvar fun farg lvar BoolType++instance (GCompare var,GetType var,+ GCompare qvar,GetType qvar,+ GCompare fun,GetFunType fun,+ GCompare farg,GetType farg,+ GCompare lvar,GetType lvar+ ) => Embed Identity (SMTExpr var qvar fun farg lvar) where+ type EmVar Identity (SMTExpr var qvar fun farg lvar) = var+ type EmQVar Identity (SMTExpr var qvar fun farg lvar) = qvar+ type EmFun Identity (SMTExpr var qvar fun farg lvar) = fun+ type EmFunArg Identity (SMTExpr var qvar fun farg lvar) = farg+ type EmLVar Identity (SMTExpr var qvar fun farg lvar) = lvar+ embed e = do+ re <- e+ return $ SMTExpr re+ embedQuantifier quant tps f = return $ SMTQuant quant tps (runIdentity . f)+ embedTypeOf = pure getType++instance (GetType var,GetType qvar,GetFunType fun,GetType farg,GetType lvar)+ => GetType (SMTExpr var qvar fun farg lvar) where+ getType (SMTExpr e) = getType e+ getType (SMTQuant _ _ _) = BoolRepr++instance (GCompare var,+ GCompare qvar,+ GCompare fun,+ GCompare farg,+ GCompare lvar) => Extract () (SMTExpr var qvar fun farg lvar) where+ type ExVar () (SMTExpr var qvar fun farg lvar) = var+ type ExQVar () (SMTExpr var qvar fun farg lvar) = qvar+ type ExFun () (SMTExpr var qvar fun farg lvar) = fun+ type ExFunArg () (SMTExpr var qvar fun farg lvar) = farg+ type ExLVar () (SMTExpr var qvar fun farg lvar) = lvar+ extract _ (SMTExpr e) = Just e+ extract _ _ = Nothing++encodeExpr :: (Backend b)+ => SMTExpr (Var b) (QVar b) (Fun b) (FunArg b) (LVar b) tp+ -> SMT b (Expr b tp)+encodeExpr (SMTExpr e) = do+ e' <- mapExpr return return return return return+ encodeExpr e+ embedSMT $ toBackend e'+encodeExpr (SMTQuant q tps f) = do+ args <- List.mapM (\tp -> embedSMT (createQVar tp Nothing)) tps+ body <- encodeExpr (f args)+ embedSMT $ toBackend (Quantification q args body)++decodeExpr :: (Backend b) => Expr b tp+ -> SMT b (SMTExpr (Var b) (QVar b) (Fun b) (FunArg b) (LVar b) tp)+decodeExpr e = do+ st <- get+ let e' = fromBackend (backend st) e+ e'' <- mapExpr return return return return return decodeExpr e'+ return (SMTExpr e'')++data AnalyzedExpr i e tp+ = AnalyzedExpr (Maybe (Expression+ (ExVar i e)+ (ExQVar i e)+ (ExFun i e)+ (ExFunArg i e)+ (ExLVar i e)+ (AnalyzedExpr i e)+ tp)) (e tp)++analyze' :: (Extract i e) => i -> e tp -> AnalyzedExpr i e tp+analyze' i expr+ = AnalyzedExpr expr' expr+ where+ expr' = do+ e <- extract i expr+ return $ runIdentity (mapExpr return return return return return+ (return . analyze' i) e)++analyze :: (Backend b) => Expr b tp -> SMT b (AnalyzedExpr (BackendInfo b) (Expr b) tp)+analyze e = do+ st <- get+ return (analyze' (BackendInfo (backend st)) e)++instance (Embed m e,Monad m) => Embed (ExceptT err m) e where+ type EmVar (ExceptT err m) e = EmVar m e+ type EmQVar (ExceptT err m) e = EmQVar m e+ type EmFun (ExceptT err m) e = EmFun m e+ type EmFunArg (ExceptT err m) e = EmFunArg m e+ type EmLVar (ExceptT err m) e = EmLVar m e+ embed e = do+ re <- e+ lift $ embed (pure re)+ embedQuantifier q arg body = lift $ embedQuantifier q arg body+ embedTypeOf = lift embedTypeOf
+ Language/SMTLib2/Internals/Evaluate.hs view
@@ -0,0 +1,482 @@+module Language.SMTLib2.Internals.Evaluate where++import Language.SMTLib2.Internals.Expression+import Language.SMTLib2.Internals.Type hiding (Field)+import qualified Language.SMTLib2.Internals.Type as Type+import Language.SMTLib2.Internals.Type.Nat+import Language.SMTLib2.Internals.Type.List+import qualified Language.SMTLib2.Internals.Type.List as List++import Data.GADT.Compare+import Data.GADT.Show+import Data.List (genericLength)+import Data.Bits+import Data.Dependent.Map (DMap)+import qualified Data.Dependent.Map as DMap+import Data.Functor.Identity++data EvalResult fun res where+ ValueResult :: Value res -> EvalResult fun res+ ArrayResult :: ArrayModel fun idx el+ -> EvalResult fun (ArrayType idx el)++data ArrayModel fun idx el where+ ArrayConst :: EvalResult fun el+ -> List Repr idx+ -> ArrayModel fun idx el+ ArrayFun :: Function fun '(idx,res)+ -> ArrayModel fun idx res+ ArrayMap :: Function fun '(arg,res)+ -> List (ArrayModel fun idx) arg+ -> List Repr idx+ -> ArrayModel fun idx res+ ArrayStore :: List (EvalResult fun) idx+ -> EvalResult fun el+ -> ArrayModel fun idx el+ -> ArrayModel fun idx el++type FunctionEval m fun+ = forall tps r. fun '(tps,r)+ -> List (EvalResult fun) tps+ -> m (EvalResult fun r)++type FieldEval m fun+ = forall dt par args tp. (IsDatatype dt)+ => List Repr par+ -> Type.Field dt tp+ -> List Value args+ -> m (EvalResult fun (CType tp par))++evalResultType :: (GetFunType fun)+ => EvalResult fun res -> Repr res+evalResultType (ValueResult val) = valueType val+evalResultType (ArrayResult mdl) = let (idx,el) = arrayModelType mdl+ in ArrayRepr idx el++arrayModelType :: (GetFunType fun)+ => ArrayModel fun idx res -> (List Repr idx,Repr res)+arrayModelType (ArrayConst res idx) = (idx,evalResultType res)+arrayModelType (ArrayFun fun) = getFunType fun+arrayModelType (ArrayMap fun args idx)+ = let (farg,ftp) = getFunType fun+ in (idx,ftp)+arrayModelType (ArrayStore idx el mdl)+ = (runIdentity $ List.mapM (return.evalResultType) idx,evalResultType el)++evaluateArray :: (Monad m,GetFunType fun)+ => FunctionEval m fun+ -> FieldEval m fun+ -> ArrayModel fun idx el+ -> List (EvalResult fun) idx+ -> m (EvalResult fun el)+evaluateArray _ _ (ArrayConst c _) _ = return c+evaluateArray f g (ArrayFun fun) arg = evaluateFun f g fun arg+evaluateArray f g (ArrayMap fun args _) arg = do+ rargs <- List.mapM (\arr -> evaluateArray f g arr arg) args+ evaluateFun f g fun rargs+evaluateArray f g (ArrayStore idx val mdl) arg = do+ eq <- List.zipToListM (evalResultEq f g) idx arg+ if and eq+ then return val+ else evaluateArray f g mdl arg++typeNumElements :: Repr t -> Maybe Integer+typeNumElements BoolRepr = Just 2+typeNumElements IntRepr = Nothing+typeNumElements RealRepr = Nothing+typeNumElements (BitVecRepr sz) = Just (2^(bwSize sz))+typeNumElements (ArrayRepr idx el) = do+ ridx <- List.toList typeNumElements idx+ rel <- typeNumElements el+ return (product (rel:ridx))+typeNumElements (DataRepr _ _) = error "typeNumElements not implemented for datatypes"++evalResultEq :: (Monad m,GetFunType fun)+ => FunctionEval m fun+ -> FieldEval m fun+ -> EvalResult fun res+ -> EvalResult fun res+ -> m Bool+evalResultEq _ _ (ValueResult v1) (ValueResult v2) = return (v1 == v2)+evalResultEq ev evf (ArrayResult m1) (ArrayResult m2)+ = arrayModelEq ev evf m1 m2 []++arrayModelEq :: (Monad m,GetFunType fun)+ => FunctionEval m fun+ -> FieldEval m fun+ -> ArrayModel fun idx t+ -> ArrayModel fun idx t+ -> [List (EvalResult fun) idx]+ -> m Bool+arrayModelEq _ _ (ArrayFun _) _ _+ = error "Cannot decide array equality with arrays built from functions."+arrayModelEq _ _ _ (ArrayFun _) _+ = error "Cannot decide array equality with arrays built from functions."+arrayModelEq _ _ (ArrayMap _ _ _) _ _+ = error "Cannot decide array equality with arrays built from functions."+arrayModelEq _ _ _ (ArrayMap _ _ _) _+ = error "Cannot decide array equality with arrays built from functions."+arrayModelEq ev evf (ArrayConst v1 _) (ArrayConst v2 _) _+ = evalResultEq ev evf v1 v2+arrayModelEq ev evf (ArrayStore (idx::List (EvalResult fun) idx) el mdl) oth ign = do+ isIgn <- isIgnored idx ign+ if isIgn+ then arrayModelEq ev evf mdl oth ign+ else do+ othEl <- evaluateArray ev evf oth idx+ othIsEq <- evalResultEq ev evf el othEl+ if othIsEq+ then case List.toList typeNumElements (runIdentity $ List.mapM (return.evalResultType) idx) of+ Just szs -> if genericLength szs==product szs+ then return True -- All indices are ignored+ else arrayModelEq ev evf mdl oth (idx:ign)+ else return False+ where+ isIgnored _ [] = return False+ isIgnored idx (i:is) = do+ same <- List.zipToListM (evalResultEq ev evf) idx i+ if and same+ then return True+ else isIgnored idx is+arrayModelEq ev evf m1 m2 ign = arrayModelEq ev evf m2 m1 ign++evaluateExpr :: (Monad m,GCompare lv,GetFunType fun)+ => (forall t. v t -> m (EvalResult fun t))+ -> (forall t. qv t -> m (EvalResult fun t))+ -> (forall t. fv t -> m (EvalResult fun t))+ -> FunctionEval m fun+ -> FieldEval m fun+ -> (forall arg. Quantifier+ -> List qv arg+ -> e BoolType+ -> m (EvalResult fun BoolType))+ -> DMap lv (EvalResult fun)+ -> (forall t. DMap lv (EvalResult fun) -> e t -> m (EvalResult fun t))+ -> Expression v qv fun fv lv e res+ -> m (EvalResult fun res)+evaluateExpr fv _ _ _ _ _ _ _ (Var v) = fv v+evaluateExpr _ fqv _ _ _ _ _ _ (QVar v) = fqv v+evaluateExpr _ _ ffv _ _ _ _ _ (FVar v) = ffv v+evaluateExpr _ _ _ _ _ _ binds _ (LVar v) = case DMap.lookup v binds of+ Just r -> return r+evaluateExpr _ _ _ _ _ _ _ _ (Const c) = return (ValueResult c)+evaluateExpr _ _ _ _ _ _ _ _ (AsArray fun)+ = return (ArrayResult (ArrayFun fun))+evaluateExpr _ _ _ _ _ evq _ _ (Quantification q arg body)+ = evq q arg body+evaluateExpr _ _ _ _ _ _ binds f (Let arg body) = do+ nbinds <- List.foldM (\cbinds x -> do+ rx <- f cbinds (letExpr x)+ return $ DMap.insert (letVar x) rx cbinds+ ) binds arg+ f nbinds body+evaluateExpr _ _ _ evf evr _ binds f (App fun args) = do+ rargs <- List.mapM (f binds) args+ evaluateFun evf evr fun rargs++evaluateFun :: forall m fun arg res.+ (Monad m,GetFunType fun)+ => FunctionEval m fun+ -> FieldEval m fun+ -> Function fun '(arg,res)+ -> List (EvalResult fun) arg+ -> m (EvalResult fun res)+evaluateFun ev _ (Fun f) arg = ev f arg+evaluateFun ev evf (Eq tp n) args = isEq n tp args >>=+ return . ValueResult . BoolValue+ where+ isEq :: Natural n -> Repr tp -> List (EvalResult fun) (AllEq tp n) -> m Bool+ isEq Zero _ Nil = return True+ isEq (Succ Zero) _ (_ ::: Nil) = return True+ isEq (Succ (Succ n)) tp (x ::: y ::: xs) = do+ eq <- evalResultEq ev evf x y+ if eq+ then isEq (Succ n) tp (y ::: xs)+ else return False+evaluateFun ev evf (Distinct tp n) args = isDistinct n tp args >>=+ return . ValueResult . BoolValue+ where+ isDistinct :: Natural n -> Repr tp -> List (EvalResult fun) (AllEq tp n) -> m Bool+ isDistinct Zero _ Nil = return True+ isDistinct (Succ Zero) _ (_ ::: Nil) = return True+ isDistinct (Succ n) tp (x ::: xs) = do+ neq <- isNeq n tp x xs+ if neq+ then isDistinct n tp xs+ else return False+ isNeq :: Natural n -> Repr tp -> EvalResult fun tp+ -> List (EvalResult fun) (AllEq tp n) -> m Bool+ isNeq Zero _ _ Nil = return True+ isNeq (Succ n) tp x (y ::: ys) = do+ eq <- evalResultEq ev evf x y+ if eq+ then return False+ else isNeq n tp x ys+evaluateFun _ _ (Ord NumInt op) ((ValueResult (IntValue lhs)) ::: (ValueResult (IntValue rhs)) ::: Nil)+ = return $ ValueResult $ BoolValue (cmp op lhs rhs)+ where+ cmp Ge = (>=)+ cmp Gt = (>)+ cmp Le = (<=)+ cmp Lt = (<)+evaluateFun _ _ (Ord NumReal op) ((ValueResult (RealValue lhs)) ::: (ValueResult (RealValue rhs)) ::: Nil)+ = return $ ValueResult $ BoolValue (cmp op lhs rhs)+ where+ cmp Ge = (>=)+ cmp Gt = (>)+ cmp Le = (<=)+ cmp Lt = (<)+evaluateFun _ _ (Arith NumInt op n) args+ = return $ ValueResult $ IntValue $+ eval op $ fmap (\(ValueResult (IntValue v)) -> v)+ (allEqToList n args :: [EvalResult fun IntType])+ where+ eval Plus xs = sum xs+ eval Mult xs = product xs+ eval Minus [] = 0+ eval Minus [x] = -x+ eval Minus (x:xs) = x-sum xs+evaluateFun _ _ (Arith NumReal op n) args+ = return $ ValueResult $ RealValue $+ eval op $ fmap (\(ValueResult (RealValue v)) -> v)+ (allEqToList n args :: [EvalResult fun RealType])+ where+ eval Plus xs = sum xs+ eval Mult xs = product xs+ eval Minus [] = 0+ eval Minus [x] = -x+ eval Minus (x:xs) = x-sum xs+evaluateFun _ _ (ArithIntBin op) ((ValueResult (IntValue lhs)) ::: (ValueResult (IntValue rhs)) ::: Nil)+ = return $ ValueResult $ IntValue (eval op lhs rhs)+ where+ eval Div = div+ eval Mod = mod+ eval Rem = rem+evaluateFun _ _ Divide ((ValueResult (RealValue lhs)) ::: (ValueResult (RealValue rhs)) ::: Nil)+ = return $ ValueResult $ RealValue (lhs / rhs)+evaluateFun _ _ (Abs NumInt) ((ValueResult (IntValue x)) ::: Nil)+ = return $ ValueResult $ IntValue $ abs x+evaluateFun _ _ (Abs NumReal) ((ValueResult (RealValue x)) ::: Nil)+ = return $ ValueResult $ RealValue $ abs x+evaluateFun _ _ Not ((ValueResult (BoolValue x)) ::: Nil)+ = return $ ValueResult $ BoolValue $ not x+evaluateFun _ _ (Logic op n) args+ = return $ ValueResult $ BoolValue $+ eval op $ fmap (\(ValueResult (BoolValue v)) -> v)+ (allEqToList n args :: [EvalResult fun BoolType])+ where+ eval And = and+ eval Or = or+ eval XOr = foldl1 (\x y -> if x then not y else y)+ eval Implies = impl+ impl [x] = x+ impl (x:xs) = if x then impl xs else False+evaluateFun _ _ ToReal ((ValueResult (IntValue x)) ::: Nil)+ = return $ ValueResult $ RealValue $ fromInteger x+evaluateFun _ _ ToInt ((ValueResult (RealValue x)) ::: Nil)+ = return $ ValueResult $ IntValue $ round x+evaluateFun _ _ (ITE _) ((ValueResult (BoolValue c)) ::: x ::: y ::: Nil)+ = return $ if c then x else y+evaluateFun _ _ (BVComp op _) ((ValueResult (BitVecValue x nx)) ::: (ValueResult (BitVecValue y ny)) ::: Nil)+ = return $ ValueResult $ BoolValue $ comp op+ where+ bw = bwSize nx+ sx = if x >= 2^(bw-1) then x-2^bw else x+ sy = if y >= 2^(bw-1) then y-2^bw else y+ comp BVULE = x <= y+ comp BVULT = x < y+ comp BVUGE = x >= y+ comp BVUGT = x > y+ comp BVSLE = sx <= sy+ comp BVSLT = sx < sy+ comp BVSGE = sx >= sy+ comp BVSGT = sx > sy+evaluateFun _ _ (BVBin op _) ((ValueResult (BitVecValue x nx)) ::: (ValueResult (BitVecValue y ny)) ::: Nil)+ = return $ ValueResult $ BitVecValue (comp op) nx+ where+ bw = bwSize nx+ sx = if x >= 2^(bw-1) then x-2^bw else x+ sy = if y >= 2^(bw-1) then y-2^bw else y+ toU x = if x < 0+ then x+2^bw+ else x+ comp BVAdd = (x+y) `mod` (2^bw)+ comp BVSub = (x-y) `mod` (2^bw)+ comp BVMul = (x*y) `mod` (2^bw)+ comp BVURem = x `rem` y+ comp BVSRem = toU (sx `rem` sy)+ comp BVUDiv = x `div` y+ comp BVSDiv = toU (sx `div` sy)+ comp BVSHL = x * 2^y+ comp BVLSHR = x `div` (2^y)+ comp BVASHR = toU $ sx `div` (2^y)+ comp BVXor = xor x y+ comp BVAnd = x .&. y+ comp BVOr = x .|. y+evaluateFun _ _ (BVUn op _) ((ValueResult (BitVecValue x nx)) ::: Nil)+ = return $ ValueResult $ BitVecValue (comp op) nx+ where+ bw = bwSize nx+ comp BVNot = xor (2^bw-1) x+ comp BVNeg = 2^bw-x+evaluateFun ev evf (Select _ _) ((ArrayResult mdl) ::: idx)+ = evaluateArray ev evf mdl idx+evaluateFun _ _ (Store _ _) ((ArrayResult mdl) ::: el ::: idx)+ = return $ ArrayResult (ArrayStore idx el mdl)+evaluateFun _ _ (ConstArray idx _) (val ::: Nil)+ = return $ ArrayResult (ArrayConst val idx)+evaluateFun _ _ (Concat _ _) ((ValueResult (BitVecValue x nx)) ::: (ValueResult (BitVecValue y ny)) ::: Nil)+ = return $ ValueResult $ BitVecValue (x*(2^bw)+y) (bwAdd nx ny)+ where+ bw = bwSize nx+evaluateFun _ _ (Extract bw start len) ((ValueResult (BitVecValue x nx)) ::: Nil)+ = return $ ValueResult $ BitVecValue (x `div` (2^(bwSize start))) len+evaluateFun _ _ (Constructor dt par con) args = do+ rargs <- List.mapM (\(ValueResult v) -> return v) args+ return $ ValueResult $ DataValue (construct par con rargs)+evaluateFun _ _ (Test dt par con) ((ValueResult (ConstrValue par' con' _)) ::: Nil)+ = return $ ValueResult $ BoolValue $ case geq con con' of+ Just Refl -> True+ Nothing -> False+--evaluateFun _ ev (Field f) ((ValueResult (ConstrValue con args)) ::: Nil)+-- = ev f con args+evaluateFun _ _ (Divisible n) ((ValueResult (IntValue i)) ::: Nil)+ = return $ ValueResult $ BoolValue $ i `mod` n == 0++instance GetFunType fun => GetType (EvalResult fun) where+ getType (ValueResult v) = getType v+ getType (ArrayResult v) = let (idx,res) = getArrayModelType v+ in ArrayRepr idx res++getArrayModelType :: GetFunType fun => ArrayModel fun idx el -> (List Repr idx,Repr el)+getArrayModelType (ArrayConst c idx) = (idx,getType c)+getArrayModelType (ArrayFun fun) = getFunType fun+getArrayModelType (ArrayMap fun args idx)+ = let (_,res) = getFunType fun+ in (idx,res)+getArrayModelType (ArrayStore idx el arr) = getArrayModelType arr++instance GShow fun => Show (EvalResult fun res) where+ showsPrec p (ValueResult v) = showsPrec p v+ showsPrec p (ArrayResult arr) = showsPrec p arr++instance GShow fun => Show (ArrayModel fun idx el) where+ showsPrec p (ArrayConst c idx)+ = showString "(array-const " .+ showsPrec 11 idx . showChar ' ' .+ showsPrec 11 c . showChar ')'+ showsPrec p (ArrayFun fun)+ = showString "(array-fun " .+ showsPrec 11 fun . showChar ')'+ showsPrec p (ArrayMap fun args idx)+ = showString "(array-map " .+ showsPrec 11 fun . showChar ' ' .+ showsPrec 11 args . showChar ')'+ showsPrec p (ArrayStore idx el mdl)+ = showString "(array-store " .+ showsPrec 11 idx . showChar ' ' .+ showsPrec 11 el . showChar ' ' .+ showsPrec 11 mdl . showChar ')'++instance GShow fun => GShow (EvalResult fun) where+ gshowsPrec = showsPrec++instance GShow fun => GShow (ArrayModel fun idx) where+ gshowsPrec = showsPrec++instance GEq fun => GEq (EvalResult fun) where+ geq (ValueResult x) (ValueResult y) = geq x y+ geq (ArrayResult mdl1) (ArrayResult mdl2) = do+ (Refl,Refl) <- geqArrayModel mdl1 mdl2+ return Refl+ geq _ _ = Nothing++instance GCompare fun => GCompare (EvalResult fun) where+ gcompare (ValueResult x) (ValueResult y) = gcompare x y+ gcompare (ValueResult _) _ = GLT+ gcompare _ (ValueResult _) = GGT+ gcompare (ArrayResult x) (ArrayResult y) = case gcompareArrayModel x y of+ (GEQ,GEQ) -> GEQ+ (GEQ,GLT) -> GLT+ (GEQ,GGT) -> GGT+ (GLT,_) -> GLT+ (GGT,_) -> GGT++geqArrayModel :: GEq fun => ArrayModel fun idx1 el1 -> ArrayModel fun idx2 el2 -> Maybe (idx1 :~: idx2,el1 :~: el2)+geqArrayModel (ArrayConst v1 idx1) (ArrayConst v2 idx2) = do+ Refl <- geq v1 v2+ Refl <- geq idx1 idx2+ return (Refl,Refl)+geqArrayModel (ArrayFun f1) (ArrayFun f2) = do+ Refl <- geq f1 f2+ return (Refl,Refl)+geqArrayModel (ArrayMap f1 arg1 idx1) (ArrayMap f2 arg2 idx2) = do+ Refl <- geq idx1 idx2+ Refl <- geq f1 f2+ _ <- zipToListM (\x y -> do+ (Refl,Refl) <- geqArrayModel x y+ return ()) arg1 arg2+ return (Refl,Refl)+geqArrayModel (ArrayStore idx1 el1 arr1) (ArrayStore idx2 el2 arr2) = do+ Refl <- geq idx1 idx2+ Refl <- geq el1 el2+ (Refl,Refl) <- geqArrayModel arr1 arr2+ return (Refl,Refl)+geqArrayModel _ _ = Nothing++gcompareArrayModel :: GCompare fun => ArrayModel fun idx1 el1 -> ArrayModel fun idx2 el2+ -> (GOrdering idx1 idx2,+ GOrdering el1 el2)+gcompareArrayModel (ArrayConst c1 idx1) (ArrayConst c2 idx2)+ = case gcompare idx1 idx2 of+ GEQ -> (GEQ,gcompare c1 c2)+ GLT -> (GLT,GLT)+ GGT -> (GGT,GGT)+gcompareArrayModel (ArrayConst _ _) _ = (GLT,GLT)+gcompareArrayModel _ (ArrayConst _ _) = (GGT,GGT)+gcompareArrayModel (ArrayFun f1) (ArrayFun f2) = case gcompare f1 f2 of+ GEQ -> (GEQ,GEQ)+ GLT -> (GLT,GLT)+ GGT -> (GGT,GGT)+gcompareArrayModel (ArrayFun _) _ = (GLT,GLT)+gcompareArrayModel _ (ArrayFun _) = (GGT,GGT)+gcompareArrayModel (ArrayMap f1 arg1 idx1) (ArrayMap f2 arg2 idx2)+ = case gcompare idx1 idx2 of+ GEQ -> (GEQ,case gcompare f1 f2 of+ GEQ -> case gcompareArrayModels arg1 arg2 of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT+ GLT -> GLT+ GGT -> GGT)+ GLT -> (GLT,GLT)+ GGT -> (GGT,GGT)+ where+ gcompareArrayModels :: GCompare fun+ => List (ArrayModel fun idx) arg1+ -> List (ArrayModel fun idx) arg2+ -> GOrdering arg1 arg2+ gcompareArrayModels Nil Nil = GEQ+ gcompareArrayModels Nil _ = GLT+ gcompareArrayModels _ Nil = GGT+ gcompareArrayModels (x:::xs) (y:::ys) = case gcompareArrayModel x y of+ (GEQ,GEQ) -> case gcompareArrayModels xs ys of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT+ (GEQ,GLT) -> GLT+ (GEQ,GGT) -> GGT+ (GLT,_) -> GLT+ (GGT,_) -> GGT+gcompareArrayModel (ArrayMap _ _ _) _ = (GLT,GLT)+gcompareArrayModel _ (ArrayMap _ _ _) = (GGT,GGT)+gcompareArrayModel (ArrayStore idx1 el1 mdl1) (ArrayStore idx2 el2 mdl2)+ = case gcompareArrayModel mdl1 mdl2 of+ (GEQ,GEQ) -> case gcompare idx1 idx2 of+ GEQ -> case gcompare el1 el2 of+ GEQ -> (GEQ,GEQ)+ GLT -> (GEQ,GLT)+ GGT -> (GEQ,GGT)+ GLT -> (GLT,GLT)+ GGT -> (GGT,GGT)+ r -> r
+ Language/SMTLib2/Internals/Expression.hs view
@@ -0,0 +1,1155 @@+module Language.SMTLib2.Internals.Expression where++import Language.SMTLib2.Internals.Type hiding (Field)+import qualified Language.SMTLib2.Internals.Type as Type+import Language.SMTLib2.Internals.Type.Nat+import Language.SMTLib2.Internals.Type.List (List(..))+import qualified Language.SMTLib2.Internals.Type.List as List++import Data.Typeable+import Text.Show+import Data.GADT.Compare+import Data.GADT.Show+import Data.Functor.Identity+import Data.Ratio+import qualified GHC.TypeLits as TL++type family AllEq (tp :: Type) (n :: Nat) :: [Type] where+ AllEq tp Z = '[]+ AllEq tp (S n) = tp ': (AllEq tp n)++allEqToList :: Natural n -> List a (AllEq tp n) -> [a tp]+allEqToList Zero Nil = []+allEqToList (Succ n) (x ::: xs) = x:allEqToList n xs++allEqFromList :: [a tp] -> (forall n. Natural n -> List a (AllEq tp n) -> r) -> r+allEqFromList [] f = f Zero Nil+allEqFromList (x:xs) f = allEqFromList xs (\n arg -> f (Succ n) (x ::: arg))++allEqOf :: Repr tp -> Natural n -> List Repr (AllEq tp n)+allEqOf tp Zero = Nil+allEqOf tp (Succ n) = tp ::: allEqOf tp n++mapAllEq :: Monad m => (e1 tp -> m (e2 tp))+ -> Natural n+ -> List e1 (AllEq tp n)+ -> m (List e2 (AllEq tp n))+mapAllEq f Zero Nil = return Nil+mapAllEq f (Succ n) (x ::: xs) = do+ x' <- f x+ xs' <- mapAllEq f n xs+ return (x' ::: xs')++data Function (fun :: ([Type],Type) -> *) (sig :: ([Type],Type)) where+ Fun :: fun '(arg,res) -> Function fun '(arg,res)+ Eq :: Repr tp -> Natural n -> Function fun '(AllEq tp n,BoolType)+ Distinct :: Repr tp -> Natural n -> Function fun '(AllEq tp n,BoolType)+ Map :: List Repr idx -> Function fun '(arg,res)+ -> Function fun '(Lifted arg idx,ArrayType idx res)+ Ord :: NumRepr tp -> OrdOp -> Function fun '([tp,tp],BoolType)+ Arith :: NumRepr tp -> ArithOp -> Natural n+ -> Function fun '(AllEq tp n,tp)+ ArithIntBin :: ArithOpInt -> Function fun '([IntType,IntType],IntType)+ Divide :: Function fun '([RealType,RealType],RealType)+ Abs :: NumRepr tp -> Function fun '( '[tp],tp)+ Not :: Function fun '( '[BoolType],BoolType)+ Logic :: LogicOp -> Natural n -> Function fun '(AllEq BoolType n,BoolType)+ ToReal :: Function fun '( '[IntType],RealType)+ ToInt :: Function fun '( '[RealType],IntType)+ ITE :: Repr a -> Function fun '([BoolType,a,a],a)+ BVComp :: BVCompOp -> BitWidth a -> Function fun '([BitVecType a,BitVecType a],BoolType)+ BVBin :: BVBinOp -> BitWidth a -> Function fun '([BitVecType a,BitVecType a],BitVecType a)+ BVUn :: BVUnOp -> BitWidth a -> Function fun '( '[BitVecType a],BitVecType a)+ Select :: List Repr idx -> Repr val -> Function fun '(ArrayType idx val ': idx,val)+ Store :: List Repr idx -> Repr val -> Function fun '(ArrayType idx val ': val ': idx,ArrayType idx val)+ ConstArray :: List Repr idx -> Repr val -> Function fun '( '[val],ArrayType idx val)+ Concat :: BitWidth n1 -> BitWidth n2 -> Function fun '([BitVecType n1,BitVecType n2],BitVecType (n1 TL.+ n2))+ Extract :: BitWidth bw -> BitWidth start -> BitWidth len -> Function fun '( '[BitVecType bw],BitVecType len)+ Constructor :: (IsDatatype dt,List.Length par ~ Parameters dt)+ => Datatype dt+ -> List Repr par+ -> Constr dt sig+ -> Function fun '(Instantiated sig par,DataType dt par)+ Test :: (IsDatatype dt,List.Length par ~ Parameters dt)+ => Datatype dt+ -> List Repr par+ -> Constr dt sig+ -> Function fun '( '[DataType dt par],BoolType)+ Field :: (IsDatatype dt,List.Length par ~ Parameters dt)+ => Datatype dt+ -> List Repr par+ -> Type.Field dt t+ -> Function fun '( '[DataType dt par],CType t par)+ Divisible :: Integer -> Function fun '( '[IntType],BoolType)++data AnyFunction (fun :: ([Type],Type) -> *) where+ AnyFunction :: Function fun '(arg,t) -> AnyFunction fun++data OrdOp = Ge | Gt | Le | Lt deriving (Eq,Ord,Show)++data ArithOp = Plus | Mult | Minus deriving (Eq,Ord,Show)++data ArithOpInt = Div | Mod | Rem deriving (Eq,Ord,Show)++data LogicOp = And | Or | XOr | Implies deriving (Eq,Ord,Show)++data BVCompOp = BVULE+ | BVULT+ | BVUGE+ | BVUGT+ | BVSLE+ | BVSLT+ | BVSGE+ | BVSGT+ deriving (Eq,Ord,Show)++data BVBinOp = BVAdd+ | BVSub+ | BVMul+ | BVURem+ | BVSRem+ | BVUDiv+ | BVSDiv+ | BVSHL+ | BVLSHR+ | BVASHR+ | BVXor+ | BVAnd+ | BVOr+ deriving (Eq,Ord,Show)++data BVUnOp = BVNot | BVNeg deriving (Eq,Ord,Show)++data LetBinding (v :: Type -> *) (e :: Type -> *) (t :: Type)+ = LetBinding { letVar :: v t+ , letExpr :: e t }++data Quantifier = Forall | Exists deriving (Typeable,Eq,Ord,Show)++data Expression (v :: Type -> *) (qv :: Type -> *) (fun :: ([Type],Type) -> *) (fv :: Type -> *) (lv :: Type -> *) (e :: Type -> *) (res :: Type) where+#if __GLASGOW_HASKELL__>=712+ -- | Free variable.+#endif+ Var :: v res -> Expression v qv fun fv lv e res+#if __GLASGOW_HASKELL__>=712+ -- | Quantified variable, i.e. a variable that's bound by a forall/exists quantor.+#endif+ QVar :: qv res -> Expression v qv fun fv lv e res+#if __GLASGOW_HASKELL__>=712+ -- | A function argument variable. Only used in function bodies.+#endif+ FVar :: fv res -> Expression v qv fun fv lv e res+#if __GLASGOW_HASKELL__>=712+ -- | A variable bound by a let binding.+#endif+ LVar :: lv res -> Expression v qv fun fv lv e res+#if __GLASGOW_HASKELL__>=712+ -- | Function application+#endif+ App :: Function fun '(arg,res)+ -> List e arg+ -> Expression v qv fun fv lv e res+#if __GLASGOW_HASKELL__>=712+ -- | Constant+#endif+ Const :: Value a -> Expression v qv fun fv lv e a+#if __GLASGOW_HASKELL__>=712+ -- | AsArray converts a function into an array by using the function+ -- arguments as array indices and the return type as array element.+#endif+ AsArray :: Function fun '(arg,res)+ -> Expression v qv fun fv lv e (ArrayType arg res)+#if __GLASGOW_HASKELL__>=712+ -- | Bind variables using a forall or exists quantor.+#endif+ Quantification :: Quantifier -> List qv arg -> e BoolType+ -> Expression v qv fun fv lv e BoolType+#if __GLASGOW_HASKELL__>=712+ -- | Bind variables to expressions.+#endif+ Let :: List (LetBinding lv e) arg+ -> e res+ -> Expression v qv fun fv lv e res++instance GEq fun => Eq (Function fun sig) where+ (==) = defaultEq++class SMTOrd (t :: Type) where+ lt :: Function fun '( '[t,t],BoolType)+ le :: Function fun '( '[t,t],BoolType)+ gt :: Function fun '( '[t,t],BoolType)+ ge :: Function fun '( '[t,t],BoolType)++instance SMTOrd IntType where+ lt = Ord NumInt Lt+ le = Ord NumInt Le+ gt = Ord NumInt Gt+ ge = Ord NumInt Ge++instance SMTOrd RealType where+ lt = Ord NumReal Lt+ le = Ord NumReal Le+ gt = Ord NumReal Gt+ ge = Ord NumReal Ge++class SMTArith t where+ arithFromInteger :: Integer -> Value t+ arith :: ArithOp -> Natural n -> Function fun '(AllEq t n,t)+ plus :: Natural n -> Function fun '(AllEq t n,t)+ minus :: Natural n -> Function fun '(AllEq t n,t)+ mult :: Natural n -> Function fun '(AllEq t n,t)+ abs' :: Function fun '( '[t],t)++instance SMTArith IntType where+ arithFromInteger n = IntValue n+ arith = Arith NumInt+ plus = Arith NumInt Plus+ minus = Arith NumInt Minus+ mult = Arith NumInt Mult+ abs' = Abs NumInt++instance SMTArith RealType where+ arithFromInteger n = RealValue (fromInteger n)+ arith = Arith NumReal+ plus = Arith NumReal Plus+ minus = Arith NumReal Minus+ mult = Arith NumReal Mult+ abs' = Abs NumReal++functionType :: Monad m+ => (forall arg t. fun '(arg,t) -> m (List Repr arg,Repr t))+ -> Function fun '(arg,res)+ -> m (List Repr arg,Repr res)+functionType f (Fun fun) = f fun+functionType _ (Eq tp n) = return (allEqOf tp n,BoolRepr)+functionType _ (Distinct tp n) = return (allEqOf tp n,BoolRepr)+functionType f (Map idx fun) = do+ (arg,res) <- functionType f fun+ return (liftType arg idx,ArrayRepr idx res)+functionType _ (Ord tp _) = return (numRepr tp ::: numRepr tp ::: Nil,BoolRepr)+functionType _ (Arith tp _ n) = return (allEqOf (numRepr tp) n,numRepr tp)+functionType _ (ArithIntBin _) = return (IntRepr ::: IntRepr ::: Nil,IntRepr)+functionType _ Divide = return (RealRepr ::: RealRepr ::: Nil,RealRepr)+functionType _ (Abs tp) = return (numRepr tp ::: Nil,numRepr tp)+functionType _ Not = return (BoolRepr ::: Nil,BoolRepr)+functionType _ (Logic op n) = return (allEqOf BoolRepr n,BoolRepr)+functionType _ ToReal = return (IntRepr ::: Nil,RealRepr)+functionType _ ToInt = return (RealRepr ::: Nil,IntRepr)+functionType _ (ITE tp) = return (BoolRepr ::: tp ::: tp ::: Nil,tp)+functionType _ (BVComp _ n) = return (BitVecRepr n ::: BitVecRepr n ::: Nil,BoolRepr)+functionType _ (BVBin _ n) = return (BitVecRepr n ::: BitVecRepr n ::: Nil,BitVecRepr n)+functionType _ (BVUn _ n) = return (BitVecRepr n ::: Nil,BitVecRepr n)+functionType _ (Select idx el) = return (ArrayRepr idx el ::: idx,el)+functionType _ (Store idx el) = return (ArrayRepr idx el ::: el ::: idx,ArrayRepr idx el)+functionType _ (ConstArray idx el) = return (el ::: Nil,ArrayRepr idx el)+functionType _ (Concat bw1 bw2) = return (BitVecRepr bw1 ::: BitVecRepr bw2 ::: Nil,+ BitVecRepr (bwAdd bw1 bw2))+functionType _ (Extract bw start len) = return (BitVecRepr bw ::: Nil,BitVecRepr len)+functionType _ (Constructor dt par con) = case instantiate (constrSig con) par of+ (res,Refl) -> return (res,DataRepr dt par)+functionType _ (Test dt par con) = return (DataRepr dt par ::: Nil,BoolRepr)+functionType _ (Field dt par field)+ = return (DataRepr dt par ::: Nil,ctype (fieldType field) par)+functionType _ (Divisible _) = return (IntRepr ::: Nil,BoolRepr)++expressionType :: (Monad m,Functor m)+ => (forall t. v t -> m (Repr t))+ -> (forall t. qv t -> m (Repr t))+ -> (forall arg t. fun '(arg,t) -> m (List Repr arg,Repr t))+ -> (forall t. fv t -> m (Repr t))+ -> (forall t. lv t -> m (Repr t))+ -> (forall t. e t -> m (Repr t))+ -> Expression v qv fun fv lv e res+ -> m (Repr res)+expressionType f _ _ _ _ _ (Var v) = f v+expressionType _ f _ _ _ _ (QVar v) = f v+expressionType _ _ _ f _ _ (FVar v) = f v+expressionType _ _ _ _ f _ (LVar v) = f v+expressionType _ _ f _ _ _ (App fun arg) = fmap snd $ functionType f fun+expressionType _ _ _ _ _ _ (Const v) = return $ valueType v+expressionType _ _ f _ _ _ (AsArray fun) = do+ (arg,res) <- functionType f fun+ return $ ArrayRepr arg res+expressionType _ _ _ _ _ _ (Quantification _ _ _) = return BoolRepr+expressionType _ _ _ _ _ f (Let _ body) = f body++mapExpr :: (Functor m,Monad m)+ => (forall t. v1 t -> m (v2 t)) -- ^ How to translate variables+ -> (forall t. qv1 t -> m (qv2 t)) -- ^ How to translate quantified variables+ -> (forall arg t. fun1 '(arg,t) -> m (fun2 '(arg,t))) -- ^ How to translate functions+ -> (forall t. fv1 t -> m (fv2 t)) -- ^ How to translate function variables+ -> (forall t. lv1 t -> m (lv2 t)) -- ^ How to translate let variables+ -> (forall t. e1 t -> m (e2 t)) -- ^ How to translate sub-expressions+ -> Expression v1 qv1 fun1 fv1 lv1 e1 r -- ^ The expression to translate+ -> m (Expression v2 qv2 fun2 fv2 lv2 e2 r)+mapExpr f _ _ _ _ _ (Var v) = fmap Var (f v)+mapExpr _ f _ _ _ _ (QVar v) = fmap QVar (f v)+mapExpr _ _ _ f _ _ (FVar v) = fmap FVar (f v)+mapExpr _ _ _ _ f _ (LVar v) = fmap LVar (f v)+mapExpr _ _ f _ _ i (App fun args) = do+ fun' <- mapFunction f fun+ args' <- List.mapM i args+ return (App fun' args')+mapExpr _ _ _ _ _ _ (Const val) = return (Const val)+mapExpr _ _ f _ _ _ (AsArray fun) = fmap AsArray (mapFunction f fun)+mapExpr _ f _ _ _ g (Quantification q args body) = do+ args' <- List.mapM f args+ body' <- g body+ return (Quantification q args' body')+mapExpr _ _ _ _ f g (Let args body) = do+ args' <- List.mapM (\bind -> do+ nv <- f (letVar bind)+ nexpr <- g (letExpr bind)+ return $ LetBinding nv nexpr+ ) args+ body' <- g body+ return (Let args' body')++mapFunction :: (Functor m,Monad m)+ => (forall arg t. fun1 '(arg,t) -> m (fun2 '(arg,t)))+ -> Function fun1 '(arg,res)+ -> m (Function fun2 '(arg,res))+mapFunction f (Fun x) = fmap Fun (f x)+mapFunction _ (Eq tp n) = return (Eq tp n)+mapFunction _ (Distinct tp n) = return (Distinct tp n)+mapFunction f (Map idx x) = do+ x' <- mapFunction f x+ return (Map idx x')+mapFunction _ (Ord tp op) = return (Ord tp op)+mapFunction _ (Arith tp op n) = return (Arith tp op n)+mapFunction _ (ArithIntBin op) = return (ArithIntBin op)+mapFunction _ Divide = return Divide+mapFunction _ (Abs tp) = return (Abs tp)+mapFunction _ Not = return Not+mapFunction _ (Logic op n) = return (Logic op n)+mapFunction _ ToReal = return ToReal+mapFunction _ ToInt = return ToInt+mapFunction _ (ITE tp) = return (ITE tp)+mapFunction _ (BVComp op bw) = return (BVComp op bw)+mapFunction _ (BVBin op bw) = return (BVBin op bw)+mapFunction _ (BVUn op bw) = return (BVUn op bw)+mapFunction _ (Select idx el) = return (Select idx el)+mapFunction _ (Store idx el) = return (Store idx el)+mapFunction _ (ConstArray idx el) = return (ConstArray idx el)+mapFunction _ (Concat bw1 bw2) = return (Concat bw1 bw2)+mapFunction _ (Extract bw start len) = return (Extract bw start len)+mapFunction _ (Constructor dt par con) = return (Constructor dt par con)+mapFunction _ (Test dt par con) = return (Test dt par con)+mapFunction _ (Field dt par x) = return (Field dt par x)+mapFunction _ (Divisible x) = return (Divisible x)++instance (GShow v,GShow qv,GShow fun,GShow fv,GShow lv,GShow e)+ => Show (Expression v qv fun fv lv e r) where+ showsPrec p (Var v) = showParen (p>10) $+ showString "Var " .+ gshowsPrec 11 v+ showsPrec p (QVar v) = showParen (p>10) $+ showString "QVar " .+ gshowsPrec 11 v+ showsPrec p (FVar v) = showParen (p>10) $+ showString "FVar " .+ gshowsPrec 11 v+ showsPrec p (LVar v) = showParen (p>10) $+ showString "LVar " .+ gshowsPrec 11 v+ showsPrec p (App fun args)+ = showParen (p>10) $+ showString "App " .+ showsPrec 11 fun .+ showChar ' ' .+ showsPrec 11 args+ showsPrec p (Const val) = showsPrec p val+ showsPrec p (AsArray fun)+ = showParen (p>10) $+ showString "AsArray " .+ showsPrec 11 fun+ showsPrec p (Quantification q args body)+ = showParen (p>10) $+ showsPrec 11 q .+ showChar ' ' .+ showsPrec 11 args .+ showChar ' ' .+ gshowsPrec 11 body+ showsPrec p (Let args body)+ = showParen (p>10) $+ showString "Let " .+ showListWith id (runIdentity $ List.toList+ (\(LetBinding v e)+ -> return $ (gshowsPrec 10 v) . showChar '=' . (gshowsPrec 10 e)+ ) args) .+ showChar ' ' .+ gshowsPrec 10 body++instance (GShow v,GShow qv,GShow fun,GShow fv,GShow lv,GShow e)+ => GShow (Expression v qv fun fv lv e) where+ gshowsPrec = showsPrec++instance (GShow fun)+ => Show (Function fun sig) where+ showsPrec p (Fun x) = gshowsPrec p x+ showsPrec _ (Eq _ _) = showString "Eq"+ showsPrec _ (Distinct _ _) = showString "Distinct"+ showsPrec p (Map _ x) = showParen (p>10) $+ showString "Map " .+ showsPrec 11 x+ showsPrec p (Ord tp op) = showParen (p>10) $+ showString "Ord " .+ showsPrec 11 tp .+ showChar ' ' .+ showsPrec 11 op+ showsPrec p (Arith tp op _) = showParen (p>10) $+ showString "Arith " .+ showsPrec 11 tp .+ showChar ' ' .+ showsPrec 11 op+ showsPrec p (ArithIntBin op) = showParen (p>10) $+ showString "ArithIntBin " .+ showsPrec 11 op+ showsPrec p Divide = showString "Divide"+ showsPrec p (Abs tp) = showParen (p>10) $+ showString "Abs " .+ showsPrec 11 tp+ showsPrec _ Not = showString "Not"+ showsPrec p (Logic op _) = showParen (p>10) $+ showString "Logic " .+ showsPrec 11 op+ showsPrec _ ToReal = showString "ToReal"+ showsPrec _ ToInt = showString "ToInt"+ showsPrec _ (ITE _) = showString "ITE"+ showsPrec p (BVComp op _) = showParen (p>10) $+ showString "BVComp " .+ showsPrec 11 op+ showsPrec p (BVBin op _) = showParen (p>10) $+ showString "BVBin " .+ showsPrec 11 op+ showsPrec p (BVUn op _) = showParen (p>10) $+ showString "BVUn " .+ showsPrec 11 op+ showsPrec _ (Select _ _) = showString "Select"+ showsPrec _ (Store _ _) = showString "Store"+ showsPrec _ (ConstArray _ _) = showString "ConstArray"+ showsPrec _ (Concat _ _) = showString "Concat"+ showsPrec p (Extract bw start len)+ = showParen (p>10) $+ showString "Extract " .+ showsPrec 11 bw .+ showChar ' ' .+ showsPrec 11 start .+ showChar ' ' .+ showsPrec 11 len+ showsPrec p (Constructor _ _ con) = showParen (p>10) $+ showString "Constructor " .+ showString (constrName con)+ showsPrec p (Test _ _ con) = showParen (p>10) $+ showString "Test " .+ showString (constrName con)+ showsPrec p (Field _ _ x) = showParen (p>10) $+ showString "Field " .+ showString (fieldName x)+ showsPrec p (Divisible x) = showParen (p>10) $+ showString "Divisible " .+ showsPrec 11 x++data RenderMode = SMTRendering deriving (Eq,Ord,Show)++renderExprDefault :: (GetType qv,GShow v,GShow qv,GShow fun,GShow fv,GShow lv,GShow e)+ => RenderMode+ -> Expression v qv fun fv lv e tp+ -> ShowS+renderExprDefault m+ = renderExpr m (gshowsPrec 11) (gshowsPrec 11) (gshowsPrec 11)+ (gshowsPrec 11) (gshowsPrec 11) (gshowsPrec 11)++renderExpr :: (GetType qv) => RenderMode+ -> (forall tp. v tp -> ShowS)+ -> (forall tp. qv tp -> ShowS)+ -> (forall arg res. fun '(arg,res) -> ShowS)+ -> (forall tp. fv tp -> ShowS)+ -> (forall tp. lv tp -> ShowS)+ -> (forall tp. e tp -> ShowS)+ -> Expression v qv fun fv lv e tp+ -> ShowS+renderExpr _ f _ _ _ _ _ (Var x) = f x+renderExpr _ _ f _ _ _ _ (QVar x) = f x+renderExpr _ _ _ _ f _ _ (FVar x) = f x+renderExpr _ _ _ _ _ f _ (LVar x) = f x+renderExpr SMTRendering _ _ f _ _ i (App fun args)+ = showChar '(' .+ renderFunction SMTRendering f fun .+ renderArgs i args .+ showChar ')'+ where+ renderArgs :: (forall tp. e tp -> ShowS) -> List e tps -> ShowS+ renderArgs f Nil = id+ renderArgs f (x ::: xs) = showChar ' ' . f x . renderArgs f xs+renderExpr m _ _ _ _ _ _ (Const val) = renderValue m val+renderExpr SMTRendering _ _ f _ _ _ (AsArray fun)+ = showString "(_ as-array " .+ renderFunction SMTRendering f fun .+ showChar ')'+renderExpr SMTRendering _ f _ _ _ g (Quantification q args body)+ = showChar '(' .+ showString (case q of+ Forall -> "forall"+ Exists -> "exists") .+ showString " (" . renderArgs f args . showString ") " . g body . showChar ')'+ where+ renderArgs :: GetType qv => (forall tp. qv tp -> ShowS)+ -> List qv tps -> ShowS+ renderArgs _ Nil = id+ renderArgs f (x ::: xs) = showChar '(' .+ f x . showChar ' ' .+ renderType SMTRendering (getType x) .+ showChar ')' .+ (case xs of+ Nil -> id+ _ -> showChar ' ' . renderArgs f xs)+renderExpr SMTRendering _ _ _ _ f g (Let args body)+ = showString "(let (" . renderArgs f g args . showString ") " . g body . showChar ')'+ where+ renderArgs :: (forall tp. lv tp -> ShowS) -> (forall tp. e tp -> ShowS)+ -> List (LetBinding lv e) args+ -> ShowS+ renderArgs _ _ Nil = id+ renderArgs f g (x ::: xs)+ = showChar '(' .+ f (letVar x) . showChar ' ' .+ g (letExpr x) . showChar ')' .+ (case xs of+ Nil -> id+ _ -> showChar ' ' . renderArgs f g xs)++renderValue :: RenderMode -> Value tp -> ShowS+renderValue SMTRendering (BoolValue v) = if v then showString "true" else showString "false"+renderValue SMTRendering (IntValue v)+ = if v>=0 then showsPrec 0 v+ else showString "(- " .+ showsPrec 0 (negate v) .+ showChar ')'+renderValue SMTRendering (RealValue v)+ = showString "(/ " . n . showChar ' ' . d . showChar ')'+ where+ n = if numerator v >= 0+ then showsPrec 0 (numerator v)+ else showString "(- " . showsPrec 0 (negate $ numerator v) . showChar ')'+ d = showsPrec 0 (denominator v)+renderValue SMTRendering (BitVecValue n bw)+ = showString "(_ bv" .+ showsPrec 0 n .+ showChar ' ' .+ showsPrec 0 (bwSize bw) .+ showChar ')'+renderValue SMTRendering (ConstrValue par con Nil) = showString (constrName con)+renderValue SMTRendering (ConstrValue par con xs)+ = showChar '(' . showString (constrName con) . renderValues xs . showChar ')'+ where+ renderValues :: List Value arg -> ShowS+ renderValues Nil = id+ renderValues (x ::: xs) = showChar ' ' . renderValue SMTRendering x . renderValues xs++renderFunction :: RenderMode+ -> (forall arg res. fun '(arg,res) -> ShowS)+ -> Function fun '(arg,res)+ -> ShowS+renderFunction _ f (Fun x) = f x+renderFunction SMTRendering _ (Eq _ _) = showChar '='+renderFunction SMTRendering _ (Distinct _ _) = showString "distinct"+renderFunction SMTRendering f (Map _ fun)+ = showString "(map " .+ renderFunction SMTRendering f fun .+ showChar ')'+renderFunction SMTRendering _ (Ord _ Ge) = showString ">="+renderFunction SMTRendering _ (Ord _ Gt) = showChar '>'+renderFunction SMTRendering _ (Ord _ Le) = showString "<="+renderFunction SMTRendering _ (Ord _ Lt) = showString "<"+renderFunction SMTRendering _ (Arith _ Plus _) = showChar '+'+renderFunction SMTRendering _ (Arith _ Mult _) = showChar '*'+renderFunction SMTRendering _ (Arith _ Minus _) = showChar '-'+renderFunction SMTRendering _ (ArithIntBin Div) = showString "div"+renderFunction SMTRendering _ (ArithIntBin Mod) = showString "mod"+renderFunction SMTRendering _ (ArithIntBin Rem) = showString "rem"+renderFunction SMTRendering _ Divide = showChar '/'+renderFunction SMTRendering _ (Abs _) = showString "abs"+renderFunction SMTRendering _ Not = showString "not"+renderFunction SMTRendering _ (Logic And _) = showString "and"+renderFunction SMTRendering _ (Logic Or _) = showString "or"+renderFunction SMTRendering _ (Logic XOr _) = showString "xor"+renderFunction SMTRendering _ (Logic Implies _) = showString "=>"+renderFunction SMTRendering _ ToReal = showString "to_real"+renderFunction SMTRendering _ ToInt = showString "to_int"+renderFunction SMTRendering _ (ITE _) = showString "ite"+renderFunction SMTRendering _ (BVComp op _) = showString $ case op of+ BVULE -> "bvule"+ BVULT -> "bvult"+ BVUGE -> "bvuge"+ BVUGT -> "bvugt"+ BVSLE -> "bvsle"+ BVSLT -> "bvslt"+ BVSGE -> "bvsge"+ BVSGT -> "bvsgt"+renderFunction SMTRendering _ (BVBin op _) = showString $ case op of+ BVAdd -> "bvadd"+ BVSub -> "bvsub"+ BVMul -> "bvmul"+ BVURem -> "bvurem"+ BVSRem -> "bvsrem"+ BVUDiv -> "bvudiv"+ BVSDiv -> "bvsdiv"+ BVSHL -> "bvshl"+ BVLSHR -> "bvshr"+ BVASHR -> "bvashr"+ BVXor -> "bvxor"+ BVAnd -> "bvand"+ BVOr -> "bvor"+renderFunction SMTRendering _ (BVUn op _) = showString $ case op of+ BVNot -> "bvnot"+ BVNeg -> "bvneg"+renderFunction SMTRendering _ (Select _ _) = showString "select"+renderFunction SMTRendering _ (Store _ _) = showString "store"+renderFunction SMTRendering _ (ConstArray idx el)+ = showString "(as const " .+ renderType SMTRendering (ArrayRepr idx el) .+ showChar ')'+renderFunction SMTRendering _ (Concat _ _) = showString "concat"+renderFunction SMTRendering _ (Extract _ start len)+ = showString "(_ extract " .+ showString (show $ start'+len'-1) .+ showChar ' ' .+ showString (show start') .+ showChar ')'+ where+ start' = bwSize start+ len' = bwSize len+renderFunction SMTRendering _ (Constructor dt par con)+ | determines dt con = showString (constrName con)+ | otherwise = showString "(as " .+ showString (constrName con) .+ renderType SMTRendering (DataRepr dt par) .+ showChar ')'+renderFunction SMTRendering _ (Test _ _ con)+ = showString "is-" . showString (constrName con)+renderFunction SMTRendering _ (Field _ _ field) = showString (fieldName field)+renderFunction SMTRendering _ (Divisible n) = showString "(_ divisible " .+ showsPrec 10 n .+ showChar ')'++renderType :: RenderMode -> Repr tp -> ShowS+renderType SMTRendering BoolRepr = showString "Bool"+renderType SMTRendering IntRepr = showString "Int"+renderType SMTRendering RealRepr = showString "Real"+renderType SMTRendering (BitVecRepr bw) = showString "(BitVec " .+ showString (show $ bwSize bw) .+ showChar ')'+renderType SMTRendering (ArrayRepr idx el) = showString "(Array (" .+ renderTypes idx .+ showString ") " .+ renderType SMTRendering el .+ showChar ')'+renderType _ (DataRepr dt Nil) = showString (datatypeName dt)+renderType SMTRendering (DataRepr dt par)+ = showChar '(' .+ showString (datatypeName dt) .+ showChar ' ' .+ renderTypes par .+ showChar ')'++renderTypes :: List Repr tps -> ShowS+renderTypes Nil = id+renderTypes (tp ::: Nil) = renderType SMTRendering tp+renderTypes (tp ::: tps) = renderType SMTRendering tp .+ showChar ' ' .+ renderTypes tps+ +instance GShow fun => GShow (Function fun) where+ gshowsPrec = showsPrec++instance (GEq v,GEq e) => GEq (LetBinding v e) where+ geq (LetBinding v1 e1) (LetBinding v2 e2) = do+ Refl <- geq v1 v2+ geq e1 e2++instance (GCompare v,GCompare e) => GCompare (LetBinding v e) where+ gcompare (LetBinding v1 e1) (LetBinding v2 e2) = case gcompare v1 v2 of+ GEQ -> gcompare e1 e2+ r -> r++instance (GEq v,GEq qv,GEq fun,GEq fv,GEq lv,GEq e)+ => GEq (Expression v qv fun fv lv e) where+ geq (Var v1) (Var v2) = geq v1 v2+ geq (QVar v1) (QVar v2) = geq v1 v2+ geq (FVar v1) (FVar v2) = geq v1 v2+ geq (LVar v1) (LVar v2) = geq v1 v2+ geq (App f1 arg1) (App f2 arg2) = do+ Refl <- geq f1 f2+ Refl <- geq arg1 arg2+ return Refl+ geq (Const x) (Const y) = geq x y+ geq (AsArray f1) (AsArray f2) = do+ Refl <- geq f1 f2+ return Refl+ geq (Quantification q1 arg1 body1) (Quantification q2 arg2 body2)+ | q1==q2 = do+ Refl <- geq arg1 arg2+ geq body1 body2+ | otherwise = Nothing+ geq (Let bnd1 body1) (Let bnd2 body2) = do+ Refl <- geq bnd1 bnd2+ geq body1 body2+ geq _ _ = Nothing++instance (GEq v,GEq qv,GEq fun,GEq fv,GEq lv,GEq e)+ => Eq (Expression v qv fun fv lv e t) where+ (==) = defaultEq++instance (GCompare v,GCompare qv,GCompare fun,GCompare fv,GCompare lv,GCompare e)+ => GCompare (Expression v qv fun fv lv e) where+ gcompare (Var v1) (Var v2) = gcompare v1 v2+ gcompare (Var _) _ = GLT+ gcompare _ (Var _) = GGT+ gcompare (QVar v1) (QVar v2) = gcompare v1 v2+ gcompare (QVar _) _ = GLT+ gcompare _ (QVar _) = GGT+ gcompare (FVar v1) (FVar v2) = gcompare v1 v2+ gcompare (FVar _) _ = GLT+ gcompare _ (FVar _) = GGT+ gcompare (LVar v1) (LVar v2) = gcompare v1 v2+ gcompare (LVar _) _ = GLT+ gcompare _ (LVar _) = GGT+ gcompare (App f1 arg1) (App f2 arg2) = case gcompare f1 f2 of+ GEQ -> case gcompare arg1 arg2 of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT+ GLT -> GLT+ GGT -> GGT+ gcompare (App _ _) _ = GLT+ gcompare _ (App _ _) = GGT+ gcompare (Const v1) (Const v2) = gcompare v1 v2+ gcompare (Const _) _ = GLT+ gcompare _ (Const _) = GGT+ gcompare (AsArray f1) (AsArray f2) = case gcompare f1 f2 of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT+ gcompare (AsArray _) _ = GLT+ gcompare _ (AsArray _) = GGT+ gcompare (Quantification q1 arg1 body1) (Quantification q2 arg2 body2) = case compare q1 q2 of+ LT -> GLT+ GT -> GGT+ EQ -> case gcompare arg1 arg2 of+ GEQ -> gcompare body1 body2+ GLT -> GLT+ GGT -> GGT+ gcompare (Quantification _ _ _) _ = GLT+ gcompare _ (Quantification _ _ _) = GGT+ gcompare (Let bnd1 body1) (Let bnd2 body2) = case gcompare bnd1 bnd2 of+ GEQ -> gcompare body1 body2+ GLT -> GLT+ GGT -> GGT++instance (GCompare v,GCompare qv,GCompare fun,GCompare fv,GCompare lv,GCompare e)+ => Ord (Expression v qv fun fv lv e t) where+ compare = defaultCompare++instance GEq fun => GEq (Function fun) where+ geq (Fun f1) (Fun f2) = geq f1 f2+ geq (Eq tp1 n1) (Eq tp2 n2) = do+ Refl <- geq tp1 tp2+ Refl <- geq n1 n2+ return Refl+ geq (Distinct tp1 n1) (Distinct tp2 n2) = do+ Refl <- geq tp1 tp2+ Refl <- geq n1 n2+ return Refl+ geq (Map i1 f1) (Map i2 f2) = do+ Refl <- geq f1 f2+ Refl <- geq i1 i2+ return Refl+ geq (Ord tp1 o1) (Ord tp2 o2) = do+ Refl <- geq tp1 tp2+ if o1==o2 then return Refl else Nothing+ geq (Arith tp1 o1 n1) (Arith tp2 o2 n2) = do+ Refl <- geq tp1 tp2+ if o1==o2+ then do+ Refl <- geq n1 n2+ return Refl+ else Nothing+ geq (ArithIntBin o1) (ArithIntBin o2) = if o1==o2 then Just Refl else Nothing+ geq Divide Divide = Just Refl+ geq (Abs tp1) (Abs tp2) = do+ Refl <- geq tp1 tp2+ return Refl+ geq Not Not = Just Refl+ geq (Logic o1 n1) (Logic o2 n2)+ = if o1==o2+ then do+ Refl <- geq n1 n2+ return Refl+ else Nothing+ geq ToReal ToReal = Just Refl+ geq ToInt ToInt = Just Refl+ geq (ITE t1) (ITE t2) = do+ Refl <- geq t1 t2+ return Refl+ geq (BVComp o1 bw1) (BVComp o2 bw2)+ = if o1==o2+ then do+ Refl <- geq bw1 bw2+ return Refl+ else Nothing+ geq (BVBin o1 bw1) (BVBin o2 bw2)+ = if o1==o2+ then do+ Refl <- geq bw1 bw2+ return Refl+ else Nothing+ geq (BVUn o1 bw1) (BVUn o2 bw2)+ = if o1==o2+ then do+ Refl <- geq bw1 bw2+ return Refl+ else Nothing+ geq (Select i1 e1) (Select i2 e2) = do+ Refl <- geq i1 i2+ Refl <- geq e1 e2+ return Refl+ geq (Store i1 e1) (Store i2 e2) = do+ Refl <- geq i1 i2+ Refl <- geq e1 e2+ return Refl+ geq (ConstArray i1 e1) (ConstArray i2 e2) = do+ Refl <- geq i1 i2+ Refl <- geq e1 e2+ return Refl+ geq (Concat a1 b1) (Concat a2 b2) = do+ Refl <- geq a1 a2+ Refl <- geq b1 b2+ return Refl+ geq (Extract bw1 start1 len1) (Extract bw2 start2 len2) = do+ Refl <- geq bw1 bw2+ Refl <- geq start1 start2+ Refl <- geq len1 len2+ return Refl+ geq (Constructor d1 par1 (c1 :: Constr dt1 sig1)) (Constructor d2 par2 (c2 :: Constr dt2 sig2)) = do+ Refl <- datatypeEq d1 d2+ Refl <- geq par1 par2+ Refl <- geq c1 c2+ return Refl+ geq (Test d1 par1 (c1 :: Constr dt1 sig1)) (Test d2 par2 (c2 :: Constr dt2 sig2)) = do+ Refl <- datatypeEq d1 d2+ Refl <- geq par1 par2+ Refl <- geq c1 c2+ return Refl+ geq (Field d1 par1 (f1 :: Type.Field dt1 tp1))+ (Field d2 par2 (f2 :: Type.Field dt2 tp2)) = do+ Refl <- datatypeEq d1 d2+ Refl <- geq par1 par2+ Refl <- geq f1 f2+ return Refl+ geq (Divisible n1) (Divisible n2) = if n1==n2 then Just Refl else Nothing+ geq _ _ = Nothing++instance GCompare fun => GCompare (Function fun) where+ gcompare (Fun x) (Fun y) = gcompare x y+ gcompare (Fun _) _ = GLT+ gcompare _ (Fun _) = GGT+ gcompare (Eq t1 n1) (Eq t2 n2) = case gcompare t1 t2 of+ GEQ -> case gcompare n1 n2 of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT+ GLT -> GLT+ GGT -> GGT+ gcompare (Eq _ _) _ = GLT+ gcompare _ (Eq _ _) = GGT+ gcompare (Distinct t1 n1) (Distinct t2 n2) = case gcompare t1 t2 of+ GEQ -> case gcompare n1 n2 of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT+ GLT -> GLT+ GGT -> GGT+ gcompare (Distinct _ _) _ = GLT+ gcompare _ (Distinct _ _) = GGT+ gcompare (Map i1 f1) (Map i2 f2) = case gcompare f1 f2 of+ GEQ -> case gcompare i1 i2 of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT+ GLT -> GLT+ GGT -> GGT+ gcompare (Map _ _) _ = GLT+ gcompare _ (Map _ _) = GGT+ gcompare (Ord tp1 o1) (Ord tp2 o2) = case gcompare tp1 tp2 of+ GEQ -> case compare o1 o2 of+ EQ -> GEQ+ LT -> GLT+ GT -> GGT+ GLT -> GLT+ GGT -> GGT+ gcompare (Ord _ _) _ = GLT+ gcompare _ (Ord _ _) = GGT+ gcompare (Arith tp1 o1 n1) (Arith tp2 o2 n2) = case gcompare tp1 tp2 of+ GEQ -> case compare o1 o2 of+ EQ -> case gcompare n1 n2 of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT+ LT -> GLT+ GT -> GGT+ GLT -> GLT+ GGT -> GGT+ gcompare (Arith _ _ _) _ = GLT+ gcompare _ (Arith _ _ _) = GGT+ gcompare (ArithIntBin o1) (ArithIntBin o2) = case compare o1 o2 of+ EQ -> GEQ+ LT -> GLT+ GT -> GGT+ gcompare (ArithIntBin _) _ = GLT+ gcompare _ (ArithIntBin _) = GGT+ gcompare Divide Divide = GEQ+ gcompare Divide _ = GLT+ gcompare _ Divide = GGT+ gcompare (Abs tp1) (Abs tp2) = case gcompare tp1 tp2 of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT+ gcompare (Abs _) _ = GLT+ gcompare _ (Abs _) = GGT+ gcompare Not Not = GEQ+ gcompare Not _ = GLT+ gcompare _ Not = GGT+ gcompare (Logic o1 n1) (Logic o2 n2) = case compare o1 o2 of+ EQ -> case gcompare n1 n2 of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT+ LT -> GLT+ GT -> GGT+ gcompare (Logic _ _) _ = GLT+ gcompare _ (Logic _ _) = GGT+ gcompare ToReal ToReal = GEQ+ gcompare ToReal _ = GLT+ gcompare _ ToReal = GGT+ gcompare ToInt ToInt = GEQ+ gcompare ToInt _ = GLT+ gcompare _ ToInt = GGT+ gcompare (ITE t1) (ITE t2) = case gcompare t1 t2 of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT+ gcompare (ITE _) _ = GLT+ gcompare _ (ITE _) = GGT+ gcompare (BVComp o1 bw1) (BVComp o2 bw2) = case compare o1 o2 of+ EQ -> case gcompare bw1 bw2 of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT+ LT -> GLT+ GT -> GGT+ gcompare (BVComp _ _) _ = GLT+ gcompare _ (BVComp _ _) = GGT+ gcompare (BVBin o1 bw1) (BVBin o2 bw2) = case compare o1 o2 of+ EQ -> case gcompare bw1 bw2 of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT+ LT -> GLT+ GT -> GGT+ gcompare (BVBin _ _) _ = GLT+ gcompare _ (BVBin _ _) = GGT+ gcompare (BVUn o1 bw1) (BVUn o2 bw2) = case compare o1 o2 of+ EQ -> case gcompare bw1 bw2 of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT+ LT -> GLT+ GT -> GGT+ gcompare (BVUn _ _) _ = GLT+ gcompare _ (BVUn _ _) = GGT+ gcompare (Select i1 e1) (Select i2 e2) = case gcompare i1 i2 of+ GEQ -> case gcompare e1 e2 of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT+ GLT -> GLT+ GGT -> GGT+ gcompare (Select _ _) _ = GLT+ gcompare _ (Select _ _) = GGT+ gcompare (Store i1 e1) (Store i2 e2) = case gcompare i1 i2 of+ GEQ -> case gcompare e1 e2 of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT+ GLT -> GLT+ GGT -> GGT+ gcompare (Store _ _) _ = GLT+ gcompare _ (Store _ _) = GGT+ gcompare (ConstArray i1 e1) (ConstArray i2 e2) = case gcompare i1 i2 of+ GEQ -> case gcompare e1 e2 of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT+ GLT -> GLT+ GGT -> GGT+ gcompare (ConstArray _ _) _ = GLT+ gcompare _ (ConstArray _ _) = GGT+ gcompare (Concat a1 b1) (Concat a2 b2) = case gcompare a1 a2 of+ GEQ -> case gcompare b1 b2 of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT+ GLT -> GLT+ GGT -> GGT+ gcompare (Concat _ _) _ = GLT+ gcompare _ (Concat _ _) = GGT+ gcompare (Extract bw1 start1 len1) (Extract bw2 start2 len2)+ = case gcompare bw1 bw2 of+ GEQ -> case gcompare start1 start2 of+ GEQ -> case gcompare len1 len2 of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT+ GLT -> GLT+ GGT -> GGT+ GLT -> GLT+ GGT -> GGT+ gcompare (Extract _ _ _) _ = GLT+ gcompare _ (Extract _ _ _) = GGT+ gcompare (Constructor d1 par1 c1) (Constructor d2 par2 c2)+ = case datatypeCompare d1 d2 of+ GEQ -> case gcompare par1 par2 of+ GEQ -> case gcompare c1 c2 of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT+ GLT -> GLT+ GGT -> GGT+ GLT -> GLT+ GGT -> GGT+ gcompare (Constructor _ _ _) _ = GLT+ gcompare _ (Constructor _ _ _) = GGT+ gcompare (Test d1 par1 c1) (Test d2 par2 c2)+ = case datatypeCompare d1 d2 of+ GEQ -> case gcompare par1 par2 of+ GEQ -> case gcompare c1 c2 of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT+ GLT -> GLT+ GGT -> GGT+ GLT -> GLT+ GGT -> GGT+ gcompare (Test _ _ _) _ = GLT+ gcompare _ (Test _ _ _) = GGT+ gcompare (Field d1 par1 f1) (Field d2 par2 f2)+ = case datatypeCompare d1 d2 of+ GEQ -> case gcompare par1 par2 of+ GEQ -> case gcompare f1 f2 of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT+ GLT -> GLT+ GGT -> GGT+ GLT -> GLT+ GGT -> GGT+ gcompare (Field _ _ _) _ = GLT+ gcompare _ (Field _ _ _) = GGT+ gcompare (Divisible n1) (Divisible n2) = case compare n1 n2 of+ EQ -> GEQ+ LT -> GLT+ GT -> GGT++data NoVar (t::Type) = NoVar'+data NoFun (sig::([Type],Type)) = NoFun'+data NoCon (sig::([Type],*)) = NoCon'+data NoField (sig::(*,Type)) = NoField'++instance GEq NoVar where+ geq _ _ = error "geq for NoVar"++instance GEq NoFun where+ geq _ _ = error "geq for NoFun"++instance GEq NoCon where+ geq _ _ = error "geq for NoCon"++instance GEq NoField where+ geq _ _ = error "geq for NoField"++instance GCompare NoVar where+ gcompare _ _ = error "gcompare for NoVar"++instance GCompare NoFun where+ gcompare _ _ = error "gcompare for NoFun"++instance GCompare NoCon where+ gcompare _ _ = error "gcompare for NoCon"++instance GCompare NoField where+ gcompare _ _ = error "gcompare for NoField"++instance Eq (NoVar t) where+ (==) _ _ = error "== for NoVar"++instance Eq (NoFun t) where+ (==) _ _ = error "== for NoFun"++instance Eq (NoCon t) where+ (==) _ _ = error "== for NoCon"++instance Eq (NoField t) where+ (==) _ _ = error "== for NoField"++instance Ord (NoVar t) where+ compare _ _ = error "compare for NoVar"++instance Ord (NoFun t) where+ compare _ _ = error "compare for NoFun"++instance Ord (NoCon t) where+ compare _ _ = error "compare for NoCon"++instance Ord (NoField t) where+ compare _ _ = error "compare for NoField"++instance Show (NoVar t) where+ showsPrec _ _ = showString "NoVar"++instance GShow NoVar where+ gshowsPrec = showsPrec++instance Show (NoFun t) where+ showsPrec _ _ = showString "NoFun"++instance GShow NoFun where+ gshowsPrec = showsPrec++instance Show (NoCon t) where+ showsPrec _ _ = showString "NoCon"++instance GShow NoCon where+ gshowsPrec = showsPrec++instance Show (NoField t) where+ showsPrec _ _ = showString "NoVar"++instance GShow NoField where+ gshowsPrec = showsPrec++instance GetType NoVar where+ getType _ = error "getType called on NoVar."++instance GetFunType NoFun where+ getFunType _ = error "getFunType called on NoFun."++instance (GetType v,GetType qv,GetFunType fun,GetType fv,GetType lv,GetType e)+ => GetType (Expression v qv fun fv lv e) where+ getType = runIdentity . expressionType+ (return.getType) (return.getType) (return.getFunType)+ (return.getType) (return.getType) (return.getType)++instance (GetFunType fun)+ => GetFunType (Function fun) where+ getFunType = runIdentity . functionType (return.getFunType)
− Language/SMTLib2/Internals/Instances.hs
@@ -1,1658 +0,0 @@-{- | Implements various instance declarations for 'Language.SMTLib2.SMTType',- 'Language.SMTLib2.SMTValue', etc. -}-{-# LANGUAGE FlexibleInstances,OverloadedStrings,MultiParamTypeClasses,RankNTypes,TypeFamilies,GeneralizedNewtypeDeriving,DeriveDataTypeable,GADTs,FlexibleContexts,CPP,ScopedTypeVariables,TypeOperators #-}-module Language.SMTLib2.Internals.Instances where--import Language.SMTLib2.Internals-import Language.SMTLib2.Internals.Operators-import Data.Ratio-import Data.Typeable-import Data.List (genericReplicate,zip4,zip5,zip6,genericIndex)-#ifdef SMTLIB2_WITH_CONSTRAINTS-import Data.Constraint-import Data.Proxy-#endif-import Data.Fix-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe (fromJust)-import Data.Traversable (mapM)-import Data.Foldable (foldlM)-import Text.Show-import Data.Functor.Identity-import Prelude hiding (mapM)--valueToHaskell :: DataTypeInfo- -> (forall t. SMTType t => [ProxyArg] -> t -> SMTAnnotation t -> r)- -> Maybe Sort- -> Value- -> r-valueToHaskell _ f _ (BoolValue v) = f [] v ()-valueToHaskell _ f _ (IntValue v) = f [] v ()-valueToHaskell _ f _ (RealValue v) = f [] v ()-valueToHaskell _ f (Just (Fix (BVSort { bvSortUntyped = True }))) (BVValue { bvValueWidth = w- , bvValueValue = v })- = f [] (BitVector v::BitVector BVUntyped) w-valueToHaskell _ f _ (BVValue { bvValueWidth = w- , bvValueValue = v })- = reifyNat w (\(_::Proxy tp) -> f [] (BitVector v::BitVector (BVTyped tp)) ())-valueToHaskell dtInfo f sort (ConstrValue name args sort')- = case Map.lookup name (constructors dtInfo) of- Just (con,dt,struct)- -> let sort'' = case sort of- Just (Fix (NamedSort name args)) -> Just (name,args)- Nothing -> sort'- argPrx = case sort'' of- Just (_,sort''') -> fmap (\s -> Just $ withSort dtInfo s ProxyArg) sort'''- Nothing -> genericReplicate (argCount struct) Nothing- sorts' = fmap (\field -> argumentSortToSort- (\i -> case sort'' of- Nothing -> Nothing- Just (_,sort''') -> Just $ sort''' `genericIndex` i)- (fieldSort field)- ) (conFields con)- rargs :: [AnyValue]- rargs = fmap (\(val,s) -> valueToHaskell dtInfo AnyValue s val) (zip args sorts')- in construct con argPrx rargs f---- | Reconstruct the type annotation for a given SMT expression.-extractAnnotation :: SMTExpr a -> SMTAnnotation a-extractAnnotation (Var _ ann) = ann-extractAnnotation (QVar _ _ ann) = ann-extractAnnotation (FunArg _ ann) = ann-extractAnnotation (Const _ ann) = ann-extractAnnotation (AsArray f arg) = (arg,inferResAnnotation f arg)-extractAnnotation (Forall _ _ _) = ()-extractAnnotation (Exists _ _ _) = ()-extractAnnotation (Let _ _ f) = extractAnnotation f-extractAnnotation (Named x _) = extractAnnotation x-extractAnnotation (App f arg) = inferResAnnotation f (extractArgAnnotation arg)-extractAnnotation (InternalObj _ ann) = ann-extractAnnotation (UntypedExpr (expr::SMTExpr t)) = ProxyArg (undefined::t) (extractAnnotation expr)-extractAnnotation (UntypedExprValue (expr::SMTExpr t)) = ProxyArgValue (undefined::t) (extractAnnotation expr)--inferResAnnotation :: SMTFunction arg res -> ArgAnnotation arg -> SMTAnnotation res-inferResAnnotation SMTEq _ = ()-inferResAnnotation x@(SMTMap f) ann- = withUndef f x (\ua ui -> let (i_ann,a_ann) = inferLiftedAnnotation ua ui ann- in (i_ann,inferResAnnotation f a_ann))- where- withUndef :: SMTFunction arg res -> SMTFunction (Lifted arg i) (SMTArray i res) -> (arg -> i -> b) -> b- withUndef _ _ f' = f' undefined undefined-inferResAnnotation (SMTFun _ ann) _ = ann-inferResAnnotation (SMTBuiltIn _ ann) _ = ann-inferResAnnotation (SMTOrd _) _ = ()-inferResAnnotation (SMTArith _) ~(ann:_) = ann-inferResAnnotation SMTMinus ~(ann,_) = ann-inferResAnnotation (SMTIntArith _) ~(ann,_) = ann-inferResAnnotation SMTDivide ~(ann,_) = ann-inferResAnnotation SMTNeg ann = ann-inferResAnnotation SMTAbs ann = ann-inferResAnnotation SMTNot _ = ()-inferResAnnotation (SMTLogic _) _ = ()-inferResAnnotation SMTDistinct _ = ()-inferResAnnotation SMTToReal _ = ()-inferResAnnotation SMTToInt _ = ()-inferResAnnotation SMTITE ~(_,ann,_) = ann-inferResAnnotation (SMTBVComp _) _ = ()-inferResAnnotation (SMTBVBin _) ~(ann,_) = ann-inferResAnnotation (SMTBVUn _) ann = ann-inferResAnnotation SMTSelect ~(~(_,ann),_) = ann-inferResAnnotation SMTStore ~(ann,_,_) = ann-inferResAnnotation (SMTConstArray i_ann) v_ann = (i_ann,v_ann)-inferResAnnotation x@SMTConcat ~(ann1,ann2)- = withUndef x $ \u1 u2 -> concatAnnotation u1 u2 ann1 ann2- where- withUndef :: SMTFunction (SMTExpr (BitVector a),SMTExpr (BitVector b)) res- -> (a -> b -> c) -> c- withUndef _ f = f undefined undefined-inferResAnnotation x@(SMTExtract _ prLen) ann- = withUndef x $ \u1 u2 -> extractAnn u1 u2 (reflectNat prLen 0) ann- where- withUndef :: SMTFunction (SMTExpr (BitVector a)) (BitVector res)- -> (a -> res -> c) -> c- withUndef _ f = f undefined undefined-inferResAnnotation (SMTConstructor (Constructor prx dt con)) _- = case dataTypeGetUndefined dt prx (\_ ann' -> cast ann') of- Just ann' -> ann'-inferResAnnotation (SMTConTest _) _ = ()-inferResAnnotation (SMTFieldSel (Field prx dt _ f)) _- = dataTypeGetUndefined dt prx (\u _ -> case fieldGet f prx u (\_ ann -> cast ann) of- Just ann' -> ann')-inferResAnnotation (SMTDivisible _) _ = ()---- Untyped--entype :: (forall a. SMTType a => SMTExpr a -> b) -> SMTExpr Untyped -> b-entype f (Var i (ProxyArg (_::t) ann))- = f (Var i ann::SMTExpr t)-entype f (QVar lvl i (ProxyArg (_::t) ann))- = f (QVar lvl i ann::SMTExpr t)-entype f (FunArg i (ProxyArg (_::t) ann))- = f (FunArg i ann::SMTExpr t)-entype f (UntypedExpr x) = f x-entype f (InternalObj obj (ProxyArg (_::t) ann))- = f (InternalObj obj ann :: SMTExpr t)-entype f expr = error $ "Can't entype expression "++show expr--entypeValue :: (forall a. SMTValue a => SMTExpr a -> b) -> SMTExpr UntypedValue -> b-entypeValue f (Var i (ProxyArgValue (_::t) ann))- = f (Var i ann::SMTExpr t)-entypeValue f (QVar lvl i (ProxyArgValue (_::t) ann))- = f (QVar lvl i ann::SMTExpr t)-entypeValue f (FunArg i (ProxyArgValue (_::t) ann))- = f (FunArg i ann::SMTExpr t)-entypeValue f (Const (UntypedValue v) (ProxyArgValue (_::t) ann))- = case cast v of- Just rv -> f (Const (rv::t) ann)-entypeValue f (UntypedExprValue x) = f x-entypeValue f (InternalObj obj (ProxyArgValue (_::t) ann))- = f (InternalObj obj ann :: SMTExpr t)-entypeValue f expr = error $ "Can't entype expression "++show expr--{--entypeValueFunction :: (forall a. SMTValue a => SMTFunction arg a -> b)- -> SMTFunction arg UntypedValue- -> b-entypeValueFunction f (SMTFun i (ProxyArgValue (_::t) ann))- = f (SMTFun i ann::SMTFunction arg t)-}--castUntypedExpr :: SMTType t => SMTExpr Untyped -> SMTExpr t-castUntypedExpr = entype (\expr -> case cast expr of- Just r -> r- Nothing -> error $ "smtlib2: castUntypedExpr failed.")--castUntypedExprValue :: SMTType t => SMTExpr UntypedValue -> SMTExpr t-castUntypedExprValue- = entypeValue (\expr -> case cast expr of- Just r -> r- Nothing -> error $ "smtlib2: castUntypedExprValue failed.")--instance SMTType Untyped where- type SMTAnnotation Untyped = ProxyArg- getSort _ (ProxyArg u ann) = getSort u ann- asDataType _ (ProxyArg u ann) = asDataType u ann- asValueType _ (ProxyArg u ann) f = asValueType u ann f- getProxyArgs _ (ProxyArg u ann) = getProxyArgs u ann- additionalConstraints _ (ProxyArg u ann) = do- constr <- additionalConstraints u ann- return $ \(UntypedExpr x) -> case cast x of- Just x' -> constr x'- annotationFromSort _ sort = withSort emptyDataTypeInfo sort ProxyArg- defaultExpr (ProxyArg (_::t) ann) = UntypedExpr (defaultExpr ann :: SMTExpr t)--instance SMTType UntypedValue where- type SMTAnnotation UntypedValue = ProxyArgValue- getSort _ (ProxyArgValue u ann) = getSort u ann- asDataType _ (ProxyArgValue u ann) = asDataType u ann- asValueType _ (ProxyArgValue u ann) f = asValueType u ann f- getProxyArgs _ (ProxyArgValue u ann) = getProxyArgs u ann- additionalConstraints _ (ProxyArgValue u ann) = do- constr <- additionalConstraints u ann- return $ \(UntypedExprValue x) -> case cast x of- Just x' -> constr x'- annotationFromSort _ sort- = withSort emptyDataTypeInfo sort- (\u ann -> case asValueType u ann ProxyArgValue of- Just r -> r- Nothing -> error $ "annotationFromSort for non-value type "++show (typeOf u)++" used.")- defaultExpr (ProxyArgValue (_::t) ann)- = UntypedExprValue (defaultExpr ann :: SMTExpr t)--instance SMTValue UntypedValue where- unmangle = ComplexUnmangling $- \f st val (ProxyArgValue _ ann)- -> entypeValue- (\(expr'::SMTExpr t) -> case cast ann of- Just ann' -> do- (res,nst) <- f st expr' ann'- return (Just $ UntypedValue res,nst)- ) val- mangle = ComplexMangling (\(UntypedValue x) (ProxyArgValue (_::t) ann)- -> case cast x of- Just x' -> UntypedExprValue $ Const (x'::t) ann)---- Bool--instance SMTType Bool where- type SMTAnnotation Bool = ()- getSort _ _ = Fix BoolSort- annotationFromSort _ _ = ()- asValueType x ann f = Just $ f x ann- defaultExpr _ = Const False ()--instance SMTValue Bool where- unmangle = PrimitiveUnmangling (\val _ -> case val of- BoolValue v -> Just v- _ -> Nothing)- mangle = PrimitiveMangling (\v _ -> BoolValue v)---- Integer--instance SMTType Integer where- type SMTAnnotation Integer = ()- getSort _ _ = Fix IntSort- annotationFromSort _ _ = ()- asValueType x ann f = Just $ f x ann- defaultExpr _ = Const 0 ()--instance SMTValue Integer where- unmangle = PrimitiveUnmangling (\val _ -> case val of- IntValue v -> Just v- _ -> Nothing)- mangle = PrimitiveMangling (\v _ -> IntValue v)--instance SMTArith Integer--instance Num (SMTExpr Integer) where- fromInteger x = Const x ()- (+) x y = App (SMTArith Plus) [x,y]- (-) x y = App SMTMinus (x,y)- (*) x y = App (SMTArith Mult) [x,y]- negate x = App SMTNeg x- abs x = App SMTAbs x- signum x = App SMTITE (App (SMTOrd Ge) (x,Const 0 ()),Const 1 (),Const (-1) ())--instance SMTOrd Integer where- (.<.) x y = App (SMTOrd Lt) (x,y)- (.<=.) x y = App (SMTOrd Le) (x,y)- (.>.) x y = App (SMTOrd Gt) (x,y)- (.>=.) x y = App (SMTOrd Ge) (x,y)--instance Enum (SMTExpr Integer) where- succ x = x + 1- pred x = x - 1- toEnum x = Const (fromIntegral x) ()- fromEnum (Const x _) = fromIntegral x- fromEnum _ = error $ "smtlib2: Can't use fromEnum on non-constant SMTExpr (use getValue to extract values from the solver)"- enumFrom x = case x of- Const x' _ -> fmap (\i -> Const i ()) (enumFrom x')- _ -> x:[ x+(Const n ()) | n <- [1..] ]- enumFromThen x inc = case inc of- Const inc' _ -> case x of- Const x' _ -> fmap (\i -> Const i ()) (enumFromThen x' inc')- _ -> x:[ x + (Const (n*inc') ()) | n <- [1..]]- _ -> [ Prelude.foldl (+) x (genericReplicate n inc) | n <- [(0::Integer)..]]- enumFromThenTo (Const x _) (Const inc _) (Const lim _)- = fmap (\i -> Const i ()) (enumFromThenTo x inc lim)- enumFromThenTo _ _ _ = error $ "smtlib2: Can't use enumFromThenTo on non-constant SMTExprs"---- Real--instance SMTType (Ratio Integer) where- type SMTAnnotation (Ratio Integer) = ()- getSort _ _ = Fix RealSort- annotationFromSort _ _ = ()- asValueType x ann f = Just $ f x ann- defaultExpr _ = Const 0 ()--instance SMTValue (Ratio Integer) where- unmangle = PrimitiveUnmangling (\val _ -> case val of- RealValue v -> Just v- _ -> Nothing)- mangle = PrimitiveMangling (\v _ -> RealValue v)--instance SMTArith (Ratio Integer)--instance Num (SMTExpr (Ratio Integer)) where- fromInteger x = Const (fromInteger x) ()- (+) x y = App (SMTArith Plus) [x,y]- (-) x y = App SMTMinus (x,y)- (*) x y = App (SMTArith Mult) [x,y]- negate = App SMTNeg- abs x = App SMTITE (App (SMTOrd Ge) (x,Const 0 ()),x,App SMTNeg x)- signum x = App SMTITE (App (SMTOrd Ge) (x,Const 0 ()),Const 1 (),Const (-1) ())--instance Fractional (SMTExpr (Ratio Integer)) where- (/) x y = App SMTDivide (x,y)- fromRational x = Const x ()--instance SMTOrd (Ratio Integer) where- (.<.) x y = App (SMTOrd Lt) (x,y)- (.<=.) x y = App (SMTOrd Le) (x,y)- (.>.) x y = App (SMTOrd Gt) (x,y)- (.>=.) x y = App (SMTOrd Ge) (x,y)---- Arrays--instance (Args idx,SMTType val) => SMTType (SMTArray idx val) where- type SMTAnnotation (SMTArray idx val) = (ArgAnnotation idx,SMTAnnotation val)- getSort u (anni,annv) = Fix $ ArraySort (argSorts (getIdx u) anni) (getSort (getVal u) annv)- where- getIdx :: SMTArray i v -> i- getIdx _ = undefined- getVal :: SMTArray i v -> v- getVal _ = undefined- annotationFromSort u (Fix (ArraySort argSorts valSort)) = (argAnn,annotationFromSort (getVal u) valSort)- where- (argAnn,[]) = getArgAnnotation (getIdx u) argSorts- getIdx :: SMTArray i v -> i- getIdx _ = undefined- getVal :: SMTArray i v -> v- getVal _ = undefined- asValueType _ _ _ = Nothing- defaultExpr ~(anni,annv) = App (SMTConstArray anni) (defaultExpr annv)--instance (SMTType a) => Liftable (SMTExpr a) where- type Lifted (SMTExpr a) i = SMTExpr (SMTArray i a)- getLiftedArgumentAnn _ _ a_ann i_ann = (i_ann,a_ann)- inferLiftedAnnotation _ _ ~(i,a) = (i,a)-#ifdef SMTLIB2_WITH_CONSTRAINTS- getConstraint _ = Dict-#endif--instance (SMTType a) => Liftable [SMTExpr a] where- type Lifted [SMTExpr a] i = [SMTExpr (SMTArray i a)]- getLiftedArgumentAnn _ _ a_anns i_ann = fmap (\a_ann -> (i_ann,a_ann)) a_anns- inferLiftedAnnotation _ _ ~(~(i,x):xs) = (i,x:(fmap snd xs))-#ifdef SMTLIB2_WITH_CONSTRAINTS- getConstraint _ = Dict-#endif--instance (Liftable a,Liftable b)- => Liftable (a,b) where- type Lifted (a,b) i = (Lifted a i,Lifted b i)- getLiftedArgumentAnn ~(x,y) i (a_ann,b_ann) i_ann = (getLiftedArgumentAnn x i a_ann i_ann,- getLiftedArgumentAnn y i b_ann i_ann)- inferLiftedAnnotation ~(x,y) i ~(a_ann,b_ann) = let (ann_i,ann_a) = inferLiftedAnnotation x i a_ann- (_,ann_b) = inferLiftedAnnotation y i b_ann- in (ann_i,(ann_a,ann_b))-#ifdef SMTLIB2_WITH_CONSTRAINTS- getConstraint (_ :: p ((a,b),i)) = case getConstraint (Proxy :: Proxy (a,i)) of- Dict -> case getConstraint (Proxy :: Proxy (b,i)) of- Dict -> Dict-#endif--instance (Liftable a,Liftable b,Liftable c)- => Liftable (a,b,c) where- type Lifted (a,b,c) i = (Lifted a i,Lifted b i,Lifted c i)- getLiftedArgumentAnn ~(x1,x2,x3) i (ann1,ann2,ann3) i_ann- = (getLiftedArgumentAnn x1 i ann1 i_ann,- getLiftedArgumentAnn x2 i ann2 i_ann,- getLiftedArgumentAnn x3 i ann3 i_ann)- inferLiftedAnnotation ~(x1,x2,x3) i ~(ann1,ann2,ann3)- = let (i_ann,ann1') = inferLiftedAnnotation x1 i ann1- (_,ann2') = inferLiftedAnnotation x2 i ann2- (_,ann3') = inferLiftedAnnotation x3 i ann3- in (i_ann,(ann1',ann2',ann3'))-#ifdef SMTLIB2_WITH_CONSTRAINTS- getConstraint (_ :: p ((a,b,c),i)) = case getConstraint (Proxy :: Proxy (a,i)) of- Dict -> case getConstraint (Proxy :: Proxy (b,i)) of- Dict -> case getConstraint (Proxy :: Proxy (c,i)) of- Dict -> Dict-#endif--instance (Liftable a,Liftable b,Liftable c,Liftable d)- => Liftable (a,b,c,d) where- type Lifted (a,b,c,d) i = (Lifted a i,Lifted b i,Lifted c i,Lifted d i)- getLiftedArgumentAnn ~(x1,x2,x3,x4) i (ann1,ann2,ann3,ann4) i_ann- = (getLiftedArgumentAnn x1 i ann1 i_ann,- getLiftedArgumentAnn x2 i ann2 i_ann,- getLiftedArgumentAnn x3 i ann3 i_ann,- getLiftedArgumentAnn x4 i ann4 i_ann)- inferLiftedAnnotation ~(x1,x2,x3,x4) i ~(ann1,ann2,ann3,ann4)- = let (i_ann,ann1') = inferLiftedAnnotation x1 i ann1- (_,ann2') = inferLiftedAnnotation x2 i ann2- (_,ann3') = inferLiftedAnnotation x3 i ann3- (_,ann4') = inferLiftedAnnotation x4 i ann4- in (i_ann,(ann1',ann2',ann3',ann4'))-#ifdef SMTLIB2_WITH_CONSTRAINTS- getConstraint (_ :: p ((a,b,c,d),i)) = case getConstraint (Proxy :: Proxy (a,i)) of- Dict -> case getConstraint (Proxy :: Proxy (b,i)) of- Dict -> case getConstraint (Proxy :: Proxy (c,i)) of- Dict -> case getConstraint (Proxy :: Proxy (d,i)) of- Dict -> Dict-#endif--instance (Liftable a,Liftable b,Liftable c,Liftable d,Liftable e)- => Liftable (a,b,c,d,e) where- type Lifted (a,b,c,d,e) i = (Lifted a i,Lifted b i,Lifted c i,Lifted d i,Lifted e i)- getLiftedArgumentAnn ~(x1,x2,x3,x4,x5) i (ann1,ann2,ann3,ann4,ann5) i_ann- = (getLiftedArgumentAnn x1 i ann1 i_ann,- getLiftedArgumentAnn x2 i ann2 i_ann,- getLiftedArgumentAnn x3 i ann3 i_ann,- getLiftedArgumentAnn x4 i ann4 i_ann,- getLiftedArgumentAnn x5 i ann5 i_ann)- inferLiftedAnnotation ~(x1,x2,x3,x4,x5) i ~(ann1,ann2,ann3,ann4,ann5)- = let (i_ann,ann1') = inferLiftedAnnotation x1 i ann1- (_,ann2') = inferLiftedAnnotation x2 i ann2- (_,ann3') = inferLiftedAnnotation x3 i ann3- (_,ann4') = inferLiftedAnnotation x4 i ann4- (_,ann5') = inferLiftedAnnotation x5 i ann5- in (i_ann,(ann1',ann2',ann3',ann4',ann5'))-#ifdef SMTLIB2_WITH_CONSTRAINTS- getConstraint (_ :: p ((a,b,c,d,e),i)) = case getConstraint (Proxy :: Proxy (a,i)) of- Dict -> case getConstraint (Proxy :: Proxy (b,i)) of- Dict -> case getConstraint (Proxy :: Proxy (c,i)) of- Dict -> case getConstraint (Proxy :: Proxy (d,i)) of- Dict -> case getConstraint (Proxy :: Proxy (e,i)) of- Dict -> Dict-#endif--instance (Liftable a,Liftable b,Liftable c,Liftable d,Liftable e,Liftable f)- => Liftable (a,b,c,d,e,f) where- type Lifted (a,b,c,d,e,f) i = (Lifted a i,Lifted b i,Lifted c i,Lifted d i,Lifted e i,Lifted f i)- getLiftedArgumentAnn ~(x1,x2,x3,x4,x5,x6) i (ann1,ann2,ann3,ann4,ann5,ann6) i_ann- = (getLiftedArgumentAnn x1 i ann1 i_ann,- getLiftedArgumentAnn x2 i ann2 i_ann,- getLiftedArgumentAnn x3 i ann3 i_ann,- getLiftedArgumentAnn x4 i ann4 i_ann,- getLiftedArgumentAnn x5 i ann5 i_ann,- getLiftedArgumentAnn x6 i ann6 i_ann)- inferLiftedAnnotation ~(x1,x2,x3,x4,x5,x6) i ~(ann1,ann2,ann3,ann4,ann5,ann6)- = let (i_ann,ann1') = inferLiftedAnnotation x1 i ann1- (_,ann2') = inferLiftedAnnotation x2 i ann2- (_,ann3') = inferLiftedAnnotation x3 i ann3- (_,ann4') = inferLiftedAnnotation x4 i ann4- (_,ann5') = inferLiftedAnnotation x5 i ann5- (_,ann6') = inferLiftedAnnotation x6 i ann6- in (i_ann,(ann1',ann2',ann3',ann4',ann5',ann6'))-#ifdef SMTLIB2_WITH_CONSTRAINTS- getConstraint (_ :: p ((a,b,c,d,e,f),i)) = case getConstraint (Proxy :: Proxy (a,i)) of- Dict -> case getConstraint (Proxy :: Proxy (b,i)) of- Dict -> case getConstraint (Proxy :: Proxy (c,i)) of- Dict -> case getConstraint (Proxy :: Proxy (d,i)) of- Dict -> case getConstraint (Proxy :: Proxy (e,i)) of- Dict -> case getConstraint (Proxy :: Proxy (f,i)) of- Dict -> Dict-#endif--instance (TypeableNat n1,TypeableNat n2,TypeableNat (Add n1 n2))- => Concatable (BVTyped n1) (BVTyped n2) where- type ConcatResult (BVTyped n1) (BVTyped n2) = BVTyped (Add n1 n2)- concatAnnotation _ _ _ _ = ()--instance (TypeableNat n2) => Concatable BVUntyped (BVTyped n2) where- type ConcatResult BVUntyped (BVTyped n2) = BVUntyped- concatAnnotation _ (_::BVTyped n2) ann1 _- = ann1+(reflectNat (Proxy::Proxy n2) 0)--instance (TypeableNat n1) => Concatable (BVTyped n1) BVUntyped where- type ConcatResult (BVTyped n1) BVUntyped = BVUntyped- concatAnnotation (_::BVTyped n1) _ _ ann2- = (reflectNat (Proxy::Proxy n1) 0)+ann2--instance Concatable BVUntyped BVUntyped where- type ConcatResult BVUntyped BVUntyped = BVUntyped- concatAnnotation _ _ ann1 ann2 = ann1+ann2---- Arguments--instance (SMTType a) => Args (SMTExpr a) where- type ArgAnnotation (SMTExpr a) = SMTAnnotation a- foldExprs f = f- foldsExprs f = f- extractArgAnnotation = extractAnnotation- toArgs _ (x:xs) = do- r <- entype gcast x- return (r,xs)- toArgs _ [] = Nothing- fromArgs x = [UntypedExpr x]- getTypes (_::SMTExpr a) ann = [ProxyArg (undefined::a) ann]- getArgAnnotation u (s:rest) = (annotationFromSort (getUndef u) s,rest)- getArgAnnotation _ [] = error "smtlib2: To few sorts provided."--instance (Args a,Args b) => Args (a,b) where- type ArgAnnotation (a,b) = (ArgAnnotation a,ArgAnnotation b)- foldExprs f s ~(e1,e2) ~(ann1,ann2) = do- ~(s1,e1') <- foldExprs f s e1 ann1- ~(s2,e2') <- foldExprs f s1 e2 ann2- return (s2,(e1',e2'))- foldsExprs f s args ~(ann1,ann2) = do- ~(s1,e1,r1) <- foldsExprs f s (fmap (\(~(e1,_),b) -> (e1,b)) args) ann1- ~(s2,e2,r2) <- foldsExprs f s1 (fmap (\(~(_,e2),b) -> (e2,b)) args) ann2- return (s2,zip e1 e2,(r1,r2))- extractArgAnnotation ~(x,y) = (extractArgAnnotation x,- extractArgAnnotation y)- toArgs ~(ann1,ann2) x = do- (r1,x1) <- toArgs ann1 x- (r2,x2) <- toArgs ann2 x1- return ((r1,r2),x2)- fromArgs (x,y) = fromArgs x ++ fromArgs y- getTypes ~(x1,x2) (ann1,ann2) = getTypes x1 ann1 ++ getTypes x2 ann2- getArgAnnotation (_::(a1,a2)) sorts- = let (ann1,r1) = getArgAnnotation (undefined::a1) sorts- (ann2,r2) = getArgAnnotation (undefined::a2) r1- in ((ann1,ann2),r2)--instance (SMTValue a) => LiftArgs (SMTExpr a) where- type Unpacked (SMTExpr a) = a- liftArgs = Const- unliftArgs expr f = f expr--instance (LiftArgs a,LiftArgs b) => LiftArgs (a,b) where- type Unpacked (a,b) = (Unpacked a,Unpacked b)- liftArgs (x,y) ~(a1,a2) = (liftArgs x a1,liftArgs y a2)- unliftArgs (x,y) f = do- rx <- unliftArgs x f- ry <- unliftArgs y f- return (rx,ry)--instance (Args a,Args b,Args c) => Args (a,b,c) where- type ArgAnnotation (a,b,c) = (ArgAnnotation a,ArgAnnotation b,ArgAnnotation c)- foldExprs f s ~(e1,e2,e3) ~(ann1,ann2,ann3) = do- ~(s1,e1') <- foldExprs f s e1 ann1- ~(s2,e2') <- foldExprs f s1 e2 ann2- ~(s3,e3') <- foldExprs f s2 e3 ann3- return (s3,(e1',e2',e3'))- foldsExprs f s args ~(ann1,ann2,ann3) = do- ~(s1,e1,r1) <- foldsExprs f s (fmap (\(~(e1,_,_),b) -> (e1,b)) args) ann1- ~(s2,e2,r2) <- foldsExprs f s1 (fmap (\(~(_,e2,_),b) -> (e2,b)) args) ann2- ~(s3,e3,r3) <- foldsExprs f s2 (fmap (\(~(_,_,e3),b) -> (e3,b)) args) ann3- return (s3,zip3 e1 e2 e3,(r1,r2,r3))- extractArgAnnotation ~(e1,e2,e3)- = (extractArgAnnotation e1,- extractArgAnnotation e2,- extractArgAnnotation e3)- toArgs ~(ann1,ann2,ann3) x = do- (r1,x1) <- toArgs ann1 x- (r2,x2) <- toArgs ann2 x1- (r3,x3) <- toArgs ann3 x2- return ((r1,r2,r3),x3)- fromArgs (x1,x2,x3) = fromArgs x1 ++- fromArgs x2 ++- fromArgs x3- getArgAnnotation (_::(a1,a2,a3)) sorts- = let (ann1,r1) = getArgAnnotation (undefined::a1) sorts- (ann2,r2) = getArgAnnotation (undefined::a2) r1- (ann3,r3) = getArgAnnotation (undefined::a3) r2- in ((ann1,ann2,ann3),r3)- getTypes ~(x1,x2,x3) (ann1,ann2,ann3) = getTypes x1 ann1 ++ getTypes x2 ann2 ++ getTypes x3 ann3--instance (LiftArgs a,LiftArgs b,LiftArgs c) => LiftArgs (a,b,c) where- type Unpacked (a,b,c) = (Unpacked a,Unpacked b,Unpacked c)- liftArgs (x,y,z) ~(a1,a2,a3) = (liftArgs x a1,liftArgs y a2,liftArgs z a3)- unliftArgs (x,y,z) f = do- rx <- unliftArgs x f- ry <- unliftArgs y f- rz <- unliftArgs z f- return (rx,ry,rz)--instance (Args a,Args b,Args c,Args d) => Args (a,b,c,d) where- type ArgAnnotation (a,b,c,d) = (ArgAnnotation a,ArgAnnotation b,ArgAnnotation c,ArgAnnotation d)- foldExprs f s ~(e1,e2,e3,e4) ~(ann1,ann2,ann3,ann4) = do- ~(s1,e1') <- foldExprs f s e1 ann1- ~(s2,e2') <- foldExprs f s1 e2 ann2- ~(s3,e3') <- foldExprs f s2 e3 ann3- ~(s4,e4') <- foldExprs f s3 e4 ann4- return (s4,(e1',e2',e3',e4'))- foldsExprs f s args ~(ann1,ann2,ann3,ann4) = do- ~(s1,e1,r1) <- foldsExprs f s (fmap (\(~(e1,_,_,_),b) -> (e1,b)) args) ann1- ~(s2,e2,r2) <- foldsExprs f s1 (fmap (\(~(_,e2,_,_),b) -> (e2,b)) args) ann2- ~(s3,e3,r3) <- foldsExprs f s2 (fmap (\(~(_,_,e3,_),b) -> (e3,b)) args) ann3- ~(s4,e4,r4) <- foldsExprs f s3 (fmap (\(~(_,_,_,e4),b) -> (e4,b)) args) ann4- return (s4,zip4 e1 e2 e3 e4,(r1,r2,r3,r4))- extractArgAnnotation ~(e1,e2,e3,e4)- = (extractArgAnnotation e1,- extractArgAnnotation e2,- extractArgAnnotation e3,- extractArgAnnotation e4)- toArgs ~(ann1,ann2,ann3,ann4) x = do- (r1,x1) <- toArgs ann1 x- (r2,x2) <- toArgs ann2 x1- (r3,x3) <- toArgs ann3 x2- (r4,x4) <- toArgs ann4 x3- return ((r1,r2,r3,r4),x4)- fromArgs (x1,x2,x3,x4)- = fromArgs x1 ++- fromArgs x2 ++- fromArgs x3 ++- fromArgs x4- getArgAnnotation (_::(a1,a2,a3,a4)) sorts- = let (ann1,r1) = getArgAnnotation (undefined::a1) sorts- (ann2,r2) = getArgAnnotation (undefined::a2) r1- (ann3,r3) = getArgAnnotation (undefined::a3) r2- (ann4,r4) = getArgAnnotation (undefined::a4) r3- in ((ann1,ann2,ann3,ann4),r4)- getTypes ~(x1,x2,x3,x4) (ann1,ann2,ann3,ann4)- = getTypes x1 ann1 ++- getTypes x2 ann2 ++- getTypes x3 ann3 ++- getTypes x4 ann4--instance (LiftArgs a,LiftArgs b,LiftArgs c,LiftArgs d) => LiftArgs (a,b,c,d) where- type Unpacked (a,b,c,d) = (Unpacked a,Unpacked b,Unpacked c,Unpacked d)- liftArgs (x1,x2,x3,x4) ~(a1,a2,a3,a4) = (liftArgs x1 a1,liftArgs x2 a2,liftArgs x3 a3,liftArgs x4 a4)- unliftArgs (x1,x2,x3,x4) f = do- r1 <- unliftArgs x1 f- r2 <- unliftArgs x2 f- r3 <- unliftArgs x3 f- r4 <- unliftArgs x4 f- return (r1,r2,r3,r4)--instance (Args a,Args b,Args c,Args d,Args e) => Args (a,b,c,d,e) where- type ArgAnnotation (a,b,c,d,e) = (ArgAnnotation a,ArgAnnotation b,ArgAnnotation c,ArgAnnotation d,ArgAnnotation e)- foldExprs f s ~(e1,e2,e3,e4,e5) ~(ann1,ann2,ann3,ann4,ann5) = do- ~(s1,e1') <- foldExprs f s e1 ann1- ~(s2,e2') <- foldExprs f s1 e2 ann2- ~(s3,e3') <- foldExprs f s2 e3 ann3- ~(s4,e4') <- foldExprs f s3 e4 ann4- ~(s5,e5') <- foldExprs f s4 e5 ann5- return (s5,(e1',e2',e3',e4',e5'))- foldsExprs f s args ~(ann1,ann2,ann3,ann4,ann5) = do- ~(s1,e1,r1) <- foldsExprs f s (fmap (\(~(e1,_,_,_,_),b) -> (e1,b)) args) ann1- ~(s2,e2,r2) <- foldsExprs f s1 (fmap (\(~(_,e2,_,_,_),b) -> (e2,b)) args) ann2- ~(s3,e3,r3) <- foldsExprs f s2 (fmap (\(~(_,_,e3,_,_),b) -> (e3,b)) args) ann3- ~(s4,e4,r4) <- foldsExprs f s3 (fmap (\(~(_,_,_,e4,_),b) -> (e4,b)) args) ann4- ~(s5,e5,r5) <- foldsExprs f s4 (fmap (\(~(_,_,_,_,e5),b) -> (e5,b)) args) ann5- return (s5,zip5 e1 e2 e3 e4 e5,(r1,r2,r3,r4,r5))- extractArgAnnotation ~(e1,e2,e3,e4,e5)- = (extractArgAnnotation e1,- extractArgAnnotation e2,- extractArgAnnotation e3,- extractArgAnnotation e4,- extractArgAnnotation e5)- toArgs ~(ann1,ann2,ann3,ann4,ann5) x = do- (r1,x1) <- toArgs ann1 x- (r2,x2) <- toArgs ann2 x1- (r3,x3) <- toArgs ann3 x2- (r4,x4) <- toArgs ann4 x3- (r5,x5) <- toArgs ann5 x4- return ((r1,r2,r3,r4,r5),x5)- fromArgs (x1,x2,x3,x4,x5)- = fromArgs x1 ++- fromArgs x2 ++- fromArgs x3 ++- fromArgs x4 ++- fromArgs x5- getArgAnnotation (_::(a1,a2,a3,a4,a5)) sorts- = let (ann1,r1) = getArgAnnotation (undefined::a1) sorts- (ann2,r2) = getArgAnnotation (undefined::a2) r1- (ann3,r3) = getArgAnnotation (undefined::a3) r2- (ann4,r4) = getArgAnnotation (undefined::a4) r3- (ann5,r5) = getArgAnnotation (undefined::a5) r4- in ((ann1,ann2,ann3,ann4,ann5),r5)- getTypes ~(x1,x2,x3,x4,x5) (ann1,ann2,ann3,ann4,ann5)- = getTypes x1 ann1 ++- getTypes x2 ann2 ++- getTypes x3 ann3 ++- getTypes x4 ann4 ++- getTypes x5 ann5--instance (LiftArgs a,LiftArgs b,LiftArgs c,LiftArgs d,LiftArgs e) => LiftArgs (a,b,c,d,e) where- type Unpacked (a,b,c,d,e) = (Unpacked a,Unpacked b,Unpacked c,Unpacked d,Unpacked e)- liftArgs (x1,x2,x3,x4,x5) ~(a1,a2,a3,a4,a5) = (liftArgs x1 a1,liftArgs x2 a2,liftArgs x3 a3,liftArgs x4 a4,liftArgs x5 a5)- unliftArgs (x1,x2,x3,x4,x5) f = do- r1 <- unliftArgs x1 f- r2 <- unliftArgs x2 f- r3 <- unliftArgs x3 f- r4 <- unliftArgs x4 f- r5 <- unliftArgs x5 f- return (r1,r2,r3,r4,r5)--instance (Args a,Args b,Args c,Args d,Args e,Args f) => Args (a,b,c,d,e,f) where- type ArgAnnotation (a,b,c,d,e,f) = (ArgAnnotation a,ArgAnnotation b,ArgAnnotation c,ArgAnnotation d,ArgAnnotation e,ArgAnnotation f)- foldExprs f s ~(e1,e2,e3,e4,e5,e6) ~(ann1,ann2,ann3,ann4,ann5,ann6) = do- ~(s1,e1') <- foldExprs f s e1 ann1- ~(s2,e2') <- foldExprs f s1 e2 ann2- ~(s3,e3') <- foldExprs f s2 e3 ann3- ~(s4,e4') <- foldExprs f s3 e4 ann4- ~(s5,e5') <- foldExprs f s4 e5 ann5- ~(s6,e6') <- foldExprs f s5 e6 ann6- return (s6,(e1',e2',e3',e4',e5',e6'))- foldsExprs f s args ~(ann1,ann2,ann3,ann4,ann5,ann6) = do- ~(s1,e1,r1) <- foldsExprs f s (fmap (\(~(e1,_,_,_,_,_),b) -> (e1,b)) args) ann1- ~(s2,e2,r2) <- foldsExprs f s1 (fmap (\(~(_,e2,_,_,_,_),b) -> (e2,b)) args) ann2- ~(s3,e3,r3) <- foldsExprs f s2 (fmap (\(~(_,_,e3,_,_,_),b) -> (e3,b)) args) ann3- ~(s4,e4,r4) <- foldsExprs f s3 (fmap (\(~(_,_,_,e4,_,_),b) -> (e4,b)) args) ann4- ~(s5,e5,r5) <- foldsExprs f s4 (fmap (\(~(_,_,_,_,e5,_),b) -> (e5,b)) args) ann5- ~(s6,e6,r6) <- foldsExprs f s5 (fmap (\(~(_,_,_,_,_,e6),b) -> (e6,b)) args) ann6- return (s6,zip6 e1 e2 e3 e4 e5 e6,(r1,r2,r3,r4,r5,r6))- extractArgAnnotation ~(e1,e2,e3,e4,e5,e6)- = (extractArgAnnotation e1,- extractArgAnnotation e2,- extractArgAnnotation e3,- extractArgAnnotation e4,- extractArgAnnotation e5,- extractArgAnnotation e6)- toArgs ~(ann1,ann2,ann3,ann4,ann5,ann6) x = do- (r1,x1) <- toArgs ann1 x- (r2,x2) <- toArgs ann2 x1- (r3,x3) <- toArgs ann3 x2- (r4,x4) <- toArgs ann4 x3- (r5,x5) <- toArgs ann5 x4- (r6,x6) <- toArgs ann6 x5- return ((r1,r2,r3,r4,r5,r6),x6)- fromArgs (x1,x2,x3,x4,x5,x6)- = fromArgs x1 ++- fromArgs x2 ++- fromArgs x3 ++- fromArgs x4 ++- fromArgs x5 ++- fromArgs x6- getArgAnnotation (_::(a1,a2,a3,a4,a5,a6)) sorts- = let (ann1,r1) = getArgAnnotation (undefined::a1) sorts- (ann2,r2) = getArgAnnotation (undefined::a2) r1- (ann3,r3) = getArgAnnotation (undefined::a3) r2- (ann4,r4) = getArgAnnotation (undefined::a4) r3- (ann5,r5) = getArgAnnotation (undefined::a5) r4- (ann6,r6) = getArgAnnotation (undefined::a6) r5- in ((ann1,ann2,ann3,ann4,ann5,ann6),r6)- getTypes ~(x1,x2,x3,x4,x5,x6) (ann1,ann2,ann3,ann4,ann5,ann6)- = getTypes x1 ann1 ++- getTypes x2 ann2 ++- getTypes x3 ann3 ++- getTypes x4 ann4 ++- getTypes x5 ann5 ++- getTypes x6 ann6--instance (LiftArgs a,LiftArgs b,LiftArgs c,LiftArgs d,LiftArgs e,LiftArgs f) => LiftArgs (a,b,c,d,e,f) where- type Unpacked (a,b,c,d,e,f) = (Unpacked a,Unpacked b,Unpacked c,Unpacked d,Unpacked e,Unpacked f)- liftArgs (x1,x2,x3,x4,x5,x6) ~(a1,a2,a3,a4,a5,a6)- = (liftArgs x1 a1,liftArgs x2 a2,liftArgs x3 a3,liftArgs x4 a4,liftArgs x5 a5,liftArgs x6 a6)- unliftArgs (x1,x2,x3,x4,x5,x6) f = do- r1 <- unliftArgs x1 f- r2 <- unliftArgs x2 f- r3 <- unliftArgs x3 f- r4 <- unliftArgs x4 f- r5 <- unliftArgs x5 f- r6 <- unliftArgs x6 f- return (r1,r2,r3,r4,r5,r6)--instance Args a => Args [a] where- type ArgAnnotation [a] = [ArgAnnotation a]- foldExprs _ s _ [] = return (s,[])- foldExprs f s ~(x:xs) (ann:anns) = do- (s',x') <- foldExprs f s x ann- (s'',xs') <- foldExprs f s' xs anns- return (s'',x':xs')- foldsExprs f s _ [] = return (s,[],[])- foldsExprs f s args [ann] = do- let args_heads = fmap (\(xs,b) -> (head xs,b)) args- ~(s1,res_heads,zhead) <- foldsExprs f s args_heads ann- return (s1,fmap (\x -> [x]) res_heads,[zhead])- foldsExprs f s args (ann:anns) = do- let args_heads = fmap (\(xs,b) -> (head xs,b)) args- args_tails = fmap (\(xs,b) -> (tail xs,b)) args- ~(s1,res_heads,zhead) <- foldsExprs f s args_heads ann- ~(s2,res_tails,ztail) <- foldsExprs f s1 args_tails anns- return (s2,zipWith (:) res_heads res_tails,zhead:ztail)- extractArgAnnotation = fmap extractArgAnnotation- toArgs [] xs = Just ([],xs)- toArgs (ann:anns) x = do- (r,x') <- toArgs ann x- (rs,x'') <- toArgs anns x'- return (r:rs,x'')- fromArgs xs = concat $ fmap fromArgs xs- getArgAnnotation _ [] = ([],[])- getArgAnnotation (_::[a]) sorts = let (x,r1) = getArgAnnotation (undefined::a) sorts- (xs,r2) = getArgAnnotation (undefined::[a]) r1- in (x:xs,r2)- getTypes _ [] = []- getTypes ~(x:xs) (ann:anns) = getTypes x ann ++ getTypes xs anns--instance (Typeable a,Show a,Args b,Ord a) => Args (Map a b) where- type ArgAnnotation (Map a b) = Map a (ArgAnnotation b)- foldExprs f s mp mp_ann = foldlM (\(s',cmp) (k,ann) -> do- let el = case Map.lookup k mp of- Nothing -> error $ "smtlib2: Map annotation contains key "++- show k++- " but it is not in the map. (Map annotation: "++- show (Map.keys mp_ann)++- ", map: "++- show (Map.keys mp)- Just x -> x- (s'',el') <- foldExprs f s' el ann- return (s'',Map.insert k el' cmp)- ) (s,Map.empty) (Map.toList mp_ann)- foldsExprs f s args mp_ann = do- let lst_ann = Map.toAscList mp_ann- lst = fmap (\(mp,extra) -> ([ mp Map.! k | (k,_) <- lst_ann ],extra)- ) args- (ns,lst',lst_merged) <- foldsExprs f s lst (fmap snd lst_ann)- return (ns,fmap (\lst'' -> Map.fromAscList $ zip (fmap fst lst_ann) lst''- ) lst',Map.fromAscList $ zip (fmap fst lst_ann) lst_merged)- extractArgAnnotation = fmap extractArgAnnotation- toArgs mp_ann exprs = case Map.mapAccum (\cst ann -> case cst of- Nothing -> (Nothing,undefined)- Just rest -> case toArgs ann rest of- Nothing -> (Nothing,undefined)- Just (res,rest') -> (Just rest',res)- ) (Just exprs) mp_ann of- (Nothing,_) -> Nothing- (Just rest,mp) -> Just (mp,rest)- fromArgs exprs = concat $ fmap fromArgs $ Map.elems exprs- getTypes (_::Map a b) anns = concat [ getTypes (undefined::b) ann | (_,ann) <- Map.toAscList anns ]- getArgAnnotation _ sorts = (Map.empty,sorts)--instance (Args a,Args b) => Args (Either a b) where- type ArgAnnotation (Either a b) = Either (ArgAnnotation a) (ArgAnnotation b)- foldExprs f s ~(Left x) (Left ann) = do- (ns,res) <- foldExprs f s x ann- return (ns,Left res)- foldExprs f s ~(Right x) (Right ann) = do- (ns,res) <- foldExprs f s x ann- return (ns,Right res)- foldsExprs f s lst (Left ann) = do- (ns,ress,res) <- foldsExprs f s (fmap (\(x,p) -> (case x of- Left x' -> x',p)) lst) ann- return (ns,fmap Left ress,Left res)- foldsExprs f s lst (Right ann) = do- (ns,ress,res) <- foldsExprs f s (fmap (\(x,p) -> (case x of- Right x' -> x',p)) lst) ann- return (ns,fmap Right ress,Right res)- extractArgAnnotation (Left x) = Left $ extractArgAnnotation x- extractArgAnnotation (Right x) = Right $ extractArgAnnotation x- toArgs (Left ann) exprs = do- (res,rest) <- toArgs ann exprs- return (Left res,rest)- toArgs (Right ann) exprs = do- (res,rest) <- toArgs ann exprs- return (Right res,rest)- fromArgs (Left xs) = fromArgs xs- fromArgs (Right xs) = fromArgs xs- getTypes (_::Either a b) (Left ann) = getTypes (undefined::a) ann- getTypes (_::Either a b) (Right ann) = getTypes (undefined::b) ann- getArgAnnotation _ _ = error "smtlib2: getArgAnnotation undefined for Either"--instance Args a => Args (Maybe a) where- type ArgAnnotation (Maybe a) = Maybe (ArgAnnotation a)- foldExprs _ s _ Nothing = return (s,Nothing)- foldExprs f s ~(Just x) (Just ann) = do- (ns,res) <- foldExprs f s x ann- return (ns,Just res)- foldsExprs _ s lst Nothing = return (s,fmap (const Nothing) lst,Nothing)- foldsExprs f s lst (Just ann) = do- (ns,ress,res) <- foldsExprs f s (fmap (\(x,p) -> (case x of- Just x' -> x',p)) lst) ann- return (ns,fmap Just ress,Just res)- extractArgAnnotation = fmap extractArgAnnotation- toArgs Nothing exprs = Just (Nothing,exprs)- toArgs (Just ann) exprs = do- (res,rest) <- toArgs ann exprs- return (Just res,rest)- fromArgs Nothing = []- fromArgs (Just x) = fromArgs x- getTypes _ Nothing = []- getTypes (_::Maybe a) (Just ann) = getTypes (undefined::a) ann- getArgAnnotation _ _ = error "smtlib2: getArgAnnotation undefined for Maybe"--instance LiftArgs a => LiftArgs [a] where- type Unpacked [a] = [Unpacked a]- liftArgs _ [] = []- liftArgs ~(x:xs) (ann:anns) = liftArgs x ann:liftArgs xs anns- unliftArgs [] _ = return []- unliftArgs (x:xs) f = do- x' <- unliftArgs x f- xs' <- unliftArgs xs f- return (x':xs')--instance (Typeable a,Show a,Ord a,LiftArgs b) => LiftArgs (Map a b) where- type Unpacked (Map a b) = Map a (Unpacked b)- liftArgs mp ann = Map.mapWithKey (\k ann' -> liftArgs (mp Map.! k) ann') ann- unliftArgs mp f = mapM (\el -> unliftArgs el f) mp--instance (LiftArgs a,LiftArgs b) => LiftArgs (Either a b) where- type Unpacked (Either a b) = Either (Unpacked a) (Unpacked b)- liftArgs ~(Left x) (Left ann) = Left (liftArgs x ann)- liftArgs ~(Right x) (Right ann) = Right (liftArgs x ann)- unliftArgs (Left x) f = do- res <- unliftArgs x f- return $ Left res- unliftArgs (Right x) f = do- res <- unliftArgs x f- return $ Right res--instance LiftArgs a => LiftArgs (Maybe a) where- type Unpacked (Maybe a) = Maybe (Unpacked a)- liftArgs _ Nothing = Nothing- liftArgs ~(Just x) (Just ann) = Just (liftArgs x ann)- unliftArgs Nothing _ = return Nothing- unliftArgs (Just x) f = do- res <- unliftArgs x f- return (Just res)--instance SMTType a => SMTType (Maybe a) where- type SMTAnnotation (Maybe a) = SMTAnnotation a- getSort u ann = Fix $ NamedSort "Maybe" [getSort (undefArg u) ann]- asDataType _ _ = Just ("Maybe",- TypeCollection { argCount = 1- , dataTypes = [dtMaybe]- })- getProxyArgs (_::Maybe t) ann = [ProxyArg (undefined::t) ann]- annotationFromSort u (Fix (NamedSort "Maybe" [argSort])) = annotationFromSort (undefArg u) argSort- asValueType (_::Maybe x) ann f = asValueType (undefined::x) ann $- \(_::y) ann' -> f (undefined::Maybe y) ann'- defaultExpr ann = withUndef $- \u -> App (SMTConstructor (nothing' ann)) ()- where- withUndef :: (a -> SMTExpr (Maybe a)) -> SMTExpr (Maybe a)- withUndef f = f undefined--dtMaybe :: DataType-dtMaybe = DataType { dataTypeName = "Maybe"- , dataTypeConstructors = [conNothing,- conJust]- , dataTypeGetUndefined = \sorts f -> case sorts of- [s] -> withProxyArg s $- \(_::t) ann -> f (undefined::Maybe t) ann- }--conNothing :: Constr-conNothing- = Constr { conName = "Nothing"- , conFields = []- , construct = \[Just prx] [] f- -> withProxyArg prx $- \(_::t) ann -> f [prx] (Nothing::Maybe t) ann- , conUndefinedArgs = \_ f -> f () ()- , conTest = \args x -> case args of- [s] -> withProxyArg s $- \(_::t) _ -> case cast x of- Just (Nothing::Maybe t) -> True- _ -> False- }--conJust :: Constr-conJust- = Constr { conName = "Just"- , conFields = [fieldFromJust]- , construct = \sort args f- -> case args of- [v] -> withAnyValue v $- \_ (rv::t) ann- -> f [ProxyArg (undefined::t) ann] (Just rv) ann- , conUndefinedArgs = \sorts f -> case sorts of- [s] -> withProxyArg s $- \(_::t) ann -> f (undefined::SMTExpr t) ann- , conTest = \args x -> case args of- [s] -> withProxyArg s $- \(_::t) _ -> case cast x of- Just (Just (_::t)) -> True- _ -> False- }--nothing' :: SMTType a => SMTAnnotation a -> Constructor () (Maybe a)-nothing' ann = withUndef $- \u -> Constructor [ProxyArg u ann] dtMaybe conNothing- where- withUndef :: (a -> Constructor () (Maybe a)) -> Constructor () (Maybe a)- withUndef f = f undefined--just' :: SMTType a => SMTAnnotation a -> Constructor (SMTExpr a) (Maybe a)-just' ann = withUndef $- \u -> Constructor [ProxyArg u ann] dtMaybe conJust- where- withUndef :: (a -> Constructor (SMTExpr a) (Maybe a)) -> Constructor (SMTExpr a) (Maybe a)- withUndef f = f undefined--fieldFromJust :: DataField-fieldFromJust = DataField { fieldName = "fromJust"- , fieldSort = Fix $ ArgumentSort 0- , fieldGet = \args x f- -> case args of- [s] -> withProxyArg s $- \(_::t) ann- -> f (case cast x of- Just (arg::Maybe t) -> fromJust arg) ann- }--instance SMTValue a => SMTValue (Maybe a) where- unmangle = case unmangle of- PrimitiveUnmangling p- -> PrimitiveUnmangling (\val ann -> case val of- ConstrValue "Nothing" [] _ -> Just Nothing- ConstrValue "Just" [arg] _- -> case p arg ann of- Just v -> Just (Just v)- Nothing -> Nothing- _ -> Nothing)- ComplexUnmangling p- -> ComplexUnmangling $ \f st (expr::SMTExpr (Maybe t)) ann -> do- (isNothing,st1) <- f st (App (SMTConTest- (Constructor [ProxyArg (undefined::t) (extractAnnotation expr)]- dtMaybe conNothing :: Constructor () (Maybe a))) expr- ) ()- if isNothing- then return (Just Nothing,st1)- else do- (val,st2) <- p f st1 (App (SMTFieldSel (Field [ProxyArg (undefined::t) (extractAnnotation expr)] dtMaybe conJust fieldFromJust)) expr) ann- case val of- Nothing -> return (Nothing,st2)- Just val' -> return (Just (Just val'),st2)- mangle = case mangle of- PrimitiveMangling p- -> PrimitiveMangling $- \val ann -> case val of- (Nothing::Maybe t) -> ConstrValue "Nothing" [] (Just ("Maybe",[getSort (undefined::t) ann]))- Just x -> ConstrValue "Just" [p x ann] Nothing- ComplexMangling p- -> ComplexMangling $- \(val::Maybe t) ann -> case val of- Just x -> App (SMTConstructor- (Constructor [ProxyArg (undefined::t) ann] dtMaybe conJust))- (p x ann)- Nothing -> App (SMTConstructor- (Constructor [ProxyArg (undefined::t) ann]- dtMaybe conNothing :: Constructor () (Maybe t)))- ()---- | Get an undefined value of the type argument of a type.-undefArg :: b a -> a-undefArg _ = undefined--instance (Typeable a,SMTType a) => SMTType [a] where- type SMTAnnotation [a] = SMTAnnotation a- getSort u ann = Fix (NamedSort "List" [getSort (undefArg u) ann])- asDataType _ _ = Just ("List",- TypeCollection { argCount = 1- , dataTypes = [dtList] })- getProxyArgs (_::[t]) ann = [ProxyArg (undefined::t) ann]- annotationFromSort u (Fix (NamedSort "List" [sort])) = annotationFromSort (undefArg u) sort- asValueType (_::[a]) ann f = asValueType (undefined::a) ann $- \(_::b) ann' -> f (undefined::[b]) ann'- defaultExpr ann = App (SMTConstructor (nil' ann)) ()--dtList :: DataType-dtList = DataType { dataTypeName = "List"- , dataTypeConstructors = [conNil,conInsert]- , dataTypeGetUndefined = \args f -> case args of- [s] -> withProxyArg s (\(_::t) ann -> f (undefined::[t]) ann)- }--conNil :: Constr-conNil = Constr { conName = "nil"- , conFields = []- , construct = \[Just sort] args f- -> withProxyArg sort $- \(_::t) ann -> f [sort] ([]::[t]) ann- , conUndefinedArgs = \_ f -> f () ()- , conTest = \args x -> case args of- [s] -> withProxyArg s $- \(_::t) _ -> case cast x of- Just ([]::[t]) -> True- _ -> False- }--conInsert :: Constr-conInsert = Constr { conName = "insert"- , conFields = [fieldHead- ,fieldTail]- , construct = \sort args f- -> case args of- [h,t] -> withAnyValue h $- \_ (v::t) ann- -> case castAnyValue t of- Just (vs,_) -> f [ProxyArg (undefined::t) ann] (v:vs) ann- , conUndefinedArgs = \sorts f -> case sorts of- [s] -> withProxyArg s $- \(_::t) ann -> f (undefined::(SMTExpr t,SMTExpr [t])) (ann,ann)- , conTest = \args x -> case args of- [s] -> withProxyArg s $- \(_::t) _ -> case cast x of- Just ((_:_)::[t]) -> True- _ -> False- }--insert' :: SMTType a => SMTAnnotation a -> Constructor (SMTExpr a,SMTExpr [a]) [a]-insert' ann = withUndef $- \u -> Constructor [ProxyArg u ann] dtList conInsert- where- withUndef :: (a -> Constructor (SMTExpr a,SMTExpr [a]) [a]) -> Constructor (SMTExpr a,SMTExpr [a]) [a]- withUndef f = f undefined--nil' :: SMTType a => SMTAnnotation a -> Constructor () [a]-nil' ann = withUndef $- \u -> Constructor [ProxyArg u ann] dtList conNil- where- withUndef :: (a -> Constructor () [a]) -> Constructor () [a]- withUndef f = f undefined--fieldHead :: DataField-fieldHead = DataField { fieldName = "head"- , fieldSort = Fix (ArgumentSort 0)- , fieldGet = \args x f -> case args of- [s] -> withProxyArg s $- \(_::t) ann- -> case cast x of- Just (ys::[t]) -> f (head ys) ann- }--fieldTail :: DataField-fieldTail = DataField { fieldName = "tail"- , fieldSort = Fix (NormalSort (NamedSort "List" [Fix (ArgumentSort 0)]))- , fieldGet = \args x f -> case args of- [s] -> withProxyArg s $- \(_::t) ann- -> case cast x of- Just (ys::[t]) -> f (tail ys) ann- }--instance (Typeable a,SMTValue a) => SMTValue [a] where- unmangle = case unmangle of- PrimitiveUnmangling p- -> PrimitiveUnmangling $ pUnmangle p- ComplexUnmangling p- -> ComplexUnmangling $ cUnmangle p- where- pUnmangle _ (ConstrValue "nil" [] _) ann = Just []- pUnmangle p (ConstrValue "insert" [h,t] _) ann = do- h' <- p h ann- t' <- pUnmangle p t ann- return (h':t')- cUnmangle :: Monad m- => ((forall b. SMTValue b => st -> SMTExpr b -> SMTAnnotation b -> m (b,st))- -> st -> SMTExpr a -> SMTAnnotation a -> m (Maybe a,st))- -> (forall b. SMTValue b => st -> SMTExpr b -> SMTAnnotation b -> m (b,st))- -> st -> SMTExpr [a] -> SMTAnnotation a -> m (Maybe [a],st)- cUnmangle c f st (expr::SMTExpr [t]) ann = do- (isNil,st1) <- f st (App (SMTConTest- (Constructor [ProxyArg (undefined::t) ann] dtList conNil- ::Constructor () [t]))- expr) ()- if isNil- then return (Just [],st1)- else do- (h,st2) <- c f st1 (App (SMTFieldSel (Field [ProxyArg (undefined::t) ann] dtList conInsert fieldHead))- expr) ann- (t,st3) <- cUnmangle c f st2 (App (SMTFieldSel (Field [ProxyArg (undefined::t) ann] dtList conInsert fieldTail)) expr) ann- return (do- h' <- h- t' <- t- return $ h':t',st3)- mangle = case mangle of- PrimitiveMangling p- -> PrimitiveMangling $ pMangle p- ComplexMangling p- -> ComplexMangling $ cMangle p- where- pMangle _ ([]::[t]) ann = ConstrValue "nil" [] (Just ("List",[getSort (undefined::t) ann]))- pMangle p (x:xs) ann = ConstrValue "insert" [p x ann,pMangle p xs ann] Nothing- cMangle :: (a -> SMTAnnotation a -> SMTExpr a)- -> [a] -> SMTAnnotation a -> SMTExpr [a]- cMangle c ([]::[t]) ann- = App (SMTConstructor (Constructor [ProxyArg (undefined::t) ann] dtList conNil)) ()- cMangle c ((x::t):xs) ann- = App (SMTConstructor (Constructor [ProxyArg (undefined::t) ann] dtList conInsert))- (c x ann,cMangle c xs ann)---- BitVector implementation--instance SMTType (BitVector BVUntyped) where- type SMTAnnotation (BitVector BVUntyped) = Integer- getSort _ l = Fix (BVSort l True)- annotationFromSort _ (Fix (BVSort l _)) = l- asValueType x ann f = Just $ f x ann- defaultExpr bw = Const (BitVector 0) bw--instance IsBitVector BVUntyped where- getBVSize _ = id--instance SMTValue (BitVector BVUntyped) where- unmangle = PrimitiveUnmangling $- \val _ -> case val of- BVValue _ v -> Just (BitVector v)- _ -> Nothing- mangle = PrimitiveMangling $- \(BitVector v) l -> BVValue l v--instance TypeableNat n => SMTType (BitVector (BVTyped n)) where- type SMTAnnotation (BitVector (BVTyped n)) = ()- getSort _ _ = Fix (BVSort (reflectNat (Proxy::Proxy n) 0) False)- annotationFromSort _ _ = ()- asValueType x ann f = Just $ f x ann- defaultExpr _ = Const (BitVector 0) ()--instance TypeableNat n => IsBitVector (BVTyped n) where- getBVSize (_::Proxy (BVTyped n)) _ = reflectNat (Proxy::Proxy n) 0--instance TypeableNat n => SMTValue (BitVector (BVTyped n)) where- unmangle = PrimitiveUnmangling $- \val _ -> case val of- BVValue w v- | (reflectNat (Proxy::Proxy n) 0)==w -> Just (BitVector v)- | otherwise -> Nothing- _ -> Nothing- mangle = PrimitiveMangling $- \(BitVector v) _ -> BVValue (reflectNat (Proxy::Proxy n) 0) v--bvUnsigned :: IsBitVector a => BitVector a -> SMTAnnotation (BitVector a) -> Integer-bvUnsigned (BitVector x) _ = x--bvSigned :: IsBitVector a => BitVector a -> SMTAnnotation (BitVector a) -> Integer-bvSigned (BitVector x::BitVector a) ann- = let sz = getBVSize (Proxy::Proxy a) ann- in if x < 2^(sz-1)- then x- else x-2^sz--bvRestrict :: IsBitVector a => BitVector a -> SMTAnnotation (BitVector a) -> BitVector a-bvRestrict (BitVector x::BitVector a) ann- = let sz = getBVSize (Proxy::Proxy a) ann- in BitVector (x `mod` (2^sz))--instance TypeableNat n => Num (BitVector (BVTyped n)) where- (+) (BitVector x) (BitVector y) = BitVector (x+y)- (-) (BitVector x) (BitVector y) = BitVector (x-y)- (*) (BitVector x) (BitVector y) = BitVector (x*y)- negate (BitVector x) = BitVector (negate x)- abs (BitVector x) = BitVector (abs x)- signum (BitVector x) = BitVector (signum x)- fromInteger i = BitVector i--instance TypeableNat n => Num (SMTExpr (BitVector (BVTyped n))) where- (+) (x::SMTExpr (BitVector (BVTyped n))) y = App (SMTBVBin BVAdd) (x,y)- (-) (x::SMTExpr (BitVector (BVTyped n))) y = App (SMTBVBin BVSub) (x,y)- (*) (x::SMTExpr (BitVector (BVTyped n))) y = App (SMTBVBin BVMul) (x,y)- negate (x::SMTExpr (BitVector (BVTyped n))) = App (SMTBVUn BVNeg) x- abs (x::SMTExpr (BitVector (BVTyped n))) = App SMTITE (App (SMTBVComp BVUGT) (x,Const (BitVector 0) ()),x,App (SMTBVUn BVNeg) x)- signum (x::SMTExpr (BitVector (BVTyped n))) = App SMTITE (App (SMTBVComp BVUGT) (x,Const (BitVector 0) ()),Const (BitVector 1) (),Const (BitVector (-1)) ())- fromInteger i = Const (BitVector i) ()--instance Extractable BVUntyped BVUntyped where- extractAnn _ _ len _ = len- getExtractLen _ _ len = len--instance TypeableNat n => Extractable (BVTyped n) BVUntyped where- extractAnn _ _ len _ = len- getExtractLen _ _ len = len--instance TypeableNat n => Extractable BVUntyped (BVTyped n) where- extractAnn _ _ _ _ = ()- getExtractLen _ (_::BVTyped n) _ = reflectNat (Proxy::Proxy n) 0--instance (TypeableNat n1,TypeableNat n2) => Extractable (BVTyped n1) (BVTyped n2) where- extractAnn _ _ _ _ = ()- getExtractLen _ (_::BVTyped n) _ = reflectNat (Proxy::Proxy n) 0--withSort :: DataTypeInfo -> Sort -> (forall t. SMTType t => t -> SMTAnnotation t -> r) -> r-withSort _ (Fix BoolSort) f = f (undefined::Bool) ()-withSort _ (Fix IntSort) f = f (undefined::Integer) ()-withSort _ (Fix RealSort) f = f (undefined::Rational) ()-withSort _ (Fix (BVSort { bvSortWidth = w- , bvSortUntyped = unt })) f- = if unt- then f (undefined::BitVector BVUntyped) w- else reifyNat w (\(_::Proxy tp) -> f (undefined::BitVector (BVTyped tp)) ())-withSort mp (Fix (ArraySort args res)) f- = withSorts mp args $ \(_::rargs) argAnn- -> withSort mp res $ \(_::rres) resAnn- -> f (undefined::SMTArray rargs rres) (argAnn,resAnn)-withSort mp (Fix (NamedSort name args)) f- = case Map.lookup name (datatypes mp) of- Just (decl,_) -> dataTypeGetUndefined decl- (fmap (\s -> withSort mp s ProxyArg) args) f- Nothing -> error $ "smtlib2: Datatype "++name++" not defined."--withNumSort :: DataTypeInfo -> Sort -> (forall t. (SMTArith t) => t -> SMTAnnotation t -> r) -> Maybe r-withNumSort _ (Fix IntSort) f = Just $ f (undefined::Integer) ()-withNumSort _ (Fix RealSort) f = Just $ f (undefined::Rational) ()-withNumSort _ _ _ = Nothing--withSorts :: DataTypeInfo -> [Sort] -> (forall arg . Liftable arg => arg -> ArgAnnotation arg -> r) -> r-withSorts mp [x] f = withSort mp x $ \(_::t) ann -> f (undefined::SMTExpr t) ann-withSorts mp [x0,x1] f- = withSort mp x0 $- \(_::r1) ann1- -> withSort mp x1 $- \(_::r2) ann2 -> f (undefined::(SMTExpr r1,SMTExpr r2)) (ann1,ann2)-withSorts mp [x0,x1,x2] f- = withSort mp x0 $- \(_::r1) ann1- -> withSort mp x1 $- \(_::r2) ann2- -> withSort mp x2 $- \(_::r3) ann3 -> f (undefined::(SMTExpr r1,SMTExpr r2,SMTExpr r3)) (ann1,ann2,ann3)--withArraySort :: DataTypeInfo -> [Sort] -> Sort -> (forall i v. (Liftable i,SMTType v) => SMTArray i v -> (ArgAnnotation i,SMTAnnotation v) -> a) -> a-withArraySort mp idx v f- = withSorts mp idx $- \(_::i) anni- -> withSort mp v $- \(_::vt) annv -> f (undefined::SMTArray i vt) (anni,annv)---- | Recursively fold a monadic function over all sub-expressions of this expression-foldExprM :: (SMTType a,Monad m) => (forall t. SMTType t => s -> SMTExpr t -> m (s,[SMTExpr t]))- -> s -> SMTExpr a -> m (s,[SMTExpr a])-foldExprM f s (Forall lvl args body) = do- (s',exprs1) <- foldExprM f s body- return (s',[ Forall lvl args body'- | body' <- exprs1 ])-foldExprM f s (Exists lvl args body) = do- (s',exprs1) <- foldExprM f s body- return (s',[ Exists lvl args body'- | body' <- exprs1 ])-foldExprM f s (Let lvl defs body) = do- (s1,defs') <- foldDefs s defs- (s2,body') <- foldExprM f s1 body- return (s2,[ Let lvl defs body- | defs <- defs'- , body <- body' ])- where- foldDefs s [] = return (s,[[]])- foldDefs s (d:ds) = do- (s1,d') <- foldExprM f s d- (s2,ds') <- foldDefs s1 ds- return (s2,[ d:ds- | d <- d'- , ds <- ds' ])-foldExprM f s (App fun arg) = do- (s',args') <- foldArgsM f s arg- return (s',[ App fun arg'- | arg' <- args' ])-foldExprM f s (Named expr i) = do- (s',exprs') <- foldExprM f s expr- return (s',[ Named expr' i- | expr' <- exprs' ])-foldExprM f s (UntypedExpr e) = do- (s',exprs') <- foldExprM f s e- return (s',[ UntypedExpr e'- | e' <- exprs' ])-foldExprM f s (UntypedExprValue e) = do- (s',exprs') <- foldExprM f s e- return (s',[ UntypedExprValue e'- | e' <- exprs' ])-foldExprM f s expr = f s expr---- | Recursively fold a monadic function over all sub-expressions of the argument-foldArgsM :: (Args a,Monad m) => (forall t. SMTType t => s -> SMTExpr t -> m (s,[SMTExpr t]))- -> s -> a -> m (s,[a])-foldArgsM f s arg = do- (ns,res) <- fold s (fromArgs arg)- let res' = fmap (\x -> let Just (x',[]) = toArgs (extractArgAnnotation arg) x- in x'- ) res- return (ns,res')- where- fold cs [] = return (cs,[[]])- fold cs ((UntypedExpr expr):exprs) = do- (s1,nexprs) <- foldExprM f cs expr- (s2,rest) <- fold s1 exprs- return (s2,[ (UntypedExpr x):xs- | x <- nexprs- , xs <- rest ])---- | Recursively fold a function over all sub-expressions of this expression.--- It is implemented as a special case of 'foldExprM'.-foldExpr :: SMTType a => (forall t. SMTType t => s -> SMTExpr t -> (s,SMTExpr t))- -> s -> SMTExpr a -> (s,SMTExpr a)-foldExpr f s expr = case runIdentity $ foldExprM (\s' expr' -> let (ns,r) = f s' expr'- in return (ns,[r])) s expr of- (ns,[r]) -> (ns,r)---foldExprMux :: SMTType a => (forall t. SMTType t => s -> SMTExpr t -> (s,[SMTExpr t]))- -> s -> SMTExpr a -> (s,[SMTExpr a])-foldExprMux f s expr = runIdentity $ foldExprM (\s' expr' -> return $ f s' expr') s expr---- | Recursively fold a function over all sub-expressions of the argument.--- It is implemented as a special case of 'foldArgsM'.-foldArgs :: Args a => (forall t. SMTType t => s -> SMTExpr t -> (s,SMTExpr t))- -> s -> a -> (s,a)-foldArgs f s expr = case runIdentity $ foldArgsM (\s' expr' -> let (ns,expr'') = f s' expr'- in return (ns,[expr''])) s expr of- (ns,[r]) -> (ns,r)---foldArgsMux :: Args a => (forall t. SMTType t => s -> SMTExpr t -> (s,[SMTExpr t]))- -> s -> a -> (s,[a])-foldArgsMux f s expr = runIdentity $ foldArgsM (\s' expr' -> return $ f s' expr') s expr--instance Args arg => Eq (SMTFunction arg res) where- (==) f1 f2 = compareFun f1 f2 == EQ--instance Args arg => Ord (SMTFunction arg res) where- compare = compareFun- -compareFun :: (Args a1,Args a2) => SMTFunction a1 r1 -> SMTFunction a2 r2 -> Ordering-compareFun SMTEq SMTEq = EQ-compareFun SMTEq _ = LT-compareFun _ SMTEq = GT-compareFun (SMTMap f1) (SMTMap f2) = compareFun f1 f2-compareFun (SMTMap _) _ = LT-compareFun _ (SMTMap _) = GT-compareFun (SMTFun i _) (SMTFun j _) = compare i j-compareFun (SMTFun _ _) _ = LT-compareFun _ (SMTFun _ _) = GT-compareFun (SMTBuiltIn n1 _) (SMTBuiltIn n2 _) = compare n1 n2-compareFun (SMTBuiltIn _ _) _ = LT-compareFun _ (SMTBuiltIn _ _) = GT-compareFun (SMTOrd op1) (SMTOrd op2) = compare op1 op2-compareFun (SMTOrd _) _ = LT-compareFun _ (SMTOrd _) = GT-compareFun (SMTArith op1) (SMTArith op2) = compare op1 op2-compareFun SMTMinus SMTMinus = EQ-compareFun SMTMinus _ = LT-compareFun _ SMTMinus = GT-compareFun (SMTIntArith op1) (SMTIntArith op2) = compare op1 op2-compareFun (SMTIntArith _) _ = LT-compareFun _ (SMTIntArith _) = GT-compareFun SMTDivide SMTDivide = EQ-compareFun SMTDivide _ = LT-compareFun _ SMTDivide = GT-compareFun SMTNeg SMTNeg = EQ-compareFun SMTNeg _ = LT-compareFun _ SMTNeg = GT-compareFun SMTAbs SMTAbs = EQ-compareFun SMTAbs _ = LT-compareFun _ SMTAbs = GT-compareFun SMTNot SMTNot = EQ-compareFun SMTNot _ = LT-compareFun _ SMTNot = GT-compareFun (SMTLogic op1) (SMTLogic op2) = compare op1 op2-compareFun (SMTLogic _) _ = LT-compareFun _ (SMTLogic _) = GT-compareFun SMTDistinct SMTDistinct = EQ-compareFun SMTDistinct _ = LT-compareFun _ SMTDistinct = GT-compareFun SMTToReal SMTToReal = EQ-compareFun SMTToReal _ = LT-compareFun _ SMTToReal = GT-compareFun SMTToInt SMTToInt = EQ-compareFun SMTToInt _ = LT-compareFun _ SMTToInt = GT-compareFun SMTITE SMTITE = EQ-compareFun SMTITE _ = LT-compareFun _ SMTITE = GT-compareFun (SMTBVComp op1) (SMTBVComp op2) = compare op1 op2-compareFun (SMTBVComp _) _ = LT-compareFun _ (SMTBVComp _) = GT-compareFun (SMTBVBin op1) (SMTBVBin op2) = compare op1 op2-compareFun (SMTBVBin _) _ = LT-compareFun _ (SMTBVBin _) = GT-compareFun (SMTBVUn op1) (SMTBVUn op2) = compare op1 op2-compareFun (SMTBVUn _) _ = LT-compareFun _ (SMTBVUn _) = GT-compareFun SMTSelect SMTSelect = EQ-compareFun SMTSelect _ = LT-compareFun _ SMTSelect = GT-compareFun SMTStore SMTStore = EQ-compareFun SMTStore _ = LT-compareFun _ SMTStore = GT-compareFun (SMTConstArray _) (SMTConstArray _) = EQ-compareFun (SMTConstArray _) _ = LT-compareFun _ (SMTConstArray _) = GT-compareFun SMTConcat SMTConcat = EQ-compareFun SMTConcat _ = LT-compareFun _ SMTConcat = GT-compareFun (SMTExtract (_::Proxy start1) (_::Proxy len1)) (SMTExtract (_::Proxy start2) (_::Proxy len2))- = compare (typeOf (undefined::start1),typeOf (undefined::len1))- (typeOf (undefined::start2),typeOf (undefined::len2))-compareFun (SMTExtract _ _) _ = LT-compareFun _ (SMTExtract _ _) = GT-compareFun (SMTConstructor con1) (SMTConstructor con2)- = compareConstructor con1 con2-compareFun (SMTConstructor _) _ = LT-compareFun _ (SMTConstructor _) = GT-compareFun (SMTConTest con1) (SMTConTest con2)- = compareConstructor con1 con2-compareFun (SMTConTest _) _ = LT-compareFun _ (SMTConTest _) = GT-compareFun (SMTFieldSel f1) (SMTFieldSel f2) = compareField f1 f2-compareFun (SMTFieldSel _) _ = LT-compareFun _ (SMTFieldSel _) = GT-compareFun (SMTDivisible x) (SMTDivisible y) = compare x y-compareFun (SMTDivisible _) _ = LT-compareFun _ (SMTDivisible _) = GT--compareConstructor :: Constructor arg1 res1 -> Constructor arg2 res2 -> Ordering-compareConstructor (Constructor p1 dt1 con1) (Constructor p2 dt2 con2)- = case compare (dataTypeName dt1) (dataTypeName dt2) of- EQ -> case compare p1 p2 of- EQ -> compare (conName con1) (conName con2)- r -> r- r -> r--compareField :: Field a1 f1 -> Field a2 f2 -> Ordering-compareField (Field p1 dt1 con1 f1) (Field p2 dt2 con2 f2)- = case compare (dataTypeName dt1) (dataTypeName dt2) of- EQ -> case compare p1 p2 of- EQ -> case compare (conName con1) (conName con2) of- EQ -> compare (fieldName f1) (fieldName f2)- r -> r- r -> r- r -> r--compareArgs :: (Args a1,Args a2) => a1 -> a2 -> Ordering-compareArgs x y = compare (fromArgs x) (fromArgs y)--compareExprs :: (SMTType t1,SMTType t2) => SMTExpr t1 -> SMTExpr t2 -> Ordering-compareExprs (UntypedExpr e1) e2 = compareExprs e1 e2-compareExprs e1 (UntypedExpr e2) = compareExprs e1 e2-compareExprs (UntypedExprValue e1) e2 = compareExprs e1 e2-compareExprs e1 (UntypedExprValue e2) = compareExprs e1 e2-compareExprs (Var i _) (Var j _) = compare i j-compareExprs (Var _ _) _ = LT-compareExprs _ (Var _ _) = GT-compareExprs (QVar lvl1 i1 _) (QVar lvl2 i2 _) = case compare lvl1 lvl2 of- EQ -> compare i1 i2- r -> r-compareExprs (QVar _ _ _) _ = LT-compareExprs _ (QVar _ _ _) = GT-compareExprs (FunArg i _) (FunArg j _) = compare i j-compareExprs (FunArg _ _) _ = LT-compareExprs _ (FunArg _ _) = GT-compareExprs (Const i _) (Const j _) = case cast j of- Just j' -> compare i j'- Nothing -> compare (typeOf i) (typeOf j)-compareExprs (Const _ _) _ = LT-compareExprs _ (Const _ _) = GT-compareExprs (AsArray f1 _) (AsArray f2 _) = compareFun f1 f2-compareExprs (AsArray _ _) _ = LT-compareExprs _ (AsArray _ _) = GT-compareExprs (Forall lvl1 args1 f1) (Forall lvl2 args2 f2)- = case compare lvl1 lvl2 of- EQ -> case compare args1 args2 of- EQ -> compareExprs f1 f2- r -> r- r -> r-compareExprs (Forall _ _ _) _ = LT-compareExprs _ (Forall _ _ _) = GT-compareExprs (Exists lvl1 args1 f1) (Exists lvl2 args2 f2)- = case compare lvl1 lvl2 of- EQ -> case compare args1 args2 of- EQ -> compareExprs f1 f2- r -> r- r -> r-compareExprs (Exists _ _ _) _ = LT-compareExprs _ (Exists _ _ _) = GT-compareExprs (Let lvl1 arg1 f1) (Let lvl2 arg2 f2)- = case compare lvl1 lvl2 of- EQ -> case compare arg1 arg2 of- EQ -> compareExprs f1 f2- r -> r- r -> r-compareExprs (Let _ _ _) _ = LT-compareExprs _ (Let _ _ _) = GT-compareExprs (App f1 arg1) (App f2 arg2) = case compareFun f1 f2 of- EQ -> compareArgs arg1 arg2- x -> x-compareExprs (App _ _) _ = LT-compareExprs _ (App _ _) = GT-compareExprs (Named _ i1) (Named _ i2) = compare i1 i2-compareExprs (Named _ _) _ = LT-compareExprs _ (Named _ _) = GT-compareExprs (InternalObj o1 ann1) (InternalObj o2 ann2) = case compare (typeOf o1) (typeOf o2) of- EQ -> case compare (typeOf ann1) (typeOf ann2) of- EQ -> case cast (o2,ann2) of- Just (o2',ann2') -> compare (o1,ann1) (o2',ann2')- r -> r- r -> r-compareExprs (InternalObj _ _) _ = LT-compareExprs _ (InternalObj _ _) = GT--instance Eq a => Eq (SMTExpr a) where- (==) x y = case eqExpr x y of- Just True -> True- _ -> False--instance SMTType t => Ord (SMTExpr t) where- compare = compareExprs--eqExpr :: SMTExpr a -> SMTExpr a -> Maybe Bool-eqExpr lhs rhs = case (lhs,rhs) of- (Var v1 _,Var v2 _) -> if v1 == v2- then Just True- else Nothing- (QVar l1 v1 _,QVar l2 v2 _) -> if l1==l2 && v1==v2- then Just True- else Nothing- (FunArg v1 _,FunArg v2 _) -> if v1==v2- then Just True- else Nothing- (Const v1 _,Const v2 _) -> Just $ v1 == v2- (AsArray f1 arg1,AsArray f2 arg2) -> case cast f2 of- Nothing -> Nothing- Just f2' -> case cast arg2 of- Nothing -> Nothing- Just arg2' -> if f1 == f2' && arg1 == arg2'- then Just True- else Nothing- (Forall l1 a1 f1,Forall l2 a2 f2) -> if l1==l2 && a1==a2- then eqExpr f1 f2- else Nothing- (Exists l1 a1 f1,Exists l2 a2 f2) -> if l1==l2 && a1==a2- then eqExpr f1 f2- else Nothing- (Let l1 a1 f1,Let l2 a2 f2) -> if l1==l2 && a1==a2- then eqExpr f1 f2- else Nothing- (Named e1 i1,Named e2 i2) -> if i1==i2- then eqExpr e1 e2- else Nothing- (App f1 arg1,App f2 arg2) -> case cast f2 of- Nothing -> Nothing- Just f2' -> case cast arg2 of- Nothing -> Nothing- Just arg2' -> if f1 == f2' && arg1 == arg2'- then Just True- else Nothing- (InternalObj o1 ann1,InternalObj o2 ann2) -> case cast (o2,ann2) of- Nothing -> Nothing- Just (o2',ann2') -> Just $ (o1 == o2') && (ann1 == ann2')- (UntypedExpr e1,UntypedExpr e2) -> case cast e2 of- Just e2' -> eqExpr e1 e2'- Nothing -> Just False- (_,_) -> Nothing--instance Eq (Constructor arg res) where- (Constructor p1 dt1 con1) == (Constructor p2 dt2 con2)- = (dataTypeName dt1 == dataTypeName dt2) &&- (p1 == p2) &&- (conName con1 == conName con2)--instance Ord (Constructor arg res) where- compare = compareConstructor--instance Eq (Field a f) where- (Field p1 dt1 con1 f1) == (Field p2 dt2 con2 f2)- = (dataTypeName dt1 == dataTypeName dt2) &&- (p1 == p2) &&- (conName con1 == conName con2) &&- (fieldName f1 == fieldName f2)--instance Ord (Field a f) where- compare = compareField--valueToConst :: DataTypeInfo -> Value -> (forall a. SMTType a => [ProxyArg] -> a -> SMTAnnotation a -> b) -> b-valueToConst _ (BoolValue c) app = app [] c ()-valueToConst _ (IntValue c) app = app [] c ()-valueToConst _ (RealValue c) app = app [] c ()-valueToConst _ (BVValue w v) app = reifyNat w (\(_::Proxy n) -> app [] (BitVector v::BitVector (BVTyped n)) ())-valueToConst dts (ConstrValue name args sort) app = case Map.lookup name (constructors dts) of- Just (con,dt,tc) -> construct con (case sort of- Nothing -> genericReplicate (argCount tc) Nothing- Just (_,pars) -> [ Just $ withSort dts par ProxyArg- | par <- pars ])- (fmap (\val -> valueToConst dts val AnyValue) args)- app
Language/SMTLib2/Internals/Interface.hs view
@@ -1,677 +1,1045 @@-{- | Defines the user-accessible interface of the smtlib2 library -}-{-# LANGUAGE TypeFamilies,OverloadedStrings,FlexibleContexts,ScopedTypeVariables,CPP,ViewPatterns #-}-module Language.SMTLib2.Internals.Interface where--import Language.SMTLib2.Internals-import Language.SMTLib2.Internals.Instances (extractAnnotation,dtList,conNil,conInsert,withSort)-import Language.SMTLib2.Internals.Optimize-import Language.SMTLib2.Internals.Operators-import Language.SMTLib2.Strategy--import Data.Typeable-import Data.Array-import Data.Unit-import Data.List (genericReplicate)-import Data.Proxy---- | Check if the model is satisfiable (e.g. if there is a value for each variable so that every assertion holds)-checkSat :: Monad m => SMT' m Bool-checkSat = checkSat' Nothing noLimits >>= return.isSat---- | Check if the model is satisfiable using a given tactic. (Works only with Z3)-checkSatUsing :: Monad m => Tactic -> SMT' m Bool-checkSatUsing t = checkSat' (Just t) noLimits >>= return.isSat---- | Like 'checkSat', but gives you more options like choosing a tactic (Z3 only) or providing memory/time-limits-checkSat' :: Monad m => Maybe Tactic -> CheckSatLimits -> SMT' m CheckSatResult-checkSat' tactic limits = smtBackend $ \b -> smtHandle b (SMTCheckSat tactic limits)--isSat :: CheckSatResult -> Bool-isSat Sat = True-isSat Unsat = False-isSat Unknown = error "smtlib2: checkSat query return 'unknown' (To catch this, use checkSat' function)"---- | Apply the given tactic to the current assertions. (Works only with Z3)-apply :: Monad m => Tactic -> SMT' m [SMTExpr Bool]-apply t = smtBackend $ \backend -> smtHandle backend (SMTApply t)---- | Push a new context on the stack-push :: Monad m => SMT' m ()-push = smtBackend $ \b -> smtHandle b SMTPush---- | Pop a new context from the stack-pop :: Monad m => SMT' m ()-pop = smtBackend $ \b -> smtHandle b SMTPop---- | Perform a stacked operation, meaning that every assertion and declaration made in it will be undone after the operation.-stack :: Monad m => SMT' m a -> SMT' m a-stack act = do- push- res <- act- pop- return res---- | Insert a comment into the SMTLib2 command stream.--- If you aren't looking at the command stream for debugging, this will do nothing.-comment :: Monad m => String -> SMT' m ()-comment msg = smtBackend $ \b -> smtHandle b (SMTComment msg)---- | Create a new named variable-varNamed :: (SMTType t,Typeable t,Unit (SMTAnnotation t),Monad m) => String -> SMT' m (SMTExpr t)-varNamed name = varNamedAnn name unit---- | Create a named and annotated variable.-varNamedAnn :: (SMTType t,Typeable t,Monad m) => String -> SMTAnnotation t -> SMT' m (SMTExpr t)-varNamedAnn = argVarsAnnNamed---- | Create a annotated variable-varAnn :: (SMTType t,Typeable t,Monad m) => SMTAnnotation t -> SMT' m (SMTExpr t)-varAnn ann = argVarsAnn ann---- | Create a fresh new variable-var :: (SMTType t,Typeable t,Unit (SMTAnnotation t),Monad m) => SMT' m (SMTExpr t)-var = argVarsAnn unit---- | Create a fresh untyped variable with a name-untypedNamedVar :: Monad m => String -> Sort -> SMT' m (SMTExpr Untyped)-untypedNamedVar name sort = do- dts <- smtBackend $ \b -> smtHandle b SMTDeclaredDataTypes- withSort dts sort $- \(_::t) ann -> do- v <- varNamedAnn name ann- return $ UntypedExpr (v::SMTExpr t)---- | Create a fresh untyped variable-untypedVar :: Monad m => Sort -> SMT' m (SMTExpr Untyped)-untypedVar sort = do- dts <- smtBackend $ \b -> smtHandle b SMTDeclaredDataTypes- withSort dts sort $- \(_::t) ann -> do- v <- varAnn ann- return $ UntypedExpr (v::SMTExpr t)---- | Like `argVarsAnnNamed`, but defaults the name to "var"-argVarsAnn :: (Args a,Monad m) => ArgAnnotation a -> SMT' m a-argVarsAnn = argVarsAnnNamed' Nothing---- | Create annotated named SMT variables of the `Args` class.--- If more than one variable is needed, they get a numerical suffix.-argVarsAnnNamed :: (Args a,Monad m) => String -> ArgAnnotation a -> SMT' m a-argVarsAnnNamed name = argVarsAnnNamed' (Just name)--argVarsAnnNamed' :: (Args a,Monad m) => Maybe String -> ArgAnnotation a -> SMT' m a-argVarsAnnNamed' name ann = do- (_,arg) <- foldExprs (\_ (_::SMTExpr t) ann' -> do- declareType (undefined::t) ann'- let info = FunInfo { funInfoProxy = Proxy::Proxy ((),t)- , funInfoArgAnn = ()- , funInfoResAnn = ann'- , funInfoName = name }- res <- smtBackend $ \b -> smtHandle b (SMTDeclareFun info)- let expr = Var res ann'- case additionalConstraints (undefined::t) ann' of- Nothing -> return ()- Just constr -> mapM_ assert $ constr expr- return ((),expr)- ) () undefined ann- return arg---- | Like `argVarsAnn`, but can only be used for unit type annotations.-argVars :: (Args a,Unit (ArgAnnotation a),Monad m) => SMT' m a-argVars = argVarsAnn unit---- | A constant expression.-constant :: (SMTValue t,Unit (SMTAnnotation t)) => t -> SMTExpr t-constant x = Const x unit---- | An annotated constant expression.-constantAnn :: SMTValue t => t -> SMTAnnotation t -> SMTExpr t-constantAnn x ann = Const x ann--getValue :: (SMTValue t,Monad m) => SMTExpr t -> SMT' m t-getValue expr = smtBackend $ \b -> smtHandle b (SMTGetValue expr)--getValues :: (LiftArgs arg,Monad m) => arg -> SMT' m (Unpacked arg)-getValues args = unliftArgs args getValue---- | Extract all assigned values of the model-getModel :: Monad m => SMT' m SMTModel-getModel = smtBackend $ \b -> smtHandle b SMTGetModel---- | Extract all values of an array by giving the range of indices.-unmangleArray :: (Liftable i,LiftArgs i,Ix (Unpacked i),SMTValue v,- Unit (ArgAnnotation i),Monad m)- => (Unpacked i,Unpacked i)- -> SMTExpr (SMTArray i v)- -> SMT' m (Array (Unpacked i) v)-unmangleArray b expr = mapM (\i -> do- v <- getValue (App SMTSelect (expr,liftArgs i unit))- return (i,v)- ) (range b) >>= return.array b---- | Define a new function with a body-defFun :: (Args a,SMTType r,Unit (ArgAnnotation a),Monad m)- => (a -> SMTExpr r) -> SMT' m (SMTFunction a r)-defFun = defFunAnn unit---- | Define a new constant.-defConst :: (SMTType r,Monad m) => SMTExpr r -> SMT' m (SMTExpr r)-defConst = defConstNamed "constvar"---- | Define a new constant with a name-defConstNamed :: (SMTType r,Monad m) => String -> SMTExpr r -> SMT' m (SMTExpr r)-defConstNamed name = defConstNamed' (Just name)--defConstNamed' :: (SMTType r,Monad m) => Maybe String -> SMTExpr r -> SMT' m (SMTExpr r)-defConstNamed' name e = do- i <- smtBackend $ \b -> smtHandle b (SMTDefineFun name (Proxy::Proxy ()) () e)- return (Var i (extractAnnotation e))---- | Define a new function with a body and custom type annotations for arguments and result.-defFunAnnNamed :: (Args a,SMTType r,Monad m)- => String -> ArgAnnotation a -> (a -> SMTExpr r) -> SMT' m (SMTFunction a r)-defFunAnnNamed name = defFunAnnNamed' (Just name)--defFunAnnNamed' :: (Args a,SMTType r,Monad m)- => Maybe String -> ArgAnnotation a -> (a -> SMTExpr r)- -> SMT' m (SMTFunction a r)-defFunAnnNamed' name ann_arg (f::a -> SMTExpr r) = do- let (_,rargs) = foldExprsId (\i _ ann -> (i+1,FunArg i ann)) 0 (undefined::a) ann_arg- body = f rargs- i <- smtBackend $ \b -> smtHandle b (SMTDefineFun name (Proxy::Proxy a) ann_arg body)- return (SMTFun i (extractAnnotation body))---- | Like `defFunAnnNamed`, but defaults the function name to "fun".-defFunAnn :: (Args a,SMTType r,Monad m)- => ArgAnnotation a -> (a -> SMTExpr r) -> SMT' m (SMTFunction a r)-defFunAnn = defFunAnnNamed' Nothing---- | Boolean conjunction-and' :: SMTFunction [SMTExpr Bool] Bool-and' = SMTLogic And--(.&&.) :: SMTExpr Bool -> SMTExpr Bool -> SMTExpr Bool-(.&&.) x y = App (SMTLogic And) [x,y]---- | Boolean disjunction-or' :: SMTFunction [SMTExpr Bool] Bool-or' = SMTLogic Or--(.||.) :: SMTExpr Bool -> SMTExpr Bool -> SMTExpr Bool-(.||.) x y = App (SMTLogic Or) [x,y]---- | Create a boolean expression that encodes that the array is equal to the supplied constant array.-arrayEquals :: (LiftArgs i,Liftable i,SMTValue v,Ix (Unpacked i),Unit (ArgAnnotation i),Unit (SMTAnnotation v))- => SMTExpr (SMTArray i v) -> Array (Unpacked i) v -> SMTExpr Bool-arrayEquals expr arr - = case [(select expr (liftArgs i unit)) .==. (constant v)- | (i,v) <- assocs arr ] of- [] -> constant True- xs -> foldl1 (.&&.) xs---- | Asserts that a boolean expression is true-assert :: Monad m => SMTExpr Bool -> SMT' m ()-assert expr = smtBackend $ \b -> smtHandle b (SMTAssert expr Nothing Nothing)---- | Create a new interpolation group-interpolationGroup :: Monad m => SMT' m InterpolationGroup-interpolationGroup = smtBackend $ \b -> smtHandle b SMTNewInterpolationGroup---- | Assert a boolean expression and track it for an unsat core call later-assertId :: Monad m => SMTExpr Bool -> SMT' m ClauseId-assertId expr = smtBackend $ \b -> do- (cid,b1) <- smtHandle b SMTNewClauseId- ((),b2) <- smtHandle b1 (SMTAssert expr Nothing (Just cid))- return (cid,b2)---- | Assert a boolean expression to be true and assign it to an interpolation group-assertInterp :: Monad m => SMTExpr Bool -> InterpolationGroup -> SMT' m ()-assertInterp expr interp = smtBackend $ \b -> smtHandle b (SMTAssert expr (Just interp) Nothing)--getInterpolant :: Monad m => [InterpolationGroup] -> SMT' m (SMTExpr Bool)-getInterpolant grps = smtBackend $ \b -> smtHandle b (SMTGetInterpolant grps)--interpolate :: Monad m => [SMTExpr Bool] -> SMT' m [SMTExpr Bool]-interpolate exprs = smtBackend $ \b -> smtHandle b (SMTInterpolate exprs)---- | Set an option for the underlying SMT solver-setOption :: Monad m => SMTOption -> SMT' m ()-setOption opt = smtBackend $ \b -> smtHandle b (SMTSetOption opt)---- | Get information about the underlying SMT solver-getInfo :: (Monad m,Typeable i) => SMTInfo i -> SMT' m i-getInfo inf = smtBackend $ \b -> smtHandle b (SMTGetInfo inf)---- | Create a new uniterpreted function with annotations for--- the argument and the return type.-funAnn :: (Liftable a,SMTType r,Monad m) => ArgAnnotation a -> SMTAnnotation r -> SMT' m (SMTFunction a r)-funAnn = funAnnNamed' Nothing---- | Create a new uninterpreted named function with annotation for--- the argument and the return type.-funAnnNamed :: (Liftable a, SMTType r,Monad m) => String -> ArgAnnotation a -> SMTAnnotation r -> SMT' m (SMTFunction a r)-funAnnNamed name = funAnnNamed' (Just name)--funAnnNamed' :: (Liftable a, SMTType r,Monad m) => Maybe String -> ArgAnnotation a -> SMTAnnotation r -> SMT' m (SMTFunction a r)-funAnnNamed' name annArg annRet- = withUndef $ \(_::a) (_::r) -> do- let finfo = FunInfo { funInfoProxy = Proxy::Proxy (a,r)- , funInfoArgAnn = annArg- , funInfoResAnn = annRet- , funInfoName = name- }- i <- smtBackend $ \b -> smtHandle b (SMTDeclareFun finfo)- let fun = SMTFun i annRet- case additionalConstraints (undefined::t) annRet of- Nothing -> return ()- Just constr -> assert $ forAllAnn annArg- (\x -> case constr (fun `app` x) of- [] -> constant True- [x] -> x- xs -> and' `app` xs)- return fun- where- withUndef :: (a -> r -> SMT' m (SMTFunction a r)) -> SMT' m (SMTFunction a r)- withUndef f = f undefined undefined---- | funAnn with an annotation only for the return type.-funAnnRet :: (Liftable a,SMTType r,Unit (ArgAnnotation a),Monad m)- => SMTAnnotation r -> SMT' m (SMTFunction a r)-funAnnRet = funAnn unit---- | Create a new uninterpreted function.-fun :: (Liftable a,SMTType r,SMTAnnotation r ~ (),Unit (ArgAnnotation a),Monad m)- => SMT' m (SMTFunction a r)-fun = funAnn unit unit---- | Apply a function to an argument-app :: (Args arg,SMTType res) => SMTFunction arg res -> arg -> SMTExpr res-app = App---- | Lift a function to arrays-map' :: (Liftable arg,Args i,SMTType res)- => SMTFunction arg res -> SMTFunction (Lifted arg i) (SMTArray i res)-map' f = SMTMap f---- | Two expressions shall be equal-(.==.) :: SMTType a => SMTExpr a -> SMTExpr a -> SMTExpr Bool-(.==.) x y = App SMTEq [x,y]--infix 4 .==.---- | A generalized version of `.==.`-argEq :: Args a => a -> a -> SMTExpr Bool-argEq xs ys = app and' res- where- (res,_,_) = foldsExprsId- (\s [(arg1,_),(arg2,_)] _ -> ((arg1 .==. arg2):s,[arg1,arg2],undefined))- []- [(xs,()),(ys,())] (extractArgAnnotation xs)---- | Declares all arguments to be distinct-distinct :: SMTType a => [SMTExpr a] -> SMTExpr Bool-distinct = App SMTDistinct---- | Calculate the sum of arithmetic expressions-plus :: (SMTArith a) => SMTFunction [SMTExpr a] a-plus = SMTArith Plus---- | Calculate the product of arithmetic expressions-mult :: (SMTArith a) => SMTFunction [SMTExpr a] a-mult = SMTArith Mult---- | Subtracts two expressions-minus :: (SMTArith a) => SMTFunction (SMTExpr a,SMTExpr a) a-minus = SMTMinus---- | Divide an arithmetic expression by another-div' :: SMTExpr Integer -> SMTExpr Integer -> SMTExpr Integer-div' x y = App (SMTIntArith Div) (x,y)--div'' :: SMTFunction (SMTExpr Integer,SMTExpr Integer) Integer-div'' = SMTIntArith Div---- | Perform a modulo operation on an arithmetic expression-mod' :: SMTExpr Integer -> SMTExpr Integer -> SMTExpr Integer-mod' x y = App (SMTIntArith Mod) (x,y)--mod'' :: SMTFunction (SMTExpr Integer,SMTExpr Integer) Integer-mod'' = SMTIntArith Mod---- | Calculate the remainder of the division of two integer expressions-rem' :: SMTExpr Integer -> SMTExpr Integer -> SMTExpr Integer-rem' x y = App (SMTIntArith Rem) (x,y)--rem'' :: SMTFunction (SMTExpr Integer,SMTExpr Integer) Integer-rem'' = SMTIntArith Rem---- | Divide a rational expression by another one-divide :: SMTExpr Rational -> SMTExpr Rational -> SMTExpr Rational-divide x y = App SMTDivide (x,y)--divide' :: SMTFunction (SMTExpr Rational,SMTExpr Rational) Rational-divide' = SMTDivide---- | For an expression @x@, this returns the expression @-x@.-neg :: SMTArith a => SMTFunction (SMTExpr a) a-neg = SMTNeg---- | Convert an integer expression to a real expression-toReal :: SMTExpr Integer -> SMTExpr Rational-toReal = App SMTToReal---- | Convert a real expression into an integer expression-toInt :: SMTExpr Rational -> SMTExpr Integer-toInt = App SMTToInt---- | If-then-else construct-ite :: (SMTType a) => SMTExpr Bool -- ^ If this expression is true- -> SMTExpr a -- ^ Then return this expression- -> SMTExpr a -- ^ Else this one- -> SMTExpr a-ite c l r = App SMTITE (c,l,r)---- | Exclusive or: Return true if exactly one argument is true.-xor :: SMTFunction [SMTExpr Bool] Bool-xor = SMTLogic XOr---- | Implication-(.=>.) :: SMTExpr Bool -- ^ If this expression is true- -> SMTExpr Bool -- ^ This one must be as well- -> SMTExpr Bool-(.=>.) x y = App (SMTLogic Implies) [x,y]---- | Negates a boolean expression-not' :: SMTExpr Bool -> SMTExpr Bool-not' = App SMTNot--not'' :: SMTFunction (SMTExpr Bool) Bool-not'' = SMTNot---- | Extracts an element of an array by its index-select :: (Liftable i,SMTType v) => SMTExpr (SMTArray i v) -> i -> SMTExpr v-select arr i = App SMTSelect (arr,i)---- | The expression @store arr i v@ stores the value /v/ in the array /arr/ at position /i/ and returns the resulting new array.-store :: (Liftable i,SMTType v) => SMTExpr (SMTArray i v) -> i -> SMTExpr v -> SMTExpr (SMTArray i v)-store arr i v = App SMTStore (arr,i,v)---- | Interpret a function /f/ from /i/ to /v/ as an array with indices /i/ and elements /v/.--- Such that: @f \`app\` j .==. select (asArray f) j@ for all indices j.-asArray :: (Args arg,Unit (ArgAnnotation arg),SMTType res)- => SMTFunction arg res -> SMTExpr (SMTArray arg res)-asArray f = AsArray f unit---- | Create an array where each element is the same.-constArray :: (Args i,SMTType v) => SMTExpr v -- ^ This element will be at every index of the array- -> ArgAnnotation i -- ^ Annotations of the index type- -> SMTExpr (SMTArray i v)-constArray e i_ann = App (SMTConstArray i_ann) e---- | Bitvector and-bvand :: (IsBitVector t) => SMTExpr (BitVector t) -> SMTExpr (BitVector t) -> SMTExpr (BitVector t)-bvand e1 e2 = App (SMTBVBin BVAnd) (e1,e2)---- | Bitvector or-bvor :: (IsBitVector t) => SMTExpr (BitVector t) -> SMTExpr (BitVector t) -> SMTExpr (BitVector t)-bvor e1 e2 = App (SMTBVBin BVOr) (e1,e2)---- | Bitvector or-bvxor :: (IsBitVector t) => SMTExpr (BitVector t) -> SMTExpr (BitVector t) -> SMTExpr (BitVector t)-bvxor e1 e2 = App (SMTBVBin BVXor) (e1,e2)---- | Bitvector not-bvnot :: (IsBitVector t) => SMTExpr (BitVector t) -> SMTExpr (BitVector t)-bvnot e = App (SMTBVUn BVNot) e---- | Bitvector signed negation-bvneg :: (IsBitVector t) => SMTExpr (BitVector t) -> SMTExpr (BitVector t)-bvneg e = App (SMTBVUn BVNeg) e---- | Bitvector addition-bvadd :: (IsBitVector t) => SMTExpr (BitVector t) -> SMTExpr (BitVector t) -> SMTExpr (BitVector t)-bvadd e1 e2 = App (SMTBVBin BVAdd) (e1,e2)---- | Bitvector subtraction-bvsub :: (IsBitVector t) => SMTExpr (BitVector t) -> SMTExpr (BitVector t) -> SMTExpr (BitVector t)-bvsub e1 e2 = App (SMTBVBin BVSub) (e1,e2)---- | Bitvector multiplication-bvmul :: (IsBitVector t) => SMTExpr (BitVector t) -> SMTExpr (BitVector t) -> SMTExpr (BitVector t)-bvmul e1 e2 = App (SMTBVBin BVMul) (e1,e2)---- | Bitvector unsigned remainder-bvurem :: (IsBitVector t) => SMTExpr (BitVector t) -> SMTExpr (BitVector t) -> SMTExpr (BitVector t)-bvurem e1 e2 = App (SMTBVBin BVURem) (e1,e2)---- | Bitvector signed remainder-bvsrem :: (IsBitVector t) => SMTExpr (BitVector t) -> SMTExpr (BitVector t) -> SMTExpr (BitVector t)-bvsrem e1 e2 = App (SMTBVBin BVSRem) (e1,e2)---- | Bitvector unsigned division-bvudiv :: (IsBitVector t) => SMTExpr (BitVector t) -> SMTExpr (BitVector t) -> SMTExpr (BitVector t)-bvudiv e1 e2 = App (SMTBVBin BVUDiv) (e1,e2)---- | Bitvector signed division-bvsdiv :: (IsBitVector t) => SMTExpr (BitVector t) -> SMTExpr (BitVector t) -> SMTExpr (BitVector t)-bvsdiv e1 e2 = App (SMTBVBin BVSDiv) (e1,e2)---- | Bitvector unsigned less-or-equal-bvule :: (IsBitVector t) => SMTExpr (BitVector t) -> SMTExpr (BitVector t) -> SMTExpr Bool-bvule e1 e2 = App (SMTBVComp BVULE) (e1,e2)---- | Bitvector unsigned less-than-bvult :: (IsBitVector t) => SMTExpr (BitVector t) -> SMTExpr (BitVector t) -> SMTExpr Bool-bvult e1 e2 = App (SMTBVComp BVULT) (e1,e2)---- | Bitvector unsigned greater-or-equal-bvuge :: (IsBitVector t) => SMTExpr (BitVector t) -> SMTExpr (BitVector t) -> SMTExpr Bool-bvuge e1 e2 = App (SMTBVComp BVUGE) (e1,e2)---- | Bitvector unsigned greater-than-bvugt :: (IsBitVector t) => SMTExpr (BitVector t) -> SMTExpr (BitVector t) -> SMTExpr Bool-bvugt e1 e2 = App (SMTBVComp BVUGT) (e1,e2)---- | Bitvector signed less-or-equal-bvsle :: (IsBitVector t) => SMTExpr (BitVector t) -> SMTExpr (BitVector t) -> SMTExpr Bool-bvsle e1 e2 = App (SMTBVComp BVSLE) (e1,e2)---- | Bitvector signed less-than-bvslt :: (IsBitVector t) => SMTExpr (BitVector t) -> SMTExpr (BitVector t) -> SMTExpr Bool-bvslt e1 e2 = App (SMTBVComp BVSLT) (e1,e2)---- | Bitvector signed greater-or-equal-bvsge :: (IsBitVector t) => SMTExpr (BitVector t) -> SMTExpr (BitVector t) -> SMTExpr Bool-bvsge e1 e2 = App (SMTBVComp BVSGE) (e1,e2)---- | Bitvector signed greater-than-bvsgt :: (IsBitVector t) => SMTExpr (BitVector t) -> SMTExpr (BitVector t) -> SMTExpr Bool-bvsgt e1 e2 = App (SMTBVComp BVSGT) (e1,e2)---- | Bitvector shift left-bvshl :: (IsBitVector t) => SMTExpr (BitVector t) -> SMTExpr (BitVector t) -> SMTExpr (BitVector t)-bvshl e1 e2 = App (SMTBVBin BVSHL) (e1,e2)---- | Bitvector logical right shift-bvlshr :: (IsBitVector t) => SMTExpr (BitVector t) -> SMTExpr (BitVector t) -> SMTExpr (BitVector t)-bvlshr e1 e2 = App (SMTBVBin BVLSHR) (e1,e2)---- | Bitvector arithmetical right shift-bvashr :: (IsBitVector t) => SMTExpr (BitVector t) -> SMTExpr (BitVector t) -> SMTExpr (BitVector t)-bvashr e1 e2 = App (SMTBVBin BVASHR) (e1,e2)---- | Concats two bitvectors into one.-bvconcat :: (Concatable t1 t2) => SMTExpr (BitVector t1) -> SMTExpr (BitVector t2) -> SMTExpr (BitVector (ConcatResult t1 t2))-bvconcat e1 e2 = App SMTConcat (e1,e2)---- | Extract a sub-vector out of a given bitvector.-bvextract :: (TypeableNat start,TypeableNat len,Extractable tp len')- => Proxy start -- ^ The start of the extracted region- -> Proxy len- -> SMTExpr (BitVector tp) -- ^ The bitvector to extract from- -> SMTExpr (BitVector len')-bvextract start len (e::SMTExpr (BitVector tp))- = App (SMTExtract start len) e--bvextract' :: Integer -> Integer -> SMTExpr (BitVector BVUntyped) -> SMTExpr (BitVector BVUntyped)-bvextract' start len = reifyNat start $- \start' -> reifyNat len $ \len' -> bvextract start' len'---- | Safely split a 16-bit bitvector into two 8-bit bitvectors.-bvsplitu16to8 :: SMTExpr BV16 -> (SMTExpr BV8,SMTExpr BV8)-bvsplitu16to8 e = (App (SMTExtract (Proxy::Proxy N8) (Proxy::Proxy N8)) e,- App (SMTExtract (Proxy::Proxy N0) (Proxy::Proxy N8)) e)---- | Safely split a 32-bit bitvector into two 16-bit bitvectors.-bvsplitu32to16 :: SMTExpr BV32 -> (SMTExpr BV16,SMTExpr BV16)-bvsplitu32to16 e = (App (SMTExtract (Proxy::Proxy N16) (Proxy::Proxy N16)) e,- App (SMTExtract (Proxy::Proxy N0) (Proxy::Proxy N16)) e)---- | Safely split a 32-bit bitvector into four 8-bit bitvectors.-bvsplitu32to8 :: SMTExpr BV32 -> (SMTExpr BV8,SMTExpr BV8,SMTExpr BV8,SMTExpr BV8)-bvsplitu32to8 e = (App (SMTExtract (Proxy::Proxy N24) (Proxy::Proxy N8)) e,- App (SMTExtract (Proxy::Proxy N16) (Proxy::Proxy N8)) e,- App (SMTExtract (Proxy::Proxy N8) (Proxy::Proxy N8)) e,- App (SMTExtract (Proxy::Proxy N0) (Proxy::Proxy N8)) e)---- | Safely split a 64-bit bitvector into two 32-bit bitvectors.-bvsplitu64to32 :: SMTExpr BV64 -> (SMTExpr BV32,SMTExpr BV32)-bvsplitu64to32 e = (App (SMTExtract (Proxy::Proxy N32) (Proxy::Proxy N32)) e,- App (SMTExtract (Proxy::Proxy N0) (Proxy::Proxy N32)) e)---- | Safely split a 64-bit bitvector into four 16-bit bitvectors.-bvsplitu64to16 :: SMTExpr BV64 -> (SMTExpr BV16,SMTExpr BV16,SMTExpr BV16,SMTExpr BV16)-bvsplitu64to16 e = (App (SMTExtract (Proxy::Proxy N48) (Proxy::Proxy N16)) e,- App (SMTExtract (Proxy::Proxy N32) (Proxy::Proxy N16)) e,- App (SMTExtract (Proxy::Proxy N16) (Proxy::Proxy N16)) e,- App (SMTExtract (Proxy::Proxy N0) (Proxy::Proxy N16)) e)---- | Safely split a 64-bit bitvector into eight 8-bit bitvectors.-bvsplitu64to8 :: SMTExpr BV64 -> (SMTExpr BV8,SMTExpr BV8,SMTExpr BV8,SMTExpr BV8,SMTExpr BV8,SMTExpr BV8,SMTExpr BV8,SMTExpr BV8)-bvsplitu64to8 e = (App (SMTExtract (Proxy::Proxy N56) (Proxy::Proxy N8)) e,- App (SMTExtract (Proxy::Proxy N48) (Proxy::Proxy N8)) e,- App (SMTExtract (Proxy::Proxy N40) (Proxy::Proxy N8)) e,- App (SMTExtract (Proxy::Proxy N32) (Proxy::Proxy N8)) e,- App (SMTExtract (Proxy::Proxy N24) (Proxy::Proxy N8)) e,- App (SMTExtract (Proxy::Proxy N16) (Proxy::Proxy N8)) e,- App (SMTExtract (Proxy::Proxy N8) (Proxy::Proxy N8)) e,- App (SMTExtract (Proxy::Proxy N0) (Proxy::Proxy N8)) e)--mkQuantified :: (Args a,SMTType b) => (Integer -> [ProxyArg] -> SMTExpr b -> SMTExpr b)- -> ArgAnnotation a -> (a -> SMTExpr b)- -> SMTExpr b-mkQuantified constr ann f = constr lvl sorts body- where- undef :: (a -> SMTExpr b) -> a- undef _ = undefined- sorts = getTypes (undef f) ann- Just (arg0,[]) = toArgs ann [InternalObj () prx- | prx <- sorts ]- body' = f arg0- lvl = quantificationLevel body'- Just (arg1,[]) = toArgs ann [QVar lvl i prx- | (i,prx) <- Prelude.zip [0..] sorts ]- body = f arg1- --- | If the supplied function returns true for all possible values, the forall quantification returns true.-forAll :: (Args a,Unit (ArgAnnotation a)) => (a -> SMTExpr Bool) -> SMTExpr Bool-forAll = forAllAnn unit---- | An annotated version of `forAll`.-forAllAnn :: Args a => ArgAnnotation a -> (a -> SMTExpr Bool) -> SMTExpr Bool-forAllAnn = mkQuantified Forall---- | If the supplied function returns true for at least one possible value, the exists quantification returns true.-exists :: (Args a,Unit (ArgAnnotation a)) => (a -> SMTExpr Bool) -> SMTExpr Bool-exists = existsAnn unit---- | An annotated version of `exists`.-existsAnn :: Args a => ArgAnnotation a -> (a -> SMTExpr Bool) -> SMTExpr Bool-existsAnn = mkQuantified Exists---- | Binds an expression to a variable.--- Can be used to prevent blowups in the command stream if expressions are used multiple times.--- @let' x f@ is functionally equivalent to @f x@.-let' :: (Args a,Unit (ArgAnnotation a),SMTType b) => a -> (a -> SMTExpr b) -> SMTExpr b-let' = letAnn unit---- | Like `let'`, but can be given an additional type annotation for the argument of the function.-letAnn :: (Args a,SMTType b) => ArgAnnotation a -> a -> (a -> SMTExpr b) -> SMTExpr b-letAnn ann arg = mkQuantified (\lvl _ body -> Let lvl args body) ann- where- args = fromArgs arg---- | Like 'let'', but can define multiple variables of the same type.-lets :: (Args a,Unit (ArgAnnotation a),SMTType b) => [a] -> ([a] -> SMTExpr b) -> SMTExpr b-lets xs = letAnn (fmap (const unit) xs) xs---- | Like 'forAll', but can quantify over more than one variable (of the same type).-forAllList :: (Args a,Unit (ArgAnnotation a)) => Integer -- ^ Number of variables to quantify- -> ([a] -> SMTExpr Bool) -- ^ Function which takes a list of the quantified variables- -> SMTExpr Bool-forAllList l = forAllAnn (genericReplicate l unit)---- | Like `exists`, but can quantify over more than one variable (of the same type).-existsList :: (Args a,Unit (ArgAnnotation a)) => Integer -- ^ Number of variables to quantify- -> ([a] -> SMTExpr Bool) -- ^ Function which takes a list of the quantified variables- -> SMTExpr Bool-existsList l = existsAnn (genericReplicate l unit)---- | Checks if the expression is formed a specific constructor.-is :: (Args arg,SMTType dt) => SMTExpr dt -> Constructor arg dt -> SMTExpr Bool-is e con = App (SMTConTest con) e---- | Access a field of an expression-(.#) :: (SMTType a,SMTType f) => SMTExpr a -> Field a f -> SMTExpr f-(.#) e f = App (SMTFieldSel f) e---- | Takes the first element of a list-head' :: (SMTType a,Unit (SMTAnnotation a)) => SMTExpr [a] -> SMTExpr a-head' = App (SMTBuiltIn "head" unit)---- | Drops the first element from a list-tail' :: (SMTType a,Unit (SMTAnnotation a)) => SMTExpr [a] -> SMTExpr [a]-tail' = App (SMTBuiltIn "tail" unit)---- | Checks if a list is empty.-isNil :: (SMTType a) => SMTExpr [a] -> SMTExpr Bool-isNil (e::SMTExpr [a]) = is e (Constructor [ProxyArg (undefined::[a]) (extractAnnotation e)] dtList conNil:: Constructor () [a])---- | Checks if a list is non-empty.-isInsert :: (SMTType a,Unit (SMTAnnotation a)) => SMTExpr [a] -> SMTExpr Bool-isInsert (e::SMTExpr [a]) = is e (Constructor [ProxyArg (undefined::[a]) (extractAnnotation e)] dtList conInsert :: Constructor (SMTExpr a,SMTExpr [a]) [a])---- | Sets the logic used for the following program (Not needed for many solvers).-setLogic :: Monad m => String -> SMT' m ()-setLogic name = smtBackend $ \b -> smtHandle b (SMTSetLogic name)---- | Given an arbitrary expression, this creates a named version of it and a name to reference it later on.-named :: (SMTType a,SMTAnnotation a ~ (),Monad m)- => String -> SMTExpr a -> SMT' m (SMTExpr a,SMTExpr a)-named name expr = do- i <- smtBackend $ \b -> smtHandle b (SMTNameExpr name expr)- return (Named expr i,Var i (extractAnnotation expr))---- | Like `named`, but defaults the name to "named".-named' :: (SMTType a,SMTAnnotation a ~ (),Monad m)- => SMTExpr a -> SMT' m (SMTExpr a,SMTExpr a)-named' = named "named"- --- | After an unsuccessful 'checkSat' this method extracts a proof from the SMT solver that the instance is unsatisfiable.-getProof :: Monad m => SMT' m (SMTExpr Bool)-getProof = smtBackend $ \b -> smtHandle b SMTGetProof---- | Use the SMT solver to simplify a given expression.--- Currently only works with Z3.-simplify :: (SMTType t,Monad m) => SMTExpr t -> SMT' m (SMTExpr t)-simplify expr = smtBackend $ \b -> smtHandle b (SMTSimplify expr)---- | After an unsuccessful 'checkSat', return a list of clauses which make the--- instance unsatisfiable.-getUnsatCore :: Monad m => SMT' m [ClauseId]-getUnsatCore = smtBackend $ \b -> smtHandle b SMTGetUnsatCore- -optimizeExpr' :: SMTExpr a -> SMTExpr a-optimizeExpr' e = case optimizeExpr e of- Nothing -> e- Just e' -> e'+module Language.SMTLib2.Internals.Interface+ (Same(),IsSMTNumber(),HasMonad(..),+ -- * Expressions+ pattern Var,+ -- ** Constants+ pattern ConstBool,pattern ConstInt,pattern ConstReal,pattern ConstBV,+ constant,asConstant,true,false,cbool,cint,creal,cbv,cbvUntyped,cdt,+ -- ** Quantification+ exists,forall,+ -- ** Functions+ pattern Fun,app,fun,+ -- *** Equality+ pattern EqLst,pattern Eq,pattern (:==:),+ eq,(.==.),+ pattern DistinctLst,pattern Distinct,pattern (:/=:),+ distinct,(./=.),+ -- *** Map+ map',+ -- *** Comparison+ pattern Ord,pattern (:>=:),pattern (:>:),pattern (:<=:),pattern (:<:),+ ord,(.>=.),(.>.),(.<=.),(.<.),+ -- *** Arithmetic+ pattern ArithLst,pattern Arith,arith,+ pattern PlusLst,pattern Plus,pattern (:+:),plus,(.+.),+ pattern MultLst,pattern Mult,pattern (:*:),mult,(.*.),+ pattern MinusLst,pattern Minus,pattern (:-:),pattern Neg,minus,(.-.),neg,+ pattern Div,pattern Mod,pattern Rem,div',mod',rem',+ pattern (:/:),(./.),+ pattern Abs,abs',+ -- *** Logic+ pattern Not,not',+ pattern LogicLst,pattern Logic,logic,+ pattern AndLst,pattern And,pattern (:&:),and',(.&.),+ pattern OrLst,pattern Or,pattern (:|:),or',(.|.),+ pattern XOrLst,pattern XOr,xor',+ pattern ImpliesLst,pattern Implies,pattern (:=>:),implies,(.=>.),+ -- *** Conversion+ pattern ToReal,pattern ToInt,toReal,toInt,+ -- *** If-then-else+ pattern ITE,ite,+ -- *** Bitvectors+ pattern BVComp,pattern BVULE,pattern BVULT,pattern BVUGE,pattern BVUGT,pattern BVSLE,pattern BVSLT,pattern BVSGE,pattern BVSGT,bvcomp,bvule,bvult,bvuge,bvugt,bvsle,bvslt,bvsge,bvsgt,+ pattern BVBin,pattern BVAdd,pattern BVSub,pattern BVMul,pattern BVURem,pattern BVSRem,pattern BVUDiv,pattern BVSDiv,pattern BVSHL,pattern BVLSHR,pattern BVASHR,pattern BVXor,pattern BVAnd,pattern BVOr,bvbin,bvadd,bvsub,bvmul,bvurem,bvsrem,bvudiv,bvsdiv,bvshl,bvlshr,bvashr,bvxor,bvand,bvor,+ pattern BVUn,pattern BVNot,pattern BVNeg,+ bvun,bvnot,bvneg,+ pattern Concat,pattern Extract,concat',extract',extractChecked,extractUntypedStart,extractUntyped,+ -- *** Arrays+ pattern Select,pattern Store,pattern ConstArray,select,select1,store,store1,constArray,+ -- *** Datatypes+ pattern Mk,mk,pattern Is,is,(.#.),+ -- *** Misc+ pattern Divisible,divisible,+ -- * Lists+ (.:.),nil+ ) where++import Language.SMTLib2.Internals.Type+import Language.SMTLib2.Internals.Type.Nat+import Language.SMTLib2.Internals.Type.List (List(..))+import qualified Language.SMTLib2.Internals.Type.List as List+import Language.SMTLib2.Internals.Expression hiding (Function(..),OrdOp(..),ArithOp(..),ArithOpInt(..),LogicOp(..),BVCompOp(..),BVBinOp(..),BVUnOp(..),Const,Var,arith,plus,minus,mult,abs')+import qualified Language.SMTLib2.Internals.Expression as E+import Language.SMTLib2.Internals.Embed++import Data.Constraint+import Data.Functor.Identity+import qualified GHC.TypeLits as TL++-- Helper classes++-- | All elements of this list must be of the same type+class Same (tps :: [Type]) where+ type SameType tps :: Type+ -- | Extract the type that all elements of the list share.+ -- This is simply the first element.+ sameType :: List Repr tps -> Repr (SameType tps)+ -- | Convert a list of same elements to an all-equal list.+ -- This is just the identity function.+ sameToAllEq :: List e tps -> List e (AllEq (SameType tps) (List.Length tps))++instance Same '[tp] where+ type SameType '[tp] = tp+ sameType (tp ::: Nil) = tp+ sameToAllEq = id++instance (Same (tp ': tps),tp ~ (SameType (tp ': tps))) => Same (tp ': tp ': tps) where+ type SameType (tp ': tp ': tps) = tp+ sameType (x ::: _) = x+ sameToAllEq (x ::: xs) = x ::: (sameToAllEq xs)++-- | Convert an all-equal list to a list of elements of same type.+-- This can fail (return 'Nothing') when the list is empty.+allEqToSame :: Repr tp -> Natural n -> List e (AllEq tp n)+ -> Maybe (Dict (Same (AllEq tp n),+ SameType (AllEq tp n) ~ tp))+allEqToSame _ Zero Nil = Nothing+allEqToSame tp (Succ Zero) (x ::: Nil) = Just Dict+allEqToSame tp (Succ (Succ n)) (x ::: y ::: ys) = do+ Dict <- allEqToSame tp (Succ n) (y ::: ys)+ return Dict++-- | The same as 'allEqToSame' but also returns the original list.+-- Only used for pattern matching.+allEqToSame' :: Repr tp -> Natural n -> List e (AllEq tp n)+ -> Maybe (Dict (Same (AllEq tp n),+ SameType (AllEq tp n) ~ tp),+ List e (AllEq tp n))+allEqToSame' tp n lst = do+ d <- allEqToSame tp n lst+ return (d,lst)++class Num (Value tp) => IsSMTNumber (tp :: Type) where+ smtNumRepr :: NumRepr tp+ smtFromInteger :: Integer -> Value tp++instance IsSMTNumber IntType where+ smtNumRepr = NumInt+ smtFromInteger n = IntValue n++instance IsSMTNumber RealType where+ smtNumRepr = NumReal+ smtFromInteger n = RealValue (fromInteger n)++class HasMonad a where+ type MatchMonad a (m :: * -> *) :: Constraint+ type MonadResult a :: *+ embedM :: (Applicative m,MatchMonad a m) => a -> m (MonadResult a)++instance HasMonad (e (tp::Type)) where+ type MatchMonad (e tp) m = ()+ type MonadResult (e tp) = e tp+ embedM = pure++instance HasMonad ((m :: * -> *) (e (tp::Type))) where+ type MatchMonad (m (e tp)) m' = m ~ m'+ type MonadResult (m (e tp)) = e tp+ embedM = id++instance HasMonad (List e (tp::[Type])) where+ type MatchMonad (List e tp) m = ()+ type MonadResult (List e tp) = List e tp+ embedM = pure++instance HasMonad (m (List e (tp::[Type]))) where+ type MatchMonad (m (List e tp)) m' = m ~ m'+ type MonadResult (m (List e tp)) = List e tp+ embedM = id++matchNumRepr :: NumRepr tp -> Dict (IsSMTNumber tp)+matchNumRepr NumInt = Dict+matchNumRepr NumReal = Dict++matchNumRepr' :: NumRepr tp -> (Dict (IsSMTNumber tp),NumRepr tp)+matchNumRepr' r = (matchNumRepr r,r)++-- Patterns++#if __GLASGOW_HASKELL__ >= 800+#define SEP ->+#define MK_SIG(PROV,REQ,NAME,LHS,RHS) pattern NAME :: REQ => PROV => LHS -> RHS+#elif __GLASGOW_HASKELL__ >= 710+#define SEP ->+#define MK_SIG(PROV,REQ,NAME,LHS,RHS) pattern NAME :: PROV => REQ => LHS -> RHS+#else+#define SEP+#define MK_SIG(PROV,REQ,NAME,LHS,RHS) pattern PROV => NAME LHS :: REQ => RHS+#endif++-- | Matches constant boolean expressions ('true' or 'false').+MK_SIG((rtp ~ BoolType),(),ConstBool,Bool,Expression v qv fun fv lv e rtp)+pattern ConstBool x = E.Const (BoolValue x)++MK_SIG((rtp ~ IntType),(),ConstInt,Integer,Expression v qv fun fv lv e rtp)+pattern ConstInt x = E.Const (IntValue x)++MK_SIG((rtp ~ RealType),(),ConstReal,Rational,Expression v qv fun fv lv e rtp)+pattern ConstReal x = E.Const (RealValue x)++MK_SIG((rtp ~ BitVecType bw),(),ConstBV,Integer SEP (BitWidth bw),Expression v qv fun fv lv e rtp)+pattern ConstBV x bw = E.Const (BitVecValue x bw)++pattern Fun f arg = App (E.Fun f) arg++MK_SIG((rtp ~ BoolType),(),EqLstP,(Repr tp) SEP [e tp],Expression v qv fun fv lv e rtp)+pattern EqLstP tp lst <- App (E.Eq tp n) (allEqToList n -> lst) where+ EqLstP tp lst = allEqFromList lst (\n -> App (E.Eq tp n))++MK_SIG((rtp ~ BoolType),(GetType e),EqLst,[e tp],Expression v qv fun fv lv e rtp)+pattern EqLst lst <- EqLstP _ lst where+ EqLst lst@(x:_) = EqLstP (getType x) lst++MK_SIG((rtp ~ BoolType,Same tps),(GetType e),Eq,List e tps,Expression v qv fun fv lv e rtp)+pattern Eq lst <- App (E.Eq tp n) (allEqToSame' tp n -> Just (Dict,lst)) where+ Eq lst = sameApp E.Eq lst++MK_SIG((rtp ~ BoolType),(GetType e),(:==:),(e tp) SEP (e tp),Expression v qv fun fv lv e rtp)+pattern (:==:) x y <- App (E.Eq _ (Succ (Succ Zero))) (x ::: y ::: Nil) where+ (:==:) x y = App (E.Eq (getType x) (Succ (Succ Zero))) (x ::: y ::: Nil)++MK_SIG((rtp ~ BoolType),(),DistinctLstP,(Repr tp) SEP [e tp],Expression v qv fun fv lv e rtp)+pattern DistinctLstP tp lst <- App (E.Distinct tp n) (allEqToList n -> lst) where+ DistinctLstP tp lst = allEqFromList lst (\n -> App (E.Distinct tp n))++MK_SIG((rtp ~ BoolType),(GetType e),DistinctLst,[e tp],Expression v qv fun fv lv e rtp)+pattern DistinctLst lst <- DistinctLstP _ lst where+ DistinctLst lst@(x:_) = DistinctLstP (getType x) lst++MK_SIG((rtp ~ BoolType,Same tps),(GetType e),Distinct,List e tps,Expression v qv fun fv lv e rtp)+pattern Distinct lst <- App (E.Distinct tp n) (allEqToSame' tp n -> Just (Dict,lst)) where+ Distinct lst = sameApp E.Distinct lst++MK_SIG((rtp ~ BoolType),(GetType e),(:/=:),(e tp) SEP (e tp),Expression v qv fun fv lv e rtp)+pattern (:/=:) x y <- App (E.Distinct _ (Succ (Succ Zero))) (x ::: y ::: Nil) where+ (:/=:) x y = App (E.Distinct (getType x) (Succ (Succ Zero))) (x ::: y ::: Nil)++MK_SIG((rtp ~ BoolType,IsSMTNumber tp),(),Ord,E.OrdOp SEP (e tp) SEP (e tp),Expression v qv fun fv lv e rtp)+pattern Ord op x y <- App (E.Ord (matchNumRepr -> Dict) op) (x ::: y ::: Nil) where+ Ord op x y = App (E.Ord smtNumRepr op) (x ::: y ::: Nil)++MK_SIG((rtp ~ BoolType,IsSMTNumber tp),(),(:>=:),(e tp) SEP (e tp),Expression v qv fun fv lv e rtp)+pattern (:>=:) x y <- App (E.Ord (matchNumRepr -> Dict) E.Ge) (x ::: y ::: Nil) where+ (:>=:) x y = App (E.Ord smtNumRepr E.Ge) (x ::: y ::: Nil)++MK_SIG((rtp ~ BoolType,IsSMTNumber tp),(),(:>:),(e tp) SEP (e tp),Expression v qv fun fv lv e rtp)+pattern (:>:) x y <- App (E.Ord (matchNumRepr -> Dict) E.Gt) (x ::: y ::: Nil) where+ (:>:) x y = App (E.Ord smtNumRepr E.Gt) (x ::: y ::: Nil)++MK_SIG((rtp ~ BoolType,IsSMTNumber tp),(),(:<=:),(e tp) SEP (e tp),Expression v qv fun fv lv e rtp)+pattern (:<=:) x y <- App (E.Ord (matchNumRepr -> Dict) E.Le) (x ::: y ::: Nil) where+ (:<=:) x y = App (E.Ord smtNumRepr E.Le) (x ::: y ::: Nil)++MK_SIG((rtp ~ BoolType,IsSMTNumber tp),(),(:<:),(e tp) SEP (e tp),Expression v qv fun fv lv e rtp)+pattern (:<:) x y <- App (E.Ord (matchNumRepr -> Dict) E.Lt) (x ::: y ::: Nil) where+ (:<:) x y = App (E.Ord smtNumRepr E.Lt) (x ::: y ::: Nil)++MK_SIG((),(),ArithLstP,E.ArithOp SEP (NumRepr tp) SEP [e tp],Expression v qv fun fv lv e tp)+pattern ArithLstP op tp lst <- App (E.Arith tp op n) (allEqToList n -> lst) where+ ArithLstP op tp lst = allEqFromList lst (\n -> App (E.Arith tp op n))++MK_SIG((IsSMTNumber tp),(),ArithLst,E.ArithOp SEP [e tp],Expression v qv fun fv lv e tp)+pattern ArithLst op lst <- ArithLstP op (matchNumRepr -> Dict) lst where+ ArithLst op lst = ArithLstP op smtNumRepr lst++MK_SIG((IsSMTNumber tp,Same tps,tp ~ SameType tps),(),Arith,E.ArithOp SEP (List e tps),Expression v qv fun fv lv e tp)+pattern Arith op lst <- App (E.Arith (matchNumRepr' -> (Dict,tp)) op n)+ (allEqToSame' (numRepr tp) n -> Just (Dict,lst)) where+ Arith op lst = App (E.Arith smtNumRepr op (List.length lst)) (sameToAllEq lst)++pattern PlusLst lst = ArithLst E.Plus lst+pattern Plus lst = Arith E.Plus lst+pattern (:+:) x y = Arith E.Plus (x ::: y ::: Nil)++pattern MinusLst lst = ArithLst E.Minus lst+pattern Minus lst = Arith E.Minus lst+pattern (:-:) x y = Arith E.Minus (x ::: y ::: Nil)+pattern Neg x = Arith E.Minus (x ::: Nil)++pattern MultLst lst = ArithLst E.Mult lst+pattern Mult lst = Arith E.Mult lst+pattern (:*:) x y = Arith E.Mult (x ::: y ::: Nil)++pattern Div x y = App (E.ArithIntBin E.Div) (x ::: y ::: Nil)+pattern Mod x y = App (E.ArithIntBin E.Mod) (x ::: y ::: Nil)+pattern Rem x y = App (E.ArithIntBin E.Rem) (x ::: y ::: Nil)++pattern (:/:) x y = App E.Divide (x ::: y ::: Nil)++MK_SIG((IsSMTNumber tp),(),Abs,e tp,Expression v qv fun fv lv e tp)+pattern Abs x <- App (E.Abs (matchNumRepr -> Dict)) (x ::: Nil) where+ Abs x = App (E.Abs smtNumRepr) (x ::: Nil)++pattern Not x = App E.Not (x ::: Nil)++MK_SIG((rtp ~ BoolType),(),LogicLst,E.LogicOp SEP [e BoolType],Expression v qv fun fv lv e rtp)+pattern LogicLst op lst <- App (E.Logic op n) (allEqToList n -> lst) where+ LogicLst op lst = allEqFromList lst (\n -> App (E.Logic op n))++MK_SIG((rtp ~ BoolType,Same tps,SameType tps ~ BoolType),(),Logic,E.LogicOp SEP (List e tps),Expression v qv fun fv lv e rtp)+pattern Logic op lst <- App (E.Logic op n) (allEqToSame' bool n -> Just (Dict,lst)) where+ Logic op lst = App (E.Logic op (List.length lst)) (sameToAllEq lst)++pattern AndLst lst = LogicLst E.And lst+pattern And lst = Logic E.And lst+MK_SIG((rtp ~ BoolType),(),(:&:),(e BoolType) SEP (e BoolType),Expression v qv fun fv lv e rtp)+pattern (:&:) x y = App (E.Logic E.And (Succ (Succ Zero))) (x ::: y ::: Nil)++pattern OrLst lst = LogicLst E.Or lst+pattern Or lst = Logic E.Or lst+MK_SIG((rtp ~ BoolType),(),(:|:),(e BoolType) SEP (e BoolType),Expression v qv fun fv lv e rtp)+pattern (:|:) x y = App (E.Logic E.Or (Succ (Succ Zero))) (x ::: y ::: Nil)++pattern XOrLst lst = LogicLst E.XOr lst+pattern XOr lst = Logic E.XOr lst++pattern ImpliesLst lst = LogicLst E.Implies lst+pattern Implies lst = Logic E.Implies lst+MK_SIG((rtp ~ BoolType),(),(:=>:),(e BoolType) SEP (e BoolType),Expression v qv fun fv lv e rtp)+pattern (:=>:) x y = App (E.Logic E.Implies (Succ (Succ Zero))) (x ::: y ::: Nil)++pattern ToReal x = App E.ToReal (x ::: Nil)+pattern ToInt x = App E.ToInt (x ::: Nil)++MK_SIG((),(GetType e),ITE,(e BoolType) SEP (e tp) SEP (e tp),Expression v qv fun fv lv e tp)+pattern ITE c ifT ifF <- App (E.ITE _) (c ::: ifT ::: ifF ::: Nil) where+ ITE c ifT ifF = App (E.ITE (getType ifT)) (c ::: ifT ::: ifF ::: Nil)++MK_SIG((rtp ~ BoolType),(GetType e),BVComp,E.BVCompOp SEP (e (BitVecType bw)) SEP (e (BitVecType bw)),Expression v qv fun fv lv e rtp)+pattern BVComp op lhs rhs <- App (E.BVComp op _) (lhs ::: rhs ::: Nil) where+ BVComp op lhs rhs = App (E.BVComp op (getBW lhs)) (lhs ::: rhs ::: Nil)++pattern BVULE lhs rhs = BVComp E.BVULE lhs rhs+pattern BVULT lhs rhs = BVComp E.BVULT lhs rhs+pattern BVUGE lhs rhs = BVComp E.BVUGE lhs rhs+pattern BVUGT lhs rhs = BVComp E.BVUGT lhs rhs+pattern BVSLE lhs rhs = BVComp E.BVSLE lhs rhs+pattern BVSLT lhs rhs = BVComp E.BVSLT lhs rhs+pattern BVSGE lhs rhs = BVComp E.BVSGE lhs rhs+pattern BVSGT lhs rhs = BVComp E.BVSGT lhs rhs++MK_SIG((rtp ~ BitVecType bw),(GetType e),BVBin,E.BVBinOp SEP (e (BitVecType bw)) SEP (e (BitVecType bw)),Expression v qv fun fv lv e rtp)+pattern BVBin op lhs rhs <- App (E.BVBin op _) (lhs ::: rhs ::: Nil) where+ BVBin op lhs rhs = App (E.BVBin op (getBW lhs)) (lhs ::: rhs ::: Nil)++pattern BVAdd lhs rhs = BVBin E.BVAdd lhs rhs+pattern BVSub lhs rhs = BVBin E.BVSub lhs rhs+pattern BVMul lhs rhs = BVBin E.BVMul lhs rhs+pattern BVURem lhs rhs = BVBin E.BVURem lhs rhs+pattern BVSRem lhs rhs = BVBin E.BVSRem lhs rhs+pattern BVUDiv lhs rhs = BVBin E.BVUDiv lhs rhs+pattern BVSDiv lhs rhs = BVBin E.BVSDiv lhs rhs+pattern BVSHL lhs rhs = BVBin E.BVSHL lhs rhs+pattern BVLSHR lhs rhs = BVBin E.BVLSHR lhs rhs+pattern BVASHR lhs rhs = BVBin E.BVASHR lhs rhs+pattern BVXor lhs rhs = BVBin E.BVXor lhs rhs+pattern BVAnd lhs rhs = BVBin E.BVAnd lhs rhs+pattern BVOr lhs rhs = BVBin E.BVOr lhs rhs++MK_SIG((rtp ~ BitVecType bw),(GetType e),BVUn,E.BVUnOp SEP (e (BitVecType bw)),Expression v qv fun fv lv e rtp)+pattern BVUn op x <- App (E.BVUn op _) (x ::: Nil) where+ BVUn op x = App (E.BVUn op (getBW x)) (x ::: Nil)++pattern BVNot x = BVUn E.BVNot x+pattern BVNeg x = BVUn E.BVNeg x++MK_SIG((rtp ~ val),(GetType e),Select,(e (ArrayType idx val)) SEP (List e idx),Expression v qv fun fv lv e rtp)+pattern Select arr idx <- App (E.Select _ _) (arr ::: idx) where+ Select arr idx = case getType arr of+ ArrayRepr idxTp elTp -> App (E.Select idxTp elTp) (arr ::: idx)++MK_SIG((rtp ~ ArrayType idx val),(GetType e),Store,(e (ArrayType idx val)) SEP (List e idx) SEP (e val),Expression v qv fun fv lv e rtp)+pattern Store arr idx el <- App (E.Store _ _) (arr ::: el ::: idx) where+ Store arr idx el = case getType arr of+ ArrayRepr idxTp elTp -> App (E.Store idxTp elTp) (arr ::: el ::: idx)++MK_SIG((rtp ~ ArrayType idx val),(GetType e),ConstArray,(List Repr idx) SEP (e val),Expression v qv fun fv lv e rtp)+pattern ConstArray idx el <- App (E.ConstArray idx _) (el ::: Nil) where+ ConstArray idx el = App (E.ConstArray idx (getType el)) (el ::: Nil)++MK_SIG((rtp ~ BitVecType (n1 TL.+ n2)),(GetType e),Concat,(e (BitVecType n1)) SEP (e (BitVecType n2)),Expression v qv fun fv lv e rtp)+pattern Concat lhs rhs <- App (E.Concat _ _) (lhs :::rhs ::: Nil) where+ Concat lhs rhs = case getType lhs of+ BitVecRepr n1 -> case getType rhs of+ BitVecRepr n2 -> App (E.Concat n1 n2) (lhs ::: rhs ::: Nil)++MK_SIG((rtp ~ BitVecType len),(GetType e),Extract,(BitWidth start) SEP (BitWidth len) SEP (e (BitVecType bw)),Expression v qv fun fv lv e rtp)+pattern Extract start len arg <- App (E.Extract _ start len) (arg ::: Nil) where+ Extract start len arg = case getType arg of+ BitVecRepr bw -> App (E.Extract bw start len) (arg ::: Nil)++MK_SIG((rtp ~ BoolType),(),Divisible,Integer SEP (e IntType),Expression v qv fun fv lv e rtp)+pattern Divisible n e = App (E.Divisible n) (e ::: Nil)++pattern Mk dt par con args = App (E.Constructor dt par con) args++MK_SIG((rtp ~ BoolType),(GetType e),Is,(Constr dt sig) SEP (e (DataType dt par)),Expression v qv fun fv lv e rtp)+pattern Is con e <- App (E.Test _ _ con) (e ::: Nil) where+ Is con e = case getType e of+ DataRepr dt par -> App (E.Test dt par con) (e ::: Nil)++{-MK_SIG((),(GetType e),(:#:),(e (DataType dt par)) SEP (Field dt tp),Expression v qv fun fv lv e (CType tp par))+pattern (:#:) e field <- App (E.Field _ _ field) (e ::: Nil) where+ (:#:) e field = case getType e of+ DataRepr dt par -> App (E.Field dt par field) (e ::: Nil)-}++sameApp :: (Same tps,GetType e)+ => (Repr (SameType tps) -> Natural (List.Length tps)+ -> E.Function fun '(AllEq (SameType tps) (List.Length tps),ret))+ -> List e tps+ -> Expression v qv fun fv lv e ret+sameApp f lst = App (f (sameType $ runIdentity $+ List.mapM (return.getType) lst+ ) (List.length lst))+ (sameToAllEq lst)++getBW :: GetType e => e (BitVecType bw) -> BitWidth bw+getBW e = case getType e of+ BitVecRepr bw -> bw++-- | Create a constant, for example an integer:+--+-- Example:+-- +-- @+-- do+-- x <- declareVar int+-- -- x is greater than 5+-- assert $ x .>. constant (IntValue 5)+-- @+constant :: (Embed m e) => Value tp -> m (e tp)+constant x = embed $ pure $ E.Const x++-- | Create a boolean constant expression.+cbool :: Embed m e => Bool -> m (e BoolType)+cbool x = embed $ pure $ E.Const (BoolValue x)++-- | Create an integer constant expression.+cint :: Embed m e => Integer -> m (e IntType)+cint x = embed $ pure $ E.Const (IntValue x)++-- | Create a real constant expression.+--+-- Example:+--+-- @+-- import Data.Ratio+--+-- x = creal (5 % 4)+-- @+creal :: Embed m e => Rational -> m (e RealType)+creal x = embed $ pure $ E.Const (RealValue x)++-- | Create a constant bitvector expression.+cbv :: Embed m e => Integer -- ^ The value (negative values will be stored in two's-complement).+ -> BitWidth bw -- ^ The bitwidth of the bitvector value.+ -> m (e (BitVecType bw))+cbv i bw = embed $ pure $ E.Const (BitVecValue i bw)++-- | Create an untyped constant bitvector expression.+cbvUntyped :: (Embed m e,Monad m) => Integer -- ^ The value (negative values will be stored in two's-complement).+ -> Integer -- ^ The bitwidth (must be >= 0).+ -> (forall bw. e (BitVecType bw) -> m b)+ -> m b+cbvUntyped val w f = case TL.someNatVal w of+ Just (TL.SomeNat rw) -> do+ bv <- embed $ pure $ E.Const (BitVecValue val (bw rw))+ f bv+ Nothing -> error "cbvUntyped: Negative bitwidth"++cdt :: (Embed m e,IsDatatype t,List.Length par ~ Parameters t)+ => t par Value -> m (e (DataType t par))+cdt v = embed $ pure $ E.Const $ DataValue v++asConstant :: Expression v qv fun fv lv e tp -> Maybe (Value tp)+asConstant (E.Const v) = Just v+asConstant _ = Nothing++MK_SIG((tp ~ rtp),(),Var,(v tp),Expression v qv fun fv lv e rtp)+pattern Var x = E.Var x++fun :: (Embed m e,HasMonad a,MatchMonad a m,MonadResult a ~ List e args)+ => EmFun m e '(args,res) -> a -> m (e res)+fun fun args = embed $ App (E.Fun fun) <$> embedM args+{-# INLINEABLE fun #-}++-- | Create an expression by applying a function to a list of arguments.+app :: (Embed m e,HasMonad a,MatchMonad a m,MonadResult a ~ List e args)+ => E.Function (EmFun m e) '(args,res)+ -> a+ -> m (e res)+app f args = embed $ App f <$> embedM args+{-# INLINEABLE app #-}++-- | Create a typed list by appending an element to the front of another list.+(.:.) :: (HasMonad a,MonadResult a ~ e tp,MatchMonad a m,Applicative m)+ => a -> m (List e tps) -> m (List e (tp ': tps))+(.:.) x xs = (:::) <$> embedM x <*> xs+{-# INLINEABLE (.:.) #-}++infixr 5 .:.++-- | Create an empty list.+nil :: Applicative m => m (List e '[])+nil = pure Nil++-- | Create a boolean expression that encodes that two expressions have the same+-- value.+--+-- Example:+--+-- @+-- is5 :: 'Language.SMTLib2.Backend' b => 'Language.SMTLib2.Expr' b 'IntType' -> 'Language.SMTLib2.SMT' b 'BoolType'+-- is5 e = e `.==.` `cint` 5+-- @+(.==.) :: (Embed m e,HasMonad a,HasMonad b,+ MatchMonad a m,MatchMonad b m,+ MonadResult a ~ e tp,MonadResult b ~ e tp)+ => a -> b -> m (e BoolType)+(.==.) lhs rhs+ = embed $ (\lhs' rhs' tp -> App (E.Eq (tp lhs') (Succ (Succ Zero))) (lhs' ::: rhs' ::: Nil)) <$>+ (embedM lhs) <*>+ (embedM rhs) <*>+ embedTypeOf+{-# INLINEABLE (.==.) #-}++(./=.) :: (Embed m e,HasMonad a,HasMonad b,+ MatchMonad a m,MatchMonad b m,+ MonadResult a ~ e tp,MonadResult b ~ e tp)+ => a -> b -> m (e BoolType)+(./=.) lhs rhs+ = embed $ (\lhs' rhs' tp -> App (E.Distinct (tp lhs') (Succ (Succ Zero))) (lhs' ::: rhs' ::: Nil)) <$>+ (embedM lhs) <*>+ (embedM rhs) <*>+ embedTypeOf+{-# INLINEABLE (./=.) #-}++infix 4 .==., ./=.++eq :: (Embed m e,HasMonad a,MatchMonad a m,MonadResult a ~ e tp)+ => [a] -> m (e BoolType)+eq [] = embed $ pure $ E.Const (BoolValue True)+eq xs = embed $ (\xs' tp -> allEqFromList xs' $ \n -> App (E.Eq (tp $ head xs') n)) <$>+ (traverse embedM xs) <*>+ embedTypeOf+{-# INLINEABLE eq #-}++distinct :: (Embed m e,HasMonad a,MatchMonad a m,MonadResult a ~ e tp)+ => [a] -> m (e BoolType)+distinct [] = embed $ pure $ E.Const (BoolValue True)+distinct xs = embed $ (\xs' tp -> allEqFromList xs' $ \n -> App (E.Distinct (tp $ head xs') n)) <$>+ (traverse embedM xs) <*>+ embedTypeOf+{-# INLINEABLE distinct #-}++map' :: (Embed m e,HasMonad arg,MatchMonad arg m,MonadResult arg ~ List e (Lifted tps idx),+ Unlift tps idx,GetType e,GetFunType (EmFun m e))+ => E.Function (EmFun m e) '(tps,res)+ -> arg+ -> m (e (ArrayType idx res))+map' f arg = embed $ (\arg' -> let (tps,res) = getFunType f+ idx = unliftTypeWith (getTypes arg') tps+ in E.App (E.Map idx f) arg') <$>+ (embedM arg)+{-# INLINEABLE map' #-}++ord :: (Embed m e,IsSMTNumber tp,HasMonad a,HasMonad b,+ MatchMonad a m,MatchMonad b m,+ MonadResult a ~ e tp,MonadResult b ~ e tp)+ => E.OrdOp -> a -> b -> m (e BoolType)+ord op lhs rhs = embed $ Ord op <$> embedM lhs <*> embedM rhs+{-# INLINEABLE ord #-}++(.>=.),(.>.),(.<=.),(.<.) :: (Embed m e,IsSMTNumber tp,HasMonad a,HasMonad b,+ MatchMonad a m,MatchMonad b m,+ MonadResult a ~ e tp,MonadResult b ~ e tp)+ => a -> b -> m (e BoolType)+(.>=.) = ord E.Ge+(.>.) = ord E.Gt+(.<=.) = ord E.Le+(.<.) = ord E.Lt+{-# INLINEABLE (.>=.) #-}+{-# INLINEABLE (.>.) #-}+{-# INLINEABLE (.<=.) #-}+{-# INLINEABLE (.<.) #-}++infix 4 .>=.,.>.,.<=.,.<.++arith :: (Embed m e,HasMonad a,MatchMonad a m,+ MonadResult a ~ e tp,IsSMTNumber tp)+ => E.ArithOp -> [a] -> m (e tp)+arith op xs = embed $ ArithLst op <$> traverse embedM xs+{-# INLINEABLE arith #-}++plus,minus,mult :: (Embed m e,HasMonad a,MatchMonad a m,+ MonadResult a ~ e tp,IsSMTNumber tp)+ => [a] -> m (e tp)+plus = arith E.Plus+minus = arith E.Minus+mult = arith E.Mult+{-# INLINEABLE plus #-}+{-# INLINEABLE minus #-}+{-# INLINEABLE mult #-}++(.+.),(.-.),(.*.) :: (Embed m e,HasMonad a,HasMonad b,+ MatchMonad a m,MatchMonad b m,+ MonadResult a ~ e tp,MonadResult b ~ e tp,+ IsSMTNumber tp)+ => a -> b -> m (e tp)+(.+.) x y = embed $ (:+:) <$> embedM x <*> embedM y+(.-.) x y = embed $ (:-:) <$> embedM x <*> embedM y+(.*.) x y = embed $ (:*:) <$> embedM x <*> embedM y+{-# INLINEABLE (.+.) #-}+{-# INLINEABLE (.-.) #-}+{-# INLINEABLE (.*.) #-}++infixl 6 .+.,.-.+infixl 7 .*.++neg :: (Embed m e,HasMonad a,MatchMonad a m,MonadResult a ~ e tp,IsSMTNumber tp)+ => a -> m (e tp)+neg x = embed $ Neg <$> embedM x+{-# INLINEABLE neg #-}++abs' :: (Embed m e,HasMonad a,MatchMonad a m,MonadResult a ~ e tp,IsSMTNumber tp)+ => a -> m (e tp)+abs' x = embed $ Abs <$> embedM x+{-# INLINEABLE abs' #-}++-- TODO: The following instances cause overlap:+{-instance (Embed m e) => Num (m (e IntType)) where+ fromInteger x = embed $ E.Const $ smtFromInteger x+ (+) x y = do+ x' <- x+ y' <- y+ embed $ x' :+: y'+ (-) x y = do+ x' <- x+ y' <- y+ embed $ x' :-: y'+ (*) x y = do+ x' <- x+ y' <- y+ embed $ x' :*: y'+ negate x = x >>= embed.Neg+ abs x = x >>= embed.Abs+ signum x = do+ x' <- x+ one <- embed $ E.Const (IntValue 1)+ negOne <- embed $ E.Const (IntValue (-1))+ zero <- embed $ E.Const (IntValue 0)+ ltZero <- embed $ x' :<: zero+ gtZero <- embed $ x' :>: zero+ cond1 <- embed $ App (E.ITE int) (ltZero ::: negOne ::: zero ::: Nil)+ embed $ App (E.ITE int) (gtZero ::: one ::: cond1 ::: Nil)++instance (Embed m e) => Num (m (e RealType)) where+ fromInteger x = embed $ E.Const $ smtFromInteger x+ (+) x y = do+ x' <- x+ y' <- y+ embed $ x' :+: y'+ (-) x y = do+ x' <- x+ y' <- y+ embed $ x' :-: y'+ (*) x y = do+ x' <- x+ y' <- y+ embed $ x' :*: y'+ negate x = x >>= embed.Neg+ abs x = x >>= embed.Abs+ signum x = do+ x' <- x+ one <- embed $ E.Const (smtFromInteger 1)+ negOne <- embed $ Neg one+ zero <- embed $ E.Const (smtFromInteger 0)+ ltZero <- embed $ x' :<: zero+ gtZero <- embed $ x' :>: zero+ cond1 <- embed $ App (E.ITE real) (ltZero ::: negOne ::: zero ::: Nil)+ embed $ App (E.ITE real) (gtZero ::: one ::: cond1 ::: Nil) -}++rem',div',mod' :: (Embed m e,HasMonad a,HasMonad b,+ MatchMonad a m,MatchMonad b m,+ MonadResult a ~ e IntType,MonadResult b ~ e IntType)+ => a -> b -> m (e IntType)+rem' x y = embed $ Rem <$> embedM x <*> embedM y+div' x y = embed $ Div <$> embedM x <*> embedM y+mod' x y = embed $ Mod <$> embedM x <*> embedM y+{-# INLINEABLE rem' #-}+{-# INLINEABLE div' #-}+{-# INLINEABLE mod' #-}++infixl 7 `div'`, `rem'`, `mod'`++(./.) :: (Embed m e,HasMonad a,HasMonad b,MatchMonad a m,MatchMonad b m,+ MonadResult a ~ e RealType,MonadResult b ~ e RealType)+ => a -> b -> m (e RealType)+(./.) x y = embed $ (:/:) <$> embedM x <*> embedM y+{-# INLINEABLE (./.) #-}++infixl 7 ./.++-- TODO: The following instances cause overlap:+{- instance Embed m e => Fractional (m (e RealType)) where+ (/) x y = do+ x' <- x+ y' <- y+ embed $ x' :/: y'+ fromRational r = embed $ E.Const $ RealValue r -}++not' :: (Embed m e,HasMonad a,MatchMonad a m,MonadResult a ~ e BoolType)+ => a -> m (e BoolType)+not' x = embed $ Not <$> embedM x+{-# INLINEABLE not' #-}++logic :: (Embed m e,HasMonad a,MatchMonad a m,MonadResult a ~ e BoolType)+ => E.LogicOp -> [a] -> m (e BoolType)+logic op lst = embed $ LogicLst op <$> traverse embedM lst+{-# INLINEABLE logic #-}++and',or',xor',implies :: (Embed m e,HasMonad a,MatchMonad a m,MonadResult a ~ e BoolType)+ => [a] -> m (e BoolType)+and' [] = true+and' [x] = embedM x+and' xs = embed $ AndLst <$> traverse embedM xs+or' [] = false+or' [x] = embedM x+or' xs = embed $ OrLst <$> traverse embedM xs+xor' xs = embed $ XOrLst <$> traverse embedM xs+implies xs = embed $ ImpliesLst <$> traverse embedM xs+{-# INLINEABLE and' #-}+{-# INLINEABLE or' #-}+{-# INLINEABLE xor' #-}+{-# INLINEABLE implies #-}++(.&.),(.|.),(.=>.) :: (Embed m e,HasMonad a,HasMonad b,+ MatchMonad a m,MatchMonad b m,+ MonadResult a ~ e BoolType,MonadResult b ~ e BoolType)+ => a -> b -> m (e BoolType)+(.&.) x y = embed $ (:&:) <$> embedM x <*> embedM y+(.|.) x y = embed $ (:|:) <$> embedM x <*> embedM y+(.=>.) x y = embed $ (:=>:) <$> embedM x <*> embedM y+{-# INLINEABLE (.&.) #-}+{-# INLINEABLE (.|.) #-}+{-# INLINEABLE (.=>.) #-}++infixr 3 .&.+infixr 2 .|.+infixr 2 .=>.++toReal :: (Embed m e,HasMonad a,MatchMonad a m,MonadResult a ~ e IntType)+ => a -> m (e RealType)+toReal x = embed $ ToReal <$> embedM x+{-# INLINEABLE toReal #-}++toInt :: (Embed m e,HasMonad a,MatchMonad a m,MonadResult a ~ e RealType)+ => a -> m (e IntType)+toInt x = embed $ ToInt <$> embedM x+{-# INLINEABLE toInt #-}++ite :: (Embed m e,HasMonad a,HasMonad b,HasMonad c,+ MatchMonad a m,MatchMonad b m,MatchMonad c m,+ MonadResult a ~ e BoolType,MonadResult b ~ e tp,MonadResult c ~ e tp)+ => a -> b -> c -> m (e tp)+ite c ifT ifF = embed $ (\c' ifT' ifF' tp -> App (E.ITE (tp ifT')) (c' ::: ifT' ::: ifF' ::: Nil)) <$>+ embedM c <*>+ embedM ifT <*>+ embedM ifF <*>+ embedTypeOf+{-# INLINEABLE ite #-}++bvcomp :: forall m e a b bw.+ (Embed m e,HasMonad a,HasMonad b,+ MatchMonad a m,MatchMonad b m,+ MonadResult a ~ e (BitVecType bw),MonadResult b ~ e (BitVecType bw))+ => E.BVCompOp -> a -> b -> m (e BoolType)+bvcomp op x y = embed $ (\x' y' tp -> case tp x' of+ BitVecRepr bw -> App (E.BVComp op bw) (x' ::: y' ::: Nil)) <$>+ embedM x <*>+ embedM y <*>+ embedTypeOf+{-# INLINEABLE bvcomp #-}++bvule,bvult,bvuge,bvugt,bvsle,bvslt,bvsge,bvsgt :: (Embed m e,HasMonad a,HasMonad b,+ MatchMonad a m,MatchMonad b m,+ MonadResult a ~ e (BitVecType bw),MonadResult b ~ e (BitVecType bw))+ => a -> b -> m (e BoolType)+bvule = bvcomp E.BVULE+bvult = bvcomp E.BVULT+bvuge = bvcomp E.BVUGE+bvugt = bvcomp E.BVUGT+bvsle = bvcomp E.BVSLE+bvslt = bvcomp E.BVSLT+bvsge = bvcomp E.BVSGE+bvsgt = bvcomp E.BVSGT+{-# INLINEABLE bvule #-}+{-# INLINEABLE bvult #-}+{-# INLINEABLE bvuge #-}+{-# INLINEABLE bvugt #-}+{-# INLINEABLE bvsle #-}+{-# INLINEABLE bvslt #-}+{-# INLINEABLE bvsge #-}+{-# INLINEABLE bvsgt #-}++bvbin :: forall m e a b bw.+ (Embed m e,HasMonad a,HasMonad b,+ MatchMonad a m,MatchMonad b m,+ MonadResult a ~ e (BitVecType bw),MonadResult b ~ e (BitVecType bw))+ => E.BVBinOp -> a -> b -> m (e (BitVecType bw))+bvbin op x y = embed $ (\x' y' tp -> case tp x' of+ BitVecRepr bw -> App (E.BVBin op bw) (x' ::: y' ::: Nil)) <$>+ embedM x <*>+ embedM y <*>+ embedTypeOf+{-# INLINEABLE bvbin #-}++bvadd,bvsub,bvmul,bvurem,bvsrem,bvudiv,bvsdiv,bvshl,bvlshr,bvashr,bvxor,bvand,bvor+ :: (Embed m e,HasMonad a,HasMonad b,+ MatchMonad a m,MatchMonad b m,+ MonadResult a ~ e (BitVecType bw),MonadResult b ~ e (BitVecType bw))+ => a -> b -> m (e (BitVecType bw))+bvadd = bvbin E.BVAdd+bvsub = bvbin E.BVSub+bvmul = bvbin E.BVMul+bvurem = bvbin E.BVURem+bvsrem = bvbin E.BVSRem+bvudiv = bvbin E.BVUDiv+bvsdiv = bvbin E.BVSDiv+bvshl = bvbin E.BVSHL+bvlshr = bvbin E.BVLSHR+bvashr = bvbin E.BVASHR+bvxor = bvbin E.BVXor+bvand = bvbin E.BVAnd+bvor = bvbin E.BVOr+{-# INLINEABLE bvadd #-}+{-# INLINEABLE bvsub #-}+{-# INLINEABLE bvmul #-}+{-# INLINEABLE bvurem #-}+{-# INLINEABLE bvsrem #-}+{-# INLINEABLE bvudiv #-}+{-# INLINEABLE bvsdiv #-}+{-# INLINEABLE bvshl #-}+{-# INLINEABLE bvlshr #-}+{-# INLINEABLE bvashr #-}+{-# INLINEABLE bvxor #-}+{-# INLINEABLE bvand #-}+{-# INLINEABLE bvor #-}++bvun :: forall m e a bw.+ (Embed m e,HasMonad a,+ MatchMonad a m,+ MonadResult a ~ e (BitVecType bw))+ => E.BVUnOp -> a -> m (e (BitVecType bw))+bvun op x = embed $ (\x' tp -> case tp x' of+ BitVecRepr bw -> App (E.BVUn op bw) (x' ::: Nil)) <$>+ embedM x <*>+ embedTypeOf+{-# INLINEABLE bvun #-}++bvnot,bvneg :: (Embed m e,HasMonad a,+ MatchMonad a m,+ MonadResult a ~ e (BitVecType bw))+ => a -> m (e (BitVecType bw))+bvnot = bvun E.BVNot+bvneg = bvun E.BVNeg+{-# INLINEABLE bvnot #-}+{-# INLINEABLE bvneg #-}++-- | Access an array element.+-- The following law holds:+--+-- @+-- select (store arr i e) i .==. e+-- @+select :: (Embed m e,HasMonad arr,MatchMonad arr m,MonadResult arr ~ e (ArrayType idx el),+ HasMonad i,MatchMonad i m,MonadResult i ~ List e idx)+ => arr -> i -> m (e el)+select arr idx = embed $ (\arr' idx' tp -> case tp arr' of+ ArrayRepr idxTp elTp -> App (E.Select idxTp elTp) (arr' ::: idx')) <$>+ embedM arr <*>+ embedM idx <*>+ embedTypeOf+{-# INLINEABLE select #-}++-- | A specialized version of 'select' when the index is just a single element.+select1 :: (Embed m e,HasMonad arr,HasMonad idx,+ MatchMonad arr m,MatchMonad idx m,+ MonadResult arr ~ e (ArrayType '[idx'] el),+ MonadResult idx ~ e idx')+ => arr -> idx -> m (e el)+select1 arr idx = select arr (idx .:. nil)+{-# INLINEABLE select1 #-}++-- | Write an element into an array and return the resulting array.+-- The following laws hold (forall i/=j):+--+-- @+-- select (store arr i e) i .==. e+-- select (store arr i e) j .==. select arr j+-- @+store :: (Embed m e,HasMonad arr,MatchMonad arr m,MonadResult arr ~ e (ArrayType idx el),+ HasMonad i,MatchMonad i m,MonadResult i ~ List e idx,+ HasMonad nel,MatchMonad nel m,MonadResult nel ~ e el)+ => arr -> i -> nel -> m (e (ArrayType idx el))+store arr idx nel = embed $ (\arr' idx' nel' tp -> case tp arr' of+ ArrayRepr idxTp elTp -> App (E.Store idxTp elTp) (arr' ::: nel' ::: idx')) <$>+ embedM arr <*>+ embedM idx <*>+ embedM nel <*>+ embedTypeOf+{-# INLINEABLE store #-}++-- | A specialized version of 'store' when the index is just a single element.+store1 :: (Embed m e,HasMonad arr,HasMonad idx,HasMonad el,+ MatchMonad arr m,MatchMonad idx m,MatchMonad el m,+ MonadResult arr ~ e (ArrayType '[idx'] el'),+ MonadResult idx ~ e idx',+ MonadResult el ~ e el')+ => arr -> idx -> el -> m (e (ArrayType '[idx'] el'))+store1 arr idx el = store arr (idx .:. nil) el+{-# INLINEABLE store1 #-}++-- | Create an array where every element is the same.+-- The following holds:+--+-- @+-- select (constArray tp e) i .==. e+-- @+constArray :: (Embed m e,HasMonad a,MatchMonad a m,MonadResult a ~ e tp)+ => List Repr idx -> a+ -> m (e (ArrayType idx tp))+constArray idx el = embed $ (\el' tp -> App (E.ConstArray idx (tp el')) (el' ::: Nil)) <$>+ embedM el <*>+ embedTypeOf+{-# INLINEABLE constArray #-}++concat' :: forall m e a b n1 n2.+ (Embed m e,HasMonad a,HasMonad b,+ MatchMonad a m,MatchMonad b m,+ MonadResult a ~ e (BitVecType n1),MonadResult b ~ e (BitVecType n2))+ => a -> b -> m (e (BitVecType (n1 TL.+ n2)))+concat' x y = embed $ f <$>+ embedM x <*>+ embedM y <*>+ embedTypeOf <*>+ embedTypeOf+ where+ f :: e (BitVecType n1) -> e (BitVecType n2)+ -> (e (BitVecType n1) -> Repr (BitVecType n1))+ -> (e (BitVecType n2) -> Repr (BitVecType n2))+ -> Expression v qv fun fv lv e (BitVecType (n1 TL.+ n2))+ f x' y' tp1 tp2 = case tp1 x' of+ BitVecRepr bw1 -> case tp2 y' of+ BitVecRepr bw2 -> App (E.Concat bw1 bw2) (x' ::: y' ::: Nil)+{-# INLINEABLE concat' #-}++extract' :: forall m e a bw start len.+ (Embed m e,HasMonad a,MatchMonad a m,+ MonadResult a ~ e (BitVecType bw),+ (start TL.+ len) TL.<= bw)+ => BitWidth start -> BitWidth len -> a+ -> m (e (BitVecType len))+extract' start len arg = embed $ f <$> embedM arg <*> embedTypeOf+ where+ f :: e (BitVecType bw) -> (e (BitVecType bw) -> Repr (BitVecType bw))+ -> Expression v qv fun fv lv e (BitVecType len)+ f arg' tp = case tp arg' of+ BitVecRepr bw -> App (E.Extract bw start len) (arg' ::: Nil)+{-# INLINEABLE extract' #-}++extractChecked :: forall m e a bw start len.+ (Embed m e,HasMonad a,MatchMonad a m,TL.KnownNat start,TL.KnownNat len,+ MonadResult a ~ e (BitVecType bw))+ => BitWidth start -> BitWidth len -> a+ -> m (e (BitVecType len))+extractChecked start len arg+ = embed $ f <$> embedM arg <*> embedTypeOf+ where+ f :: e (BitVecType bw) -> (e (BitVecType bw) -> Repr (BitVecType bw))+ -> Expression v qv fun fv lv e (BitVecType len)+ f arg' tp = case tp arg' of+ BitVecRepr bw+ | bwSize start + bwSize len <= bwSize bw+ -> App (E.Extract bw start len) (arg' ::: Nil)+ | otherwise -> error $ "extractChecked: Invalid parameters"+{-# INLINEABLE extractChecked #-}++extractUntypedStart :: forall m e a bw len.+ (Embed m e,HasMonad a,MatchMonad a m,TL.KnownNat len,+ MonadResult a ~ e (BitVecType bw))+ => Integer -> BitWidth len -> a+ -> m (e (BitVecType len))+extractUntypedStart start len arg = case TL.someNatVal start of+ Just (TL.SomeNat start') -> extractChecked (bw start') len arg+ Nothing -> error "extractUntypedStart: Negative start value"++extractUntyped :: forall m e a bw b.+ (Embed m e,Monad m,HasMonad a,MatchMonad a m,+ MonadResult a ~ e (BitVecType bw))+ => Integer -> Integer -> a+ -> (forall len. e (BitVecType len) -> m b)+ -> m b+extractUntyped start len arg f = case TL.someNatVal start of+ Just (TL.SomeNat start') -> case TL.someNatVal len of+ Just (TL.SomeNat len') -> do+ bv <- extractChecked (bw start') (bw len') arg+ f bv+ Nothing -> error "extractUntyped: Negative length"+ Nothing -> error "extractUntyped: Negative start value"++divisible :: (Embed m e,HasMonad a,MatchMonad a m,MonadResult a ~ e IntType)+ => Integer -> a -> m (e BoolType)+divisible n x = embed $ Divisible n <$> embedM x+{-# INLINEABLE divisible #-}++-- | Create the boolean expression "true".+true :: Embed m e => m (e BoolType)+true = embed $ pure $ E.Const (BoolValue True)+{-# INLINEABLE true #-}++-- | Create the boolean expression "false".+false :: Embed m e => m (e BoolType)+false = embed $ pure $ E.Const (BoolValue False)+{-# INLINEABLE false #-}++mk :: (Embed m e,HasMonad a,MatchMonad a m,+ MonadResult a ~ List e (Instantiated sig par),+ IsDatatype dt,List.Length par ~ Parameters dt)+ => Datatype dt -> List Repr par -> Constr dt sig -> a+ -> m (e (DataType dt par))+mk dt par con args = embed $ E.App (E.Constructor dt par con) <$>+ embedM args+{-# INLINEABLE mk #-}++is :: (Embed m e,HasMonad a,MatchMonad a m,MonadResult a ~ e (DataType dt par),IsDatatype dt)+ => a -> Constr dt sig -> m (e BoolType)+is e con = embed $ (\re tp -> case tp re of+ DataRepr dt par -> E.App (E.Test dt par con) ( re ::: Nil)+ ) <$>+ embedM e <*>+ embedTypeOf+{-# INLINEABLE is #-}++(.#.) :: (Embed m e,HasMonad a,MatchMonad a m,+ MonadResult a ~ e (DataType dt par),IsDatatype dt)+ => a -> Field dt tp -> m (e (CType tp par))+(.#.) e f = embed $ (\re tp -> case tp re of+ DataRepr dt par -> E.App (E.Field dt par f) (re ::: Nil)+ ) <$>+ embedM e <*>+ embedTypeOf+{-# INLINEABLE (.#.) #-}++exists :: (Embed m e,Monad m) => List Repr tps+ -> (forall m e. (Embed m e,Monad m) => List e tps -> m (e BoolType))+ -> m (e BoolType)+exists tps f = embedQuantifier Exists tps (\vars -> do+ nvars <- List.traverse (\var -> embed $ pure $ QVar var) vars+ f nvars)++forall :: (Embed m e,Monad m) => List Repr tps+ -> (forall m e. (Embed m e,Monad m) => List e tps -> m (e BoolType))+ -> m (e BoolType)+forall tps f = embedQuantifier Forall tps (\vars -> do+ nvars <- List.traverse (\var -> embed $ pure $ QVar var) vars+ f nvars)
+ Language/SMTLib2/Internals/Monad.hs view
@@ -0,0 +1,101 @@+module Language.SMTLib2.Internals.Monad where++import Language.SMTLib2.Internals.Backend as B+import Language.SMTLib2.Internals.Type++import Control.Monad.State.Strict+import Control.Exception (onException)+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Foldable (foldlM)++-- | The SMT monad is used to perform communication with the SMT solver. The+-- type of solver is given by the /b/ parameter.+newtype SMT b a = SMT { runSMT :: StateT (SMTState b) (SMTMonad b) a }++data SMTState b = SMTState { backend :: !b+ , datatypes :: !(Set String) }++instance Backend b => Functor (SMT b) where+ fmap f (SMT act) = SMT (fmap f act)++instance Backend b => Applicative (SMT b) where+ pure x = SMT (pure x)+ (<*>) (SMT fun) (SMT arg) = SMT (fun <*> arg)++instance Backend b => Monad (SMT b) where+ (>>=) (SMT act) app = SMT (act >>= (\res -> case app res of+ SMT p -> p))++instance Backend b => MonadState (SMTState b) (SMT b) where+ get = SMT get+ put x = SMT (put x)+ state act = SMT (state act)++instance (Backend b,MonadIO (SMTMonad b)) => MonadIO (SMT b) where+ liftIO act = SMT (liftIO act)++-- | Execute an SMT action on a given backend.+withBackend :: Backend b => SMTMonad b b -- ^ An action that creates a fresh backend.+ -> SMT b a -- ^ The SMT action to perform.+ -> SMTMonad b a+withBackend constr act = do+ b <- constr+ (res,nb) <- runStateT (runSMT act) (SMTState b Set.empty)+ exit (backend nb)+ return res++-- | Like `withBackend` but specialized to the 'IO' monad so exeptions can be+-- handled by gracefully exiting the solver.+withBackendExitCleanly :: (Backend b,SMTMonad b ~ IO) => IO b -> SMT b a -> IO a+withBackendExitCleanly constr (SMT act) = do+ b <- constr+ (do+ (res,nb) <- runStateT act (SMTState b Set.empty)+ exit (backend nb)+ return res) `onException` (exit b)++liftSMT :: Backend b => SMTMonad b a -> SMT b a+liftSMT act = SMT (lift act)++embedSMT :: Backend b => (b -> SMTMonad b (a,b)) -> SMT b a+embedSMT act = SMT $ do+ b <- get+ (res,nb) <- lift $ act (backend b)+ put (b { backend = nb })+ return res++embedSMT' :: Backend b => (b -> SMTMonad b b) -> SMT b ()+embedSMT' act = SMT $ do+ b <- get+ nb <- lift $ act (backend b)+ put (b { backend = nb })++registerDatatype :: (Backend b,IsDatatype dt) => Datatype dt -> SMT b ()+registerDatatype pr = do+ st <- get+ if Set.member (datatypeName pr) (datatypes st)+ then return ()+ else do+ let (ndts,deps) = dependencies (datatypes st) pr+ nb <- foldlM (\b dts -> do+ ((),nb) <- liftSMT $ B.declareDatatypes dts b+ return nb+ ) (backend st) deps+ put $ st { backend = nb+ , datatypes = ndts }++defineVar' :: (B.Backend b) => B.Expr b t -> SMT b (B.Var b t)+defineVar' e = embedSMT $ B.defineVar Nothing e++defineVarNamed' :: (B.Backend b) => String -> B.Expr b t -> SMT b (B.Var b t)+defineVarNamed' name e = embedSMT $ B.defineVar (Just name) e++declareVar' :: B.Backend b => Repr t -> SMT b (B.Var b t)+declareVar' tp = embedSMT $ B.declareVar tp Nothing++declareVarNamed' :: B.Backend b => Repr t -> String -> SMT b (B.Var b t)+declareVarNamed' tp name = embedSMT $ B.declareVar tp (Just name)
− Language/SMTLib2/Internals/Operators.hs
@@ -1,58 +0,0 @@-module Language.SMTLib2.Internals.Operators where--import Data.Typeable--data SMTOrdOp- = Ge- | Gt- | Le- | Lt- deriving (Typeable,Eq,Ord,Show)--data SMTArithOp- = Plus- | Mult- deriving (Typeable,Eq,Ord,Show)--data SMTIntArithOp = Div- | Mod- | Rem- deriving (Typeable,Eq,Ord,Show)--data SMTLogicOp = And- | Or- | XOr- | Implies- deriving (Typeable,Eq,Ord,Show)--data SMTBVCompOp- = BVULE- | BVULT- | BVUGE- | BVUGT- | BVSLE- | BVSLT- | BVSGE- | BVSGT- deriving (Typeable,Eq,Ord,Show)--data SMTBVBinOp- = BVAdd- | BVSub- | BVMul- | BVURem- | BVSRem- | BVUDiv- | BVSDiv- | BVSHL- | BVLSHR- | BVASHR- | BVXor- | BVAnd- | BVOr- deriving (Typeable,Eq,Ord,Show)--data SMTBVUnOp- = BVNot - | BVNeg- deriving (Typeable,Eq,Ord,Show)
− Language/SMTLib2/Internals/Optimize.hs
@@ -1,247 +0,0 @@-module Language.SMTLib2.Internals.Optimize (optimizeBackend,optimizeExpr) where--import Language.SMTLib2.Internals-import Language.SMTLib2.Internals.Instances (bvSigned,bvUnsigned,bvRestrict,eqExpr)-import Language.SMTLib2.Internals.Operators-import Data.Proxy-import Data.Bits-import Data.Either (partitionEithers)-import Data.Typeable (cast)--optimizeBackend :: b -> OptimizeBackend b-optimizeBackend = OptB--data OptimizeBackend b = OptB b--instance SMTBackend b m => SMTBackend (OptimizeBackend b) m where- smtHandle (OptB b) (SMTAssert expr grp cid)- = let nexpr = case optimizeExpr expr of- Just e -> e- Nothing -> expr- in case nexpr of- Const True _ -> return ((),OptB b)- _ -> do- (res,nb) <- smtHandle b (SMTAssert nexpr grp cid)- return (res,OptB nb)- smtHandle (OptB b) (SMTDefineFun name prx ann body) = do- let nbody = case optimizeExpr body of- Just e -> e- Nothing -> body- (res,nb) <- smtHandle b (SMTDefineFun name prx ann nbody)- return (res,OptB nb)- smtHandle (OptB b) (SMTGetValue expr) = do- let nexpr = case optimizeExpr expr of- Just e -> e- Nothing -> expr- (res,nb) <- smtHandle b (SMTGetValue nexpr)- return (res,OptB nb)- smtHandle (OptB b) SMTGetProof = do- (res,nb) <- smtHandle b SMTGetProof- return (case optimizeExpr res of- Just e -> e- Nothing -> res,OptB nb)- smtHandle (OptB b) (SMTSimplify expr) = do- let nexpr = case optimizeExpr expr of- Just e -> e- Nothing -> expr- (simp,nb) <- smtHandle b (SMTSimplify nexpr)- return (case optimizeExpr simp of- Nothing -> simp- Just simp' -> simp',OptB nb)- smtHandle (OptB b) (SMTGetInterpolant grps) = do- (inter,nb) <- smtHandle b (SMTGetInterpolant grps)- return (case optimizeExpr inter of- Nothing -> inter- Just e -> e,OptB nb)- smtHandle (OptB b) req = do- (res,nb) <- smtHandle b req- return (res,OptB nb)- smtGetNames (OptB b) = smtGetNames b- smtNextName (OptB b) = smtNextName b--optimizeExpr :: SMTExpr t -> Maybe (SMTExpr t)-optimizeExpr (App fun x) = let (opt,x') = foldExprsId (\opt expr ann -> case optimizeExpr expr of- Nothing -> (opt,expr)- Just expr' -> (True,expr')- ) False x (extractArgAnnotation x)- in case optimizeCall fun x' of- Nothing -> if opt- then Just $ App fun x'- else Nothing- Just res -> Just res-optimizeExpr _ = Nothing--optimizeCall :: SMTFunction arg res -> arg -> Maybe (SMTExpr res)-optimizeCall SMTEq [] = Just (Const True ())-optimizeCall SMTEq [_] = Just (Const True ())-optimizeCall SMTEq [x,y] = case eqExpr x y of- Nothing -> Nothing- Just res -> Just (Const res ())-optimizeCall SMTNot (Const x _) = Just $ Const (not x) ()-optimizeCall (SMTLogic _) [x] = Just x-optimizeCall (SMTLogic And) xs = case removeConstsOf False xs of- Just _ -> Just $ Const False ()- Nothing -> case removeConstsOf True xs of- Nothing -> case xs of- [] -> Just $ Const True ()- _ -> Nothing- Just [] -> Just $ Const True ()- Just [x] -> Just x- Just xs' -> Just $ App (SMTLogic And) xs'-optimizeCall (SMTLogic Or) xs = case removeConstsOf True xs of- Just _ -> Just $ Const True ()- Nothing -> case removeConstsOf False xs of- Nothing -> case xs of- [] -> Just $ Const False ()- _ -> Nothing- Just [] -> Just $ Const False ()- Just [x] -> Just x- Just xs' -> Just $ App (SMTLogic Or) xs'-optimizeCall (SMTLogic XOr) [] = Just $ Const False ()-optimizeCall (SMTLogic Implies) [] = Just $ Const True ()-optimizeCall (SMTLogic Implies) xs- = let (args,res) = splitLast xs- in case res of- Const True _ -> Just (Const True ())- _ -> case removeConstsOf False args of- Just _ -> Just $ Const True ()- Nothing -> case removeConstsOf True args of- Nothing -> case args of- [] -> Just res- _ -> Nothing- Just [] -> Just res- Just args' -> Just $ App (SMTLogic Implies) (args'++[res])-optimizeCall SMTITE (Const True _,ifT,_) = Just ifT-optimizeCall SMTITE (Const False _,_,ifF) = Just ifF-optimizeCall SMTITE (_,ifT,ifF) = case eqExpr ifT ifF of- Just True -> Just ifT- _ -> Nothing-optimizeCall (SMTBVBin op) args = bvBinOpOptimize op args-optimizeCall SMTConcat (Const (BitVector v1::BitVector b1) ann1,Const (BitVector v2::BitVector b2) ann2)- = Just (Const (BitVector $ (v1 `shiftL` (fromInteger $ getBVSize (Proxy::Proxy b2) ann2)) .|. v2)- (concatAnnotation (undefined::b1) (undefined::b2) ann1 ann2))-optimizeCall (SMTExtract pstart plen) (Const from@(BitVector v) ann)- = let start = reflectNat pstart 0- undefFrom :: BitVector from -> from- undefFrom _ = undefined- undefLen :: SMTExpr (BitVector len) -> len- undefLen _ = undefined- len = reflectNat plen 0- res = Const (BitVector $ (v `shiftR` (fromInteger start)) .&. (1 `shiftL` (fromInteger $ reflectNat plen 0) - 1))- (extractAnn (undefFrom from) (undefLen res) len ann)- in Just res-optimizeCall (SMTBVComp op) args = bvCompOptimize op args-optimizeCall (SMTArith op) args = case cast args of- Just args' -> case cast (intArithOptimize op args') of- Just res -> res- Nothing -> Nothing-optimizeCall SMTMinus args = case cast args of- Just args' -> case cast (intMinusOptimize args') of- Just res -> res- Nothing -> Nothing-optimizeCall (SMTOrd op) args = case cast args of- Just args' -> case cast (intCmpOptimize op args') of- Just res -> res- Nothing -> Nothing-optimizeCall _ _ = Nothing--removeConstsOf :: Bool -> [SMTExpr Bool] -> Maybe [SMTExpr Bool]-removeConstsOf val = removeItems (\e -> case e of- Const c _ -> c==val- _ -> False)--removeItems :: (a -> Bool) -> [a] -> Maybe [a]-removeItems f [] = Nothing-removeItems f (x:xs) = if f x- then (case removeItems f xs of- Nothing -> Just xs- Just xs' -> Just xs')- else (case removeItems f xs of- Nothing -> Nothing- Just xs' -> Just (x:xs'))--splitLast :: [a] -> ([a],a)-splitLast [x] = ([],x)-splitLast (x:xs) = let (xs',last) = splitLast xs- in (x:xs',last)--bvBinOpOptimize :: IsBitVector a => SMTBVBinOp -> (SMTExpr (BitVector a),SMTExpr (BitVector a)) -> Maybe (SMTExpr (BitVector a))-bvBinOpOptimize BVAdd (Const (BitVector 0) _,y) = Just y-bvBinOpOptimize BVAdd (x,Const (BitVector 0) _) = Just x-bvBinOpOptimize BVAdd (Const (BitVector x) w,Const (BitVector y) _) = Just (Const (bvRestrict (BitVector $ x+y) w) w)-bvBinOpOptimize BVAnd (Const (BitVector x) w,Const (BitVector y) _) = Just (Const (BitVector $ x .&. y) w)-bvBinOpOptimize BVOr (Const (BitVector x) w,Const (BitVector y) _) = Just (Const (BitVector $ x .|. y) w)-bvBinOpOptimize BVOr (Const (BitVector 0) _,oth) = Just oth-bvBinOpOptimize BVOr (oth,Const (BitVector 0) _) = Just oth-bvBinOpOptimize BVSHL (Const (BitVector x) w,Const (BitVector y) _)- = Just (Const (bvRestrict (BitVector $ x `shiftL` (fromInteger y)) w) w)-bvBinOpOptimize BVSHL (Const (BitVector 0) w,_) = Just (Const (BitVector 0) w)-bvBinOpOptimize BVSHL (oth,Const (BitVector 0) w) = Just oth-bvBinOpOptimize _ _ = Nothing--bvCompOptimize :: IsBitVector a => SMTBVCompOp -> (SMTExpr (BitVector a),SMTExpr (BitVector a)) -> Maybe (SMTExpr Bool)-bvCompOptimize op (Const b1 ann1,Const b2 ann2)- = Just $ Const (case op of- BVULE -> u1 <= u2- BVULT -> u1 < u2- BVUGE -> u1 >= u2- BVUGT -> u1 > u2- BVSLE -> s1 <= s2- BVSLT -> s1 < s2- BVSGE -> s1 >= s2- BVSGT -> s1 > s2) ()- where- u1 = bvUnsigned b1 ann1- u2 = bvUnsigned b2 ann2- s1 = bvSigned b1 ann1- s2 = bvSigned b2 ann2-bvCompOptimize _ _ = Nothing--intArithOptimize :: SMTArithOp -> [SMTExpr Integer] -> Maybe (SMTExpr Integer)-intArithOptimize Plus xs- = let (consts,nonconsts) = partitionEithers $ fmap (\e -> case e of- Const i _ -> Left i- _ -> Right e- ) xs- in case consts of- [] -> Nothing- [x] -> case nonconsts of- [] -> Just (Const x ())- [y] -> if x==0- then Just y- else Nothing- _ -> Nothing- _ -> let s = sum consts- in case nonconsts of- [] -> Just (Const s ())- [x] -> if s==0- then Just x- else Just (App (SMTArith Plus) [x,Const s ()])- _ -> Just (App (SMTArith Plus) (nonconsts++(if s==0- then []- else [Const s ()])))-intArithOptimize Mult xs- = let (consts,nonconsts) = partitionEithers $ fmap (\e -> case e of- Const i _ -> Left i- _ -> Right e- ) xs- in case consts of- [] -> Nothing- [_] -> Nothing- _ -> case nonconsts of- [] -> Just (Const (product consts) ())- _ -> Just (App (SMTArith Mult) (nonconsts++[Const (product consts) ()]))--intMinusOptimize :: (SMTExpr Integer,SMTExpr Integer) -> Maybe (SMTExpr Integer)-intMinusOptimize (Const x _,Const y _) = Just (Const (x-y) ())-intMinusOptimize (x,Const 0 _) = Just x-intMinusOptimize _ = Nothing--intCmpOptimize :: SMTOrdOp -> (SMTExpr Integer,SMTExpr Integer) -> Maybe (SMTExpr Bool)-intCmpOptimize op (Const x _,Const y _)- = Just (Const (case op of- Ge -> x >= y- Gt -> x > y- Le -> x <= y- Lt -> x < y) ())-intCmpOptimize _ _ = Nothing
+ Language/SMTLib2/Internals/Proof.hs view
@@ -0,0 +1,89 @@+module Language.SMTLib2.Internals.Proof where++import Language.SMTLib2.Internals.Type+import Language.SMTLib2.Internals.Type.List (List(..))+import Language.SMTLib2.Internals.Type.Nat+import Language.SMTLib2.Internals.Expression++import Data.GADT.Compare+import Data.GADT.Show+import Data.Map (Map)+import qualified Data.Map as Map+import Control.Monad.Trans+import Control.Monad.State+import Control.Monad.Except+import Control.Monad.Writer++data ProofResult (e :: Type -> *)+ = ProofExpr (e BoolType)+ | EquivSat (e BoolType) (e BoolType)++data Proof r (e :: Type -> *) p = Rule r [p] (ProofResult e)++verifyProof :: (Monad m,Ord p,Show r,Show p)+ => (p -> m (Proof r e p))+ -> (r -> [ProofResult e] -> ProofResult e -> ExceptT String m ())+ -> p+ -> StateT (Map p (ProofResult e)) (ExceptT String m) (ProofResult e)+verifyProof f v p = do+ computed <- gets (Map.lookup p)+ case computed of+ Just res -> return res+ Nothing -> do+ proof <- lift $ lift $ f p+ case proof of+ Rule r ante res -> do+ ante' <- mapM (verifyProof f v) ante+ lift $ withExceptT (\e -> "In rule "++show r++show ante++": "++e) $ v r ante' res+ modify $ Map.insert p res+ return res++renderProof :: (Monad m,Ord p,Show r)+ => (forall tp. e tp -> ShowS)+ -> (p -> m (Proof r e p))+ -> p+ -> m ShowS+renderProof renderE f p = do+ Endo res <- execWriterT (evalStateT (renderProof' renderE f p) Map.empty)+ return (showString "digraph proof {\n" . res . showString "}")++renderProof' :: (Monad m,Ord p,Show r)+ => (forall tp. e tp -> ShowS)+ -> (p -> m (Proof r e p))+ -> p+ -> StateT (Map p Int) (WriterT (Endo String) m) Int+renderProof' renderE f p = do+ rendered <- gets (Map.lookup p)+ case rendered of+ Just r -> return r+ Nothing -> do+ proof <- lift $ lift $ f p+ case proof of+ Rule r ante res -> do+ ident <- gets Map.size+ modify $ Map.insert p ident+ tell $ Endo $ showChar 'n' . shows ident . showString "_T[label=" . shows r . showString "];\n"+ tell $ Endo $ showChar 'n' . shows ident . showString "[label=\"" .+ renderProofResult renderE res . showString "\"];\n"+ tell $ Endo $ showChar 'n' . shows ident . showString "_T -> " . showChar 'n' . shows ident . showString ";\n"+ mapM_ (\pre -> do+ preId <- renderProof' renderE f pre+ tell $ Endo $ showChar 'n' . shows preId . showString " -> " . showChar 'n' . shows ident . showString "_T;\n"+ ) ante+ return ident++renderProofResult :: (forall tp. e tp -> ShowS) -> ProofResult e -> ShowS+renderProofResult f (ProofExpr e) = f e+renderProofResult f (EquivSat lhs rhs)+ = showString "(~ " . f lhs . showChar ' ' . f rhs . showChar ')'++mapProof :: (forall tp. e tp -> e' tp) -> Proof r e p -> Proof r e' p+mapProof f (Rule rule args res) = Rule rule args (mapResult res)+ where+ mapResult (ProofExpr e) = ProofExpr (f e)+ mapResult (EquivSat e1 e2) = EquivSat (f e1) (f e2)++instance GShow e => Show (ProofResult e) where+ showsPrec p (ProofExpr e) = gshowsPrec p e+ showsPrec p (EquivSat lhs rhs)+ = showString "(~ " . gshowsPrec 10 lhs . showChar ' ' . gshowsPrec 10 rhs . showChar ')'
+ Language/SMTLib2/Internals/Proof/Verify.hs view
@@ -0,0 +1,82 @@+module Language.SMTLib2.Internals.Proof.Verify where++import qualified Language.SMTLib2.Internals.Backend as B+import Language.SMTLib2.Internals.Monad+import Language.SMTLib2.Internals.Embed+import Language.SMTLib2.Internals.Proof+import Language.SMTLib2+import qualified Language.SMTLib2.Internals.Expression as E++import Data.GADT.Compare+import Data.GADT.Show+import Control.Monad.State+import Control.Monad.Except+import qualified Data.Map as Map++verifyZ3Proof :: B.Backend b => B.Proof b -> SMT b ()+verifyZ3Proof pr = do+ res <- runExceptT (evalStateT (verifyProof analyzeProof (\name args res -> do+ b <- gets backend+ verifyZ3Rule (BackendInfo b) name args res) pr) Map.empty)+ case res of+ Right _ -> return ()+ Left err -> error $ "Error in proof: "++err++verifyZ3Rule :: (GetType e,Extract i e,GEq e,Monad m,GShow e)+ => i -> String -> [ProofResult e] -> ProofResult e -> ExceptT String m ()+verifyZ3Rule _ "asserted" [] q = return ()+verifyZ3Rule i "mp" [p,impl] q = case p of+ ProofExpr p' -> case q of+ ProofExpr q' -> case impl of+ ProofExpr (extract i -> Just (Implies (rp ::: rq ::: Nil)))+ -> case geq p' rp of+ Just Refl -> case geq q' rq of+ Just Refl -> return ()+ Nothing -> throwError "right hand side of implication doesn't match result"+ Nothing -> throwError "left hand side of implication doesn't match argument"+ ProofExpr (extract i -> Just (Eq (rp ::: rq ::: Nil)))+ -> case geq p' rp of+ Just Refl -> case geq q' rq of+ Just Refl -> return ()+ Nothing -> throwError "right hand side of implication doesn't match result"+ Nothing -> throwError "left hand side of implication doesn't match argument"+ _ -> throwError "second argument isn't an implication"+ _ -> throwError "result type can't be equisatisfiable equality"+ _ -> throwError "first argument can't be equisatisfiable equality"+verifyZ3Rule i "reflexivity" [] res = case res of+ EquivSat e1 e2 -> case geq e1 e2 of+ Just Refl -> return ()+ Nothing -> throwError "arguments must be the same"+ ProofExpr (extract i -> Just (Eq (x ::: y ::: Nil)))+ -> case geq x y of+ Just Refl -> return ()+ Nothing -> throwError "arguments must be the same"+ _ -> throwError "result must be equality"+verifyZ3Rule i "symmetry" [rel] res = case rel of+ EquivSat x y -> case res of+ EquivSat y' x' -> case geq x x' of+ Just Refl -> case geq y y' of+ Just Refl -> return ()+ Nothing -> throwError "argument mismatch"+ Nothing -> throwError "argument mismatch"+ _ -> throwError "argument mismatch"+ ProofExpr (extract i -> Just (E.App r1 (x ::: y ::: Nil)))+ -> case res of+ ProofExpr (extract i -> Just (E.App r2 (ry ::: rx ::: Nil)))+ -> case geq x rx of+ Just Refl -> case geq y ry of+ Just Refl -> case geq r1 r2 of+ Just Refl -> case r1 of+ E.Eq _ _ -> return ()+ E.Logic E.And _ -> return ()+ E.Logic E.Or _ -> return ()+ E.Logic E.XOr _ -> return ()+ _ -> throwError "relation is not symmetric"+ _ -> throwError "result must be the same relation"+ _ -> throwError "argument mismatch"+ _ -> throwError "argument mismatch"+ _ -> throwError "result must be a relation"+ _ -> throwError "argument must be a relation"+--verifyZ3Rule i "transitivity"+verifyZ3Rule i name args res = error $ "Cannot verify rule "++show name++" "++show args++" => "++show res+
+ Language/SMTLib2/Internals/Type.hs view
@@ -0,0 +1,1126 @@+module Language.SMTLib2.Internals.Type where++import Language.SMTLib2.Internals.Type.Nat+import Language.SMTLib2.Internals.Type.List (List(..))+import qualified Language.SMTLib2.Internals.Type.List as List++import Data.Proxy+import Data.Typeable+import Numeric+import Data.List (genericLength,genericReplicate)+import Data.GADT.Compare+import Data.GADT.Show+import Data.Functor.Identity+import Data.Graph+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Bits+import qualified GHC.TypeLits as TL+import Unsafe.Coerce++-- | Describes the kind of all SMT types.+-- It is only used in promoted form, for a concrete representation see 'Repr'.+data Type = BoolType+ | IntType+ | RealType+ | BitVecType TL.Nat+ | ArrayType [Type] Type+ | forall a. DataType a [Type]+ | ParameterType Nat+ deriving Typeable++type family Lifted (tps :: [Type]) (idx :: [Type]) :: [Type] where+ Lifted '[] idx = '[]+ Lifted (tp ': tps) idx = (ArrayType idx tp) ': Lifted tps idx++class Unlift (tps::[Type]) (idx::[Type]) where+ unliftType :: List Repr (Lifted tps idx) -> (List Repr tps,List Repr idx)+ unliftTypeWith :: List Repr (Lifted tps idx) -> List Repr tps -> List Repr idx++instance Unlift '[tp] idx where+ unliftType (ArrayRepr idx tp ::: Nil) = (tp ::: Nil,idx)+ unliftTypeWith (ArrayRepr idx tp ::: Nil) (tp' ::: Nil) = idx++instance Unlift (t2 ': ts) idx => Unlift (t1 ': t2 ': ts) idx where+ unliftType (ArrayRepr idx tp ::: ts)+ = let (tps,idx') = unliftType ts+ in (tp ::: tps,idx)+ unliftTypeWith (ArrayRepr idx tp ::: ts) (tp' ::: tps) = idx++type family Fst (a :: (p,q)) :: p where+ Fst '(x,y) = x++type family Snd (a :: (p,q)) :: q where+ Snd '(x,y) = y++class (Typeable dt,Ord (Datatype dt),GCompare (Constr dt),GCompare (Field dt))+ => IsDatatype (dt :: [Type] -> (Type -> *) -> *) where+ type Parameters dt :: Nat+ type Signature dt :: [[Type]]+ data Datatype dt :: *+ data Constr dt (csig :: [Type])+ data Field dt (tp :: Type)+ -- | Get the data type from a value+ datatypeGet :: (GetType e,List.Length par ~ Parameters dt)+ => dt par e -> (Datatype dt,List Repr par)+ -- | How many polymorphic parameters does this datatype have+ parameters :: Datatype dt -> Natural (Parameters dt)+ -- | The name of the datatype. Must be unique.+ datatypeName :: Datatype dt -> String+ -- | Get all of the constructors of this datatype+ constructors :: Datatype dt -> List (Constr dt) (Signature dt)+ -- | Get the name of a constructor+ constrName :: Constr dt csig -> String+ -- | Test if a value is constructed using a specific constructor+ test :: dt par e -> Constr dt csig -> Bool+ -- | Get all the fields of a constructor+ fields :: Constr dt csig -> List (Field dt) csig+ -- | Construct a value using a constructor+ construct :: (List.Length par ~ Parameters dt)+ => List Repr par+ -> Constr dt csig+ -> List e (Instantiated csig par)+ -> dt par e+ -- | Deconstruct a value into a constructor and a list of arguments+ deconstruct :: GetType e => dt par e -> ConApp dt par e+ -- | Get the name of a field+ fieldName :: Field dt tp -> String+ -- | Get the type of a field+ fieldType :: Field dt tp -> Repr tp+ -- | Extract a field value from a value+ fieldGet :: dt par e -> Field dt tp -> e (CType tp par)++type family CType (tp :: Type) (par :: [Type]) :: Type where+ CType 'BoolType par = 'BoolType+ CType 'IntType par = 'IntType+ CType 'RealType par = 'RealType+ CType ('BitVecType w) par = 'BitVecType w+ CType ('ArrayType idx el) par = 'ArrayType (Instantiated idx par) (CType el par)+ CType ('DataType dt arg) par = 'DataType dt (Instantiated arg par)+ CType ('ParameterType n) par = List.Index par n++type family Instantiated (sig :: [Type]) (par :: [Type]) :: [Type] where+ Instantiated '[] par = '[]+ Instantiated (tp ': tps) par = (CType tp par) ': Instantiated tps par++data ConApp dt par e+ = forall csig.+ (List.Length par ~ Parameters dt) =>+ ConApp { parameters' :: List Repr par+ , constructor :: Constr dt csig+ , arguments :: List e (Instantiated csig par) }++--data FieldType tp where+-- FieldType :: Repr tp -> FieldType ('Left tp)+-- ParType :: Natural n -> FieldType ('Right n)++data AnyDatatype = forall dt. IsDatatype dt => AnyDatatype (Datatype dt)+data AnyConstr = forall dt csig. IsDatatype dt => AnyConstr (Datatype dt) (Constr dt csig)+data AnyField = forall dt csig tp. IsDatatype dt => AnyField (Datatype dt) (Field dt tp)++data TypeRegistry dt con field = TypeRegistry { allDatatypes :: Map dt AnyDatatype+ , revDatatypes :: Map AnyDatatype dt+ , allConstructors :: Map con AnyConstr+ , revConstructors :: Map AnyConstr con+ , allFields :: Map field AnyField+ , revFields :: Map AnyField field }++emptyTypeRegistry :: TypeRegistry dt con field+emptyTypeRegistry = TypeRegistry Map.empty Map.empty Map.empty Map.empty Map.empty Map.empty++dependencies :: IsDatatype dt+ => Set String -- ^ Already registered datatypes+ -> Datatype dt+ -> (Set String,[[AnyDatatype]])+dependencies known p = (known',dts)+ where+ dts = fmap (\scc -> fmap (\(dt,_,_) -> dt) $ flattenSCC scc) sccs+ sccs = stronglyConnCompR edges+ (known',edges) = dependencies' known p+ + dependencies' :: IsDatatype dt => Set String -> Datatype dt+ -> (Set String,[(AnyDatatype,String,[String])])+ dependencies' known dt+ | Set.member (datatypeName dt) known = (known,[])+ | otherwise = let name = datatypeName dt+ known1 = Set.insert name known+ deps = dependenciesCons (constructors dt)+ (known2,edges) = foldl (\(cknown,cedges) (AnyDatatype dt)+ -> dependencies' cknown dt+ ) (known1,[])+ deps+ in (known2,(AnyDatatype dt,name,[ datatypeName dt | AnyDatatype dt <- deps ]):edges)++ dependenciesCons :: IsDatatype dt => List (Constr dt) tps+ -> [AnyDatatype]+ dependenciesCons Nil = []+ dependenciesCons (con ::: cons)+ = let dep1 = dependenciesFields (fields con)+ dep2 = dependenciesCons cons+ in dep1++dep2++ dependenciesFields :: IsDatatype dt => List (Field dt) tps+ -> [AnyDatatype]+ dependenciesFields Nil = []+ dependenciesFields (f ::: fs)+ = let dep1 = dependenciesTp (fieldType f)+ dep2 = dependenciesFields fs+ in dep1++dep2++ dependenciesTp :: Repr tp+ -> [AnyDatatype]+ dependenciesTp (ArrayRepr idx el)+ = let dep1 = dependenciesTps idx+ dep2 = dependenciesTp el+ in dep1++dep2+ dependenciesTp (DataRepr dt par)+ = let dep1 = [AnyDatatype dt]+ dep2 = dependenciesTps par+ in dep1++dep2+ dependenciesTp _ = []++ dependenciesTps :: List Repr tps+ -> [AnyDatatype]+ dependenciesTps Nil = []+ dependenciesTps (tp ::: tps)+ = let dep1 = dependenciesTp tp+ dep2 = dependenciesTps tps+ in dep1++dep2++signature :: IsDatatype dt => Datatype dt -> List (List Repr) (Signature dt)+signature dt+ = runIdentity $ List.mapM (\con -> List.mapM (\f -> return (fieldType f)+ ) (fields con)+ ) (constructors dt)++constrSig :: IsDatatype dt => Constr dt sig -> List Repr sig+constrSig constr+ = runIdentity $ List.mapM (\f -> return (fieldType f)) (fields constr)++instantiate :: List Repr sig+ -> List Repr par+ -> (List Repr (Instantiated sig par),+ List.Length sig :~: List.Length (Instantiated sig par))+instantiate Nil _ = (Nil,Refl)+instantiate (tp ::: tps) par = case instantiate tps par of+ (ntps,Refl) -> (ctype tp par ::: ntps,Refl)++ctype :: Repr tp+ -> List Repr par+ -> Repr (CType tp par)+ctype BoolRepr _ = BoolRepr+ctype IntRepr _ = IntRepr+ctype RealRepr _ = RealRepr+ctype (BitVecRepr w) _ = BitVecRepr w+ctype (ArrayRepr idx el) par = case instantiate idx par of+ (nidx,Refl) -> ArrayRepr nidx (ctype el par)+ctype (DataRepr dt args) par = case instantiate args par of+ (nargs,Refl) -> DataRepr dt nargs+ctype (ParameterRepr p) par = List.index par p++determines :: IsDatatype dt+ => Datatype dt+ -> Constr dt sig+ -> Bool+determines dt con = allDetermined (fromInteger $ naturalToInteger $+ parameters dt) $+ determines' (fields con) Set.empty+ where+ determines' :: IsDatatype dt => List (Field dt) tps+ -> Set Integer -> Set Integer+ determines' Nil mp = mp+ determines' (f ::: fs) mp = determines' fs (containedParameter (fieldType f) mp)++ allDetermined sz mp = Set.size mp == sz++containedParameter :: Repr tp -> Set Integer -> Set Integer+containedParameter (ArrayRepr idx el) det+ = runIdentity $ List.foldM (\det tp -> return $ containedParameter tp det+ ) (containedParameter el det) idx+containedParameter (DataRepr i args) det+ = runIdentity $ List.foldM (\det tp -> return $ containedParameter tp det+ ) det args+containedParameter (ParameterRepr p) det+ = Set.insert (naturalToInteger p) det+containedParameter _ det = det++typeInference :: Repr atp -- ^ The type containing parameters+ -> Repr ctp -- ^ The concrete type without parameters+ -> (forall n ntp. Natural n -> Repr ntp -> a -> Maybe a) -- ^ Action to execute when a parameter is assigned+ -> a+ -> Maybe a+typeInference BoolRepr BoolRepr _ x = Just x+typeInference IntRepr IntRepr _ x = Just x+typeInference RealRepr RealRepr _ x = Just x+typeInference (BitVecRepr w1) (BitVecRepr w2) _ x = do+ Refl <- geq w1 w2+ return x+typeInference (ParameterRepr n) tp f x = f n tp x+typeInference (ArrayRepr idx el) (ArrayRepr idx' el') f x = do+ x1 <- typeInferences idx idx' f x+ typeInference el el' f x1+typeInference (DataRepr (_::Datatype dt) par) (DataRepr (_::Datatype dt') par') f x = do+ Refl <- eqT :: Maybe (dt :~: dt')+ typeInferences par par' f x+typeInference _ _ _ _ = Nothing++typeInferences :: List Repr atps+ -> List Repr ctps+ -> (forall n ntp. Natural n -> Repr ntp -> a -> Maybe a)+ -> a+ -> Maybe a+typeInferences Nil Nil _ x = Just x+typeInferences (atp ::: atps) (ctp ::: ctps) f x = do+ x1 <- typeInference atp ctp f x+ typeInferences atps ctps f x1+typeInferences _ _ _ _ = Nothing++partialInstantiation :: Repr tp+ -> (forall n a. Natural n ->+ (forall ntp. Repr ntp -> a) -> Maybe a)+ -> (forall rtp. Repr rtp -> a)+ -> a+partialInstantiation BoolRepr _ res = res BoolRepr+partialInstantiation IntRepr _ res = res IntRepr+partialInstantiation RealRepr _ res = res RealRepr+partialInstantiation (BitVecRepr w) _ res = res (BitVecRepr w)+partialInstantiation (ArrayRepr idx el) f res+ = partialInstantiations idx f $+ \nidx -> partialInstantiation el f $+ \nel -> res $ ArrayRepr nidx nel+partialInstantiation (DataRepr dt par) f res+ = partialInstantiations par f $+ \npar -> res $ DataRepr dt npar+partialInstantiation (ParameterRepr n) f res+ = case f n res of+ Just r -> r+ Nothing -> res (ParameterRepr n)++partialInstantiations :: List Repr tp+ -> (forall n a. Natural n ->+ (forall ntp. Repr ntp -> a) -> Maybe a)+ -> (forall rtp. List.Length tp ~ List.Length rtp+ => List Repr rtp -> a)+ -> a+partialInstantiations Nil _ res = res Nil+partialInstantiations (tp ::: tps) f res+ = partialInstantiation tp f $+ \ntp -> partialInstantiations tps f $+ \ntps -> res (ntp ::: ntps)+++registerType :: (Monad m,IsDatatype tp,Ord dt,Ord con,Ord field) => dt+ -> (forall sig. Constr tp sig -> m con)+ -> (forall sig tp'. Field tp tp' -> m field)+ -> Datatype tp -> TypeRegistry dt con field+ -> m (TypeRegistry dt con field)+registerType i f g dt reg+ = List.foldM+ (\reg con -> do+ c <- f con+ let reg' = reg { allConstructors = Map.insert c (AnyConstr dt con) (allConstructors reg) }+ List.foldM (\reg field -> do+ fi <- g field+ return $ reg { allFields = Map.insert fi (AnyField dt field) (allFields reg) }+ ) reg' (fields con)+ ) reg1 (constructors dt)+ where+ reg1 = reg { allDatatypes = Map.insert i (AnyDatatype dt) (allDatatypes reg)+ , revDatatypes = Map.insert (AnyDatatype dt) i (revDatatypes reg) }++registerTypeName :: IsDatatype dt => Datatype dt+ -> TypeRegistry String String String+ -> TypeRegistry String String String+registerTypeName dt reg = runIdentity (registerType (datatypeName dt) (return . constrName) (return . fieldName) dt reg)++instance Eq AnyDatatype where+ (==) (AnyDatatype x) (AnyDatatype y) = datatypeName x == datatypeName y++instance Eq AnyConstr where+ (==) (AnyConstr _ c1) (AnyConstr _ c2) = constrName c1 == constrName c2++instance Eq AnyField where+ (==) (AnyField _ f1) (AnyField _ f2) = fieldName f1 == fieldName f2++instance Ord AnyDatatype where+ compare (AnyDatatype x) (AnyDatatype y) = compare (datatypeName x) (datatypeName y)++instance Ord AnyConstr where+ compare (AnyConstr _ c1) (AnyConstr _ c2) = compare (constrName c1) (constrName c2)++instance Ord AnyField where+ compare (AnyField _ f1) (AnyField _ f2) = compare (fieldName f1) (fieldName f2)++data DynamicDatatype (par :: Nat) (sig :: [[Type]])+ = DynDatatype { dynDatatypeParameters :: Natural par+ , dynDatatypeSig :: List (DynamicConstructor sig) sig+ , dynDatatypeName :: String }+ deriving (Eq,Ord)++data DynamicConstructor+ (sig :: [[Type]])+ (csig :: [Type]) where+ DynConstructor :: Natural idx -> String+ -> List (DynamicField sig) (List.Index sig idx)+ -> DynamicConstructor sig (List.Index sig idx)++data DynamicField+ (sig :: [[Type]])+ (tp :: Type) where+ DynField :: Natural idx -> Natural fidx -> String+ -> Repr (List.Index (List.Index sig idx) fidx)+ -> DynamicField sig (List.Index (List.Index sig idx) fidx)++data DynamicValue+ (plen :: Nat)+ (sig :: [[Type]])+ (par :: [Type]) e where+ DynValue :: DynamicDatatype (List.Length par) sig+ -> List Repr par+ -> DynamicConstructor sig csig+ -> List e (Instantiated csig par)+ -> DynamicValue (List.Length par) sig par e++instance (Typeable l,Typeable sig) => IsDatatype (DynamicValue l sig) where+ type Parameters (DynamicValue l sig) = l+ type Signature (DynamicValue l sig) = sig+ newtype Datatype (DynamicValue l sig)+ = DynDatatypeInfo { dynDatatypeInfo :: DynamicDatatype l sig }+ deriving (Eq,Ord)+ data Constr (DynamicValue l sig) csig+ = DynConstr (DynamicDatatype l sig) (DynamicConstructor sig csig)+ newtype Field (DynamicValue l sig) tp+ = DynField' (DynamicField sig tp)+ parameters = dynDatatypeParameters . dynDatatypeInfo+ datatypeGet (DynValue dt par _ _) = (DynDatatypeInfo dt,par)+ datatypeName = dynDatatypeName . dynDatatypeInfo+ constructors (DynDatatypeInfo dt) = runIdentity $ List.mapM+ (\con -> return (DynConstr dt con))+ (dynDatatypeSig dt)+ constrName (DynConstr _ (DynConstructor _ n _)) = n+ test (DynValue _ _ (DynConstructor n _ _) _)+ (DynConstr _ (DynConstructor m _ _))+ = case geq n m of+ Just Refl -> True+ Nothing -> False+ fields (DynConstr _ (DynConstructor _ _ fs)) = runIdentity $ List.mapM+ (\f -> return (DynField' f)) fs+ construct par (DynConstr dt con) args+ = DynValue dt par con args+ deconstruct (DynValue dt par con args) = ConApp par (DynConstr dt con) args+ fieldName (DynField' (DynField _ _ n _)) = n+ fieldType (DynField' (DynField _ _ _ tp)) = tp+ fieldGet (DynValue dt par con@(DynConstructor cidx _ fs) args)+ (DynField' (DynField cidx' fidx _ _))+ = case geq cidx cidx' of+ Just Refl -> index par fs args fidx+ where+ index :: List Repr par+ -> List (DynamicField sig) csig+ -> List e (Instantiated csig par)+ -> Natural n+ -> e (CType (List.Index csig n) par)+ index _ (_ ::: _) (tp ::: _) Zero = tp+ index par (_ ::: sig) (_ ::: tps) (Succ n) = index par sig tps n++instance Show (Datatype (DynamicValue l sig)) where+ showsPrec p (DynDatatypeInfo dt) = showString (dynDatatypeName dt)++instance GEq (DynamicConstructor sig) where+ geq (DynConstructor i1 _ _) (DynConstructor i2 _ _) = do+ Refl <- geq i1 i2+ return Refl++instance GCompare (DynamicConstructor sig) where+ gcompare (DynConstructor i1 _ _) (DynConstructor i2 _ _)+ = case gcompare i1 i2 of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT++instance GEq (Constr (DynamicValue l sig)) where+ geq (DynConstr _ (DynConstructor n _ _)) (DynConstr _ (DynConstructor m _ _)) = do+ Refl <- geq n m+ return Refl++instance GCompare (Constr (DynamicValue l sig)) where+ gcompare (DynConstr _ (DynConstructor n _ _))+ (DynConstr _ (DynConstructor m _ _)) = case gcompare n m of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT++instance GEq (Field (DynamicValue l sig)) where+ geq (DynField' (DynField cidx1 fidx1 _ _))+ (DynField' (DynField cidx2 fidx2 _ _)) = do+ Refl <- geq cidx1 cidx2+ Refl <- geq fidx1 fidx2+ return Refl++instance GCompare (Field (DynamicValue l sig)) where+ gcompare (DynField' (DynField cidx1 fidx1 _ _))+ (DynField' (DynField cidx2 fidx2 _ _))+ = case gcompare cidx1 cidx2 of+ GEQ -> case gcompare fidx1 fidx2 of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT+ GLT -> GLT+ GGT -> GGT++newtype BitWidth (bw :: TL.Nat) = BitWidth { bwSize :: Integer }++getBw :: Integer -> (forall bw. TL.KnownNat bw => BitWidth bw -> a) -> a+getBw w f = case TL.someNatVal w of+ Just (TL.SomeNat (_::Proxy bw))+ -> f (BitWidth w::BitWidth bw)++-- | Values that can be used as constants in expressions.+data Value (a :: Type) where+ BoolValue :: Bool -> Value BoolType+ IntValue :: Integer -> Value IntType+ RealValue :: Rational -> Value RealType+ BitVecValue :: Integer+ -> BitWidth bw+ -> Value (BitVecType bw)+ DataValue :: (IsDatatype dt,List.Length par ~ Parameters dt)+ => dt par Value -> Value (DataType dt par)++#if __GLASGOW_HASKELL__ >= 800+pattern ConstrValue :: ()+ => (List.Length par ~ Parameters dt,a ~ DataType dt par,IsDatatype dt)+#else+pattern ConstrValue :: (List.Length par ~ Parameters dt,a ~ DataType dt par,IsDatatype dt)+ => ()+#endif+ => List Repr par+ -> Constr dt csig+ -> List Value (Instantiated csig par)+ -> Value a+pattern ConstrValue par con args <- DataValue (deconstruct -> ConApp par con args) where+ ConstrValue par con args = DataValue (construct par con args)++data AnyValue = forall (t :: Type). AnyValue (Value t)++-- | A concrete representation of an SMT type.+-- For aesthetic reasons, it's recommended to use the functions 'bool', 'int', 'real', 'bitvec' or 'array'.+data Repr (t :: Type) where+ BoolRepr :: Repr BoolType+ IntRepr :: Repr IntType+ RealRepr :: Repr RealType+ BitVecRepr :: BitWidth bw -> Repr (BitVecType bw)+ ArrayRepr :: List Repr idx -> Repr val -> Repr (ArrayType idx val)+ DataRepr :: (IsDatatype dt,List.Length par ~ Parameters dt) => Datatype dt -> List Repr par -> Repr (DataType dt par)+ ParameterRepr :: Natural p -> Repr (ParameterType p)++data NumRepr (t :: Type) where+ NumInt :: NumRepr IntType+ NumReal :: NumRepr RealType++data FunRepr (sig :: ([Type],Type)) where+ FunRepr :: List Repr arg -> Repr tp -> FunRepr '(arg,tp)++class GetType v where+ getType :: v tp -> Repr tp++class GetFunType fun where+ getFunType :: fun '(arg,res) -> (List Repr arg,Repr res)++bw :: TL.KnownNat bw => Proxy bw -> BitWidth bw+bw = BitWidth . TL.natVal++instance Eq (BitWidth bw) where+ (==) (BitWidth _) (BitWidth _) = True++-- | A representation of the SMT Bool type.+-- Holds the values 'Language.SMTLib2.true' or 'Language.SMTLib2.Internals.false'.+-- Constants can be created using 'Language.SMTLib2.cbool'.+bool :: Repr BoolType+bool = BoolRepr++-- | A representation of the SMT Int type.+-- Holds the unbounded positive and negative integers.+-- Constants can be created using 'Language.SMTLib2.cint'.+int :: Repr IntType+int = IntRepr++-- | A representation of the SMT Real type.+-- Holds positive and negative reals x/y where x and y are integers.+-- Constants can be created using 'Language.SMTLib2.creal'.+real :: Repr RealType+real = RealRepr++-- | A typed representation of the SMT BitVec type.+-- Holds bitvectors (a vector of booleans) of a certain bitwidth.+-- Constants can be created using 'Language.SMTLib2.cbv'.+bitvec :: BitWidth bw -- ^ The width of the bitvector+ -> Repr (BitVecType bw)+bitvec = BitVecRepr++-- | A representation of the SMT Array type.+-- Has a list of index types and an element type.+-- Stores one value of the element type for each combination of the index types.+-- Constants can be created using 'Language.SMTLib2.constArray'.+array :: List Repr idx -> Repr el -> Repr (ArrayType idx el)+array = ArrayRepr++-- | A representation of a user-defined datatype without parameters.+dt :: (IsDatatype dt,Parameters dt ~ 'Z) => Datatype dt -> Repr (DataType dt '[])+dt dt = DataRepr dt List.Nil++-- | A representation of a user-defined datatype with parameters.+dt' :: (IsDatatype dt,List.Length par ~ Parameters dt) => Datatype dt -> List Repr par -> Repr (DataType dt par)+dt' = DataRepr++instance GEq BitWidth where+ geq (BitWidth bw1) (BitWidth bw2)+ | bw1==bw2 = Just $ unsafeCoerce Refl+ | otherwise = Nothing++instance GCompare BitWidth where+ gcompare (BitWidth bw1) (BitWidth bw2)+ = case compare bw1 bw2 of+ EQ -> unsafeCoerce GEQ+ LT -> GLT+ GT -> GGT++instance GetType Repr where+ getType = id++instance GetType Value where+ getType = valueType++instance GEq Value where+ geq (BoolValue v1) (BoolValue v2) = if v1==v2 then Just Refl else Nothing+ geq (IntValue v1) (IntValue v2) = if v1==v2 then Just Refl else Nothing+ geq (RealValue v1) (RealValue v2) = if v1==v2 then Just Refl else Nothing+ geq (BitVecValue v1 bw1) (BitVecValue v2 bw2) = do+ Refl <- geq bw1 bw2+ if v1==v2+ then return Refl+ else Nothing+ geq (DataValue (v1::dt1 par1 Value)) (DataValue (v2::dt2 par2 Value)) = do+ Refl <- eqT :: Maybe (dt1 :~: dt2)+ case deconstruct v1 of+ ConApp p1 c1 arg1 -> case deconstruct v2 of+ ConApp p2 c2 arg2 -> do+ Refl <- geq p1 p2+ Refl <- geq c1 c2+ Refl <- geq arg1 arg2+ return Refl+ geq _ _ = Nothing++instance Eq (Value t) where+ (==) = defaultEq++instance GCompare Value where+ gcompare (BoolValue v1) (BoolValue v2) = case compare v1 v2 of+ EQ -> GEQ+ LT -> GLT+ GT -> GGT+ gcompare (BoolValue _) _ = GLT+ gcompare _ (BoolValue _) = GGT+ gcompare (IntValue v1) (IntValue v2) = case compare v1 v2 of+ EQ -> GEQ+ LT -> GLT+ GT -> GGT+ gcompare (IntValue _) _ = GLT+ gcompare _ (IntValue _) = GGT+ gcompare (RealValue v1) (RealValue v2) = case compare v1 v2 of+ EQ -> GEQ+ LT -> GLT+ GT -> GGT+ gcompare (RealValue _) _ = GLT+ gcompare _ (RealValue _) = GGT+ gcompare (BitVecValue v1 bw1) (BitVecValue v2 bw2)+ = case gcompare bw1 bw2 of+ GEQ -> case compare v1 v2 of+ EQ -> GEQ+ LT -> GLT+ GT -> GGT+ GLT -> GLT+ GGT -> GGT+ gcompare (BitVecValue _ _) _ = GLT+ gcompare _ (BitVecValue _ _) = GGT+ gcompare (DataValue (v1::dt1 par1 Value)) (DataValue (v2::dt2 par2 Value))+ = case eqT :: Maybe (dt1 :~: dt2) of+ Just Refl -> case deconstruct v1 of+ ConApp p1 c1 arg1 -> case deconstruct v2 of+ ConApp p2 c2 arg2 -> case gcompare p1 p2 of+ GEQ -> case gcompare c1 c2 of+ GEQ -> case gcompare arg1 arg2 of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT+ GLT -> GLT+ GGT -> GGT+ GLT -> GLT+ GGT -> GGT+ Nothing -> case compare (typeRep (Proxy::Proxy dt1))+ (typeRep (Proxy::Proxy dt2)) of+ LT -> GLT+ GT -> GGT++instance Ord (Value t) where+ compare = defaultCompare++instance GEq Repr where+ geq BoolRepr BoolRepr = Just Refl+ geq IntRepr IntRepr = Just Refl+ geq RealRepr RealRepr = Just Refl+ geq (BitVecRepr bw1) (BitVecRepr bw2) = do+ Refl <- geq bw1 bw2+ return Refl+ geq (ArrayRepr idx1 val1) (ArrayRepr idx2 val2) = do+ Refl <- geq idx1 idx2+ Refl <- geq val1 val2+ return Refl+ geq (DataRepr (_::Datatype dt1) p1) (DataRepr (_::Datatype dt2) p2) = do+ Refl <- eqT :: Maybe (Datatype dt1 :~: Datatype dt2)+ Refl <- geq p1 p2+ return Refl+ geq _ _ = Nothing++instance Eq (Repr tp) where+ (==) _ _ = True++instance GEq NumRepr where+ geq NumInt NumInt = Just Refl+ geq NumReal NumReal = Just Refl+ geq _ _ = Nothing++instance GEq FunRepr where+ geq (FunRepr a1 r1) (FunRepr a2 r2) = do+ Refl <- geq a1 a2+ Refl <- geq r1 r2+ return Refl++instance GCompare Repr where+ gcompare BoolRepr BoolRepr = GEQ+ gcompare BoolRepr _ = GLT+ gcompare _ BoolRepr = GGT+ gcompare IntRepr IntRepr = GEQ+ gcompare IntRepr _ = GLT+ gcompare _ IntRepr = GGT+ gcompare RealRepr RealRepr = GEQ+ gcompare RealRepr _ = GLT+ gcompare _ RealRepr = GGT+ gcompare (BitVecRepr bw1) (BitVecRepr bw2) = case gcompare bw1 bw2 of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT+ gcompare (BitVecRepr _) _ = GLT+ gcompare _ (BitVecRepr _) = GGT+ gcompare (ArrayRepr idx1 val1) (ArrayRepr idx2 val2) = case gcompare idx1 idx2 of+ GEQ -> case gcompare val1 val2 of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT+ GLT -> GLT+ GGT -> GGT+ gcompare (ArrayRepr _ _) _ = GLT+ gcompare _ (ArrayRepr _ _) = GGT+ gcompare (DataRepr (dt1 :: Datatype dt1) p1 ) (DataRepr (dt2 :: Datatype dt2) p2)+ = case eqT of+ Just (Refl :: Datatype dt1 :~: Datatype dt2) -> case gcompare p1 p2 of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT+ Nothing -> case compare (datatypeName dt1) (datatypeName dt2) of+ LT -> GLT+ GT -> GGT++instance Ord (Repr tp) where+ compare _ _ = EQ++instance GCompare NumRepr where+ gcompare NumInt NumInt = GEQ+ gcompare NumInt _ = GLT+ gcompare _ NumInt = GGT+ gcompare NumReal NumReal = GEQ++instance GCompare FunRepr where+ gcompare (FunRepr a1 r1) (FunRepr a2 r2) = case gcompare a1 a2 of+ GEQ -> case gcompare r1 r2 of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT+ GLT -> GLT+ GGT -> GGT++instance Show (Value tp) where+ showsPrec p (BoolValue b) = showsPrec p b+ showsPrec p (IntValue i) = showsPrec p i+ showsPrec p (RealValue i) = showsPrec p i+ showsPrec p (BitVecValue v n)+ = showBitVec p v (bwSize n)+ showsPrec p (DataValue val) = case deconstruct val of+ ConApp par con args -> showParen (p>10) $+ showString "ConstrValue " .+ showString (constrName con).+ showChar ' ' .+ showsPrec 11 args++showBitVec :: Int -> Integer -> Integer -> ShowS+showBitVec p v bw+ | bw `mod` 4 == 0 = let str = showHex rv ""+ exp_len = bw `div` 4+ len = genericLength str+ in showString "#x" .+ showString (genericReplicate (exp_len-len) '0') .+ showString str+ | otherwise = let str = showIntAtBase 2 (\x -> case x of+ 0 -> '0'+ 1 -> '1'+ ) rv ""+ len = genericLength str+ in showString "#b" .+ showString (genericReplicate (bw-len) '0') .+ showString str+ where+ rv = v `mod` 2^bw++instance GShow Value where+ gshowsPrec = showsPrec++instance Show (Repr t) where+ showsPrec _ BoolRepr = showString "bool"+ showsPrec _ IntRepr = showString "int"+ showsPrec _ RealRepr = showString "real"+ showsPrec p (BitVecRepr n) = showParen (p>10) $+ showString "bitvec " .+ showsPrec 11 (bwSize n)+ showsPrec p (ArrayRepr idx el) = showParen (p>10) $+ showString "array " .+ showsPrec 11 idx . showChar ' ' .+ showsPrec 11 el+ showsPrec p (DataRepr dt par) = showParen (p>10) $+ showString "dt " .+ showString (datatypeName dt)++instance GShow Repr where+ gshowsPrec = showsPrec++deriving instance Show (NumRepr t)++instance GShow NumRepr where+ gshowsPrec = showsPrec+ +valueType :: Value tp -> Repr tp+valueType (BoolValue _) = BoolRepr+valueType (IntValue _) = IntRepr+valueType (RealValue _) = RealRepr+valueType (BitVecValue _ bw) = BitVecRepr bw+valueType (DataValue v) = let (dt,par) = datatypeGet v+ in DataRepr dt par++liftType :: List Repr tps -> List Repr idx -> List Repr (Lifted tps idx)+liftType Nil idx = Nil+liftType (x ::: xs) idx = (ArrayRepr idx x) ::: (liftType xs idx)++numRepr :: NumRepr tp -> Repr tp+numRepr NumInt = IntRepr+numRepr NumReal = RealRepr++asNumRepr :: Repr tp -> Maybe (NumRepr tp)+asNumRepr IntRepr = Just NumInt+asNumRepr RealRepr = Just NumReal+asNumRepr _ = Nothing++getTypes :: GetType e => List e tps -> List Repr tps+getTypes Nil = Nil+getTypes (x ::: xs) = getType x ::: getTypes xs++-- | Determine the number of elements a type contains.+-- 'Nothing' means the type has infinite elements.+typeSize :: Maybe (List Repr par) -> Repr tp -> Maybe Integer+typeSize _ BoolRepr = Just 2+typeSize _ IntRepr = Nothing+typeSize _ RealRepr = Nothing+typeSize _ (BitVecRepr bw) = Just $ 2^(bwSize bw)+typeSize par (ArrayRepr idx el) = do+ idxSz <- List.toList (typeSize par) idx+ elSz <- typeSize par el+ return $ product (elSz:idxSz)+typeSize _ (DataRepr dt par) = do+ conSz <- List.toList (constrSize dt par) (constructors dt)+ return $ sum conSz+ where+ constrSize :: IsDatatype dt => Datatype dt -> List Repr par+ -> Constr dt sig -> Maybe Integer+ constrSize dt par con = do+ fieldSz <- List.toList (fieldSize dt par) (fields con)+ return $ product fieldSz+ fieldSize :: IsDatatype dt => Datatype dt -> List Repr par+ -> Field dt tp -> Maybe Integer+ fieldSize dt par field = typeSize (Just par) (fieldType field)+typeSize (Just par) (ParameterRepr p) = typeSize Nothing (List.index par p)++typeFiniteDomain :: Repr tp -> Maybe [Value tp]+typeFiniteDomain BoolRepr = Just [BoolValue False,BoolValue True]+typeFiniteDomain (BitVecRepr bw) = Just [ BitVecValue n bw+ | n <- [0..2^(bwSize bw)-1] ]+typeFiniteDomain _ = Nothing++instance Enum (Value BoolType) where+ succ (BoolValue x) = BoolValue (succ x)+ pred (BoolValue x) = BoolValue (pred x)+ toEnum i = BoolValue (toEnum i)+ fromEnum (BoolValue x) = fromEnum x+ enumFrom (BoolValue x) = fmap BoolValue (enumFrom x)+ enumFromThen (BoolValue x) (BoolValue y) = fmap BoolValue (enumFromThen x y)+ enumFromTo (BoolValue x) (BoolValue y) = fmap BoolValue (enumFromTo x y)+ enumFromThenTo (BoolValue x) (BoolValue y) (BoolValue z) = fmap BoolValue (enumFromThenTo x y z)++instance Bounded (Value BoolType) where+ minBound = BoolValue False+ maxBound = BoolValue True++instance Num (Value IntType) where+ (+) (IntValue x) (IntValue y) = IntValue (x+y)+ (-) (IntValue x) (IntValue y) = IntValue (x-y)+ (*) (IntValue x) (IntValue y) = IntValue (x*y)+ negate (IntValue x) = IntValue (negate x)+ abs (IntValue x) = IntValue (abs x)+ signum (IntValue x) = IntValue (signum x)+ fromInteger = IntValue++instance Enum (Value IntType) where+ succ (IntValue x) = IntValue (succ x)+ pred (IntValue x) = IntValue (pred x)+ toEnum i = IntValue (toEnum i)+ fromEnum (IntValue x) = fromEnum x+ enumFrom (IntValue x) = fmap IntValue (enumFrom x)+ enumFromThen (IntValue x) (IntValue y) = fmap IntValue (enumFromThen x y)+ enumFromTo (IntValue x) (IntValue y) = fmap IntValue (enumFromTo x y)+ enumFromThenTo (IntValue x) (IntValue y) (IntValue z) = fmap IntValue (enumFromThenTo x y z)++instance Real (Value IntType) where+ toRational (IntValue x) = toRational x++instance Integral (Value IntType) where+ quot (IntValue x) (IntValue y) = IntValue $ quot x y+ rem (IntValue x) (IntValue y) = IntValue $ rem x y+ div (IntValue x) (IntValue y) = IntValue $ div x y+ mod (IntValue x) (IntValue y) = IntValue $ mod x y+ quotRem (IntValue x) (IntValue y) = (IntValue q,IntValue r)+ where+ (q,r) = quotRem x y+ divMod (IntValue x) (IntValue y) = (IntValue d,IntValue m)+ where+ (d,m) = divMod x y+ toInteger (IntValue x) = x++instance Num (Value RealType) where+ (+) (RealValue x) (RealValue y) = RealValue (x+y)+ (-) (RealValue x) (RealValue y) = RealValue (x-y)+ (*) (RealValue x) (RealValue y) = RealValue (x*y)+ negate (RealValue x) = RealValue (negate x)+ abs (RealValue x) = RealValue (abs x)+ signum (RealValue x) = RealValue (signum x)+ fromInteger = RealValue . fromInteger++instance Real (Value RealType) where+ toRational (RealValue x) = x++instance Fractional (Value RealType) where+ (/) (RealValue x) (RealValue y) = RealValue (x/y)+ recip (RealValue x) = RealValue (recip x)+ fromRational = RealValue++instance RealFrac (Value RealType) where+ properFraction (RealValue x) = let (p,q) = properFraction x+ in (p,RealValue q)+ truncate (RealValue x) = truncate x+ round (RealValue x) = round x+ ceiling (RealValue x) = ceiling x+ floor (RealValue x) = floor x++withBW :: TL.KnownNat bw => (Proxy bw -> res (BitVecType bw))+ -> res (BitVecType bw)+withBW f = f Proxy++bvAdd :: Value (BitVecType bw) -> Value (BitVecType bw) -> Value (BitVecType bw)+bvAdd (BitVecValue x bw1) (BitVecValue y bw2)+ | bw1 /= bw2 = error "bvAdd: Bitvector size mismatch"+ | otherwise = BitVecValue ((x+y) `mod` (2^(bwSize bw1))) bw1++bvSub :: Value (BitVecType bw) -> Value (BitVecType bw) -> Value (BitVecType bw)+bvSub (BitVecValue x bw1) (BitVecValue y bw2)+ | bw1 /= bw2 = error "bvSub: Bitvector size mismatch"+ | otherwise = BitVecValue ((x-y) `mod` (2^(bwSize bw1))) bw1++bvMul :: Value (BitVecType bw) -> Value (BitVecType bw) -> Value (BitVecType bw)+bvMul (BitVecValue x bw1) (BitVecValue y bw2)+ | bw1 /= bw2 = error "bvMul: Bitvector size mismatch"+ | otherwise = BitVecValue ((x*y) `mod` (2^(bwSize bw1))) bw1++bvDiv :: Value (BitVecType bw) -> Value (BitVecType bw) -> Value (BitVecType bw)+bvDiv (BitVecValue x bw1) (BitVecValue y bw2)+ | bw1 /= bw2 = error "bvDiv: Bitvector size mismatch"+ | otherwise = BitVecValue (x `div` y) bw1++bvMod :: Value (BitVecType bw) -> Value (BitVecType bw) -> Value (BitVecType bw)+bvMod (BitVecValue x bw1) (BitVecValue y bw2)+ | bw1 /= bw2 = error "bvMod: Bitvector size mismatch"+ | otherwise = BitVecValue (x `mod` y) bw1++bvNegate :: Value (BitVecType bw) -> Value (BitVecType bw)+bvNegate (BitVecValue x bw) = BitVecValue (if x==0+ then 0+ else 2^(bwSize bw)-x) bw++bvSignum :: Value (BitVecType bw) -> Value (BitVecType bw)+bvSignum (BitVecValue x bw) = BitVecValue (if x==0 then 0 else 1) bw++instance TL.KnownNat bw => Num (Value (BitVecType bw)) where+ (+) = bvAdd+ (-) = bvSub+ (*) = bvMul+ negate = bvNegate+ abs = id+ signum = bvSignum+ fromInteger x = withBW $ \pr -> let bw = TL.natVal pr+ in BitVecValue (x `mod` (2^bw)) (BitWidth bw)++-- | Get the smallest bitvector value that is bigger than the given one.+-- Also known as the successor.+bvSucc :: Value (BitVecType bw) -> Value (BitVecType bw)+bvSucc (BitVecValue i bw)+ | i < 2^(bwSize bw) - 1 = BitVecValue (i+1) bw+ | otherwise = error "bvSucc: tried to take `succ' of maxBound"++-- | Get the largest bitvector value that is smaller than the given one.+-- Also known as the predecessor.+bvPred :: Value (BitVecType bw) -> Value (BitVecType bw)+bvPred (BitVecValue i bw)+ | i > 0 = BitVecValue (i-1) bw+ | otherwise = error "bvPred: tried to take `pred' of minBound"++instance TL.KnownNat bw => Enum (Value (BitVecType bw)) where+ succ = bvSucc+ pred = bvPred+ toEnum i = withBW $ \bw -> let i' = toInteger i+ bw' = TL.natVal bw+ in if i >= 0 && i < 2^bw'+ then BitVecValue i' (BitWidth bw')+ else error "Prelude.toEnum: argument out of range for bitvector value."+ fromEnum (BitVecValue i _) = fromInteger i+ enumFrom (BitVecValue x bw) = [ BitVecValue i bw | i <- [x..2^(bwSize bw)-1] ]+ enumFromThen (BitVecValue x bw) (BitVecValue y _) = [ BitVecValue i bw | i <- [x,y..2^(bwSize bw)-1] ]+ enumFromTo (BitVecValue x bw) (BitVecValue y _) = [ BitVecValue i bw | i <- [x..y] ]+ enumFromThenTo (BitVecValue x bw) (BitVecValue y _) (BitVecValue z _)+ = [ BitVecValue i bw | i <- [x,y..z] ]++instance TL.KnownNat bw => Bounded (Value (BitVecType bw)) where+ minBound = withBW $ \w -> BitVecValue 0 (bw w)+ maxBound = withBW $ \bw -> let bw' = TL.natVal bw+ in BitVecValue (2^bw'-1) (BitWidth bw')++-- | Get the minimal value for a bitvector.+-- If unsigned, the value is 0, otherwise 2^(bw-1).+bvMinValue :: Bool -- ^ Signed bitvector?+ -> Repr (BitVecType bw)+ -> Value (BitVecType bw)+bvMinValue False (BitVecRepr bw) = BitVecValue 0 bw+bvMinValue True (BitVecRepr bw) = BitVecValue (2^(bwSize bw-1)) bw++-- | Get the maximal value for a bitvector.+-- If unsigned, the value is 2^(bw-1)-1, otherwise 2^bw-1.+bvMaxValue :: Bool -- ^ Signed bitvector?+ -> Repr (BitVecType bw)+ -> Value (BitVecType bw)+bvMaxValue False (BitVecRepr bw) = BitVecValue (2^(bwSize bw)-1) bw+bvMaxValue True (BitVecRepr bw) = BitVecValue (2^(bwSize bw-1)-1) bw++instance TL.KnownNat bw => Bits (Value (BitVecType bw)) where+ (.&.) (BitVecValue x bw) (BitVecValue y _) = BitVecValue (x .&. y) bw+ (.|.) (BitVecValue x bw) (BitVecValue y _) = BitVecValue (x .|. y) bw+ xor (BitVecValue x bw) (BitVecValue y _)+ = BitVecValue ((x .|. max) `xor` (y .|. max)) bw+ where+ max = bit $ fromInteger $ bwSize bw+ complement (BitVecValue x bw) = BitVecValue (2^(bwSize bw)-1-x) bw+ shift (BitVecValue x bw) i = BitVecValue ((x `shift` i) `mod` (2^(bwSize bw))) bw+ rotate (BitVecValue x bw) i = BitVecValue ((x `rotate` i) `mod` (2^(bwSize bw))) bw+ zeroBits = withBW $ \w -> BitVecValue 0 (bw w)+ bit n = withBW $ \bw -> let bw' = TL.natVal bw+ in if toInteger n < bw' && n >= 0+ then BitVecValue (bit n) (BitWidth bw')+ else BitVecValue 0 (BitWidth bw')+ setBit (BitVecValue x bw) i = if toInteger i < bwSize bw && i >= 0+ then BitVecValue (setBit x i) bw+ else BitVecValue x bw+ clearBit (BitVecValue x bw) i = if toInteger i < bwSize bw && i >= 0+ then BitVecValue (clearBit x i) bw+ else BitVecValue x bw+ complementBit (BitVecValue x bw) i = if toInteger i < bwSize bw && i >= 0+ then BitVecValue (complementBit x i) bw+ else BitVecValue x bw+ testBit (BitVecValue x _) i = testBit x i+#if MIN_VERSION_base(4,7,0)+ bitSizeMaybe (BitVecValue _ bw) = Just (fromInteger $ bwSize bw)+#endif+ bitSize (BitVecValue _ bw) = fromInteger $ bwSize bw+ isSigned _ = False+ shiftL (BitVecValue x bw) i = BitVecValue ((shiftL x i) `mod` 2^(bwSize bw)) bw+ shiftR (BitVecValue x bw) i = BitVecValue ((shiftR x i) `mod` 2^(bwSize bw)) bw+ rotateL (BitVecValue x bw) i = BitVecValue ((rotateL x i) `mod` 2^(bwSize bw)) bw+ rotateR (BitVecValue x bw) i = BitVecValue ((rotateR x i) `mod` 2^(bwSize bw)) bw+ popCount (BitVecValue x _) = popCount x++#if MIN_VERSION_base(4,7,0)+instance TL.KnownNat bw => FiniteBits (Value (BitVecType bw)) where+ finiteBitSize (BitVecValue _ bw) = fromInteger $ bwSize bw+#endif++instance TL.KnownNat bw => Real (Value (BitVecType bw)) where+ toRational (BitVecValue x _) = toRational x++instance TL.KnownNat bw => Integral (Value (BitVecType bw)) where+ quot (BitVecValue x bw) (BitVecValue y _) = BitVecValue (quot x y) bw+ rem (BitVecValue x bw) (BitVecValue y _) = BitVecValue (rem x y) bw+ div (BitVecValue x bw) (BitVecValue y _) = BitVecValue (div x y) bw+ mod (BitVecValue x bw) (BitVecValue y _) = BitVecValue (mod x y) bw+ quotRem (BitVecValue x bw) (BitVecValue y _) = (BitVecValue q bw,BitVecValue r bw)+ where+ (q,r) = quotRem x y+ divMod (BitVecValue x bw) (BitVecValue y _) = (BitVecValue d bw,BitVecValue m bw)+ where+ (d,m) = divMod x y+ toInteger (BitVecValue x _) = x++instance GetType NumRepr where+ getType NumInt = IntRepr+ getType NumReal = RealRepr++instance Show (BitWidth bw) where+ showsPrec p bw = showsPrec p (bwSize bw)++bwAdd :: BitWidth bw1 -> BitWidth bw2 -> BitWidth (bw1 TL.+ bw2)+bwAdd (BitWidth w1) (BitWidth w2) = BitWidth (w1+w2)++datatypeEq :: (IsDatatype dt1,IsDatatype dt2)+ => Datatype dt1 -> Datatype dt2 -> Maybe (dt1 :~: dt2)+datatypeEq (d1 :: Datatype dt1) (d2 :: Datatype dt2) = do+ Refl <- eqT :: Maybe (dt1 :~: dt2)+ if d1==d2+ then return Refl+ else Nothing++datatypeCompare :: (IsDatatype dt1,IsDatatype dt2)+ => Datatype dt1 -> Datatype dt2+ -> GOrdering dt1 dt2+datatypeCompare (d1 :: Datatype dt1) (d2 :: Datatype dt2)+ = case eqT of+ Just (Refl :: dt1 :~: dt2) -> case compare d1 d2 of+ EQ -> GEQ+ LT -> GLT+ GT -> GGT+ Nothing -> case compare+ (typeRep (Proxy::Proxy dt1))+ (typeRep (Proxy::Proxy dt2)) of+ LT -> GLT+ GT -> GGT
+ Language/SMTLib2/Internals/Type/List.hs view
@@ -0,0 +1,346 @@+module Language.SMTLib2.Internals.Type.List where++import Language.SMTLib2.Internals.Type.Nat++import Prelude hiding (head,tail,length,mapM,insert,drop,take,last,reverse,map,traverse,concat,replicate)+import Data.GADT.Compare+import Data.GADT.Show+import Language.Haskell.TH++type family Head (lst :: [a]) :: a where+ Head (x ': xs) = x++type family Tail (lst :: [a]) :: [a] where+ Tail (x ': xs) = xs++type family Index (lst :: [a]) (idx :: Nat) :: a where+ Index (x ': xs) Z = x+ Index (x ': xs) (S n) = Index xs n++type family Insert (lst :: [a]) (idx :: Nat) (el :: a) :: [a] where+ Insert (x ': xs) Z y = y ': xs+ Insert (x ': xs) (S n) y = x ': (Insert xs n y)++type family Remove (lst :: [a]) (idx :: Nat) :: [a] where+ Remove (x ': xs) Z = xs+ Remove (x ': xs) (S n) = x ': (Remove xs n)++type family Append (lst :: [a]) (el :: a) :: [a] where+ Append '[] y = y ': '[]+ Append (x ': xs) y = x ': (Append xs y)++type family Length (lst :: [a]) :: Nat where+ Length '[] = Z+ Length (x ': xs) = S (Length xs)++type family Drop (lst :: [a]) (i :: Nat) :: [a] where+ Drop lst Z = lst+ Drop (x ': xs) (S n) = Drop xs n++type family Take (lst :: [a]) (i :: Nat) :: [a] where+ Take xs Z = '[]+ Take (x ': xs) (S n) = x ': (Take xs n)++type family StripPrefix (lst :: [a]) (pre :: [a]) :: [a] where+ StripPrefix xs '[] = xs+ StripPrefix (x ': xs) (x ': ys) = StripPrefix xs ys++type family Last (lst :: [a]) :: a where+ Last '[x] = x+ Last (x ': y ': rest) = Last (y ': rest)++type family DropLast (lst :: [a]) :: [a] where+ DropLast '[x] = '[]+ DropLast (x ': y ': rest) = x ': (DropLast (y ': rest))++type family Reverse (lst :: [a]) :: [a] where+ Reverse '[] = '[]+ Reverse (x ': xs) = Append (Reverse xs) x++type family Map (lst :: [a]) (f :: a -> b) :: [b] where+ Map '[] f = '[]+ Map (x ': xs) f = (f x) ': (Map xs f)++type family Concat (xs :: [a]) (ys :: [a]) :: [a] where+ Concat '[] ys = ys+ Concat (x ': xs) ys = x ': (Concat xs ys)++type family Replicate (n :: Nat) (x :: a) :: [a] where+ Replicate 'Z x = '[]+ Replicate ('S n) x = x ': Replicate n x++-- | Strongly typed heterogenous lists.+--+-- A /List e '[tp1,tp2,tp3]/ contains 3 elements of types /e tp1/, /e tp2/ and+-- /e tp3/ respectively.+--+-- As an example, the following list contains two types:+--+-- >>> int ::: bool ::: Nil :: List Repr '[IntType,BoolType]+-- [IntRepr,BoolRepr]+data List e (tp :: [a]) where+ Nil :: List e '[]+ (:::) :: e x -> List e xs -> List e (x ': xs)++infixr 9 :::++list :: [ExpQ] -> ExpQ+list [] = [| Nil |]+list (x:xs) = [| $(x) ::: $(list xs) |]++nil :: List e '[]+nil = Nil++list1 :: e t1 -> List e '[t1]+list1 x1 = x1 ::: Nil++list2 :: e t1 -> e t2 -> List e '[t1,t2]+list2 x1 x2 = x1 ::: x2 ::: Nil++list3 :: e t1 -> e t2 -> e t3 -> List e '[t1,t2,t3]+list3 x1 x2 x3 = x1 ::: x2 ::: x3 ::: Nil++-- | Get a static representation of a dynamic list.+--+-- For example, to convert a list of strings into a list of types:+--+-- >>> reifyList (\name f -> case name of { "int" -> f int ; "bool" -> f bool }) ["bool","int"] show+-- "[BoolRepr,IntRepr]"+reifyList :: (forall r'. a -> (forall tp. e tp -> r') -> r')+ -> [a] -> (forall tp. List e tp -> r)+ -> r+reifyList _ [] g = g Nil+reifyList f (x:xs) g = f x $ \x' -> reifyList f xs $ \xs' -> g (x' ::: xs')++access :: Monad m => List e lst -> Natural idx+ -> (e (Index lst idx) -> m (a,e tp))+ -> m (a,List e (Insert lst idx tp))+access (x ::: xs) Zero f = do+ (res,nx) <- f x+ return (res,nx ::: xs)+access (x ::: xs) (Succ n) f = do+ (res,nxs) <- access xs n f+ return (res,x ::: nxs)++access' :: Monad m => List e lst -> Natural idx+ -> (e (Index lst idx) -> m (a,e (Index lst idx)))+ -> m (a,List e lst)+access' (x ::: xs) Zero f = do+ (res,nx) <- f x+ return (res,nx ::: xs)+access' (x ::: xs) (Succ n) f = do+ (res,nxs) <- access' xs n f+ return (res,x ::: nxs)++head :: List e lst -> e (Head lst)+head (x ::: xs) = x++tail :: List e lst -> List e (Tail lst)+tail (x ::: xs) = xs++index :: List e lst -> Natural idx -> e (Index lst idx)+index (x ::: xs) Zero = x+index (x ::: xs) (Succ n) = index xs n++indexDyn :: Integral i => List e tps -> i -> (forall tp. e tp -> a) -> a+indexDyn es i f+ | i < 0 = error $ "indexDyn: Negative index"+ | otherwise = indexDyn' es i f+ where+ indexDyn' :: Integral i => List e tps -> i -> (forall tp. e tp -> a) -> a+ indexDyn' Nil _ _ = error $ "indexDyn: Index out of range"+ indexDyn' (e ::: _) 0 f = f e+ indexDyn' (_ ::: es) n f = indexDyn' es (n-1) f++insert :: List e lst -> Natural idx -> e tp -> List e (Insert lst idx tp)+insert (x ::: xs) Zero y = y ::: xs+insert (x ::: xs) (Succ n) y = x ::: (insert xs n y)++remove :: List e lst -> Natural idx -> List e (Remove lst idx)+remove (x ::: xs) Zero = xs+remove (x ::: xs) (Succ n) = x ::: (remove xs n)++mapM :: Monad m => (forall x. e x -> m (e' x)) -> List e lst -> m (List e' lst)+mapM _ Nil = return Nil+mapM f (x ::: xs) = do+ nx <- f x+ nxs <- mapM f xs+ return (nx ::: nxs)++mapIndexM :: Monad m => (forall n. Natural n -> e (Index lst n) -> m (e' (Index lst n)))+ -> List e lst+ -> m (List e' lst)+mapIndexM f Nil = return Nil+mapIndexM f (x ::: xs) = do+ nx <- f Zero x+ nxs <- mapIndexM (\n -> f (Succ n)) xs+ return (nx ::: nxs)++traverse :: Applicative f => (forall x. e x -> f (e' x)) -> List e lst -> f (List e' lst)+traverse f Nil = pure Nil+traverse f (x ::: xs) = (:::) <$> f x <*> traverse f xs++cons :: e x -> List e xs -> List e (x ': xs)+cons = (:::)++append :: List e xs -> e x -> List e (Append xs x)+append Nil y = y ::: Nil+append (x ::: xs) y = x ::: (append xs y)++length :: List e lst -> Natural (Length lst)+length Nil = Zero+length (_ ::: xs) = Succ (length xs)++drop :: List e lst -> Natural i -> List e (Drop lst i)+drop xs Zero = xs+drop (x ::: xs) (Succ n) = drop xs n++take :: List e lst -> Natural i -> List e (Take lst i)+take xs Zero = Nil+take (x ::: xs) (Succ n) = x ::: (take xs n)++last :: List e lst -> e (Last lst)+last (x ::: Nil) = x+last (x ::: y ::: rest) = last (y ::: rest)++dropLast :: List e lst -> List e (DropLast lst)+dropLast (_ ::: Nil) = Nil+dropLast (x ::: y ::: rest) = x ::: (dropLast (y ::: rest))++stripPrefix :: GEq e => List e lst -> List e pre -> Maybe (List e (StripPrefix lst pre))+stripPrefix xs Nil = Just xs+stripPrefix (x ::: xs) (y ::: ys)+ = case geq x y of+ Just Refl -> stripPrefix xs ys+ Nothing -> Nothing++reverse :: List e lst -> List e (Reverse lst)+reverse Nil = Nil+reverse (x ::: xs) = append (reverse xs) x++map :: List e lst -> (forall x. e x -> e (f x)) -> List e (Map lst f)+map Nil _ = Nil+map (x ::: xs) f = (f x) ::: (map xs f)++unmap :: List p lst -> List e (Map lst f) -> (forall x. e (f x) -> e x) -> List e lst+unmap Nil Nil _ = Nil+unmap (_ ::: tps) (x ::: xs) f = (f x) ::: (unmap tps xs f)++unmapM :: Monad m => List p lst -> List e (Map lst f)+ -> (forall x. e (f x) -> m (e x)) -> m (List e lst)+unmapM Nil Nil _ = return Nil+unmapM (_ ::: tps) (x ::: xs) f = do+ x' <- f x+ xs' <- unmapM tps xs f+ return $ x' ::: xs'++mapM' :: Monad m => List e lst -> (forall x. e x -> m (e (f x))) -> m (List e (Map lst f))+mapM' Nil _ = return Nil+mapM' (x ::: xs) f = do+ x' <- f x+ xs' <- mapM' xs f+ return (x' ::: xs')++concat :: List e xs -> List e ys -> List e (Concat xs ys)+concat Nil ys = ys+concat (x ::: xs) ys = x ::: concat xs ys++replicate :: Natural n -> e x -> List e (Replicate n x)+replicate Zero _ = Nil+replicate (Succ n) x = x ::: replicate n x++toList :: Monad m => (forall x. e x -> m a) -> List e lst -> m [a]+toList f Nil = return []+toList f (x ::: xs) = do+ nx <- f x+ nxs <- toList f xs+ return (nx : nxs)++toListIndex :: Monad m => (forall n. Natural n -> e (Index lst n) -> m a)+ -> List e lst -> m [a]+toListIndex f Nil = return []+toListIndex f (x ::: xs) = do+ nx <- f Zero x+ nxs <- toListIndex (\n -> f (Succ n)) xs+ return (nx : nxs)++foldM :: Monad m => (forall x. s -> e x -> m s) -> s -> List e lst -> m s+foldM f s Nil = return s+foldM f s (x ::: xs) = do+ ns <- f s x+ foldM f ns xs++zipWithM :: Monad m => (forall x. e1 x -> e2 x -> m (e3 x))+ -> List e1 lst -> List e2 lst -> m (List e3 lst)+zipWithM f Nil Nil = return Nil+zipWithM f (x ::: xs) (y ::: ys) = do+ z <- f x y+ zs <- zipWithM f xs ys+ return $ z ::: zs++zipToListM :: Monad m => (forall x. e1 x -> e2 x -> m a)+ -> List e1 lst -> List e2 lst+ -> m [a]+zipToListM f Nil Nil = return []+zipToListM f (x ::: xs) (y ::: ys) = do+ z <- f x y+ zs <- zipToListM f xs ys+ return (z : zs)++mapAccumM :: Monad m => (forall x. s -> e x -> m (s,e' x))+ -> s -> List e xs+ -> m (s,List e' xs)+mapAccumM _ s Nil = return (s,Nil)+mapAccumM f s (x ::: xs) = do+ (s1,x') <- f s x+ (s2,xs') <- mapAccumM f s1 xs+ return (s2,x' ::: xs')++instance GEq e => Eq (List e lst) where+ (==) Nil Nil = True+ (==) (x ::: xs) (y ::: ys) = case geq x y of+ Just Refl -> xs==ys+ Nothing -> False++instance GEq e => GEq (List e) where+ geq Nil Nil = Just Refl+ geq (x ::: xs) (y ::: ys) = do+ Refl <- geq x y+ Refl <- geq xs ys+ return Refl+ geq _ _ = Nothing++instance GCompare e => Ord (List e lst) where+ compare Nil Nil = EQ+ compare (x ::: xs) (y ::: ys) = case gcompare x y of+ GEQ -> compare xs ys+ GLT -> LT+ GGT -> GT++instance GCompare e => GCompare (List e) where+ gcompare Nil Nil = GEQ+ gcompare Nil _ = GLT+ gcompare _ Nil = GGT+ gcompare (x ::: xs) (y ::: ys) = case gcompare x y of+ GEQ -> case gcompare xs ys of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT+ GLT -> GLT+ GGT -> GGT++instance GShow e => Show (List e lst) where+ showsPrec p Nil = showString "[]"+ showsPrec p (x ::: xs) = showChar '[' .+ gshowsPrec 0 x .+ showLst xs .+ showChar ']'+ where+ showLst :: List e lst' -> ShowS+ showLst Nil = id+ showLst (x ::: xs) = showChar ',' .+ gshowsPrec 0 x .+ showLst xs++instance GShow e => GShow (List e) where+ gshowsPrec = showsPrec
+ Language/SMTLib2/Internals/Type/Nat.hs view
@@ -0,0 +1,253 @@+module Language.SMTLib2.Internals.Type.Nat where++import Data.Typeable+import Data.Constraint+import Data.GADT.Compare+import Data.GADT.Show+import Language.Haskell.TH++-- | Natural numbers on the type-level.+data Nat = Z | S Nat deriving Typeable++-- | A concrete representation of the 'Nat' type.+data Natural (n::Nat) where+ Zero :: Natural Z+ Succ :: Natural n -> Natural (S n)++type family (+) (n :: Nat) (m :: Nat) :: Nat where+ (+) Z n = n+ (+) (S n) m = S ((+) n m)++type family (-) (n :: Nat) (m :: Nat) :: Nat where+ (-) n Z = n+ (-) (S n) (S m) = n - m++type family (<=) (n :: Nat) (m :: Nat) :: Bool where+ (<=) Z m = True+ (<=) (S n) Z = False+ (<=) (S n) (S m) = (<=) n m++naturalToInteger :: Natural n -> Integer+naturalToInteger = conv 0+ where+ conv :: Integer -> Natural m -> Integer+ conv n Zero = n+ conv n (Succ x) = conv (n+1) x++naturalAdd :: Natural n -> Natural m -> Natural (n + m)+naturalAdd Zero n = n+naturalAdd (Succ x) y = Succ (naturalAdd x y)++naturalSub :: Natural (n + m) -> Natural n -> Natural m+naturalSub n Zero = n+naturalSub (Succ sum) (Succ n) = naturalSub sum n++naturalSub' :: Natural n -> Natural m+ -> (forall diff. ((m + diff) ~ n) => Natural diff -> a)+ -> a+naturalSub' n Zero f = f n+naturalSub' (Succ sum) (Succ n) f = naturalSub' sum n f++naturalLEQ :: Natural n -> Natural m -> Maybe (Dict ((n <= m) ~ True))+naturalLEQ Zero _ = Just Dict+naturalLEQ (Succ n) (Succ m) = case naturalLEQ n m of+ Just Dict -> Just Dict+ Nothing -> Nothing+naturalLEQ _ _ = Nothing++instance Show (Natural n) where+ showsPrec p = showsPrec p . naturalToInteger++instance Eq (Natural n) where+ (==) _ _ = True++instance Ord (Natural n) where+ compare _ _ = EQ++-- | Get a static representation for a dynamically created natural number.+--+-- Example:+--+-- >>> reifyNat (S (S Z)) show+-- "2"+reifyNat :: Nat -> (forall n. Natural n -> r) -> r+reifyNat Z f = f Zero+reifyNat (S n) f = reifyNat n $ \n' -> f (Succ n')++-- | A template haskell function to create nicer looking numbers.+--+-- Example:+--+-- >>> :t $(nat 5)+-- $(nat 5) :: Natural ('S ('S ('S ('S ('S 'Z)))))+nat :: (Num a,Ord a) => a -> ExpQ+nat n+ | n < 0 = error $ "nat: Can only use numbers >= 0."+ | otherwise = nat' n+ where+ nat' 0 = [| Zero |]+ nat' n = [| Succ $(nat' (n-1)) |]++-- | A template haskell function to create nicer looking number types.+--+-- Example:+--+-- >>> $(nat 5) :: Natural $(natT 5)+-- 5+natT :: (Num a,Ord a) => a -> TypeQ+natT n+ | n < 0 = error $ "natT: Can only use numbers >= 0."+ | otherwise = natT' n+ where+ natT' 0 = [t| Z |]+ natT' n = [t| S $(natT' (n-1)) |]++instance Eq Nat where+ (==) Z Z = True+ (==) (S x) (S y) = x == y+ (==) _ _ = False++instance Ord Nat where+ compare Z Z = EQ+ compare Z _ = LT+ compare _ Z = GT+ compare (S x) (S y) = compare x y++instance Num Nat where+ (+) Z n = n+ (+) (S n) m = S (n + m)+ (-) n Z = n+ (-) (S n) (S m) = n - m+ (-) _ _ = error $ "Cannot produce negative natural numbers."+ (*) Z n = Z+ (*) (S n) m = m+(n*m)+ negate _ = error $ "Cannot produce negative natural numbers."+ abs = id+ signum Z = Z+ signum (S _) = S Z+ fromInteger x+ | x<0 = error $ "Cannot produce negative natural numbers."+ | otherwise = f x+ where+ f 0 = Z+ f n = S (f (n-1))++instance Enum Nat where+ succ = S+ pred (S n) = n+ pred Z = error $ "Cannot produce negative natural numbers."+ toEnum 0 = Z+ toEnum n = S (toEnum (n-1))+ fromEnum Z = 0+ fromEnum (S n) = (fromEnum n)+1++instance Real Nat where+ toRational Z = 0+ toRational (S n) = (toRational n)+1++instance Integral Nat where+ quotRem x y = let (q,r) = quotRem (toInteger x) (toInteger y)+ in (fromInteger q,fromInteger r)+ toInteger = f 0+ where+ f n Z = n+ f n (S m) = f (n+1) m++type N0 = Z+type N1 = S N0+type N2 = S N1+type N3 = S N2+type N4 = S N3+type N5 = S N4+type N6 = S N5+type N7 = S N6+type N8 = S N7+type N9 = S N8+type N10 = S N9+type N11 = S N10+type N12 = S N11+type N13 = S N12+type N14 = S N13+type N15 = S N14+type N16 = S N15+type N17 = S N16+type N18 = S N17+type N19 = S N18+type N20 = S N19+type N21 = S N20+type N22 = S N21+type N23 = S N22+type N24 = S N23+type N25 = S N24+type N26 = S N25+type N27 = S N26+type N28 = S N27+type N29 = S N28+type N30 = S N29+type N31 = S N30+type N32 = S N31+type N33 = S N32+type N34 = S N33+type N35 = S N34+type N36 = S N35+type N37 = S N36+type N38 = S N37+type N39 = S N38+type N40 = S N39+type N41 = S N40+type N42 = S N41+type N43 = S N42+type N44 = S N43+type N45 = S N44+type N46 = S N45+type N47 = S N46+type N48 = S N47+type N49 = S N48+type N50 = S N49+type N51 = S N50+type N52 = S N51+type N53 = S N52+type N54 = S N53+type N55 = S N54+type N56 = S N55+type N57 = S N56+type N58 = S N57+type N59 = S N58+type N60 = S N59+type N61 = S N60+type N62 = S N61+type N63 = S N62+type N64 = S N63++instance GEq Natural where+ geq Zero Zero = Just Refl+ geq (Succ x) (Succ y) = do+ Refl <- geq x y+ return Refl+ geq _ _ = Nothing++instance GCompare Natural where+ gcompare Zero Zero = GEQ+ gcompare Zero _ = GLT+ gcompare _ Zero = GGT+ gcompare (Succ x) (Succ y) = case gcompare x y of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT++instance GShow Natural where+ gshowsPrec = showsPrec++class IsNatural n where+ getNatural :: Natural n++instance IsNatural Z where+ getNatural = Zero++instance IsNatural n => IsNatural (S n) where+ getNatural = Succ getNatural++deriveIsNatural :: Natural n -> Dict (IsNatural n)+deriveIsNatural Zero = Dict+deriveIsNatural (Succ n) = case deriveIsNatural n of+ Dict -> Dict
+ Language/SMTLib2/Internals/Type/Struct.hs view
@@ -0,0 +1,187 @@+module Language.SMTLib2.Internals.Type.Struct where++import Language.SMTLib2.Internals.Type.Nat+import Language.SMTLib2.Internals.Type.List (List(..))+import qualified Language.SMTLib2.Internals.Type.List as List++import Prelude hiding (mapM,insert)+import Data.GADT.Compare+import Data.GADT.Show+import Data.Functor.Identity++data Tree a = Leaf a+ | Node [Tree a]++data Struct e tp where+ Singleton :: e t -> Struct e (Leaf t)+ Struct :: List (Struct e) ts -> Struct e (Node ts)++type family Index (struct :: Tree a) (idx :: [Nat]) :: Tree a where+ Index x '[] = x+ Index (Node xs) (n ': ns) = Index (List.Index xs n) ns++type family ElementIndex (struct :: Tree a) (idx :: [Nat]) :: a where+ ElementIndex (Leaf x) '[] = x+ ElementIndex (Node xs) (n ': ns) = ElementIndex (List.Index xs n) ns++type family Insert (struct :: Tree a) (idx :: [Nat]) (el :: Tree a) :: Tree a where+ Insert x '[] y = y+ Insert (Node xs) (n ': ns) y = Node (List.Insert xs n+ (Insert (List.Index xs n) ns y))++type family Remove (struct :: Tree a) (idx :: [Nat]) :: Tree a where+ Remove (Node xs) '[n] = Node (List.Remove xs n)+ Remove (Node xs) (n1 ': n2 ': ns) = Node (List.Insert xs n1+ (Remove (List.Index xs n1) (n2 ': ns)))++type family Size (struct :: Tree a) :: Nat where+ Size (Leaf x) = S Z+ Size (Node '[]) = Z+ Size (Node (x ': xs)) = (Size x) + (Size (Node xs))++access :: Monad m => Struct e tp -> List Natural idx+ -> (e (ElementIndex tp idx) -> m (a,e (ElementIndex tp idx)))+ -> m (a,Struct e tp)+access (Singleton x) Nil f = do+ (res,nx) <- f x+ return (res,Singleton nx)+access (Struct xs) (n ::: ns) f = do+ (res,nxs) <- List.access' xs n (\x -> access x ns f)+ return (res,Struct nxs)++accessElement :: Monad m => Struct e tp -> List Natural idx+ -> (e (ElementIndex tp idx) -> m (a,e ntp))+ -> m (a,Struct e (Insert tp idx (Leaf ntp)))+accessElement (Singleton x) Nil f = do+ (res,nx) <- f x+ return (res,Singleton nx)+accessElement (Struct xs) (n ::: ns) f = do+ (res,nxs) <- List.access xs n (\x -> accessElement x ns f)+ return (res,Struct nxs)++index :: Struct e tp -> List Natural idx -> Struct e (Index tp idx)+index x Nil = x+index (Struct xs) (n ::: ns) = index (List.index xs n) ns++elementIndex :: Struct e tp -> List Natural idx -> e (ElementIndex tp idx)+elementIndex (Singleton x) Nil = x+elementIndex (Struct xs) (n ::: ns)+ = elementIndex (List.index xs n) ns++insert :: Struct e tps -> List Natural idx -> Struct e tp+ -> Struct e (Insert tps idx tp)+insert x Nil y = y+insert (Struct xs) (n ::: ns) y+ = Struct (List.insert xs n (insert (List.index xs n) ns y))++remove :: Struct e tps -> List Natural idx -> Struct e (Remove tps idx)+remove (Struct xs) (n ::: Nil) = Struct (List.remove xs n)+remove (Struct xs) (n1 ::: n2 ::: ns)+ = Struct (List.insert xs n1+ (remove (List.index xs n1) (n2 ::: ns)))++mapM :: Monad m => (forall x. e x -> m (e' x)) -> Struct e tps -> m (Struct e' tps)+mapM f (Singleton x) = do+ nx <- f x+ return (Singleton nx)+mapM f (Struct xs) = do+ nxs <- List.mapM (mapM f) xs+ return (Struct nxs)++mapIndexM :: Monad m+ => (forall idx.+ List Natural idx+ -> e (ElementIndex tps idx)+ -> m (e' (ElementIndex tps idx)))+ -> Struct e tps+ -> m (Struct e' tps)+mapIndexM f (Singleton x) = do+ nx <- f Nil x+ return (Singleton nx)+mapIndexM f (Struct xs) = do+ nxs <- List.mapIndexM (\n -> mapIndexM (\ns -> f (n ::: ns))) xs+ return (Struct nxs)++map :: (forall x. e x -> e' x) -> Struct e tps -> Struct e' tps+map f = runIdentity . (mapM (return.f))++size :: Struct e tps -> Natural (Size tps)+size (Singleton x) = Succ Zero+size (Struct Nil) = Zero+size (Struct (x ::: xs)) = naturalAdd (size x) (size (Struct xs))++flatten :: Monad m => (forall x. e x -> m a) -> ([a] -> m a) -> Struct e tps -> m a+flatten f _ (Singleton x) = f x+flatten f g (Struct xs) = do+ nxs <- List.toList (flatten f g) xs+ g nxs++flattenIndex :: Monad m => (forall idx. List Natural idx+ -> e (ElementIndex tps idx)+ -> m a)+ -> ([a] -> m a)+ -> Struct e tps -> m a+flattenIndex f _ (Singleton x) = f Nil x+flattenIndex f g (Struct xs) = do+ nxs <- List.toListIndex (\n x -> flattenIndex (\idx -> f (n ::: idx)) g x) xs+ g nxs++zipWithM :: Monad m => (forall x. e1 x -> e2 x -> m (e3 x))+ -> Struct e1 tps -> Struct e2 tps -> m (Struct e3 tps)+zipWithM f (Singleton x) (Singleton y) = do+ z <- f x y+ return (Singleton z)+zipWithM f (Struct xs) (Struct ys) = do+ zs <- List.zipWithM (zipWithM f) xs ys+ return (Struct zs)++zipFlatten :: Monad m => (forall x. e1 x -> e2 x -> m a)+ -> ([a] -> m a)+ -> Struct e1 tps -> Struct e2 tps -> m a+zipFlatten f _ (Singleton x) (Singleton y) = f x y+zipFlatten f g (Struct xs) (Struct ys) = do+ zs <- List.zipToListM (zipFlatten f g) xs ys+ g zs++instance GEq e => Eq (Struct e tps) where+ (==) (Singleton x) (Singleton y) = case geq x y of+ Just Refl -> True+ Nothing -> False+ (==) (Struct xs) (Struct ys) = xs==ys++instance GEq e => GEq (Struct e) where+ geq (Singleton x) (Singleton y) = do+ Refl <- geq x y+ return Refl+ geq (Struct xs) (Struct ys) = do+ Refl <- geq xs ys+ return Refl+ geq _ _ = Nothing++instance GCompare e => Ord (Struct e tps) where+ compare (Singleton x) (Singleton y) = case gcompare x y of+ GEQ -> EQ+ GLT -> LT+ GGT -> GT+ compare (Struct xs) (Struct ys) = compare xs ys++instance GCompare e => GCompare (Struct e) where+ gcompare (Singleton x) (Singleton y) = case gcompare x y of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT+ gcompare (Singleton _) _ = GLT+ gcompare _ (Singleton _) = GGT+ gcompare (Struct xs) (Struct ys) = case gcompare xs ys of+ GEQ -> GEQ+ GLT -> GLT+ GGT -> GGT++instance GShow e => Show (Struct e tps) where+ showsPrec p (Singleton x) = gshowsPrec p x+ showsPrec p (Struct xs) = showParen (p>10) $+ showString "Struct " .+ showsPrec 11 xs++instance GShow e => GShow (Struct e) where+ gshowsPrec = showsPrec
− Language/SMTLib2/Pipe.hs
@@ -1,1743 +0,0 @@-{-# LANGUAGE ViewPatterns, ImpredicativeTypes #-}-module Language.SMTLib2.Pipe- (SMTPipe(),- FunctionParser(..),- createSMTPipe,- withPipe,- exprToLisp,- exprToLispWith,- lispToExpr,lispToExprWith,- sortToLisp,lispToSort,- renderExpr,- renderExpr',- renderSMTRequest,- renderSMTResponse,- commonFunctions,- commonTheorems,- simpleParser,- FunctionParser'(..)) where--import Language.SMTLib2.Internals as SMT-import Language.SMTLib2.Internals.Instances-import Language.SMTLib2.Internals.Operators-import Language.SMTLib2.Strategy as Strat-import Data.Unit--import Data.Monoid-import qualified Data.AttoLisp as L-import qualified Data.Attoparsec.Number as L-import Data.Attoparsec-import System.Process-import qualified Data.Text as T--import System.IO as IO-import qualified Data.ByteString as BS hiding (reverse)-import qualified Data.ByteString.Char8 as BS8-import Blaze.ByteString.Builder-import Data.Typeable-import qualified Data.Map as Map-import Data.Fix-import Data.Proxy-#ifdef SMTLIB2_WITH_CONSTRAINTS-import Data.Constraint-#endif-import Data.List (genericLength,genericIndex,find)-import Numeric (readInt,readHex)-import Data.Ratio-import Control.Monad.Trans (MonadIO,liftIO)-import Control.Monad.Identity-import Data.Char (isDigit)--{- | An SMT backend which uses process pipes to communicate with an SMT solver- process. -}-data SMTPipe = SMTPipe { channelIn :: Handle- , channelOut :: Handle- , processHandle :: ProcessHandle- , smtState :: SMTState }--renderExpr :: (SMTType t,Monad m) => SMTExpr t -> SMT' m String-renderExpr expr = smtBackend $ \b -> do- getName <- smtGetNames b- (dts,nb) <- smtHandle b SMTDeclaredDataTypes- return (renderExpr' getName dts expr,nb)--renderExpr' :: SMTType t => (Integer -> String) -> DataTypeInfo -> SMTExpr t -> String-renderExpr' getName dts expr- = let lexpr = exprToLisp expr getName dts- in show lexpr--instance MonadIO m => SMTBackend SMTPipe m where- smtHandle pipe req@(SMTGetValue (expr::SMTExpr t))- = case unmangle :: Unmangling t of- PrimitiveUnmangling _ -> handleNormal pipe req- ComplexUnmangling f -> do- (res,npipe) <- f (\pipe expr' ann -> smtHandle pipe (SMTGetValue expr')- ) pipe expr (extractAnnotation expr)- case res of- Just x -> return (x,npipe)- Nothing -> error $ "smtlib2: Error while unmangling expression "++show expr++" to type "++show (typeOf (undefined::t))- smtHandle pipe req = handleNormal pipe req- --smtGetState pipe = return $ smtState pipe- smtGetNames pipe = return (\idx -> case Map.lookup idx (allVars (smtState pipe)) of- Just (info,nc) -> case funInfoName info of- Nothing -> escapeName (Right idx)- Just name -> escapeName (Left (name,nc)))- smtNextName pipe = return (\name -> case name of- Nothing -> let nxt = nextVar (smtState pipe)- in escapeName (Right nxt)- Just name' -> case Map.lookup name' (nameCount (smtState pipe)) of- Just nc -> escapeName (Left (name',nc))- Nothing -> escapeName (Left (name',0)))--handleNormal :: (MonadIO m,Typeable a) => SMTPipe -> SMTRequest a -> m (a,SMTPipe)-handleNormal pipe req = do- case cast req of- Just (_::SMTRequest ()) -> return ()- _ -> clearInput pipe- getName <- smtGetNames pipe- nxtName <- smtNextName pipe- case renderSMTRequest nxtName getName (declaredDataTypes $ smtState pipe) req of- Left l -> putRequest pipe l- Right "" -> return ()- Right msg -> liftIO $ IO.hPutStr (channelIn pipe) $ Prelude.unlines (fmap (';':) (Prelude.lines msg))- handleRequest pipe req--renderSMTRequest :: (Maybe String -> String) -> (Integer -> String) -> DataTypeInfo- -> SMTRequest r -> Either L.Lisp String-renderSMTRequest _ _ _ (SMTGetInfo SMTSolverName)- = Left $ L.List [L.Symbol "get-info",L.Symbol ":name"]-renderSMTRequest _ _ _ (SMTGetInfo SMTSolverVersion)- = Left $ L.List [L.Symbol "get-info",L.Symbol ":version"]-renderSMTRequest _ getName dts (SMTAssert expr interp cid)- = let expr1 = exprToLisp expr getName dts- expr2 = case interp of- Nothing -> expr1- Just (InterpolationGroup gr)- -> L.List [L.Symbol "!"- ,expr1- ,L.Symbol ":interpolation-group"- ,L.Symbol (T.pack $ "i"++show gr)]- expr3 = case cid of- Nothing -> expr2- Just (ClauseId cid)- -> L.List [L.Symbol "!"- ,expr2- ,L.Symbol ":named"- ,L.Symbol (T.pack $ "_cid"++show cid)]- in Left $ L.List [L.Symbol "assert",expr3]-renderSMTRequest _ _ _ (SMTCheckSat tactic limits)- = Left $ L.List (if extendedCheckSat- then [L.Symbol "check-sat-using"- ,case tactic of- Just t -> tacticToLisp t- Nothing -> L.Symbol "smt"]++- (case limitTime limits of- Just t -> [L.Symbol ":timeout"- ,L.Number (L.I t)]- Nothing -> [])++- (case limitMemory limits of- Just m -> [L.Symbol ":max-memory"- ,L.Number (L.I m)]- Nothing -> [])- else [L.Symbol "check-sat"])- where- extendedCheckSat = case tactic of- Just _ -> True- _ -> case limitTime limits of- Just _ -> True- _ -> case limitMemory limits of- Just _ -> True- _ -> False-renderSMTRequest _ _ _ SMTDeclaredDataTypes = Right ""-renderSMTRequest _ _ _ (SMTDeclareDataTypes dts)- = let param x = L.Symbol $ T.pack $ "arg"++show x- in Left $- L.List [L.Symbol "declare-datatypes"- ,args [ param i | i <- [0..(argCount dts)-1] ]- ,L.List- [ L.List $ [L.Symbol $ T.pack $ dataTypeName dt]- ++ [ L.List $ [L.Symbol $ T.pack $ conName con]- ++ [ L.List [L.Symbol $ T.pack $ fieldName field- ,case fieldSort field of- Fix (NormalSort (NamedSort fTpName _)) -> case find (\dt -> (dataTypeName dt)==fTpName) (dataTypes dts) of- Nothing -> argumentSortToLisp param (fieldSort field)- Just _ -> L.Symbol (T.pack fTpName)- _ -> argumentSortToLisp param (fieldSort field)]- | field <- conFields con ]- | con <- dataTypeConstructors dt ]- | dt <- dataTypes dts ]- ]-renderSMTRequest _ _ _ (SMTDeclareSort name arity)- = Left $ L.List [L.Symbol "declare-sort",L.Symbol $ T.pack name,L.toLisp arity]-renderSMTRequest nextName _ _ (SMTDeclareFun finfo)- = let tps = funInfoArgSorts finfo- rtp = funInfoSort finfo- in Left $ L.List [L.Symbol "declare-fun"- ,L.Symbol $ T.pack (nextName (funInfoName finfo))- ,args (fmap sortToLisp tps)- ,sortToLisp rtp- ]-renderSMTRequest nextName getName dts (SMTDefineFun name (_::Proxy arg) argAnn (body::SMTExpr res))- = let tpLst = zip [0..] (getTypes (undefined::arg) argAnn)- annRes = extractAnnotation body- name' = nextName name- retSort = getSort (undefined::res) annRes- in Left $ L.List [L.Symbol "define-fun"- ,L.Symbol $ T.pack name'- ,args [ L.List [ L.Symbol $ T.pack $ "farg_"++show (j::Integer)- , sortToLisp $ getSort u ann ]- | (j,ProxyArg u ann) <- tpLst ]- ,sortToLisp retSort- ,exprToLisp body getName dts]-renderSMTRequest _ _ _ (SMTComment msg) = Right msg-renderSMTRequest _ _ _ SMTExit = Left $ L.List [L.Symbol "exit"]-renderSMTRequest _ _ _ (SMTGetInterpolant grps)- = Left $ L.List [L.Symbol "get-interpolant"- ,L.List [ L.Symbol $ T.pack ("i"++show g) | InterpolationGroup g <- grps ]- ]-renderSMTRequest _ getName dts (SMTInterpolate exprs)- = Left $ L.List $ (L.Symbol "get-interpolant"):- [ exprToLisp expr getName dts- | expr <- exprs ]-renderSMTRequest _ _ _ (SMTSetOption opt)- = Left $ L.List $ [L.Symbol "set-option"]- ++(case opt of- PrintSuccess v -> [L.Symbol ":print-success"- ,L.Symbol $ if v then "true" else "false"]- ProduceModels v -> [L.Symbol ":produce-models"- ,L.Symbol $ if v then "true" else "false"]- SMT.ProduceProofs v -> [L.Symbol ":produce-proofs"- ,L.Symbol $ if v then "true" else "false"]- SMT.ProduceUnsatCores v -> [L.Symbol ":produce-unsat-cores"- ,L.Symbol $ if v then "true" else "false"]- ProduceInterpolants v -> [L.Symbol ":produce-interpolants"- ,L.Symbol $ if v then "true" else "false"]- )-renderSMTRequest _ _ _ (SMTSetLogic name)- = Left $ L.List [L.Symbol "set-logic"- ,L.Symbol $ T.pack name]-renderSMTRequest _ _ _ SMTGetProof- = Left $ L.List [L.Symbol "get-proof"]-renderSMTRequest _ _ _ SMTGetUnsatCore- = Left $ L.List [L.Symbol "get-unsat-core"]-renderSMTRequest _ getName dts (SMTSimplify expr)- = let lexpr = exprToLisp expr getName dts- in Left $ L.List [L.Symbol "simplify"- ,lexpr]-renderSMTRequest _ _ _ SMTPush = Left $ L.List [L.Symbol "push",L.toLisp (1::Integer)]-renderSMTRequest _ _ _ SMTPop = Left $ L.List [L.Symbol "pop",L.toLisp (1::Integer)]-renderSMTRequest _ getName dts (SMTGetValue expr)- = let lexpr = exprToLisp expr getName dts- in Left $ L.List [L.Symbol "get-value"- ,L.List [lexpr]]-renderSMTRequest _ _ _ SMTGetModel = Left $ L.List [L.Symbol "get-model"]-renderSMTRequest _ _ _ (SMTApply tactic)- = Left $ L.List [L.Symbol "apply"- ,tacticToLisp tactic]-renderSMTRequest _ _ _ (SMTNameExpr _ _) = Right ""-renderSMTRequest _ _ _ SMTNewInterpolationGroup = Right ""-renderSMTRequest _ _ _ SMTNewClauseId = Right ""--handleRequest :: MonadIO m => SMTPipe -> SMTRequest response -> m (response,SMTPipe)-handleRequest pipe (SMTGetInfo SMTSolverName) = do- res <- parseResponse pipe- case res of- L.List [L.Symbol ":name",L.String name] -> return (T.unpack name,pipe)- _ -> error "Invalid solver response to 'get-info' name query"-handleRequest pipe (SMTGetInfo SMTSolverVersion) = do- res <- parseResponse pipe- case res of- L.List [L.Symbol ":version",L.String name] -> return (T.unpack name,pipe)- _ -> error "Invalid solver response to 'get-info' version query"-handleRequest pipe (SMTAssert _ _ _) = return ((),pipe)-handleRequest pipe (SMTCheckSat tactic limits) = do- res <- liftIO $ BS.hGetLine (channelOut pipe)- return (case res of- "sat" -> Sat- "sat\r" -> Sat- "unsat" -> Unsat- "unsat\r" -> Unsat- "unknown" -> Unknown- "unknown\r" -> Unknown- _ -> error $ "smtlib2: unknown check-sat response: "++show res,pipe)-handleRequest pipe SMTDeclaredDataTypes = return (declaredDataTypes $ smtState pipe,pipe)-handleRequest pipe (SMTDeclareDataTypes dts) = do- let ndts = addDataTypeStructure dts (declaredDataTypes $ smtState pipe)- return ((),pipe { smtState = (smtState pipe) { declaredDataTypes = ndts } })-handleRequest pipe (SMTDeclareSort name arity) = return ((),pipe)-handleRequest pipe (SMTDeclareFun info)- = let (v,_,nst) = smtStateAddFun info (smtState pipe)- in return (v,pipe { smtState = nst })-handleRequest pipe (SMTDefineFun name (_::Proxy arg) argAnn (body::SMTExpr res)) = do- let finfo = FunInfo { funInfoProxy = Proxy::Proxy (arg,res)- , funInfoArgAnn = argAnn- , funInfoResAnn = extractAnnotation body- , funInfoName = name }- (i,_,nst) = smtStateAddFun finfo (smtState pipe)- return (i,pipe { smtState = nst })-handleRequest pipe (SMTComment msg) = return ((),pipe)-handleRequest pipe SMTExit = do- liftIO $ hClose (channelIn pipe)- liftIO $ hClose (channelOut pipe)- liftIO $ terminateProcess (processHandle pipe)- _ <- liftIO $ waitForProcess (processHandle pipe)- return ((),pipe)-handleRequest pipe (SMTGetInterpolant grps) = do- val <- parseResponse pipe- case lispToExpr commonFunctions- (findName $ smtState pipe) (declaredDataTypes $ smtState pipe)- gcast (Just $ Fix BoolSort) 0 val of- Just (Just x) -> return (x,pipe)- _ -> error $ "smtlib2: Failed to parse get-interpolant result: "++show val-handleRequest pipe (SMTInterpolate exprs) = case exprs of- [] -> return ([],pipe)- e:es -> do- resp <- mapM (\_ -> do- val <- parseResponse pipe- case lispToExpr commonFunctions- (findName $ smtState pipe)- (declaredDataTypes $ smtState pipe)- gcast (Just $ Fix BoolSort) 0 val of- Just (Just x) -> return x- _ -> error $ "smtlib2: Failed to parse get-interpolant result: "++show val- ) es- return (resp,pipe)-handleRequest pipe (SMTSetOption opt) = return ((),pipe)-handleRequest pipe (SMTSetLogic name) = return ((),pipe)-handleRequest pipe SMTGetProof = do- res <- parseResponse pipe- let proof = case res of- L.List items -> case findProof items of- Nothing -> res- Just p -> p- _ -> res- case lispToExpr (commonFunctions `mappend` commonTheorems)- (findName $ smtState pipe)- (declaredDataTypes $ smtState pipe) gcast (Just $ Fix BoolSort) 0 proof of- Just (Just x) -> return (x,pipe)- _ -> error $ "smtlib2: Couldn't parse proof "++show res- where- findProof [] = Nothing :: Maybe L.Lisp- findProof ((L.List [L.Symbol "proof",proof]):_) = Just proof- findProof (x:xs) = findProof xs-handleRequest pipe SMTGetUnsatCore = do- res <- parseResponse pipe- case res of- L.List names -> return- (fmap (\name -> case name of- L.Symbol s -> case T.unpack s of- '_':'c':'i':'d':cid- | all isDigit cid -> ClauseId (read cid)- str -> error $ "Language.SMTLib2.getUnsatCore: Unknown clause id "++str- _ -> error $ "Language.SMTLib2.getUnsatCore: Unknown expression "- ++show name++" in core list."- ) names,pipe)- _ -> error $ "Language.SMTLib2.getUnsatCore: Unknown response "++show res++" to query."-handleRequest pipe (SMTSimplify (expr::SMTExpr t)) = do- val <- parseResponse pipe- case lispToExpr commonFunctions- (findName $ smtState pipe) (declaredDataTypes $ smtState pipe)- gcast (Just $ getSort (undefined::t) (extractAnnotation expr)) 0 val of- Just (Just x) -> return (x,pipe)- _ -> error $ "smtlib2: Failed to parse simplify result: "++show val-handleRequest pipe SMTPush = return ((),pipe)-handleRequest pipe SMTPop = return ((),pipe)-handleRequest pipe (SMTGetValue (expr::SMTExpr t)) = do- let ann = extractAnnotation expr- sort = getSort (undefined::t) ann- PrimitiveUnmangling unm = unmangle :: Unmangling t- val <- parseResponse pipe- case val of- L.List [L.List [_,res]]- -> let res' = removeLets res- in case lispToValue' (declaredDataTypes $ smtState pipe) (Just sort) res' of- Just val' -> case unm val' ann of- Just val'' -> return (val'',pipe)- Nothing -> error $ "smtlib2: Failed to unmangle value "++show val'++" to type "++show (typeOf (undefined::t))- Nothing -> error $ "smtlib2: Failed to parse value from "++show res- _ -> error $ "smtlib2: Unexpected get-value response: "++show val-handleRequest pipe SMTGetModel = do- val <- parseResponse pipe- case val of- L.List (L.Symbol "model":mdl) -> return (foldl parseModel (SMTModel Map.empty) mdl,pipe)- _ -> error $ "smtlib2: Unexpected get-model response: "++show val- where- parseModel cur (L.List [L.Symbol "define-fun",- L.Symbol fname,- L.List args,- rtp,- fun]) = case mapM (\arg -> case arg of- L.List [L.Symbol argName,- argTp] -> case lispToSort argTp of- Just argTp' -> withSort (declaredDataTypes $ smtState pipe ) argTp' $- \u ann -> Just (argName,ProxyArg u ann)- _ -> Nothing- _ -> Nothing- ) args of- Just args' -> case lispToSort rtp of- Just rtp' -> let argMp = Map.fromList [ (name,(i,sort))- | (i,(name,sort)) <- zip [0..] args' ]- funId = case unescapeName (T.unpack fname) of- Nothing -> Nothing :: Maybe Integer- Just (Right idx) -> Just idx- Just (Left name) -> case Map.lookup name (namedVars $ smtState pipe) of- Just idx -> Just idx- Nothing -> Nothing- in case lispToExpr commonFunctions (\n -> do- (i,tp) <- Map.lookup n argMp- return $ QVar 0 i tp)- (declaredDataTypes $ smtState pipe)- UntypedExpr- (Just rtp')- 1- fun of- Just res -> case funId of- Nothing -> error $ "smtlib2: Model defines unknown function "++show fname- Just fid -> cur { modelFunctions = Map.insert fid (0,fmap snd args',res)- (modelFunctions cur)- }- Nothing -> error $ "smtlib2: Failed to parse return type: "++show rtp- Nothing -> error $ "smtlib2: Failed to parse argument specification "++show args- parseModel _ def = error $ "smtlib2: Failed to parse model entry: "++show def-handleRequest pipe (SMTApply tactic) = do- val <- parseResponse pipe- case val of- L.List (L.Symbol "goals":goals)- -> return- (fmap (\goal -> case goal of- L.List ((L.Symbol "goal"):expr:_)- -> case lispToExpr (commonFunctions `mappend` commonTheorems)- (findName $ smtState pipe)- (declaredDataTypes $ smtState pipe) gcast (Just $ Fix BoolSort) 0 expr of- Just (Just x) -> x- _ -> error $ "smtlib2: Couldn't parse goal "++show expr- _ -> error $ "smtlib2: Couldn't parse goal description "++show val- ) goals,pipe)-handleRequest pipe (SMTNameExpr name (expr::SMTExpr t)) = do- return (i,pipe { smtState = nst })- where- finfo = FunInfo { funInfoProxy = Proxy::Proxy ((),t)- , funInfoArgAnn = ()- , funInfoResAnn = extractAnnotation expr- , funInfoName = Just name }- (i,_,nst) = smtStateAddFun finfo (smtState pipe)-handleRequest pipe SMTNewInterpolationGroup = do- return (InterpolationGroup igrp,pipe { smtState = nst })- where- igrp = nextInterpolationGroup (smtState pipe)- nst = (smtState pipe) { nextInterpolationGroup = igrp+1 }-handleRequest pipe SMTNewClauseId = do- return (ClauseId icl,pipe { smtState = nst })- where- icl = nextClauseId (smtState pipe)- nst = (smtState pipe) { nextClauseId = icl+1 }--renderSMTResponse :: (Integer -> String) -> DataTypeInfo -> SMTRequest response -> response -> Maybe String-renderSMTResponse _ _ (SMTGetInfo SMTSolverName) name- = Just $ show $ L.List [L.Symbol ":name",L.String $ T.pack name]-renderSMTResponse _ _ (SMTGetInfo SMTSolverVersion) vers- = Just $ show $ L.List [L.Symbol ":version",L.String $ T.pack vers]-renderSMTResponse _ _ (SMTCheckSat _ _) res = case res of- Sat -> Just "sat"- Unsat -> Just "unsat"- Unknown -> Just "unknown"-renderSMTResponse getName dts (SMTGetInterpolant grps) expr- = Just $ renderExpr' getName dts expr-renderSMTResponse getName dts (SMTInterpolate _) exprs- = Just $ unwords [ renderExpr' getName dts expr- | expr <- exprs ]-renderSMTResponse getName dts SMTGetProof proof- = Just $ renderExpr' getName dts proof-renderSMTResponse getName dts (SMTSimplify _) expr- = Just $ renderExpr' getName dts expr-renderSMTResponse _ _ (SMTGetValue _) v = Just $ show v-renderSMTResponse getName dts (SMTApply _) goals- = Just $ show $- L.List $ [L.Symbol "goals"]++- [exprToLisp goal getName dts- | goal <- goals ]-renderSMTResponse _ _ SMTGetUnsatCore core = Just (show core)-renderSMTResponse getName dts SMTGetModel mdl- = Just $ "(model"++concat assignments++")"- where- assignments = [ "\n ("++getName fun++" "++- renderExpr' getName dts expr++")"- | (fun,(_,_,expr)) <- Map.toList $ modelFunctions mdl ]-renderSMTResponse _ _ _ _ = Nothing---- | Spawn a new SMT solver process and create a pipe to communicate with it.-createSMTPipe :: String -- ^ Path to the binary of the SMT solver- -> [String] -- ^ Command line arguments to be passed to the SMT solver- -> IO SMTPipe-createSMTPipe solver args = do- let cmd = (proc solver args) { std_in = CreatePipe- , std_out = CreatePipe- , std_err = Inherit- , create_group = True }- (Just hin,Just hout,_,handle) <- createProcess cmd- return $ SMTPipe { channelIn = hin- , channelOut = hout- , processHandle = handle- , smtState = emptySMTState }--sortToLisp :: Sort -> L.Lisp-sortToLisp s = sortToLisp' sortToLisp (unFix s)--argumentSortToLisp :: (Integer -> L.Lisp) -> ArgumentSort -> L.Lisp-argumentSortToLisp f sort = case unFix sort of- ArgumentSort i -> f i- NormalSort s -> sortToLisp' (argumentSortToLisp f) s--sortToLisp' :: (a -> L.Lisp) -> Sort' a -> L.Lisp-sortToLisp' _ BoolSort = L.Symbol "Bool"-sortToLisp' _ IntSort = L.Symbol "Int"-sortToLisp' _ RealSort = L.Symbol "Real"-sortToLisp' _ (BVSort { bvSortWidth = w })- = L.List [L.Symbol "_",- L.Symbol "BitVec",- L.toLisp w]-sortToLisp' f (ArraySort args' val)- = L.List ((L.Symbol "Array"):(fmap f args')++[f val])-sortToLisp' _ (NamedSort name []) = L.Symbol (T.pack name)-sortToLisp' f (NamedSort name args)- = L.List $ (L.Symbol $ T.pack name):fmap f args---- | Parse a lisp expression into an SMT sort.-lispToSort :: L.Lisp -> Maybe Sort-lispToSort (L.Symbol "Bool") = Just $ Fix BoolSort-lispToSort (L.Symbol "Int") = Just $ Fix IntSort-lispToSort (L.Symbol "Real") = Just $ Fix RealSort-lispToSort (L.List [L.Symbol "_",- L.Symbol "BitVec",- L.Number (L.I n)])- = Just $ Fix $ BVSort { bvSortWidth = n- , bvSortUntyped = False }-lispToSort (L.List (L.Symbol "Array":args)) = do- argSorts <- mapM lispToSort args'- resSort <- lispToSort res- return $ Fix $ ArraySort argSorts resSort- where- (args',res) = splitLast args- splitLast [s] = ([],s)- splitLast (x:xs) = let (xs',l) = splitLast xs- in (x:xs',l)-lispToSort (L.Symbol x) = Just $ Fix $ NamedSort (T.unpack x) []-lispToSort (L.List ((L.Symbol x):args)) = do- argSorts <- mapM lispToSort args- return $ Fix $ NamedSort (T.unpack x) argSorts-lispToSort _ = Nothing--{-getSMTName :: FunInfo -> String-getSMTName info = escapeName (case funInfoName info of- Nothing -> Right (funInfoId info)- Just name -> Left name)-}--findName :: SMTState -> T.Text -> Maybe (SMTExpr Untyped)-findName st name = case unescapeName (T.unpack name) of- Nothing -> Nothing- Just (Right idx) -> case Map.lookup idx (allVars st) of- Nothing -> Nothing- Just (FunInfo { funInfoProxy = _::Proxy (a,t)- , funInfoResAnn = ann- },nc) -> let expr :: SMTExpr t- expr = Var idx ann- in Just $ mkUntyped expr- Just (Left name') -> case Map.lookup name' (namedVars st) of- Nothing -> Nothing- Just idx -> case Map.lookup idx (allVars st) of- Nothing -> Nothing- Just (FunInfo { funInfoProxy = _::Proxy (a,t)- , funInfoResAnn = ann- },_) -> let expr :: SMTExpr t- expr = Var idx ann- in Just $ mkUntyped expr--mkUntyped :: SMTType t => SMTExpr t -> SMTExpr Untyped-mkUntyped e = case cast e of- Just e' -> e'- Nothing -> case cast e of- Just e' -> entypeValue UntypedExpr e'- Nothing -> UntypedExpr e--exprToLisp :: SMTExpr t -> (Integer -> String) -> DataTypeInfo -> L.Lisp-exprToLisp- = exprToLispWith- (\obj -> error $ "smtlib2: Can't translate internal object "++- show obj++" to s-expression.")--exprToLispWith :: (forall a. (Typeable a,Ord a,Show a) => a -> L.Lisp) -> SMTExpr t- -> (Integer -> String)- -> DataTypeInfo -> L.Lisp-exprToLispWith _ (Var idx _) mp _ = L.Symbol $ T.pack $ mp idx-exprToLispWith _ (QVar lvl idx _) _ _ = L.Symbol $ T.pack $ "q_"++show lvl++"_"++show idx-exprToLispWith _ (FunArg i _) _ _ = L.Symbol $ T.pack $ "farg_"++show i-exprToLispWith objs (Const x ann) mp dts = case mangle of- PrimitiveMangling f -> valueToLisp dts $ f x ann- ComplexMangling f -> exprToLispWith objs (f x ann) mp dts-exprToLispWith _ (AsArray f arg) mp _- = let f' = functionGetSymbol mp f arg- (sargs,sres) = functionSignature f arg- in L.List [L.Symbol "_",L.Symbol "as-array",if isOverloaded f- then L.List [f'- ,L.List $ fmap sortToLisp sargs- ,sortToLisp sres]- else f']-exprToLispWith objs (Forall lvl tps body) mp dts- = L.List [L.Symbol "forall"- ,L.List [L.List [L.Symbol $ T.pack $ "q_"++show lvl++"_"++show (i::Integer),sortToLisp sort]- | (i,tp) <- Prelude.zip [0..] tps- , let sort = withProxyArg tp getSort ]- ,exprToLispWith objs body mp dts]-exprToLispWith objs (Exists lvl tps body) mp dts- = L.List [L.Symbol "exists"- ,L.List [L.List [L.Symbol $ T.pack $ "q_"++show lvl++"_"++show (i::Integer),sortToLisp sort]- | (i,tp) <- Prelude.zip [0..] tps- , let sort = withProxyArg tp getSort ]- ,exprToLispWith objs body mp dts]-exprToLispWith objs (Let lvl args body) mp dts- = L.List [L.Symbol "let"- ,L.List [L.List [L.Symbol $ T.pack $ "q_"++show lvl++"_"++show (i::Integer),- exprToLispWith objs def mp dts]- | (i,def) <- Prelude.zip [0..] args ]- ,exprToLispWith objs body mp dts]-exprToLispWith objs (App fun x) mp dts- = let arg_ann = extractArgAnnotation x- l = functionGetSymbol mp fun arg_ann- x' = fmap (\e -> exprToLispWith objs e mp dts) (fromArgs x)- in if Prelude.null x'- then l- else L.List $ l:x'-exprToLispWith objs (Named expr idx) mp dts- = let expr' = exprToLispWith objs expr mp dts- name = mp idx- in L.List [L.Symbol "!",expr'- ,L.Symbol ":named"- ,L.Symbol $ T.pack name]-exprToLispWith objs (InternalObj obj ann) _ _ = objs obj-exprToLispWith objs (UntypedExpr expr) mp dts- = exprToLispWith objs expr mp dts-exprToLispWith objs (UntypedExprValue expr) mp dts- = exprToLispWith objs expr mp dts--isOverloaded :: SMTFunction a b -> Bool-isOverloaded SMTEq = True-isOverloaded (SMTMap _) = True-isOverloaded (SMTOrd _) = True-isOverloaded (SMTArith _) = True-isOverloaded SMTMinus = True-isOverloaded SMTNeg = True-isOverloaded SMTAbs = True-isOverloaded SMTDistinct = True-isOverloaded SMTITE = True-isOverloaded (SMTBVComp _) = True-isOverloaded (SMTBVBin _) = True-isOverloaded (SMTBVUn _) = True-isOverloaded SMTSelect = True-isOverloaded SMTStore = True-isOverloaded (SMTConstArray _) = True-isOverloaded SMTConcat = True-isOverloaded (SMTExtract _ _) = True-isOverloaded _ = False--functionSignature :: (Args a,SMTType b) => SMTFunction a b -> ArgAnnotation a -> ([Sort],Sort)-functionSignature f argAnn = withUndef f $- \ua ur -> (getSorts ua argAnn,- getSort ur resAnn)- where- resAnn = inferResAnnotation f argAnn- withUndef :: SMTFunction a b -> (a -> b -> r) -> r- withUndef _ f = f undefined undefined--functionGetSymbol :: (Integer -> String) -> SMTFunction a b -> ArgAnnotation a -> L.Lisp-functionGetSymbol _ SMTEq _ = L.Symbol "="-functionGetSymbol mp fun@(SMTMap f) ann- = L.List [L.Symbol "_",- L.Symbol "map",- sym]- where- getUndefI :: SMTFunction p (SMTArray i res) -> i- getUndefI _ = undefined- getUndefA :: SMTFunction arg res -> arg- getUndefA _ = undefined- ui = getUndefI fun- ua = getUndefA f- (ann_i,ann_v) = inferLiftedAnnotation ua ui ann- sym' = functionGetSymbol mp f ann_v- (sigArg,sigRes) = functionSignature f ann_v- sym = if isOverloaded f- then L.List [sym',- L.List (fmap sortToLisp sigArg),- sortToLisp sigRes]- else sym' -functionGetSymbol mp (SMTFun i _) _ = L.Symbol (T.pack $ mp i)-functionGetSymbol _ (SMTBuiltIn name _) _ = L.Symbol $ T.pack name-functionGetSymbol _ (SMTOrd op) _ = L.Symbol $ case op of- Ge -> ">="- Gt -> ">"- Le -> "<="- Lt -> "<"-functionGetSymbol _ (SMTArith op) _ = L.Symbol $ case op of- Plus -> "+"- Mult -> "*"-functionGetSymbol _ SMTMinus _ = L.Symbol "-"-functionGetSymbol _ (SMTIntArith op) _ = L.Symbol $ case op of- Div -> "div"- Mod -> "mod"- Rem -> "rem"-functionGetSymbol _ SMTDivide _ = L.Symbol "/"-functionGetSymbol _ SMTNeg _ = L.Symbol "-"-functionGetSymbol _ SMTAbs _ = L.Symbol "abs"-functionGetSymbol _ SMTNot _ = L.Symbol "not"-functionGetSymbol _ (SMTLogic op) _ = case op of- And -> L.Symbol "and"- Or -> L.Symbol "or"- XOr -> L.Symbol "xor"- Implies -> L.Symbol "=>"-functionGetSymbol _ SMTDistinct _ = L.Symbol "distinct"-functionGetSymbol _ SMTToReal _ = L.Symbol "to_real"-functionGetSymbol _ SMTToInt _ = L.Symbol "to_int"-functionGetSymbol _ SMTITE _ = L.Symbol "ite"-functionGetSymbol _ (SMTBVComp op) _ = L.Symbol $ case op of- BVULE -> "bvule"- BVULT -> "bvult"- BVUGE -> "bvuge"- BVUGT -> "bvugt"- BVSLE -> "bvsle"- BVSLT -> "bvslt"- BVSGE -> "bvsge"- BVSGT -> "bvsgt"-functionGetSymbol _ (SMTBVBin op) _ = L.Symbol $ case op of- BVAdd -> "bvadd"- BVSub -> "bvsub"- BVMul -> "bvmul"- BVURem -> "bvurem"- BVSRem -> "bvsrem"- BVUDiv -> "bvudiv"- BVSDiv -> "bvsdiv"- BVSHL -> "bvshl"- BVLSHR -> "bvlshr"- BVASHR -> "bvashr"- BVXor -> "bvxor"- BVAnd -> "bvand"- BVOr -> "bvor"-functionGetSymbol _ (SMTBVUn op) _ = case op of- BVNot -> L.Symbol "bvnot"- BVNeg -> L.Symbol "bvneg"-functionGetSymbol _ SMTSelect _ = L.Symbol "select"-functionGetSymbol _ SMTStore _ = L.Symbol "store"-functionGetSymbol _ f@(SMTConstArray i_ann) v_ann- = withUndef f $- \u_arr -> L.List [L.Symbol "as"- ,L.Symbol "const"- ,sortToLisp $ getSort u_arr (i_ann,v_ann)]- where- withUndef :: SMTFunction (SMTExpr v) (SMTArray i v)- -> (SMTArray i v -> a) -> a- withUndef _ f' = f' undefined-functionGetSymbol _ SMTConcat _ = L.Symbol "concat"-functionGetSymbol _ f@(SMTExtract prStart prLen) ann- = L.List [L.Symbol "_"- ,L.Symbol "extract"- ,L.Number $ L.I (start+len-1)- ,L.Number $ L.I start]- where- start = reflectNat prStart 0- len = reflectNat prLen 0-functionGetSymbol _ (SMTConstructor (Constructor _ _ con)) _ = L.Symbol $ T.pack (conName con)-functionGetSymbol _ (SMTConTest (Constructor _ _ con)) _ = L.Symbol $ T.pack $ "is-"++(conName con)-functionGetSymbol _ (SMTFieldSel (Field _ _ _ f)) _ = L.Symbol $ T.pack (fieldName f)-functionGetSymbol _ (SMTDivisible n) _ = L.List [L.Symbol "_",L.Symbol "divisible",L.Number $ L.I n]--clearInput :: MonadIO m => SMTPipe -> m ()-clearInput pipe = do- r <- liftIO $ hReady (channelOut pipe)- if r- then (do- _ <- liftIO $ BS.hGetSome (channelOut pipe) 1024- clearInput pipe)- else return ()--putRequest :: MonadIO m => SMTPipe -> L.Lisp -> m ()-putRequest pipe expr = do- clearInput pipe- liftIO $ toByteStringIO (BS.hPutStr $ channelIn pipe) (mappend (L.fromLispExpr expr) flush)- liftIO $ BS8.hPutStrLn (channelIn pipe) ""- liftIO $ hFlush (channelIn pipe)--parseResponse :: MonadIO m => SMTPipe -> m L.Lisp-parseResponse pipe = do- str <- liftIO $ BS.hGetLine (channelOut pipe)- let continue (Done _ r) = return r- continue res@(Partial _) = do- line <- liftIO $ BS.hGetLine (channelOut pipe)- continue (feed (feed res line) (BS8.singleton '\n'))- continue (Fail str' ctx msg) = error $ "Error parsing "++show str'++" response in "++show ctx++": "++msg- continue $ parse L.lisp (BS8.snoc str '\n')--args :: [L.Lisp] -> L.Lisp-args [] = L.Symbol "()"-args xs = L.List xs--removeLets :: L.Lisp -> L.Lisp-removeLets = removeLets' Map.empty- where- removeLets' mp (L.List [L.Symbol "let",L.List decls,body])- = let nmp = Map.union mp- (Map.fromList- [ (name,removeLets' nmp expr)- | L.List [L.Symbol name,expr] <- decls ])- in removeLets' nmp body- removeLets' mp (L.Symbol sym) = case Map.lookup sym mp of- Nothing -> L.Symbol sym- Just r -> r- removeLets' mp (L.List entrs) = L.List $ fmap (removeLets' mp) entrs- removeLets' _ x = x--newtype FunctionParser = FunctionParser { parseFun :: L.Lisp- -> FunctionParser- -> DataTypeInfo- -> Maybe FunctionParser' }--instance Monoid FunctionParser where- mempty = FunctionParser $ \_ _ _ -> Nothing- mappend p1 p2 = FunctionParser $ \l fun dts -> case parseFun p1 l fun dts of- Nothing -> parseFun p2 l fun dts- Just r -> Just r--data FunctionParser'- = OverloadedParser { sortConstraint :: [Sort] -> Bool- , deriveRetSort :: [Sort] -> Maybe Sort- , parseOverloaded :: forall a. [Sort] -> Sort- -> (forall arg res. (Liftable arg,SMTType res) => SMTFunction arg res -> a)- -> Maybe a }- | DefinedParser { definedArgSig :: [Sort]- , definedRetSig :: Sort- , parseDefined :: forall a. (forall arg res. (Liftable arg,SMTType res) => SMTFunction arg res -> a)- -> Maybe a }---- | A map which contains signatures for a few common theorems which can be used in the proofs which 'getProof' returns.-commonTheorems :: FunctionParser-commonTheorems = mconcat- [nameParser (L.Symbol "|unit-resolution|")- (OverloadedParser (const True)- (const $ Just $ Fix BoolSort)- $ \_ _ f -> Just $ f (SMTBuiltIn "|unit-resolution|" () :: SMTFunction [SMTExpr Bool] Bool))- ,simpleParser (SMTBuiltIn "asserted" () :: SMTFunction (SMTExpr Bool) Bool)- ,simpleParser (SMTBuiltIn "hypothesis" () :: SMTFunction (SMTExpr Bool) Bool)- ,simpleParser (SMTBuiltIn "lemma" () :: SMTFunction (SMTExpr Bool) Bool)- ,simpleParser (SMTBuiltIn "monotonicity" () :: SMTFunction (SMTExpr Bool,SMTExpr Bool) Bool)- ,simpleParser (SMTBuiltIn "trans" () :: SMTFunction (SMTExpr Bool,SMTExpr Bool,SMTExpr Bool) Bool)- ,simpleParser (SMTBuiltIn "rewrite" () :: SMTFunction (SMTExpr Bool) Bool)- ,simpleParser (SMTBuiltIn "mp" () :: SMTFunction (SMTExpr Bool,SMTExpr Bool,SMTExpr Bool) Bool)]--lispToValue :: DataTypeInfo -> Maybe Sort -> L.Lisp -> Maybe Value-lispToValue _ sort (L.Symbol "true") = case sort of- Nothing -> Just $ BoolValue True- Just (Fix BoolSort) -> Just $ BoolValue True- Just _ -> Nothing-lispToValue _ sort (L.Symbol "false") = case sort of- Nothing -> Just $ BoolValue False- Just (Fix BoolSort) -> Just $ BoolValue False- Just _ -> Nothing-lispToValue _ sort (L.Number (L.I x)) = case sort of- Nothing -> Just $ IntValue x- Just (Fix RealSort) -> Just $ RealValue (fromInteger x)- Just (Fix IntSort) -> Just $ IntValue x- Just (Fix (BVSort { bvSortWidth = w })) -> Just $ BVValue { bvValueWidth = w- , bvValueValue = x }- Just _ -> Nothing-lispToValue dts sort (L.List [L.Symbol "-",v])- = case lispToValue dts sort v of- Just (RealValue x) -> Just $ RealValue (-x)- Just (IntValue x) -> Just $ IntValue (-x)- _ -> Nothing-lispToValue _ sort (L.Number (L.D x)) = case sort of- Nothing -> Just $ RealValue (realToFrac x)- Just (Fix RealSort) -> Just $ RealValue (realToFrac x)- Just _ -> Nothing-lispToValue dts sort (L.List [L.Symbol "/",x,y]) = case sort of- Nothing -> result- Just (Fix RealSort) -> result- Just _ -> Nothing- where- result = do- RealValue x' <- lispToValue dts (Just $ Fix RealSort) x- RealValue y' <- lispToValue dts (Just $ Fix RealSort) y- return $ RealValue $ x' / y'-lispToValue _ sort (L.Symbol s) = case sort of- Nothing -> result- Just (Fix (BVSort {})) -> result- Just _ -> Nothing- where- result = case T.unpack s of- '#':'b':rest -> let len = genericLength rest- in case readInt 2- (\x -> x=='0' || x=='1')- (\x -> if x=='0' then 0 else 1)- rest of- [(v,_)] -> Just $ BVValue { bvValueWidth = len- , bvValueValue = v }- _ -> Nothing- '#':'x':rest -> let len = (genericLength rest)*4- in case readHex rest of- [(v,_)] -> Just $ BVValue { bvValueWidth = len- , bvValueValue = v }- _ -> Nothing- _ -> Nothing-lispToValue _ sort (L.List [L.Symbol "_",L.Symbol val,L.Number (L.I bits)])- = case sort of- Nothing -> result- Just (Fix (BVSort {})) -> result- Just _ -> Nothing- where- result = case T.unpack val of- 'b':'v':num -> Just $ BVValue { bvValueWidth = fromIntegral bits- , bvValueValue = read num }- _ -> Nothing-lispToValue _ _ _ = Nothing--lispToValue' :: DataTypeInfo -> Maybe Sort -> L.Lisp -> Maybe Value-lispToValue' dts sort l = case lispToValue dts sort l of- Just res -> Just res- Nothing -> case sort of- Just (Fix (NamedSort name argSorts)) -> lispToConstr dts (Just (name,argSorts)) l- _ -> error $ "smtlib2: Cannot translate "++show l++" to value"--lispToConstr :: DataTypeInfo -> Maybe (String,[Sort]) -> L.Lisp -> Maybe Value-lispToConstr dts sort (L.List [L.Symbol "as",- expr,- dt]) = do- sort' <- lispToSort dt- case sort' of- Fix (NamedSort name args) -> lispToConstr dts (Just (name,args)) expr-lispToConstr dts sort (L.Symbol n)- = let rn = T.unpack n- in case Map.lookup rn (constructors dts) of- Just (constr,dt,coll)- -> Just (ConstrValue rn [] (case sort of- Just s -> Just s- Nothing -> Nothing))-lispToConstr dts sort (L.List ((L.Symbol name):args)) = do- let (constr,dt,coll) = case Map.lookup (T.unpack name) (constructors dts) of- Just r -> r- Nothing -> error $ "smtlib2: Can't find constructor for "++(T.unpack name)- argSorts = fmap (\field -> getArgSort (fieldSort field)- ) (conFields constr)- args' <- mapM (\(l,s) -> lispToValue' dts s l) (zip args argSorts)- return $ ConstrValue (T.unpack name) args'- (case sort of- Just sort' -> Just sort'- Nothing -> Nothing)- where- getArgSort (Fix (ArgumentSort n)) = case sort of- Just (_,args) -> Just $ args `genericIndex` n- _ -> Nothing- getArgSort (Fix (NormalSort s)) = case s of- BoolSort -> Just $ Fix BoolSort- IntSort -> Just $ Fix IntSort- RealSort -> Just $ Fix RealSort- BVSort w u -> Just $ Fix (BVSort w u)- ArraySort idx v -> do- idx' <- mapM getArgSort idx- v' <- getArgSort v- return $ Fix $ ArraySort idx' v'- NamedSort name args -> do- args' <- mapM getArgSort args- return $ Fix $ NamedSort name args'-lispToConstr _ _ _ = Nothing--valueToLisp :: DataTypeInfo -> Value -> L.Lisp-valueToLisp _ (BoolValue False) = L.Symbol "false"-valueToLisp _ (BoolValue True) = L.Symbol "true"-valueToLisp _ (IntValue i) = if i<0- then L.List [L.Symbol "-"- ,L.Number $ L.I (abs i)]- else L.Number $ L.I i-valueToLisp _ (RealValue i)- = let res = L.List [L.Symbol "/"- ,L.Number $ L.I (abs $ numerator i)- ,L.Number $ L.I $ denominator i]- in if i<0- then L.List [L.Symbol "-"- ,res]- else res-valueToLisp _ (BVValue { bvValueWidth = w- , bvValueValue = v })- = L.List [L.Symbol "_"- ,L.Symbol $ T.pack $ "bv"++(if v>=0- then show v- else show (2^w + v))- ,L.Number $ L.I w]-valueToLisp dts (ConstrValue name vals sort)- = let constr = case sort of- Just (tp,sort') -> L.List [L.Symbol "as"- ,L.Symbol $ T.pack name- ,if null sort'- then L.Symbol $ T.pack tp- else L.List $ [L.Symbol $ T.pack tp]++(fmap sortToLisp sort')]- Nothing -> L.Symbol $ T.pack name- in case vals of- [] -> constr- _ -> L.List (constr:(fmap (valueToLisp dts) vals))---- | Parse a lisp expression into an SMT expression.--- Since we cannot know what type the expression might have, we pass a--- general function which may take any SMT expression and produce the desired--- result.-lispToExpr :: FunctionParser -- ^ The parser to use for function symbols- -> (T.Text -> Maybe (SMTExpr Untyped)) -- ^ How to handle variable names- -> DataTypeInfo -- ^ Information about declared data types- -> (forall a. SMTType a => SMTExpr a -> b) -- ^ A function to apply to the resulting SMT expression- -> Maybe Sort -- ^ If you know the sort of the expression, you can pass it here.- -> Integer -- ^ The current quantification level- -> L.Lisp -- ^ The lisp expression to parse- -> Maybe b-lispToExpr = lispToExprWith lispToExpr--lispToExprWith :: (forall b. FunctionParser- -> (T.Text -> Maybe (SMTExpr Untyped))- -> DataTypeInfo- -> (forall a. SMTType a => SMTExpr a -> b)- -> Maybe Sort- -> Integer- -> L.Lisp -> Maybe b) -- ^ Recursive descend function- -> FunctionParser -- ^ The parser to use for function symbols- -> (T.Text -> Maybe (SMTExpr Untyped)) -- ^ How to handle variable names- -> DataTypeInfo -- ^ Information about declared data types- -> (forall a. SMTType a => SMTExpr a -> b) -- ^ A function to apply to the resulting SMT expression- -> Maybe Sort -- ^ If you know the sort of the expression, you can pass it here.- -> Integer -- ^ The current quantification level- -> L.Lisp -- ^ The lisp expression to parse- -> Maybe b-lispToExprWith recp fun bound dts f expected lvl l = case lispToValue dts expected l of- Just val -> valueToHaskell dts- (\_ (val'::t) ann- -> asValueType (undefined::t) ann $- \(_::tv) ann' -> case cast (val',ann') of- Just (rval::tv,rann::SMTAnnotation tv) -> f $ Const rval rann- ) expected val- Nothing -> case preprocessHack l of- L.Symbol name -> case bound name of- Nothing -> Nothing- Just subst -> entype (\expr -> Just $ f expr) subst- L.List [L.Symbol "forall",L.List args',body]- -> fmap f $ quantToExpr recp Forall fun bound dts args' lvl body- L.List [L.Symbol "exists",L.List args',body]- -> fmap f $ quantToExpr recp Exists fun bound dts args' lvl body- L.List [L.Symbol "let",L.List args',body]- -> parseLet recp fun bound dts f expected args' lvl body- L.List [L.Symbol "_",L.Symbol "as-array",fsym]- -> case parseFun fun fsym fun dts of- Nothing -> Nothing- Just (DefinedParser arg_sort _ parse)- -> parse $ \(rfun :: SMTFunction arg res) -> case getArgAnnotation (undefined::arg) arg_sort of- (ann,[]) -> f (AsArray rfun ann)- (_,_) -> error "smtlib2: Arguments not wholy parsed."- Just _ -> error "smtlib2: as-array can't handle overloaded functions."- L.List (fsym:args') -> case parseFun fun fsym fun dts of- Nothing -> Nothing- Just (OverloadedParser constr derive parse)- -> do- nargs <- lispToExprs constr args'- let arg_tps = fmap (entype $ \(expr::SMTExpr t)- -> getSort (undefined::t) (extractAnnotation expr)- ) nargs- parse arg_tps- (case derive arg_tps of- Nothing -> case expected of- Nothing -> error $ "smtlib2: Couldn't infer return type of "++show l- Just s -> s- Just s -> s) $- \(rfun :: SMTFunction arg res)- -> case (do- let (ann,[]) = getArgAnnotation (undefined::arg) arg_tps- (rargs,rest) <- toArgs ann nargs- case rest of- [] -> Just $ App rfun rargs- _ -> Nothing) of- Just e -> f e- Nothing -> error $ "smtlib2: Wrong arguments for function "++show fsym++": "++show arg_tps++" (Expected: "++show args'++")."- Just (DefinedParser arg_tps _ parse) -> do- nargs <- mapM (\(el,tp) -> recp fun bound dts mkUntyped (Just tp) lvl el)- (zip args' arg_tps)- parse $ \(rfun :: SMTFunction arg res)- -> case (do- let (ann,[]) = getArgAnnotation (undefined::arg) arg_tps- (rargs,rest) <- toArgs ann nargs- case rest of- [] -> Just $ App rfun rargs- _ -> Nothing) of- Just e -> f e- Nothing -> error $ "smtlib2: Wrong arguments for function "++show fsym++" (Expected: "++show arg_tps++")"- _ -> Nothing- where- lispToExprs constr exprs = do- res <- mapM (\arg -> recp fun bound dts mkUntyped Nothing lvl arg) exprs- let sorts = fmap (entype exprSort) res- if constr sorts- then return res- else (case generalizeSorts sorts of- Just sorts' -> mapM (\(arg,sort') -> recp fun bound dts mkUntyped (Just sort') lvl arg) (zip exprs sorts')- Nothing -> return res)- preprocessHack (L.List ((L.Symbol "concat"):args)) = foldl1 (\expr arg -> L.List [L.Symbol "concat",expr,arg]) args- preprocessHack x = x--generalizeSort :: Sort -> Maybe Sort-generalizeSort (Fix (BVSort i False)) = Just $ Fix $ BVSort i True-generalizeSort (Fix (ArraySort idx cont)) = case generalizeSorts idx of- Just idx' -> case generalizeSort cont of- Just cont' -> Just $ Fix $ ArraySort idx' cont'- Nothing -> Just $ Fix $ ArraySort idx' cont- Nothing -> case generalizeSort cont of- Just cont' -> Just $ Fix $ ArraySort idx cont'- Nothing -> Nothing-generalizeSort (Fix (NamedSort n args)) = case generalizeSorts args of- Nothing -> Nothing- Just args' -> Just $ Fix $ NamedSort n args'-generalizeSort _ = Nothing--generalizeSorts :: [Sort] -> Maybe [Sort]-generalizeSorts [] = Nothing-generalizeSorts (x:xs) = case generalizeSort x of- Nothing -> case generalizeSorts xs of- Just xs' -> Just $ x:xs'- Nothing -> Nothing- Just x' -> case generalizeSorts xs of- Nothing -> Just $ x':xs- Just xs' -> Just $ x':xs'--exprSort :: SMTType a => SMTExpr a -> Sort-exprSort (expr::SMTExpr a) = getSort (undefined::a) (extractAnnotation expr)--quantToExpr :: (forall b. FunctionParser- -> (T.Text -> Maybe (SMTExpr Untyped))- -> DataTypeInfo- -> (forall a. SMTType a => SMTExpr a -> b)- -> Maybe Sort- -> Integer- -> L.Lisp -> Maybe b) -- ^ Recursive descend function- -> (Integer -> [ProxyArg] -> SMTExpr Bool -> SMTExpr Bool)- -> FunctionParser- -> (T.Text -> Maybe (SMTExpr Untyped))- -> DataTypeInfo- -> [L.Lisp] -> Integer -> L.Lisp -> Maybe (SMTExpr Bool)-quantToExpr recp con fun bound dts args lvl body = do- argLst <- mapM (\el -> case el of- L.List [L.Symbol name,tp] -> do- sort <- lispToSort tp- return (name,withSort dts sort ProxyArg)- _ -> Nothing- ) args- let argMp = Map.fromList [ (name,(i,tp))- | (i,(name,tp)) <- Prelude.zip [0..] argLst ]- bound' name = case Map.lookup name argMp of- Just (idx,tp) -> Just (QVar lvl idx tp)- Nothing -> bound name- recp fun bound' dts- (\body' -> case cast body' of- Just body'' -> con lvl (fmap snd argLst) body''- ) (Just $ Fix BoolSort) (lvl+1) body--parseLet :: (forall b. FunctionParser- -> (T.Text -> Maybe (SMTExpr Untyped))- -> DataTypeInfo- -> (forall a. SMTType a => SMTExpr a -> b)- -> Maybe Sort- -> Integer- -> L.Lisp -> Maybe b) -- ^ Recursive descend function- -> FunctionParser- -> (T.Text -> Maybe (SMTExpr Untyped))- -> DataTypeInfo- -> (forall a. SMTType a => SMTExpr a -> b)- -> Maybe Sort- -> [L.Lisp] -> Integer -> L.Lisp -> Maybe b-parseLet recp fun bound dts app expected args lvl body = do- argLst <- mapM (\el -> case el of- L.List [L.Symbol name,expr] -> do- expr' <- recp fun bound dts UntypedExpr Nothing (lvl+1) expr- return (name,expr')- _ -> Nothing- ) args- let argMp = Map.fromList [ (name,(i,extractAnnotation expr))- | (i,(name,expr)) <- Prelude.zip [0..] argLst ]- bound' name = case Map.lookup name argMp of- Just (idx,tp) -> Just (QVar lvl idx tp)- Nothing -> bound name- recp fun bound' dts- (\body' -> app (Let lvl (fmap snd argLst) body')- ) expected (lvl+1) body--withFirstArgSort :: DataTypeInfo -> L.Lisp -> [Sort] -> (forall t. SMTType t => t -> SMTAnnotation t -> a) -> a-withFirstArgSort dts _ (s:rest) f = case s of- Fix (BVSort i False) -> if any (\sort -> case sort of- Fix (BVSort _ True) -> True- _ -> False) rest- then withSort dts (Fix $ BVSort i True) f- else withSort dts s f- _ -> withSort dts s f-withFirstArgSort _ sym [] _ = error $ "smtlib2: Function "++show sym++" needs at least one argument."--nameParser :: L.Lisp -> FunctionParser' -> FunctionParser-nameParser name sub = FunctionParser (\sym _ _ -> if sym==name- then Just sub- else Nothing)--allEqConstraint :: [Sort] -> Bool-allEqConstraint (x:xs) = all (==x) xs-allEqConstraint [] = True--simpleParser :: (Liftable arg,SMTType res,Unit (ArgAnnotation arg),Unit (SMTAnnotation res))- => SMTFunction arg res -> FunctionParser-simpleParser fun- = let fsym = functionGetSymbol (error "smtlib2: Don't lookup names in simpleParser") fun unit- (uargs,ures) = getFunUndef fun- in nameParser fsym (DefinedParser- (getSorts uargs unit)- (getSort ures unit)- $ \f -> Just $ f fun)---- | A parser for all available SMT logics.-commonFunctions :: FunctionParser-commonFunctions = mconcat- [fieldParser- ,constructorParser- ,eqParser- ,mapParser- ,ordOpParser- ,arithOpParser- ,minusParser- ,intArithParser- ,divideParser- ,absParser- ,logicParser- ,iteParser- ,distinctParser- ,toRealParser- ,toIntParser- ,bvCompParser- ,bvBinOpParser- ,bvUnOpParser- ,selectParser- ,storeParser- ,constArrayParser- ,concatParser- ,extractParser- ,sigParser- ,divisibleParser]--eqParser,- mapParser,- ordOpParser,- arithOpParser,- minusParser,- intArithParser,- divideParser,- absParser,- logicParser,- iteParser,- distinctParser,- toRealParser,- toIntParser,- bvCompParser,- bvBinOpParser,- bvUnOpParser,- selectParser,- storeParser,- constArrayParser,- concatParser,- extractParser,- sigParser,- divisibleParser :: FunctionParser-eqParser = FunctionParser v- where- v (L.Symbol "=") rec dts = Just $ OverloadedParser allEqConstraint- (const $ Just $ getSort (undefined::Bool) ()) $- \sort_arg _ f- -> withFirstArgSort dts "=" sort_arg $- \(_::t) _ -> Just $ f (SMTEq :: SMTFunction [SMTExpr t] Bool)- v _ _ _ = Nothing--mapParser = FunctionParser v- where- v (L.List [L.Symbol "_"- ,L.Symbol "map"- ,fun]) rec dts-#ifdef SMTLIB2_WITH_CONSTRAINTS- = case parseFun rec fun rec dts of- Nothing -> Nothing :: Maybe FunctionParser'- Just (DefinedParser _ ret_sig parse)- -> Just $ OverloadedParser- { sortConstraint = const True- , deriveRetSort = \arg -> case arg of- Fix (ArraySort i _):_ -> Just (Fix $ ArraySort i ret_sig)- _ -> error "smtlib2: map function must have arrays as arguments."- , parseOverloaded = \_ ret f- -> let idx_sort = case ret of- Fix (ArraySort i _) -> i- _ -> error "smtlib2: map function must have arrays as return type."- in parse $ \(fun' :: SMTFunction arg res)- -> withSorts dts idx_sort $- \(_::i) _- -> let res = SMTMap fun' :: SMTFunction (Lifted arg i) (SMTArray i res)- in case getConstraint (Proxy :: Proxy (arg,i)) of- Dict -> f res- }- Just _ -> error "smtlib2: map function can't handle overloaded functions."-#else- = Just $ error "smtlib2: Compile smtlib2 with -fWithConstraints to enable parsing of map functions"-#endif- v _ _ _ = Nothing--ordOpParser = FunctionParser $ \sym _ dts -> case sym of- L.Symbol ">=" -> p sym Ge dts- L.Symbol ">" -> p sym Gt dts- L.Symbol "<=" -> p sym Le dts- L.Symbol "<" -> p sym Lt dts- _ -> Nothing- where- p :: L.Lisp -> SMTOrdOp -> DataTypeInfo -> Maybe FunctionParser'- p sym op dts = Just $ OverloadedParser allEqConstraint (const $ Just $ getSort (undefined::Bool) ()) $- \[sort_arg,_] _ f -> withNumSort dts sort_arg $- \(_::t) _- -> f (SMTOrd op :: SMTFunction (SMTExpr t,SMTExpr t) Bool)--arithOpParser = FunctionParser $ \sym _ dts -> case sym of- L.Symbol "+" -> Just $ OverloadedParser allEqConstraint (\sorts -> Just (head sorts)) $- \_ sort_ret f- -> withNumSort dts sort_ret $- \(_::t) _- -> f (SMTArith Plus::SMTFunction [SMTExpr t] t)- L.Symbol "*" -> Just $ OverloadedParser allEqConstraint (\sorts -> Just (head sorts)) $- \_ sort_ret f- -> withNumSort dts sort_ret $- \(_::t) _- -> f (SMTArith Mult::SMTFunction [SMTExpr t] t)- _ -> Nothing--minusParser = FunctionParser $ \sym _ dts -> case sym of- L.Symbol "-" -> Just $ OverloadedParser allEqConstraint (\sorts -> Just (head sorts)) $- \sort_arg _ f -> case sort_arg of- [] -> error "smtlib2: minus function needs at least one argument"- [s] -> withNumSort dts s $ \(_::t) _ -> f (SMTNeg::SMTFunction (SMTExpr t) t)- (s:_) -> withNumSort dts s $ \(_::t) _ -> f (SMTMinus::SMTFunction (SMTExpr t,SMTExpr t) t)- _ -> Nothing--intArithParser = mconcat [simpleParser (SMTIntArith Div)- ,simpleParser (SMTIntArith Mod)- ,simpleParser (SMTIntArith Rem)]--divideParser = simpleParser SMTDivide--absParser = FunctionParser $ \sym _ dts -> case sym of- L.Symbol "abs" -> Just $ OverloadedParser (const True) (\sorts -> Just $ head sorts) $- \_ sort_ret f- -> withNumSort dts sort_ret $ \(_::t) _ -> f (SMTAbs::SMTFunction (SMTExpr t) t)- _ -> Nothing--logicParser = mconcat $- (simpleParser SMTNot)- :[ nameParser (L.Symbol name)- (OverloadedParser (const True)- (const $ Just $ getSort (undefined::Bool) ())- $ \_ _ f -> Just $ f (SMTLogic p))- | (name,p) <- [("and",And),("or",Or),("xor",XOr),("=>",Implies)]]--distinctParser = FunctionParser $ \sym _ dts -> case sym of- L.Symbol "distinct" -> Just $ OverloadedParser allEqConstraint- (const $ Just $ getSort (undefined::Bool) ()) $- \sort_arg _ f- -> withFirstArgSort dts "distinct" sort_arg $- \(_::t) _ -> Just $ f (SMTDistinct::SMTFunction [SMTExpr t] Bool)- _ -> Nothing--toRealParser = simpleParser SMTToReal-toIntParser = simpleParser SMTToInt--iteParser = FunctionParser $ \sym _ dts -> case sym of- L.Symbol "ite" -> Just $ OverloadedParser (\sorts -> case sorts of- [_,s1,s2] -> s1==s2- _ -> False)- (\sorts -> case sorts of- [_,s,_] -> Just s- _ -> error $ "smtlib2: Wrong number of arguments to ite (expected 3, got "++show (length sorts)++".") $- \_ sort_ret f- -> withSort dts sort_ret $- \(_::t) _ -> Just $ f (SMTITE :: SMTFunction (SMTExpr Bool,SMTExpr t,SMTExpr t) t)- _ -> Nothing--bvCompParser = FunctionParser $ \sym _ _ -> case sym of- L.Symbol "bvule" -> p BVULE- L.Symbol "bvult" -> p BVULT- L.Symbol "bvuge" -> p BVUGE- L.Symbol "bvugt" -> p BVSLE- L.Symbol "bvsle" -> p BVSLE- L.Symbol "bvslt" -> p BVSLT- L.Symbol "bvsge" -> p BVSGE- L.Symbol "bvsgt" -> p BVSGT- _ -> Nothing- where- p :: SMTBVCompOp -> Maybe FunctionParser'- p op = Just $ OverloadedParser allEqConstraint (const $ Just $ getSort (undefined::Bool) ()) $- \sort_arg _ f -> case sort_arg of- (Fix (BVSort i False):_)- -> reifyNat i $ \(_::Proxy n)- -> Just $ f (SMTBVComp op::SMTFunction (SMTExpr (BitVector (BVTyped n)),- SMTExpr (BitVector (BVTyped n))) Bool)- (Fix (BVSort _ True):_)- -> Just $ f (SMTBVComp op::SMTFunction (SMTExpr (BitVector BVUntyped),- SMTExpr (BitVector BVUntyped)) Bool)- _ -> error "smtlib2: Bitvector comparision needs bitvector arguments."--bvBinOpParser = FunctionParser $ \sym _ _ -> case sym of- L.Symbol "bvadd" -> p BVAdd- L.Symbol "bvsub" -> p BVSub- L.Symbol "bvmul" -> p BVMul- L.Symbol "bvurem" -> p BVURem- L.Symbol "bvsrem" -> p BVSRem- L.Symbol "bvudiv" -> p BVUDiv- L.Symbol "bvsdiv" -> p BVSDiv- L.Symbol "bvshl" -> p BVSHL- L.Symbol "bvlshr" -> p BVLSHR- L.Symbol "bvashr" -> p BVASHR- L.Symbol "bvxor" -> p BVXor- L.Symbol "bvand" -> p BVAnd- L.Symbol "bvor" -> p BVOr- _ -> Nothing- where- p :: SMTBVBinOp -> Maybe FunctionParser'- p op = Just $ OverloadedParser allEqConstraint (Just . head) $- \_ sort_ret f -> case sort_ret of- Fix (BVSort i False)- -> reifyNat i (\(_::Proxy n)- -> Just $ f (SMTBVBin op::SMTFunction (SMTExpr (BitVector (BVTyped n)),- SMTExpr (BitVector (BVTyped n)))- (BitVector (BVTyped n))))- Fix (BVSort _ True)- -> Just $ f (SMTBVBin op::SMTFunction (SMTExpr (BitVector BVUntyped),- SMTExpr (BitVector BVUntyped))- (BitVector BVUntyped))- _ -> Nothing--bvUnOpParser = FunctionParser $ \sym _ _ -> case sym of- L.Symbol "bvnot"- -> Just $ OverloadedParser (const True) (Just . head) $- \_ sort_ret f -> case sort_ret of- Fix (BVSort i False)- -> reifyNat i $ \(_::Proxy n)- -> Just $ f (SMTBVUn BVNot::SMTFunction (SMTExpr (BitVector (BVTyped n)))- (BitVector (BVTyped n)))- Fix (BVSort _ True) -> Just $ f (SMTBVUn BVNot::SMTFunction (SMTExpr (BitVector BVUntyped))- (BitVector BVUntyped))- _ -> Nothing- L.Symbol "bvneg"- -> Just $ OverloadedParser (const True) (Just . head) $- \_ sort_ret f -> case sort_ret of- Fix (BVSort i False)- -> reifyNat i $ \(_::Proxy n)- -> Just $ f (SMTBVUn BVNeg::SMTFunction (SMTExpr (BitVector (BVTyped n)))- (BitVector (BVTyped n)))- Fix (BVSort _ True) -> Just $ f (SMTBVUn BVNeg::SMTFunction (SMTExpr (BitVector BVUntyped))- (BitVector BVUntyped))- _ -> Nothing- _ -> Nothing--selectParser = FunctionParser $ \sym _ dts -> case sym of- L.Symbol "select"- -> Just $ OverloadedParser (const True)- (\sort_arg -> case sort_arg of- (Fix (ArraySort _ vsort):_) -> Just vsort- _ -> error $ "smtlib2: Wrong arguments for select function ("++show sort_arg++").") $- \sort_arg sort_ret f -> case sort_arg of- (Fix (ArraySort isort1 _):_)- -> withSorts dts isort1 $- \(_::i) _ -> withSort dts sort_ret $- \(_::v) _ -> Just $ f (SMTSelect::SMTFunction (SMTExpr (SMTArray i v),i) v)- _ -> error $ "smtlib2: Wrong arguments for select function ("++show sort_arg++")."- _ -> Nothing--storeParser = FunctionParser $ \sym _ dts -> case sym of- L.Symbol "store"- -> Just $ OverloadedParser (\tps -> case tps of- (Fix (ArraySort idx res)):tps' -> checkArraySort idx res tps'- _ -> False)- (\sort_arg -> case sort_arg of- s:_ -> Just s- _ -> error "smtlib2: Wrong arguments for store function.") $- \_ sort_ret f -> case sort_ret of- Fix (ArraySort idx val)- -> withArraySort dts idx val $- \(_::SMTArray i v) _- -> Just $ f (SMTStore::SMTFunction (SMTExpr (SMTArray i v),i,SMTExpr v) (SMTArray i v))- _ -> error "smtlib2: Wrong return type for store function."- _ -> Nothing- where- checkArraySort [] cont [tp] = cont==tp- checkArraySort (arg:args) cont (tp:tps) = arg==tp && checkArraySort args cont tps- checkArraySort _ _ _ = False--constArrayParser = FunctionParser g- where- g (L.List [L.Symbol "as"- ,L.Symbol "const"- ,s]) _ dts- = case lispToSort s of- Just rsort@(Fix (ArraySort idx val))- -> Just $ DefinedParser [val] rsort $- \f -> withArraySort dts idx val $- \(_::SMTArray i v) (i_ann,_)- -> Just $ f (SMTConstArray i_ann::SMTFunction (SMTExpr v) (SMTArray i v))- _ -> Nothing- g _ _ _ = Nothing--concatParser = nameParser (L.Symbol "concat")- (OverloadedParser (const True)- (\args' -> let lenSum = sum $ fmap (\(Fix (BVSort i _)) -> i) args'- untypedRes = any (\(Fix (BVSort _ isUntyped)) -> isUntyped) args'- in Just $ Fix $ BVSort lenSum untypedRes)- (\sort_arg _ f -> case sort_arg of- [Fix (BVSort i1 False),Fix (BVSort i2 False)]- -> reifySum i1 i2 $- \(_::Proxy n1) (_::Proxy n2) _- -> Just $ f (SMTConcat::SMTFunction (SMTExpr (BitVector (BVTyped n1)),- SMTExpr (BitVector (BVTyped n2)))- (BitVector (ConcatResult (BVTyped n1) (BVTyped n2))))- [Fix (BVSort _ True),Fix (BVSort i2 False)]- -> reifyNat i2 $- \(_::Proxy n2)- -> Just $ f (SMTConcat::SMTFunction (SMTExpr (BitVector BVUntyped),- SMTExpr (BitVector (BVTyped n2)))- (BitVector BVUntyped))- [Fix (BVSort i1 False),Fix (BVSort _ True)]- -> reifyNat i1 $- \(_::Proxy n1)- -> Just $ f (SMTConcat::SMTFunction (SMTExpr (BitVector (BVTyped n1)),- SMTExpr (BitVector BVUntyped))- (BitVector BVUntyped))- [Fix (BVSort _ True),Fix (BVSort _ True)]- -> Just $ f (SMTConcat::SMTFunction (SMTExpr (BitVector BVUntyped),SMTExpr (BitVector BVUntyped)) (BitVector BVUntyped))- _ -> Nothing))--extractParser = FunctionParser g- where- g (L.List [L.Symbol "_"- ,L.Symbol "extract"- ,L.Number (L.I u)- ,L.Number (L.I l)]) _ _- = Just $ OverloadedParser (const True)- (\args' -> case args' of- [Fix (BVSort t untyped)] -> if u < t && l >= 0 && l <= u- then Just $ Fix (BVSort (u-l+1) untyped)- else error "smtlib2: Invalid parameters for extract."- _ -> error "smtlib2: Invalid parameters for extract.")- (\sort_arg sort_ret f -> case sort_arg of- [Fix (BVSort t untA)] -> case sort_ret of- Fix (BVSort r untR)- -> if r+l == u+1 && (untR == untA)- then reifyNat l $- \(_::Proxy start)- -> reifyNat (u-l+1) $- \(_::Proxy len)- -> if not untR- then reifyNat t $- \(_::Proxy tp)- -> Just $ f (SMTExtract (Proxy::Proxy start) (Proxy::Proxy len)- ::SMTFunction (SMTExpr (BitVector (BVTyped tp)))- (BitVector (BVTyped len)))- else Just $ f (SMTExtract (Proxy::Proxy start) (Proxy::Proxy len)- ::SMTFunction (SMTExpr (BitVector BVUntyped))- (BitVector (BVTyped len)))- else error "smtlib2: Invalid parameters for extract."- _ -> error "smtlib2: Wrong return type for extract."- _ -> error "smtlib2: Wrong argument type for extract.")- g _ _ _ = Nothing--sigParser = FunctionParser g- where- g (L.List [fsym,L.List sig,ret]) r dts = do- rsig <- mapM lispToSort sig- rret <- lispToSort ret- parser <- parseFun r fsym r dts- return $ DefinedParser rsig rret $- \f -> case parser of- OverloadedParser _ _ parse -> parse rsig rret f- DefinedParser _ _ parse -> parse f- g _ _ _ = Nothing--divisibleParser = FunctionParser g- where- g (L.List [L.Symbol "_",L.Symbol "divisible",L.Number (L.I n)]) _ _- = Just $ DefinedParser { definedArgSig = [Fix IntSort]- , definedRetSig = Fix BoolSort- , parseDefined = \f -> Just $ f (SMTDivisible n) }- g _ _ _ = Nothing--constructorParser :: FunctionParser-constructorParser- = FunctionParser $- \sym _ dts -> case sym of- L.Symbol name -> case Map.lookup (T.unpack name) (constructors dts) of- Nothing -> Nothing- Just (con,dt,struc) -> case argCount struc of- 0 -> let argSorts = [ runIdentity $- argumentSortToSort- (error $ "smtlib2: Internal error: Constructor "++conName con- ++" of data type "++dataTypeName dt- ++" is declared as having no arguments, but it uses them")- (fieldSort field)- | field <- conFields con ]- resSort = Fix $ NamedSort (dataTypeName dt) []- in Just $ DefinedParser { definedArgSig = argSorts- , definedRetSig = resSort- , parseDefined = \f -> withSort dts resSort- (\(uret::ret) ann_ret- -> withSorts dts argSorts- (\(_::arg) ann- -> Just $ f (SMTConstructor (Constructor (getProxyArgs uret ann_ret) dt con::Constructor arg ret))))- }- _ -> Just $ OverloadedParser { sortConstraint = \_ -> True- , deriveRetSort = infer- , parseOverloaded = parse- }- where- infer tps = let inf = foldl (\cinf (x,y) -> inferSorts x y cinf)- Map.empty (zip (fmap fieldSort (conFields con)) tps)- in argumentSortToSort (\i -> Map.lookup i inf)- (Fix $ NormalSort (NamedSort (dataTypeName dt)- [Fix $ ArgumentSort i- | i <- [0..(argCount struc)-1]]))- parse :: [Sort] -> Sort- -> (forall arg res.- (Liftable arg,SMTType res)- => SMTFunction arg res -> a) -> Maybe a- parse tps rtp app- = withSorts dts tps $- \(_::arg') _- -> withSort dts rtp $- \(_::res') _- -> Just $ app (SMTConstructor- (Constructor proxies dt con- ::Constructor arg' res'))- where- proxies = case rtp of- Fix (NamedSort _ tps) -> fmap (\tp -> withSort dts tp ProxyArg) tps- _ -> Nothing--fieldParser :: FunctionParser-fieldParser- = FunctionParser $- \sym _ dts -> case sym of- L.Symbol name -> case Map.lookup (T.unpack name) (fields dts) of- Nothing -> Nothing- Just (field,constr,dt,struc)- -> Just $ OverloadedParser { sortConstraint = \_ -> True- , deriveRetSort = infer- , parseOverloaded = parse }- where- infer [Fix (NamedSort _ tps)]- = let mp = Map.fromList (zip [0..] tps)- in argumentSortToSort (\i -> Map.lookup i mp) (fieldSort field)- parse :: [Sort] -> Sort- -> (forall arg res.- (Liftable arg,SMTType res)- => SMTFunction arg res -> a) -> Maybe a- parse [Fix (NamedSort _ tps)] rtp app- = dataTypeGetUndefined dt proxies $- \(u::t) _ -> withSort dts rtp $- \(_::f) _- -> Just $ app (SMTFieldSel- (Field proxies dt constr field- :: Field t f))- where- proxies = fmap (\tp -> withSort dts tp ProxyArg) tps- _ -> Nothing--withPipe :: MonadIO m => String -> [String] -> SMT' m a -> m a-withPipe prog args act = do- pipe <- liftIO $ createSMTPipe prog args- withSMTBackend' pipe True act--tacticToLisp :: Tactic -> L.Lisp-tacticToLisp Skip = L.Symbol "skip"-tacticToLisp (AndThen ts) = L.List ((L.Symbol "and-then"):fmap tacticToLisp ts)-tacticToLisp (OrElse ts) = L.List ((L.Symbol "or-else"):fmap tacticToLisp ts)-tacticToLisp (ParOr ts) = L.List ((L.Symbol "par-or"):fmap tacticToLisp ts)-tacticToLisp (ParThen t1 t2) = L.List [L.Symbol "par-then"- ,tacticToLisp t1- ,tacticToLisp t2]-tacticToLisp (TryFor t n) = L.List [L.Symbol "try-for"- ,tacticToLisp t- ,L.Number $ L.I n]-tacticToLisp (If c t1 t2) = L.List [L.Symbol "if"- ,probeToLisp c- ,tacticToLisp t1- ,tacticToLisp t2]-tacticToLisp (FailIf c) = L.List [L.Symbol "fail-if"- ,probeToLisp c]-tacticToLisp (UsingParams (CustomTactic name) []) = L.Symbol (T.pack name)-tacticToLisp (UsingParams (CustomTactic name) pars)- = L.List ([L.Symbol "using-params"- ,L.Symbol $ T.pack name]++- concat [ [L.Symbol (T.pack $ ':':pname)- ,case par of- ParBool True -> L.Symbol "true"- ParBool False -> L.Symbol "false"- ParInt i -> L.Number $ L.I i- ParDouble i -> L.Number $ L.D i]- | (pname,par) <- pars ])--probeToLisp :: Probe a -> L.Lisp-probeToLisp (ProbeBoolConst b)- = L.Symbol $ if b then "true" else "false"-probeToLisp (ProbeIntConst i)- = L.Number $ L.I i-probeToLisp (ProbeAnd ps)- = L.List ((L.Symbol "and"):- fmap probeToLisp ps)-probeToLisp (ProbeOr ps)- = L.List ((L.Symbol "or"):- fmap probeToLisp ps)-probeToLisp (ProbeNot p)- = L.List [L.Symbol "not"- ,probeToLisp p]-probeToLisp (ProbeEq p1 p2)- = L.List [L.Symbol "="- ,probeToLisp p1- ,probeToLisp p2]-probeToLisp (ProbeCompare cmp p1 p2)- = L.List [L.Symbol $ case cmp of- Ge -> ">="- Gt -> ">"- Le -> "<="- Lt -> "<"- ,probeToLisp p1- ,probeToLisp p2]-probeToLisp IsPB = L.Symbol "is-pb"-probeToLisp ArithMaxDeg = L.Symbol "arith-max-deg"-probeToLisp ArithAvgDeg = L.Symbol "arith-avg-deg"-probeToLisp ArithMaxBW = L.Symbol "arith-max-bw"-probeToLisp ArithAvgBW = L.Symbol "arith-avg-bw"-probeToLisp IsQFLIA = L.Symbol "is-qflia"-probeToLisp IsQFLRA = L.Symbol "is-qflra"-probeToLisp IsQFLIRA = L.Symbol "is-qflira"-probeToLisp IsILP = L.Symbol "is-ilp"-probeToLisp IsQFNIA = L.Symbol "is-qfnia"-probeToLisp IsQFNRA = L.Symbol "is-qfnra"-probeToLisp IsNIA = L.Symbol "is-nia"-probeToLisp IsNRA = L.Symbol "is-nra"-probeToLisp IsUnbounded = L.Symbol "is-unbounded"-probeToLisp Memory = L.Symbol "memory"-probeToLisp Depth = L.Symbol "depth"-probeToLisp Size = L.Symbol "size"-probeToLisp NumExprs = L.Symbol "num-exprs"-probeToLisp NumConsts = L.Symbol "num-consts"-probeToLisp NumBoolConsts = L.Symbol "num-bool-consts"-probeToLisp NumArithConsts = L.Symbol "num-arith-consts"-probeToLisp NumBVConsts = L.Symbol "num-bv-consts"-probeToLisp Strat.ProduceProofs = L.Symbol "produce-proofs"-probeToLisp ProduceModel = L.Symbol "produce-model"-probeToLisp Strat.ProduceUnsatCores = L.Symbol "produce-unsat-cores"-probeToLisp HasPatterns = L.Symbol "has-patterns"-probeToLisp IsPropositional = L.Symbol "is-propositional"-probeToLisp IsQFBV = L.Symbol "is-qfbv"-probeToLisp IsQFBVEQ = L.Symbol "is-qfbv-eq"-
− Language/SMTLib2/Solver.hs
@@ -1,23 +0,0 @@-{- | Gives interfaces to some common SMT solvers.- -}-module Language.SMTLib2.Solver where--import Language.SMTLib2-import Language.SMTLib2.Pipe-import Control.Monad.Trans (MonadIO)---- | Z3 is a solver by Microsoft <http://research.microsoft.com/en-us/um/redmond/projects/z3>.-withZ3 :: MonadIO m => SMT' m a -> m a-withZ3 = withPipe "z3" ["-smt2","-in"]---- | MathSAT <http://mathsat.fbk.eu>.-withMathSat :: MonadIO m => SMT' m a -> m a-withMathSat = withPipe "mathsat" []---- | CVC4 is an open-source SMT solver <http://cs.nyu.edu/acsys/cvc4>-withCVC4 :: MonadIO m => SMT' m a -> m a-withCVC4 = withPipe "cvc4" ["--lang smt2"]---- | SMTInterpol is an experimental interpolating SMT solver <http://ultimate.informatik.uni-freiburg.de/smtinterpol>-withSMTInterpol :: MonadIO m => SMT' m a -> m a-withSMTInterpol = withPipe "java" ["-jar","/usr/local/share/java/smtinterpol.jar","-q"]
Language/SMTLib2/Strategy.hs view
@@ -1,7 +1,5 @@ module Language.SMTLib2.Strategy where -import Language.SMTLib2.Internals.Operators- data Tactic = Skip | AndThen [Tactic]@@ -20,7 +18,10 @@ ProbeOr :: [Probe Bool] -> Probe Bool ProbeNot :: Probe Bool -> Probe Bool ProbeEq :: Show a => Probe a -> Probe a -> Probe Bool- ProbeCompare :: SMTOrdOp -> Probe Integer -> Probe Integer -> Probe Bool+ ProbeGt :: Probe Integer -> Probe Integer -> Probe Bool+ ProbeGe :: Probe Integer -> Probe Integer -> Probe Bool+ ProbeLt :: Probe Integer -> Probe Integer -> Probe Bool+ ProbeLe :: Probe Integer -> Probe Integer -> Probe Bool IsPB :: Probe Bool ArithMaxDeg :: Probe Integer ArithAvgDeg :: Probe Integer@@ -110,6 +111,22 @@ showsPrec p (ProbeNot c) = showParen (p>10) (showString "ProbeNot " . showsPrec 11 c) showsPrec p (ProbeEq p1 p2) = showParen (p>10) (showString "ProbeEq " .+ showsPrec 11 p1 .+ showChar ' ' .+ showsPrec 11 p2)+ showsPrec p (ProbeGe p1 p2) = showParen (p>10) (showString "ProbeGe " .+ showsPrec 11 p1 .+ showChar ' ' .+ showsPrec 11 p2)+ showsPrec p (ProbeGt p1 p2) = showParen (p>10) (showString "ProbeGt " .+ showsPrec 11 p1 .+ showChar ' ' .+ showsPrec 11 p2)+ showsPrec p (ProbeLe p1 p2) = showParen (p>10) (showString "ProbeLe " .+ showsPrec 11 p1 .+ showChar ' ' .+ showsPrec 11 p2)+ showsPrec p (ProbeLt p1 p2) = showParen (p>10) (showString "ProbeLt " . showsPrec 11 p1 . showChar ' ' . showsPrec 11 p2)
+ README.org view
@@ -0,0 +1,43 @@+This library provides a pure haskell interface to many SMT solvers by+implementing the [[http://www.smtlib.org/][SMTLib2 language]]. SMT solving is done by spawning a+SMT solver process and communicating with it.++* Features+ + - Communication via the SMTLIB2-format with solvers who support it+ (Currently Z3, MathSAT and CVC4).+ - Native bindings for solvers without a (proper) SMTLIB2 interface+ (Currently stp, boolector and yices).+ - Supports haskell data types (automatic instance generation+ available via template-haskell).++* Installation+ To install this package, you need [[http://www.haskell.org/haskellwiki/Cabal-Install][cabal-install]].+ The first package to install must be "smtlib2":++ #+BEGIN_SRC sh+ cabal install+ #+END_SRC++ After this, you can install the extra packages in whatever order you+ wish.++ | Package | Location |+ |-------------------+--------------------|+ | smtlib2-th | extras/th |+ | smtlib2-stp | backends/stp |+ | smtlib2-boolector | backends/boolector |+ | smtlib2-yices | backends/yices |++* Supported solvers+ For the moment, only [[http://research.microsoft.com/en-us/um/redmond/projects/z3/][Z3]] supports every feature implemented in this+ interface. [[http://mathsat4.disi.unitn.it/][MathSAT]] implements most features, except for data types.++| Solver | Version | SMTLib2 format | Bitvectors | Integer | Enumerations | Datatypes |+|-----------+---------+----------------+------------+---------+--------------+-----------|+| Z3 | 4.3 | yes | yes | yes | yes | yes |+| MathSAT | 5.2.10 | yes | yes | yes | no | no |+| STP | | incomplete | yes | no | no | no |+| Yices | 2.1.0 | no | yes | yes | yes | no |+| Boolector | 1.6.0 | incomplete | yes | no | no | no |+| CVC4 | 1.4 | yes | yes | yes | no | yes |
smtlib2.cabal view
@@ -1,5 +1,5 @@ Name: smtlib2-Version: 0.3.1+Version: 1.0 Author: Henning Günther <guenther@forsyte.at> Maintainer: guenther@forsyte.at Synopsis: A type-safe interface to communicate with an SMT solver.@@ -9,44 +9,51 @@ License-File: LICENSE Build-Type: Simple Cabal-Version: >=1.6+Extra-Source-Files:+ README.org Source-Repository head Type: git Location: https://github.com/hguenther/smtlib2.git -Flag WithConstraints- Description: Enables the use of the constraint-kind extension which is needed to parse 'map'-expressions.- Default: True-Flag WithDataKinds- Description: Enables the use of the data-kinds extension which is needed for typed bitvectors.- Default: False- Library- Build-Depends: base >= 4 && < 5,text,mtl,process,blaze-builder,bytestring,- attoparsec,atto-lisp >= 0.2 && < 0.3,array,- containers, transformers, data-fix, tagged- Extensions: GADTs,RankNTypes,CPP,ScopedTypeVariables,- MultiParamTypeClasses,FlexibleContexts,OverloadedStrings,- DeriveFunctor,FlexibleInstances,DeriveTraversable,DeriveFoldable,- DeriveDataTypeable- GHC-Options: -fcontext-stack=100- if flag(WithConstraints)- Build-Depends: constraints- CPP-Options: -DSMTLIB2_WITH_CONSTRAINTS- if flag(WithDataKinds)- Extensions: DataKinds,PolyKinds- CPP-Options: -DSMTLIB2_WITH_DATAKINDS- - GHC-Options: -fwarn-unused-imports+ Build-Depends: base >= 4 && < 5, constraints, mtl, containers, template-haskell, dependent-sum, dependent-map+ Extensions:+ GADTs+ FlexibleContexts+ FlexibleInstances+ ExistentialQuantification+ KindSignatures+ DataKinds+ TypeFamilies+ TypeOperators+ MultiParamTypeClasses+ ScopedTypeVariables+ RankNTypes+ UndecidableInstances+ GeneralizedNewtypeDeriving+ DeriveDataTypeable+ CPP+ PolyKinds+ StandaloneDeriving+ EmptyDataDecls+ PatternSynonyms+ ViewPatterns+ TemplateHaskell+ QuasiQuotes+ GHC-Options: -fwarn-unused-imports -fprint-explicit-kinds Exposed-Modules:- Language.SMTLib2- Language.SMTLib2.Solver- Language.SMTLib2.Connection- Language.SMTLib2.Internals- Language.SMTLib2.Internals.Instances- Language.SMTLib2.Internals.Interface- Language.SMTLib2.Internals.Optimize- Language.SMTLib2.Internals.Operators- Language.SMTLib2.Pipe- Language.SMTLib2.Strategy- Data.Unit+ Language.SMTLib2.Internals.Backend+ Language.SMTLib2.Internals.Embed+ Language.SMTLib2.Internals.Expression+ Language.SMTLib2.Internals.Monad+ Language.SMTLib2.Internals.Type+ Language.SMTLib2.Internals.Type.Nat+ Language.SMTLib2.Internals.Type.List+ Language.SMTLib2.Internals.Type.Struct+ Language.SMTLib2.Strategy+ Language.SMTLib2+ Language.SMTLib2.Internals.Evaluate+ Language.SMTLib2.Internals.Interface+ Language.SMTLib2.Internals.Proof+ Language.SMTLib2.Internals.Proof.Verify