SQL Search Condition Parser

gistfile1.fs

  module SqlAst =

    open System

    type BinaryOp =
      | Add
      | Sub
      | Mul
      | Div
      | Mod
      | BitAnd
      | BitOr
      | BitXor

    type UnaryOp =
      | Neg
      | BitNot
    
    type Comparison =
      | Eq
      | Ne

    type Constant =
      | Int32 of int
      | Float of float
      | DateTime of DateTime
      | Bool of bool
      | String of string
      | Null
      
    type ScalarExpr =
      | Identifier of string list
      | Constant of Constant
      | Binary of BinaryOp * ScalarExpr * ScalarExpr
      | Unary of UnaryOp * ScalarExpr

    type SearchCondition =
      | Comparison of Comparison * ScalarExpr * ScalarExpr
      | Or of SearchCondition * SearchCondition
      | And of SearchCondition * SearchCondition

  module (*private*) SqlParserImpl =

    open FParsec
    open FParsec.Primitives
    open FParsec.CharParsers
    open SqlAst

    type Assoc = Associativity

    let ws = spaces

    let nameStartChar = pchar '_' <|> asciiLetter
    let nameChar = nameStartChar <|> digit
    let name = many1Chars2 nameStartChar nameChar
    let id = sepBy1 name (pstring ".") .>> ws |>> Identifier
    let trueLiteral = stringCIReturn "true" (Bool true) .>> ws
    let falseLiteral = stringCIReturn "false" (Bool false) .>> ws
    let boolLiteral = (trueLiteral <|> falseLiteral)
    let nullLiteral = stringCIReturn "null" Null .>> ws
    let quoteChar = pstring "'"
    let pChar = satisfy ((<>) '\'')
    let stringLiteral = (quoteChar >>. (manyCharsTill pChar quoteChar)) |>> String .>> ws
    let floatLiteral = pfloat |>> Float .>> ws
    let int32Literal = pint32 |>> Int32 .>> ws
    let constant = 
      [ boolLiteral; nullLiteral; int32Literal; floatLiteral; stringLiteral ]
      |> choice
      |>> Constant
    let strOrSymOp str sym x = ((stringCIReturn str x) <|> (stringCIReturn sym x)) .>> ws
    let eqOp = strOrSymOp "eq" "=" Eq
    let neOp = strOrSymOp "ne" "<>" Ne
    let compareOp = [ eqOp; neOp ] |> choice
    let lparen = pstring "(" >>. ws
    let rparen = pstring ")" >>. ws
    let opp = OperatorPrecedenceParser<_,_,_>()
    let scalarExpr = opp.ExpressionParser
    opp.TermParser <- constant <|> id <|> between lparen rparen scalarExpr <|> scalarExpr
    let addInfixOp (str, prec, op) = opp.AddOperator(InfixOperator(str, ws, prec, Assoc.Left, fun l r -> Binary(op, l, r)))
    let addPrefixOp (str, prec, op) = opp.AddOperator(PrefixOperator(str, ws, prec, false, fun x -> Unary(op, x)))
    [ "|", 1, BitOr
      "^", 2, BitXor
      "&", 3, BitAnd
      "+", 4, Add
      "-", 4, Sub
      "*", 5, Mul
      "/", 5, Div
      "%", 5, Mod ]
    |> List.iter addInfixOp
    [ "-", 6, Neg
      "~", 6, BitNot ]
    |> List.iter addPrefixOp
    let comparison = 
      let compareExpr = pipe3 scalarExpr compareOp scalarExpr (fun l op r -> Comparison(op, l, r))
      between lparen rparen compareExpr <|> compareExpr
    let andTerm = pstringCI "and" .>> ws
    let orTerm = pstringCI "or" .>> ws
    let searchCondition, searchConditionRef = createParserForwardedToRef()
    searchConditionRef := 
      [ comparison 
        pipe3 searchCondition andTerm searchCondition (fun l _ r -> And(l, r))
        pipe3 searchCondition orTerm searchCondition (fun l _ r -> Or(l, r))
        between lparen rparen searchCondition ]
      |> choice
    let filter : Parser<_,unit> = ws >>. searchCondition .>> eof