{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, GADTs, KindSignatures, TypeFamilies, DeriveDataTypeable #-}moduleLanguage.HERMIT.Shell.Command(-- * The HERMIT Command-line ShellcommandLine)whereimportqualifiedGhcPluginsasGHCimportControl.ApplicativeimportControl.Arrowhiding(loop)importControl.ConcurrentimportControl.Concurrent.STMimportControl.Exception.Basehiding(catch)importControl.Monad.StateimportControl.Monad.ErrorimportData.CharimportData.MonoidimportData.List(intercalate,isPrefixOf,nub)importData.Default(def)importData.DynamicimportqualifiedData.MapasMimportData.MaybeimportLanguage.HERMIT.DictionaryimportLanguage.HERMIT.ExprimportLanguage.HERMIT.ExternalimportLanguage.HERMIT.InterpimportLanguage.HERMIT.Kernel.ScopedimportLanguage.HERMIT.KureimportLanguage.HERMIT.MonadimportLanguage.HERMIT.PrettyPrinterimportLanguage.HERMIT.Primitive.NavigationimportLanguage.HERMIT.Primitive.Inline-- import Language.HERMIT.Primitive.GHCimportSystem.Console.ANSIimportSystem.IOimportqualifiedText.PrettyPrint.MarkedHughesPJasPPimportSystem.Console.Haskelinehiding(catch)-- There are 3 types of commands, AST effect-ful, Shell effect-ful, and Queries.dataShellCommand::*whereAstEffect::AstEffect->ShellCommandShellEffect::ShellEffect->ShellCommandQueryFun::QueryFun->ShellCommandMetaCommand::MetaCommand->ShellCommand-- | AstEffects are things that are recorded in our log and saved files.dataAstEffect-- | This applys a rewrite (giving a whole new lower-level AST)=Apply(RewriteHCore)-- | This changes the current location using a computed path|Pathfinder(TranslateHCorePath)-- | This changes the currect location using directions|DirectionDirection-- | This changes the current location using a give path|PushFocusPath|BeginScope|EndScope|TagString-- ^ Adding a tag-- | A precondition or other predicate that must not fail|CorrectnessCritera(TranslateHCore())derivingTypeableinstanceExternAstEffectwheretypeBoxAstEffect=AstEffectboxi=iunboxi=idataShellEffect::*whereSessionStateEffect::(CommandLineState->SessionState->IOSessionState)->ShellEffectderivingTypeabledataQueryFun::*whereQueryT::TranslateHCoreString->QueryFun-- These two be can generalized into-- (CommandLineState -> IO String)Display::QueryFunMessage::String->QueryFunInquiry::(CommandLineState->SessionState->IOString)->QueryFunderivingTypeableinstanceExternQueryFunwheretypeBoxQueryFun=QueryFunboxi=iunboxi=idataMetaCommand=Resume|Abort|DumpStringStringStringInt|LoadFileString-- load a file on top of the current node|SaveFileStringderivingTypeableinstanceExternMetaCommandwheretypeBoxMetaCommand=MetaCommandboxi=iunboxi=i-- TODO: Use another word, Navigation is a more general concept-- Perhaps VersionNavigationdataNavigation=Back-- back (up) the derivation tree|Step-- down one step; assumes only one choice|GotoInt-- goto a specific node, if possible|GotoTagString-- goto a specific named tagderivingShowdataShellCommandBox=ShellCommandBoxShellCommandderivingTypeableinstanceExternShellEffectwheretypeBoxShellEffect=ShellEffectboxi=iunboxi=iinstanceExternShellCommandwheretypeBoxShellCommand=ShellCommandBoxbox=ShellCommandBoxunbox(ShellCommandBoxi)=iinterpShellCommand::[InterpShellCommand]interpShellCommand=[interp$\(ShellCommandBoxcmd)->cmd,interp$\(IntBoxi)->AstEffect(PushFocus[i]),interp$\(RewriteCoreBoxrr)->AstEffect(Applyrr),interp$\(TranslateCorePathBoxtt)->AstEffect(Pathfindertt),interp$\(StringBoxstr)->QueryFun(Messagestr),interp$\(TranslateCoreStringBoxtt)->QueryFun(QueryTtt),interp$\(TranslateCoreCheckBoxtt)->AstEffect(CorrectnessCriteratt),interp$\(effect::AstEffect)->AstEffecteffect,interp$\(effect::ShellEffect)->ShellEffecteffect,interp$\(query::QueryFun)->QueryFunquery,interp$\(meta::MetaCommand)->MetaCommandmeta]-- TODO: move this into the shell, it is completely specific to the way-- the shell works. What about list, for example?--interpKernelCommand :: [Interp KernelCommand]--interpKernelCommand =-- [ Interp $ \ (KernelCommandBox cmd) -> cmd-- ]shell_externals::[External]shell_externals=map(.+Shell)[external"resume"Resume-- HERMIT Kernel Exit["stops HERMIT; resumes compile"],external"abort"Abort-- UNIX Exit["hard UNIX-style exit; does not return to GHC; does not save"],external"display"Display["redisplays current state"],external"left"(DirectionL)["move to the next child"],external"right"(DirectionR)["move to the previous child"],external"up"(DirectionU)["move to the parent"],external"down"(DirectionD)["move to the first child"],external"tag"Tag["tag <label> names the current AST with a label"],external"navigate"(SessionStateEffect$\_st->return$st{cl_nav=True})["switch to navigate mode"],external"command-line"(SessionStateEffect$\_st->return$st{cl_nav=False})["switch to command line mode"],external"top"(DirectionT)["move to root of tree"],external"back"(SessionStateEffect$navigationBack)["go back in the derivation"].+VersionControl,external"log"(InquiryshowDerivationTree)["go back in the derivation"].+VersionControl,external"step"(SessionStateEffect$navigationStep)["step forward in the derivation"].+VersionControl,external"goto"(SessionStateEffect.navigation.Goto)["goto a specific step in the derivation"].+VersionControl,external"goto"(SessionStateEffect.navigation.GotoTag)["goto a named step in the derivation"],external"setpp"(\pp->SessionStateEffect$\_st->caseM.lookuppppp_dictionaryofNothing->doputStrLn$"List of Pretty Printers: "++intercalate", "(M.keyspp_dictionary)returnstJust_->return$st{cl_pretty=pp})["set the pretty printer","use 'setpp ls' to list available pretty printers"],external"set-renderer"changeRenderer["set the output renderer mode"],external"set-renderer"showRenderers["set the output renderer mode"],external"dump"Dump["dump <filename> <pretty-printer> <renderer> <width>"],external"set-width"(\n->SessionStateEffect$\_st->return$st{cl_width=n})["set the width of the screen"],external"set-pp-expr-type"(\str->SessionStateEffect$\_st->casereadsstr::[(ShowOption,String)]of[(opt,"")]->return$st{cl_pretty_opts=(cl_pretty_optsst){po_exprTypes=opt}}_->returnst)["set how to show expression-level types (Show|Abstact|Omit)"],external"{"BeginScope["push current lens onto a stack"]-- tag as internal,external"}"EndScope["pop a lens off a stack"]-- tag as internal,external"load"LoadFile["load <filename> : load a file of commands into the current derivation"],external"save"SaveFile["save <filename> : save the current complete derivation into a file"]]showRenderers::QueryFunshowRenderers=Message$"set-renderer "++show(mapfstfinalRenders)changeRenderer::String->ShellEffectchangeRendererrenderer=SessionStateEffect$\_st->caselookuprendererfinalRendersofNothing->returnst-- should fail with messageJustr->return$st{cl_render=r}----------------------------------------------------------------------------------catch::IOa->(String->IOa)->IOacatch=catchJust(\(err::IOException)->return(showerr))pretty::SessionState->PrettyHCoreprettyss=caseM.lookup(cl_prettyss)pp_dictionaryofJustpp->pp(cl_pretty_optsss)Nothing->pure(PP.text$"<<no pretty printer for "++cl_prettyss++">>")showFocus::MonadIOm=>CLMm()showFocus=dost<-get-- No not show focus while loadingifM(gets(cl_loading.cl_session))(return())(iokm2clm'"Rendering error: "(liftIO.cl_render(cl_sessionst)stdout(cl_pretty_opts$cl_sessionst))(queryS(cl_kernelst)(cl_cursor$cl_sessionst)(pretty$cl_sessionst)(cl_kernel_env$cl_sessionst)))-------------------------------------------------------------------------------typeCLMma=ErrorTString(StateTCommandLineStatem)a-- TODO: Come up with names for these, and/or better characterise these abstractions.iokm2clm'::MonadIOm=>String->(a->CLMmb)->IO(KureMonada)->CLMmbiokm2clm'msgretm=liftIOm>>=runKureMonadret(throwError.(msg++))iokm2clm::MonadIOm=>String->IO(KureMonada)->CLMmaiokm2clmmsg=iokm2clm'msgreturndataCommandLineState=CommandLineState{cl_graph::[(SAST,ExprH,SAST)],cl_tags::[(String,SAST)]-- these two should be in a reader,cl_dict::M.MapString[Dynamic],cl_kernel::ScopedKernel-- and the session state (perhaps in a seperate state?),cl_session::SessionState}newSAST::ExprH->SAST->CommandLineState->CommandLineStatenewSASTexprsastst=st{cl_session=(cl_sessionst){cl_cursor=sast},cl_graph=(cl_cursor(cl_sessionst),expr,sast):cl_graphst}-- Session-local issues; things that are never saved.dataSessionState=SessionState{cl_cursor::SAST-- ^ the current AST,cl_pretty::String-- ^ which pretty printer to use,cl_pretty_opts::PrettyOptions-- ^ The options for the pretty printer,cl_render::Handle->PrettyOptions->DocH->IO()-- ^ the way of outputing to the screen,cl_width::Int-- ^ how wide is the screen?,cl_nav::Bool-- ^ keyboard input the the nav panel,cl_loading::Bool-- ^ if loading a file,cl_tick::TVar(M.MapStringInt)-- ^ The list of ticked messages}-------------------------------------------------------------------------------dataCompletionType=ConsiderC-- complete with possible arguments to consider|InlineC-- complete with names that can be inlined|CommandC-- complete using dictionary commands (default)|AmbiguousC[CompletionType]-- completionType function needs to be more specificderiving(Show)-- todo: reverse rPrev and parse it, to better figure out what possiblities are in context?-- for instance, completing "any-bu (inline " should be different than completing just "inline "-- this would also allow typed completion?completionType::String->CompletionTypecompletionType=go.dropWhileisSpacewheregorPrev=case[ty|(nm,ty)<-opts,reversenm`isPrefixOf`rPrev]of[]->CommandC[t]->tts->AmbiguousCtsopts=[("inline",InlineC),("consider",ConsiderC),("rhs-of",ConsiderC)]completionQuery::CommandLineState->CompletionType->IO(TranslateHCore[String])completionQuery_ConsiderC=return$considerTargets>>^((++mapfstconsiderables).map('\'':))completionQuery_InlineC=return$inlineTargets>>^map('\'':)completionQuerysCommandC=return$pure(M.keys(cl_dicts))-- Need to modify opts in completionType function. No key can be a suffix of another key.completionQuery_(AmbiguousCts)=doputStrLn"\nCannot tab complete: ambiguous completion type."putStrLn$"Possibilities: "++intercalate", "(mapshowts)return(pure[])shellComplete::MVarCommandLineState->String->String->IO[Completion]shellCompletemvarrPrevso_far=dost<-readMVarmvartargetQuery<-completionQueryst(completionTyperPrev)-- (liftM.liftM) (map simpleCompletion . nub . filter (so_far `isPrefixOf`))-- $ queryS (cl_kernel st) (cl_cursor (cl_session st)) targetQuery-- TODO: I expect you want to build a silent version of the kernal_env for this querymcls<-queryS(cl_kernelst)(cl_cursor(cl_sessionst))targetQuery(cl_kernel_env(cl_sessionst))cl<-runKureMonadreturnfailmcls-- TO DO: probably shouldn't use fail here.return$(mapsimpleCompletion.nub.filter(so_far`isPrefixOf`))cl-- | The first argument is a list of files to load.commandLine::[String]->Behavior->GHC.ModGuts->GHC.CoreMGHC.ModGutscommandLinefilesToLoadbehaviormodGuts=doletdict=dictionary$all_externalsshell_externalsletws_complete=" ()"letstartup=domodify$\st->st{cl_session=(cl_sessionst){cl_loading=True}}sequence_[performMetaCommand$casefileNameof"abort"->Abort"resume"->Resume_->LoadFilefileName|fileName<-reversefilesToLoad,not(nullfileName)]`ourCatch`\msg->liftIO.putStrLn$"Booting Failure: "++msgmodify$\st->st{cl_session=(cl_sessionst){cl_loading=False}}var<-GHC.liftIO$atomically$newTVarM.emptyflipscopedKernelmodGuts$\skernelsast->doletsessionState=SessionStatesast"clean"defunicodeConsole80FalseFalsevarshellState=CommandLineState[][]dictskernelsessionStatecompletionMVar<-newMVarshellState_<-runInputTBehaviorbehavior(setComplete(completeWordWithPrevNothingws_complete(shellCompletecompletionMVar))defaultSettings)(evalStateT(runErrorT(startup>>showFocus>>loopcompletionMVar))shellState)return()loop::(MonadIOm,m~InputTIO)=>MVarCommandLineState->CLMm()loopcompletionMVar=loop'whereloop'=dost<-get-- so the completion can get the current stateliftIO$modifyMVar_completionMVar(const$returnst)-- liftIO $ print (cl_pretty st, cl_cursor (cl_session st))letSASTn=cl_cursor(cl_sessionst)maybeLine<-ifcl_nav(cl_sessionst)thenliftIOgetNavCmdelselift$lift$getInputLine$"hermit<"++shown++"> "casemaybeLineofNothing->performMetaCommandResumeJust('-':'-':_msg)->loop'Justline->ifallisSpacelinethenloop'else(caseparseStmtsHlineofLeftmsg->throwError("Parse failure: "++msg)Rightstmts->evalStmtsstmts)`ourCatch`(liftIO.putStrLn)>>loop'ourCatch::(MonadIOn)=>CLMIO()->(String->CLMn())->CLMn()ourCatchmfailure=dost<-get(res,st')<-liftIO$runStateT(runErrorTm)stputst'caseresofLeftmsg->failuremsgRight()->return()evalStmts::(MonadIOm)=>[StmtHExprH]->CLMm()evalStmts=mapM_evalExpr.scopeswherescopes::[StmtHExprH]->[ExprH]scopes[]=[]scopes(ExprHe:ss)=e:scopesssscopes(ScopeHs:ss)=(CmdName"{":scopess)++[CmdName"}"]++scopesssevalExpr::(MonadIOm)=>ExprH->CLMm()evalExprexpr=dodict<-getscl_dictcaseinterpExprHdictinterpShellCommandexprofLeftmsg->throwErrormsgRightcmd->casecmdofAstEffecteffect->performAstEffecteffectexprShellEffecteffect->performShellEffecteffectQueryFunquery->performQueryqueryMetaCommandmeta->performMetaCommandmeta--------------------------------------------------------------------------------- TODO: This can be refactored. We always showFocus. Also, Perhaps return a modifier, not ()-- UPDATE: Not true. We don't always showFocus.-- TODO: All of these should through an exception if they fail to execute the command as given.performAstEffect::MonadIOm=>AstEffect->ExprH->CLMm()performAstEffect(Applyrr)expr=dost<-getiokm2clm'"Rewrite failed: "(\ast'->put(newSASTexprast'st)>>showFocus)(applyS(cl_kernelst)(cl_cursor$cl_sessionst)rr(cl_kernel_env$cl_sessionst))performAstEffect(Pathfindert)expr=dost<-get-- An extension to the Pathiokm2clm'"Cannot find path: "(\p->doast<-iokm2clm"Path is invalid: "$modPathS(cl_kernelst)(cl_cursor(cl_sessionst))(extendLocalPathp)(cl_kernel_env$cl_sessionst)put$newSASTexpraststshowFocus)(queryS(cl_kernelst)(cl_cursor$cl_sessionst)t(cl_kernel_env$cl_sessionst))performAstEffect(Directiondir)expr=dost<-get-- This seems unnecassary. But if you restore it, note that it needs editing so that it doesn't print if we're loading a file.-- child_count <- iokm2clm "Could not compute number of children:" $ queryS (cl_kernel st) (cl_cursor (cl_session st)) numChildrenT (cl_kernel_env (cl_session st))-- liftIO $ print (child_count, dir)ast<-iokm2clm"Invalid move: "$modPathS(cl_kernelst)(cl_cursor$cl_sessionst)(moveLocallydir)(cl_kernel_env$cl_sessionst)put$newSASTexprastst-- something changed, to printshowFocusperformAstEffect(PushFocusp)expr=dost<-getast<-iokm2clm"Invalid push: "$modPathS(cl_kernelst)(cl_cursor$cl_sessionst)(extendLocalPathp)(cl_kernel_env$cl_sessionst)put$newSASTexpraststshowFocusperformAstEffectBeginScopeexpr=dost<-getast<-liftIO$beginScopeS(cl_kernelst)(cl_cursor(cl_sessionst))put$newSASTexpraststshowFocusperformAstEffectEndScopeexpr=dost<-getast<-liftIO$endScopeS(cl_kernelst)(cl_cursor(cl_sessionst))put$newSASTexpraststshowFocusperformAstEffect(Tagtag)_=dost<-getput(st{cl_tags=(tag,cl_cursor$cl_sessionst):cl_tagsst})performAstEffect(CorrectnessCriteraq)expr=dost<-get-- TODO: Again, we may want a quiet version of the kernel_envliftIO(queryS(cl_kernelst)(cl_cursor$cl_sessionst)q(cl_kernel_env$cl_sessionst))>>=runKureMonad(\()->putStrToConsole$unparseExprHexpr++" [correct]")(\err->fail$unparseExprHexpr++" [exception: "++err++"]")-- correctness <- liftIO (try $ queryS (cl_kernel st) (cl_cursor (cl_session st)) q)-- case correctness of-- Right () -> do putStrToConsole $ unparseExprH expr ++ " [correct]"-- Left (err :: IOException)-- -> fail $ unparseExprH expr ++ " [exception: " ++ show err ++ "]"-------------------------------------------------------------------------------performShellEffect::MonadIOm=>ShellEffect->CLMm()performShellEffect(SessionStateEffectf)=dost<-getopt<-liftIO(fmapRight(fst$cl_sessionst)`catch`\str->return(Leftstr))caseoptofRights_st'->doput(st{cl_session=s_st'})showFocusLefterr->throwErrorerr-------------------------------------------------------------------------------performQuery::MonadIOm=>QueryFun->CLMm()performQuery(QueryTq)=dost<-getiokm2clm'"Query failed: "putStrToConsole(queryS(cl_kernelst)(cl_cursor$cl_sessionst)q(cl_kernel_env$cl_sessionst))performQuery(Inquiryf)=dost<-getstr<-liftIO$fst(cl_sessionst)putStrToConsolestr-- These two need to use InquiryperformQuery(Messagemsg)=liftIO(putStrLnmsg)performQueryDisplay=showFocus-- do-- st <- get-- liftIO $ do-- ps <- pathS (cl_kernel st) (cl_cursor (cl_session st))-- putStrLn $ "Paths: " ++ show ps-- print ("Graph",cl_graph st)-- print ("This",cl_cursor (cl_session st))-------------------------------------------------------------------------------performMetaCommand::MonadIOm=>MetaCommand->CLMm()performMetaCommandAbort=getscl_kernel>>=(liftIO.abortS)performMetaCommandResume=dost<-getliftIO$resumeS(cl_kernelst)(cl_cursor$cl_sessionst)performMetaCommand(DumpfileName_pprendererwidth)=dost<-getcase(M.lookup(cl_pretty(cl_sessionst))pp_dictionary,lookuprendererfinalRenders)of(Justpp,Justr)->dodoc<-iokm2clm"Bad pretty-printer or renderer option: "$queryS(cl_kernelst)(cl_cursor$cl_sessionst)(pp(cl_pretty_opts$cl_sessionst))(cl_kernel_env$cl_sessionst)liftIO$doh<-openFilefileNameWriteModerh((cl_pretty_opts$cl_sessionst){po_width=width})dochCloseh_->throwError"dump: bad pretty-printer or renderer option"performMetaCommand(LoadFilefileName)=doputStrToConsole$"[loading "++fileName++"]"res<-liftIO$try(readFilefileName)caseresofRightstr->caseparseStmtsH(normalizestr)ofLeftmsg->throwError("Parse failure: "++msg)Rightstmts->doload_st<-gets(cl_loading.cl_session)modify$\st->st{cl_session=(cl_sessionst){cl_loading=True}}evalStmtsstmts`catchError`(\err->domodify$\st->st{cl_session=(cl_sessionst){cl_loading=load_st}}throwErrorerr)modify$\st->st{cl_session=(cl_sessionst){cl_loading=load_st}}putStrToConsole$"[done, loaded "++show(numStmtsHstmts)++" commands]"-- TODO: This is better than saying "N", but not very robust.showFocusLeft(err::IOException)->throwError("IO error: "++showerr)wherenormalize=unlines.map(++";")-- HACK!.maprmComment.linesrmComment[]=[]rmCommentxs|"--"`isPrefixOf`xs=[]-- we need a real parser and lexer here!rmComment(x:xs)=x:rmCommentxsperformMetaCommand(SaveFilefileName)=dost<-getputStrToConsole$"[saving "++fileName++"]"-- no checks to see if you are clobering; be carefulliftIO$writeFilefileName$showGraph(cl_graphst)(cl_tagsst)(SAST0)-------------------------------------------------------------------------------putStrToConsole::MonadIOm=>String->CLMm()putStrToConsolestr=ifM(gets(cl_loading.cl_session))(return())(liftIO$putStrLnstr)-------------------------------------------------------------------------------newtypeUnicodeTerminal=UnicodeTerminal(Handle->MaybePath->IO())instanceRenderSpecialUnicodeTerminalwhererenderSpecialsym=UnicodeTerminal$\h_->hPutStrh[ch]where(Unicodech)=renderSpecialsyminstanceMonoidUnicodeTerminalwheremempty=UnicodeTerminal$\__->return()mappend(UnicodeTerminalf1)(UnicodeTerminalf2)=UnicodeTerminal$\hp->f1hp>>f2hpfinalRenders::[(String,Handle->PrettyOptions->DocH->IO())]finalRenders=[("unicode-terminal",unicodeConsole)]++coreRendersunicodeConsole::Handle->PrettyOptions->DocH->IO()unicodeConsolehwdoc=dolet(UnicodeTerminalprty)=renderCodewdocprtyhNothinginstanceRenderCodeUnicodeTerminalwhererPutStrtxt=UnicodeTerminal$\h_->hPutStrhtxtrDoHighlight_[]=UnicodeTerminal$\h_->hSetSGRh[Reset]rDoHighlight_(Colorcol:_)=UnicodeTerminal$\h_->dohSetSGRh[Reset]hSetSGRh$casecolofKeywordColor->[SetConsoleIntensityBoldIntensity,SetColorForegroundDullBlue]SyntaxColor->[SetColorForegroundDullRed]VarColor->[]-- as isTypeColor->[SetColorForegroundDullGreen]LitColor->[SetColorForegroundDullCyan]rDoHighlighto(_:rest)=rDoHighlightorestrEnd=UnicodeTerminal$\h_->hPutStrLnh""--------------------------------------------------------navigation::Navigation->CommandLineState->SessionState->IOSessionStatenavigationwhereTostsess_st=casewhereToofGoton->doall_nds<-listS(cl_kernelst)ifSASTn`elem`all_ndsthenreturn$sess_st{cl_cursor=SASTn}elsefail$"Can not find AST #"++shownGotoTagtag->caselookuptag(cl_tagsst)ofJustsast->return$sess_st{cl_cursor=sast}Nothing->fail$"Can not find tag "++showtagStep->doletns=[edge|edge@(s,_,_)<-cl_graphst,s==cl_cursor(cl_sessionst)]casensof[]->fail"Cannot step forward (no more steps)"[(_,cmd,d)]->doputStrLn$"step : "++unparseExprHcmdreturn$sess_st{cl_cursor=d}_->fail"Cannot step forward (multiple choices)"Back->doletns=[edge|edge@(_,_,d)<-cl_graphst,d==cl_cursor(cl_sessionst)]casensof[]->fail"Cannot step backwards (no more steps)"[(s,cmd,_)]->doputStrLn$"back, unstepping : "++unparseExprHcmdreturn$sess_st{cl_cursor=s}_->fail"Cannot step backwards (multiple choices, impossible!)"--------------------------------------------------------getNavCmd::IO(MaybeString)getNavCmd=dob_in<-hGetBufferingstdinhSetBufferingstdinNoBufferingb_out<-hGetBufferingstdinhSetBufferingstdoutNoBufferingec_in<-hGetEchostdinhSetEchostdinFalseputStr"(navigation mode; use arrow keys, escape to quit, '?' for help)"r<-readCh[]putStr"\n"hSetBufferingstdinb_inhSetBufferingstdoutb_outhSetEchostdinec_inreturnrwherereadChxs=dox<-getCharletstr=xs++[x](fromMaybereset$lookupstrcmds)strreset_=doputStr"\BEL"readCh[]resstr_=return(Juststr)cmds=[("\ESC",\str->ifM(hReadystdin)(readChstr)(return$Just"command-line")),("\ESC[",readCh),("\ESC[A",res"up"),("\ESC[B",res"down"),("\ESC[C",res"right"),("\ESC[D",res"left"),("?",res"nav-commands"),("f",res"step")]++[(shown,res(shown))|n<-[0..9]::[Int]]showDerivationTree::CommandLineState->SessionState->IOStringshowDerivationTreestss=return$unlines$showRefactorTrailgraphtags0mewheregraph=[(a,[unparseExprHb],c)|(SASTa,b,SASTc)<-cl_graphst]tags=[(n,nm)|(nm,SASTn)<-cl_tagsst]SASTme=cl_cursorssshowRefactorTrail::(Eqa,Showa)=>[(a,[String],a)]->[(a,String)]->a->a->[String]showRefactorTraildbtagsame=case[(b,c)|(a0,b,c)<-db,a==a0]of[]->[show'3a++" "++dot++tags_txt]((b,c):bs)->[show'3a++" "++dot++(ifnot(nullbs)then"->"else"")++tags_txt]++[" "++"| "++txt|txt<-b]++showRefactorTraildbtagscme++ifnullbsthen[]else[]:showRefactorTrail[(a',b',c')|(a',b',c')<-db,not(a==a'&&c==c')]tagsamewheredot=ifa==methen"*"else"o"show'nx=replicate(n-length(showa))' '++showxtags_txt=concat[' ':txt|(n,txt)<-tags,n==a]showGraph::[(SAST,ExprH,SAST)]->[(String,SAST)]->SAST->StringshowGraphgraphtagsthis@(SASTn)=(iflengthpaths>1then"tag "++shown++"\n"else"")++concat(intercalate["goto "++shown++"\n"][[unparseExprHb++"\n"++showGraphgraphtagsc]|(b,c)<-paths])wherepaths=[(b,c)|(a,b,c)<-graph,a==this]----------------------------------------------------------------------------------------------cl_kernel_env::SessionState->HermitMEnvcl_kernel_envss=mkHermitMEnv$\msg->casemsgofDebugTickmsg'->doc<-GHC.liftIO$tick(cl_tickss)msg'GHC.liftIO$putStrLn$"<"++showc++"> "++msg'DebugCoremsg'cxtcore->doGHC.liftIO$putStrLn$"["++msg'++"]"doc::DocH<-apply(prettyss)cxtcoreGHC.liftIO$cl_renderssstdout(cl_pretty_optsss)doc-- tick countertick::TVar(M.MapStringInt)->String->IOInttickvarmsg=atomically$dom<-readTVarvarletc=caseM.lookupmsgmofNothing->1Justx->x+1writeTVarvar(M.insertmsgcm)returnc