Minimalistic Parser Combinators in F#

pc.fs

// Minimalistic Parser Combinator in F#
//  Neither Performance nor Error Reporting has been considered
//  For production code you are better off using http://www.quanttec.com/fparsec/
//  Inspired by the classic: http://www.cs.nott.ac.uk/~pszgmh/monparsing.pdf
[<Measure>]
type ParserPos
type ParserResult<'T> = 'T option*int<ParserPos>
type Parser<'T>       = string*int<ParserPos> -> ParserResult<'T>

module Parser =
  let inline Success v i : ParserResult<'T> = Some v, i
  let inline Failure i   : ParserResult<'T> = None, i

  let inline (|MatchSuccess|MatchFailure|) (r : ParserResult<'T>) =
    match r with
    | None, i   -> MatchFailure i
    | Some v, i -> MatchSuccess (v, i)

  // Fundamental Parsers

  let Bind (t : Parser<'T>) (uf : 'T -> Parser<'U>) : Parser<'U> =
    fun (s, i) ->
      match t (s, i) with
      | MatchFailure ii -> Failure ii
      | MatchSuccess (vv, ii) -> uf vv (s, ii)
  let inline (>>=) t uf = Bind t uf

  let Literal ch : Parser<unit> =
    fun (s, i) ->
      if int i < s.Length && ch = s.[int i] then Success () (i + 1<ParserPos>)
      else Failure i

  let EOS : Parser<unit> =
    fun (s, i) ->
      if int i < s.Length then Failure i
      else Success () i

  let Fail : Parser<'T> =
    fun (s, i) ->
      Failure i

  let Opt (t : Parser<'T>) : Parser<'T option> =
    fun (s, i) ->
      match t (s, i) with
      | MatchFailure _ -> Success None i
      | MatchSuccess (vv, ii) -> Success (Some vv) ii

  let Return v : Parser<'T> =
    fun (s, i) ->
      Success v i

  let Satisfy f : Parser<char> =
    fun (s, i) ->
      if int i < s.Length && f s.[int i] then Success s.[int i] (i + 1<ParserPos>)
      else Failure i

  // Parser Forwarders

  let Forwarder<'T> () : Parser<'T>*(Parser<'T> -> unit) =
    let rp        = ref Fail
    let p (s, i)  = !rp (s, i)
    let sp p      = rp := p
    p, sp

  // Parser Debuggers

  let Trace name t : Parser<'T> =
    fun (s, i) ->
      printfn "Before %s" name
      match t (s, i) with
      | MatchFailure ii ->
        printfn "Failed %s@%d" name ii
        Failure ii
      | MatchSuccess (vv, ii) ->
        printfn "Success %s@%d = %A" name ii vv
        Success vv ii

  // Parser Modifiers

  let Map m t : Parser<'U> = t >>= fun v -> Return (m v)
  let inline (|>>) p m = Map m p
  let inline (>>!) p v = p |>> (fun _ -> v)

  let Pair t u : Parser<'T*'U> = t >>= fun tv -> u >>= fun uv -> Return (tv, uv)
  let inline (.>>.) t u = Pair t u

  let inline KeepLeft t u : Parser<'T> = Pair t u |>> fst
  let inline (.>>) t u = KeepLeft t u

  let inline KeepRight t u : Parser<'U> = Pair t u |>> snd
  let inline (>>.) t u = KeepRight t u

  let Between b t e : Parser<'T> = b >>. t .>> e

  let Many t : Parser<'T list> =
    let ot = Opt t
    let rec loop pvs = ot >>= function Some pv -> loop (pv::pvs) | _ -> Return (pvs |> List.rev)
    loop []

  let Many1 t : Parser<'T list> = Many t >>= function [] -> Fail | vs -> Return vs

  let SepBy term op : Parser<'T> =
    let oop = Opt op
    let rec loop v = oop >>= function Some f -> (term >>= fun vv -> loop (f v vv)) | _ -> Return v
    term >>= loop

  let OrElse t u : Parser<'T> =
    let ot = Opt t
    ot >>= function Some tv -> Return tv | _ -> u
  let inline (<|>) t u = OrElse t u

  // Char Parsers

  let Digit         : Parser<char> = Satisfy System.Char.IsDigit
  let Letter        : Parser<char> = Satisfy System.Char.IsLetter
  let LetterOrDigit : Parser<char> = Satisfy System.Char.IsLetterOrDigit
  let WhiteSpace    : Parser<char> = Satisfy System.Char.IsWhiteSpace

  // String Parsers

  let ManyChar p    : Parser<string> = Many p |>> (List.toArray >> System.String)
  let ManyChar2 f r : Parser<string> = f >>= fun ch -> Many r |>> fun rest -> ch::rest |> List.toArray |> System.String
  let ManyChar1 f   : Parser<string> = ManyChar2 f f

  // Parse

  let Parse (t : Parser<'T>) (s : string) : 'T option*int =
    match t (s, 0<ParserPos>) with
    | MatchFailure ii      -> None, int ii
    | MatchSuccess (v, ii) -> Some v, int ii

module ExpressionParser =
  type Operator =
    | Add
    | Divide
    | Multiply
    | Subtract
  type Expression =
    | Value     of int
    | Variable  of string
    | Binary    of Expression*Operator*Expression

  module Details =
    open Parser
    let FullExpr =
      let binary op l r   = Binary (l, op, r)
      let add             = binary Add
      let subtract        = binary Subtract
      let multiply        = binary Multiply
      let divide          = binary Divide

      let expr, setExpr   = Forwarder<Expression> ()
      
      let whitespace      = Many WhiteSpace
      let token ch        = Literal ch .>> whitespace
      let subexpr         = Between (token '(') expr (token ')')
      let int             = ManyChar1 Digit |>> (System.Int32.Parse >> Value)
      let variable        = ManyChar2 Letter LetterOrDigit |>> Variable
      let term            = (subexpr <|> int <|> variable) .>> whitespace
      let op ch f         = token ch >>! f
      let opMultiplyLike  = SepBy term (op '*' multiply <|> op '/' divide)
      let opAddLike       = SepBy opMultiplyLike (op '+' add <|> op '-' subtract)

      setExpr opAddLike

      expr .>> EOS

  let Parse s = Parser.Parse Details.FullExpr s

  let AsString e =
    let sb = System.Text.StringBuilder ()
    let rec loop e =
      match e with
      | Value v           -> sb.Append v |> ignore
      | Variable v        -> sb.Append v |> ignore
      | Binary (l,op, r)  ->
        sb.Append '(' |> ignore
        loop l
        let ch =
          match op with
          | Add       -> '+'
          | Divide    -> '/'
          | Multiply  -> '*'
          | Subtract  -> '-'
        sb.Append ch |> ignore
        loop r
        sb.Append ')' |> ignore
    loop e
    sb.ToString ()

[<EntryPoint>]
let main argv =
  let input = "12*x + 4*y + z*(x + z)"
  let expr  = ExpressionParser.Parse input
  let str   =
    match expr with
    | Some e, _ -> ExpressionParser.AsString e
    | _, p      -> sprintf "Parsing failed@%d" p
  printfn "Input    : %s" input
  printfn "Expr     : %A" expr
  printfn "AsString : %s" str
  0