moduleLanguage.Egison.ParserwhereimportLanguage.Egison.TypesimportControl.Monad.ErrorimportqualifiedData.CharasCharimportData.CompleximportData.ArrayimportNumericimportData.RatioimportText.ParserCombinators.Parsechiding(spaces)importText.Parsec.LanguageimportText.Parsec.Prim(ParsecT)importqualifiedText.Parsec.TokenasPegisonDef::LanguageDef()egisonDef=emptyDef{P.commentStart="#|",P.commentEnd="|#",P.commentLine=";",P.nestedComments=True,P.identStart=letter<|>symbol,P.identLetter=letter<|>digit<|>symbol<|>symbol2,P.reservedNames=[],P.caseSensitive=True}--lexer :: P.GenTokenParser String () Identitylexer=P.makeTokenParseregisonDef--dot :: ParsecT String () Identity Stringdot=P.dotlexer--parens :: ParsecT String () Identity a -> ParsecT String () Identity aparens=P.parenslexerbrackets=P.bracketslexerbraces=P.braceslexerangles=P.angleslexer--identifier :: ParsecT String () Identity Stringidentifier=P.identifierlexer-- TODO: typedef. starting point was: whiteSpace :: CharParser ()--whiteSpace :: ParsecT String () Identity ()whiteSpace=P.whiteSpacelexer--lexeme :: ParsecT String () Identity a -> ParsecT String () Identity alexeme=P.lexemelexersymbol::ParserChar--symbol = oneOf "!$%&|*+-/:<=>?@^_~."symbol=oneOf"%&|*+-/:="symbol2::ParserChar--symbol = oneOf "!$%&|*+-/:<=>?@^_~."symbol2=oneOf"!?"parseBool::ParserEgisonExprparseBool=do_<-string"#"x<-oneOf"tf"return$casexof't'->BoolExprTrue'f'->BoolExprFalse_->BoolExprFalseparseBool2::ParserBoolparseBool2=doboolExpr<-parseBoolcaseboolExprofBoolExprTrue->returnTrueBoolExprFalse->returnFalseparseChar::ParserEgisonExprparseChar=do_<-char'\''x<-parseEscapedChar<|>noneOf("'")_<-char'\''return$CharExprxparseChar2::ParserCharparseChar2=dochrExpr<-parseCharcasechrExprofCharExprchr->returnchrparseOctalNumber::ParserEgisonExprparseOctalNumber=do_<-try(string"#o")sign<-many(oneOf"-")num<-many1(oneOf"01234567")case(lengthsign)of0->return$NumberExpr$fst$Numeric.readOctnum!!01->return$NumberExpr$fromInteger$(*)(-1)$fst$Numeric.readOctnum!!0_->pzeroparseBinaryNumber::ParserEgisonExprparseBinaryNumber=do_<-try(string"#b")sign<-many(oneOf"-")num<-many1(oneOf"01")case(lengthsign)of0->return$NumberExpr$fst$Numeric.readInt2(`elem`"01")Char.digitToIntnum!!01->return$NumberExpr$fromInteger$(*)(-1)$fst$Numeric.readInt2(`elem`"01")Char.digitToIntnum!!0_->pzeroparseHexNumber::ParserEgisonExprparseHexNumber=do_<-try(string"#x")sign<-many(oneOf"-")num<-many1(digit<|>oneOf"abcdefABCDEF")case(lengthsign)of0->return$NumberExpr$fst$Numeric.readHexnum!!01->return$NumberExpr$fromInteger$(*)(-1)$fst$Numeric.readHexnum!!0_->pzero-- |Parser for Integer, base 10parseDecimalNumber::ParserEgisonExprparseDecimalNumber=do_<-try(many(string"#d"))sign<-many(oneOf"-")num<-many1(digit)if(lengthsign)>1thenpzeroelsereturn$(NumberExpr.read)$sign++num-- |Parser for a base 10 Integer that will also-- check to see if the number is followed by-- an exponent (scientific notation). If so,-- the integer is converted to a float of the-- given magnitude.parseDecimalNumberMaybeExponent::ParserEgisonExprparseDecimalNumberMaybeExponent=donum<-parseDecimalNumberresult<-parseNumberExponentnumreturnresult-- |Parse an integer in any baseparseNumber::ParserEgisonExprparseNumber=parseDecimalNumberMaybeExponent<|>parseHexNumber<|>parseBinaryNumber<|>parseOctalNumber<?>"Unable to parse number"parseNumber2::ParserIntegerparseNumber2=donumExpr<-parseNumbercasenumExprofNumberExprn->returnn-- |Parse a floating point numberparseRealNumber::ParserEgisonExprparseRealNumber=dosign<-many(oneOf"-+")num<-many1(digit)_<-char'.'frac<-many1(digit)letdec=num++"."++fracf<-case(lengthsign)of0->return$FloatExpr$fst$Numeric.readFloatdec!!0-- Bit of a hack, but need to support the + sign as well as the minus.1->ifsign=="-"thenreturn$FloatExpr$(*)(-1.0)$fst$Numeric.readFloatdec!!0elsereturn$FloatExpr$fst$Numeric.readFloatdec!!0_->pzeroresult<-parseNumberExponentfreturnresultparseRealNumber2::ParserDoubleparseRealNumber2=dofloatExpr<-parseRealNumbercasefloatExprofFloatExprd->returnd-- | Parse the exponent section of a floating point number-- in scientific notation. Eg "e10" from "1.0e10"parseNumberExponent::EgisonExpr->ParserEgisonExprparseNumberExponentn=doexp<-many$oneOf"Ee"case(lengthexp)of0->returnn1->donum<-try(parseDecimalNumber)casenumofNumberExprexp->buildResultnexp_->pzero_->pzerowherebuildResult(NumberExprnum)exp=return$FloatExpr$(fromIntegralnum)*(10**(fromIntegralexp))buildResult(FloatExprnum)exp=return$FloatExpr$num*(10**(fromIntegralexp))buildResultnum_=pzeroparseEscapedChar::GenParserCharstCharparseEscapedChar=do_<-char'\\'c<-anyCharreturn$casecof'n'->'\n''t'->'\t''r'->'\r'_->cparseString2::ParserStringparseString2=do_<-char'"'x<-many(parseEscapedChar<|>noneOf("\""))_<-char'"'return$xparseString::ParserEgisonExprparseString=dox<-parseString2return$StringExprxparseIndexNums::Parser[EgisonExpr]parseIndexNums=dotry(dochar'_'n<-parseExprns<-parseIndexNumsreturn(n:ns))<|>doreturn[]parseInnerExp::ParserInnerExprparseInnerExp=dov<-lexemeparseExprreturn$ElementExprv<|>dochar'@'v<-lexemeparseExprreturn$SubCollectionExprvparsePatVar2::ParserVarExprparsePatVar2=dochar'$'name<-identifiernums<-parseIndexNumsreturn(name,nums)parsePatVar::ParserEgisonExprparsePatVar=do(name,nums)<-parsePatVar2return$PatVarExprnamenumsparseSymbol2::ParserVarExprparseSymbol2=dochar'#'name<-identifiernums<-lexemeparseIndexNumsreturn(name,nums)parseSymbol::ParserEgisonExprparseSymbol=do(name,nums)<-parseSymbol2return$SymbolExprnamenumsparseArgs::ParserArgsExprparseArgs=dotry(do(name,_)<-lexemeparsePatVar2return$AVarname)<|>try(lexeme(brackets(doargs<-sepEndByparseArgswhiteSpacereturn$ATupleargs)))parseBindings::ParserBindingsparseBindings=dobraces(dosepEndBy(brackets(doargs<-lexemeparseArgsexpr<-lexemeparseExprreturn(args,expr)))whiteSpace)parseRecursiveBindings::ParserRecursiveBindingsparseRecursiveBindings=dobraces(dosepEndBy(brackets(dochar'$'name<-lexemeidentifierexpr<-lexemeparseExprreturn(name,expr)))whiteSpace)parseVar::ParserEgisonExprparseVar=doname<-identifiernums<-lexemeparseIndexNumsreturn$VarExprnamenumsparseWildCard::ParserEgisonExprparseWildCard=dochar'_'returnWildCardExprparseCutPat::ParserEgisonExprparseCutPat=dochar'!'expr<-parseExprreturn$CutPatExprexprparseNotPat::ParserEgisonExprparseNotPat=dochar'^'expr<-parseExprreturn$NotPatExprexprparseValuePat::ParserEgisonExprparseValuePat=dochar','expr<-parseExprreturn$PredPatExpr"="[expr]parseInnerExpr::ParserInnerExprparseInnerExpr=doexpr<-parseExprreturn$ElementExprexpr<|>dochar'@'expr<-parseExprreturn$SubCollectionExprexprparsePattern::ParserEgisonExprparsePattern=parseWildCard<|>parsePatVar<|>parseCutPat<|>parseNotPat<|>parseValuePat<|>parens(dotry(char'?'>>many1space)predName<-lexemeidentifierargExprs<-sepEndByparseExprwhiteSpacereturn(PredPatExprpredNameargExprs)<|>dotry(char'|'>>many1space)pats<-sepEndByparseExprwhiteSpacereturn(OrPatExprpats)<|>dotry(char'&'>>many1space)pats<-sepEndByparseExprwhiteSpacereturn(AndPatExprpats))parseDestructInfoExpr::ParserDestructInfoExprparseDestructInfoExpr=braces(sepEndByparseDestructClausewhiteSpace)parseDestructClause::Parser(String,EgisonExpr,[(PrimitivePattern,EgisonExpr)])parseDestructClause=brackets(dopatCons<-lexemeidentifiertypExpr<-lexemeparseExprdc2s<-lexeme(braces(sepEndByparseDestructClause2whiteSpace))return(patCons,typExpr,dc2s))parseDestructClause2::Parser(PrimitivePattern,EgisonExpr)parseDestructClause2=brackets(dodatPat<-lexemeparsePrimitivePatternexpr<-lexemeparseExprreturn(datPat,expr))parsePrimitivePattern::ParserPrimitivePatternparsePrimitivePattern=dochar'_'returnPWildCard<|>dochar'$'name<-identifierreturn(PPatVarname)<|>angles(doc<-lexemeidentifierps<-sepEndByparsePrimitivePatternwhiteSpacereturn(PInductivePatcps))<|>try(dostring"{}"returnPEmptyPat)<|>try(dolexeme$char'{'a<-lexemeparsePrimitivePatternchar'.'b<-lexemeparsePrimitivePatternchar'}'return(PConsPatab))<|>try(dolexeme$char'{'char'.'a<-lexemeparsePrimitivePatternb<-lexemeparsePrimitivePatternchar'}'return(PSnocPatab))<|>dob<-tryparseBool2return(PPatBoolb)<|>doc<-tryparseChar2return(PPatCharc)<|>dod<-tryparseRealNumber2return(PPatFloatd)<|>don<-tryparseNumber2return(PPatNumbern)parseMatchClause::ParserMatchClauseparseMatchClause=brackets(dopat<-lexemeparseExprbody<-lexemeparseExprreturn(pat,body))-- |Parse an expressionparseExpr::ParserEgisonExprparseExpr=try(lexemeparseRealNumber)<|>try(lexemeparseNumber)<|>lexemeparseChar<|>lexemeparseString<|>try(lexemeparseBool)<|>try(lexemeparseSymbol)<|>try(lexemeparsePattern)-- <|> lexeme parsePatVarOmitExpr<|>lexemeparseVar<|>angles(docons<-lexemeidentifierargExprs<-sepEndByparseExprwhiteSpacereturn$InductiveDataExprconsargExprs)<|>braces(doinnerExprs<-sepEndByparseInnerExprwhiteSpacereturn$CollectionExprinnerExprs)<|>brackets(doinnerExprs<-sepEndByparseInnerExprwhiteSpacereturn$TupleExprinnerExprs)<|>parens(dotry(string"lambda">>many1space)args<-lexemeparseArgsbody<-lexemeparseExprreturn(FuncExprargsbody)<|>dotry(string"if">>many1space)condExpr<-lexemeparseExprexpr1<-lexemeparseExprexpr2<-lexemeparseExprreturn(IfExprcondExprexpr1expr2)<|>dotry(string"letrec">>many1space)bindings<-lexemeparseRecursiveBindingsbody<-lexemeparseExprreturn(LetRecExprbindingsbody)<|>dotry(string"let">>many1space)bindings<-lexemeparseBindingsbody<-lexemeparseExprreturn(LetExprbindingsbody)<|>dotry(string"do">>many1space)bindings<-lexemeparseBindingsbody<-lexemeparseExprreturn(DoExprbindingsbody)<|>dotry(string"type-ref">>many1space)typExpr<-lexemeparseExprname<-lexemeidentifierreturn(TypeRefExprtypExprname)<|>dotry(string"type">>many1space)bindings<-lexemeparseRecursiveBindingsreturn(TypeExprbindings)<|>dotry(string"destructor">>many1space)deconsInfo<-lexemeparseDestructInfoExprreturn(DestructorExprdeconsInfo)<|>dotry(string"match-all">>many1space)tgtExpr<-lexemeparseExprtypExpr<-lexemeparseExprmc<-lexemeparseMatchClausereturn(MatchAllExprtgtExprtypExprmc)<|>dotry(string"match">>many1space)tgtExpr<-lexemeparseExprtypExpr<-lexemeparseExprmcs<-braces(sepEndByparseMatchClausewhiteSpace)return(MatchExprtgtExprtypExprmcs)<|>dotry(string"loop">>many1space)(loopVar,_)<-lexemeparsePatVar2(indexVar,_)<-lexemeparsePatVar2rangeExpr<-lexemeparseExprloopExpr<-lexemeparseExprtailExpr<-lexemeparseExprreturn(LoopExprloopVarindexVarrangeExprloopExprtailExpr)<|>doopExpr<-lexemeparseExprargExprs<-sepEndByparseExprwhiteSpacereturn(ApplyExpropExpr(TupleExpr(mapElementExprargExprs))))<?>"Expression"parseTopExpr::ParserTopExprparseTopExpr=dowhiteSpaceparens(dotry$lexeme$string"define"char'$'name<-lexemeidentifierexpr<-lexemeparseExprreturn(Definenameexpr)<|>dotry$lexeme$string"test"expr<-lexemeparseExprreturn(Testexpr)<|>dotry$lexeme$string"execute"args<-sepEndByparseString2whiteSpacereturn(Executeargs)<|>dotry$string"load-file">>many1spacefilename<-lexemeparseString2return(LoadFilefilename)<|>dotry$lexeme$string"load"filename<-lexemeparseString2return(Loadfilename))<?>"top expression"mainParser::ParserTopExprmainParser=dox<-parseTopExpr-- FUTURE? (seemed to break test cases, but is supposed to be best practice?) eofreturnx-- |Use a parser to parse the given text, throwing an error-- if there is a problem parsing the text.readOrThrow::Parsera->String->ThrowsErrorareadOrThrowparserinput=caseparseparser"egison"inputofLefterr->throwError$ParsererrRightval->returnval-- |Parse an top expression from a string of textreadTopExpr::String->ThrowsErrorTopExprreadTopExpr=readOrThrowmainParser-- |Parse an expression from a string of textreadExpr::String->ThrowsErrorEgisonExprreadExpr=readOrThrowparseExpr-- |Parse many top expressions from a string of textreadTopExprList::String->ThrowsError[TopExpr]readTopExprList=readOrThrow(endBymainParserwhiteSpace)