------------------------------------------------------------------------------- |-- Module : Database.TxtSushi.SQLParser-- Copyright : (c) Keith Sheppard 2009-- License : GPL3 or greater-- Maintainer : keithshep@gmail.com-- Stability : experimental-- Portability : portable---- Module for parsing SQL-------------------------------------------------------------------------------moduleDatabase.TxtSushi.SQLParser(allMaybeTableNames,parseSelectStatement,SelectStatement(..),TableExpression(..),ColumnIdentifier(..),prettyFormatColumn,ColumnSelection(..),expressionIdentifier,Expression(..),OrderByItem(..),prettyFormatWithArgs,SQLFunction(..),withTrailing,withoutTrailing,isAggregate,selectStatementContainsAggregates,-- aggregatesavgFunction,countFunction,firstFunction,lastFunction,maxFunction,minFunction,sumFunction,-- String SQL functionconcatenateFunction,absFunction,upperFunction,lowerFunction,trimFunction,substringFromFunction,substringFromToFunction,-- Algebraic SQL functionsmultiplyFunction,divideFunction,plusFunction,minusFunction,negateFunction,-- Boolean SQL functionsisFunction,isNotFunction,lessThanFunction,lessThanOrEqualToFunction,greaterThanFunction,greaterThanOrEqualToFunction,andFunction,orFunction,notFunction,regexMatchFunction,-- Etc...maybeReadInt,maybeReadReal)whereimportData.CharimportData.ListimportText.ParserCombinators.ParsecimportText.ParserCombinators.Parsec.Expr---------------------------------------------------------------------------------- The data definition for select statements---------------------------------------------------------------------------------- | represents a select statement-- TODO this should be moved inside the TableExpression typedataSelectStatement=SelectStatement{columnSelections::[ColumnSelection],maybeFromTable::MaybeTableExpression,maybeWhereFilter::MaybeExpression,maybeGroupByHaving::Maybe([Expression],MaybeExpression),orderByItems::[OrderByItem]}deriving(Show,Ord,Eq)dataTableExpression=TableIdentifier{tableName::String,maybeTableAlias::MaybeString}|InnerJoin{leftJoinTable::TableExpression,rightJoinTable::TableExpression,onCondition::Expression,maybeTableAlias::MaybeString}|CrossJoin{leftJoinTable::TableExpression,rightJoinTable::TableExpression,maybeTableAlias::MaybeString}|SelectExpression{selectStatement::SelectStatement,maybeTableAlias::MaybeString}deriving(Show,Ord,Eq)-- | convenience function for extracting all of the table names used by the-- given table expressionallMaybeTableNames::(MaybeTableExpression)->[String]allMaybeTableNamesNothing=[]allMaybeTableNames(JusttblExp)=allTableNamestblExpallTableNames::TableExpression->[String]allTableNames(TableIdentifiertblName_)=[tblName]allTableNames(InnerJoinlftTblrtTbl__)=(allTableNameslftTbl)++(allTableNamesrtTbl)allTableNames(CrossJoinlftTblrtTbl_)=(allTableNameslftTbl)++(allTableNamesrtTbl)allTableNames(SelectExpressionselectStmt_)=allMaybeTableNames$maybeFromTableselectStmtdataColumnSelection=AllColumns|AllColumnsFrom{sourceTableName::String}|ExpressionColumn{expression::Expression,maybeColumnAlias::MaybeString}--QualifiedColumn {-- qualifiedColumnId :: ColumnIdentifier}deriving(Show,Ord,Eq)dataColumnIdentifier=ColumnIdentifier{maybeTableName::MaybeString,columnId::String}deriving(Show,Ord,Eq)-- | I wanted to leave the default Show, but I also wanted a pretty print, so-- here it is!prettyFormatColumn::ColumnIdentifier->StringprettyFormatColumn(ColumnIdentifier(JusttblName)colId)=tblName++"."++colIdprettyFormatColumn(ColumnIdentifier(Nothing)colId)=colIddataExpression=FunctionExpression{sqlFunction::SQLFunction,functionArguments::[Expression]}|ColumnExpression{column::ColumnIdentifier}|StringConstantExpression{stringConstant::String}|IntegerConstantExpression{intConstant::Int}|RealConstantExpression{realConstant::Double}deriving(Show,Ord,Eq)-- | an aggregate function is one whose min function count is 1 and whose-- arg count is not fixedisAggregate::SQLFunction->BoolisAggregatesqlFun=minArgCountsqlFun==1&&not(argCountIsFixedsqlFun)containsAggregates::Expression->BoolcontainsAggregates(FunctionExpressionsqlFunargs)=isAggregatesqlFun||anycontainsAggregatesargscontainsAggregates_=FalseselectionContainsAggregates::ColumnSelection->BoolselectionContainsAggregates(ExpressionColumnexpr_)=containsAggregatesexprselectionContainsAggregates_=FalseorderByItemContainsAggregates::OrderByItem->BoolorderByItemContainsAggregates(OrderByItemexpr_)=containsAggregatesexprselectStatementContainsAggregates::SelectStatement->BoolselectStatementContainsAggregatesselect=anyselectionContainsAggregates(columnSelectionsselect)||anyorderByItemContainsAggregates(orderByItemsselect)expressionIdentifier::Expression->ColumnIdentifierexpressionIdentifier(FunctionExpressionfuncargs)=ColumnIdentifierNothing((prettyFormatWithArgsfunc)args)expressionIdentifier(ColumnExpressioncol)=colexpressionIdentifier(StringConstantExpressionstr)=ColumnIdentifierNothing("\""++str++"\"")expressionIdentifier(IntegerConstantExpressionint)=ColumnIdentifierNothing(showint)expressionIdentifier(RealConstantExpressionreal)=ColumnIdentifierNothing(showreal)needsParens::Expression->BoolneedsParens(FunctionExpression__)=TrueneedsParens_=FalsetoArgString::Expression->StringtoArgStringexpr=letexprFmt=prettyFormatColumn$expressionIdentifierexprinifneedsParensexprthen"("++exprFmt++")"elseexprFmtprettyFormatWithArgs::SQLFunction->[Expression]->StringprettyFormatWithArgssqlFuncfuncArgs|sqlFunc`elem`normalSyntaxFunctions=prettyFormatNormalFunctionExpressionsqlFuncfuncArgs|or(map(sqlFunc`elem`)infixFunctions)=prettyFormatInfixFunctionExpressionsqlFuncfuncArgs|sqlFunc==negateFunction="-"++toArgString(headfuncArgs)|sqlFunc==countFunction=functionNamecountFunction++"(*)"|sqlFunc==substringFromToFunction||sqlFunc==substringFromFunction||sqlFunc==notFunction=prettyFormatNormalFunctionExpressionsqlFuncfuncArgs|otherwise=error$"don't know how to format the given SQL function : "++showsqlFuncprettyFormatInfixFunctionExpression::SQLFunction->[Expression]->StringprettyFormatInfixFunctionExpressionsqlFuncfuncArgs=letarg1=headfuncArgsarg2=funcArgs!!1intoArgStringarg1++functionNamesqlFunc++toArgStringarg2prettyFormatNormalFunctionExpression::SQLFunction->[Expression]->StringprettyFormatNormalFunctionExpressionsqlFuncfuncArgs=letargString=intercalate", "(maptoArgStringfuncArgs)infunctionNamesqlFunc++"("++argString++")"dataSQLFunction=SQLFunction{functionName::String,minArgCount::Int,argCountIsFixed::Bool}deriving(Show,Ord,Eq)dataOrderByItem=OrderByItem{orderExpression::Expression,orderAscending::Bool}deriving(Show,Ord,Eq)-- | Parses a SQL select statementparseSelectStatement::GenParserCharstSelectStatementparseSelectStatement=(try$spaces>>parseToken"SELECT")>>parseSelectBody-- | Parses all of the stuff that comes after "SELECT "parseSelectBody::GenParserCharstSelectStatementparseSelectBody=docolumnVals<-parseColumnSelections-- TODO need a better error message for missing "ON" etc. in-- the from part, can do this by grabing "FROM" firstmaybeFrom<-maybeParseFromPartmaybeWhere<-maybeParseWherePartgroupByExprs<-maybeParseGroupByPartorderBy<-parseOrderByPartreturnSelectStatement{columnSelections=columnVals,maybeFromTable=maybeFrom,maybeWhereFilter=maybeWhere,orderByItems=orderBy,maybeGroupByHaving=groupByExprs}wheremaybeParseFromPart=ifParseThen(parseToken"FROM")parseTableExpressionmaybeParseWherePart=ifParseThen(parseToken"WHERE")parseExpression-- | Parses the "ORDER BY ..." part of a select statement returning the list-- of OrderByItem's that were parsed (this list will be empty if there is no-- "ORDER BY" parsedparseOrderByPart::GenParserCharst[OrderByItem]parseOrderByPart=ifParseThenElse-- if we see an "ORDER BY"(parseToken"ORDER")-- then parse the order expressions(parseToken"BY">>sepByAtLeast1parseOrderByItemcommaSeparator)-- else there is nothing to sort by(return[])whereparseOrderByItem::GenParserCharstOrderByItemparseOrderByItem=doorderExpr<-parseExpressionisAscending<-ifParseThenElse-- if we parse "DESC"(tryparseDescending)-- then return false, it isn't ascending(returnFalse)-- else try to consume "ASC" but even if we don't it's still-- ascending so return true unconditionally((parseAscending<|>return[])>>returnTrue)return$OrderByItemorderExprisAscendingparseAscending=parseToken"ASCENDING"<|>parseToken"ASC"parseDescending=parseToken"DESCENDING"<|>parseToken"DESC"maybeParseGroupByPart::GenParserCharst(Maybe([Expression],MaybeExpression))maybeParseGroupByPart=ifParseThen-- if we see a "GROUP BY"(parseToken"GROUP")-- then parse the expressions(parseToken"BY">>parseGroupBy)whereparseGroupBy=dogroupExprs<-atLeastOneExprmaybeHavingExpr<-ifParseThen(parseToken"HAVING")parseExpressionreturn(groupExprs,maybeHavingExpr)atLeastOneExpr::GenParserCharst[Expression]atLeastOneExpr=sepByAtLeast1parseExpressioncommaSeparator---------------------------------------------------------------------------------- Functions for parsing the column names specified after "SELECT"--------------------------------------------------------------------------------parseColumnSelections::GenParserCharst[ColumnSelection]parseColumnSelections=sepBy1parseAnyColType(trycommaSeparator)whereparseAnyColType=parseAllCols<|>(tryparseAllColsFromTbl)<|>(tryparseColExpression)parseAllCols::GenParserCharstColumnSelectionparseAllCols=parseToken"*">>returnAllColumnsparseAllColsFromTbl::GenParserCharstColumnSelectionparseAllColsFromTbl=dotableVal<-parseIdentifierstring".">>spaces>>parseToken"*"return$AllColumnsFromtableValparseColExpression::GenParserCharstColumnSelectionparseColExpression=doexpr<-parseExpressionmaybeAlias<-maybeParseAliasreturn$ExpressionColumnexprmaybeAliasparseColumnId::GenParserCharstColumnIdentifierparseColumnId=dofirstId<-parseIdentifiermaybeFullyQual<-maybeParse$(char'.'>>spaces)casemaybeFullyQualof-- No '.' means it's a partially qualified columnNothing->return$ColumnIdentifierNothingfirstIdJust_->dosecondId<-parseIdentifierreturn$ColumnIdentifier(JustfirstId)secondId---------------------------------------------------------------------------------- Functions for parsing the table part (after "FROM")--------------------------------------------------------------------------------parseTableExpression::GenParserCharaTableExpressionparseTableExpression=parenthesizeparseTableExpression<|>parseSelectExpression<|>parseTableIdentifierOrJoin<?>"Table Expression"parseSelectExpression::GenParserCharaTableExpressionparseSelectExpression=doselectStmt<-parseSelectStatementmaybeAlias<-maybeParseAliasreturn$SelectExpressionselectStmtmaybeAliasparseTableIdentifierOrJoin::GenParserCharaTableExpressionparseTableIdentifierOrJoin=donextTblId<-parseTableIdentifierletifCrossOrInnerJoinParse=ifParseThenElse-- ifcrossJoinSep-- TODO commit to join-- then(parseCrossJoinRemaindernextTblId)-- elseifInnerJoinParseifInnerJoinParse=ifParseThenElse-- ifinnerJoinSep-- TODO commit to join-- then(parseInnerJoinRemaindernextTblId)-- else(returnnextTblId)ifCrossOrInnerJoinParsewherecrossJoinSep=(commaSeparator>>return"")<|>(parseToken"CROSS">>parseToken"JOIN")innerJoinSep=((maybeParse$parseToken"INNER")>>parseToken"JOIN")parseInnerJoinRemainder::TableExpression->GenParserCharaTableExpressionparseInnerJoinRemainderleftTblExpr=dorightTblExpr<-parseTableExpressionparseToken"ON"onPart<-parseExpressionmaybeAlias<-maybeParseAliasreturnInnerJoin{leftJoinTable=leftTblExpr,rightJoinTable=rightTblExpr,onCondition=onPart,maybeTableAlias=maybeAlias}parseCrossJoinRemainder::TableExpression->GenParserCharaTableExpressionparseCrossJoinRemainderleftTblExpr=dorightTblExpr<-parseTableExpressionmaybeAlias<-maybeParseAliasreturnCrossJoin{leftJoinTable=leftTblExpr,rightJoinTable=rightTblExpr,maybeTableAlias=maybeAlias}parseTableIdentifier::GenParserCharstTableExpressionparseTableIdentifier=dotheId<-parseIdentifiermaybeAlias<-maybeParseAliasreturn$TableIdentifiertheIdmaybeAliasmaybeParseAlias::GenParserCharst(Maybe[Char])maybeParseAlias=ifParseThen(parseToken"AS")parseIdentifier---------------------------------------------------------------------------------- Expression parsing: These can be after "SELECT", "WHERE" or "HAVING"--------------------------------------------------------------------------------parseExpression::GenParserCharstExpressionparseExpression=letopTable=map(mapparseInfixOp)infixFunctionsinbuildExpressionParseropTableparseAnyNonInfixExpression<?>"expression"parseAnyNonInfixExpression::GenParserCharstExpressionparseAnyNonInfixExpression=parenthesizeparseExpression<|>parseStringConstant<|>tryparseRealConstant<|>tryparseIntConstant<|>parseAnyNormalFunction<|>parseNegateFunction<|>parseSubstringFunction<|>parseNotFunction<|>parseCountStar<|>(parseColumnId>>=return.ColumnExpression)parseStringConstant::GenParserCharstExpressionparseStringConstant=(quotedTextTrue'"'<|>quotedTextTrue'\'')>>=(return.StringConstantExpression)parseIntConstant::GenParserCharstExpressionparseIntConstant=parseInt>>=return.IntegerConstantExpressionparseInt::GenParserCharstIntparseInt=eatSpacesAfter.try.(withoutTrailingalphaNum)$dodigitTxt<-anyParseTxtreturn$readdigitTxtwhereanyParseTxt=signedParseTxt<|>unsignedParseTxt<?>"integer"unsignedParseTxt=many1digitsignedParseTxt=dochar'-'unsignedDigitTxt<-unsignedParseTxtreturn$'-':unsignedDigitTxt-- | returns an int if it can be read from the stringmaybeReadInt::String->MaybeIntmaybeReadIntintStr=caseparse(withTrailing(spaces>>eof)(spaces>>parseInt))""intStrofLeft_->NothingRightint->Justint-- | returns a real if it can be read from the stringmaybeReadReal::String->MaybeDoublemaybeReadRealrealStr=caseparse(withTrailing(spaces>>eof)(spaces>>parseReal))""realStrofLeft_->maybeReadIntrealStr>>=(\int->Just$fromIntegralint)Rightreal->JustrealparseRealConstant::GenParserCharstExpressionparseRealConstant=parseReal>>=(\real->return$RealConstantExpressionreal)parseReal::GenParserCharstDoubleparseReal=eatSpacesAfter.try.(withoutTrailingalphaNum)$dorealTxt<-anyParseTxt<?>"real"return$readrealTxtwhereanyParseTxt=dotxtWithoutExp<-txtWithoutExponentexpPart<-tryexponentPart<|>return""return$txtWithoutExp++expPartexponentPart=doe<-(char'e'<|>char'E')negPart<-(char'-'>>return"-")<|>return""numPart<-many1digitreturn$(e:negPart)++numParttxtWithoutExponent=signedTxt<|>unsignedTxt<?>"real"unsignedTxt=dointTxt<-many1digitchar'.'fracTxt<-many1digitreturn$intTxt++"."++fracTxtsignedTxt=dochar'-'unsignedDigitTxt<-unsignedTxtreturn('-':unsignedDigitTxt)parseAnyNormalFunction::GenParserCharstExpressionparseAnyNormalFunction=letallParsers=mapparseNormalFunctionnormalSyntaxFunctionsinchoiceallParsersparseNormalFunction::SQLFunction->GenParserCharstExpressionparseNormalFunctionsqlFunc=try(parseToken$functionNamesqlFunc)>>parseNormalFunctionArgssqlFuncparseNormalFunctionArgs::SQLFunction->GenParserCharstExpressionparseNormalFunctionArgssqlFunc=doargs<-parenthesize$argSepBy(minArgCountsqlFunc)parseExpressioncommaSeparatorreturn$FunctionExpressionsqlFuncargswhereargSepBy=ifargCountIsFixedsqlFuncthensepByExactlyelsesepByAtLeast-- Functions with "normal" syntax --normalSyntaxFunctions::[SQLFunction]normalSyntaxFunctions=[absFunction,upperFunction,lowerFunction,trimFunction,-- all aggregates except count which accepts a (*)avgFunction,firstFunction,lastFunction,maxFunction,minFunction,sumFunction]-- non aggregatesabsFunction::SQLFunctionabsFunction=SQLFunction{functionName="ABS",minArgCount=1,argCountIsFixed=True}upperFunction::SQLFunctionupperFunction=SQLFunction{functionName="UPPER",minArgCount=1,argCountIsFixed=True}lowerFunction::SQLFunctionlowerFunction=SQLFunction{functionName="LOWER",minArgCount=1,argCountIsFixed=True}trimFunction::SQLFunctiontrimFunction=SQLFunction{functionName="TRIM",minArgCount=1,argCountIsFixed=True}-- aggregatesavgFunction::SQLFunctionavgFunction=SQLFunction{functionName="AVG",minArgCount=1,argCountIsFixed=False}countFunction::SQLFunctioncountFunction=SQLFunction{functionName="COUNT",minArgCount=1,argCountIsFixed=False}firstFunction::SQLFunctionfirstFunction=SQLFunction{functionName="FIRST",minArgCount=1,argCountIsFixed=False}lastFunction::SQLFunctionlastFunction=SQLFunction{functionName="LAST",minArgCount=1,argCountIsFixed=False}maxFunction::SQLFunctionmaxFunction=SQLFunction{functionName="MAX",minArgCount=1,argCountIsFixed=False}minFunction::SQLFunctionminFunction=SQLFunction{functionName="MIN",minArgCount=1,argCountIsFixed=False}sumFunction::SQLFunctionsumFunction=SQLFunction{functionName="SUM",minArgCount=1,argCountIsFixed=False}-- Infix functions --infixFunctions::[[SQLFunction]]infixFunctions=[[multiplyFunction,divideFunction],[plusFunction,minusFunction],[concatenateFunction],[isFunction,isNotFunction,lessThanFunction,lessThanOrEqualToFunction,greaterThanFunction,greaterThanOrEqualToFunction,regexMatchFunction],[andFunction],[orFunction]]-- | This function parses the operator part of the infix function and returns-- a function that excepts a left expression and right expression to form-- an Expression from the FunctionExpression constructorparseInfixOp::SQLFunction->OperatorCharstExpressionparseInfixOpinfixFunc=-- use the magic infix type, always assuming left associativityInfixopParserAssocLeftwhereopParser=parseToken(functionNameinfixFunc)>>returnbuildExprbuildExprleftSubExprrightSubExpr=FunctionExpression{sqlFunction=infixFunc,functionArguments=[leftSubExpr,rightSubExpr]}-- AlgebraicmultiplyFunction::SQLFunctionmultiplyFunction=SQLFunction{functionName="*",minArgCount=2,argCountIsFixed=True}divideFunction::SQLFunctiondivideFunction=SQLFunction{functionName="/",minArgCount=2,argCountIsFixed=True}plusFunction::SQLFunctionplusFunction=SQLFunction{functionName="+",minArgCount=2,argCountIsFixed=True}minusFunction::SQLFunctionminusFunction=SQLFunction{functionName="-",minArgCount=2,argCountIsFixed=True}-- BooleanisFunction::SQLFunctionisFunction=SQLFunction{functionName="=",minArgCount=2,argCountIsFixed=True}isNotFunction::SQLFunctionisNotFunction=SQLFunction{functionName="<>",minArgCount=2,argCountIsFixed=True}lessThanFunction::SQLFunctionlessThanFunction=SQLFunction{functionName="<",minArgCount=2,argCountIsFixed=True}lessThanOrEqualToFunction::SQLFunctionlessThanOrEqualToFunction=SQLFunction{functionName="<=",minArgCount=2,argCountIsFixed=True}greaterThanFunction::SQLFunctiongreaterThanFunction=SQLFunction{functionName=">",minArgCount=2,argCountIsFixed=True}greaterThanOrEqualToFunction::SQLFunctiongreaterThanOrEqualToFunction=SQLFunction{functionName=">=",minArgCount=2,argCountIsFixed=True}andFunction::SQLFunctionandFunction=SQLFunction{functionName="AND",minArgCount=2,argCountIsFixed=True}orFunction::SQLFunctionorFunction=SQLFunction{functionName="OR",minArgCount=2,argCountIsFixed=True}concatenateFunction::SQLFunctionconcatenateFunction=SQLFunction{functionName="||",minArgCount=2,argCountIsFixed=True}regexMatchFunction::SQLFunctionregexMatchFunction=SQLFunction{functionName="=~",minArgCount=2,argCountIsFixed=True}-- Functions with special syntax --specialFunctions::[SQLFunction]specialFunctions=[substringFromFunction,substringFromToFunction,negateFunction,notFunction]-- | SUBSTRING(extraction_string FROM starting_position [FOR length]-- [COLLATE collation_name])-- TODO implement COLLATE partsubstringFromFunction::SQLFunctionsubstringFromFunction=SQLFunction{functionName="SUBSTRING",minArgCount=2,argCountIsFixed=True}substringFromToFunction::SQLFunctionsubstringFromToFunction=SQLFunction{functionName="SUBSTRING",minArgCount=3,argCountIsFixed=True}parseSubstringFunction::GenParserCharstExpressionparseSubstringFunction=doparseToken$functionNamesubstringFromFunctioneatSpacesAfter$char'('strExpr<-parseExpressionparseToken"FROM"startExpr<-parseExpressionmaybeLength<-ifParseThen(parseToken"FOR")parseExpressioneatSpacesAfter$char')'return$casemaybeLengthofNothing->FunctionExpressionsubstringFromFunction[strExpr,startExpr]Justlen->FunctionExpressionsubstringFromToFunction[strExpr,startExpr,len]negateFunction::SQLFunctionnegateFunction=SQLFunction{functionName="-",minArgCount=1,argCountIsFixed=True}parseNegateFunction::GenParserCharstExpressionparseNegateFunction=doparseToken"-"expr<-parseAnyNonInfixExpressionreturn$FunctionExpressionnegateFunction[expr]notFunction::SQLFunctionnotFunction=SQLFunction{functionName="NOT",minArgCount=1,argCountIsFixed=True}parseNotFunction::GenParserCharstExpressionparseNotFunction=doparseToken$functionNamenotFunctionexpr<-parseAnyNonInfixExpressionreturn$FunctionExpressionnotFunction[expr]parseCountStar::GenParserCharstExpressionparseCountStar=dotry(parseToken$functionNamecountFunction)tryparseStar<|>parseNormalFunctionArgscountFunctionwhereparseStar=doparenthesize$parseToken"*"return$FunctionExpressioncountFunction[IntegerConstantExpression0]---------------------------------------------------------------------------------- Parse utility functions--------------------------------------------------------------------------------parseOpChar::CharParserstCharparseOpChar=oneOfopCharsopChars::[Char]opChars="~!@#$%^&*-+=|\\<>/?"withoutTrailing::(Shows)=>GenParsertoksts->GenParsertoksta->GenParsertokstawithoutTrailingendp=p>>=(\x->genNotFollowedByend>>returnx)withTrailing::(Monadm)=>ma->mb->mbwithTrailingendp=p>>=(\x->end>>returnx)-- | like the lexeme function, this function eats all spaces after the given-- parser, but this one works for me and lexeme doesn'teatSpacesAfter::GenParserCharsta->GenParserCharstaeatSpacesAfterp=p>>=(\x->spaces>>returnx)-- | find out if the given string ends with an op charendsWithOp::String->BoolendsWithOpstrToTest=laststrToTest`elem`opChars-- | A token parser that allows either upper or lower case. all trailing-- whitespace is consumedparseToken::String->GenParserCharstStringparseTokentokStr=eatSpacesAfter(try$ifendsWithOptokStrthenparseOpTokelseparseAlphaNumTok)whereparseOpTok=withoutTrailingparseOpChar(stringtokStr)parseAlphaNumTok=withoutTrailing(alphaNum<|>char'_')(upperOrLowertokStr)-- | parses an identifier. you can use a tick '`' as a quote for-- an identifier with white-spaceparseIdentifier::GenParserCharstStringparseIdentifier=doletparseId=doletidChar=alphaNum<|>char'_'notFollowedBydigitquotedTextFalse'`'<|>many1idChar((eatSpacesAfterparseId)`genExcept`parseReservedWord)<?>"identifier"-- | quoted text which allows escaping by doubling the quote char-- like "escaped quote char here:"""quotedText::Bool->Char->GenParserCharstStringquotedTextallowEmptyquoteChar=doletquote=charquoteCharmanyFunc=ifallowEmptythenmanyelsemany1quotetextValue<-manyFunc$(anyChar`genExcept`quote)<|>try(escapedQuotequoteChar)quotespacesreturntextValueescapedQuote::Char->GenParserCharstCharescapedQuotequoteChar=string[quoteChar,quoteChar]>>returnquoteCharcommaSeparator::GenParserCharstCharcommaSeparator=eatSpacesAfter$char','-- | Wraps parentheses parsers around the given inner parserparenthesize::GenParserCharsta->GenParserCharstaparenthesizeinnerParser=doeatSpacesAfter$char'('innerParseResults<-innerParsereatSpacesAfter$char')'returninnerParseResults{-
-- | Either parses the left or right parser returning the result of the
-- successful parser
eitherParse :: GenParser tok st a -> GenParser tok st b -> GenParser tok st (Either a b)
eitherParse leftParser rightParser =
(try leftParser >>= return . Left) <|> (rightParser >>= return . Right)
-}-- | if the ifParse parser succeeds return the result of thenParse, else-- return Nothing without parsing any inputifParseThen::GenParsertoksta->GenParsertokstb->GenParsertokst(Maybeb)ifParseThenifParsethenPart=doifResult<-maybeParseifParsecaseifResultofJust_->thenPart>>=return.JustNothing->returnNothing-- | if ifParse succeeds then parse thenPart otherwise parse elsePartifParseThenElse::GenParsertoksta->GenParsertokstb->GenParsertokstb->GenParsertokstbifParseThenElseifParsethenPartelsePart=doifResult<-maybeParseifParsecaseifResultofJust_->thenPartNothing->elsePartparseReservedWord::GenParserCharstStringparseReservedWord=letreservedWordParsers=mapparseTokenreservedWordsinchoicereservedWordParsers-- TODO are function names reserved... i don't think soreservedWords::[String]reservedWords=mapfunctionNamenormalSyntaxFunctions++mapfunctionName(concatinfixFunctions)++mapfunctionNamespecialFunctions++["BY","CROSS","FROM","FOR","GROUP","HAVING","INNER","JOIN","ON","ORDER","SELECT","WHERE"]-- | tries parsing both the upper and lower case versions of the given stringupperOrLower::String->GenParserCharstStringupperOrLowerstringToParse=string(maptoUpperstringToParse)<|>string(maptoLowerstringToParse)<?>stringToParse-- | accepst the same input as the given parser except and input that matches-- theException parsergenExcept::(Showb)=>GenParsertoksta->GenParsertokstb->GenParsertokstagenExceptparsertheException=dogenNotFollowedBytheExceptionparser-- | a generic version of the notFollowedBy library function. We require-- Show types so that we can better report failuresgenNotFollowedBy::(Showa)=>GenParsertoksta->GenParsertokst()genNotFollowedBytheParser=try$domayParseResult<-maybeParsetheParsercasemayParseResultofNothing->return()Justx->unexpected$showx-- | returns Just parseResult if the parse succeeds and Nothing if it failsmaybeParse::GenParsertoksta->GenParsertokst(Maybea)maybeParseparser=(tryparser>>=return.Just)<|>returnNothing-- | parse `itemParser`s seperated by exactly `minCount` `sepParser`ssepByExactly::Int->GenParsertoksta->GenParsertokstsep->GenParsertokst[a]sepByExactlyitemCountitemParsersepParser=letitemParsers=replicateitemCountitemParserinparseEachitemParserswhere-- for an empty parser list return an empty resultparseEach[]=return[]-- for a parser list of 1 we don't want to use a separatorparseEach[lastParser]=lastParser>>=(\x->return[x])-- for lists greater than 1 we do need to care about the separatorparseEach(headParser:parserTail)=doresultHead<-headParsersepParserresultTail<-parseEachparserTailreturn$resultHead:resultTail-- | parse `itemParser`s seperated by at least `minCount` `sepParser`ssepByAtLeast::Int->GenParsertoksta->GenParsertokstsep->GenParsertokst[a]sepByAtLeastminCountitemParsersepParser=dominResults<-sepByExactlyminCountitemParsersepParsertailResults<-ifParseThenElsesepParser(sepByitemParsersepParser)(return[])return$minResults++tailResults