moduleLanguage.Egison.CorewhereimportLanguage.Egison.NumericalimportLanguage.Egison.ParserimportLanguage.Egison.PrimitivesimportLanguage.Egison.TypesimportLanguage.Egison.VariablesimportControl.Monad.ErrorimportData.ArrayimportqualifiedData.MapimportqualifiedSystem.ExitimportSystem.Directory(doesFileExist,removeFile)importSystem.IOimportData.IORefimportData.VersionimportPaths_egisonegisonVersion::StringegisonVersion=showVersionversion-- |A utility function to display the egison console bannershowBanner::IO()showBanner=doputStrLn$"Egison Version "++egisonVersion++" (c) 2011-2012 Satoshi Egi"putStrLn$"http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/"putStrLn$"Welcome to Egison Interpreter!"-- |A utility function to display the egison console byebye messageshowByebyeMessage::IO()showByebyeMessage=doputStrLn$"Leaving Egison."putStrLn$"Byebye. See you again! (^^)/"-- |Load standard libraries into the given environmentloadLibraries::Env->IO()loadLibrariesenv=do-- Load standard library_<-evalStringenv$"(load \"lib/core/base.egi\")"_<-evalStringenv$"(load \"lib/core/number.egi\")"_<-evalStringenv$"(load \"lib/core/collection.egi\")"return()-- |A utility function to escape backslashes in the given stringescapeBackslashes::String->StringescapeBackslashess=foldrstep[]swherestepxxs|x=='\\'='\\':'\\':xs|otherwise=x:xsevalString::Env->String->IOStringevalStringenvstr=runIOThrowsREPL$(liftThrows$readTopExprstr)>>=evalTopExprenvevalMain::Env->[String]->IOThrowsErrorEgisonValevalMainenvargs=doletmainExpr=VarExpr"main"[]main<-cEval1$ClosureenvmainExprmainRef<-liftIO$newIORefmainletargvExpr=CollectionExpr$map(ElementExpr.StringExpr)argsargv<-cEval1$ClosureenvargvExprargvRef<-liftIO$newIORefargvworldRef<-liftIO$newIORef$Value$World[]argsRef<-liftIO$newIORef$Intermidiate$ITuple$[IElementworldRef,IElementargvRef]ret<-cApply1mainRefargsRefcEvalret-- |Evaluate egison top expression that has already been loaded into haskellevalTopExpr::Env->TopExpr->IOThrowsErrorStringevalTopExprenv(Testexpr)=liftMshow$evalenvexprevalTopExprenv(Definenameexpr)=doclr<-liftIO$makeClosureenvexprdefineVarenv(name,[])clrreturnnameevalTopExprenv(Executeargs)=doevalMainenvargsreturn""evalTopExprenv(LoadFilefilename)=doresult<-liftIO$doesFileExistfilenameifresultthendo(liftIO$readFilefilename)>>=loadenvreturn$filename++" loaded."elsethrowError$Default$"File does not exist: "++filenameevalTopExprenv(Loadlibname)=dofilename<-liftIO(getDataFileNamelibname)result<-liftIO$doesFileExistfilenameifresultthendo(liftIO$readFilefilename)>>=loadenvreturn$filename++" loaded."elsethrowError$Default$"Library does not exist: "++libnameload::Env->String->IOThrowsError()loadenvstr=doexprs<-liftThrows$readTopExprListstrmapM(evalTopExprenv)exprsreturn()-- |Evaluate egison expression that has already been loaded into haskelleval::Env->EgisonExpr->IOThrowsErrorEgisonValevalenvexpr=doobj<-cEval1(Closureenvexpr)caseobjofValueval->returnvalIntermidiateiVal->iEvaliVal_->throwError$Default$"eval: cannot reach here!: "++showobjiEval::IntermidiateVal->IOThrowsErrorEgisonValiEval(IInductiveDataconsargRefs)=doargs<-mapMcRefEvalargRefsreturn$InductiveDataconsargsiEval(ICollectioninnerValRefs)=doinnerVals<-mapMinnerValRefEvalinnerValRefsreturn$CollectioninnerValsiEval(ITupleinnerValRefs)=doinnerVals<-mapMinnerValRefEvalinnerValRefsreturn$TupleinnerValsinnerValRefEval::InnerValRef->IOThrowsErrorInnerValinnerValRefEval(IElementobjRef)=liftMElement$cRefEvalobjRefinnerValRefEval(ISubCollectionobjRef)=liftMSubCollection$cRefEvalobjRefcRefEval::ObjectRef->IOThrowsErrorEgisonValcRefEvalobjRef=doobj<-liftIO$readIORefobjRefval<-cEvalobjliftIO$writeIORefobjRef$ValuevalreturnvalcRefEval1::ObjectRef->IOThrowsErrorObjectcRefEval1objRef=doobj<-liftIO$readIORefobjRefobj2<-cEval1objliftIO$writeIORefobjRefobj2returnobj2cEval::Object->IOThrowsErrorEgisonValcEval(Closureenvexpr)=evalenvexprcEval(Valueval)=returnvalcEval(IntermidiateiVal)=iEvaliValcEval1::Object->IOThrowsErrorObjectcEval1(Closure_(BoolExprcontents))=return$Value(Boolcontents)cEval1(Closure_(CharExprcontents))=return$Value(Charcontents)cEval1(Closure_(StringExprcontents))=return$Value(Stringcontents)cEval1(Closure_(NumberExprcontents))=return$Value(Numbercontents)cEval1(Closure_(FloatExprcontents))=return$Value(Floatcontents)cEval1(Closureenv(VarExprnamenumExprs))=donumVals<-mapM(evalenv)numExprsnums<-mapM(\nVal->casenValofNumbernum->returnnum_->throwError$Default"cEval1: cannot reach here!")numValsobjRef<-getVarenv(name,nums)obj<-cRefEval1objRefcaseobjof-- for Macro expansionLoop_____->expandLoopenvobj_->returnobjcEval1(Closure_(InductiveDataExprcons[]))=doreturn$Value$InductiveDatacons[]cEval1(Closureenv(InductiveDataExprconsargExprs))=doargs<-liftIO$mapM(makeClosureenv)argExprsreturn$Intermidiate$IInductiveDataconsargscEval1(Closure_(TupleExpr[]))=doreturn$Value$Tuple[]cEval1(Closureenv(TupleExprinnerExprs))=doinnerRefs<-liftIO$mapM(makeInnerValRefenv)innerExprsobjRefs<-innerRefsToObjRefListinnerRefscaseobjRefsof[objRef]->cRefEval1objRef_->return$Intermidiate$ITupleinnerRefscEval1(Closureenv(CollectionExprinnerExprs))=doinnerRefs<-liftIO$mapM(makeInnerValRefenv)innerExprsreturn$Intermidiate$ICollectioninnerRefscEval1(Closure_WildCardExpr)=return$ValueWildCardcEval1(Closureenv(PatVarExprnamenumExprs))=donumVals<-mapM(evalenv)numExprsnums<-mapM(\nVal->casenValofNumbernum->returnnum_->throwError$Default"cEval1: cannot reach here!")numValsreturn$Value$PatVarnamenumscEval1(Closureenv(PredPatExprpredNameargExprs))=doargObjRefs<-liftIO$mapM(makeClosureenv)argExprsreturn$Value$PredPatpredNameargObjRefscEval1(Closureenv(CutPatExprpatExpr))=dopatObjRef<-liftIO$makeClosureenvpatExprreturn$Value$CutPatpatObjRefcEval1(Closureenv(NotPatExprpatExpr))=dopatObjRef<-liftIO$makeClosureenvpatExprreturn$Value$NotPatpatObjRefcEval1(Closureenv(OrPatExprpatExprs))=dopatObjRefs<-liftIO$mapM(makeClosureenv)patExprsreturn$Value$OrPatpatObjRefscEval1(Closureenv(AndPatExprpatExprs))=dopatObjRefs<-liftIO$mapM(makeClosureenv)patExprsreturn$Value$AndPatpatObjRefscEval1(Closureenv(FuncExprargsbody))=doreturn$Value$FuncargsbodyenvcEval1(Closureenv(IfExprcondExprexpr1expr2))=doobj<-cEval1$ClosureenvcondExprcaseobjofValue(BoolTrue)->cEval1$Closureenvexpr1Value(BoolFalse)->cEval1$Closureenvexpr2_->throwError$Default"if: condition is not bool value"cEval1(Closureenv(LetExprbindingsbody))=donewEnv<-extendLetenvbindingscEval1(ClosurenewEnvbody)cEval1(Closureenv(LetRecExprbindingsbody))=donewEnv<-liftIO$extendLetRecenvbindingscEval1$ClosurenewEnvbodycEval1(Closureenv(DoExpr[]body))=docEval1$ClosureenvbodycEval1(Closureenv(DoExpr(binding:bindings)body))=donewEnv<-extendLetenv[binding]cEval1$ClosurenewEnv$DoExprbindingsbodycEval1(Closureenv(TypeExprbindings))=doframeRef<-liftIO$makeLetRecFrameenvbindingsframe<-liftIO$readIORefframeRefreturn$Value$TypeframecEval1(Closureenv(TypeRefExprtypExprname))=doobj<-cEval1(ClosureenvtypExpr)caseobjofValue(Typeframe)->getVarFromFrameframe(name,[])>>=cRefEval1_->throwError$Default"type-ref: not type"cEval1(Closureenv(DestructorExprdestructInfoExpr))=dodestructInfo<-liftIO$makeDestructInfodestructInfoExprreturn$Value$DestructordestructInfowheremakeDestructInfo[]=return[]makeDestructInfo((cons,typExpr,pmcs):rest)=dotypObjRef<-liftIO$makeClosureenvtypExprletepmcs=map(\(ppat,body)->(env,ppat,body))pmcsretRest<-makeDestructInforestreturn((cons,typObjRef,epmcs):retRest)cEval1(Closureenv(MatchAllExprtgtExprtypExpr(patExpr,body)))=dopatObjRef<-liftIO$makeClosureenvpatExprtgtObjRef<-liftIO$makeClosureenvtgtExprtypObjRef<-liftIO$makeClosureenvtypExprmatchs<-patternMatchMAll[(MState[][(MAtom(PClosure[]patObjRef)tgtObjReftypObjRef)])]rets<-mapM(\match->donewEnv<-liftIO$extendEnvenvmatchobjRef<-liftIO$newIORef(ClosurenewEnvbody)returnobjRef)matchsreturn$Intermidiate$ICollection$mapIElementretscEval1(Closureenv(MatchExprtgtExprtypExprmcs))=dotgtObjRef<-liftIO$makeClosureenvtgtExprtypObjRef<-liftIO$makeClosureenvtypExprretRef<-mcLooptgtObjReftypObjRefmcscRefEval1retRefwheremcLoop__[]=throwError$Default"end of match clauses"mcLooptgtObjReftypObjRef((patExpr,body):rest)=dopatObjRef<-liftIO$makeClosureenvpatExprmatchs<-patternMatchMOne[(MState[][(MAtom(PClosure[]patObjRef)tgtObjReftypObjRef)])]casematchsof[match]->donewEnv<-liftIO$extendEnvenvmatchobjRef<-liftIO$newIORef(ClosurenewEnvbody)returnobjRef[]->mcLooptgtObjReftypObjRefrestcEval1(Closureenv(LoopExprloopVarindexVarrangeExprloopExprtailExpr))=dorangeObjRef<-liftIO$makeClosureenvrangeExprletloopObj=LooploopVarindexVarrangeObjRefloopExprtailExprexpandLoopenvloopObjcEval1(Closureenv(ApplyExpropExprargExpr))=doop<-cEval1(ClosureenvopExpr)caseopofValue(IOFuncfn)->doarg<-evalenvargExprval<-fn(tupleToListarg)return$ValuevalValue(PrimitiveFuncfn)->doarg<-evalenvargExprval<-liftThrows$fn(tupleToListarg)return$ValuevalValue(FuncfArgsbodycEnv)->doframe<-liftIO(makeClosureenvargExpr)>>=makeFramefArgsnewEnv<-liftIO$extendEnvcEnvframecEval1(ClosurenewEnvbody)_->throwError$Default"not function"cEval1val=returnvalcApply1::ObjectRef->ObjectRef->IOThrowsErrorObjectcApply1fnObjRefargObjRef=dofnObj<-cRefEval1fnObjRefcasefnObjofValue(IOFuncfn)->throwError$Default"undefined ioFunc"Value(PrimitiveFuncfn)->doarg<-cRefEvalargObjRefval<-liftThrows$fn(tupleToListarg)return$ValuevalValue(FuncfArgsbodycEnv)->doframe<-makeFramefArgsargObjRefnewEnv<-liftIO$extendEnvcEnvframecEval1(ClosurenewEnvbody)_->throwError$Default"cApply1: not function"expandLoop::Env->Object->IOThrowsErrorObjectexpandLoopenv(LooploopVarindexVarrangeObjRefloopExprtailExpr)=dob<-isEmptyCollectionrangeObjRefifbthencEval1$ClosureenvtailExprelsedo(carObjRef,cdrObjRef)<-consDestructrangeObjRefloopObjRef<-liftIO$newIORef$LooploopVarindexVarcdrObjRefloopExprtailExprnewEnv<-liftIO$extendEnvenv[((loopVar,[]),loopObjRef),((indexVar,[]),carObjRef)]cEval1$ClosurenewEnvloopExprexpandLoop_obj=throwError$Default$"expandLoop: cannot reach here: "++showobj-- |Extend given environment by binding a series of values to a new environment for let.extendLet::Env-- ^ Environment ->[(Args,EgisonExpr)]-- ^ Extensions to the environment->IOThrowsErrorEnv-- ^ Extended environmentextendLetenvabindings=dobingingList<-liftMconcat$mapM(\(args,expr)->doobjRef<-liftIO$makeClosureenvexprhelperargsobjRef)abindingsliftIO$extendEnvenvbingingListwherehelper(AVarname)objRef=return[((name,[]),objRef)]helper(ATupleargss)objRef=doobj<-cRefEval1objRefcaseobjofIntermidiate(ITupleinnerRefs)->doobjRefs<-innerValRefsToObjRefListinnerRefsliftMconcat$mapM(\(args,objRef3)->helperargsobjRef3)$zipargssobjRefsValue(TupleinnerVals)->doobjRefs<-liftIO$mapM(newIORef.Value)$innerValsToListinnerValsliftMconcat$mapM(\(args,objRef3)->helperargsobjRef3)$zipargssobjRefs_->throwError$Default"extendLet: not tuple"makeFrame::Args->ObjectRef->IOThrowsError[(Var,ObjectRef)]makeFrame(AVarname)objRef=return$[((name,[]),objRef)]makeFrame(ATuple[])_=return$[]makeFrame(ATuple[fArg])objRef=makeFramefArgobjRefmakeFrame(ATuplefArgs)objRef=doobj<-cRefEval1objRefcaseobjofIntermidiate(ITupleinnerRefs)->doobjRefs<-innerValRefsToObjRefListinnerRefsframes<-mapM(\(fArg,objRef3)->makeFramefArgobjRef3)$zipfArgsobjRefsreturn$concatframesValue(TupleinnerVals)->doletvals=innerValsToListinnerValsobjRefs<-liftIO$valsToObjRefListvalsframes<-mapM(\(fArg,objRef3)->makeFramefArgobjRef3)$zipfArgsobjRefsreturn$concatframes_->throwError$Default"makeFrame: not tuple"innerValRefsToObjRefList::[InnerValRef]->IOThrowsError[ObjectRef]innerValRefsToObjRefList[]=return[]innerValRefsToObjRefList(innerRef:rest)=dorestRet<-innerValRefsToObjRefListrestcaseinnerRefofIElementobjRef->return$objRef:restRetISubCollectionobjRef->doobj2<-cRefEval1objRefcaseobj2ofIntermidiate(ICollectioninnerRefs)->doobjRefs<-innerValRefsToObjRefListinnerRefsreturn$objRefs++restRetValue(CollectioninnerVals)->doobjRefs<-liftIO$mapMnewIORef$mapValue$innerValsToListinnerValsreturn$objRefs++restRet_->throwError$Default"innerValRefsToObjRefList: not collection"patternMatch::MatchFlag->[MState]->IOThrowsError[FrameList]patternMatch_[]=return[]patternMatchMAll((MStateframe[]):rest)=doframes<-patternMatchMAllrestreturn(frame:frames)patternMatchMOne((MStateframe[]):_)=doreturn[frame]patternMatchflag((MStateframe((MAtom(PClosurebfpatObjRef)tgtObjReftypObjRef):atoms)):states)=dopatObj<-liftIO$readIORefpatObjRefcasepatObjofClosureenvexpr->donewEnv<-liftIO$extendEnvenvbfpatObj2<-cEval1$ClosurenewEnvexprpatObjRef2<-liftIO$newIORefpatObj2patternMatchflag((MStateframe((MAtom(PClosure[]patObjRef2)tgtObjReftypObjRef):atoms)):states)ValueWildCard->patternMatchflag((MStateframeatoms):states)Value(PatVarnamenums)->dotyp<-cRefEval1typObjRefcasetypofValue(Typetf)->letmObjRef=Data.Map.lookup("var-match",[])tfincasemObjRefofNothing->throwError(Default"no method in type: var-match")JustfnObjRef->doret<-cApply1fnObjReftgtObjRefcaseretofIntermidiate(ICollectioninnerObjRefs)->doobjRefs<-innerValRefsToObjRefListinnerObjRefspatternMatchflag$(map(\objRef->(MState(((name,nums),objRef):frame)(map(\(MAtom(PClosurebf2pat2)tgt2typ2)->(MAtom(PClosure(((name,nums),objRef):bf2)pat2)tgt2typ2))atoms)))objRefs)++states_->throwError$Default"patternMatch: second argument of match expressions must be type"Intermidiate(IInductiveDataconpatObjRefs)->dotypObj<-cRefEval1typObjRefcasetypObjofValue(Typetf)->letmObjRef=Data.Map.lookup("inductive-match",[])tfincasemObjRefofNothing->throwError(Default"no method in type: inductiver-match")JustfnObjRef->dofnObj<-cRefEval1fnObjRefcasefnObjofValue(DestructordeconInfo)->doindRet<-inductiveMatchdeconInfocontgtObjRefcaseindRetof(nTypObjRef,nTgtsObjRef)->doinTypObjRefs<-tupleToObjRefListnTypObjRefinTgtsRefs<-collectionToObjRefListnTgtsObjRefinTgtObjRefss<-mapMtupleToObjRefListinTgtsRefspatternMatchflag((map(\inTgtObjRefs->(MStateframe((map(\(pat,inTgtObjRef,inTypObjRef)->(MAtom(PClosurebfpat)inTgtObjRefinTypObjRef))(zip3patObjRefsinTgtObjRefsinTypObjRefs))++atoms)))inTgtObjRefss)++states)_->throwError$Default"patternMatch: second argument of match expressions must be type"Value(InductiveDataconpats)->dopatObjRefs<-liftIO$mapM(newIORef.Value)patstypObj<-cRefEval1typObjRefcasetypObjofValue(Typetf)->letmObjRef=Data.Map.lookup("inductive-match",[])tfincasemObjRefofNothing->throwError(Default"no method in type: inductiver-match")JustfnObjRef->dofnObj<-cRefEval1fnObjRefcasefnObjofValue(DestructordeconInfo)->doindRet<-inductiveMatchdeconInfocontgtObjRefcaseindRetof(nTypObjRef,nTgtsObjRef)->doinTypObjRefs<-tupleToObjRefListnTypObjRefinTgtsRefs<-collectionToObjRefListnTgtsObjRefinTgtObjRefss<-mapMtupleToObjRefListinTgtsRefspatternMatchflag$(map(\inTgtObjRefs->(MStateframe((map(\(pat,inTgtObjRef,inTypObjRef)->MAtom(PClosurebfpat)inTgtObjRefinTypObjRef)(zip3patObjRefsinTgtObjRefsinTypObjRefs))++atoms)))inTgtObjRefss)++states_->throwError$Default"patternMatch: second argument of match expressions must be type"Intermidiate(ITuplepats)->dopatObjRefs<-innerRefsToObjRefListpatstgtObjRefs<-tupleToObjRefListtgtObjReftypObjRefs<-tupleToObjRefListtypObjRefpatternMatchflag$(MStateframe((map(\(pat,tgt,typ)->MAtom(PClosurebfpat)tgttyp)(zip3patObjRefstgtObjRefstypObjRefs))++atoms)):statesValue(Tuplepats)->dopatObjRefs<-innerValsToObjRefListpatstgtObjRefs<-tupleToObjRefListtgtObjReftypObjRefs<-tupleToObjRefListtypObjRefpatternMatchflag$(MStateframe((map(\(pat,tgt,typ)->MAtom(PClosurebfpat)tgttyp)(zip3patObjRefstgtObjRefstypObjRefs))++atoms)):statesValue(PredPatpredNamepatObjRefs)->dotypObj<-cRefEval1typObjRefcasetypObjofValue(Typetf)->letmObjRef=Data.Map.lookup(predName,[])tfincasemObjRefofNothing->throwError$Default$"no method in type: "++predNameJustfnObjRef->doargsObjRef<-liftIO$newIORef$Intermidiate$ITuple$mapIElement$patObjRefs++[tgtObjRef]ret<-cApply1fnObjRefargsObjRefcaseretofValue(BoolTrue)->patternMatchflag((MStateframeatoms):states)Value(BoolFalse)->patternMatchflagstates_->throwError(Default"patternMatch: return value of pred-pattern is not boolean value")_->throwError$Default"patternMatch: second argument of match expressions must be type"Value(NotPatpatObjRef2)->doretFrames<-patternMatchMOne[(MStateframe[(MAtom(PClosurebfpatObjRef2)tgtObjReftypObjRef)])]caseretFramesof[]->patternMatchflag((MStateframeatoms):states)_->patternMatchflagstatesValue(AndPatpatObjRefs)->patternMatchflag((MStateframe((map(\patObjRef2->(MAtom(PClosurebfpatObjRef2)tgtObjReftypObjRef))patObjRefs)++atoms)):states)Value(OrPatpatObjRefs)->patternMatchflag((map(\patObjRef2->(MStateframe((MAtom(PClosurebfpatObjRef2)tgtObjReftypObjRef):atoms)))patObjRefs)++states)Value(CutPatpatObjRef2)->doretFrames<-patternMatchflag[(MStateframe((MAtom(PClosurebfpatObjRef2)tgtObjReftypObjRef):atoms))]caseretFramesof[]->return[]_->caseflagofMAll->dorestFrames<-patternMatchflagstatesreturn(retFrames++restFrames)MOne->returnretFrames_->throwError$Default$"invalid pattern: "++showpatObjinductiveMatch::DestructInfo->String->ObjectRef->IOThrowsError(ObjectRef,ObjectRef)inductiveMatch[]__=throwError(Default"inductiveMatch: not matched any clauses")inductiveMatch((con,_,[]):rest)pcontgtObjRefRef=if(con==pcon)thenthrowError(Default"inductiveMatch: not matched any clauses")elseinductiveMatchrestpcontgtObjRefRefinductiveMatch((con,typObjRef,((env,ppat,expr):cls)):rest)pcontgtObjRefRef=doif(con==pcon)thendomPpmRet<-primitivePatternMatchppattgtObjRefRefcasemPpmRetofNothing->inductiveMatch((con,typObjRef,cls):rest)pcontgtObjRefRefJustppmRet->donewEnv<-liftIO$extendEnvenvppmRetret<-liftIO$makeClosurenewEnvexprreturn(typObjRef,ret)elseinductiveMatchrestpcontgtObjRefRefprimitivePatternMatch::PrimitivePattern->ObjectRef->IOThrowsError(MaybeFrameList)primitivePatternMatch(PPatBoolbool)objRef=doval<-cRefEvalobjRefcasevalofBoolbool2->ifbool==bool2thenreturn(Just[])elsereturnNothing_->returnNothingprimitivePatternMatch(PPatCharchr)objRef=doval<-cRefEvalobjRefcasevalofCharchr2->ifchr==chr2thenreturn(Just[])elsereturnNothing_->returnNothingprimitivePatternMatch(PPatNumbernum)objRef=doval<-cRefEvalobjRefcasevalofNumbernum2->ifnum==num2thenreturn(Just[])elsereturnNothing_->returnNothingprimitivePatternMatch(PPatFloatd)objRef=doval<-cRefEvalobjRefcasevalofFloatd2->ifd==d2thenreturn(Just[])elsereturnNothing_->returnNothingprimitivePatternMatchPWildCard_=return$Just[]primitivePatternMatch(PPatVarname)objRef=return(Just[((name,[]),objRef)])primitivePatternMatch(PInductivePatpConspPats)objRef=doobj<-cRefEval1objRefcaseobjofIntermidiate(IInductiveDataconsobjRefs)->ifpCons==consthenprimitivePatternMatchListpPatsobjRefselsereturnNothingValue(InductiveDataconsvals)->ifpCons==consthendoobjRefs<-liftIO$mapM(newIORef.Value)valsprimitivePatternMatchListpPatsobjRefselsereturnNothing_->returnNothingprimitivePatternMatchPEmptyPatobjRef=dob<-isEmptyCollectionobjRefifbthenreturn(Just[])elsereturnNothingprimitivePatternMatch(PConsPatcarPatcdrPat)objRef=dob<-isEmptyCollectionobjRefifbthenreturnNothingelsedo(carObjRef,cdrObjRef)<-consDestructobjRefmCarFrame<-primitivePatternMatchcarPatcarObjRefcasemCarFrameofNothing->returnNothingJustcarFrame->domCdrFrame<-primitivePatternMatchcdrPatcdrObjRefcasemCdrFrameofNothing->returnNothingJustcdrFrame->return(Just(carFrame++cdrFrame))primitivePatternMatch(PSnocPatrdcPatracPat)objRef=dob<-isEmptyCollectionobjRefifbthenreturnNothingelsedo(racObjRef,rdcObjRef)<-snocDestructobjRefmRacFrame<-primitivePatternMatchracPatracObjRefcasemRacFrameofNothing->returnNothingJustracFrame->domRdcFrame<-primitivePatternMatchrdcPatrdcObjRefcasemRdcFrameofJustrdcFrame->return(Just(racFrame++rdcFrame))Nothing->returnNothingprimitivePatternMatchList::[PrimitivePattern]->[ObjectRef]->IOThrowsError(MaybeFrameList)primitivePatternMatchList[][]=return(Just[])primitivePatternMatchList(pat:pats)(objRef:objRefs)=domFrame<-primitivePatternMatchpatobjRefcasemFrameofNothing->returnNothingJustframe->domRestFrame<-primitivePatternMatchListpatsobjRefscasemRestFrameofNothing->returnNothingJustrestFrame->return(Just(frame++restFrame))primitivePatternMatchList__=throwError(Default"primitivePatternMatchList : number of patterns and targets are different")isEmptyCollection::ObjectRef->IOThrowsErrorBoolisEmptyCollectionobjRef=doobj<-cRefEval1objRefcaseobjofIntermidiate(ICollectioninnerRefs)->isEmptyInnerRefsinnerRefsValue(CollectioninnerVals)->isEmptyInnerValsinnerVals_->throwError$Default$"isEmptyCollection: not collection:"++showobjisEmptyInnerRefs::[InnerValRef]->IOThrowsErrorBoolisEmptyInnerRefs[]=returnTrueisEmptyInnerRefs((IElement_):_)=returnFalseisEmptyInnerRefs((ISubCollectionobjRef):rest)=dob<-isEmptyCollectionobjRefifbthenisEmptyInnerRefsrestelsereturnFalseisEmptyInnerVals::[InnerVal]->IOThrowsErrorBoolisEmptyInnerVals[]=returnTrueisEmptyInnerVals((Element_):_)=returnFalseisEmptyInnerVals((SubCollectionval):rest)=doobjRef<-liftIO$newIORef$Valuevalb<-isEmptyCollectionobjRefifbthenisEmptyInnerValsrestelsereturnFalseconsDestruct::ObjectRef->IOThrowsError(ObjectRef,ObjectRef)consDestructobjRef=doobj<-cRefEval1objRefcaseobjofIntermidiate(ICollectioninnerRefs)->consDestructInnerRefsinnerRefsValue(CollectioninnerVals)->consDestructInnerValsinnerVals_->throwError$Default"consDestruct: not collection"consDestructInnerRefs::[InnerValRef]->IOThrowsError(ObjectRef,ObjectRef)consDestructInnerRefs[]=throwError$Default"consDestructInnerRefs: empty collection"consDestructInnerRefs((IElementobjRef):rest)=docdrObjRef<-liftIO$newIORef$Intermidiate$ICollectionrestreturn(objRef,cdrObjRef)consDestructInnerRefs((ISubCollectionobjRef):rest)=dob<-isEmptyCollectionobjRefifbthenconsDestructInnerRefsrestelsedo(carObjRef,cdrObjRef)<-consDestructobjRefcdrObjRef2<-liftIO$newIORef$Intermidiate$ICollection$(ISubCollectioncdrObjRef):restreturn(carObjRef,cdrObjRef2)consDestructInnerVals::[InnerVal]->IOThrowsError(ObjectRef,ObjectRef)consDestructInnerVals[]=throwError$Default"consDestructInnerVals: empty collection"consDestructInnerVals((Elementval):rest)=docarObjRef<-liftIO$newIORef$ValuevalcdrObjRef<-liftIO$newIORef$Value$Collectionrestreturn(carObjRef,cdrObjRef)consDestructInnerVals((SubCollectionval):rest)=doobjRef<-liftIO$newIORef$Valuevalb<-isEmptyCollectionobjRefifbthenconsDestructInnerValsrestelsedo(carObjRef,cdrObjRef)<-consDestructobjRefcdrObj<-liftIO$readIORefcdrObjRefcasecdrObjofValue(CollectioninnerVals)->docdrObjRef2<-liftIO$newIORef$Value$Collection$(SubCollection(CollectioninnerVals)):restreturn(carObjRef,cdrObjRef2)_->throwError$Default"consDestructInnerVals: cannot reach here!"snocDestruct::ObjectRef->IOThrowsError(ObjectRef,ObjectRef)snocDestructobjRef=doobj<-cRefEval1objRefcaseobjofIntermidiate(ICollectioninnerRefs)->snocDestructInnerRefsinnerRefsValue(CollectioninnerVals)->snocDestructInnerValsinnerVals_->throwError$Default"snocDestruct: not collection"snocDestructInnerRefs::[InnerValRef]->IOThrowsError(ObjectRef,ObjectRef)snocDestructInnerRefs[]=throwError$Default"snocDestructInnerRefs: empty collection"snocDestructInnerRefs((IElementobjRef):rest)=docdrObjRef<-liftIO$newIORef$Intermidiate$ICollectionrestreturn(objRef,cdrObjRef)snocDestructInnerRefs((ISubCollectionobjRef):rest)=dob<-isEmptyCollectionobjRefifbthensnocDestructInnerRefsrestelsedo(carObjRef,cdrObjRef)<-snocDestructobjRefcdrObjRef2<-liftIO$newIORef$Intermidiate$ICollection$(ISubCollectioncdrObjRef):restreturn(carObjRef,cdrObjRef2)snocDestructInnerVals::[InnerVal]->IOThrowsError(ObjectRef,ObjectRef)snocDestructInnerVals[]=throwError$Default"snocDestructInnerVals: empty collection"snocDestructInnerVals((Elementval):rest)=docarObjRef<-liftIO$newIORef$ValuevalcdrObjRef<-liftIO$newIORef$Value$Collectionrestreturn(carObjRef,cdrObjRef)snocDestructInnerVals((SubCollectionval):rest)=doobjRef<-liftIO$newIORef$Valuevalb<-isEmptyCollectionobjRefifbthensnocDestructInnerValsrestelsedo(carObjRef,cdrObjRef)<-snocDestructobjRefcdrObj<-liftIO$readIORefcdrObjRefcasecdrObjofValue(CollectioninnerVals)->docdrObjRef2<-liftIO$newIORef$Value$Collection$(SubCollection(CollectioninnerVals)):restreturn(carObjRef,cdrObjRef2)_->throwError$Default"snocDestructInnerVals: cannot reach here!"collectionToObjRefList::ObjectRef->IOThrowsError[ObjectRef]collectionToObjRefListobjRef=doobj<-cRefEval1objRefcaseobjofIntermidiate(ICollectioninnerRefs)->innerRefsToObjRefListinnerRefsValue(CollectioninnerVals)->innerValsToObjRefListinnerVals_->throwError$Default"collectionToObjRefList: not collection"tupleToObjRefList::ObjectRef->IOThrowsError[ObjectRef]tupleToObjRefListobjRef=doobj<-cRefEval1objRefcaseobjofIntermidiate(ITupleinnerRefs)->innerRefsToObjRefListinnerRefsValue(TupleinnerVals)->innerValsToObjRefListinnerVals_->return[objRef]innerRefsToObjRefList::[InnerValRef]->IOThrowsError[ObjectRef]innerRefsToObjRefList[]=return[]innerRefsToObjRefList((IElementobjRef):rest)=doretRest<-innerRefsToObjRefListrestreturn$objRef:retRestinnerRefsToObjRefList((ISubCollectionobjRef):rest)=doretObj<-collectionToObjRefListobjRefretRest<-innerRefsToObjRefListrestreturn$retObj++retRestinnerValsToObjRefList::[InnerVal]->IOThrowsError[ObjectRef]innerValsToObjRefList[]=return[]innerValsToObjRefList((Elementval):rest)=dovalRef<-liftIO$newIORef$ValuevalretRest<-innerValsToObjRefListrestreturn$valRef:retRestinnerValsToObjRefList((SubCollectionval):rest)=dovalRef<-liftIO$newIORef$ValuevalretVal<-collectionToObjRefListvalRefretRest<-innerValsToObjRefListrestreturn$retVal++retRestprimitiveBindings::IOEnvprimitiveBindings=doinitEnv<-nullEnvconstantsFrameList<-mapMdomakeObjRefconstantsiOFuncs<-mapM(domakeFuncIOFunc)ioPrimitivesprimitiveFuncs<-mapM(domakeFuncPrimitiveFunc)primitivesextendEnvinitEnv(constantsFrameList++iOFuncs++primitiveFuncs)wheredomakeFuncconstructor(name,func)=doobjRef<-newIORef$Value$constructorfuncreturn((name,[]),objRef)domakeObjRef(name,val)=doobjRef<-newIORef$Valuevalreturn((name,[]),objRef)constants::[(String,EgisonVal)]constants=[("pi",Float3.14)]{- I/O primitives -}ioPrimitives::[(String,[EgisonVal]->IOThrowsErrorEgisonVal)]ioPrimitives=[("open-input-file",makePortReadMode),("open-output-file",makePortWriteMode),("close-input-port",closePort),("close-output-port",closePort),("read-char",readChar),("read-line",readLine),("read",readFromStdin),("write-char",writeChar),("write-string",writeString),("print",writeStringLine),("write",write),("flush",flushStdout),("read-char-from-port",readCharFromPort),("read-line-from-port",readLineFromPort),("read-from-port",readFromPort),("write-char-to-port",writeCharToPort),("write-string-to-port",writeStringToPort),("print-to-port",writeStringLineToPort),("write-to-port",writeToPort),("flush-port",flushPort)]{- "Pure" primitive functions -}primitives::[(String,[EgisonVal]->ThrowsErrorEgisonVal)]primitives=[("+",numericBinop(+)),("-",numericBinop(-)),("*",numericBinop(*)),-- ("/", numericBinop (/)),("mod",numericBinopmod),("quotient",numericBinopquot),("remainder",numericBinoprem),("+f",floatBinop(+)),("-f",floatBinop(-)),("*f",floatBinop(*)),("/f",floatBinop(/)),("round",floatNumSglopround),("floor",floatNumSglopfloor),("ceiling",floatNumSglopceiling),("truncate",floatNumSgloptruncate),("exp",numExp),("log",numLog),("sin",floatSglopsin),("cos",floatSglopcos),("tan",floatSgloptan),("asin",floatSglopasin),("acos",floatSglopacos),("atan",floatSglopatan),("sinh",floatSglopsinh),("cosh",floatSglopcosh),("tanh",floatSgloptanh),("asinh",floatSglopasinh),("acosh",floatSglopacosh),("atanh",floatSglopatanh),("sqrt",numSqrt),("expt",numExpt),("eq?",numBoolBinop(==)),("lt?",numBoolBinop(<)),("lte?",numBoolBinop(<=)),("gt?",numBoolBinop(>)),("gte?",numBoolBinop(>=)),("eq-f?",floatBoolBinop(==)),("lt-f?",floatBoolBinop(<)),("lte-f?",floatBoolBinop(<=)),("gt-f?",floatBoolBinop(>)),("gte-f?",floatBoolBinop(>=)),("eq-c?",charBoolBinop(==)),("eq-s?",strBoolBinop(==)),("&&",boolBinop(&&)),("||",boolBinop(||))]