------------------------------------------------------------------------------- |-- Module : Data.SBV.SMT.SMT-- Copyright : (c) Levent Erkok-- License : BSD3-- Maintainer : erkokl@gmail.com-- Stability : experimental-- Portability : portable---- Abstraction of SMT solvers-----------------------------------------------------------------------------{-# LANGUAGE ScopedTypeVariables #-}moduleData.SBV.SMT.SMTwhereimportqualifiedControl.ExceptionasCimportControl.Concurrent(newEmptyMVar,takeMVar,putMVar,forkIO)importControl.DeepSeq(NFData(..))importControl.Monad(when,zipWithM)importData.Char(isSpace)importData.Int(Int8,Int16,Int32,Int64)importData.List(intercalate,isPrefixOf,isInfixOf)importData.Maybe(isNothing,fromJust)importData.Word(Word8,Word16,Word32,Word64)importSystem.Directory(findExecutable)importSystem.Process(readProcessWithExitCode,runInteractiveProcess,waitForProcess)importSystem.Exit(ExitCode(..))importSystem.IO(hClose,hFlush,hPutStr,hGetContents,hGetLine)importData.SBV.BitVectors.DataimportData.SBV.BitVectors.PrettyNumimportData.SBV.Utils.TDiff-- | Solver configurationdataSMTConfig=SMTConfig{verbose::Bool-- ^ Debug mode,timing::Bool-- ^ Print timing information on how long different phases took (construction, solving, etc.),timeOut::MaybeInt-- ^ How much time to give to the solver. (In seconds),printBase::Int-- ^ Print literals in this base,solver::SMTSolver-- ^ The actual SMT solver,solverTweaks::[String]-- ^ Additional lines of script to give to the solver (user specified),smtFile::MaybeFilePath-- ^ If Just, the generated SMT script will be put in this file (for debugging purposes mostly),useSMTLib2::Bool-- ^ If True, we'll treat the solver as using SMTLib2 input format. Otherwise, SMTLib1}typeSMTEngine=SMTConfig->Bool->[(Quantifier,NamedSymVar)]->[(String,UnintKind)]->[EitherSW(SW,[SW])]->String->IOSMTResult-- | An SMT solverdataSMTSolver=SMTSolver{name::String-- ^ Printable name of the solver,executable::String-- ^ The path to its executable,options::[String]-- ^ Options to provide to the solver,engine::SMTEngine-- ^ The solver engine, responsible for interpreting solver output}-- | A model, as returned by a solverdataSMTModel=SMTModel{modelAssocs::[(String,CW)],modelArrays::[(String,[String])]-- very crude!,modelUninterps::[(String,[String])]-- very crude!}derivingShow-- | The result of an SMT solver call. Each constructor is tagged with-- the 'SMTConfig' that created it so that further tools can inspect it-- and build layers of results, if needed. For ordinary uses of the library,-- this type should not be needed, instead use the accessor functions on-- it. (Custom Show instances and model extractors.)dataSMTResult=UnsatisfiableSMTConfig-- ^ Unsatisfiable|SatisfiableSMTConfigSMTModel-- ^ Satisfiable with model|UnknownSMTConfigSMTModel-- ^ Prover returned unknown, with a potential (possibly bogus) model|ProofErrorSMTConfig[String]-- ^ Prover errored out|TimeOutSMTConfig-- ^ Computation timed out (see the 'timeout' combinator)-- | A script, to be passed to the solver.dataSMTScript=SMTScript{scriptBody::String-- ^ Initial feed,scriptModel::MaybeString-- ^ Optional continuation script, if the result is sat}resultConfig::SMTResult->SMTConfigresultConfig(Unsatisfiablec)=cresultConfig(Satisfiablec_)=cresultConfig(Unknownc_)=cresultConfig(ProofErrorc_)=cresultConfig(TimeOutc)=cinstanceNFDataSMTResultwherernf(Unsatisfiable_)=()rnf(Satisfiable_xs)=rnfxs`seq`()rnf(Unknown_xs)=rnfxs`seq`()rnf(ProofError_xs)=rnfxs`seq`()rnf(TimeOut_)=()instanceNFDataSMTModelwherernf(SMTModelassocsunintsuarrs)=rnfassocs`seq`rnfunints`seq`rnfuarrs`seq`()-- | A 'prove' call results in a 'ThmResult'newtypeThmResult=ThmResultSMTResult-- | A 'sat' call results in a 'SatResult'-- The reason for having a separate 'SatResult' is to have a more meaningful 'Show' instance.newtypeSatResult=SatResultSMTResult-- | An 'allSat' call results in a 'AllSatResult'. The boolean says whether-- we should warn the user about prefix-existentials.newtypeAllSatResult=AllSatResult(Bool,[SMTResult])instanceShowThmResultwhereshow(ThmResultr)=showSMTResult"Q.E.D.""Unknown""Unknown. Potential counter-example:\n""Falsifiable""Falsifiable. Counter-example:\n"rinstanceShowSatResultwhereshow(SatResultr)=showSMTResult"Unsatisfiable""Unknown""Unknown. Potential model:\n""Satisfiable""Satisfiable. Model:\n"r-- NB. The Show instance of AllSatResults have to be careful in being lazy enough-- as the typical use case is to pull results out as they become available.instanceShowAllSatResultwhereshow(AllSatResult(e,xs))=go(0::Int)xswhereuniqueWarn|e=" (Unique up to prefix existentials.)"|True=""goc(s:ss)=letc'=c+1(ok,o)=shc'sinc'`seq`ifoktheno++"\n"++goc'sselseogoc[]=casecof0->"No solutions found."1->"This is the only solution."++uniqueWarn_->"Found "++showc++" different solutions."++uniqueWarnshic=(ok,showSMTResult"Unsatisfiable"("Unknown #"++showi++"(No assignment to variables returned)")"Unknown. Potential assignment:\n"("Solution #"++showi++" (No assignment to variables returned)")("Solution #"++showi++":\n")c)whereok=casecofSatisfiable{}->True_->False-- | Instances of 'SatModel' can be automatically extracted from models returned by the-- solvers. The idea is that the sbv infrastructure provides a stream of 'CW''s (constant-words)-- coming from the solver, and the type @a@ is interpreted based on these constants. Many typical-- instances are already provided, so new instances can be declared with relative ease.---- Minimum complete definition: 'parseCWs'classSatModelawhere-- | Given a sequence of constant-words, extract one instance of the type @a@, returning-- the remaining elements untouched. If the next element is not what's expected for this-- type you should return 'Nothing'parseCWs::[CW]->Maybe(a,[CW])-- | Given a parsed model instance, transform it using @f@, and return the result.-- The default definition for this method should be sufficient in most use cases.cvtModel::(a->Maybeb)->Maybe(a,[CW])->Maybe(b,[CW])cvtModelfx=x>>=\(a,r)->fa>>=\b->return(b,r)genParse::Integrala=>(Bool,Size)->[CW]->Maybe(a,[CW])genParse(signed,size)(x:r)|hasSignx==signed&&sizeOfx==size=Just(fromIntegral(cwValx),r)genParse__=Nothing-- base case, that comes in handy if there are no real variablesinstanceSatModel()whereparseCWsxs=return((),xs)instanceSatModelBoolwhereparseCWsxs=do(x,r)<-genParse(False,Size(Just1))xsreturn((x::Integer)/=0,r)instanceSatModelWord8whereparseCWs=genParse(False,Size(Just8))instanceSatModelInt8whereparseCWs=genParse(True,Size(Just8))instanceSatModelWord16whereparseCWs=genParse(False,Size(Just16))instanceSatModelInt16whereparseCWs=genParse(True,Size(Just16))instanceSatModelWord32whereparseCWs=genParse(False,Size(Just32))instanceSatModelInt32whereparseCWs=genParse(True,Size(Just32))instanceSatModelWord64whereparseCWs=genParse(False,Size(Just64))instanceSatModelInt64whereparseCWs=genParse(True,Size(Just64))instanceSatModelIntegerwhereparseCWs=genParse(True,SizeNothing)-- when reading a list; go as long as we can (maximal-munch)-- note that this never fails..instanceSatModela=>SatModel[a]whereparseCWs[]=Just([],[])parseCWsxs=caseparseCWsxsofJust(a,ys)->caseparseCWsysofJust(as,zs)->Just(a:as,zs)Nothing->Just([],ys)Nothing->Just([],xs)instance(SatModela,SatModelb)=>SatModel(a,b)whereparseCWsas=do(a,bs)<-parseCWsas(b,cs)<-parseCWsbsreturn((a,b),cs)instance(SatModela,SatModelb,SatModelc)=>SatModel(a,b,c)whereparseCWsas=do(a,bs)<-parseCWsas((b,c),ds)<-parseCWsbsreturn((a,b,c),ds)instance(SatModela,SatModelb,SatModelc,SatModeld)=>SatModel(a,b,c,d)whereparseCWsas=do(a,bs)<-parseCWsas((b,c,d),es)<-parseCWsbsreturn((a,b,c,d),es)instance(SatModela,SatModelb,SatModelc,SatModeld,SatModele)=>SatModel(a,b,c,d,e)whereparseCWsas=do(a,bs)<-parseCWsas((b,c,d,e),fs)<-parseCWsbsreturn((a,b,c,d,e),fs)instance(SatModela,SatModelb,SatModelc,SatModeld,SatModele,SatModelf)=>SatModel(a,b,c,d,e,f)whereparseCWsas=do(a,bs)<-parseCWsas((b,c,d,e,f),gs)<-parseCWsbsreturn((a,b,c,d,e,f),gs)instance(SatModela,SatModelb,SatModelc,SatModeld,SatModele,SatModelf,SatModelg)=>SatModel(a,b,c,d,e,f,g)whereparseCWsas=do(a,bs)<-parseCWsas((b,c,d,e,f,g),hs)<-parseCWsbsreturn((a,b,c,d,e,f,g),hs)-- | Various SMT results that we can extract models out of.classModelableawhere-- | Is there a model?modelExists::a->Bool-- | Extract a model, the result is a tuple where the first argument (if True)-- indicates whether the model was "probable". (i.e., if the solver returned unknown.)getModel::SatModelb=>a->EitherString(Bool,b)-- | A simpler variant of 'getModel' to get a model out without the fuss.extractModel::SatModelb=>a->MaybebextractModela=casegetModelaofRight(_,b)->Justb_->Nothing-- | Return all the models from an 'allSat' call, similar to 'extractModel' but-- is suitable for the case of multiple results.extractModels::SatModela=>AllSatResult->[a]extractModels(AllSatResult(_,xs))=[ms|Right(_,ms)<-mapgetModelxs]instanceModelableThmResultwheregetModel(ThmResultr)=getModelrmodelExists(ThmResultr)=modelExistsrinstanceModelableSatResultwheregetModel(SatResultr)=getModelrmodelExists(SatResultr)=modelExistsrinstanceModelableSMTResultwheregetModel(Unsatisfiable_)=Left"SBV.getModel: Unsatisfiable result"getModel(Unknown_m)=Right(True,parseModelOutm)getModel(ProofError_s)=error$unlines$"Backend solver complains: ":sgetModel(TimeOut_)=Left"Timeout"getModel(Satisfiable_m)=Right(False,parseModelOutm)modelExists(Satisfiable{})=TruemodelExists(Unknown{})=False-- don't risk itmodelExists_=FalseparseModelOut::SatModela=>SMTModel->aparseModelOutm=caseparseCWs[c|(_,c)<-modelAssocsm]ofJust(x,[])->xJust(_,ys)->error$"SBV.getModel: Partially constructed model; remaining elements: "++showysNothing->error$"SBV.getModel: Cannot construct a model from: "++showm-- | Given an 'allSat' call, we typically want to iterate over it and print the results in sequence. The-- 'displayModels' function automates this task by calling 'disp' on each result, consecutively. The first-- 'Int' argument to 'disp' 'is the current model number. The second argument is a tuple, where the first-- element indicates whether the model is alleged (i.e., if the solver is not sure, returing Unknown)displayModels::SatModela=>(Int->(Bool,a)->IO())->AllSatResult->IOIntdisplayModelsdisp(AllSatResult(_,ms))=doinds<-zipWithMdisplay[a|Righta<-map(getModel.SatResult)ms][(1::Int)..]return$last(0:inds)wheredisplayri=dispir>>returnishowSMTResult::String->String->String->String->String->SMTResult->StringshowSMTResultunsatMsgunkMsgunkMsgModelsatMsgsatMsgModelresult=caseresultofUnsatisfiable_->unsatMsgSatisfiable_(SMTModel[][][])->satMsgSatisfiable_m->satMsgModel++showModelcfgmUnknown_(SMTModel[][][])->unkMsgUnknown_m->unkMsgModel++showModelcfgmProofError_[]->"*** An error occurred. No additional information available. Try running in verbose mode"ProofError_ls->"*** An error occurred.\n"++intercalate"\n"(map("*** "++)ls)TimeOut_->"*** Timeout"wherecfg=resultConfigresultshowModel::SMTConfig->SMTModel->StringshowModelcfgm=intercalate"\n"(map(shMcfg)assocs++concatMapshUIuninterps++concatMapshUAarrs)whereassocs=modelAssocsmuninterps=modelUninterpsmarrs=modelArraysmshCW::SMTConfig->CW->StringshCW=sh.printBasewheresh2=binSsh10=showsh16=hexSshn=\w->showw++" -- Ignoring unsupported printBase "++shown++", use 2, 10, or 16."shM::SMTConfig->(String,CW)->StringshMcfg(s,v)=" "++s++" = "++shCWcfgv-- very crude.. printing uninterpreted functionsshUI::(String,[String])->[String]shUI(flong,cases)=(" -- uninterpreted: "++f):mapshCcaseswheretf=dropWhile(/='_')flongf=ifnulltfthenflongelsetailtfshCs=" "++s-- very crude.. printing array valuesshUA::(String,[String])->[String]shUA(f,cases)=(" -- array: "++f):mapshCcaseswhereshCs=" "++spipeProcess::Bool->String->String->[String]->SMTScript->(String->String)->IO(EitherString[String])pipeProcessverbnmexecNameoptsscriptcleanErrs=dombExecPath<-findExecutableexecNamecasembExecPathofNothing->return$Left$"Unable to locate executable for "++nm++"\nExecutable specified: "++showexecNameJustexecPath->do(ec,contents,allErrors)<-runSolververbexecPathoptsscriptleterrors=dropWhileisSpace(cleanErrsallErrors)caseecofExitSuccess->ifnullerrorsthenreturn$Right$mapclean(filter(not.null)(linescontents))elsereturn$LefterrorsExitFailuren->leterrors'=ifnullerrorsthen(ifnull(dropWhileisSpacecontents)then"(No error message printed on stderr by the executable.)"elsecontents)elseerrorsinreturn$Left$"Failed to complete the call to "++nm++"\nExecutable : "++showexecPath++"\nOptions : "++unwordsopts++"\nExit code : "++shown++"\nSolver output: "++"\n"++line++"\n"++intercalate"\n"(filter(not.null)(lineserrors'))++"\n"++line++"\nGiving up.."whereclean=reverse.dropWhileisSpace.reverse.dropWhileisSpaceline=replicate78'='standardSolver::SMTConfig->SMTScript->(String->String)->([String]->a)->([String]->a)->IOastandardSolverconfigscriptcleanErrsfailuresuccess=doletmsg=when(verboseconfig).putStrLn.("** "++)smtSolver=solverconfigexec=executablesmtSolveropts=optionssmtSolverisTiming=timingconfignmSolver=namesmtSolvermsg$"Calling: "++show(unwords(exec:opts))casesmtFileconfigofNothing->return()Justf->doputStrLn$"** Saving the generated script in file: "++showfwriteFilef(scriptBodyscript)contents<-timeIfisTimingnmSolver$pipeProcess(verboseconfig)nmSolverexecoptsscriptcleanErrsmsg$nmSolver++" output:\n"++eitherid(intercalate"\n")contentscasecontentsofLefte->return$failure(linese)Rightxs->return$successxs-- A variant of readProcessWithExitCode; except it knows about continuation strings-- and can speak SMT-Lib2 (just a little)runSolver::Bool->FilePath->[String]->SMTScript->IO(ExitCode,String,String)runSolververbexecPathoptsscript|isNothing$scriptModelscript=readProcessWithExitCodeexecPathopts(scriptBodyscript)|True=do(send,ask,cleanUp)<-do(inh,outh,errh,pid)<-runInteractiveProcessexecPathoptsNothingNothingletsendl=hPutStrinh(l++"\n")>>hFlushinhrecv=hGetLineouthaskl=sendl>>recvcleanUpr=dooutMVar<-newEmptyMVarout<-hGetContentsouth_<-forkIO$C.evaluate(lengthout)>>putMVaroutMVar()err<-hGetContentserrh_<-forkIO$C.evaluate(lengtherr)>>putMVaroutMVar()hCloseinhtakeMVaroutMVartakeMVaroutMVarhCloseouthhCloseerrhex<-waitForProcesspid-- if the status is unknown, prepare for the possibility of not having a model-- TBD: This is rather crude and potentially Z3 specificif"unknown"`isPrefixOf`r&&"error"`isInfixOf`(out++err)thenreturn(ExitSuccess,r,"")elsereturn(ex,r++"\n"++out,err)return(send,ask,cleanUp)mapM_send(lines(scriptBodyscript))r<-ask"(check-sat)"when(any(`isPrefixOf`r)["sat","unknown"])$doletmls=lines(fromJust(scriptModelscript))whenverb$doputStrLn"** Sending the following model extraction commands:"mapM_putStrLnmlsmapM_sendmlscleanUpr