View
62 src/middle_end/anf_helper.ml
@@ -0,0 +1,62 @@
open Grain_parsing
open Grain_typed
open Anftree
type loc = Location.t
type env = Env.t
type ident = Ident.t
let default_loc = Location.dummy_loc
let default_env = Env.empty
let or_default_loc = Option.default default_loc
let or_default_env = Option.default default_env
module Imm = struct
let mk ?loc ?env d =
{imm_desc=d;
imm_loc=or_default_loc loc;
imm_env=or_default_env env}
let id ?loc ?env id = mk ?loc ?env (ImmId id)
let const ?loc ?env const = mk ?loc ?env (ImmConst const)
end
module Comp = struct
let mk ?loc ?env d =
{comp_desc=d;
comp_loc=or_default_loc loc;
comp_env=or_default_env env}
let imm ?loc ?env imm = mk ?loc ?env (CImmExpr imm)
let prim1 ?loc ?env p1 a = mk ?loc ?env (CPrim1(p1, a))
let prim2 ?loc ?env p2 a1 a2 = mk ?loc ?env (CPrim2(p2, a1, a2))
let tuple ?loc ?env elts = mk ?loc ?env (CTuple elts)
let tuple_get ?loc ?env tup idx = mk ?loc ?env (CGetTupleItem(tup, idx))
let tuple_set ?loc ?env tup idx value = mk ?loc ?env (CSetTupleItem(tup, idx, value))
let if_ ?loc ?env cond tru fals = mk ?loc ?env (CIf(cond, tru, fals))
let switch ?loc ?env arg branches = mk ?loc ?env (CSwitch(arg, branches))
let app ?loc ?env func args = mk ?loc ?env (CApp(func, args))
let app_builtin ?loc ?env modname name args = mk ?loc ?env (CAppBuiltin(modname, name, args))
let lambda ?loc ?env args body = mk ?loc ?env (CLambda(args, body))
let string ?loc ?env s = mk ?loc ?env (CString s)
end
module AExp = struct
let mk ?loc ?env d =
{anf_desc=d;
anf_loc=or_default_loc loc;
anf_env=or_default_env env}
let let_ ?loc ?env ?glob:(glob=Nonglobal) rec_flag binds body = mk ?loc ?env (AELet(glob, rec_flag, binds, body))
let seq ?loc ?env hd tl = mk ?loc ?env (AESeq(hd, tl))
let comp ?loc ?env e = mk ?loc ?env (AEComp(e))
end
module Imp = struct
let mk use_id d s=
{imp_use_id=use_id;
imp_desc=d;
imp_shape=s;}
let grain_value a md name s = mk a (GrainValue(md, name)) s
let wasm_func a md name s = mk a (WasmFunction(md, name)) s
let js_func a md name s = mk a (JSFunction(md, name)) s
end
View
44 src/middle_end/anf_helper.mli
@@ -0,0 +1,44 @@
open Grain_parsing
open Grain_typed
open Types
open Anftree
type loc = Location.t
type env = Env.t
type ident = Ident.t
module Imm : sig
val mk : ?loc:loc -> ?env:env -> imm_expression_desc -> imm_expression
val id : ?loc:loc -> ?env:env -> ident -> imm_expression
val const : ?loc:loc -> ?env:env -> constant -> imm_expression
end
module Comp : sig
val mk : ?loc:loc -> ?env:env -> comp_expression_desc -> comp_expression
val imm : ?loc:loc -> ?env:env -> imm_expression -> comp_expression
val prim1 : ?loc:loc -> ?env:env -> prim1 -> imm_expression -> comp_expression
val prim2 : ?loc:loc -> ?env:env -> prim2 -> imm_expression -> imm_expression -> comp_expression
val tuple : ?loc:loc -> ?env:env -> imm_expression list -> comp_expression
val tuple_get : ?loc:loc -> ?env:env -> int32 -> imm_expression -> comp_expression
val tuple_set : ?loc:loc -> ?env:env -> int32 -> imm_expression -> imm_expression -> comp_expression
val if_ : ?loc:loc -> ?env:env -> imm_expression -> anf_expression -> anf_expression -> comp_expression
val switch : ?loc:loc -> ?env:env -> imm_expression -> (int * anf_expression) list -> comp_expression
val app : ?loc:loc -> ?env:env -> imm_expression -> imm_expression list -> comp_expression
val app_builtin : ?loc:loc -> ?env:env -> string -> string -> imm_expression list -> comp_expression
val lambda : ?loc:loc -> ?env:env -> ident list -> anf_expression -> comp_expression
val string : ?loc:loc -> ?env:env -> string -> comp_expression
end
module AExp : sig
val mk : ?loc:loc -> ?env:env -> anf_expression_desc -> anf_expression
val let_ : ?loc:loc -> ?env:env -> ?glob:global_flag -> rec_flag -> (ident * comp_expression) list -> anf_expression -> anf_expression
val seq : ?loc:loc -> ?env:env -> comp_expression -> anf_expression -> anf_expression
val comp : ?loc:loc -> ?env:env -> comp_expression -> anf_expression
end
module Imp : sig
val mk : ident -> import_desc -> import_shape -> import_spec
val grain_value : ident -> string -> string -> import_shape -> import_spec
val wasm_func : ident -> string -> string -> import_shape -> import_spec
val js_func : ident -> string -> string -> import_shape -> import_spec
end
View
90 src/middle_end/anf_utils.ml
@@ -0,0 +1,90 @@
open Grain_typed
open Anftree
let rec anf_free_vars_help env (a : anf_expression) =
match a.anf_desc with
| AESeq(fst, rest) ->
Ident.Set.union
(comp_free_vars_help env fst)
(anf_free_vars_help env rest)
| AEComp(c) -> comp_free_vars_help env c
| AELet(_, recflag, binds, body) ->
let with_names = List.fold_left (fun acc (id, _) -> Ident.Set.add id acc) env binds in
let free_binds =
match recflag with
| Recursive -> List.fold_left
(fun acc (_, body) -> Ident.Set.union acc (comp_free_vars_help with_names body))
Ident.Set.empty
binds
| Nonrecursive -> List.fold_left
(fun acc (_, body) -> Ident.Set.union acc (comp_free_vars_help env body))
Ident.Set.empty
binds in
Ident.Set.union free_binds (anf_free_vars_help with_names body)
and comp_free_vars_help env (c : comp_expression) =
match c.comp_desc with
| CLambda(args, body) ->
anf_free_vars_help (Ident.Set.union env (Ident.Set.of_list args)) body
| CIf(cond, thn, els) ->
Ident.Set.union (imm_free_vars_help env cond) @@
Ident.Set.union (anf_free_vars_help env thn) (anf_free_vars_help env els)
| CSwitch(arg, branches) ->
List.fold_left (fun acc (_, b) -> Ident.Set.union (anf_free_vars_help env b) acc)
(imm_free_vars_help env arg)
branches
| CPrim1(_, arg) -> imm_free_vars_help env arg
| CPrim2(_, arg1, arg2) ->
Ident.Set.union
(imm_free_vars_help env arg1)
(imm_free_vars_help env arg2)
| CApp(fn, args) ->
List.fold_left (fun acc a -> Ident.Set.union (imm_free_vars_help env a) acc)
(imm_free_vars_help env fn)
args
| CAppBuiltin(_, _, args) ->
List.fold_left (fun acc a -> Ident.Set.union (imm_free_vars_help env a) acc)
Ident.Set.empty
args
| CTuple(args) ->
List.fold_left (fun acc a -> Ident.Set.union (imm_free_vars_help env a) acc)
Ident.Set.empty
args
| CGetTupleItem(_, arg) ->
imm_free_vars_help env arg
| CSetTupleItem(_, arg1, arg2) ->
Ident.Set.union
(imm_free_vars_help env arg1)
(imm_free_vars_help env arg2)
| CString(s) -> Ident.Set.empty
| CImmExpr(i) -> imm_free_vars_help env i
and imm_free_vars_help env (i : imm_expression) =
match i.imm_desc with
| ImmId(x) when not(Ident.Set.mem x env) -> Ident.Set.singleton x
| _ -> Ident.Set.empty
let anf_free_vars = anf_free_vars_help Ident.Set.empty
let comp_free_vars = comp_free_vars_help Ident.Set.empty
let imm_free_vars = imm_free_vars_help Ident.Set.empty
let rec anf_count_vars a =
match a.anf_desc with
| AELet(_, recflag, binds, body) ->
let max_binds = List.fold_left max 0 @@ List.map (fun (_, c) -> comp_count_vars c) binds in
begin match recflag with
| Recursive -> (List.length binds) + (max max_binds (anf_count_vars body))
| Nonrecursive -> max max_binds ((List.length binds) + (anf_count_vars body))
end
| AESeq(hd, tl) -> max (comp_count_vars hd) (anf_count_vars tl)
| AEComp(c) -> comp_count_vars c
and comp_count_vars c =
match c.comp_desc with
| CIf(_, t, f) -> max (anf_count_vars t) (anf_count_vars f)
| CSwitch(_, bs) -> List.fold_left max 0 @@ List.map (fun (_, b) -> anf_count_vars b) bs
| CApp(_, args) -> List.length args
| CAppBuiltin(_, _, args) -> List.length args
| _ -> 0
View
9 src/middle_end/anf_utils.mli
@@ -0,0 +1,9 @@
open Grain_typed
open Anftree
val anf_free_vars : anf_expression -> Ident.Set.t
val comp_free_vars : comp_expression -> Ident.Set.t
val imm_free_vars : imm_expression -> Ident.Set.t
val anf_count_vars : anf_expression -> int
val comp_count_vars : comp_expression -> int
View
112 src/middle_end/anftree.ml
@@ -0,0 +1,112 @@
(** Linearized (ANF) AST. *)
open Sexplib.Conv
open Grain_parsing
open Grain_typed
open Types
type rec_flag = Asttypes.rec_flag = Nonrecursive | Recursive
type global_flag = Global | Nonglobal [@@deriving sexp]
type 'a loc = 'a Location.loc
type prim1 = Parsetree.prim1 =
| Add1
| Sub1
| Not
| IsNum
| IsBool
| IsTuple
type prim2 = Parsetree.prim2 =
| Plus
| Minus
| Times
| Less
| Greater
| LessEq
| GreaterEq
| Eq
| And
| Or
let prim1_of_sexp, sexp_of_prim1 = Parsetree.prim1_of_sexp, Parsetree.sexp_of_prim1
let prim2_of_sexp, sexp_of_prim2 = Parsetree.prim2_of_sexp, Parsetree.sexp_of_prim2
let locs_disabled _ = not !Grain_utils.Config.sexp_locs_enabled
(** Immediate expressions (requiring no computation) *)
type imm_expression = {
imm_desc: imm_expression_desc;
imm_loc: Location.t [@sexp_drop_if locs_disabled];
imm_env: Env.t sexp_opaque;
} [@@deriving sexp]
and imm_expression_desc =
| ImmId of Ident.t
| ImmConst of constant
[@@deriving sexp]
(** Compound expressions (non-let-bound) *)
type comp_expression = {
comp_desc: comp_expression_desc;
comp_loc: Location.t [@sexp_drop_if locs_disabled];
comp_env: Env.t sexp_opaque;
}
[@@deriving sexp]
and comp_expression_desc =
| CImmExpr of imm_expression
| CPrim1 of prim1 * imm_expression
| CPrim2 of prim2 * imm_expression * imm_expression
| CTuple of imm_expression list
| CGetTupleItem of int32 * imm_expression
| CSetTupleItem of int32 * imm_expression * imm_expression
| CIf of imm_expression * anf_expression * anf_expression
| CSwitch of imm_expression * (int * anf_expression) list
| CApp of imm_expression * imm_expression list
| CAppBuiltin of string * string * imm_expression list
| CLambda of Ident.t list * anf_expression
| CString of string
[@@deriving sexp]
(** Compound expressions (possibly let-bound)
TODO: better name *)
and anf_expression = {
anf_desc: anf_expression_desc;
anf_loc: Location.t [@sexp_drop_if locs_disabled];
anf_env: Env.t sexp_opaque;
}
[@@deriving sexp]
and anf_expression_desc =
| AELet of global_flag * rec_flag * (Ident.t * comp_expression) list * anf_expression
| AESeq of comp_expression * anf_expression
| AEComp of comp_expression
[@@deriving sexp]
type import_shape =
| FunctionShape of int * int
| GlobalShape
[@@deriving sexp]
type import_desc =
| GrainValue of string * string
| WasmFunction of string * string
| JSFunction of string * string
[@@deriving sexp]
type import_spec = {
imp_use_id: Ident.t; (* <- internal references to the name will use this *)
imp_desc: import_desc;
imp_shape: import_shape;
}
[@@deriving sexp]
type anf_program = {
body: anf_expression;
env: Env.t sexp_opaque;
imports: import_spec list;
signature: Cmi_format.cmi_infos;
} [@@deriving sexp]
View
107 src/middle_end/anftree.mli
@@ -0,0 +1,107 @@
(** Linearized (ANF) AST. *)
open Sexplib.Conv
open Grain_parsing
open Grain_typed
open Types
type rec_flag = Asttypes.rec_flag = Nonrecursive | Recursive
type global_flag = Global | Nonglobal [@@deriving sexp]
type 'a loc = 'a Location.loc
type prim1 = Parsetree.prim1 =
| Add1
| Sub1
| Not
| IsNum
| IsBool
| IsTuple
type prim2 = Parsetree.prim2 =
| Plus
| Minus
| Times
| Less
| Greater
| LessEq
| GreaterEq
| Eq
| And
| Or
(** Immediate expressions (requiring no computation) *)
type imm_expression = {
imm_desc: imm_expression_desc;
imm_loc: Location.t;
imm_env: Env.t;
} [@@deriving sexp]
and imm_expression_desc =
| ImmId of Ident.t
| ImmConst of constant
[@@deriving sexp]
(** Compound expressions (non-let-bound) *)
type comp_expression = {
comp_desc: comp_expression_desc;
comp_loc: Location.t;
comp_env: Env.t;
}
[@@deriving sexp]
and comp_expression_desc =
| CImmExpr of imm_expression
| CPrim1 of prim1 * imm_expression
| CPrim2 of prim2 * imm_expression * imm_expression
| CTuple of imm_expression list
| CGetTupleItem of int32 * imm_expression
| CSetTupleItem of int32 * imm_expression * imm_expression
| CIf of imm_expression * anf_expression * anf_expression
| CSwitch of imm_expression * (int * anf_expression) list
| CApp of imm_expression * imm_expression list
| CAppBuiltin of string * string * imm_expression list (* Unwrapped function call (to WASM functions) *)
| CLambda of Ident.t list * anf_expression
| CString of string
[@@deriving sexp]
(** Compound expressions (possibly let-bound)
TODO: better name *)
and anf_expression = {
anf_desc: anf_expression_desc;
anf_loc: Location.t;
anf_env: Env.t;
}
[@@deriving sexp]
and anf_expression_desc =
| AELet of global_flag * rec_flag * (Ident.t * comp_expression) list * anf_expression
| AESeq of comp_expression * anf_expression
| AEComp of comp_expression
[@@deriving sexp]
type import_shape =
| FunctionShape of int * int
| GlobalShape
[@@deriving sexp]
type import_desc =
| GrainValue of string * string
| WasmFunction of string * string
| JSFunction of string * string
[@@deriving sexp]
type import_spec = {
imp_use_id: Ident.t; (* <- internal references to the name will use this *)
imp_desc: import_desc;
imp_shape: import_shape;
}
[@@deriving sexp]
type anf_program = {
body: anf_expression;
env: Env.t;
imports: import_spec list;
signature: Cmi_format.cmi_infos;
} [@@deriving sexp]
View
9 src/middle_end/jbuild
@@ -0,0 +1,9 @@
(jbuild_version 1)
(library
((name grain_middle_end)
(public_name grain_middle_end)
(synopsis "Grain compiler middle end")
(libraries (grain_parsing grain_typed grain_utils ppx_deriving ppx_sexp_conv sexplib))
(preprocess (pps (ppx_sexp_conv ppx_deriving)))))
View
381 src/middle_end/linearize.ml

