>{-# OPTIONS_GHC -fglasgow-exts #-}>-- |>-- Module : Ivor.Shell>-- Copyright : Edwin Brady>-- Licence : BSD-style (see LICENSE in the distribution)>-->-- Maintainer : eb@dcs.st-and.ac.uk>-- Stability : experimental>-- Portability : non-portable>-->-- Shell interface to theorem prover>moduleIvor.Shell(ShellState,>runShell,importFile,addModulePath,addStdlibPath,>prefix,getContext,newShell,updateShell,>sendCommand,sendCommandIO,addTactic,addCommand,>extendParser,configureEq,>shellParseTerm,showProofState,response)where>importIvor.ShellState>importIvor.ShellParser>importIvor.TermParser>importIvor.TTasTT>importIvor.Construction>importIvor.Equality>importIvor.Gadgets>importIvor.Primitives>importqualifiedIvor.Prefix>importIvor.Plugin>importSystem.Exit>importSystem.Environment>importSystem.Directory>importSystem.IO>importData.Char>importDebug.Trace>importText.ParserCombinators.Parsec>respond,respondLn::ShellState->String->ShellState>respondststr=st{response=(responsest)++str}>respondLnststr=st{response=(responsest)++str++"\n"}>clearResponsest=st{response=""}>-- | Create a new shell state.>newShell::Context-- ^ Initial system state>->ShellState>newShellctxt=ShellNothing"> "Falsectxt""[][][]Nothing[]>-- | Update the context in a shell>updateShell::Monadm=>>(Context->mContext)-- ^ Function to update context>->ShellState->mShellState>updateShellfctxt(Shellrpfcresptacscomsimpextpath)>=doctxt<-fctxtc>return(Shellrpfctxtresptacscomsimpextpath)>-- | Add a user defined tactic to the shell.>addTactic::String-- ^ Tactic name.>->(String->Tactic)-- ^ Tactic function. The argument is whatever was input on the shell; the function is responsible for parsing this.>->ShellState-- ^ Shell to which to add the tactic.>->ShellState>addTacticnmtacst=st{usertactics=(nm,tac):(usertacticsst)}>-- | Add a user defined command to the shell.>addCommand::String-- ^ Command name.>->(String->Context->IO(String,Context))-- ^ Command function. The argument is whatever was input on the shell; the function is responsible for parsing this. The command returns a string (the response) and a possibly updated context.>->ShellState-- ^ Shell to which to add the command.>->ShellState>addCommandnmcomst=st{usercommands=(nm,com):(usercommandsst)}>-- | Add another parsing rule for parsing terms.>extendParser::ShellState->ParserViewTerm->ShellState>extendParserstext=case(extensionsst)of>Nothing->st{extensions=Justext}>Justp->st{extensions=Just(p<|>ext)}>-- | Parse a term using the shell's current parser extensions>shellParseTerm::ShellState->ParserViewTerm>shellParseTermst=pTerm(extensionsst)>-- | Get the system state from a finished shell>getContext::ShellState->Context>getContext=context>readToSemi::IOString>readToSemi=>doc<-getChar>if(c==';')>thenreturn";">elsedos<-readToSemi>return(c:s)outputst=hPutStr(outputstreamst)outputLnstx=outputst(x++"\n")>runCommand::(Monadm)=>Command->ShellState->mShellState>runCommand(Defnmtm)st=dolet(_,tm')=addImplicit(contextst)tm>ctxt<-addDef(contextst)(namenm)tm'>returnst{context=ctxt}>runCommand(TypedDefnmtmty)st=do>ctxt<-addTypedDef(contextst)(namenm)tmty>returnst{context=ctxt}>runCommand(PatternDefnmtypatsopts)st=do>(ctxt,new)<-addPatternDef(contextst)(namenm)typats(Holey:opts)>letst'=respondLnst$("Need to define: "++shownew)>returnst'{context=ctxt}>runCommand(Datadat)st=doctxt<-addData(contextst)dat>returnst{context=ctxt}>runCommand(Axiomnmtm)st=doctxt<-addAxiom(contextst)(namenm)tm>returnst{context=ctxt}>runCommand(Declarenmtm)st=doctxt<-declare(contextst)(namenm)tm>returnst{context=ctxt}>runCommand(DeclareDatanmtm)st>=doctxt<-declareData(contextst)(namenm)tm>returnst{context=ctxt}>runCommand(Theoremnmty)st=doctxt<-theorem(save(contextst))>(namenm)ty>letst'=respondst$>showProofStatest{context=ctxt}>returnst'{context=ctxt}>runCommand(Interactivenmty)st=do>ctxt<-interactive(save(contextst))>(namenm)ty>letst'=respondst$>showProofStatest{context=ctxt}>returnst'{context=ctxt}>runCommand(Forgetn)st=do>ctxt<-forgetDef(contextst)(namen)>return$(respondLnst("Forgotten back to "++n))>{context=ctxt}>runCommand(EvalTermexp)st>|proving(contextst)=do>tm<-evalCtxt(contextst)defaultGoalexp>return(respondLnst(showtm))>|otherwise=do>tm<-check(contextst)exp>return(respondLnst(show(eval(contextst)tm)))>runCommand(WHNFexp)st>{- | proving (context st) = do
> tm <- newevalCtxt (context st) defaultGoal exp
> return (respondLn st (show tm))
> | otherwise -}>=do>tm<-check(contextst)exp>return(respondLnst(show(whnf(contextst)tm)))>runCommand(Printn)st=do>case(getDef(contextst)(namen))of>Justtm->return(respondLnst(show(viewtm)))>_->case(getPatternDef(contextst)(namen))of>Just(_,pats)->return(respondLnst(printPatspats))>_->dotm<-check(contextst)n>caseviewtmof>(NameTypeCon_)->return(respondLnst"Type constructor")>(NameElimOp_)->return(respondLnst"Elimination operator")>(NameFree_)->return(respondLnst"Undefined function")>(NameDataCon_)->return(respondLnst"Data constructor")>_->fail"Unknown definition">whereprintPats(Patternscs)=unlines(mapprintClausecs)>printClause(PClauseargsret)=n++" "++>unwords(mapargshowargs)++>" = "++showret>argshowx|' '`elem`showx="("++showx++")">|otherwise=showx>runCommand(Checkexp)st=do>tm<-check(contextst)exp>return(respondLnst(show(viewTypetm)))>runCommand(Freezen)st=doctxt<-freeze(contextst)(namen)>returnst{context=ctxt}>runCommand(Thawn)st=doctxt<-thaw(contextst)(namen)>returnst{context=ctxt}>runCommand(Focusn)st=doctxt<-focus(goaln)(contextst)>returnst{context=ctxt}>runCommand(Dumpn)st=do>letds=getAllTypes(contextst)>return(respondLnst(dumpAllnds))>runCommand(ReplDataeqreplsym)st>=returnst{repldata=Just(eq,repl,sym)}>runCommandPrfst=do>tm<-proofterm(contextst)>return(respondLnst(showtm))>runCommandPrfStatest=doletst'=respondst$showProofStatest>returnst'>runCommandQedst=doctxt<-qed(contextst)>returnst{context=(clearSavedctxt)}>runCommandSuspendst=doletst'=respondLnst"Suspending Proof">returnst'{context=suspend(contextst)}>runCommand(Resumen)st=doctxt<-resume(contextst)(namen)>letst'=respondLnst$"Resuming proof of "++n>ctxt<-if(numUnsolvedctxt)==1>thenattackdefaultGoalctxt>elsereturnctxt>letst''=respondst'$>showProofStatest'{context=ctxt}>returnst''{context=ctxt}>runCommandUndost=doctxt<-restore(contextst)>letst'=respondLnst$>showProofStatest{context=ctxt}>returnst'{context=ctxt}>runCommand(Ivor.ShellParser.GenRecn)st>=doctxt<-addGenRec(contextst)(namen)>letst'=respondLnst$"Added general recursion rule">returnst'{context=ctxt}>runCommand(JMEqnc)st=doctxt<-addEquality(contextst)(namen)>(namec)>letst'=respondLnst$"Added dependent equality">returnst'{context=ctxt}>runCommandPrimitivesst=doletst'=extendParserstparsePrimitives>ctxt<-addPrimitives(contextst')>returnst'{context=ctxt}>runCommandDropst=returnst{finished=True}>runCommand(Loadf)st=fail"Can only load in a shell -- use importFile instead">runCommand(Pluginf)st=fail"Can only load plugin in a shell -- use Plugin.load instead">runCommand(Compilef)st=fail"Can only Compile in a shell -- use 'compile' function instead">runCommand(UserCommand__)st=fail"Can only run user commands in a shell">runTactic__Attack=attack>runTactic__(AttackWithn)=attackWith(namen)>runTactic__(Claimntm)=claim(namen)tm>runTactic__(Localntm)=\gctxt->do>ctxt<-claim(namen)tmgctxt>focus(goaln)ctxt>runTactic__(Refinetmargs)=refineWithtmargs>runTactic__Solve=solve>runTactic__(Filltm)=filltm>runTactic__ReturnTac=returnComputation>runTactic__QuoteTac=quoteVal>runTactic__(CallTactm)=calltm>runTactic__Abandon=abandon>runTactic__(Renamen)=rename(namen)>runTactic__Intro=intro>runTactic__(IntroNamen)=introName(namen)>runTactic__Intros=intros>runTactic__(IntrosNamesns)=introsNames(mapnamens)>runTactic__(Equivtm)=equivtm>runTactic__(AddArgnmtm)=addArg(namenm)tm>runTactic__(GeneraliseFalsetm)=generalisetm>runTactic__(GeneraliseTruetm)=dependentGeneralisetm>runTactic_(Just(eq,repl,sym))(Replacetmf)>=replaceeqreplsymtmf>runTactic_Nothing(Replace__)=fail"replace not configured">runTactic__(Axiomatisenns)=axiomatise(namen)(mapnamens)>runTactic__Normalise=compute>runTactic__(Unfoldn)=unfold(namen)>runTactic__Trivial=trivial>runTactic__Split=split>runTactic__LeftCon=left>runTactic__RightCon=right>runTactic__AutoSolve=auto20>runTactic__(Existstm)=existstm>runTactic__(Bytm)=bytm>runTactic__(Inductiontm)=inductiontm>runTactic__(Casestm)=casestm>runTactic__(Decideme)=isItJustme>runTactictacs_(UserTactictactm)=\gctxt->do>caselookuptactacsof>(Justt)->ttmgctxt>Nothing->fail$"User tactic "++tac++" undefined">dumpAll::String->[(Name,Term)]->String>dumpAllpat[]="">dumpAllpat((n,ty):xs)>|sublistpat(lengthpat)(shown)=>shown++" : "++show(viewty)++"\n"++dumpAllpatxs>|otherwise=dumpAllpatxs>wheresublistpatixs|i>lengthxs=False>|takeixs==pat=True>sublistpati(x:xs)=sublistpatixsDealwithcommandsthatdoIOhere,sowecanhaveaseparateprocessingfunctionwhichdoesn'tneedtobeintheIOMonad.>process::ResultInput->ShellState->IOShellState>process(Failureerr)st=return$respondLnsterr>process(Success(Command(Loadf)))st=doimportFilefst>process(Success(Command(Pluginf)))st=do>(ctxt,exts,shell,cmds)<-loadf(contextst)>letst'=st{context=ctxt}>letst''=caseextsof>Nothing->st'>Justp->extendParserst'p>st'''<-casecmdsof>Nothing->returnst''>Justc->donewcmds<-c>return$st''{usercommands=usercommandsst''++newcmds}>caseshellof>Nothing->returnst'''>Justshfn->shfnst'''>process(Success(Command(Compilef)))st=docompile(contextst)f>putStrLn$"Output "++f++".hs">returnst>process(Success(Command(UserCommandcarg)))st=do>letJustfn=lookupc(usercommandsst)-- can't fail if parser succeeds>(resp,ctxt)<-fnarg(contextst)>letst'=st{context=ctxt,response=resp}>returnst'>processxst=processInputxst>processInput::Monadm=>ResultInput->ShellState->mShellState>processInput(Failureerr)st=return$respondLnsterr>processInput(Success(Commandcmd))st=runCommandcmdst>processInput(Success(Tacticgoaltac))st>=doletctxt=save(contextst)>ctxt<-runTactic(usertacticsst)(repldatast)>tacgoalctxt>ctxt<-keepSolvingdefaultGoalctxt>ctxt<-if((numUnsolvedctxt)>0)>thenbetadefaultGoalctxt>elsereturnctxt>letst'=respondst$showProofState$st{context=ctxt}>returnst'{context=ctxt}>-- | Get a string representation of the current proof state>showProofState::ShellState->String>showProofStatest>|not(provingctxt)="">|null$getGoalsctxt="\nNo more goals\n\n">|otherwise=let(g:gs)=getGoalsctxtin>"\n"++showGoalStateg++>"\nOther goals: "++showgs++"\n\n">where>ctxt=contextst>showGoalState::Goal->String>showGoalStateg=let(Justgd)=goalDatactxtTrueg>env=bindingsgd>ty=goalTypegd>nm=goalNamegdin>showEnv(reverseenv)++"\n"++>"--------------------------------\n"++>shownm++" ? "++show(viewty)++"\n">showEnv[]="">showEnv((n,ty):xs)=shown++" : "++show(viewty)++"\n"++>showEnvxs>loop::ShellState->IOShellState>loopst=doputStr(promptst)>hFlushstdout>inp<-readToSemi>st'<-catch(process(parseInput(extensionsst)>(gettacs(usertacticsst))>(mapfst(usercommandsst))inp)st)>(\e->doreturn$respondLnst(showe))>putStr$(responsest')>if(finishedst')>thenreturn(clearResponsest')>elsecatch(loop(clearResponsest'))>(\e->returnst')>-- | Set up the equality type, for use by the 'replace' tactic>configureEq::String>->String>->String>->ShellState->ShellState>configureEqeqreplsymshell=shell{repldata=Just(eq,repl,sym)}>-- | Run a command shell.>runShell::String-- ^ Prompt string>->ShellState-- ^ Initial state>->IOShellState>runShellpshell=>dost<-loopshell{prompt=p}>returnst>-- | Send a command directly to a shell>sendCommand::Monadm=>String->ShellState->mShellState>sendCommandstrst=processInput>(parseInput(extensionsst)>(gettacs(usertacticsst))>(mapfst(usercommandsst))str)$>clearResponsestSpecialcaseforimportFile.Grr.>-- | Send a command directly to a shell, allowing commands which might>-- do IO actions.>sendCommandIO::String->ShellState->IOShellState>sendCommandIOstrst=process>(parseInput(extensionsst)>(gettacs(usertacticsst))>(mapfst(usercommandsst))str)$>clearResponsest>gettacs::[(String,String->Goal->Context->IOContext)]->[String]>gettacs=mapfst>-- | Get the install prefix of the library>prefix::FilePath>prefix=Ivor.Prefix.prefixIfthegivenfileisalreadyloaded,donothing.>-- | Import a file of shell commands; fails if the module does not exist>-- in the current directory or search path, does nothing if already loaded.>importFile::FilePath->ShellState->IOShellState>importFilefpst>|fp`elem`importedst=returnst>|otherwise=doinp<-findFile(modulePathst)fp>st'<-processFile[]inpst>--resp <- readFile tmpf>return$st'{imported=fp:(importedst')}>whereprocessFileacc(';':rest)st=>do--putStrLn ("processing"++acc)>st'<-sendCommandIO(acc++";")st>processFile[]restst'>processFileacc(x:xs)st=processFile(acc++[x])xsst>processFile[][]st=returnst>-- Now eat the whitespace at the end>processFile(x:xs)[]st|isSpacex=processFilexs[]st>|otherwise=fail"Unexpected end of file">-- | Add a directory to the module search path>addModulePath::ShellState->FilePath->ShellState>addModulePathshellfp=shell{modulePath=fp:(modulePathshell)}>-- | Add the standard library path to the module search path>addStdlibPath::ShellState->ShellState>addStdlibPathshell>=shell{modulePath=(prefix++"/lib/ivor"):(modulePathshell)}>environment::String->IO(MaybeString)>environmentx=catch(doe<-getEnvx>return(Juste))>(\_->returnNothing)>tempfile::IO(FilePath,Handle)>tempfile=doenv<-environment"TMPDIR">letdir=caseenvof>Nothing->"/tmp">(Justd)->d>openTempFiledir"humett.out"