Expression parsing with monads

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22: 
23: 
24: 
25: 
26: 
27: 
28: 
29: 
30: 
31: 
32: 
33: 
34: 
35: 
36: 
37: 
38: 
39: 
40: 
41: 
42: 
43: 
44: 
45: 
46: 
47: 
48: 
49: 
50: 
51: 

(Parser Monad omitted. Code available here: https://bitbucket.org/ZachBray/parsad)

let number() = parser {
   let! n = "[0-9]+"
   return Int32.Parse n
}

let (<+>) x y () = parser {
   // Left associativity is by default for infix operators
   let! x, _, y = x, "\+", y
   return x + y
}

let (<->) x y () = parser {
   let! x, _, y = x, "\-", y
   return x - y
}

let (<*>) x y () = parser {
   let! x, _, y = x, "\*", y
   return x * y
}

let (</>) x y () = parser {
   let! x, _, y = x, "/",y
   return x / y
}

let bracketed (f:unit -> 'a Parser) () = parser{
   let! _ = "\("
   let! x = f
   let! _ = "\)"
   return x
}

let rec expression() = 
   parser {
      // Tries possible parsing steps in order
      // I.e., in reverse order of precedence
      return! [
         expression <+> expression
         expression <-> expression
         expression <*> expression
         expression </> expression
         bracketed expression
         number
      ]
   }

// Example
printfn "%A" (expression().Parse "(10 + (2 * 10 * 2))/5 - 14")

open System.Text.RegularExpressions
open System

type text = string
type error = string

[<AutoOpen>]
module String =
   let isEmpty(str:string) =
      str.Trim().Length = 0

   let (|Empty|_|) str =
      if isEmpty str then Some()
      else None

type 'a Parser =
   | Parser of (text -> error ref -> ('a * text) option)
   member x.Evaluate(text, error) =
      let (Parser f) = x
      f text error
   member x.Parse text =
      let error = ref ""
      match x.Evaluate(text, error) with
      | Some (y, Empty) -> y
      | Some _ | None ->
         failwith !error

type ParserBuilder() =
   let parse patterns text =
      let pattern =
         patterns |> Seq.map (sprintf "(%s)")
         |> String.concat ""
      let regex = Regex (sprintf "^\s*%s" pattern)
      let matchAttempt = regex.Match text
      let groups =
         [ for group in matchAttempt.Groups -> group.Value ]
      match groups with
      | [] -> []
      | x::xs -> xs

   let parsePattern pattern (f:string -> 'a Parser) text error =
      match text |> parse [pattern; ".*"] with
      | [value; rest] ->
         let g = f value
         g.Evaluate(rest, error)
      | _ ->
         error := sprintf "Expected '%s' but found '%s'" pattern text
         None
         
   let parseInfix (left:unit -> 'a Parser) op (right:unit -> 'b Parser) (f:('a*string*'b) -> 'c Parser) text error =
      match text |> parse [".*"; op; ".*"] with
      | [x; op; y] ->
         match left().Evaluate(x, error) with
         | Some(x, Empty) ->
            match right().Evaluate(y, error) with
            | Some(y, rest) ->
               f(x, op, y).Evaluate(rest, error)
            | None ->
               error := sprintf "Expected expression but found '%s'" y
               None
         | Some _ | None ->
            error := sprintf "Expected expression but found '%s'" x
            None
      | _ ->
         error := sprintf "Expected '<x> %s <y>' but found '%s'" op text
         None

   let parseAny (parsers:(unit -> 'a Parser) list) (f: 'a -> 'b Parser) text error =
      parsers |> Seq.tryPick (fun parser ->
         match parser().Evaluate(text, error) with
         | Some(x, rest) ->
            let g = f x
            g.Evaluate(rest, error)
         | None -> None
      )

   member b.Bind (parsers, f) =
      Parser(parseAny parsers f)
   member b.Bind ((left, op, right), f) =
      Parser(parseInfix left op right f)
   member b.Bind (parser, f) =
      b.Bind([parser], f)
   member b.Bind (pattern:string, f) =
      Parser(parsePattern pattern f)
   member b.Return x =
      Parser(fun text error -> Some(x, text))
   member b.ReturnFrom(parsers:_ list) =
      b.Bind(parsers, b.Return)

let parser = ParserBuilder()

val number : unit -> int Parser

Full name: Script.number

val parser : ParserBuilder

Full name: Script.parser

val n : string

type Int32 =
  struct
    member CompareTo : value:obj -> int + 1 overload
    member Equals : obj:obj -> bool + 1 overload
    member GetHashCode : unit -> int
    member GetTypeCode : unit -> TypeCode
    member ToString : unit -> string + 3 overloads
    static val MaxValue : int
    static val MinValue : int
    static member Parse : s:string -> int + 3 overloads
    static member TryParse : s:string * result:int -> bool + 1 overload
  end

Full name: System.Int32

Int32.Parse(s: string) : int
Int32.Parse(s: string, provider: IFormatProvider) : int
Int32.Parse(s: string, style: Globalization.NumberStyles) : int
Int32.Parse(s: string, style: Globalization.NumberStyles, provider: IFormatProvider) : int

val x : (unit -> int Parser)

val y : (unit -> int Parser)

val x : int

val y : int

val bracketed : f:(unit -> 'a Parser) -> unit -> 'a Parser

Full name: Script.bracketed

val f : (unit -> 'a Parser)

type unit = Unit

Full name: Microsoft.FSharp.Core.unit

Multiple items
union case Parser.Parser: (text -> error ref -> ('a * text) option) -> 'a Parser

--------------------
type 'a Parser =
  | Parser of (text -> error ref -> ('a * text) option)
  member Evaluate : text:text * error:error ref -> ('a * text) option
  member Parse : text:text -> 'a

Full name: Script.Parser<_>

val x : 'a

val expression : unit -> int Parser

Full name: Script.expression

val printfn : format:Printf.TextWriterFormat<'T> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.printfn