Initial AST definition and some template files

.gitignore

+._*/
+*.cmo
+*.cmi
+*.cmx
+*.swp
+*.o
+*.tgz
+*.tar.gz
+coffee

Makefile

+RESULT := coffee
+#GLOBALS := ast_coffee
+#PHASES :=
+#SOURCES := $(addsuffix .mli,$(GLOBALS)) $(addsuffix .ml,$(GLOBALS)) \
+#	lexer.mll parser.mly main.mli \
+#	$(patsubst %,phases/%.mli,$(PHASES)) $(patsubst %,phases/%.ml,$(PHASES)) \
+#	main.ml
+SOURCES := util.ml ast_coffee.ml traverse.ml main.ml
+LIBS := str unix
+
+# Set debugging flag to enable exception backtraces for OCAMLRUNPARAM=b
+OCAMLFLAGS := -g #-pp camlp4o
+
+.PHONY: all
+
+all: native-code
+
+# The Types module needs an implementation file to stop ocamlc from complaining
+#types.ml: types.mli
+#	cp $< $@
+
+include OCamlMakefile

ast_coffee.ml

+open Util
+
+(* AST nodes *)
+
+type ast = block
+
+and block = stmt list
+
+and stmt =
+  | Return of value option
+  | Comment of string
+  | Expr_stmt of value
+
+and value =
+  | Fun of value list * block * bool
+  | Call of value * value list
+  | Object of (string * value) list
+  | Array of value list
+  | Index of value * value
+  | Range of value option * value option * bool
+  | Try of block * block * block
+  | Throw of value
+  | New of value * value list
+  | Class of string option * value option * class_body
+  | Binop of binop * value * value
+  | Monop of monop * value
+  | Chainop of value * (binop * value) list
+  | If of value * block * block
+  | For of value * value option * binop * value * block
+  | While of value * block
+  | Switch of value * (value list * block) list * block
+  | Assign of value * value
+  | Property of value * string
+
+  | Regex of string * string
+  | Number of float
+  | String of string
+  | Var of string
+  | Js of string
+  | This
+  | Null
+  | Undefined
+  | True
+  | False
+
+  | Param of string
+  | Default of value * value
+  | Splat of value option
+
+and class_body = class_stmt list
+
+and class_stmt =
+  | Unnamed_expr of value
+  | Prototype_property of string * value
+
+and binop =
+  | Eq | Ne | Gt | Ge | Lt | Le
+  | And | Or
+  | In | Of
+  | Plus | Minus | Times | Div | Mod
+  | Div_trunc | Pow | Mod_math
+
+and monop =
+  | Not | Exists
+  | Neg | Pos
+
+(* Stringification *)
+
+let rec string_of_ast tree = string_of_block tree ^ "\n"
+
+and string_of_block block = cat "\n" string_of_stmt block
+
+and string_of_stmt = function
+  | Return None -> "return"
+  | Return (Some value) -> "return " ^ string_of_value value
+  | Comment comment -> prefix_lines "# " comment
+  | Expr_stmt value -> string_of_value value
+
+and string_of_value = function
+  | Fun (params, body, is_bound) ->
+    let params =
+      match params with
+      | [] -> ""
+      | _ -> "(" ^ cat ", " string_of_value params ^ ") "
+    in
+    let glyph = if is_bound then "=>" else "->" in
+    params ^ glyph ^ inline_block "" body
+
+  | Call (fn, args) ->
+    string_of_value fn ^ "(" ^ cat ", " string_of_value args ^ ")"
+
+  | Object key_value_pairs ->
+    let string_of_pair (key, value) = key ^ string_of_value value in
+    "{" ^ cat ", " string_of_pair key_value_pairs ^ "}"
+
+  | Array elements ->
+    "[" ^ cat ", " string_of_value elements ^ "]"
+
+  | Index (arr, (Range _ as range)) ->
+    string_of_value arr ^ string_of_value range
+  | Index (arr, idx) ->
+    string_of_value arr ^ "[" ^ string_of_value idx ^ "]"
+
+  | Range (lbnd, ubnd, inclusive) ->
+    let splat = if inclusive then ".." else "..." in
+    let s = function None -> "" | Some v -> string_of_value v in
+    "[" ^ s lbnd ^ splat ^ s ubnd ^ "]"
+
+  | Try (body, catch, finally) ->
+    let s pre = function [] -> "" | b -> pre ^ indent_block b in
+    "try" ^ indent_block body ^ "\n" ^
+    s "catch" catch ^ "\n" ^
+    s "finally" finally
+
+  | Throw value ->
+    "throw " ^ string_of_value value
+
+  | New (cls, args) ->
+    "new " ^ string_of_value cls ^ "(" ^ cat ", " string_of_value args ^ ")"
+
+  | Class (name, parent, body) ->
+    let cls =
+      match name with
+      | None -> "class"
+      | Some name -> "class " ^ name
+    in
+    let extends =
+      match parent with
+      | None -> ""
+      | Some parent -> " extends " ^ string_of_value parent
+    in
+    let body =
+      let string_of_class_stmt = function
+        | Unnamed_expr value ->
+
+          string_of_value value
+        | Prototype_property (name, value) ->
+          name ^ ": " ^ string_of_value value
+      in
+      match body with
+      | [] -> failwith "empty body"
+      | body -> "\n" ^ indent (cat "\n" string_of_class_stmt body)
+    in
+    cls ^ extends ^ body
+
+  | Binop (op, left, right) ->
+    "(" ^ string_of_value left ^
+    " " ^ string_of_binop op ^ " " ^
+    string_of_value right ^ ")"
+
+  | Monop (Exists, opnd) ->
+    string_of_value opnd ^ "?"
+  | Monop (op, opnd) ->
+    let op =
+      match op with
+      | Not -> "not"
+      | Neg -> "-"
+      | Pos -> "+"
+      | _ -> failwith "this cannot happen"
+    in
+    op ^ string_of_value opnd
+
+  | Chainop (hd, tl) ->
+    let rec s = function
+      | [] ->
+        failwith "invalid chained operator"
+      | [(op, opnd)] ->
+        string_of_binop op ^ " " ^ string_of_value opnd
+      | (op, opnd) :: tl ->
+        string_of_binop op ^ " " ^ string_of_value opnd ^ " " ^ s tl
+    in
+    string_of_value hd ^ " " ^ s tl
+
+  | If (cond, [], _) ->
+    failwith "empty if-body"
+  (*
+  | If (cond, [if_expr], []) ->
+    "if " ^ string_of_value cond ^ " then " ^ string_of_value if_expr
+  | If (cond, [if_expr], [else_expr]) ->
+    "if " ^ string_of_value cond ^ " then " ^ string_of_value if_expr ^
+    " else " ^ string_of_value else_expr
+  *)
+  | If (cond, if_body, []) ->
+    "if " ^ string_of_value cond ^ indent_block if_body
+  | If (cond, if_body, else_body) ->
+    "if " ^ string_of_value cond ^ indent_block if_body ^
+    "\nelse" ^ indent_block else_body
+
+  | For (value, index, op, arr, body) ->
+    let preamble =
+      let iterator =
+        let value = string_of_value value in
+        match index with
+        | None -> value
+        | Some index -> value ^ ", " ^ string_of_value index
+      in
+      "for " ^ iterator ^ " " ^ string_of_binop op ^ " " ^ string_of_value arr
+    in
+    begin
+      match body with
+      | [] -> failwith "empty loop body"
+      | [stmt] -> string_of_stmt stmt ^ preamble
+      | _ -> preamble ^ indent_block body
+    end
+
+  | While (cond, body) ->
+    "while " ^ string_of_value cond ^ indent_block body
+
+  | Switch (value, when_cases, default_case) ->
+    let string_of_when (match_values, body) =
+      "\nwhen " ^ cat ", " string_of_value match_values ^
+      inline_block "then" body
+    in
+    "switch " ^ string_of_value value ^
+    indent (cat "" string_of_when when_cases) ^
+    inline_block "else" default_case
+
+  | Assign (left, right) ->
+    string_of_value left ^ " = " ^ string_of_value right
+
+  | Property (obj, prop) ->
+    string_of_value obj ^ "." ^ prop
+
+  | Regex (pattern, modifiers) ->
+    "/" ^ pattern ^ "/" ^ modifiers
+
+  | Number n   -> string_of_number n
+  | String s   -> "\"" ^ s ^ "\""
+  | Var name   -> name
+  | Js js      -> "`" ^ js ^ "`"
+  | This       -> "this"
+  | Null       -> "null"
+  | Undefined  -> "undefined"
+  | True       -> "true"
+  | False      -> "false"
+  | Param name -> name
+
+  | Default (Param name, value) ->
+    name ^ "=" ^ string_of_value value
+  | Default _ ->
+    failwith "Default can only have Param as first child"
+
+  | Splat None ->
+    "..."
+  | Splat (Some value) ->
+    string_of_value value ^ "..."
+
+and string_of_number n = string_of_float n  (* FIXME *)
+
+and string_of_binop = function
+  | Eq        -> "is"
+  | Ne        -> "isnt"
+  | Gt        -> ">"
+  | Ge        -> ">="
+  | Lt        -> "<"
+  | Le        -> "<="
+  | And       -> "and"
+  | Or        -> "or"
+  | In        -> "in"
+  | Of        -> "of"
+  | Plus      -> "+"
+  | Minus     -> "-"
+  | Times     -> "*"
+  | Div       -> "/"
+  | Mod       -> "%"
+  | Div_trunc -> "//"
+  | Pow       -> "**"
+  | Mod_math  -> "%%"
+
+and indent_block = function
+  | [] -> failwith "empty block"
+  | stmts -> "\n" ^ indent (string_of_block stmts)
+
+and inline_block prefix = function
+  | [] -> ""
+  | [stmt] -> prefix ^ " " ^ string_of_stmt stmt
+  | stmts -> indent_block stmts

main.ml

+open Ast_coffee
+
+let () =
+  let f = Chainop (Var "a", [(Lt, Var "b"); (Le, Var "c"); (Eq, Var "d")]) in
+  print_endline (string_of_value f)

traverse.ml

+module C = Ast_coffee
+
+type location = int * int * int * int
+
+type location_box =
+  | Loc_stmt of C.stmt
+  | Loc_class_stmt of C.class_stmt
+  | Loc_value of C.value
+
+type location_pair = location * location_box

util.ml

+let tab = "    "
+
+let prefix_lines prefix = Str.global_replace (Str.regexp "^\\(.\\)") (prefix ^ "\\1")
+
+let indent = prefix_lines tab
+
+let rec cat sep fn = function
+  | [] -> ""
+  | [hd] -> fn hd
+  | hd :: tl -> fn hd ^ sep ^ cat sep fn tl