Parse t-sql boolean expression (CHECK Constraint)

.fsx

#if INTERACTIVE
#r "nuget: FParsec"
#endif
open FParsec
open System

type TSqlValue =
    | IntValue of int
    | StringValue of string
    | BoolValue of bool
    | NullValue
    | ColumnRef of string 
    | FuncRef of string*TSqlValue list

type ComparisonOp = Eq | Neq | Gt | Lt | Gte | Lte
type LogicalOp = And | Or

type BooleanExpr =
    | Compare of ComparisonOp * TSqlValue * TSqlValue
    | Logical of LogicalOp * BooleanExpr * BooleanExpr
    | UnaryNot of BooleanExpr
    | Paren of BooleanExpr 

type Parser<'t> = Parser<'t, unit>
let keyword s = pstringCI s .>> spaces

let identCharFirst = (many1Satisfy (fun c -> Char.IsLetterOrDigit c || c = '_')) 
let identCharRest = (manySatisfy (fun c -> Char.IsLetterOrDigit c || c = '_'))
let identifier = ((identCharFirst .>>. identCharRest) |>> (fun (a,b) -> a+b))

let columnReference : Parser<TSqlValue> =
    let contained = (pstringCI "[" >>. manyTill anyChar (pstringCI "]")) |>> (fun x -> System.String(x |> List.toArray))
    (contained <|> identifier)
    |>> (fun (t) -> ColumnRef(t))
    .>> spaces

let stringLiteral : Parser<TSqlValue> =
    let quote = pstring "'"
    (quote >>. manyTill (satisfy (fun c -> c <> '\'')) quote)
    |>> (fun c -> c |> List.toArray |> String)
    |>> StringValue
    .>> spaces

let intLiteral : Parser<TSqlValue> = pint32 |>> IntValue .>> spaces
let nullLiteral : Parser<TSqlValue> = keyword "NULL" |>> fun _ -> NullValue
let boolLiteral : Parser<TSqlValue> =
    (keyword "TRUE" >>% BoolValue true) <|> (keyword "FALSE" >>% BoolValue false)

let value,valueRef = createParserForwardedToRef ()
let funcReference : Parser<TSqlValue> =
    let args = sepBy value (pchar ',')
    let pFn = identifier .>> spaces .>> pchar '(' .>> spaces .>>. args .>>. spaces .>> pchar ')' .>> spaces
    pFn |>> (fun ((a,b), _) -> FuncRef (a,b)) |> attempt

let v : Parser<TSqlValue> = choice [
    nullLiteral
    boolLiteral
    stringLiteral
    intLiteral
    funcReference
    columnReference
]
valueRef.Value <- v

let opEq  = pstring "="  >>% Eq
let opNeq = pstring "<>" >>% Neq <|> (pstring "!=" >>% Neq)
let opGte = pstring ">=" >>% Gte
let opLte = pstring "<=" >>% Lte
let opGt  = pstring ">"  >>% Gt
let opLt  = pstring "<"  >>% Lt

let comparisonOp = choice [opGte; opLte; opNeq; opEq; opGt; opLt] .>> spaces
let expression,exprRef = createParserForwardedToRef<BooleanExpr, unit>()

let rec basicPredicate : Parser<BooleanExpr> =
    let pParen = between (pstring "(" .>> spaces) (pstring ")" .>> spaces) (expression .>> spaces) |>> Paren

    let pComparison : Parser<BooleanExpr> =
        value
        .>>. comparisonOp
        .>>. value
        |>> (fun ((v1, op), v2) -> Compare(op, v1, v2))

    let pIsNull : Parser<BooleanExpr> =
        let isNotNull = (keyword "IS NOT NULL" |>> fun _ -> Neq)
        let isNull = (keyword "IS NULL"  |>> fun _ -> Eq) 
        let value = value .>> spaces .>>. (isNull <|> isNotNull)
        
        attempt (value |>> (fun (value,op) -> Compare(op, value, NullValue)))

    choice [pIsNull; pComparison; pParen]

let pNot : Parser<BooleanExpr> =
    let pNotExpr = keyword "NOT" >>. expression |>> UnaryNot
    pNotExpr <|> basicPredicate

let pAnd : Parser<BooleanExpr> =
    let pAndOp = keyword "AND" >>% LogicalOp.And
    chainl1 pNot (pAndOp |>> fun op l r -> Logical(op, l, r))

let pOr : Parser<BooleanExpr> =
    let pOrOp = keyword "OR" >>% LogicalOp.Or
    chainl1 pAnd (pOrOp |>> fun op l r -> Logical(op, l, r))

exprRef := pOr

let parseTSqlBooleanExpression (input: string) =
    match run expression input with
    | Success(result, _, _) ->
        printfn "Successfully parsed T-SQL expression:"
        let rec printExpr indent expr =
            let newIndent = indent + "  "
            match expr with
            | Paren e ->
                printfn "%sParen (" indent
                printExpr newIndent e
                printfn "%s)" indent
            | Compare (op, v1, v2) ->
                let opStr =
                    match op with Eq -> "=" | Neq -> "<>" | Gt -> ">" | Lt -> "<" | Gte -> ">=" | Lte -> "<="
                let valueStr v =
                    match v with
                    | IntValue i -> sprintf "INT(%d)" i
                    | StringValue s -> sprintf "STRING('%s')" s
                    | BoolValue b -> sprintf "BOOL(%b)" b
                    | NullValue -> "NULL"
                    | ColumnRef c -> sprintf "COL('%s')" c
                    | FuncRef (fn, args) -> sprintf "CALL '%s' (...) " fn

                printfn "%sCompare (%s, %s, %s)" indent opStr (valueStr v1) (valueStr v2)
            | Logical (op, l, r) ->
                let opStr = match op with And -> "AND" | Or -> "OR"
                printfn "%sLogical (%s:" indent opStr
                printExpr newIndent l
                printExpr newIndent r
                printfn "%s)" indent
            | UnaryNot e ->
                printfn "%sUnaryNot (NOT:" indent
                printExpr newIndent e
                printfn "%s)" indent

        printExpr "" result

    | Failure(errorMsg, _, _) ->
        printfn "Parsing Failed:\n%s" errorMsg

let tsqlExpression1 = "NOT (Price > 1000 AND Category = 'Electronics') OR IsActive = TRUE"
let tsqlExpression2 = "[Order_ID] <= 500 AND FieldB IS NOT NULL"
let tsqlExpression3 = "Age >= 18"
let tsqlExpression4 = "CustomerName <> 'John Doe'"
let tsqlExpression5 = "Len(Name) < 10"

parseTSqlBooleanExpression tsqlExpression1
parseTSqlBooleanExpression tsqlExpression2
parseTSqlBooleanExpression tsqlExpression3
parseTSqlBooleanExpression tsqlExpression4
parseTSqlBooleanExpression tsqlExpression5