Parser combinator 和正则表达式引擎的一些改进

open Ok_parsec
open Parsec

type elm=
  | Num of string
  | Var of string
  | Add | Sub | Mul | Div
  | Ast of ast
  | Eof

and op= | OpAdd | OpSub | OpMul | OpDiv

and ast=
  | StNum of string
  | StVar of string
  | StAdd of ast * ast
  | StSub of ast * ast
  | StMul of ast * ast
  | StDiv of ast * ast
  | StAssign of string * ast
  | StApp of string * ast list

module OpPrecedence = Map.Make(
  struct
    type t= op
    let compare= compare
  end)

(* precedence table *)
let opPrecedence=
  let open OpPrecedence in
  empty
  |> add OpAdd 3
  |> add OpSub 3
  |> add OpMul 4
  |> add OpDiv 4

let rec string_of_ast= fun ast->
  match ast with
  | StNum n-> n
  | StVar n-> n
  | StAdd (a1, a2)->
    Printf.sprintf "(+ %s %s)" (string_of_ast a1) (string_of_ast a2)
  | StSub (a1, a2)->
    Printf.sprintf "(- %s %s)" (string_of_ast a1) (string_of_ast a2)
  | StMul (a1, a2)->
    Printf.sprintf "(* %s %s)" (string_of_ast a1) (string_of_ast a2)
  | StDiv (a1, a2)->
    Printf.sprintf "(/ %s %s)" (string_of_ast a1) (string_of_ast a2)
  | StAssign (name, ast)-> Printf.sprintf "(= %s %s)"
      name (string_of_ast ast)
  | StApp (name, asts)-> Printf.sprintf "(%s %s)"
      name (List.map string_of_ast asts |> String.concat " ")

let reduce ops asts last newOp=
  let rec reduce ops asts newOp=
    match ops with
    | [] -> ([newOp], asts)
    | op::tail->
      let newOpPrecedence= OpPrecedence.find newOp opPrecedence
      and nextOpPrecedence= OpPrecedence.find op opPrecedence
      in
      if newOpPrecedence <= nextOpPrecedence then
        match op with
        | OpAdd-> (match asts with
          | n1::n2::rest-> reduce tail (StAdd (n2,n1)::rest) newOp
          | _ -> failwith "ast stack is empty while reduce OpAdd")
        | OpSub-> (match asts with
          | n1::n2::rest-> reduce tail (StSub (n2,n1)::rest) newOp
          | _ -> failwith "ast stack is empty while reduce OpSub")
        | OpMul-> (match asts with
          | n1::n2::rest-> reduce tail (StMul (n2,n1)::rest) newOp
          | _ -> failwith "ast stack is empty while reduce OpMul")
        | OpDiv-> (match asts with
          | n1::n2::rest-> reduce tail (StDiv (n2,n1)::rest) newOp
          | _ -> failwith "ast stack is empty while reduce OpDiv")
      else
        (newOp::ops, asts)
  in 
  let (ops, asts)= reduce ops asts newOp in
  (ops, asts, last)

let reduceAll ops asts=
  let rec reduceAll ops asts=
    match ops with
    | [] -> asts
    | op::tail->
      match op with
      | OpAdd-> (match asts with
        | n1::n2::rest-> reduceAll tail (StAdd (n2,n1)::rest)
        | _ -> failwith "ast stack is empty")
      | OpSub-> (match asts with
        | n1::n2::rest-> reduceAll tail (StSub (n2,n1)::rest)
        | _ -> failwith "ast stack is empty")
      | OpMul-> (match asts with
        | n1::n2::rest-> reduceAll tail (StMul (n2,n1)::rest)
        | _ -> failwith "ast stack is empty while reduceAll OpMul")
      | OpDiv-> (match asts with
        | n1::n2::rest-> reduceAll tail (StDiv (n2,n1)::rest)
        | _ -> failwith "ast stack is empty while reduceAll OpDiv")
  in List.hd (reduceAll ops asts)

let spaces= many ((char ' ') <|> (char '\t'))

let num=
  many1 num_dec |>> BatString.of_list

let ident=
  let%m head= lowercase <|> uppercase in
  let%m tail= many (lowercase <|> uppercase <|> num_dec)
  in return (head::tail |> BatString.of_list)

let rec element s= s |>
  let element=
    (char '+' >>$ Add) <|>
    (char '-' >>$ Sub) <|>
    (char '*' >>$ Mul) <|>
    (char '/' >>$ Div) <|>
    (num |>> fun num -> Num num) <|>
    ((char '(' >> spaces >> expr << spaces << char ')') <|>
      (assignment <|> application)
      |>> fun ast-> Ast ast)
    <|>
    (ident |>> fun name -> Var name) <|>
    (return Eof)
  in
  spaces >> element << spaces

and params s= s |> sepBy (spaces >> char ',' >> spaces) expr

and application s= s |>
  let%m name= ident in
  spaces >> char '(' >>
  let%m ps= params in
  char ')' >>
  return (StApp (name, ps));

and assignment s= s |>
  let%m v= ident in
  spaces >> char '=' >> spaces >>
  let%m exp= assignment <|> expr in
  return (StAssign (v, exp))

and expr s=
  let rec expr result=
    let (ops, asts, last)= result in
    let%m next= element in
    match next with
    | Num num-> return (ops, StNum num::asts, next) >>= expr
    | Var name-> return (ops, StVar name::asts, next) >>= expr
    | Ast ast-> return (ops, ast::asts, next) >>= expr
    | Add-> expr (reduce ops asts next OpAdd)
    | Sub->
      (match last with
      | Add | Sub | Mul | Div->
        let%m next= element in
        (match next with
        | Num num->
          let num= "-" ^ num in
          return (ops, StNum num::asts, Num num) >>= expr
        | _ -> fail "expecting num")
      | _ -> expr (reduce ops asts next OpSub))
    | Mul-> expr (reduce ops asts next OpMul)
    | Div-> expr (reduce ops asts next OpDiv)
    | Eof->
      try
        let ast= reduceAll ops asts in
        return ast
      with Failure "hd"->
        fail "empty"
  in (return ([], [], Eof) >>= expr) s

let test parser expr=
  let%m[@Lwt] result= parse_string parser expr in
  match result with
  | Ok (r, s)-> Lwt_io.printf "%s\n" (string_of_ast r)
  | Failed (p, s)-> Lwt_io.printf "at %d, %s\n" p s

let main ()=
  let open Lwt in
  begin%m
    Lwt_io.printf "parse sequently\n";
    test expr "res= tmp=bb+ 10 * show(1,me(2+3,4))";
    test expr "10-9 - 8 * 6 / 5 - 4";
    test expr "show(a=b=c(1,2))";
    test expr "(1--2*-3/-4)*3";
    Lwt_io.printl "";
    Lwt_io.printf "parse concurrently\n";
    join [
      test expr "res= tmp=bb+ 10 * show(1,me(2+3,4))";
      test expr "10-9 - 8 * 6 / 5 - 4";
      test expr "show(a=b=c(1,2))";
      test expr "(1--2*-3/-4)*3";
    ];
  end

let ()= Lwt_main.run @@ main ()