parser.fs

module Parser

open System
open System.Text

type Parser< 'T >(func : string -> Option<'T * string> ) = 
    member this.eval = func 

(* Conditional parse *)
let (<?>) (par : Parser< 'T >) (pred : 'T -> bool) = Parser( fun x ->
    match par.eval(x) with
    | None -> None
    | Some(res, rest) -> if pred(res) then Some(res, rest) else None )

(* Compositional parse *)
let (<*>) (m : Parser< 'T >) (n : Parser< 'D >) : Parser<'T*'D> = Parser( fun x ->
    match m.eval(x) with
    | None -> None
    | Some(p, x') -> match n.eval(x') with
        | None -> None
        | Some(q, x'') -> Some((p,q), x'') )

(* Forgetting left *)
let ( *> ) (m : Parser< 'T >) (n : Parser< 'D >) : Parser<'D> = Parser( fun x ->
    match m.eval(x) with
    | None -> None
    | Some(p, x') -> match n.eval(x') with
        | None -> None
        | Some(q, x'') -> Some(q, x'') )

(* Forgetting right *)
let ( <* ) (m : Parser< 'T >) (n: Parser< 'D >) : Parser<'T> = Parser( fun x ->
    match m.eval(x) with
    | None -> None
    | Some(p, x') -> match n.eval(x') with
        | None -> None
        | Some(q, x'') -> Some(p,x'') )

(* Processing *)
let ( >>> ) (m : Parser< 'T >) (n: 'T -> 'D) : Parser< 'D > = Parser( fun x ->
    match m.eval(x) with
    | None -> None
    | Some(p, x') -> Some(n(p), x') )

(* Or *)
let (<|>) (m: Parser< 'T >) (n: Parser< 'T >) : Parser< 'T > = Parser( fun x ->
    match m.eval(x) with
    | Some(p,x') -> Some(p,x')
    | None -> match n.eval(x) with
        | None -> None
        | Some(q,x'') -> Some(q,x'') )

(* Return and Fail parsers *)
let pReturn (a: 'T) : Parser< 'T > = Parser( fun x -> Some(a, x) )
let pFail< 'T > : Parser< 'T > = Parser( fun x -> None )

(* cons a list *)
let cons (m: 'T * 'T list) : 'T list = 
    match m with
    | hd, tl -> hd::tl

(* concat chars from char list into a string *)
let ConcatChar (m: char list) : string = 
    (List.fold (fun (st : StringBuilder) (t : char) -> st.Append(t)) (new StringBuilder()) m).ToString()

(* Parser that accepts one character *)
let Character : Parser< char > = Parser( fun x ->
    match x with
    | "" -> None
    | (some : string) -> Some(some.[0], some.Substring(1)) )

(* Specialized characters *)
let Letter : Parser< char > = Character <?> Char.IsLetter
let Digit : Parser< char > = Character <?> Char.IsDigit
let Space : Parser< char > = Character <?> Char.IsWhiteSpace

(* Accepts chars according to supplied parser 1 or more times *)
let Many (m : Parser< 'T >) : Parser< 'T list > = Parser( fun x ->
    let rec until (input : string) (accum: 'T list) : 'T list * string = 
        match m.eval(input) with
        | None -> List.rev accum, input
        | Some(p,x') -> until x' (p::accum)
    match (until x ([] : 'T list)) with
    | [], _ -> None
    | lst, inp -> Some(lst, inp) )

(* Always accepts given string, returning empty list if impossible to accept *)
let Any (m : Parser< 'T >) : Parser< 'T list > = Many m <|> pReturn ([] : 'T list)

(* Uses given parser exact number of times *)
let Exact (n: int) (m: Parser< 'T >) : Parser< 'T list > = Parser( fun x ->
    let rec forN (input : string) (accum : 'T list) (nLeft : int) : 'T list * string =
        match nLeft with
        | 0 -> List.rev accum, input
        | y when y > 0 -> match m.eval(input) with
            | None -> [],input
            | Some(p, x') -> forN x' (p::accum) (nLeft - 1)
        | _ -> failwith "bad counter value in forN"
    match (forN x ([] : 'T list) n) with
    | [],_ -> None
    | lst, inp -> Some(lst, inp) )

(* Accepts given string *)
let Accept (t: string) : Parser< string > = ((Exact (t.Length) Character) >>> ConcatChar) <?> (fun x -> x = t)

(* Accepts a given char. Aux func for AnyOf parser *)
let AcceptChar (c: char) : Parser< char > = Character <?> (fun x -> x = c)

(* Accepts any char from given string *)
let AnyOf (t: string) : Parser< char > = Array.reduce (<|>) <| Array.map (fun (x: char) -> AcceptChar x) (t.ToCharArray())

(* Accepts given parser any number of times, followed by whitespaces (whitespaces are consumed, but never returned) *)
let Token (p: Parser< 'T >) : Parser< 'T list > = (Many p) <* (Any Space)