// Code from Hansen and Rischel: Functional Programming using F# 16/12 2012 // Chapter 12: Computation Expressions. Just from the sections 12.10 // Section 12.10 Monadic Parsers // ============================= open System.Text.RegularExpressions ;; // parser type // ----------- type parser<'a> = string -> int -> ('a * int) list;; // Token parsers // ------------- // from text processing library: let captureSingle (ma:Match) (n:int) = ma.Groups.[n].Captures.[0].Value ;; let token (reg: Regex) (conv: string -> 'a) : parser<'a> = fun str pos -> let ma = reg.Match(str,pos) match ma.Success with | false -> [] | _ -> let pos2 = pos + ma.Length [( conv(captureSingle ma 1), pos2)];; let emptyToken (reg: Regex) : parser = fun str pos -> let ma = reg.Match(str,pos) match ma.Success with | false -> [] | _ -> let pos2 = pos + ma.Length [( (), pos2)];; // Computation expression and builder object // ----------------------------------------- type ParserClass() = member t.Bind(p: parser<'a>, f: 'a->parser<'b>):parser<'b> = fun str pos -> List.collect (fun (a,apos) -> f a str apos) (p str pos) member bld.Zero() = (fun _ _ -> []): parser<'a> member bld.Return a = (fun str pos -> [(a,pos)]): parser<'a> member bld.ReturnFrom (p: parser<'a>) = p;; let parser = ParserClass();; // Sequencing of parsers // --------------------- let pairOf p1 p2 = parser {let! x1 = p1 let! x2 = p2 return (x1,x2)};; // Choice combinator // ----------------- let (<|>) (p1: parser<'a>) (p2: parser<'a>) = (fun str pos -> (p1 str pos) @ (p2 str pos)): parser<'a>;; // Combinators for repetitive constructs // ------------------------------------- let rec listOf p = parser {return []} <|> parser {let! x = p let! xs = listOf p return x::xs};; let rec infixL op q = fun p -> p <|> parser { let! a = p let! f1 = op let! b1 = q let a1 = f1 a b1 let p1 = parser { return a1 } return! p1 |> infixL op q } ;; let rec infixR op q = fun p -> q <|> parser { let! a = p let! f = op let! b = p |> infixR op q return f a b } ;; // ================================================================== // Person data example // ------------------- // Regular expressions let nameReg = Regex @"\G\s*([a-zA-Z][a-zA-Z0-9]*)";; let numberReg = Regex @"\G\s*([0-9]+)";; let eosReg = Regex @"\G(\s*)$";; let name = token nameReg id;; let number = token numberReg int;; let eos = emptyToken eosReg ;; // Parsers let person = pairOf name (listOf number);; let personData = listOf person;; // Use of parser personData "John 35 2 Sophie 27 Richard 17 89 3" 0;; let personDataString = parser {let! dt = personData let! _ = eos return dt };; personDataString "John 35 2 Sophie 27 Richard 17 89 3" 0;; // ------------------------------------------------------------------- // Expression example // ------------------ type Expr = | Num of int | Var of string | Neg of Expr | Add of Expr * Expr | Sub of Expr * Expr | Mul of Expr * Expr;; // Regular expressions let numReg = Regex @"\G\s*((?:\053|-|)\s*[0-9]+)";; let varReg = Regex @"\G\s*([a-zA-z][a-zA-Z0-9]*)";; let plusMinReg = Regex @"\G\s*(\053|\055)";; let addOpReg = plusMinReg;; let signReg = plusMinReg;; let mulOpReg = Regex @"\G\s*(\052)";; let leftParReg = Regex @"\G\s*(\050)";; let rightParReg = Regex @"\G\s*(\051)";; // Conversion functions let numFct (str: string) = Num (int str);; let varFct = Var;; let addOpFct = function | "+" -> fun x y -> Add(x,y) | _ -> fun x y -> Sub(x,y);; let mulOpFct _ = fun x y -> Mul(x,y);; let signFct = function | "+" -> id | _ -> fun x -> Neg x;; // Token parsers let num = token numReg numFct;; let var = token varReg varFct;; let addOp = token addOpReg addOpFct;; let mulOp = token mulOpReg mulOpFct;; let sign = token signReg signFct;; let leftPar = emptyToken leftParReg;; let rightPar = emptyToken rightParReg;; //let eos = emptyToken eosReg;; // Parser let rec expr = term |> infixL addOp term and term = factor |> infixL mulOp factor and factor = num <|> var <|> parser {let! f = sign let! x = factor return (f x)} <|> parser {let! _ = leftPar let! x = expr let! _ = rightPar return x};; // Example of use // -------------- expr "-a1 + 2 * (a2 - 3)" 0;; // Parse fulle string let exprString = parser { let! ex = expr let! _ = eos return ex };; exprString "-a1 + 2 * (a2 - 3)" 0;; //================================================================== // Reporting errors // ---------------- let mutable maxPos = 0 let updateMaxPos pos = if pos > maxPos then maxPos <- pos;; let tokenE (reg: Regex) (conv: string -> 'a) : parser<'a> = fun str pos -> let ma = reg.Match(str,pos) match ma.Success with | false -> [] | _ -> let pos2 = pos + ma.Length updateMaxPos pos2 [( conv(captureSingle ma 1), pos2)];; let emptyTokenE (reg: Regex) : parser = fun str pos -> let ma = reg.Match(str,pos) match ma.Success with | false -> [] | _ -> let pos2 = pos + ma.Length updateMaxPos pos2 [( (), pos2)];; type ParseResult<'a> = ParseOk of 'a | ParseError of int;; let parseString (p: parser<'a>) (s: string) = maxPos <- 0 match p s 0 with | (a,_)::_ -> ParseOk a | _ -> ParseError maxPos;; // ============================================== // Person data example with error handling let nameE = token nameReg id;; let numberE = token numberReg int;; let personE = pairOf nameE (listOf numberE);; let personDataE = listOf personE;; parseString personDataE "John 35 2 Sophie 27 Richard 17 89 3" ;; // Expression example with error handling let numE = tokenE numReg numFct;; let varE = tokenE varReg varFct;; let addOpE = tokenE addOpReg addOpFct;; let mulOpE = tokenE mulOpReg mulOpFct;; let signE = tokenE signReg signFct;; let leftParE = emptyTokenE leftParReg;; let rightParE = emptyTokenE rightParReg;; let eosE = emptyTokenE eosReg;; let rec exprE = termE |> infixL addOpE termE and termE = factorE |> infixL mulOpE factorE and factorE = numE <|> varE <|> parser {let! f = signE let! x = factorE return (f x)} <|> parser {let! _ = leftParE let! x = exprE let! _ = rightParE return x};; let exprStringE = parser { let! ex = exprE let! _ = eosE return ex };; parseString exprStringE "-a1 + 2 * (a2 - 3)" ;; parseString exprStringE "a - b * (1 + c" ;;