diff --git a/Data/Unit.hs b/Data/Unit.hs deleted file mode 100644 --- a/Data/Unit.hs +++ /dev/null @@ -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) diff --git a/Language/SMTLib2.hs b/Language/SMTLib2.hs --- a/Language/SMTLib2.hs +++ b/Language/SMTLib2.hs @@ -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 diff --git a/Language/SMTLib2/Connection.hs b/Language/SMTLib2/Connection.hs deleted file mode 100644 --- a/Language/SMTLib2/Connection.hs +++ /dev/null @@ -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)) diff --git a/Language/SMTLib2/Internals.hs b/Language/SMTLib2/Internals.hs deleted file mode 100644 --- a/Language/SMTLib2/Internals.hs +++ /dev/null @@ -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) diff --git a/Language/SMTLib2/Internals/Backend.hs b/Language/SMTLib2/Internals/Backend.hs new file mode 100644 --- /dev/null +++ b/Language/SMTLib2/Internals/Backend.hs @@ -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 diff --git a/Language/SMTLib2/Internals/Embed.hs b/Language/SMTLib2/Internals/Embed.hs new file mode 100644 --- /dev/null +++ b/Language/SMTLib2/Internals/Embed.hs @@ -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 diff --git a/Language/SMTLib2/Internals/Evaluate.hs b/Language/SMTLib2/Internals/Evaluate.hs new file mode 100644 --- /dev/null +++ b/Language/SMTLib2/Internals/Evaluate.hs @@ -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 diff --git a/Language/SMTLib2/Internals/Expression.hs b/Language/SMTLib2/Internals/Expression.hs new file mode 100644 --- /dev/null +++ b/Language/SMTLib2/Internals/Expression.hs @@ -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) diff --git a/Language/SMTLib2/Internals/Instances.hs b/Language/SMTLib2/Internals/Instances.hs deleted file mode 100644 --- a/Language/SMTLib2/Internals/Instances.hs +++ /dev/null @@ -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 diff --git a/Language/SMTLib2/Internals/Interface.hs b/Language/SMTLib2/Internals/Interface.hs --- a/Language/SMTLib2/Internals/Interface.hs +++ b/Language/SMTLib2/Internals/Interface.hs @@ -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) diff --git a/Language/SMTLib2/Internals/Monad.hs b/Language/SMTLib2/Internals/Monad.hs new file mode 100644 --- /dev/null +++ b/Language/SMTLib2/Internals/Monad.hs @@ -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) diff --git a/Language/SMTLib2/Internals/Operators.hs b/Language/SMTLib2/Internals/Operators.hs deleted file mode 100644 --- a/Language/SMTLib2/Internals/Operators.hs +++ /dev/null @@ -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) diff --git a/Language/SMTLib2/Internals/Optimize.hs b/Language/SMTLib2/Internals/Optimize.hs deleted file mode 100644 --- a/Language/SMTLib2/Internals/Optimize.hs +++ /dev/null @@ -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 diff --git a/Language/SMTLib2/Internals/Proof.hs b/Language/SMTLib2/Internals/Proof.hs new file mode 100644 --- /dev/null +++ b/Language/SMTLib2/Internals/Proof.hs @@ -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 ')' diff --git a/Language/SMTLib2/Internals/Proof/Verify.hs b/Language/SMTLib2/Internals/Proof/Verify.hs new file mode 100644 --- /dev/null +++ b/Language/SMTLib2/Internals/Proof/Verify.hs @@ -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 + diff --git a/Language/SMTLib2/Internals/Type.hs b/Language/SMTLib2/Internals/Type.hs new file mode 100644 --- /dev/null +++ b/Language/SMTLib2/Internals/Type.hs @@ -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 diff --git a/Language/SMTLib2/Internals/Type/List.hs b/Language/SMTLib2/Internals/Type/List.hs new file mode 100644 --- /dev/null +++ b/Language/SMTLib2/Internals/Type/List.hs @@ -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 diff --git a/Language/SMTLib2/Internals/Type/Nat.hs b/Language/SMTLib2/Internals/Type/Nat.hs new file mode 100644 --- /dev/null +++ b/Language/SMTLib2/Internals/Type/Nat.hs @@ -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 diff --git a/Language/SMTLib2/Internals/Type/Struct.hs b/Language/SMTLib2/Internals/Type/Struct.hs new file mode 100644 --- /dev/null +++ b/Language/SMTLib2/Internals/Type/Struct.hs @@ -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 diff --git a/Language/SMTLib2/Pipe.hs b/Language/SMTLib2/Pipe.hs deleted file mode 100644 --- a/Language/SMTLib2/Pipe.hs +++ /dev/null @@ -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" - diff --git a/Language/SMTLib2/Solver.hs b/Language/SMTLib2/Solver.hs deleted file mode 100644 --- a/Language/SMTLib2/Solver.hs +++ /dev/null @@ -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 . -withZ3 :: MonadIO m => SMT' m a -> m a -withZ3 = withPipe "z3" ["-smt2","-in"] - --- | MathSAT . -withMathSat :: MonadIO m => SMT' m a -> m a -withMathSat = withPipe "mathsat" [] - --- | CVC4 is an open-source SMT solver -withCVC4 :: MonadIO m => SMT' m a -> m a -withCVC4 = withPipe "cvc4" ["--lang smt2"] - --- | SMTInterpol is an experimental interpolating SMT solver -withSMTInterpol :: MonadIO m => SMT' m a -> m a -withSMTInterpol = withPipe "java" ["-jar","/usr/local/share/java/smtinterpol.jar","-q"] diff --git a/Language/SMTLib2/Strategy.hs b/Language/SMTLib2/Strategy.hs --- a/Language/SMTLib2/Strategy.hs +++ b/Language/SMTLib2/Strategy.hs @@ -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) diff --git a/README.org b/README.org new file mode 100644 --- /dev/null +++ b/README.org @@ -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 | diff --git a/smtlib2.cabal b/smtlib2.cabal --- a/smtlib2.cabal +++ b/smtlib2.cabal @@ -1,5 +1,5 @@ Name: smtlib2 -Version: 0.3.1 +Version: 1.0 Author: Henning Günther 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