Term parser & cleanup

.gitignore

@@ -14,4 +14,7 @@ Cargo.lock
 *.cmt
 *.cmti
 *.js
-/bs/node_modules/
+/bs/node_modules/
+Parser.ml
+Parser.mli
+Lexer.ml

.gitmodules

@@ -1,3 +0,0 @@
-[submodule "bs/core"]
-	path = bs/core
-	url = https://github.com/janestreet/core.git

bs/Grammar.ml

@@ -1,68 +1,60 @@
-module Grammar (Head: Symbol.Symbol) (Nonterminal: Symbol.Symbol) =
+module Grammar =
 struct
 
-open Util;;
-open Term;;
-module Term = Term(Head);;
-open Term;;
-
-module Nonterminal = Symbol.Make(Nonterminal);;
-module Head        = Symbol.Make(Head);;
-module GrammarMap  = Hashtbl.Make(Nonterminal);;
-
-type nonterminal = Nonterminal.t;;
-type head = Head.t;;
-
-type production =
-  | PVal of head
-  | PVar
-  | PStx of head * nonterminal list;;
-
-type grammar = production list GrammarMap.t;;
-
-
-let show_production_shallow (p: production): string =
-  match p with
-  | PVal(head)    -> Printf.sprintf "value of nonterminal %s" (Head.show head)
-  | PVar          -> Printf.sprintf "variable"
-  | PStx(head, _) -> Printf.sprintf "term of nonterminal %s" (Head.show head);;
-
-let validate (g: grammar) (t: 'v term) (s: nonterminal): (unit, string) result =
-
-  let nonterminal_error t s =
-    Printf.sprintf "Expected %s but found %s"
-                   s
-                   (show_term_shallow t) in
-
-  let prod_error t p =
-    Printf.sprintf
-      "Expected %s but found %s"
-      (show_production_shallow p)
-      (show_term_shallow t) in
-
-  let rec validate_nonterminal (t: 'v term) (s: nonterminal): (unit, string) result =
-    let ps = GrammarMap.find g s in
-    match ps with
-    | [p] -> validate_prod t p
-    | ps ->
-       match or_result (validate_prod t) ps with
-       | Err ()  -> Err(nonterminal_error t (Nonterminal.show s))
-       | Ok  _   -> Ok ()
-
-  and validate_prod (t: 'v term) (p: production): (unit, string) result =
-    match (t, p) with
-    | (Val(head_found, _), PVal(head_expected))
-         when head_expected == head_found ->
-       Ok ()
-    | (Var _, PVar) -> Ok ()
-    | (Stx(head_found, ts), PStx(head_expected, ss))
-         when head_expected == head_found
-              && List.length ss == List.length ts ->
-       (match and_result2 validate_nonterminal ts ss with
-        | Err msg -> Err msg
-        | Ok  _   -> Ok ())
-    | (_, _) -> Err(prod_error t p) in
-
-  validate_nonterminal t s
+  open Util;;
+  open Term;;
+  open Term;;
+
+  type nonterminal = string;;
+
+  type production =
+    | PVal
+    | PVar
+    | PStx of string * nonterminal list;;
+
+  type grammar = (string, production list) Hashtbl.t;;
+
+
+  let show_production_shallow (p: production): string =
+    match p with
+    | PVal          -> Printf.sprintf "value"
+    | PVar          -> Printf.sprintf "variable"
+    | PStx(head, _) -> Printf.sprintf "term of nonterminal %s" head;;
+
+  let validate (g: grammar) (t: term) (s: nonterminal): (unit, string) result =
+
+    let nonterminal_error t s =
+      Printf.sprintf "Expected %s but found %s"
+                     s
+                     (show_term_shallow t) in
+
+    let prod_error t p =
+      Printf.sprintf
+        "Expected %s but found %s"
+        (show_production_shallow p)
+        (show_term_shallow t) in
+
+    let rec validate_nonterminal (t: term) (s: nonterminal): (unit, string) result =
+      let ps = Hashtbl.find g s in
+      match ps with
+      | [p] -> validate_prod t p
+      | ps ->
+         match or_result (validate_prod t) ps with
+         | Err ()  -> Err(nonterminal_error t s)
+         | Ok  _   -> Ok ()
+
+    and validate_prod (t: term) (p: production): (unit, string) result =
+      match (t, p) with
+      | (Val(_), PVal) -> Ok ()
+      | (Var _, PVar)  -> Ok ()
+      | (Stx(head_found, ts), PStx(head_expected, ss))
+           when head_expected == head_found
+                && List.length ss == List.length ts ->
+         (match and_result2 validate_nonterminal ts ss with
+          | Err msg -> Err msg
+          | Ok  _   -> Ok ())
+      | (_, _) -> Err(prod_error t p) in
+
+    validate_nonterminal t s
 
 end

bs/Makefile

@@ -8,7 +8,7 @@ parser:
 	ocamlyacc parser/Parser.mly
 	cp parser/*.ml .
 	cp parser/*.mli .
-	$(COMPILE) -bs-main calc.ml
+	$(COMPILE) Parse.ml
 
 clean:
 	rm *.js

bs/Parse.ml

@@ -0,0 +1,6 @@
+
+let parse_term (buf: Lexing.lexbuf): Term.term =
+  Parser.term Lexer.token buf;;
+
+let parse_term_s (s: string): Term.term =
+  parse_term (Lexing.from_string s);;

bs/Term.ml

@@ -1,27 +1,30 @@
-module Term (Head: Symbol.Symbol) =
-  struct
-
-    open Format;;
+open Format;;
 
-    type var = string;;
+type var = string;;
 
-    module Head = Symbol.Make(Head);;
-    type head = Head.t;;
+type term =
+  | Val of string
+  | Var of var
+  | Stx of string * term list;;
 
-    type 'v term =
-      | Val of head * 'v
-      | Var of var
-      | Stx of head * 'v term list;;
-
-    let show_term_shallow (t: 'v term): string =
-      match t with
-      | Val(head, _) -> Printf.sprintf "value %s" (Head.show head)
-      | Var(var)     -> Printf.sprintf "variable %s" var
-      | Stx(head, _) -> Printf.sprintf "term %s"  (Head.show head);;
-
-    let go msg =
-      print_endline msg;;
-
-    let plus(x, y) = x + y;;
+let rec show_term (t: term): string =
+  match t with
+  | Val(v)        -> Printf.sprintf "\"%s\"" v (* TODO: string escapes *)
+  | Var(var)      -> var
+  | Stx(head, ts) -> Printf.sprintf "(%s %s)" head (show_terms ts)
+and show_terms (ts: term list): string =
+  match ts with
+  | []    -> ""
+  | [t]   -> show_term t
+  | t::ts -> Printf.sprintf "%s %s" (show_term t) (show_terms ts);;
+
+let show_term_shallow (t: term): string =
+  match t with
+  | Val(v)       -> Printf.sprintf "value %s" v
+  | Var(var)     -> Printf.sprintf "variable %s" var
+  | Stx(head, _) -> Printf.sprintf "term %s" head;;
+
+let go msg =
+  print_endline msg;;
 
-  end
+let plus(x, y) = x + y;;

bs/parser/Lexer.mll

@@ -1,16 +1,14 @@
 
 {
     open Parser        (* The type token is defined in parser.mli *)
-    exception Eof
 }
 rule token = parse
-    [' ' '\t']     { token lexbuf }     (* skip blanks *)
-  | ['\n' ]        { EOL }
-  | ['0'-'9']+ as lxm { INT(int_of_string lxm) }
-  | '+'            { PLUS }
-  | '-'            { MINUS }
-  | '*'            { TIMES }
-  | '/'            { DIV }
-  | '('            { LPAREN }
-  | ')'            { RPAREN }
-  | eof            { raise Eof }
+    [' ' '\t' '\n' '\r']     { token lexbuf } (* whitespace *)
+  | '\'' [^ '\'']* '\'' as lxm  { LITERAL(lxm) }  (* TODO: string escapes *)
+  | ['a' - 'z' 'A' - 'Z' '_']+ as lxm { IDENTIFIER(lxm) }
+  | '('                      { LPAREN }
+  | ')'                      { RPAREN }
+  | '{'                      { LBRACE }
+  | '}'                      { RBRACE }
+  | "grammar"                { GRAMMAR }
+  | eof                      { EOF }

bs/parser/Parser.mly

@@ -1,36 +1,27 @@
 %{
-  module StringNT =
-  struct
-    include String;;
-    let ord x = 1;;
-    let show s = s;;
-  end;;
-  open Term;;
-  module Term = Term(StringNT);;
+  open Term
 %}
 
-%token <int> INT
-%token PLUS MINUS TIMES DIV
+%token <string> LITERAL
+%token <string> IDENTIFIER
 %token LPAREN RPAREN
-%token EOL
-%left PLUS MINUS        /* lowest precedence */
-%left TIMES DIV         /* medium precedence */
-%nonassoc UMINUS        /* highest precedence */
-%start main             /* the entry point */
-%start expr             /* the entry point */
-%type <int> main
-%type <int> expr
+%token LBRACE RBRACE
+%token GRAMMAR
+%token EOF
+
+%start term
+%type <Term.term> term
 %%
 
-main:
-    expr EOL                { $1 }
+term:
+  | LITERAL                 {
+    let s = $1 in
+    Term.Val(String.sub s 1 (String.length(s) - 2))
+  }
+  | IDENTIFIER              { Term.Var($1) }
+  | LPAREN IDENTIFIER terms RPAREN { Term.Stx($2, $3) }
 ;
-expr:
-    INT                     { $1 }
-  | LPAREN expr RPAREN      { $2 }
-  | expr PLUS expr          { Term.plus($1, $3) }
-  | expr MINUS expr         { $1 - $3 }
-  | expr TIMES expr         { $1 * $3 }
-  | expr DIV expr           { $1 / $3 }
-  | MINUS expr %prec UMINUS { - $2 }
+terms:
+  |                         { [] }
+  | term terms              { $1 :: $2 }
 ;