740 lines
24 KiB
OCaml
740 lines
24 KiB
OCaml
open Simple_utils
|
|
|
|
type 'a name = {
|
|
content : 'a ;
|
|
name : string ;
|
|
}
|
|
|
|
let make_name name content = { name ; content }
|
|
let destruct {name ; content} = (name, content)
|
|
let get_name x = x.name
|
|
let get_content x = x.content
|
|
|
|
module Token = Lex.Token
|
|
type token = Token.token
|
|
|
|
module O = struct
|
|
|
|
type list_mode =
|
|
| Trail of token
|
|
| Trail_option of token
|
|
| Trail_force of token
|
|
| Trail_force_ne of token
|
|
| Lead of token
|
|
| Lead_ne of token
|
|
| Separated of token
|
|
| Separated_ne of token
|
|
| Separated_nene of token
|
|
| Naked
|
|
| Naked_ne
|
|
|
|
type 'a list_element = list_mode * 'a
|
|
|
|
type rhs_element = [
|
|
| `Named of string
|
|
| `Token of token
|
|
| `List of string list_element
|
|
| `Option of string
|
|
]
|
|
|
|
type rhs = rhs_element list name
|
|
type rule = rhs list name
|
|
|
|
type manual_rule_content = {
|
|
menhir_codes : string list ;
|
|
ast_code : string ;
|
|
}
|
|
type manual_rule = manual_rule_content name
|
|
|
|
type singleton =
|
|
| Manual of manual_rule
|
|
| Generated of rule
|
|
|
|
type name_element = [
|
|
| `Named of string
|
|
| `Current
|
|
| `Lower
|
|
]
|
|
|
|
type element = [
|
|
| `Named of string
|
|
| `Token of token
|
|
| `List of name_element list_element
|
|
| `Current
|
|
| `Lower
|
|
]
|
|
|
|
type operator = element list
|
|
type n_operator = operator name
|
|
|
|
type n_operators = n_operator list
|
|
type level = n_operators name
|
|
type level_list = level list
|
|
type levels = level List.Ne.t
|
|
|
|
type hierarchy = {
|
|
prefix : string ;
|
|
levels : levels ;
|
|
auxiliary_rules : rule list ;
|
|
}
|
|
type n_hierarchy = hierarchy name
|
|
let make_hierarchy prefix levels auxiliary_rules : hierarchy = { levels ; auxiliary_rules ; prefix }
|
|
|
|
type language = {
|
|
entry_point : string ;
|
|
singletons : singleton list ;
|
|
hierarchies : n_hierarchy list ;
|
|
}
|
|
|
|
let get_op : n_operator -> operator = get_content
|
|
|
|
let manual_singleton name menhir_codes ast_code : singleton = Manual (make_name name {menhir_codes ; ast_code})
|
|
let rule_singleton rule : singleton = Generated rule
|
|
let language entry_point singletons hierarchies = {entry_point ; singletons ; hierarchies}
|
|
|
|
let name_hierarchy name prefix : n_operators list -> rule list -> n_hierarchy = fun nopss rules ->
|
|
let nopss' = List.Ne.of_list nopss in
|
|
let name_i : int -> n_operators -> level = fun i x ->
|
|
let first = get_name (List.hd x) in
|
|
let name' = Format.asprintf "%s_%d_%s" name i first in
|
|
make_name name' x in
|
|
let levels : levels = List.Ne.mapi name_i nopss' in
|
|
make_name name @@ make_hierarchy prefix levels rules
|
|
|
|
end
|
|
|
|
module Check = struct
|
|
open O
|
|
|
|
let well_formed : language -> unit = fun l ->
|
|
let elements : element list -> unit = fun es ->
|
|
let rec aux = fun es ->
|
|
match es with
|
|
| [] -> ()
|
|
| [ _ ] -> ()
|
|
| (`List _ | `Named _ | `Current | `Lower) :: (`List _ | `Named _ | `Current | `Lower) :: _ ->
|
|
raise (Failure "two non-token separated ops in a row")
|
|
| _ :: tl -> aux tl
|
|
in
|
|
(if (List.length es < 2) then raise (Failure "operator is too short")) ;
|
|
aux es in
|
|
let op : n_operator -> unit = fun x -> elements @@ get_content x in
|
|
let level : level -> unit = fun l -> List.iter op @@ get_content l in
|
|
let hierarchy : n_hierarchy -> unit = fun h -> List.Ne.iter level @@ h.content.levels in
|
|
List.iter hierarchy l.hierarchies
|
|
|
|
let associativity : language -> unit = fun l ->
|
|
let level : level -> unit = fun l ->
|
|
let aux : ([`Left | `Right | `None] as 'a) -> n_operator -> 'a = fun ass nop ->
|
|
let op = get_content nop in
|
|
match ass, List.hd op, List.nth op (List.length op - 1) with
|
|
| _, `Lower, `Lower -> raise (Failure "double assoc")
|
|
| `None, `Lower, _ -> `Left
|
|
| `None, _, `Lower -> `Right
|
|
| `Left, _, `Lower -> raise (Failure "different assocs")
|
|
| `Right, `Lower, _ -> raise (Failure "different assocs")
|
|
| m, _, _ -> m
|
|
in
|
|
let _assert = List.fold_left aux `None (get_content l) in
|
|
()
|
|
in
|
|
let hierarchy : n_hierarchy -> unit = fun h ->
|
|
List.Ne.iter level h.content.levels in
|
|
List.iter hierarchy l.hierarchies
|
|
|
|
end
|
|
|
|
|
|
let make_constructor : _ -> (string * string) -> unit = fun ppf (gr, rhs) ->
|
|
let gr = String.capitalize_ascii gr in
|
|
match rhs with
|
|
| "" -> Format.fprintf ppf "%s" gr
|
|
| s -> Format.fprintf ppf "%s_%s" gr s
|
|
|
|
let make_operator : _ -> (string * string) -> unit = fun ppf (prefix, op) ->
|
|
Format.fprintf ppf "%s_%s" prefix op
|
|
|
|
module Print_AST = struct
|
|
open Format
|
|
open PP_helpers
|
|
|
|
let manual_rule : _ -> O.manual_rule -> _ = fun ppf mr ->
|
|
fprintf ppf "%s = %s" mr.name mr.content.ast_code
|
|
|
|
let generated_rule : _ -> O.rule -> _ = fun ppf gr ->
|
|
let aux : _ -> O.rhs -> _ = fun ppf rhs ->
|
|
let type_elements =
|
|
let aux : O.rhs_element -> string option = fun e ->
|
|
match e with
|
|
| `Named s -> Some (s ^ " Location.wrap")
|
|
| `List ( _, s) -> Some ("(" ^ s ^ " Location.wrap list)")
|
|
| `Option s -> Some ("(" ^ s ^ " Location.wrap option)")
|
|
| `Token _ -> None
|
|
in
|
|
List.filter_map aux rhs.content in
|
|
let type_element = fun ppf te -> fprintf ppf "%s" te in
|
|
fprintf ppf "| %a of (%a)"
|
|
make_constructor (gr.name, rhs.name)
|
|
(list_sep type_element (const " * ")) type_elements
|
|
in
|
|
fprintf ppf "%s =@. @[<v>%a@]" gr.name
|
|
(list_sep aux new_line) gr.content
|
|
|
|
let singleton : _ -> O.singleton -> _ = fun ppf s ->
|
|
match s with
|
|
| Manual s -> manual_rule ppf s
|
|
| Generated s -> generated_rule ppf s
|
|
|
|
let singletons : _ -> O.singleton list -> _ = fun ppf ss ->
|
|
match ss with
|
|
| [] -> ()
|
|
| hd :: tl ->
|
|
fprintf ppf "%a\n" (prepend "type " (singleton)) hd ;
|
|
fprintf ppf "%a" (list_sep (prepend "and " (singleton)) (const "\n")) tl
|
|
|
|
let n_operator prefix level_name : _ -> O.n_operator -> _ = fun ppf nop ->
|
|
let type_elements =
|
|
let aux : O.element -> string option = fun e ->
|
|
match e with
|
|
| `Named s -> Some (s ^ " Location.wrap")
|
|
| `List ( _, s) -> Some ("(" ^ (match s with
|
|
| `Lower | `Current -> level_name |`Named s -> s
|
|
) ^ " Location.wrap list)")
|
|
| `Token _ -> None
|
|
| `Current | `Lower -> Some (level_name ^ " Location.wrap") in
|
|
List.filter_map aux (get_content nop) in
|
|
let type_element = fun ppf te -> fprintf ppf "%s" te in
|
|
fprintf ppf "| %a of (%a)"
|
|
make_operator (prefix, nop.name)
|
|
(list_sep type_element (const " * ")) type_elements
|
|
|
|
let n_hierarchy t : _ -> O.n_hierarchy -> _ = fun ppf nh ->
|
|
let levels = List.Ne.map get_content ((get_content nh).levels) in
|
|
let nops = List.Ne.concat levels in
|
|
let name = get_name nh in
|
|
fprintf ppf "%s %s =@.@[%a@] [@@@@deriving show]" t
|
|
name
|
|
(list_sep (n_operator nh.content.prefix name) new_line) nops
|
|
|
|
let n_hierarchies (first:bool) : _ -> O.n_hierarchy list -> _ = fun ppf ss ->
|
|
match ss with
|
|
| [] -> ()
|
|
| hd :: tl ->
|
|
fprintf ppf "%a\n" (n_hierarchy (if first then "type" else "and")) hd ;
|
|
fprintf ppf "%a" (list_sep (n_hierarchy "and") (const "\n")) tl
|
|
|
|
let language : _ -> O.language -> _ = fun ppf l ->
|
|
fprintf ppf "%a@.@." comment "Language" ;
|
|
let first = List.length l.singletons = 0 in
|
|
fprintf ppf " %a@.%a@.@." comment "Singletons" singletons l.singletons ;
|
|
fprintf ppf " %a@.%a@." comment "Hierarchies" (n_hierarchies first) l.hierarchies ;
|
|
fprintf ppf " %a@.type entry_point = %s Location.wrap@.@." comment "Entry point" l.entry_point ;
|
|
()
|
|
end
|
|
|
|
module Print_Grammar = struct
|
|
open Format
|
|
open PP_helpers
|
|
|
|
let letters = [| "a" ; "b" ; "c" ; "d" ; "e" ; "f" ; "g" ; "h" ; "i" ; "j" |]
|
|
|
|
|
|
let manual_rule : _ -> O.manual_rule -> _ = fun ppf mr ->
|
|
let {name;content} = mr in
|
|
fprintf ppf "%s:@. @[<v>%a@]" name (list_sep string new_line) content.menhir_codes
|
|
|
|
let generated_rule : _ -> O.rule -> _ = fun ppf gr ->
|
|
let aux_rule : _ -> O.rhs -> _ = fun ppf rhs ->
|
|
let i = ref 0 in
|
|
let aux : _ -> O.rhs_element -> _ = fun ppf e ->
|
|
(match e with
|
|
| `Named s -> fprintf ppf "%s = wrap(%s)" letters.(!i) s
|
|
| `Option s -> fprintf ppf "%s = option(wrap(%s))" letters.(!i) s
|
|
| `List (mode, s) ->
|
|
fprintf ppf "%s = %swrap(%s))"
|
|
letters.(!i)
|
|
(match mode with
|
|
| Naked -> "naked_list("
|
|
| Naked_ne -> "naked_list_ne("
|
|
| Lead s -> "lead_list(" ^ (Token.to_string s) ^ ","
|
|
| Lead_ne s -> "lead_list_ne(" ^ (Token.to_string s) ^ ","
|
|
| Trail s -> "trail_list(" ^ (Token.to_string s) ^ ","
|
|
| Trail_option s -> "trail_option_list(" ^ (Token.to_string s) ^ ","
|
|
| Trail_force s -> "trail_force_list(" ^ (Token.to_string s) ^ ","
|
|
| Trail_force_ne s -> "trail_force_list_ne(" ^ (Token.to_string s) ^ ","
|
|
| Separated s -> "separated_list(" ^ (Token.to_string s) ^ ","
|
|
| Separated_ne s -> "separated_list_ne(" ^ (Token.to_string s) ^ ","
|
|
| Separated_nene s -> "separated_list_nene(" ^ (Token.to_string s) ^ ","
|
|
)
|
|
s
|
|
| `Token t -> i := !i - 1 ; string ppf @@ Token.to_string t) ;
|
|
i := !i + 1
|
|
in
|
|
fprintf ppf "%a" (list_sep aux (const " ")) rhs.content in
|
|
let aux_code : _ -> O.rhs -> _ = fun ppf rhs ->
|
|
let i = ref 0 in
|
|
let aux : O.rhs_element -> _ = fun e ->
|
|
let s = (match e with
|
|
| `Named _ | `List _ | `Option _ -> Some (letters.(!i))
|
|
| `Token _ -> i := !i - 1 ; None) in
|
|
i := !i + 1 ; s
|
|
in
|
|
let content = List.filter_map aux rhs.content in
|
|
fprintf ppf "%a (%a)" make_constructor (gr.name, rhs.name) (list_sep string (const " , ")) content
|
|
in
|
|
let aux : _ -> O.rhs -> _ = fun ppf rhs ->
|
|
fprintf ppf "| %a { %a }"
|
|
aux_rule rhs
|
|
aux_code rhs in
|
|
fprintf ppf "%s:@.%a" gr.name (list_sep aux (const "\n")) gr.content
|
|
|
|
let singleton : _ -> O.singleton -> _ = fun ppf s ->
|
|
match s with
|
|
| Manual s -> manual_rule ppf s
|
|
| Generated s -> generated_rule ppf s
|
|
|
|
|
|
let n_operator_rule prev_lvl_name cur_lvl_name : _ -> O.n_operator -> _ = fun ppf nop ->
|
|
let i = ref 0 in
|
|
let element : _ -> O.element -> _ = fun ppf element ->
|
|
(match element with
|
|
| `Token t -> i := !i - 1 ; string ppf @@ Token.to_string t
|
|
| `List (mode, content) ->
|
|
fprintf ppf "%s = %swrap(%s))"
|
|
letters.(!i)
|
|
(match mode with
|
|
| Naked -> "naked_list("
|
|
| Naked_ne -> "naked_list_ne("
|
|
| Lead s -> "lead_list(" ^ (Token.to_string s) ^ ","
|
|
| Lead_ne s -> "lead_list_ne(" ^ (Token.to_string s) ^ ","
|
|
| Trail s -> "trail_list(" ^ (Token.to_string s) ^ ","
|
|
| Trail_option s -> "trail_option_list(" ^ (Token.to_string s) ^ ","
|
|
| Trail_force s -> "trail_force_list(" ^ (Token.to_string s) ^ ","
|
|
| Trail_force_ne s -> "trail_force_list_ne(" ^ (Token.to_string s) ^ ","
|
|
| Separated s -> "separated_list(" ^ (Token.to_string s) ^ ","
|
|
| Separated_ne s -> "separated_list_ne(" ^ (Token.to_string s) ^ ","
|
|
| Separated_nene s -> "separated_list_nene(" ^ (Token.to_string s) ^ ","
|
|
)
|
|
(match content with | `Lower -> prev_lvl_name | `Named s -> s | `Current -> cur_lvl_name)
|
|
| `Named n ->
|
|
fprintf ppf "%s = wrap(%s)" letters.(!i) n
|
|
| `Current ->
|
|
fprintf ppf "%s = wrap(%s)" letters.(!i) cur_lvl_name
|
|
| `Lower ->
|
|
fprintf ppf "%s = wrap(%s)" letters.(!i) prev_lvl_name
|
|
) ;
|
|
i := !i + 1
|
|
in
|
|
(list_sep element (const " ")) ppf (get_content nop)
|
|
|
|
let n_operator_code prefix : _ -> O.n_operator -> _ = fun ppf nop ->
|
|
let (name, elements) = destruct nop in
|
|
let elements' =
|
|
let i = ref 0 in
|
|
let aux : O.element -> _ = fun e ->
|
|
let r =
|
|
match e with
|
|
| `Token _ -> i := !i - 1 ; None
|
|
| `List _ | `Named _ | `Current | `Lower -> Some letters.(!i)
|
|
in i := !i + 1 ; r
|
|
in
|
|
List.filter_map aux elements in
|
|
fprintf ppf "%a (%a)" make_operator (prefix, name) (list_sep string (const " , ")) elements'
|
|
|
|
let n_operator prefix prev_lvl_name cur_lvl_name : _ -> O.n_operator -> _ = fun ppf nop ->
|
|
let name = get_name nop in
|
|
fprintf ppf "%a@;| %a { %a }" comment name
|
|
(n_operator_rule prev_lvl_name cur_lvl_name) nop
|
|
(n_operator_code prefix) nop
|
|
|
|
let level prefix prev_lvl_name : _ -> O.level -> _ = fun ppf l ->
|
|
let name = get_name l in
|
|
match prev_lvl_name with
|
|
| "" -> (
|
|
fprintf ppf "%s :@. @[<v>%a@]" name
|
|
(list_sep (n_operator prefix prev_lvl_name name) new_line) (get_content l) ;
|
|
)
|
|
| _ -> (
|
|
fprintf ppf "%s :@. @[<v>%a@;| %s { $1 }@]" name
|
|
(list_sep (n_operator prefix prev_lvl_name name) new_line) (get_content l)
|
|
prev_lvl_name
|
|
)
|
|
|
|
let n_hierarchy : _ -> O.n_hierarchy -> _ = fun ppf nh ->
|
|
let name = get_name nh in
|
|
let top_level = get_name @@ List.Ne.hd nh.content.levels in
|
|
fprintf ppf "%a@.%%inline %s : %s { $1 }@.@;" comment ("Top-level for " ^ name) name top_level;
|
|
let (hd, tl) = List.Ne.rev (get_content nh).levels in
|
|
fprintf ppf "%a" (level nh.content.prefix "") hd ;
|
|
let aux prev_name lvl =
|
|
new_lines 2 ppf () ;
|
|
fprintf ppf "%a" (level nh.content.prefix prev_name) lvl ;
|
|
get_name lvl
|
|
in
|
|
let _last_name = List.fold_left aux (get_name hd) tl in
|
|
()
|
|
|
|
let language : _ -> O.language -> _ = fun ppf l ->
|
|
fprintf ppf "%a@.@." comment "Generated Language" ;
|
|
fprintf ppf "entry_point : wrap(%s) EOF { $1 }@.@." l.entry_point ;
|
|
fprintf ppf "%a@.@." comment "Singletons" ;
|
|
fprintf ppf "@[%a@]@.@." (list_sep singleton new_line) l.singletons ;
|
|
fprintf ppf "%a@.@." comment "Hierarchies" ;
|
|
fprintf ppf "@[%a@]" (list_sep n_hierarchy new_line) l.hierarchies ;
|
|
|
|
end
|
|
|
|
|
|
let infix : string -> [`Left | `Right] -> token -> O.n_operator = fun name assoc t ->
|
|
match assoc with
|
|
| `Left -> make_name name [`Current ; `Token t ; `Lower]
|
|
| `Right -> make_name name [`Lower ; `Token t ; `Current]
|
|
|
|
(* Ocaml is bad *)
|
|
let empty_infix : string -> [`Left | `Right] -> O.n_operator = fun name assoc ->
|
|
match assoc with
|
|
| `Left -> make_name name [`Current ; `Lower]
|
|
| `Right -> make_name name [`Lower ; `Current]
|
|
|
|
|
|
let paren : string -> string -> O.n_operator = fun constructor_name name ->
|
|
make_name constructor_name [`Token Token.LPAREN ; `Named name ; `Token Token.RPAREN]
|
|
|
|
let expression_name = "expression"
|
|
let type_expression_name = "type_expression"
|
|
let restricted_type_expression_name = "restricted_type_expression"
|
|
let program_name = "program"
|
|
let variable_name = "variable"
|
|
let pattern_name = "pattern"
|
|
let constructor_name = "constructor"
|
|
let int_name = "int_"
|
|
let tz_name = "tz_"
|
|
let unit_name = "unit_"
|
|
let string_name = "string_"
|
|
|
|
let variable = O.manual_singleton variable_name ["| NAME { $1 }"] "string"
|
|
let int = O.manual_singleton int_name ["| INT { $1 }"] "int"
|
|
let tz = O.manual_singleton tz_name ["| TZ { $1 }"] "int"
|
|
let unit = O.manual_singleton unit_name ["| UNIT { () }"] "unit"
|
|
let string = O.manual_singleton string_name ["| STRING { $1 }"] "string"
|
|
let constructor = O.manual_singleton constructor_name ["| CONSTRUCTOR_NAME { $1 }"] "string"
|
|
|
|
module Pattern = struct
|
|
|
|
open Token
|
|
open O
|
|
|
|
let application = empty_infix "application" `Left
|
|
|
|
let data_structure : O.n_operator = make_name "data_structure" [
|
|
`Named variable_name ; `Token LSQUARE ; `List (Lead SEMICOLON, `Current) ; `Token RSQUARE ;
|
|
]
|
|
|
|
let record_element : O.rule = make_name "p_record_element" [
|
|
make_name "" [`Named variable_name ; `Token EQUAL ; `Named pattern_name]
|
|
]
|
|
|
|
let record : O.n_operator = make_name "record" [
|
|
`Token LBRACKET ;
|
|
`List (Trail SEMICOLON, `Named record_element.name) ;
|
|
`Token RBRACKET ;
|
|
]
|
|
|
|
let pair = infix "pair" `Left COMMA
|
|
let type_annotation = make_name "type_annotation" [
|
|
`Current ; `Token COLON ; `Named restricted_type_expression_name
|
|
]
|
|
|
|
let variable : O.n_operator = make_name "variable" [ `Named variable_name ]
|
|
let constructor : O.n_operator = make_name "constructor" [ `Named constructor_name ]
|
|
|
|
let module_ident : O.n_operator = make_name "module_ident" [
|
|
`List (Trail_force_ne DOT, `Named constructor_name) ; `Named variable_name ;
|
|
]
|
|
|
|
let unit : O.n_operator = make_name "unit" [ `Named unit_name ]
|
|
|
|
let restricted_pattern_name = "restricted_pattern"
|
|
|
|
let restricted_pattern = O.name_hierarchy restricted_pattern_name "Pr" [
|
|
[variable ; unit] ;
|
|
[paren "restrict" pattern_name]
|
|
] []
|
|
|
|
let main = O.name_hierarchy pattern_name "P" [
|
|
[record] ;
|
|
[type_annotation] ;
|
|
[pair] ;
|
|
[data_structure] ;
|
|
[application] ;
|
|
[variable ; constructor ; module_ident ; unit] ;
|
|
[paren "paren" pattern_name]
|
|
] []
|
|
|
|
let singletons = [O.rule_singleton record_element]
|
|
end
|
|
|
|
module Expression = struct
|
|
|
|
open Token
|
|
open O
|
|
|
|
let application = empty_infix "application" `Right
|
|
|
|
let type_annotation = make_name "type_annotation" [
|
|
`Current ; `Token COLON ; `Named restricted_type_expression_name
|
|
]
|
|
|
|
let data_structure : O.n_operator = make_name "data_structure" [
|
|
`Named variable_name ; `Token LSQUARE ; `List (Trail SEMICOLON, `Current) ; `Token RSQUARE ;
|
|
]
|
|
|
|
let fun_ : O.n_operator = make_name "fun" [
|
|
`Token FUN ; `Named pattern_name ;
|
|
`Token ARROW ; `Current ;
|
|
]
|
|
|
|
let let_in : O.n_operator = make_name "let_in" [
|
|
`Token LET ; `Named pattern_name ;
|
|
`Token EQUAL ; `Current ;
|
|
`Token IN ; `Current ;
|
|
]
|
|
|
|
let no_seq_name = "expression_no_seq"
|
|
let no_match_name = "expression_no_match"
|
|
|
|
let record_element : O.rule = make_name "e_record_element" [
|
|
make_name "record_explicit" [`Named variable_name ; `Token EQUAL ; `Named no_seq_name] ;
|
|
make_name "record_implicit" [`Named variable_name ] ;
|
|
]
|
|
|
|
let record : O.n_operator = make_name "record" [
|
|
`Token LBRACKET ;
|
|
`List (Trail SEMICOLON, `Named record_element.name) ;
|
|
`Token RBRACKET ;
|
|
]
|
|
|
|
let ite : O.n_operator = make_name "ifthenelse" [
|
|
`Token IF ;
|
|
`Current ;
|
|
`Token THEN ;
|
|
`Lower ;
|
|
`Token ELSE ;
|
|
`Current ;
|
|
]
|
|
|
|
let it : O.n_operator = make_name "ifthen" [
|
|
`Token IF ;
|
|
`Current ;
|
|
`Token THEN ;
|
|
`Lower ;
|
|
]
|
|
|
|
(* let sequence = infix "sequence" `Left SEMICOLON *)
|
|
let sequence = make_name "sequence" [
|
|
`List (Separated_nene SEMICOLON , `Lower)
|
|
]
|
|
|
|
let match_clause = make_name "e_match_clause" [
|
|
make_name "" [`Named pattern_name ; `Token ARROW ; `Named no_match_name]
|
|
]
|
|
let match_with = make_name "match" [
|
|
`Token MATCH ; `Current ; `Token WITH ;
|
|
`List (Lead_ne VBAR, `Named match_clause.name) ;
|
|
]
|
|
let lt = infix "lt" `Left LT
|
|
let le = infix "le" `Left LE
|
|
let gt = infix "gt" `Left GT
|
|
let eq = infix "eq" `Left EQUAL
|
|
let neq = infix "neq" `Left UNEQUAL
|
|
|
|
let cons = infix "cons" `Left DOUBLE_COLON
|
|
|
|
let addition = infix "addition" `Left PLUS
|
|
let substraction = infix "substraction" `Left MINUS
|
|
|
|
let multiplication = infix "multiplication" `Left TIMES
|
|
let division = infix "division" `Left DIV
|
|
|
|
let arith_variable : O.n_operator = make_name "variable" [ `Named variable_name ]
|
|
let int : O.n_operator = make_name "int" [ `Named int_name ]
|
|
let tz : O.n_operator = make_name "tz" [ `Named tz_name ]
|
|
let unit : O.n_operator = make_name "unit" [ `Named unit_name ]
|
|
let string : O.n_operator = make_name "string" [ `Named string_name ]
|
|
let constructor : O.n_operator = make_name "constructor" [ `Named constructor_name ]
|
|
|
|
let module_ident : O.n_operator = make_name "module_ident" [
|
|
`List (Trail_force_ne DOT, `Named constructor_name) ; `Named variable_name ;
|
|
]
|
|
let access : O.n_operator = infix "access" `Right DOT
|
|
let accessor : O.n_operator = make_name "accessor" [
|
|
`Named variable_name ; `List (Lead_ne DOT, `Named variable_name) ;
|
|
]
|
|
|
|
let assignment : O.n_operator = infix "assign" `Left LEFT_ARROW
|
|
|
|
let tuple = make_name "tuple" [
|
|
`List (Separated_nene COMMA, `Lower)
|
|
]
|
|
|
|
let name = make_name "name" [`Token TILDE ; `Current]
|
|
|
|
let main_hierarchy_name = "expression_main"
|
|
|
|
let main_hierarchy = O.name_hierarchy main_hierarchy_name "Eh" [
|
|
[tuple] ;
|
|
[type_annotation] ;
|
|
[lt ; le ; gt ; eq ; neq] ;
|
|
[assignment] ;
|
|
[cons] ;
|
|
[addition ; substraction] ;
|
|
[multiplication ; division] ;
|
|
[application] ;
|
|
[data_structure] ;
|
|
[name] ;
|
|
[arith_variable ; constructor ; module_ident ; accessor ; int ; unit ; string ; tz] ;
|
|
[paren "bottom" expression_name] ;
|
|
] []
|
|
|
|
let no_sequence_expression = O.name_hierarchy no_seq_name "Es" [
|
|
[let_in ; fun_ ; record ; ite ; it ; match_with] ;
|
|
[make_name "main" [`Named main_hierarchy_name]] ;
|
|
] []
|
|
|
|
let no_match_expression = O.name_hierarchy no_match_name "Em" [
|
|
[let_in ; fun_ ; record ; ite ; it ] ;
|
|
[make_name "main" [`Named main_hierarchy_name]] ;
|
|
] []
|
|
|
|
let expression = O.name_hierarchy expression_name "E" [
|
|
[sequence] ;
|
|
[let_in ; fun_ ; record ; ite ; it ; match_with] ;
|
|
[make_name "main" [`Named main_hierarchy_name]] ;
|
|
] []
|
|
|
|
let singletons = List.map O.rule_singleton [record_element ; match_clause]
|
|
end
|
|
|
|
module Type_expression = struct
|
|
|
|
open Token
|
|
open O
|
|
|
|
let record_element : O.rule = make_name "t_record_element" [
|
|
make_name "" [`Named variable_name ; `Token COLON ; `Named type_expression_name]
|
|
]
|
|
|
|
let record : O.n_operator = make_name "record" [
|
|
`Token LBRACKET ;
|
|
`List (Trail SEMICOLON, `Named record_element.name) ;
|
|
`Token RBRACKET ;
|
|
]
|
|
|
|
let application = empty_infix "application" `Right
|
|
|
|
let tuple = make_name "tuple" [
|
|
`List (Separated_nene COMMA, `Lower)
|
|
]
|
|
|
|
let type_variable : O.n_operator = make_name "variable" [ `Named variable_name ]
|
|
|
|
let restricted_type_expression = O.name_hierarchy restricted_type_expression_name "Tr" [
|
|
[application] ;
|
|
[type_variable] ;
|
|
[paren "paren" type_expression_name] ;
|
|
] []
|
|
|
|
let type_expression = O.name_hierarchy type_expression_name "T" [
|
|
[record] ;
|
|
[tuple] ;
|
|
[application] ;
|
|
[type_variable] ;
|
|
[paren "paren" type_expression_name]
|
|
] []
|
|
|
|
let singletons = [O.rule_singleton record_element]
|
|
|
|
end
|
|
|
|
module Program = struct
|
|
|
|
open Token
|
|
open O
|
|
|
|
let statement_name = "statement"
|
|
|
|
let program : O.rule = make_name program_name [make_name "" [
|
|
`List (Trail_option DOUBLE_SEMICOLON, statement_name)
|
|
]]
|
|
|
|
let param_name = "param"
|
|
|
|
let param : O.rule = make_name param_name [
|
|
make_name "restricted_pattern" [ `Named Pattern.restricted_pattern_name ] ;
|
|
make_name "implicit_named_param" [ `Token TILDE ; `Named variable_name ] ;
|
|
]
|
|
|
|
let type_annotation_name = "type_annotation_"
|
|
let type_annotation : O.rule = make_name type_annotation_name [
|
|
make_name "" [ `Token COLON ; `Named type_expression_name ] ;
|
|
]
|
|
|
|
let let_content_name = "let_content"
|
|
let let_content : O.rule = make_name let_content_name [
|
|
make_name "" [
|
|
`Named variable_name ;
|
|
`List (Naked, param_name) ;
|
|
`Option type_annotation_name ;
|
|
`Token EQUAL ;
|
|
`Named expression_name ;
|
|
] ;
|
|
]
|
|
|
|
let statement : O.rule = make_name statement_name [
|
|
make_name "variable_declaration" [`Token LET ; `Named let_content_name] ;
|
|
make_name "init_declaration" [`Token LET_INIT ; `Named let_content_name] ;
|
|
make_name "entry_declaration" [`Token LET_ENTRY ; `Named let_content_name] ;
|
|
make_name "type_declaration" [`Token TYPE ; `Named variable_name ; `Token EQUAL ; `Named type_expression_name] ;
|
|
]
|
|
|
|
let singletons = List.map O.rule_singleton [
|
|
let_content ;
|
|
type_annotation ;
|
|
program ;
|
|
statement ;
|
|
param ;
|
|
]
|
|
|
|
end
|
|
|
|
let language = O.language program_name (
|
|
variable :: constructor :: int :: unit :: string :: tz ::
|
|
Program.singletons @
|
|
Pattern.singletons @
|
|
Expression.singletons @
|
|
Type_expression.singletons
|
|
) [
|
|
Pattern.main ;
|
|
Pattern.restricted_pattern ;
|
|
Expression.main_hierarchy ;
|
|
Expression.no_sequence_expression ;
|
|
Expression.no_match_expression ;
|
|
Expression.expression ;
|
|
Type_expression.restricted_type_expression ;
|
|
Type_expression.type_expression ;
|
|
]
|
|
|
|
let () =
|
|
let argn = Array.length Sys.argv in
|
|
if argn = 1 then exit 1 ;
|
|
let arg = Sys.argv.(1) in
|
|
match arg with
|
|
| "parser" -> (
|
|
Format.printf "%a@.%a\n" PP_helpers.comment "Full Grammar" Print_Grammar.language language
|
|
)
|
|
| "ast" -> (
|
|
Format.printf "%a@.%a\n" PP_helpers.comment "AST" Print_AST.language language
|
|
)
|
|
| _ -> exit 1
|
|
|