Large diffs are not rendered by default.

Oops, something went wrong.
View
401 src/middle_end/matchcomp.ml

Large diffs are not rendered by default.

Oops, something went wrong.
View
5 src/middle_end/optimize.ml
@@ -0,0 +1,5 @@
let optimize_program (prog : Anftree.anf_program) : Anftree.anf_program =
(* TODO: Port optimization to new tree *)
prog
View
434 src/optimize.ml

This file was deleted.

Oops, something went wrong.
View
136 src/parser.mly

This file was deleted.

Oops, something went wrong.
View
6 src/parsing/README.md
@@ -0,0 +1,6 @@
# Parsing
This submodule contains code used for the Grain frontend.
While this will certainly evolve over time, the initial version of this
library is heavily inspired by the `parsing` directory of the OCaml
compiler; we try to use their idioms, since they know better than anyone
the best way to write a compiler in OCaml.
View
159 src/parsing/ast_helper.ml
@@ -0,0 +1,159 @@
(* This file is mostly copied from OCaml's parsing/ast_helper.ml.
The original copyright notice is reproduced below. *)
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
open Parsetree
type id = Identifier.t loc
type str = string loc
type loc = Location.t
let default_loc_src = ref (fun () -> Location.dummy_loc)
let with_default_loc_src ls f =
let old = !default_loc_src in
default_loc_src := ls;
try let r = f () in default_loc_src := old; r
with exn -> default_loc_src := old; raise exn
let with_default_loc l =
with_default_loc_src (fun() -> l)
module Const = struct
let string s = PConstString s
let int i = PConstNumber i
let bool b = PConstBool b
end
module Typ = struct
let mk ?loc d =
let loc = match loc with
| None -> (!default_loc_src)()
| Some l -> l in
{ptyp_desc=d; ptyp_loc=loc}
let any ?loc () = mk ?loc PTyAny
let var ?loc a = mk ?loc (PTyVar a)
let arrow ?loc a b = mk ?loc (PTyArrow(a, b))
let tuple ?loc a = mk ?loc (PTyTuple a)
let constr ?loc a b = mk ?loc (PTyConstr(a, b))
let poly ?loc a b = mk ?loc (PTyPoly(a, b))
end
module CDecl = struct
let mk ?loc n a =
let loc = match loc with
| None -> (!default_loc_src)()
| Some l -> l in
{pcd_name=n; pcd_args=a; pcd_loc=loc}
let singleton ?loc n = mk ?loc n PConstrSingleton
let tuple ?loc n a = mk ?loc n (PConstrTuple a)
end
module Dat = struct
let mk ?loc n t k =
let loc = match loc with
| None -> (!default_loc_src)()
| Some l -> l in
{pdata_name=n; pdata_params=t; pdata_kind=k; pdata_loc=loc}
let variant ?loc n t cdl = mk ?loc n t (PDataVariant cdl)
end
module Pat = struct
let mk ?loc d =
let loc = match loc with
| None -> (!default_loc_src)()
| Some l -> l in
{ppat_desc=d; ppat_loc=loc}
let any ?loc () = mk ?loc PPatAny
let var ?loc a = mk ?loc (PPatVar a)
let tuple ?loc a = mk ?loc (PPatTuple a)
let constant ?loc a = mk ?loc (PPatConstant a)
let constraint_ ?loc a b = mk ?loc (PPatConstraint(a, b))
let construct ?loc a b = mk ?loc (PPatConstruct(a, b))
let or_ ?loc a b = mk ?loc (PPatOr(a, b))
let alias ?loc a b = mk ?loc (PPatAlias(a, b))
end
module Exp = struct
let mk ?loc d =
let loc = match loc with
| None -> (!default_loc_src)()
| Some l -> l in
{pexp_desc=d; pexp_loc=loc}
let ident ?loc a = mk ?loc (PExpId a)
let constant ?loc a = mk ?loc (PExpConstant a)
let tuple ?loc a = mk ?loc (PExpTuple a)
let let_ ?loc a b c = mk ?loc (PExpLet(a, b, c))
let match_ ?loc a b = mk ?loc (PExpMatch(a, b))
let prim1 ?loc a b = mk ?loc (PExpPrim1(a, b))
let prim2 ?loc a b c = mk ?loc (PExpPrim2(a, b, c))
let if_ ?loc a b c = mk ?loc (PExpIf(a, b, c))
let lambda ?loc a b = mk ?loc (PExpLambda(a, b))
let apply ?loc a b = mk ?loc (PExpApp(a, b))
let block ?loc a = mk ?loc (PExpBlock a)
let null ?loc () = mk ?loc PExpNull
end
module Top = struct
let mk ?loc d =
let loc = match loc with
| None -> (!default_loc_src)()
| Some l -> l in
{ptop_desc=d; ptop_loc=loc}
let foreign ?loc d = mk ?loc (PTopForeign d)
let import ?loc i = mk ?loc (PTopImport i)
let data ?loc d = mk ?loc (PTopData d)
let let_ ?loc r vb = mk ?loc (PTopLet(r, vb))
end
module Val = struct
let mk ?loc ~mod_ ~name ~typ ~prim =
let loc = match loc with
| None -> (!default_loc_src)()
| Some l -> l in
{
pval_mod=mod_;
pval_name=name;
pval_type=typ;
pval_prim=prim;
pval_loc=loc;
}
end
module Vb = struct
let mk ?loc p e =
let loc = match loc with
| None -> (!default_loc_src)()
| Some l -> l in
{pvb_pat=p; pvb_expr=e; pvb_loc=loc}
end
module Mb = struct
let mk ?loc p e =
let loc = match loc with
| None -> (!default_loc_src)()
| Some l -> l in
{pmb_pat=p; pmb_body=e; pmb_loc=loc}
end
module Imp = struct
let mk ?loc m =
let loc = match loc with
| None -> (!default_loc_src)()
| Some l -> l in
{pimp_mod=m; pimp_loc=loc}
end
View
112 src/parsing/ast_helper.mli
@@ -0,0 +1,112 @@
(* This file is largely copied from OCaml's parsing/ast_helper.mli.
The original copyright notice is reproduced below. *)
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
open Parsetree
type id = Identifier.t loc
type str = string loc
type loc = Location.t
val default_loc_src: (unit -> loc) ref
(** Default value for all optional location arguments. *)
val with_default_loc: loc -> (unit -> 'a) -> 'a
(** Set the [default_loc] within the scope of the execution
of the provided function. *)
val with_default_loc_src: (unit -> loc) -> (unit -> 'a) -> 'a
module Const : sig
val string : string -> constant
val int : int -> constant
val bool : bool -> constant
end
module Typ : sig
val mk: ?loc:loc -> parsed_type_desc -> parsed_type
val any: ?loc:loc -> unit -> parsed_type
val var: ?loc:loc -> string -> parsed_type
val arrow: ?loc:loc -> parsed_type list -> parsed_type -> parsed_type
val tuple: ?loc:loc -> parsed_type list -> parsed_type
val constr: ?loc:loc -> id -> parsed_type list -> parsed_type
val poly: ?loc:loc -> str list -> parsed_type -> parsed_type
end
module CDecl : sig
val mk: ?loc:loc -> str -> constructor_arguments -> constructor_declaration
val singleton: ?loc:loc -> str -> constructor_declaration
val tuple: ?loc:loc -> str -> parsed_type list -> constructor_declaration
end
module Dat : sig
val mk: ?loc:loc -> str -> parsed_type list -> data_kind -> data_declaration
val variant: ?loc:loc -> str -> parsed_type list -> constructor_declaration list -> data_declaration
end
module Pat : sig
val mk: ?loc:loc -> pattern_desc -> pattern
val any: ?loc:loc -> unit -> pattern
val var: ?loc:loc -> str -> pattern
val tuple: ?loc:loc -> pattern list -> pattern
val constant: ?loc:loc -> constant -> pattern
val constraint_: ?loc:loc -> pattern -> parsed_type -> pattern
val construct: ?loc:loc -> id -> pattern list -> pattern
val or_: ?loc:loc -> pattern -> pattern -> pattern
val alias: ?loc:loc -> pattern -> str -> pattern
end
module Exp: sig
val mk: ?loc:loc -> expression_desc -> expression
val ident: ?loc:loc -> id -> expression
val constant: ?loc:loc -> constant -> expression
val tuple: ?loc:loc -> expression list -> expression
val let_: ?loc:loc -> rec_flag -> value_binding list -> expression -> expression
val match_: ?loc:loc -> expression -> match_branch list -> expression
val prim1: ?loc:loc -> prim1 -> expression -> expression
val prim2: ?loc:loc -> prim2 -> expression -> expression -> expression
val if_: ?loc:loc -> expression -> expression -> expression -> expression
val lambda: ?loc:loc -> pattern list -> expression -> expression
val apply: ?loc:loc -> expression -> expression list -> expression
val block: ?loc:loc -> expression list -> expression
val null: ?loc:loc -> unit -> expression
end
module Top: sig
val mk: ?loc:loc -> toplevel_stmt_desc -> toplevel_stmt
val foreign: ?loc:loc -> value_description -> toplevel_stmt
val import: ?loc:loc -> import_declaration -> toplevel_stmt
val data: ?loc:loc -> data_declaration -> toplevel_stmt
val let_: ?loc:loc -> rec_flag -> value_binding list -> toplevel_stmt
end
module Val: sig
val mk: ?loc:loc -> mod_:str -> name:str -> typ:parsed_type -> prim:string list -> value_description
end
module Vb: sig
val mk: ?loc:loc -> pattern -> expression -> value_binding
end
module Mb: sig
val mk: ?loc:loc -> pattern -> expression -> match_branch
end
module Imp: sig
val mk: ?loc:loc -> id -> import_declaration
end
View
137 src/parsing/ast_iterator.ml
@@ -0,0 +1,137 @@
(* See copyright in ast_iterator.mli *)
open Parsetree
type iterator = {
constant: iterator -> constant -> unit;
expr: iterator -> expression -> unit;
pat: iterator -> pattern -> unit;
typ: iterator -> parsed_type -> unit;
data: iterator -> data_declaration -> unit;
constructor: iterator -> constructor_declaration -> unit;
location: iterator -> Location.t -> unit;
import: iterator -> import_declaration -> unit;
value_binding: iterator -> value_binding -> unit;
match_branch: iterator -> match_branch -> unit;
value_description: iterator -> value_description -> unit;
toplevel: iterator -> toplevel_stmt -> unit;
}
let iter_loc sub {loc; txt} = sub.location sub loc
module Cnst = struct
let iter sub c = ()
end
module E = struct
let iter sub {pexp_desc = desc; pexp_loc = loc} =
sub.location sub loc;
match desc with
| PExpId(i) -> iter_loc sub i
| PExpConstant(c) -> sub.constant sub c
| PExpTuple(es) -> List.iter (sub.expr sub) es
| PExpLet(r, vbs, e) -> List.iter (sub.value_binding sub) vbs; sub.expr sub e
| PExpMatch(e, mbs) -> sub.expr sub e; List.iter (sub.match_branch sub) mbs
| PExpPrim1(p1, e) -> sub.expr sub e
| PExpPrim2(p2, e1, e2) -> sub.expr sub e1; sub.expr sub e2
| PExpIf(c, t, f) -> sub.expr sub c; sub.expr sub t; sub.expr sub f
| PExpLambda(pl, e) -> List.iter (sub.pat sub) pl; sub.expr sub e
| PExpApp(e, el) -> sub.expr sub e; List.iter (sub.expr sub) el
| PExpBlock(el) -> List.iter (sub.expr sub) el
| PExpNull -> ()
end
module P = struct
let iter sub {ppat_desc = desc; ppat_loc = loc} =
sub.location sub loc;
match desc with
| PPatAny -> ()
| PPatVar sl -> iter_loc sub sl
| PPatTuple pl -> List.iter (sub.pat sub) pl
| PPatConstant c -> sub.constant sub c
| PPatConstraint(p, pt) -> sub.pat sub p; sub.typ sub pt
| PPatConstruct(id, pl) -> iter_loc sub id; List.iter (sub.pat sub) pl
| PPatOr(p1, p2) -> sub.pat sub p1; sub.pat sub p2
| PPatAlias(p, id) -> sub.pat sub p; iter_loc sub id
end
module C = struct
let iter sub {pcd_name = name; pcd_args = args; pcd_loc = loc} =
sub.location sub loc;
iter_loc sub name;
match args with
| PConstrTuple(ptl) -> List.iter (sub.typ sub) ptl
| PConstrSingleton -> ()
end
module D = struct
let iter sub{pdata_name = name; pdata_params = args; pdata_kind = kind; pdata_loc = loc} =
sub.location sub loc;
iter_loc sub name;
List.iter (sub.typ sub) args;
match kind with
| PDataVariant cdl -> List.iter (sub.constructor sub) cdl
end
module T = struct
let iter sub {ptyp_desc = desc; ptyp_loc = loc} =
sub.location sub loc;
match desc with
| PTyAny -> ()
| PTyVar v -> ()
| PTyArrow(args, ret) -> List.iter (sub.typ sub) args; sub.typ sub ret
| PTyTuple ts -> List.iter (sub.typ sub) ts
| PTyConstr(name, ts) -> iter_loc sub name; List.iter (sub.typ sub) ts
| PTyPoly(args, t) -> List.iter (iter_loc sub) args; sub.typ sub t
end
module V = struct
let iter sub {pvb_pat = pat; pvb_expr = expr; pvb_loc = loc} =
sub.pat sub pat;
sub.expr sub expr;
sub.location sub loc;
end
module MB = struct
let iter sub {pmb_pat = pat; pmb_body = expr; pmb_loc = loc} =
sub.pat sub pat;
sub.expr sub expr;
sub.location sub loc;
end
module I = struct
let iter sub {pimp_mod = imod; pimp_loc = loc} =
sub.location sub loc;
iter_loc sub imod
end
module VD = struct
let iter sub {pval_mod = vmod; pval_name = vname; pval_loc = loc} =
sub.location sub loc;
iter_loc sub vmod;
iter_loc sub vname
end
module TL = struct
let iter sub {ptop_desc = desc; ptop_loc = loc} =
sub.location sub loc;
match desc with
| PTopForeign vd -> sub.value_description sub vd
| PTopImport id -> sub.import sub id
| PTopData dd -> sub.data sub dd
| PTopLet(r, vb) -> List.iter (sub.value_binding sub) vb
end
let default_iterator = {
constant = Cnst.iter;
expr = E.iter;
pat = P.iter;
typ = T.iter;
data = D.iter;
constructor = C.iter;
location = (fun _ x -> ());
import = I.iter;
value_binding = V.iter;
match_branch = MB.iter;
value_description = VD.iter;
toplevel = TL.iter;
}
View
40 src/parsing/ast_iterator.mli
@@ -0,0 +1,40 @@
(* This file is largely copied from OCaml's parsing/ast_iterator.mli.
The original copyright notice is reproduced below. *)
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Nicolas Ojeda Bar, LexiFi *)
(* *)
(* Copyright 2012 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
open Parsetree
type iterator = {
constant: iterator -> constant -> unit;
expr: iterator -> expression -> unit;
pat: iterator -> pattern -> unit;
typ: iterator -> parsed_type -> unit;
data: iterator -> data_declaration -> unit;
constructor: iterator -> constructor_declaration -> unit;
location: iterator -> Location.t -> unit;
import: iterator -> import_declaration -> unit;
value_binding: iterator -> value_binding -> unit;
match_branch: iterator -> match_branch -> unit;
value_description: iterator -> value_description -> unit;
toplevel: iterator -> toplevel_stmt -> unit;
}
(** A [iterator] record implements one "method" per syntactic category,
using an open recursion style: each method takes as its first
argument the iterator to be applied to children in the syntax
tree. *)
val default_iterator: iterator
(** A default iterator, which implements a "do not do anything" mapping. *)
View
151 src/parsing/ast_mapper.ml
@@ -0,0 +1,151 @@
(* See copyright in ast_mapper.mli *)
open Parsetree
open Ast_helper
type mapper = {
constant: mapper -> constant -> constant;
expr: mapper -> expression -> expression;
pat: mapper -> pattern -> pattern;
typ: mapper -> parsed_type -> parsed_type;
data: mapper -> data_declaration -> data_declaration;
constructor: mapper -> constructor_declaration -> constructor_declaration;
location: mapper -> Location.t -> Location.t;
import: mapper -> import_declaration -> import_declaration;
value_binding: mapper -> value_binding -> value_binding;
match_branch: mapper -> match_branch -> match_branch;
value_description: mapper -> value_description -> value_description;
toplevel: mapper -> toplevel_stmt -> toplevel_stmt;
}
let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt}
module Cnst = struct
let map sub c = c
end
module E = struct
let map sub {pexp_desc = desc; pexp_loc = loc} =
let open Exp in
let loc = sub.location sub loc in
match desc with
| PExpId(i) -> ident ~loc (map_loc sub i)
| PExpConstant(c) -> constant ~loc (sub.constant sub c)
| PExpTuple(es) -> tuple ~loc (List.map (sub.expr sub) es)
| PExpLet(r, vbs, e) -> let_ ~loc r (List.map (sub.value_binding sub) vbs) (sub.expr sub e)
| PExpMatch(e, mbs) -> match_ ~loc (sub.expr sub e) (List.map (sub.match_branch sub) mbs)
| PExpPrim1(p1, e) -> prim1 ~loc p1 (sub.expr sub e)
| PExpPrim2(p2, e1, e2) -> prim2 ~loc p2 (sub.expr sub e1) (sub.expr sub e2)
| PExpIf(c, t, f) -> if_ ~loc (sub.expr sub c) (sub.expr sub t) (sub.expr sub f)
| PExpLambda(pl, e) -> lambda ~loc (List.map (sub.pat sub) pl) (sub.expr sub e)
| PExpApp(e, el) -> apply ~loc (sub.expr sub e) (List.map (sub.expr sub) el)
| PExpBlock(el) -> block ~loc (List.map (sub.expr sub) el)
| PExpNull -> null ~loc ()
end
module P = struct
let map sub {ppat_desc = desc; ppat_loc = loc} =
let open Pat in
let loc = sub.location sub loc in
match desc with
| PPatAny -> any ~loc ()
| PPatVar sl -> var ~loc (map_loc sub sl)
| PPatTuple pl -> tuple ~loc (List.map (sub.pat sub) pl)
| PPatConstant c -> constant ~loc (sub.constant sub c)
| PPatConstraint(p, pt) -> constraint_ ~loc (sub.pat sub p) (sub.typ sub pt)
| PPatConstruct(id, pl) -> construct ~loc (map_loc sub id) (List.map (sub.pat sub) pl)
| PPatOr(p1, p2) -> or_ ~loc (sub.pat sub p1) (sub.pat sub p2)
| PPatAlias(p, id) -> alias ~loc (sub.pat sub p) (map_loc sub id)
end
module C = struct
let map sub {pcd_name = name; pcd_args = args; pcd_loc = loc} =
let open CDecl in
let loc = sub.location sub loc in
let sname = map_loc sub name in
match args with
| PConstrTuple(ptl) -> tuple ~loc sname (List.map (sub.typ sub) ptl)
| PConstrSingleton -> singleton ~loc sname
end
module D = struct
let map sub{pdata_name = name; pdata_params = args; pdata_kind = kind; pdata_loc = loc} =
let open Dat in
let loc = sub.location sub loc in
let sname = map_loc sub name in
let sargs = List.map (sub.typ sub) args in
match kind with
| PDataVariant cdl -> variant ~loc sname sargs (List.map (sub.constructor sub) cdl)
end
module T = struct
let map sub {ptyp_desc = desc; ptyp_loc = loc} =
let open Typ in
let loc = sub.location sub loc in
match desc with
| PTyAny -> any ~loc ()
| PTyVar v -> var ~loc v
| PTyArrow(args, ret) -> arrow ~loc (List.map (sub.typ sub) args) (sub.typ sub ret)
| PTyTuple ts -> tuple ~loc (List.map (sub.typ sub) ts)
| PTyConstr(name, ts) -> constr ~loc (map_loc sub name) (List.map (sub.typ sub) ts)
| PTyPoly(vars, t) -> poly ~loc (List.map (map_loc sub) vars) (sub.typ sub t)
end
module V = struct
let map sub {pvb_pat = pat; pvb_expr = expr; pvb_loc = loc} =
{
pvb_pat = sub.pat sub pat;
pvb_expr = sub.expr sub expr;
pvb_loc = sub.location sub loc;
}
end
module MB = struct
let map sub {pmb_pat = pat; pmb_body = expr; pmb_loc = loc} =
{
pmb_pat = sub.pat sub pat;
pmb_body = sub.expr sub expr;
pmb_loc = sub.location sub loc;
}
end
module I = struct
let map sub {pimp_mod = imod; pimp_loc = loc} =
let open Imp in
let loc = sub.location sub loc in
mk ~loc (map_loc sub imod)
end
module VD = struct
let map sub ({pval_mod = vmod; pval_name = vname; pval_loc = loc} as d) =
let pval_loc = sub.location sub loc in
let pval_mod = map_loc sub vmod in
let pval_name = map_loc sub vname in
{d with pval_name; pval_mod; pval_loc}
end
module TL = struct
let map sub {ptop_desc = desc; ptop_loc = loc} =
let open Top in
let loc = sub.location sub loc in
match desc with
| PTopForeign d -> Top.foreign ~loc (sub.value_description sub d)
| PTopImport id -> Top.import ~loc (sub.import sub id)
| PTopData dd -> Top.data ~loc (sub.data sub dd)
| PTopLet(r, vb) -> Top.let_ ~loc r (List.map (sub.value_binding sub) vb)
end
let default_mapper = {
constant = Cnst.map;
expr = E.map;
pat = P.map;
typ = T.map;
data = D.map;
constructor = C.map;
location = (fun _ x -> x);
import = I.map;
value_binding = V.map;
match_branch = MB.map;
value_description = VD.map;
toplevel = TL.map;
}
View
40 src/parsing/ast_mapper.mli
@@ -0,0 +1,40 @@
(* This file is largely copied from OCaml's parsing/ast_mapper.mli.
The original copyright notice is reproduced below. *)
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Alain Frisch, LexiFi *)
(* *)
(* Copyright 2012 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
open Parsetree
type mapper = {
constant: mapper -> constant -> constant;
expr: mapper -> expression -> expression;
pat: mapper -> pattern -> pattern;
typ: mapper -> parsed_type -> parsed_type;
data: mapper -> data_declaration -> data_declaration;
constructor: mapper -> constructor_declaration -> constructor_declaration;
location: mapper -> Location.t -> Location.t;
import: mapper -> import_declaration -> import_declaration;
value_binding: mapper -> value_binding -> value_binding;
match_branch: mapper -> match_branch -> match_branch;
value_description: mapper -> value_description -> value_description;
toplevel: mapper -> toplevel_stmt -> toplevel_stmt;
}
(** A mapper record implements one "method" per syntactic category,
using an open recursion style: each method takes as its first
argument the mapper to be applied to children in the syntax
tree. *)
val default_mapper: mapper
(** A default mapper, which implements a "deep identity" mapping. *)
View
38 src/parsing/asttypes.ml
@@ -0,0 +1,38 @@
(* Modified from OCaml. The original copyright notice is reproduced below. *)
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
open Sexplib.Conv
(** Auxiliary AST types used by parsetree and typedtree. *)
(* These are taken from OCaml. While not all fully supported,
we will likely want to support them. *)
type constant =
| Const_int of int
| Const_string of string
| Const_float of string
| Const_int32 of int32
| Const_int64 of int64
| Const_bool of bool
[@@deriving sexp]
(** Marker for recursive/nonrecursive let bindings *)
type rec_flag = Nonrecursive | Recursive [@@deriving sexp]
(** A location-tagged value. *)
type 'a loc = 'a Location.loc = {
txt : 'a;
loc : Location.t [@sexp_drop_if fun _ -> not !Grain_utils.Config.sexp_locs_enabled];
} [@@deriving sexp]
View
41 src/parsing/driver.ml
@@ -0,0 +1,41 @@
(** External frontend for running the parser. *)
open Lexing
open Location
type error =
| AmbiguousParse of Parsetree.parsed_program list
| NoValidParse
let report_error ppf = function
| AmbiguousParse parses ->
if !Grain_utils.Config.verbose || (!Grain_utils.Config.parser_debug_level > 0) then begin
Format.fprintf ppf "The Grain compiler had trouble parsing your program. Here were the potential parses:@\n@[<v>%a@]"
(fun ppf -> List.iter (fun x ->
Format.fprintf ppf "@[%s@]%," (Sexplib.Sexp.to_string_hum @@ Parsetree.sexp_of_parsed_program x)
)) parses
end else
Format.fprintf ppf "The Grain compiler had trouble parsing your program."
| NoValidParse ->
Format.fprintf ppf "The Grain compiler was unable to parse your program. \
If you see this message, please file an issue at https://github.com/grain-lang/grain"
exception Error of Location.t * error
let () =
Location.register_error_of_exn
(function
| Error(loc, err) -> Some(Location.error_of_printer loc report_error err)
| _ -> None)
let parse ?name lexbuf : Parsetree.parsed_program =
Option.may (fun n ->
lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = n };
Location.input_name := n;
) name;
let loc_start = Option.map_default (fun n -> {lexbuf.lex_start_p with pos_fname = n}) lexbuf.lex_start_p name in
let loc_end = lexbuf.lex_curr_p in
let startpos = {loc_start; loc_end; loc_ghost=true} in
match Parser.parse_program Lexer.token lexbuf with
| [] -> raise (Error(startpos, NoValidParse))
| [(x, _)] -> x
| parses -> raise (Error(startpos, AmbiguousParse (List.map fst parses)))
View
2 src/parsing/driver.mli
@@ -0,0 +1,2 @@
(** Wrapper for the parser, including error handling and ambiguous parses. *)
val parse : ?name:string -> Lexing.lexbuf -> Parsetree.parsed_program
View
75 src/parsing/identifier.ml
@@ -0,0 +1,75 @@
open Sexplib.Conv
let sep = "::"
type t =
| IdentName of string
| IdentExternal of t * string
[@@deriving sexp]
let rec equal i1 i2 =
match i1, i2 with
| (IdentName n1), (IdentName n2) -> String.equal n1 n2
| (IdentExternal(mod1, n1)), (IdentExternal(mod2, n2)) ->
(equal mod1 mod2) && (String.equal n1 n2)
| _ -> false
open Format
let rec print_ident ppf = function
| IdentName n -> fprintf ppf "%s" n
| IdentExternal(m, n) -> fprintf ppf "%a%s%s" print_ident m sep n
let default_printer ppf i = fprintf ppf "@{<id>%a@}@," print_ident i
let printer = ref default_printer
let print ppf = !printer ppf
let rec string_of_ident i =
print_ident str_formatter i;
flush_str_formatter()
let rec compare i1 i2 =
match i1, i2 with
| (IdentName n1), (IdentName n2) -> String.compare n1 n2
| (IdentExternal(mod1, n1)), (IdentExternal(mod2, n2)) ->
let n_comp = String.compare n1 n2 in
if n_comp <> 0 then
n_comp
else
compare mod1 mod2
| (IdentName _), (IdentExternal _)
| (IdentExternal _), (IdentName _) ->
String.compare (string_of_ident i1) (string_of_ident i2)
let last = function
| IdentName s -> s
| IdentExternal (_, s) -> s
let rec split_at_dots s pos =
try
let dot = String.index_from s pos '.' in
String.sub s pos (dot - pos) :: split_at_dots s (dot + 1)
with Not_found ->
[String.sub s pos (String.length s - pos)]
let flatten n =
let rec help acc = function
| IdentName(n) -> List.rev (n::acc)
| IdentExternal(p, n) -> help (n::acc) p
in
help [] n
let unflatten = function
| [] -> None
| hd::tl -> Some (List.fold_left (fun p s -> IdentExternal(p, s)) (IdentName hd) tl)
let parse s =
match unflatten (split_at_dots s 0) with
| None -> IdentName ""
| Some v -> v
let hash name = Hashtbl.hash (flatten name)
let output oc name = output_string oc (string_of_ident name)
View
32 src/parsing/identifier.mli
@@ -0,0 +1,32 @@
(** Types for identifiers *)
open Format
(** The type of identifiers. *)
type t =
| IdentName of string
(** A simple name. *)
| IdentExternal of t * string
(** (module, ident) An external name. It is currently a well-formedness error
to have a non-name on the LHS. *)
[@@deriving sexp]
val equal : t -> t -> bool
val compare : t -> t -> int
val print : formatter -> t -> unit
val default_printer : formatter -> t -> unit
(** The default {!formatter} implementation for identifiers.
When formatting {!type:t} instances, one should use {!print} instead. *)
val printer : (formatter -> t -> unit) ref
(** The active {!formatter} implementation for identifiers *)
val string_of_ident : t -> string
val last : t -> string
val unflatten: string list -> t option
val parse: string -> t
val hash: t -> int
val output : out_channel -> t -> unit
val flatten : t -> string list
View
16 src/parsing/jbuild
@@ -0,0 +1,16 @@
(jbuild_version 1)
(ocamllex (lexer))
(library
((name grain_parsing)
(public_name grain_parsing)
(synopsis "Frontend modules for Grain compiler")
(libraries (dyp batteries ppx_deriving ppx_sexp_conv sexplib extlib grain_utils))
(preprocess (pps (ppx_sexp_conv ppx_deriving)))))
(rule
((targets (parser.ml))
(deps (parser.dyp))
(action (run dypgen --no-mli --Werror ${<}))))
View
78 src/lexer.mll → src/parsing/lexer.mll
@@ -3,6 +3,34 @@
open Parser
open Printf
let lexbuf_loc {lex_start_p=loc_start; lex_curr_p=loc_end; _} =
let open Location in
{
loc_start; loc_end; loc_ghost=false
}
type error =
| UnrecognizedCharacter of char
| UnicodeCharacter
| IllegalStringCharacter of string
exception Error of Location.t * error
let report_error ppf err =
match err with
| UnrecognizedCharacter c ->
Format.fprintf ppf "Unrecognized character: %C" c
| UnicodeCharacter ->
Format.fprintf ppf "Unicode characters are currently unsupported."
| IllegalStringCharacter sc ->
Format.fprintf ppf "Illegal string character: %S" sc
let () =
Location.register_error_of_exn
(function
| Error(loc, err) -> Some(Location.error_of_printer loc report_error err)
| _ -> None)
let add_char_code buf lexbuf = begin
let str = lexeme lexbuf in
let (esc, numstr) = ((String.sub str 1 1), (String.sub str 2 ((String.length str) - 2))) in
@@ -11,7 +39,7 @@
| "x" -> Scanf.sscanf numstr "%x" (fun x -> x)
| _ -> Scanf.sscanf (esc^numstr) "%o" (fun x -> x)) in
if (to_add > 255) then
failwith "Unicode Characters are currently unsupported."
raise (Error(lexbuf_loc lexbuf, UnicodeCharacter))
else
Buffer.add_char buf (Char.chr to_add);
end
@@ -23,7 +51,8 @@ let signed_int = dec_digit+ | ('-' dec_digit+)
let hex_digit = ['0'-'9' 'A'-'F' 'a'-'f']
let oct_digit = ['0'-'7']
let ident = ['a'-'z' 'A'-'Z' '_']['a'-'z' 'A'-'Z' '0'-'9' '_']* ("::" ['a'-'z' 'A'-'Z' '0'-'9' '_']+)?
let ident = ['a'-'z' '_']['a'-'z' 'A'-'Z' '0'-'9' '_']*
let ident_cap = ['A'-'Z']['a'-'z' 'A'-'Z' '0'-'9' '_']*
let blank = [' ' '\t']+
@@ -54,58 +83,59 @@ let newline_char = ("\r\n"|"\n\r"|'\n'|'\r')
let comment = '#' ((([^'|'])[^ '\r' '\n']*(newline_char | eof)) | (newline_char | eof))
rule token = parse
| comment { token lexbuf }
| comment { new_line lexbuf; token lexbuf }
| blank { token lexbuf }
| '\n' { new_line lexbuf; token lexbuf }
| signed_int as x { NUM (int_of_string x) }
| "def" { DEF }
| "foreign" { FOREIGN }
| "wasm" { WASM }
| "add1" { ADD1 }
| "sub1" { SUB1 }
| "printStack" { PRINTSTACK }
| "begin" { BEGIN }
| "end" { END }
| "if" { IF }
| "else" { ELSE }
| "true" { TRUE }
| "false" { FALSE }
| "isbool" { ISBOOL }
| "isnum" { ISNUM }
| "istuple" { ISTUPLE }
| "lambda" { LAMBDA }
| "λ" { LAMBDA }
| "include" { INCLUDE }
| ":" { COLON }
| "import" { IMPORT }
| "->" { ARROW }
| "else:" { ELSECOLON }
| "else" { ELSE }
| "=>" { THICKARROW }
| "data" { DATA }
| "|" { PIPE }
| "let" { LET }
| "rec" { REC }
| "in" { IN }
| "and" { AND }
| "match" { MATCH }
| "::" { COLONCOLON }
| ":=" { GETS }
| ":" { COLON }
| "==" { EQEQ }
| "=" { EQUAL }
| "," { COMMA }
| ";" { SEMI }
| "(" { LPAREN }
| ")" { RPAREN }
| "{" { LBRACE }
| "}" { RBRACE }
| "[" { LBRACK }
| "]" { RBRACK }
| "<" { LCARET }
| ">" { RCARET }
| "+" { PLUS }
| "-" { MINUS }
| "*" { TIMES }
| "<" { LESS }
| ">" { GREATER }
| "<=" { LESSEQ }
| ">=" { GREATEREQ }
| "&&" { ANDAND }
| "||" { OROR }
| "!" { NOT }
| "..." { ELLIPSIS }
| "and" { AND }
| "or" { OR }
| "not" { NOT }
| '"' { read_dquote_str (Buffer.create 16) lexbuf }
| '\'' { read_squote_str (Buffer.create 16) lexbuf }
| "_" { UNDERSCORE }
| ident as x { ID x }
| ident_cap as x { TYPEID x }
| eof { EOF }
| _ as c { failwith (sprintf "Unrecognized character: %c" c) }
| _ as c { raise (Error(lexbuf_loc lexbuf, UnrecognizedCharacter c)) }
and read_dquote_str buf =
@@ -119,7 +149,7 @@ and read_dquote_str buf =
| [^ '"' '\\']+ { Buffer.add_string buf (lexeme lexbuf);
read_dquote_str buf lexbuf }
| '"' { STRING (Buffer.contents buf) }
| _ { failwith ("Illegal string character: " ^ (lexeme lexbuf)) }
| _ { raise (Error(lexbuf_loc lexbuf, IllegalStringCharacter(lexeme lexbuf))) }
and read_squote_str buf =
parse
@@ -132,4 +162,4 @@ and read_squote_str buf =
| [^ ''' '\\']+ { Buffer.add_string buf (lexeme lexbuf);
read_squote_str buf lexbuf }
| '\'' { STRING (Buffer.contents buf) }
| _ { failwith ("Illegal string character: " ^ (lexeme lexbuf)) }
| _ { raise (Error(lexbuf_loc lexbuf, IllegalStringCharacter(lexeme lexbuf))) }
View
392 src/parsing/location.ml
@@ -0,0 +1,392 @@
(* This file is mostly copied from OCaml's parsing/location.ml.
The original copyright notice is reproduced below. *)
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
open Sexplib.Conv
open Lexing
open Grain_utils
(* NOTE: A lot of this file is taken from OCaml's parsing/location.ml.
Perhaps we should just go ahead and copy the whole thing. *)
let absname = ref false
let sexp_of_position (p : position) =
Sexplib.Sexp.List [
Sexplib.Sexp.Atom "position";
Sexplib.Sexp.List [
Sexplib.Sexp.Atom "file";
Sexplib.Conv.sexp_of_string p.pos_fname;
];
Sexplib.Sexp.List [
Sexplib.Sexp.Atom "line";
Sexplib.Conv.sexp_of_int p.pos_lnum;
];
Sexplib.Sexp.List [
Sexplib.Sexp.Atom "col";
Sexplib.Conv.sexp_of_int p.pos_cnum;
];
Sexplib.Sexp.List [
Sexplib.Sexp.Atom "bol";
Sexplib.Conv.sexp_of_int p.pos_bol;
];
]
let position_of_sexp (sexp : Sexplib.Sexp.t) =
let open Sexplib.Conv in
let open Sexplib.Sexp in
match sexp with
| Atom str -> of_sexp_error "position_of_sexp: list needed" sexp
| List [Atom "position"; List sexp_fields] when List.length sexp_fields = 4 ->
let fields = List.map (function
| List [Atom str; ((Atom _) as value)] -> (str, value)
| sexp -> of_sexp_error "position_of_sexp: invalid field" sexp) sexp_fields in
let pos_fname, pos_lnum, pos_cnum, pos_bol = begin
try
string_of_sexp (List.assoc "file" fields),
int_of_sexp (List.assoc "line" fields),
int_of_sexp (List.assoc "col" fields),
int_of_sexp (List.assoc "bol" fields)
with
| Not_found -> of_sexp_error "position_of_sexp: invalid fields" sexp
end in
{ pos_fname; pos_lnum; pos_cnum; pos_bol }
| List ((Atom "position") :: _) -> of_sexp_error "position_of_sexp: invalid fields" sexp
| List _ -> of_sexp_error "position_of_sexp: invalid s-expression" sexp
type t = Warnings.loc = {
loc_start: position;
loc_end: position;
loc_ghost: bool;
} [@@deriving sexp]
let in_file name =
let loc = {
pos_fname = name;
pos_lnum = 1;
pos_bol = 0;
pos_cnum = -1;
} in
{ loc_start = loc; loc_end = loc; loc_ghost = true }
let dummy_loc = {
loc_start=dummy_pos;
loc_end=dummy_pos;
loc_ghost=true
}
let sexp_of_t loc =
if loc = dummy_loc then
Sexplib.Sexp.Atom "dummy_loc"
else
sexp_of_t loc
let t_of_sexp sexp =
match sexp with
| Sexplib.Sexp.Atom "dummy_loc" -> dummy_loc
| _ -> t_of_sexp sexp
let curr lexbuf = {
loc_start = lexbuf.lex_start_p;
loc_end = lexbuf.lex_curr_p;
loc_ghost = false
}
let init lexbuf fname =
lexbuf.lex_curr_p <- {
pos_fname = fname;
pos_lnum = 1;
pos_bol = 0;
pos_cnum = 0;
}
let symbol_rloc () = {
loc_start = Parsing.symbol_start_pos ();
loc_end = Parsing.symbol_end_pos ();
loc_ghost = false;
}
let symbol_gloc () = {
loc_start = Parsing.symbol_start_pos ();
loc_end = Parsing.symbol_end_pos ();
loc_ghost = true;
}
let rhs_loc n = {
loc_start = Parsing.rhs_start_pos n;
loc_end = Parsing.rhs_end_pos n;
loc_ghost = false;
}
let input_name = ref "_none_"
let input_lexbuf = ref (None : lexbuf option)
(* Terminal info *)
let status = ref Terminfo.Uninitialised
let num_loc_lines = ref 0 (* number of lines already printed after input *)
let print_updating_num_loc_lines ppf f arg =
let open Format in
let out_functions = pp_get_formatter_out_functions ppf () in
let out_string str start len =
let rec count i c =
if i = start + len then c
else if String.get str i = '\n' then count (succ i) (succ c)
else count (succ i) c in
num_loc_lines := !num_loc_lines + count start 0 ;
out_functions.out_string str start len in
pp_set_formatter_out_functions ppf
{ out_functions with out_string } ;
f ppf arg ;
pp_print_flush ppf ();
pp_set_formatter_out_functions ppf out_functions
let reset () =
num_loc_lines := 0
open Format
let (msg_file, msg_line, msg_chars, msg_char, msg_to, msg_colon) =
("File \"", "\", line ", ", characters ", ", character ", "-", ":")
(** Returns (file, line, char) *)
let get_pos_info pos =
(pos.pos_fname, pos.pos_lnum, pos.pos_cnum - pos.pos_bol)
let setup_colors() =
Misc.Color.setup @@ Some(if !Grain_utils.Config.color_enabled then Misc.Color.Auto else Misc.Color.Never)
let absolute_path s = (* This function could go into Filename *)
let open Filename in
let s = if is_relative s then concat (Sys.getcwd ()) s else s in
(* Now simplify . and .. components *)
let rec aux s =
let base = basename s in
let dir = dirname s in
if dir = s then dir
else if base = current_dir_name then aux dir
else if base = parent_dir_name then dirname (aux dir)
else concat (aux dir) base
in
aux s
let show_filename file = if !absname then absolute_path file else file
let print_filename ppf file = fprintf ppf "%s" (show_filename file)
let print_loc ppf loc =
setup_colors();
let (file, line, startchar) = get_pos_info loc.loc_start in
let (_, endline, endchar) = get_pos_info loc.loc_end in
(*let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in*)
fprintf ppf "%s@{<loc>%a%s%i" msg_file print_filename file msg_line line;
if startchar >= 0 then begin
if line = endline then
fprintf ppf "%s%i%s%i" msg_chars startchar msg_to endchar
else
fprintf ppf "%s%i%sline %i%s%i" msg_char startchar msg_to endline msg_char endchar
end;
fprintf ppf "@}"
let default_printer ppf loc =
setup_colors();
fprintf ppf "@{<loc>%a@}%s@," print_loc loc msg_colon
let printer = ref default_printer
let print ppf loc = !printer ppf loc
let error_prefix = "Error"
let warning_prefix = "Warning"
let print_error_prefix ppf =
setup_colors ();
fprintf ppf "@{<error>%s@}" error_prefix
let print_compact ppf loc =
let (file, line, startchar) = get_pos_info loc.loc_start in
let (_, endline, endchar) = get_pos_info loc.loc_end in
fprintf ppf "%a:%i" print_filename file line;
if startchar >= 0 then begin
if line = endline then
fprintf ppf ",%i--%i" startchar endchar
else
fprintf ppf ",%i--%i,%i" startchar endline endchar
end
let print_error ppf loc =
fprintf ppf "%a%t:" print loc print_error_prefix
let print_error_cur_file ppf () = print_error ppf (in_file !input_name)
let default_warning_printer loc ppf w =
match Warnings.report w with
| `Inactive -> ()
| `Active { Warnings. number; message; is_error; sub_locs } ->
setup_colors ();
fprintf ppf "@[<v>";
print ppf loc;
if is_error
then
fprintf ppf "%t (%s %d): %s@," print_error_prefix
(String.uncapitalize_ascii warning_prefix) number message
else fprintf ppf "@{<warning>%s@} %d: %s@," warning_prefix number message;
List.iter
(fun (loc, msg) ->
if loc <> dummy_loc then fprintf ppf " %a %s@," print loc msg
)
sub_locs;
fprintf ppf "@]"
let warning_printer = ref default_warning_printer ;;
let print_warning loc ppf w =
print_updating_num_loc_lines ppf (!warning_printer loc) w
;;
let formatter_for_warnings = ref err_formatter;;
let prerr_warning loc w = print_warning loc !formatter_for_warnings w;;
let echo_eof () =
print_newline ();
incr num_loc_lines
type 'a loc = {
txt : 'a;
loc : t;
}
let mkloc txt loc = { txt ; loc }
let mknoloc txt = mkloc txt dummy_loc
type error =
{
loc: t;
msg: string;
sub: error list;
if_highlight: string; (* alternative message if locations are highlighted *)
}
let pp_ksprintf ?before k fmt =
let buf = Buffer.create 64 in
let ppf = Format.formatter_of_buffer buf in
Misc.Color.set_color_tag_handling ppf;
begin match before with
| None -> ()
| Some f -> f ppf
end;
kfprintf
(fun _ ->
pp_print_flush ppf ();
let msg = Buffer.contents buf in
k msg)
ppf fmt
(* Shift the formatter's offset by the length of the error prefix, which
is always added by the compiler after the message has been formatted *)
let print_phanton_error_prefix ppf =
Format.pp_print_as ppf (String.length error_prefix + 2 (* ": " *)) ""
let errorf ?(loc = dummy_loc) ?(sub = []) ?(if_highlight = "") fmt =
pp_ksprintf
~before:print_phanton_error_prefix
(fun msg -> {loc; msg; sub; if_highlight})
fmt
let error ?(loc = dummy_loc) ?(sub = []) ?(if_highlight = "") msg =
{loc; msg; sub; if_highlight}
let error_of_exn : (exn -> error option) list ref = ref []
let register_error_of_exn f = error_of_exn := f :: !error_of_exn
exception Already_displayed_error = Warnings.Errors
let error_of_exn exn =
match exn with
| Already_displayed_error -> Some `Already_displayed
| _ ->
let rec loop = function
| [] -> None
| f :: rest ->
match f exn with
| Some error -> Some (`Ok error)
| None -> loop rest
in
loop !error_of_exn
let rec default_error_reporter ppf {loc; msg; sub; if_highlight} =
fprintf ppf "@[<v>%a %s" print_error loc msg;
List.iter (Format.fprintf ppf "@,@[<2>%a@]" default_error_reporter) sub;
fprintf ppf "@]"
let error_reporter = ref default_error_reporter
let report_error ppf err =
print_updating_num_loc_lines ppf !error_reporter err
;;
let error_of_printer loc print x =
errorf ~loc "%a@?" print x
let error_of_printer_file print x =
error_of_printer (in_file !input_name) print x
let () =
register_error_of_exn
(function
| Sys_error msg ->
Some (errorf ~loc:(in_file !input_name)
"I/O error: %s" msg)
| Misc.HookExnWrapper {error = e; hook_name;
hook_info={Misc.sourcefile}} ->
let sub = match error_of_exn e with
| None | Some `Already_displayed -> error (Printexc.to_string e)
| Some (`Ok err) -> err
in
Some
(errorf ~loc:(in_file sourcefile)
"In hook %S:" hook_name
~sub:[sub])
| _ -> None
)
external reraise : exn -> 'a = "%reraise"
let rec report_exception_rec n ppf exn =
try
match error_of_exn exn with
| None -> reraise exn
| Some `Already_displayed -> ()
| Some (`Ok err) -> fprintf ppf "@[%a@]@." report_error err
with exn when n > 0 -> report_exception_rec (n-1) ppf exn
let report_exception ppf exn = report_exception_rec 5 ppf exn
exception Error of error
let () =
register_error_of_exn
(function
| Error e -> Some e
| _ -> None
)
let raise_errorf ?(loc = dummy_loc) ?(sub = []) ?(if_highlight = "") =
pp_ksprintf
~before:print_phanton_error_prefix
(fun msg -> raise (Error ({loc; msg; sub; if_highlight})))
View
116 src/parsing/location.mli
@@ -0,0 +1,116 @@
(** Source location data definitions *)
open Format
(** The type for source locations. This definition
is inspired by the OCaml compiler's source. *)
type t = Grain_utils.Warnings.loc = {
loc_start: Lexing.position; (** The starting position *)
loc_end: Lexing.position; (** The ending position *)
loc_ghost: bool; (** Whether this location was auto-generated *)
} [@@deriving sexp]
val dummy_loc : t
(** A placeholder dummy location *)
val in_file : string -> t
(** Return an empty ghost range located in a given file. *)
val init : Lexing.lexbuf -> string -> unit
(** Set the file name and line number of the [lexbuf] to be the start
of the named file. *)
val curr : Lexing.lexbuf -> t
(** Get the location of the current token from the [lexbuf]. *)
val symbol_rloc: unit -> t
val symbol_gloc: unit -> t
(** [rhs_loc n] returns the location of the symbol at position [n], starting
at 1, in the current parser rule. *)
val rhs_loc: int -> t
val input_name: string ref
val input_lexbuf: Lexing.lexbuf option ref
val print_error: formatter -> t -> unit
val print_error_cur_file: formatter -> unit -> unit
val print_warning: t -> formatter -> Grain_utils.Warnings.t -> unit
val formatter_for_warnings : formatter ref
val prerr_warning: t -> Grain_utils.Warnings.t -> unit
val reset: unit -> unit
val echo_eof: unit -> unit
val get_pos_info: Lexing.position -> string * int * int (* file, line, char *)
val print_loc: formatter -> t -> unit
val print : formatter -> t -> unit
val print_compact: formatter -> t -> unit
val print_filename: formatter -> string -> unit
val absolute_path: string -> string
val show_filename: string -> string
(** In -absname mode, return the absolute path for this filename.
Otherwise, returns the filename unchanged. *)
val default_printer : formatter -> t -> unit
(** The default {!formatter} implementation for source locations.
When formatting {!type:t} instances, one should use {!print} instead. *)
val printer : (formatter -> t -> unit) ref
(** The active {!formatter} implementation for source locations *)
(** The type for location-tagged values. *)
type 'a loc = {
txt : 'a; (** The tagged value*)
loc : t; (** The location of the value *)
}
val mknoloc : 'a -> 'a loc
(** Makes a location-tagged value with the dummy location. *)
val mkloc : 'a -> t -> 'a loc
(** Makes a location-tagged value with the given location. *)
(** Support for located errors *)
type error = {
loc: t;
msg: string;
sub: error list;
if_highlight: string; (* alternative message if locations are highlighted *)
}
exception Already_displayed_error
exception Error of error
val error: ?loc:t -> ?sub:error list -> ?if_highlight:string -> string -> error
val errorf: ?loc:t -> ?sub:error list -> ?if_highlight:string
-> ('a, Format.formatter, unit, error) format4 -> 'a
val raise_errorf: ?loc:t -> ?sub:error list -> ?if_highlight:string
-> ('a, Format.formatter, unit, 'b) format4 -> 'a
val error_of_printer: t -> (formatter -> 'a -> unit) -> 'a -> error
val error_of_printer_file: (formatter -> 'a -> unit) -> 'a -> error
val error_of_exn: exn -> [ `Ok of error | `Already_displayed ] option
val register_error_of_exn: (exn -> error option) -> unit
(** Each compiler module which defines a custom type of exception
which can surface as a user-visible error should register
a "printer" for this exception using [register_error_of_exn].
The result of the printer is an [error] value containing
a location, a message, and optionally sub-messages (each of them
being located as well). *)
val report_error: formatter -> error -> unit
val error_reporter : (formatter -> error -> unit) ref
(** Hook for intercepting error reports. *)
val default_error_reporter : formatter -> error -> unit
(** Original error reporter for use in hooks. *)
val report_exception: formatter -> exn -> unit
(** Reraise the exception if it is unknown. *)
View
367 src/parsing/parser.dyp
@@ -0,0 +1,367 @@
{
open Location
open Identifier
open Dyp
open Parsetree
open Ast_helper
(* Used for error messages and as a default, in case anything slips through
without an explicit loc. *)
let first_loc = ref Location.dummy_loc
let last_loc = ref Location.dummy_loc
let dyp_merge = keep_all
let last_state_printer = ref (fun () -> ())
let when_debug ?n thunk =
match n with
| Some(n) ->
if !Grain_utils.Config.parser_debug_level >= n then
thunk()
| None -> ()
let prerr_string s = when_debug ~n:1 (fun () -> Pervasives.prerr_string s)
let debug_print_state () =
when_debug !last_state_printer
let symbol_rloc dyp =
let ret = {
loc_start = dyp.symbol_start_pos ();
loc_end = dyp.symbol_end_pos ();
loc_ghost = false;
} in
last_state_printer := (fun () -> dyp.print_state stderr);
when_debug ~n:1 !last_state_printer;
last_loc := ret;
ret
let symbol_gloc dyp =
let ret = {
loc_start = dyp.symbol_start_pos ();
loc_end = dyp.symbol_end_pos ();
loc_ghost = true;
} in
last_state_printer := (fun () -> dyp.print_state stderr);
when_debug ~n:1 !last_state_printer;
last_loc := ret;
ret
let rhs_loc dyp n =
let ret = {
loc_start = dyp.rhs_start_pos n;
loc_end = dyp.rhs_end_pos n;
loc_ghost = false;
} in
last_state_printer := (fun () -> dyp.print_state stderr);
when_debug ~n:1 !last_state_printer;
last_loc := ret;
ret
let fix_block_mapper super =
let open Ast_mapper in
let expr mapper ({pexp_desc; pexp_loc} as e) =
match pexp_desc with
| PExpBlock([]) -> super.expr mapper e
| PExpBlock(elts) ->
let elts = List.map (mapper.expr mapper) elts in
let pre, last = List.fold_left (fun (acc_l, acc_last) cur ->
match acc_last with
| None -> (acc_l, Some cur)
| Some e -> (e::acc_l, Some cur)) ([], None) elts in
let pre = List.rev pre in
let last = match last with
| None -> raise (Syntaxerr.Error(LetWithoutBody(pexp_loc)))
| Some(l) -> l in
let fixed = List.fold_right (fun ({pexp_desc; pexp_loc; _} as e) acc ->
match pexp_desc with
| PExpLet(r, vbs, {pexp_desc=PExpBlock(b)}) ->
[{e with pexp_desc=PExpLet(r, vbs, Ast_helper.Exp.block ~loc:pexp_loc (b @ acc))}]
| _ -> e::acc) pre [last] in
(match fixed with
| [x] -> x
| _ -> {e with pexp_desc=PExpBlock(fixed)})
| _ -> super.expr mapper e in
{super with expr}
let fix_tyvar_mapper super =
let open Ast_mapper in
let open Ast_helper in
let typ mapper ({ptyp_desc; ptyp_loc} as t) =
match ptyp_desc with
| PTyVar v when (v <> "") && (match v.[0] with 'A'..'Z' -> true | _ -> false) ->
let id = mkloc (IdentName v) ptyp_loc in
{t with ptyp_desc=PTyConstr(id, [])}
| _ -> super.typ mapper t in
{super with typ}
let fix_blocks ({statements; body} as prog) =
let open Ast_mapper in
let mapper = default_mapper
|> fix_block_mapper
|> fix_tyvar_mapper in
{prog with
statements=List.map (mapper.toplevel mapper) statements;
body=mapper.expr mapper body}
let mkid ns =
let help ns =
let rec help ns (acc_ident, acc_str) =
let ident = Option.map_default (fun i -> IdentExternal(i, acc_str)) (IdentName acc_str) acc_ident in
match ns with
| [] -> ident
| n::tl -> help tl (Some ident, n) in
match ns with
| [] -> failwith "Should be impossible"
| n::tl -> help tl (None, n) in
mkloc @@ help ns
let mkstr dyp s = mkloc s (symbol_rloc dyp)
let make_program statements body =
let prog_loc = {
loc_start=(!first_loc).loc_end;
loc_end=(!last_loc).loc_end;
loc_ghost=false;
} in
fix_blocks {statements; body; prog_loc}
}
%relation pe<pt<pp<pb<pc
%token <int> NUM
%token <string> ID
%token <string> TYPEID
%token <string> STRING
%token LBRACK RBRACK LPAREN LPARENNOSPACE RPAREN LBRACE RBRACE LCARET RCARET
%token COMMA SEMI
%token THICKARROW ARROW PIPE
%token EQEQ LESSEQ GREATEREQ
%token EQUAL GETS
%token UNDERSCORE
%token COLON COLONCOLON
%token ADD1 SUB1 ISBOOL ISNUM ISTUPLE
%token PLUS MINUS TIMES
%token TRUE FALSE
%token LET REC IF ELSE MATCH
%token AND OR NOT
%token DATA IMPORT FOREIGN WASM
%token EOF
%start <Parsetree.parsed_program> program
%parser
const :
| NUM { Const.int $1 }
| TRUE { Const.bool true }
| FALSE { Const.bool false }
| STRING { Const.string $1 }
prim1 :
| ADD1 { Add1 }
| SUB1 { Sub1 }
| NOT { Not }
| ISBOOL { IsBool }
| ISNUM { IsNum }
| ISTUPLE { IsTuple }
binop_expr:
| binop_expr(<=pp) PLUS binop_expr(<pp) { prerr_string "\nbinop_expr_plus\n"; when_debug ~n:1 (fun () -> dyp.print_state stderr); Exp.prim2 ~loc:(symbol_rloc dyp) Plus $1 $3 } pp
| binop_expr(<=pp) MINUS binop_expr(<pp) { Exp.prim2 ~loc:(symbol_rloc dyp) Minus $1 $3 } pp
| binop_expr(<=pt) TIMES binop_expr(<pt) { Exp.prim2 ~loc:(symbol_rloc dyp) Times $1 $3 } pt
| binop_expr(<=pc) EQEQ binop_expr(<pc) { Exp.prim2 ~loc:(symbol_rloc dyp) Eq $1 $3 } pc
| binop_expr(<=pc) LCARET binop_expr(<pc) { Exp.prim2 ~loc:(symbol_rloc dyp) Less $1 $3 } pc
| binop_expr(<=pc) RCARET binop_expr(<pc) { Exp.prim2 ~loc:(symbol_rloc dyp) Greater $1 $3 } pc
| binop_expr(<=pc) LESSEQ binop_expr(<pc) { Exp.prim2 ~loc:(symbol_rloc dyp) LessEq $1 $3 } pc
| binop_expr(<=pc) GREATEREQ binop_expr(<pc) { Exp.prim2 ~loc:(symbol_rloc dyp) GreaterEq $1 $3 } pc
| binop_expr(<=pb) AND binop_expr(<pb) { Exp.prim2 ~loc:(symbol_rloc dyp) And $1 $3 } pb
| binop_expr(<=pb) OR binop_expr(<pb) { Exp.prim2 ~loc:(symbol_rloc dyp) Or $1 $3 } pb
| expr { prerr_string "\nbinop_expr\n"; when_debug ~n:1 (fun () -> dyp.print_state stderr); $1 } pe
pattern :
| pattern COLON typ { Pat.constraint_ ~loc:(symbol_rloc dyp) $1 $3 }
| UNDERSCORE { Pat.any ~loc:(symbol_rloc dyp) () }
/* If the pattern uses an external ID, we know it's a constructor, not a variable */
| ext_id { Pat.construct ~loc:(symbol_rloc dyp) $1 [] }
| ID { Pat.var ~loc:(symbol_rloc dyp) (mkstr dyp $1) }
| LPAREN tuple_patterns RPAREN { Pat.tuple ~loc:(symbol_rloc dyp) $2 }
| LPAREN pattern RPAREN { $2 }
| type_id LPAREN tuple_patterns RPAREN { Pat.construct ~loc:(symbol_rloc dyp) $1 $3 }
| type_id { Pat.construct ~loc:(symbol_rloc dyp) $1 [] }
patterns :
| pattern [COMMA pattern {$2}]* { $1::$2 }
tuple_patterns :
| pattern COMMA { [$1] }
| pattern [COMMA pattern {$2}]+ { $1::$2 }
data_typ :
| type_id LCARET typ [COMMA typ {$2}]* RCARET { Typ.constr $1 ($3::$4) }
| type_id { Typ.constr $1 [] }
typ :
/* Convenience: Parens optional for single-argument functions */
| data_typ ARROW typ { Typ.arrow ~loc:(symbol_rloc dyp) [$1] $3 }
| ID ARROW typ { Typ.arrow ~loc:(symbol_rloc dyp) [(Typ.var $1)] $3 }
| LPAREN typs RPAREN ARROW typ { Typ.arrow ~loc:(symbol_rloc dyp) $2 $5 }
| LPAREN tuple_typs RPAREN { Typ.tuple ~loc:(symbol_rloc dyp) $2 }
| LPAREN typ RPAREN { $2 }
| ID { Typ.var $1 }
| data_typ
typs :
| [typ [COMMA typ {$2}]* {$1::$2}]? { Option.default [] $1 }
tuple_typs :
| typ COMMA { [$1] }
| typ [COMMA typ {$2}]+ { $1::$2 }
value_bind :
| pattern EQUAL binop_expr { Vb.mk ~loc:(symbol_rloc dyp) $1 $3 }
value_binds :
| value_bind [COMMA value_bind {$2}]* { $1::$2 }
import_stmt :
| IMPORT id { Imp.mk $2 }
data_constructor :
| TYPEID { CDecl.singleton ~loc:(symbol_rloc dyp) (mkstr dyp $1) }
| TYPEID LPAREN typs RPAREN { CDecl.tuple ~loc:(symbol_rloc dyp) (mkstr dyp $1) $3 }
data_constructors :
| data_constructor [PIPE data_constructor {$2}]* { $1::$2 }
| [PIPE data_constructor {$2}]+ { $1 }
data_declaration :
| DATA TYPEID EQUAL data_constructors { Dat.mk ~loc:(symbol_rloc dyp) (mkstr dyp $2) [] (PDataVariant $4) }
| DATA TYPEID LCARET ID [COMMA ID {$2}]* RCARET EQUAL data_constructors { Dat.mk ~loc:(symbol_rloc dyp) (mkstr dyp $2) (List.map Typ.var ($4::$5)) (PDataVariant $8) }
prim1_expr :
| prim1 LPAREN binop_expr RPAREN { Exp.prim1 ~loc:(symbol_rloc dyp) $1 $3 }
paren_expr :
| LPAREN binop_expr RPAREN { $2 }
app_arg_exprs :
| [binop_expr [COMMA binop_expr {$2}]* { $1::$2 }]? { Option.default [] $1 }
app_expr :
| expr LPAREN app_arg_exprs RPAREN { prerr_string "\napp_expr\n"; when_debug ~n:1 (fun () -> dyp.print_state stderr); Exp.apply ~loc:(symbol_rloc dyp) $1 $3 }
ext_id :
| ID [COLONCOLON TYPEID {$2}]+ { prerr_string "\nid\n"; when_debug ~n:1 (fun () -> dyp.print_state stderr); (mkid ($1::$2)) (symbol_rloc dyp) }
id :
| ID [COLONCOLON ID {$2}]* { prerr_string "\nid\n"; when_debug ~n:1 (fun () -> dyp.print_state stderr); (mkid ($1::$2)) (symbol_rloc dyp) }
type_id :
| TYPEID { prerr_string "\nid\n"; when_debug ~n:1 (fun () -> dyp.print_state stderr); (mkid [$1]) (symbol_rloc dyp) }
simple_expr :
| const { Exp.constant ~loc:(symbol_rloc dyp) $1 }
| id { prerr_string "\nsimple_expr\n"; when_debug ~n:1 (fun () -> dyp.print_state stderr); Exp.ident ~loc:(symbol_rloc dyp) $1 }
| type_id { prerr_string "\nsimple_expr\n"; when_debug ~n:1 (fun () -> dyp.print_state stderr); Exp.ident ~loc:(symbol_rloc dyp) $1 }
| LPAREN tuple_exprs RPAREN { Exp.tuple ~loc:(symbol_rloc dyp) $2 }
block_expr :
| LBRACE block RBRACE { Exp.block ~loc:(symbol_rloc dyp) $2 }
lam_args :
| patterns? { Option.default [] $1 }
lam_expr :
| LPAREN lam_args RPAREN THICKARROW block_expr { Exp.lambda ~loc:(symbol_rloc dyp) $2 $5 }
let_expr :
| LET REC value_binds { Exp.let_ ~loc:(symbol_rloc dyp) Recursive $3 (Exp.block []) }
| LET value_binds { Exp.let_ ~loc:(symbol_rloc dyp) Nonrecursive $2 (Exp.block []) }
if_expr :
| IF binop_expr block_expr { Exp.if_ ~loc:(symbol_rloc dyp) $2 $3 (Exp.block []) }
| IF binop_expr block_expr ELSE block_expr { Exp.if_ ~loc:(symbol_rloc dyp) $2 $3 $5 }
match_branch :
| pattern THICKARROW binop_expr { Mb.mk ~loc:(symbol_rloc dyp) $1 $3 }
match_branches :
| [PIPE match_branch {$2}]+ { $1 }
match_expr :
| MATCH LPAREN expr RPAREN LBRACE match_branches RBRACE { Exp.match_ ~loc:(symbol_rloc dyp) $3 $6 }
expr :
| app_expr { prerr_string "\nexpr_app_expr\n"; when_debug ~n:1 (fun () -> dyp.print_state stderr); $1 }
| simple_expr { prerr_string "\nexpr_simple_expr\n"; when_debug ~n:1 (fun () -> dyp.print_state stderr); $1 }
| paren_expr { $1 }
| prim1_expr { $1 }
| block_expr { $1 }
| lam_expr { $1 }
| if_expr { $1 }
| match_expr { $1 }
block_body_expr :
| let_expr { $1 }
| binop_expr { $1 }
tuple_exprs :
| binop_expr COMMA { [$1] }
| binop_expr [COMMA binop_expr {$2}]+ { $1::$2 }
block :
| block_body_expr [SEMI block_body_expr {$2}]* { $1::$2 }
id_str :
| ID { Location.mkloc $1 (symbol_rloc dyp) }
foreign_stmt :
| FOREIGN WASM id_str id_str COLON typ { Val.mk ~loc:(symbol_rloc dyp) ~mod_:$3 ~name:$4 ~typ:$6 ~prim:[$4.txt] }
toplevel_stmt :
| LET REC value_binds { Top.let_ Recursive $3 }
| LET value_binds { Top.let_ Nonrecursive $2 }
| foreign_stmt { Top.foreign ~loc:(symbol_rloc dyp) $1 }
| import_stmt { Top.import $1 }
| data_declaration { Top.data $1 }
toplevel_stmts :
| toplevel_stmt [SEMI toplevel_stmt {$2}]* { $1::$2 }
program :
| toplevel_stmts SEMI EOF { make_program $1 (Exp.null ~loc:dummy_loc ()) }
| toplevel_stmts SEMI binop_expr EOF { make_program $1 $3 }
| binop_expr EOF { prerr_string "\nprogram\n"; when_debug ~n:1 (fun () -> dyp.print_state stderr); make_program [] $1 }
%%
{
let parse_program t lexbuf =
Dyp.dypgen_verbose := !Grain_utils.Config.parser_debug_level;
first_loc := Location.curr lexbuf;
with_default_loc_src (fun() -> !last_loc) (fun() -> program t lexbuf)
let print_syntax_error =
let open Printf in
let open Location in
function
| Syntax_error -> begin
debug_print_state();
Some(errorf ~loc:(!last_loc) "Syntax error")
end
| _ -> None
let () =
Dyp.dypgen_verbose := !Grain_utils.Config.parser_debug_level;
Location.register_error_of_exn print_syntax_error
}
%mli {
val parse_program : Lexing.lexbuf -> ((Parsetree.parsed_program * 'a) list)
}
View
171 src/parsing/parsetree.ml
@@ -0,0 +1,171 @@
(** Parse tree type definitions. This is a reformulation
of our original parse tree which better aligns with the design
of the OCaml parse tree. Credit for the module's architecture goes to
the OCaml team. *)
open Sexplib.Conv
open Asttypes
type 'a loc = 'a Asttypes.loc = {
txt: 'a;
loc: Location.t;
}
type rec_flag = Asttypes.rec_flag = Nonrecursive | Recursive
(** Type for syntax-level types *)
type parsed_type_desc =
| PTyAny
| PTyVar of string
| PTyArrow of parsed_type list * parsed_type
| PTyTuple of parsed_type list
| PTyConstr of (Identifier.t loc) * parsed_type list
| PTyPoly of string loc list * parsed_type
[@@deriving sexp]
and parsed_type = {
ptyp_desc: parsed_type_desc;
ptyp_loc: Location.t [@sexp_drop_if fun _ -> not !Grain_utils.Config.sexp_locs_enabled];
}
(** Type for arguments to a constructor *)
type constructor_arguments =
| PConstrTuple of parsed_type list
| PConstrSingleton
[@@deriving sexp]
(** Type for branches within data declarations *)
type constructor_declaration = {
pcd_name: string loc;
pcd_args: constructor_arguments;
pcd_loc: Location.t [@sexp_drop_if fun _ -> not !Grain_utils.Config.sexp_locs_enabled];
} [@@deriving sexp]
(** Different types of data which can be declared. Currently only one. *)
type data_kind =
| PDataVariant of constructor_declaration list
[@@deriving sexp]
(** Type for data declarations. *)
type data_declaration = {
pdata_name: string loc;
pdata_params: parsed_type list;
pdata_kind: data_kind;
pdata_loc: Location.t [@sexp_drop_if fun _ -> not !Grain_utils.Config.sexp_locs_enabled];
} [@@deriving sexp]
(** Constants supported by Grain *)
type constant =
| PConstNumber of int
| PConstBool of bool
| PConstString of string
[@@deriving sexp]
(** Various binding forms *)
type pattern_desc =
| PPatAny
| PPatVar of string loc
| PPatTuple of pattern list
| PPatConstant of constant
| PPatConstraint of pattern * parsed_type
| PPatConstruct of Identifier.t loc * pattern list
| PPatOr of pattern * pattern
| PPatAlias of pattern * string loc
[@@deriving sexp]
and pattern = {
ppat_desc: pattern_desc;
ppat_loc: Location.t [@sexp_drop_if fun _ -> not !Grain_utils.Config.sexp_locs_enabled];
} [@@deriving sexp]
(** Single-argument operators *)
type prim1 =
| Add1
| Sub1
| Not
| IsNum
| IsBool
| IsTuple
[@@deriving sexp]
(** Two-argument operators *)
type prim2 =
| Plus
| Minus
| Times
| Less
| Greater
| LessEq
| GreaterEq
| Eq
| And
| Or
[@@deriving sexp]
(** Type for expressions (i.e. things which evaluate to something) *)
type expression = {
pexp_desc: expression_desc;
pexp_loc: Location.t [@sexp_drop_if fun _ -> not !Grain_utils.Config.sexp_locs_enabled];
} [@@deriving sexp]
and expression_desc =
| PExpId of Identifier.t loc
| PExpConstant of constant
| PExpTuple of expression list
| PExpLet of rec_flag * value_binding list * expression
| PExpMatch of expression * match_branch list
| PExpPrim1 of prim1 * expression
| PExpPrim2 of prim2 * expression * expression
| PExpIf of expression * expression * expression
| PExpLambda of pattern list * expression
| PExpApp of expression * expression list
| PExpBlock of expression list
| PExpNull (** Used for modules without body expressions *)
[@@deriving sexp]
(** let-binding form *)
and value_binding = {
pvb_pat: pattern;
pvb_expr: expression;
pvb_loc: Location.t [@sexp_drop_if fun _ -> not !Grain_utils.Config.sexp_locs_enabled];
} [@@deriving sexp]
and match_branch = {
pmb_pat: pattern;
pmb_body: expression;
pmb_loc: Location.t [@sexp_drop_if fun _ -> not !Grain_utils.Config.sexp_locs_enabled];
} [@@deriving sexp]
(** Type for import statements *)
type import_declaration = {
pimp_mod: Identifier.t loc;
pimp_loc: Location.t [@sexp_drop_if fun _ -> not !Grain_utils.Config.sexp_locs_enabled];
} [@@deriving sexp]
type value_description = {
pval_mod: string loc;
pval_name: string loc;
pval_type: parsed_type;
pval_prim: string list;
pval_loc: Location.t [@sexp_drop_if fun _ -> not !Grain_utils.Config.sexp_locs_enabled];
} [@@deriving sexp]
(** Statements which can exist at the top level *)
type toplevel_stmt_desc =
| PTopForeign of value_description
| PTopImport of import_declaration
| PTopData of data_declaration
| PTopLet of rec_flag * value_binding list
[@@deriving sexp]
type toplevel_stmt = {
ptop_desc: toplevel_stmt_desc;
ptop_loc: Location.t [@sexp_drop_if fun _ -> not !Grain_utils.Config.sexp_locs_enabled];
} [@@deriving sexp]
(** The type for parsed programs *)
type parsed_program = {
statements: toplevel_stmt list;
body: expression;
prog_loc: Location.t [@sexp_drop_if fun _ -> not !Grain_utils.Config.sexp_locs_enabled];
} [@@deriving sexp]
View
26 src/parsing/syntaxerr.ml
@@ -0,0 +1,26 @@
(* See copyright information in syntaxerr.mli *)
type stxerr =
| LetWithoutBody of Location.t
| Other of Location.t
exception Error of stxerr
let prepare_error = function
| LetWithoutBody loc ->
Location.errorf ~loc "Missing expression after let binding"
| Other loc ->
Location.errorf ~loc "Syntax error"
let () =
Location.register_error_of_exn
(function
| Error err -> Some (prepare_error err)
| _ -> None
)
let location_of_error = function
| LetWithoutBody l
| Other l -> l
View
23 src/parsing/syntaxerr.mli
@@ -0,0 +1,23 @@
(* This file is largely copied from OCaml's parsing/syntaxerr.mli file. The original copyright is reproduced below. *)
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1997 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
type stxerr =
| LetWithoutBody of Location.t
| Other of Location.t
exception Error of stxerr
val location_of_error: stxerr -> Location.t
View
103 src/parsing/well_formedness.ml
@@ -0,0 +1,103 @@
open Parsetree
open Ast_iterator
open Grain_utils
type wferr =
| MalformedString of Location.t
| MultipleModuleName of Location.t
| TypeNameShouldBeUppercase of string * Location.t
| TyvarNameShouldBeLowercase of string * Location.t
exception Error of wferr
let prepare_error =
let open Printf in
let open Location in
function
| MalformedString loc ->
errorf ~loc "Malformed string literal"
| MultipleModuleName loc ->
errorf ~loc "Multiple modules in identifier"
| TypeNameShouldBeUppercase(name, loc) ->
errorf ~loc "Type '%s' should have an uppercase name." name
| TyvarNameShouldBeLowercase(var, loc) ->
errorf ~loc "Type variable '%s' should be lowercase." var
let () =
Location.register_error_of_exn
(function
| Error err -> Some (prepare_error err)
| _ -> None
)
type well_formedness_checker = {
errs : wferr list ref;
iterator : iterator;
}
let malformed_strings errs super =
let iter_expr self ({pexp_desc=desc; pexp_loc=loc} as e) =
begin
match desc with
| PExpConstant(PConstString s) ->
begin
try
BatUTF8.validate s
with
| BatUTF8.Malformed_code ->
errs := (MalformedString loc)::!errs
end
| _ -> ()
end;
super.expr self e in
let iterator = { super with
expr = iter_expr } in
{ errs; iterator }
let malformed_identifiers errs super =
let open Identifier in
let iter_expr self ({pexp_desc=desc; pexp_loc=loc} as e) =
begin
match desc with
| PExpId {txt=(IdentExternal(IdentExternal _, _))} ->
errs := (MultipleModuleName loc)::!errs
| _ -> ()
end;
super.expr self e in
let iterator = { super with expr = iter_expr } in
{ errs; iterator }
let types_have_correct_case errs super =
let check_uppercase loc s =
let first_char = String.get s 0 in
if first_char <> BatChar.uppercase first_char then
errs := (TypeNameShouldBeUppercase(s, loc))::!errs in
let iter_data self ({pdata_name={loc=name_loc; txt=name}; pdata_loc=loc; _} as d) =
check_uppercase name_loc name;
super.data self d in
(* FIXME: The parser should read in uppercase types as PTyConstr instances *)
let iterator = { super with data = iter_data } in
{ errs; iterator }
let compose_well_formedness { errs; iterator } cur =
cur errs iterator
let well_formedness_checks = [
malformed_strings;
malformed_identifiers;
types_have_correct_case;
]
let well_formedness_checker() =
List.fold_left
compose_well_formedness
{errs=ref []; iterator=default_iterator}
well_formedness_checks
let check_well_formedness {statements; body} =
let checker = well_formedness_checker() in
List.iter (checker.iterator.toplevel checker.iterator) statements;
checker.iterator.expr checker.iterator body;
(* FIXME: We should be able to raise _all_ errors at once *)
List.iter (fun e -> raise (Error e)) !(checker.errs)
Oops, something went wrong.