From 3b05fba2bd2e95fab74aefef5e2d62165d1004f9 Mon Sep 17 00:00:00 2001 From: Torben Ewert Date: Sat, 17 Jun 2023 16:28:13 +0200 Subject: [PATCH] update formatting profile --- .ocamlformat | 13 +- bin/print.ml | 16 +- lib/pinc_backend/Pinc_HTML.ml | 34 +- lib/pinc_backend/Pinc_Interpreter.ml | 1334 ++++++++++---------- lib/pinc_backend/Pinc_Interpreter.mli | 40 +- lib/pinc_backend/Pinc_Interpreter_Types.ml | 138 +- lib/pinc_backend/Pinc_Typer.ml | 50 +- lib/pinc_diagnostics/Pinc_Location.ml | 8 +- lib/pinc_diagnostics/Pinc_Position.ml | 12 +- lib/pinc_diagnostics/Pinc_Position.mli | 12 +- lib/pinc_diagnostics/Pinc_Printer.ml | 69 +- lib/pinc_frontend/Pinc_Ast.ml | 82 +- lib/pinc_frontend/Pinc_Lexer.ml | 1118 ++++++++-------- lib/pinc_frontend/Pinc_Operators.ml | 52 +- lib/pinc_frontend/Pinc_Parser.ml | 728 +++++------ lib/pinc_frontend/Pinc_Token.ml | 18 +- lib/pinc_frontend/Pinc_Token.mli | 10 +- 17 files changed, 1889 insertions(+), 1845 deletions(-) diff --git a/.ocamlformat b/.ocamlformat index 0619e80..7b7ef86 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1 +1,12 @@ -profile = janestreet +profile=default +break-infix=fit-or-vertical +break-cases=fit-or-vertical +break-fun-decl=fit-or-vertical +break-fun-sig=fit-or-vertical +if-then-else=vertical +let-and=sparse +let-binding-spacing=double-semicolon +margin=90 +parens-ite=true +type-decl=sparse +wrap-fun-args=false \ No newline at end of file diff --git a/bin/print.ml b/bin/print.ml index 7096d86..a1a5551 100644 --- a/bin/print.ml +++ b/bin/print.ml @@ -11,11 +11,11 @@ let get_source filename = let get_files_with_ext ~ext dir = let rec loop result = function | file :: rest when Sys.is_directory file -> - Sys.readdir file - |> Array.to_list - |> List.map (Filename.concat file) - |> List.append rest - |> loop result + Sys.readdir file + |> Array.to_list + |> List.map (Filename.concat file) + |> List.append rest + |> loop result | file :: rest when Filename.extension file = ext -> loop (file :: result) rest | _file :: rest -> loop result rest | [] -> result @@ -31,12 +31,12 @@ let get_declarations_from ~directory () = (fun acc filename -> let decls = filename |> get_source |> Parser.parse ~filename in let f key x y = - match x, y with + match (x, y) with | None, Some y -> Some y | Some x, None -> Some x | Some _, Some _ -> - failwith - (Printf.sprintf "Found multiple declarations with identifier %s" key) + failwith + (Printf.sprintf "Found multiple declarations with identifier %s" key) | None, None -> None in StringMap.merge f acc decls) diff --git a/lib/pinc_backend/Pinc_HTML.ml b/lib/pinc_backend/Pinc_HTML.ml index f2812c8..7d69e5c 100644 --- a/lib/pinc_backend/Pinc_HTML.ml +++ b/lib/pinc_backend/Pinc_HTML.ml @@ -1,19 +1,17 @@ -let void_elements = - [| "area" - ; "base" - ; "br" - ; "col" - ; "embed" - ; "hr" - ; "img" - ; "input" - ; "link" - ; "meta" - ; "param" - ; "source" - ; "track" - ; "wbr" - |] +let is_void_el = function + | "area" -> true + | "base" -> true + | "br" -> true + | "col" -> true + | "embed" -> true + | "hr" -> true + | "img" -> true + | "input" -> true + | "link" -> true + | "meta" -> true + | "param" -> true + | "source" -> true + | "track" -> true + | "wbr" -> true + | _ -> false ;; - -let is_void_el s = Array.mem s void_elements diff --git a/lib/pinc_backend/Pinc_Interpreter.ml b/lib/pinc_backend/Pinc_Interpreter.ml index eec6d8b..a99aefb 100644 --- a/lib/pinc_backend/Pinc_Interpreter.ml +++ b/lib/pinc_backend/Pinc_Interpreter.ml @@ -27,63 +27,67 @@ module Value = struct | Int i -> string_of_int i | Float f when Float.is_integer f -> string_of_int (int_of_float f) | Float f -> string_of_float f - | Bool b -> if b then "true" else "false" + | Bool b -> + if b then + "true" + else + "false" | Array l -> - let buf = Buffer.create 200 in - l - |> Array.iteri (fun i it -> - if i <> 0 then Buffer.add_char buf '\n'; - Buffer.add_string buf (to_string it)); - Buffer.contents buf + let buf = Buffer.create 200 in + l + |> Array.iteri (fun i it -> + if i <> 0 then + Buffer.add_char buf '\n'; + Buffer.add_string buf (to_string it)); + Buffer.contents buf | Record m -> - let b = Buffer.create 1024 in - m - |> StringMap.to_seq - |> List.of_seq - |> List.fast_sort (fun (_key, (index_a, _value)) (_key, (index_b, _value)) -> - index_a - index_b) - |> List.iter (fun (_key, (_index, value)) -> - Buffer.add_string b (to_string value); - Buffer.add_char b '\n'); - Buffer.contents b + let b = Buffer.create 1024 in + m + |> StringMap.to_seq + |> List.of_seq + |> List.fast_sort (fun (_key, (index_a, _value)) (_key, (index_b, _value)) -> + index_a - index_b) + |> List.iter (fun (_key, (_index, value)) -> + Buffer.add_string b (to_string value); + Buffer.add_char b '\n'); + Buffer.contents b | HtmlTemplateNode (tag, attributes, children, self_closing) -> - let buf = Buffer.create 128 in - Buffer.add_char buf '<'; - Buffer.add_string buf tag; - if not (StringMap.is_empty attributes) - then - attributes - |> StringMap.iter (fun key value -> - match value with - | Null -> () - | Portal _ - | Function _ - | String _ - | Int _ - | Float _ - | Bool _ - | Array _ - | Record _ - | HtmlTemplateNode _ - | ComponentTemplateNode _ - | DefinitionInfo _ -> - Buffer.add_char buf ' '; - Buffer.add_string buf key; - Buffer.add_char buf '='; - Buffer.add_char buf '"'; - Buffer.add_string buf (value |> to_string); - Buffer.add_char buf '"' - | TagInfo _ -> assert false); - if self_closing && Pinc_HTML.is_void_el tag - then Buffer.add_string buf " />" - else ( - Buffer.add_char buf '>'; - children |> List.iter (fun child -> Buffer.add_string buf (to_string child)); + let buf = Buffer.create 128 in Buffer.add_char buf '<'; - Buffer.add_char buf '/'; Buffer.add_string buf tag; - Buffer.add_char buf '>'); - Buffer.contents buf + if not (StringMap.is_empty attributes) then + attributes + |> StringMap.iter (fun key value -> + match value with + | Null -> () + | Portal _ + | Function _ + | String _ + | Int _ + | Float _ + | Bool _ + | Array _ + | Record _ + | HtmlTemplateNode _ + | ComponentTemplateNode _ + | DefinitionInfo _ -> + Buffer.add_char buf ' '; + Buffer.add_string buf key; + Buffer.add_char buf '='; + Buffer.add_char buf '"'; + Buffer.add_string buf (value |> to_string); + Buffer.add_char buf '"' + | TagInfo _ -> assert false); + if self_closing && Pinc_HTML.is_void_el tag then + Buffer.add_string buf " />" + else ( + Buffer.add_char buf '>'; + children |> List.iter (fun child -> Buffer.add_string buf (to_string child)); + Buffer.add_char buf '<'; + Buffer.add_char buf '/'; + Buffer.add_string buf tag; + Buffer.add_char buf '>'); + Buffer.contents buf | ComponentTemplateNode (_render_fn, _tag, _attributes, result) -> result |> to_string | Function _ -> "" | DefinitionInfo _ -> "" @@ -109,7 +113,7 @@ module Value = struct ;; let rec equal a b = - match a, b with + match (a, b) with | String a, String b -> String.equal a b | Int a, Int b -> a = b | Float a, Float b -> a = b @@ -120,15 +124,15 @@ module Value = struct | Record a, Record b -> StringMap.equal (fun (_, a) (_, b) -> equal a b) a b | Function _, Function _ -> false | DefinitionInfo (a, _, _), DefinitionInfo (b, _, _) -> String.equal a b - | ( HtmlTemplateNode (a_tag, a_attrs, a_children, a_self_closing) - , HtmlTemplateNode (b_tag, b_attrs, b_children, b_self_closing) ) -> - a_tag = b_tag - && a_self_closing = b_self_closing - && StringMap.equal equal a_attrs b_attrs - && a_children = b_children - | ( ComponentTemplateNode (_, a_tag, a_attributes, _) - , ComponentTemplateNode (_, b_tag, b_attributes, _) ) -> - a_tag = b_tag && StringMap.equal equal a_attributes b_attributes + | ( HtmlTemplateNode (a_tag, a_attrs, a_children, a_self_closing), + HtmlTemplateNode (b_tag, b_attrs, b_children, b_self_closing) ) -> + a_tag = b_tag + && a_self_closing = b_self_closing + && StringMap.equal equal a_attrs b_attrs + && a_children = b_children + | ( ComponentTemplateNode (_, a_tag, a_attributes, _), + ComponentTemplateNode (_, b_tag, b_attributes, _) ) -> + a_tag = b_tag && StringMap.equal equal a_attributes b_attributes | Null, Null -> true | TagInfo _, _ -> assert false | _, TagInfo _ -> assert false @@ -136,7 +140,7 @@ module Value = struct ;; let compare a b = - match a, b with + match (a, b) with | String a, String b -> String.compare a b | Int a, Int b -> Int.compare a b | Float a, Float b -> Float.compare a b @@ -158,29 +162,29 @@ module Value = struct ;; let merge left right = - match left, right with + match (left, right) with | Array left, Array right -> Array (Array.append left right) | Record left, Record right -> - Record - (StringMap.union (fun _key _x y -> Some y) left right - |> StringMap.to_seq - |> Seq.mapi (fun index (key, (_, value)) -> key, (index, value)) - |> StringMap.of_seq) + Record + (StringMap.union (fun _key _x y -> Some y) left right + |> StringMap.to_seq + |> Seq.mapi (fun index (key, (_, value)) -> (key, (index, value))) + |> StringMap.of_seq) | HtmlTemplateNode (tag, attributes, children, self_closing), Record right -> - let attributes = - StringMap.union (fun _key _x y -> Some y) attributes (StringMap.map snd right) - in - HtmlTemplateNode (tag, attributes, children, self_closing) + let attributes = + StringMap.union (fun _key _x y -> Some y) attributes (StringMap.map snd right) + in + HtmlTemplateNode (tag, attributes, children, self_closing) | HtmlTemplateNode _, _ -> - failwith "Trying to merge a non record value onto tag attributes." + failwith "Trying to merge a non record value onto tag attributes." | ComponentTemplateNode (fn, tag, attributes, _), Record right -> - let attributes = - StringMap.union (fun _key _x y -> Some y) attributes (StringMap.map snd right) - in - let result = fn attributes in - ComponentTemplateNode (fn, tag, attributes, result) + let attributes = + StringMap.union (fun _key _x y -> Some y) attributes (StringMap.map snd right) + in + let result = fn attributes in + ComponentTemplateNode (fn, tag, attributes, result) | ComponentTemplateNode _, _ -> - failwith "Trying to merge a non record value onto tag attributes." + failwith "Trying to merge a non record value onto tag attributes." | Array _, _ -> failwith "Trying to merge a non array value onto an array." | _, Array _ -> failwith "Trying to merge an array value onto a non array." | _ -> failwith "Trying to merge two non array values." @@ -189,25 +193,25 @@ end module State = struct let make - ?(tag_listeners = Hashtbl.create 10) - ?parent_component - ?(context = Hashtbl.create 10) - ?(portals = Hashtbl.create 10) - ?(tag_cache = Hashtbl.create 10) - ~mode - declarations - = - { mode - ; binding_identifier = None - ; declarations - ; output = Null - ; environment = { scope = []; use_scope = [] } - ; tag_listeners - ; parent_tag = None - ; tag_cache - ; parent_component - ; context - ; portals + ?(tag_listeners = Hashtbl.create 10) + ?parent_component + ?(context = Hashtbl.create 10) + ?(portals = Hashtbl.create 10) + ?(tag_cache = Hashtbl.create 10) + ~mode + declarations = + { + mode; + binding_identifier = None; + declarations; + output = Null; + environment = { scope = []; use_scope = [] }; + tag_listeners; + parent_tag = None; + tag_cache; + parent_component; + context; + portals; } ;; @@ -237,22 +241,25 @@ module State = struct let rec update_scope state = List.map (function - | scope when not !updated -> - (List.map (function - | key, binding when (not !updated) && key = ident && binding.is_mutable -> - updated := true; - key, { binding with value } - | ( key - , ({ value = Function { state = fn_state; parameters; exec }; _ } as - binding) ) - when not !updated -> - fn_state.environment.scope <- update_scope fn_state; - ( key - , { binding with value = Function { state = fn_state; parameters; exec } } - ) - | v -> v)) - scope - | scope -> scope) + | scope when not !updated -> + (List.map (function + | key, binding when (not !updated) && key = ident && binding.is_mutable + -> + updated := true; + (key, { binding with value }) + | ( key, + ({ value = Function { state = fn_state; parameters; exec }; _ } as + binding) ) + when not !updated -> + fn_state.environment.scope <- update_scope fn_state; + ( key, + { + binding with + value = Function { state = fn_state; parameters; exec }; + } ) + | v -> v)) + scope + | scope -> scope) state.environment.scope in t.environment.scope <- update_scope t @@ -262,12 +269,16 @@ module State = struct let update_scope state = List.map (List.map (function - | key, ({ value = Function { state; parameters; exec }; _ } as binding) -> - let new_state = - add_value_to_scope ~ident ~value ~is_optional ~is_mutable state - in - key, { binding with value = Function { state = new_state; parameters; exec } } - | v -> v)) + | key, ({ value = Function { state; parameters; exec }; _ } as binding) -> + let new_state = + add_value_to_scope ~ident ~value ~is_optional ~is_mutable state + in + ( key, + { + binding with + value = Function { state = new_state; parameters; exec }; + } ) + | v -> v)) state.environment.scope in t.environment.scope <- update_scope t @@ -286,15 +297,15 @@ end let rec eval_statement ~state = function | Ast.LetStatement (Lowercase_Id ident, expression) -> - eval_let ~state ~ident ~is_mutable:false ~is_optional:false expression + eval_let ~state ~ident ~is_mutable:false ~is_optional:false expression | Ast.OptionalLetStatement (Lowercase_Id ident, expression) -> - eval_let ~state ~ident ~is_mutable:false ~is_optional:true expression + eval_let ~state ~ident ~is_mutable:false ~is_optional:true expression | Ast.OptionalMutableLetStatement (Lowercase_Id ident, expression) -> - eval_let ~state ~ident ~is_mutable:true ~is_optional:true expression + eval_let ~state ~ident ~is_mutable:true ~is_optional:true expression | Ast.MutableLetStatement (Lowercase_Id ident, expression) -> - eval_let ~state ~ident ~is_mutable:true ~is_optional:false expression + eval_let ~state ~ident ~is_mutable:true ~is_optional:false expression | Ast.MutationStatement (Lowercase_Id ident, expression) -> - eval_mutation ~state ~ident expression + eval_mutation ~state ~ident expression | Ast.UseStatement (Uppercase_Id ident, expression) -> eval_use ~state ~ident expression | Ast.BreakStatement -> raise_notrace Loop_Break | Ast.ContinueStatement -> raise_notrace Loop_Continue @@ -303,133 +314,133 @@ let rec eval_statement ~state = function and eval_expression ~state = function | Ast.Int i -> state |> State.add_output ~output:(Value.of_int i) | Ast.Float f when Float.is_integer f -> - state |> State.add_output ~output:(Value.of_int (int_of_float f)) + state |> State.add_output ~output:(Value.of_int (int_of_float f)) | Ast.Float f -> state |> State.add_output ~output:(Value.of_float f) | Ast.Bool b -> state |> State.add_output ~output:(Value.of_bool b) | Ast.Array l -> - state - |> State.add_output - ~output: - (l - |> Array.map (fun it -> it |> eval_expression ~state |> State.get_output) - |> Value.of_array) + state + |> State.add_output + ~output: + (l + |> Array.map (fun it -> it |> eval_expression ~state |> State.get_output) + |> Value.of_array) | Ast.Record map -> - state - |> State.add_output - ~output: - (map - |> StringMap.mapi (fun ident (index, optional, expression) -> - expression - |> eval_expression - ~state:{ state with binding_identifier = Some (optional, ident) } - |> State.get_output - |> function - | Null when not optional -> - failwith - ("identifier " - ^ ident - ^ " is not marked as nullable, but was given a null value.") - | value -> index, value) - |> Value.of_string_map) + state + |> State.add_output + ~output: + (map + |> StringMap.mapi (fun ident (index, optional, expression) -> + expression + |> eval_expression + ~state:{ state with binding_identifier = Some (optional, ident) } + |> State.get_output + |> function + | Null when not optional -> + failwith + ("identifier " + ^ ident + ^ " is not marked as nullable, but was given a null value.") + | value -> (index, value)) + |> Value.of_string_map) | Ast.String template -> eval_string_template ~state template | Ast.Function (parameters, body) -> eval_function_declaration ~state ~parameters body | Ast.FunctionCall (left, arguments) -> eval_function_call ~state ~arguments left | Ast.UppercaseIdentifierExpression id -> - let value = state.declarations |> StringMap.find_opt id in - let typ = - match value with - | None -> None - | Some (Ast.ComponentDeclaration _) -> Some `Component - | Some (Ast.PageDeclaration _) -> Some `Page - | Some (Ast.SiteDeclaration _) -> Some `Site - | Some (Ast.StoreDeclaration _) -> Some `Store - | Some (Ast.LibraryDeclaration _) -> - (* + let value = state.declarations |> StringMap.find_opt id in + let typ = + match value with + | None -> None + | Some (Ast.ComponentDeclaration _) -> Some `Component + | Some (Ast.PageDeclaration _) -> Some `Page + | Some (Ast.SiteDeclaration _) -> Some `Site + | Some (Ast.StoreDeclaration _) -> Some `Store + | Some (Ast.LibraryDeclaration _) -> + (* NOTE: Do we really want to evaluate the library with the current state? Or do we maybe want to create a fresh state? *) - let declaration = eval_declaration ~state id in - let top_level_bindings = declaration |> State.get_bindings in - let used_values = declaration |> State.get_used_values in - Some (`Library (top_level_bindings, used_values)) - in - state |> State.add_output ~output:(DefinitionInfo (id, typ, `NotNegated)) + let declaration = eval_declaration ~state id in + let top_level_bindings = declaration |> State.get_bindings in + let used_values = declaration |> State.get_used_values in + Some (`Library (top_level_bindings, used_values)) + in + state |> State.add_output ~output:(DefinitionInfo (id, typ, `NotNegated)) | Ast.LowercaseIdentifierExpression id -> eval_lowercase_identifier ~state id | Ast.TagExpression tag -> eval_tag ~state tag | Ast.ForInExpression { index; iterator = Lowercase_Id ident; reverse; iterable; body } -> eval_for_in ~state ~index_ident:index ~ident ~reverse ~iterable body | Ast.TemplateExpression nodes -> - state - |> State.add_output - ~output: - (nodes - |> List.map (fun it -> it |> eval_template ~state |> State.get_output) - |> Value.of_list) + state + |> State.add_output + ~output: + (nodes + |> List.map (fun it -> it |> eval_template ~state |> State.get_output) + |> Value.of_list) | Ast.BlockExpression e -> eval_block ~state e | Ast.ConditionalExpression { condition; consequent; alternate } -> - eval_if ~state ~condition ~alternate ~consequent + eval_if ~state ~condition ~alternate ~consequent | Ast.UnaryExpression (Ast.Operators.Unary.NOT, expression) -> - eval_unary_not ~state expression + eval_unary_not ~state expression | Ast.UnaryExpression (Ast.Operators.Unary.MINUS, expression) -> - eval_unary_minus ~state expression + eval_unary_minus ~state expression | Ast.BinaryExpression (left, Ast.Operators.Binary.EQUAL, right) -> - eval_binary_equal ~state left right + eval_binary_equal ~state left right | Ast.BinaryExpression (left, Ast.Operators.Binary.NOT_EQUAL, right) -> - eval_binary_not_equal ~state left right + eval_binary_not_equal ~state left right | Ast.BinaryExpression (left, Ast.Operators.Binary.GREATER, right) -> - eval_binary_greater ~state left right + eval_binary_greater ~state left right | Ast.BinaryExpression (left, Ast.Operators.Binary.GREATER_EQUAL, right) -> - eval_binary_greater_equal ~state left right + eval_binary_greater_equal ~state left right | Ast.BinaryExpression (left, Ast.Operators.Binary.LESS, right) -> - eval_binary_less ~state left right + eval_binary_less ~state left right | Ast.BinaryExpression (left, Ast.Operators.Binary.LESS_EQUAL, right) -> - eval_binary_less_equal ~state left right + eval_binary_less_equal ~state left right | Ast.BinaryExpression (left, Ast.Operators.Binary.PLUS, right) -> - eval_binary_plus ~state left right + eval_binary_plus ~state left right | Ast.BinaryExpression (left, Ast.Operators.Binary.MINUS, right) -> - eval_binary_minus ~state left right + eval_binary_minus ~state left right | Ast.BinaryExpression (left, Ast.Operators.Binary.TIMES, right) -> - eval_binary_times ~state left right + eval_binary_times ~state left right | Ast.BinaryExpression (left, Ast.Operators.Binary.DIV, right) -> - eval_binary_div ~state left right + eval_binary_div ~state left right | Ast.BinaryExpression (left, Ast.Operators.Binary.POW, right) -> - eval_binary_pow ~state left right + eval_binary_pow ~state left right | Ast.BinaryExpression (left, Ast.Operators.Binary.MODULO, right) -> - eval_binary_modulo ~state left right + eval_binary_modulo ~state left right | Ast.BinaryExpression (left, Ast.Operators.Binary.CONCAT, right) -> - eval_binary_concat ~state left right + eval_binary_concat ~state left right | Ast.BinaryExpression (left, Ast.Operators.Binary.AND, right) -> - eval_binary_and ~state left right + eval_binary_and ~state left right | Ast.BinaryExpression (left, Ast.Operators.Binary.OR, right) -> - eval_binary_or ~state left right + eval_binary_or ~state left right | Ast.BinaryExpression (left, Ast.Operators.Binary.DOT_ACCESS, right) -> - eval_binary_dot_access ~state left right + eval_binary_dot_access ~state left right | Ast.BinaryExpression (left, Ast.Operators.Binary.BRACKET_ACCESS, right) -> - eval_binary_bracket_access ~state left right + eval_binary_bracket_access ~state left right | Ast.BinaryExpression (left, Ast.Operators.Binary.ARRAY_ADD, right) -> - eval_binary_array_add ~state left right + eval_binary_array_add ~state left right | Ast.BinaryExpression (left, Ast.Operators.Binary.MERGE, right) -> - eval_binary_merge ~state left right + eval_binary_merge ~state left right | Ast.BinaryExpression (left, Ast.Operators.Binary.RANGE, right) -> - eval_range ~state ~inclusive:false left right + eval_range ~state ~inclusive:false left right | Ast.BinaryExpression (left, Ast.Operators.Binary.INCLUSIVE_RANGE, right) -> - eval_range ~state ~inclusive:true left right + eval_range ~state ~inclusive:true left right | Ast.BinaryExpression (left, Ast.Operators.Binary.FUNCTION_CALL, right) -> - eval_function_call ~state ~arguments:[ right ] left + eval_function_call ~state ~arguments:[ right ] left | Ast.BinaryExpression (left, Ast.Operators.Binary.PIPE, right) -> - eval_binary_pipe ~state left right + eval_binary_pipe ~state left right and eval_string_template ~state template = state |> State.add_output ~output: (template - |> List.map (function - | Ast.StringText s -> s - | Ast.StringInterpolation e -> - eval_expression ~state e |> State.get_output |> Value.to_string) - |> String.concat "" - |> Value.of_string) + |> List.map (function + | Ast.StringText s -> s + | Ast.StringInterpolation e -> + eval_expression ~state e |> State.get_output |> Value.to_string) + |> String.concat "" + |> Value.of_string) and eval_function_declaration ~state ~parameters body = let ident = state.binding_identifier in @@ -439,12 +450,12 @@ and eval_function_declaration ~state ~parameters body = match ident with | None -> state | Some (_, ident) -> - state - |> State.add_value_to_scope - ~ident - ~value:!self - ~is_mutable:false - ~is_optional:false + state + |> State.add_value_to_scope + ~ident + ~value:!self + ~is_mutable:false + ~is_optional:false in let state = state @@ -459,12 +470,12 @@ and eval_function_declaration ~state ~parameters body = let fn = Function { parameters; state; exec } in ident |> Option.iter (fun (_, ident) -> - state - |> State.add_value_to_function_scopes - ~ident - ~value:fn - ~is_optional:false - ~is_mutable:false); + state + |> State.add_value_to_function_scopes + ~ident + ~value:fn + ~is_optional:false + ~is_mutable:false); self := fn; state |> State.add_output ~output:fn @@ -473,36 +484,35 @@ and eval_function_call ~state ~arguments left = match maybe_fn with | Function { parameters; state = fn_state; exec } when List.compare_lengths parameters arguments = 0 -> - let arguments = - List.combine parameters arguments - |> List.fold_left - (fun acc (param, arg) -> - let value = arg |> eval_expression ~state |> State.get_output in - acc |> StringMap.add param value) - StringMap.empty - in - state |> State.add_output ~output:(exec ~arguments ~state:fn_state ()) - | Function { parameters; state = _; exec = _ } -> - if List.compare_lengths parameters arguments > 0 - then ( - let arguments_len = List.length arguments in - let missing = - parameters - |> List.filteri (fun index _ -> index > arguments_len - 1) - |> List.map (fun item -> "`" ^ item ^ "`") - |> String.concat ", " + let arguments = + List.combine parameters arguments + |> List.fold_left + (fun acc (param, arg) -> + let value = arg |> eval_expression ~state |> State.get_output in + acc |> StringMap.add param value) + StringMap.empty in - failwith - ("This function was provided too few arguments. The following parameters are \ - missing: " - ^ missing)) - else - failwith - ("This function only accepts " - ^ string_of_int (List.length parameters) - ^ " arguments, but was provided " - ^ string_of_int (List.length arguments) - ^ " here.") + state |> State.add_output ~output:(exec ~arguments ~state:fn_state ()) + | Function { parameters; state = _; exec = _ } -> + if List.compare_lengths parameters arguments > 0 then ( + let arguments_len = List.length arguments in + let missing = + parameters + |> List.filteri (fun index _ -> index > arguments_len - 1) + |> List.map (fun item -> "`" ^ item ^ "`") + |> String.concat ", " + in + failwith + ("This function was provided too few arguments. The following parameters are \ + missing: " + ^ missing)) + else + failwith + ("This function only accepts " + ^ string_of_int (List.length parameters) + ^ " arguments, but was provided " + ^ string_of_int (List.length arguments) + ^ " here.") | _ -> failwith "Trying to call a non function value" and eval_binary_pipe ~state left right = @@ -516,7 +526,7 @@ and eval_binary_pipe ~state left right = and eval_binary_plus ~state left right = let a = left |> eval_expression ~state |> State.get_output in let b = right |> eval_expression ~state |> State.get_output in - match a, b with + match (a, b) with | Int a, Int b -> state |> State.add_output ~output:(Int (a + b)) | Float a, Float b -> state |> State.add_output ~output:(Float (a +. b)) | Float a, Int b -> state |> State.add_output ~output:(Float (a +. float_of_int b)) @@ -526,7 +536,7 @@ and eval_binary_plus ~state left right = and eval_binary_minus ~state left right = let a = left |> eval_expression ~state |> State.get_output in let b = right |> eval_expression ~state |> State.get_output in - match a, b with + match (a, b) with | Int a, Int b -> state |> State.add_output ~output:(Int (a - b)) | Float a, Float b -> state |> State.add_output ~output:(Float (a -. b)) | Float a, Int b -> state |> State.add_output ~output:(Float (a -. float_of_int b)) @@ -536,7 +546,7 @@ and eval_binary_minus ~state left right = and eval_binary_times ~state left right = let a = left |> eval_expression ~state |> State.get_output in let b = right |> eval_expression ~state |> State.get_output in - match a, b with + match (a, b) with | Int a, Int b -> state |> State.add_output ~output:(Int (a * b)) | Float a, Float b -> state |> State.add_output ~output:(Float (a *. b)) | Float a, Int b -> state |> State.add_output ~output:(Float (a *. float_of_int b)) @@ -547,7 +557,7 @@ and eval_binary_div ~state left right = let a = left |> eval_expression ~state |> State.get_output in let b = right |> eval_expression ~state |> State.get_output in let r = - match a, b with + match (a, b) with | Int _, Int 0 -> failwith "Trying to divide by 0" | Float _, Float 0. -> failwith "Trying to divide by 0" | Float _, Int 0 -> failwith "Trying to divide by 0" @@ -558,24 +568,26 @@ and eval_binary_div ~state left right = | Int a, Float b -> float_of_int a /. b | _ -> failwith "Trying to divide non numeric literals." in - if Float.is_integer r - then state |> State.add_output ~output:(Int (int_of_float r)) - else state |> State.add_output ~output:(Float r) + if Float.is_integer r then + state |> State.add_output ~output:(Int (int_of_float r)) + else + state |> State.add_output ~output:(Float r) and eval_binary_pow ~state left right = let a = left |> eval_expression ~state |> State.get_output in let b = right |> eval_expression ~state |> State.get_output in let r = - match a, b with + match (a, b) with | Int a, Int b -> float_of_int a ** float_of_int b | Float a, Float b -> a ** b | Float a, Int b -> a ** float_of_int b | Int a, Float b -> float_of_int a ** b | _ -> failwith "Trying to raise non numeric literals." in - if Float.is_integer r - then state |> State.add_output ~output:(Int (int_of_float r)) - else state |> State.add_output ~output:(Float r) + if Float.is_integer r then + state |> State.add_output ~output:(Int (int_of_float r)) + else + state |> State.add_output ~output:(Float r) and eval_binary_modulo ~state left right = let a = left |> eval_expression ~state |> State.get_output in @@ -583,7 +595,7 @@ and eval_binary_modulo ~state left right = let ( %. ) = mod_float in let ( % ) = ( mod ) in let r = - match a, b with + match (a, b) with | Int _, Int 0 -> failwith "Trying to modulo with 0 on right hand side." | Int _, Float 0. -> failwith "Trying to modulo with 0 on right hand side." | Float _, Float 0. -> failwith "Trying to modulo with 0 on right hand side." @@ -639,100 +651,100 @@ and eval_binary_not_equal ~state left right = and eval_binary_concat ~state left right = let a = left |> eval_expression ~state |> State.get_output in let b = right |> eval_expression ~state |> State.get_output in - match a, b with + match (a, b) with | String a, String b -> state |> State.add_output ~output:(String (a ^ b)) | _ -> failwith "Trying to concat non string literals." and eval_binary_dot_access ~state left right = let left = left |> eval_expression ~state |> State.get_output in - match left, right with + match (left, right) with | Null, _ -> state |> State.add_output ~output:Null | Record left, Ast.LowercaseIdentifierExpression b -> - let output = - left |> StringMap.find_opt b |> Option.map snd |> Option.value ~default:Null - in - state |> State.add_output ~output - | HtmlTemplateNode (tag, attributes, _, _), Ast.LowercaseIdentifierExpression b -> - (match b with - | "tag" -> state |> State.add_output ~output:(String tag) - | "attributes" -> - state - |> State.add_output - ~output: - (Record - (attributes - |> StringMap.to_seq - |> Seq.mapi (fun index (key, value) -> key, (index, value)) - |> StringMap.of_seq)) - | s -> - failwith - ("Unknown property " - ^ s - ^ " on template node. Known properties are: `tag` and `attributes`.")) - | ComponentTemplateNode (_, tag, attributes, _), Ast.LowercaseIdentifierExpression b -> - (match b with - | "tag" -> state |> State.add_output ~output:(String tag) - | "attributes" -> - state - |> State.add_output - ~output: - (Record - (attributes - |> StringMap.to_seq - |> Seq.mapi (fun index (key, value) -> key, (index, value)) - |> StringMap.of_seq)) - | s -> - failwith - ("Unknown property " - ^ s - ^ " on component. Known properties are: `tag` and`attributes`.")) + let output = + left |> StringMap.find_opt b |> Option.map snd |> Option.value ~default:Null + in + state |> State.add_output ~output + | HtmlTemplateNode (tag, attributes, _, _), Ast.LowercaseIdentifierExpression b -> ( + match b with + | "tag" -> state |> State.add_output ~output:(String tag) + | "attributes" -> + state + |> State.add_output + ~output: + (Record + (attributes + |> StringMap.to_seq + |> Seq.mapi (fun index (key, value) -> (key, (index, value))) + |> StringMap.of_seq)) + | s -> + failwith + ("Unknown property " + ^ s + ^ " on template node. Known properties are: `tag` and `attributes`.")) + | ComponentTemplateNode (_, tag, attributes, _), Ast.LowercaseIdentifierExpression b + -> ( + match b with + | "tag" -> state |> State.add_output ~output:(String tag) + | "attributes" -> + state + |> State.add_output + ~output: + (Record + (attributes + |> StringMap.to_seq + |> Seq.mapi (fun index (key, value) -> (key, (index, value))) + |> StringMap.of_seq)) + | s -> + failwith + ("Unknown property " + ^ s + ^ " on component. Known properties are: `tag` and`attributes`.")) | Record _, _ -> - failwith "Expected right hand side of record access to be a lowercase identifier." - | DefinitionInfo (name, maybe_library, _), Ast.LowercaseIdentifierExpression b -> - (match state |> State.get_used_values |> List.assoc_opt name, maybe_library with - | None, Some (`Library (top_level_bindings, _)) - | Some (DefinitionInfo (_, Some (`Library (top_level_bindings, _)), _)), _ -> - state - |> State.add_output - ~output: - (top_level_bindings - |> List.assoc_opt b - |> Option.map (fun b -> b.value) - |> Option.value ~default:Null) - | None, None -> state |> State.add_output ~output:Null - | _ -> - failwith "Trying to access a property on a non record, library or template value.") - | DefinitionInfo (name, maybe_library, _), Ast.UppercaseIdentifierExpression b -> - (match state |> State.get_used_values |> List.assoc_opt name, maybe_library with - | None, Some (`Library (_, use_scope)) - | Some (DefinitionInfo (_, Some (`Library (_, use_scope)), _)), _ -> - state - |> State.add_output - ~output:(use_scope |> List.assoc_opt b |> Option.value ~default:Null) - | None, None -> state |> State.add_output ~output:Null - | _ -> - failwith "Trying to access a property on a non record, library or template value.") + failwith "Expected right hand side of record access to be a lowercase identifier." + | DefinitionInfo (name, maybe_library, _), Ast.LowercaseIdentifierExpression b -> ( + match (state |> State.get_used_values |> List.assoc_opt name, maybe_library) with + | None, Some (`Library (top_level_bindings, _)) + | Some (DefinitionInfo (_, Some (`Library (top_level_bindings, _)), _)), _ -> + state + |> State.add_output + ~output: + (top_level_bindings + |> List.assoc_opt b + |> Option.map (fun b -> b.value) + |> Option.value ~default:Null) + | None, None -> state |> State.add_output ~output:Null + | _ -> + failwith + "Trying to access a property on a non record, library or template value.") + | DefinitionInfo (name, maybe_library, _), Ast.UppercaseIdentifierExpression b -> ( + match (state |> State.get_used_values |> List.assoc_opt name, maybe_library) with + | None, Some (`Library (_, use_scope)) + | Some (DefinitionInfo (_, Some (`Library (_, use_scope)), _)), _ -> + state + |> State.add_output + ~output:(use_scope |> List.assoc_opt b |> Option.value ~default:Null) + | None, None -> state |> State.add_output ~output:Null + | _ -> + failwith + "Trying to access a property on a non record, library or template value.") | DefinitionInfo (name, None, _), _ -> - failwith ("Trying to access a property on a non existant library `" ^ name ^ "` .") + failwith ("Trying to access a property on a non existant library `" ^ name ^ "` .") | _, Ast.LowercaseIdentifierExpression _ -> - failwith "Trying to access a property on a non record, library or template value." + failwith "Trying to access a property on a non record, library or template value." | _ -> failwith "I am really not sure what you are trying to do here..." and eval_binary_bracket_access ~state left right = let left = left |> eval_expression ~state |> State.get_output in let right = right |> eval_expression ~state |> State.get_output in - match left, right with + match (left, right) with | Array left, Int right -> - let output = - try Array.unsafe_get left right with - | _ -> Null - in - state |> State.add_output ~output + let output = try Array.unsafe_get left right with _ -> Null in + state |> State.add_output ~output | Record left, String right -> - let output = - left |> StringMap.find_opt right |> Option.map snd |> Option.value ~default:Null - in - state |> State.add_output ~output + let output = + left |> StringMap.find_opt right |> Option.map snd |> Option.value ~default:Null + in + state |> State.add_output ~output | Null, _ -> state |> State.add_output ~output:Null | Array _, _ -> failwith "Cannot access array with a non integer value." | Record _, _ -> failwith "Cannot access record with a non string value." @@ -742,9 +754,9 @@ and eval_binary_array_add ~state left right = let left = left |> eval_expression ~state |> State.get_output in let right = right |> eval_expression ~state |> State.get_output in let add left right = - match left, right with + match (left, right) with | Array left, value -> - state |> State.add_output ~output:(Array (Array.append left [| value |])) + state |> State.add_output ~output:(Array (Array.append left [| value |])) | _ -> failwith "Trying to add an element on a non array value." in add left right @@ -757,12 +769,12 @@ and eval_binary_merge ~state left right = and eval_unary_not ~state expression = match eval_expression ~state expression |> State.get_output with | DefinitionInfo (name, typ, negated) -> - let negated = - match negated with - | `Negated -> `NotNegated - | `NotNegated -> `Negated - in - state |> State.add_output ~output:(DefinitionInfo (name, typ, negated)) + let negated = + match negated with + | `Negated -> `NotNegated + | `NotNegated -> `Negated + in + state |> State.add_output ~output:(DefinitionInfo (name, typ, negated)) | v -> state |> State.add_output ~output:(Bool (not (Value.is_true v))) and eval_unary_minus ~state expression = @@ -770,17 +782,15 @@ and eval_unary_minus ~state expression = | Int i -> state |> State.add_output ~output:(Int (Int.neg i)) | Float f -> state |> State.add_output ~output:(Float (Float.neg f)) | _ -> - failwith - "Invalid usage of unary `-` operator. You are only able to negate integers or \ - floats." + failwith + "Invalid usage of unary `-` operator. You are only able to negate integers or \ + floats." and eval_lowercase_identifier ~state ident = - state - |> State.get_value_from_scope ~ident - |> function + state |> State.get_value_from_scope ~ident |> function | None -> failwith ("Unbound identifier `" ^ ident ^ "`") | Some { value; is_mutable = _; is_optional = _ } -> - state |> State.add_output ~output:value + state |> State.add_output ~output:value and eval_let ~state ~ident ~is_mutable ~is_optional expression = let state = @@ -790,50 +800,48 @@ and eval_let ~state ~ident ~is_mutable ~is_optional expression = in match State.get_output state with | Null when not is_optional -> - failwith - ("identifier " ^ ident ^ " is not marked as nullable, but was given a null value.") + failwith + ("identifier " ^ ident ^ " is not marked as nullable, but was given a null value.") | value -> - state - |> State.add_value_to_scope ~ident ~value ~is_mutable ~is_optional - |> State.add_output ~output:Null + state + |> State.add_value_to_scope ~ident ~value ~is_mutable ~is_optional + |> State.add_output ~output:Null and eval_use ~state ~ident expression = let value = expression |> eval_expression ~state |> State.get_output in match value with | value -> - state |> State.add_value_to_use_scope ~ident ~value |> State.add_output ~output:Null + state |> State.add_value_to_use_scope ~ident ~value |> State.add_output ~output:Null and eval_mutation ~state ~ident expression = let current_binding = State.get_value_from_scope ~ident state in match current_binding with | None -> - failwith "Trying to update a variable, which does not exist in the current scope." + failwith "Trying to update a variable, which does not exist in the current scope." | Some { is_mutable = false; _ } -> failwith "Trying to update a non mutable variable." | Some { value = _; is_mutable = true; is_optional } -> - let output = - expression - |> eval_expression - ~state:{ state with binding_identifier = Some (is_optional, ident) } - in - let () = - output - |> State.get_output - |> function - | Null when not is_optional -> - failwith - ("identifier " - ^ ident - ^ " is not marked as nullable, but was tried to be updated with a null value." - ) - | value -> state |> State.update_value_in_scope ~ident ~value - in - state |> State.add_output ~output:Null + let output = + expression + |> eval_expression + ~state:{ state with binding_identifier = Some (is_optional, ident) } + in + let () = + output |> State.get_output |> function + | Null when not is_optional -> + failwith + ("identifier " + ^ ident + ^ " is not marked as nullable, but was tried to be updated with a null \ + value.") + | value -> state |> State.update_value_in_scope ~ident ~value + in + state |> State.add_output ~output:Null and eval_if ~state ~condition ~alternate ~consequent = let condition_matches = condition |> eval_expression ~state |> State.get_output |> Value.is_true in - match condition_matches, alternate with + match (condition_matches, alternate) with | true, _ -> consequent |> eval_statement ~state | false, Some alt -> alt |> eval_statement ~state | false, None -> state |> State.add_output ~output:Null @@ -843,49 +851,50 @@ and eval_for_in ~state ~index_ident ~ident ~reverse ~iterable body = let index = ref (-1) in let rec loop acc = function | [] -> List.rev acc - | value :: tl -> - index := succ !index; - let state = - state - |> State.add_value_to_scope ~ident ~value ~is_mutable:false ~is_optional:false - in - let state = - match index_ident with - | Some (Lowercase_Id ident) -> + | value :: tl -> ( + index := succ !index; + let state = state - |> State.add_value_to_scope - ~ident - ~value:(Int !index) - ~is_mutable:false - ~is_optional:false - | None -> state - in - (match eval_statement ~state body with - | exception Loop_Continue -> loop acc tl - | exception Loop_Break -> List.rev acc - | v -> loop (State.get_output v :: acc) tl) + |> State.add_value_to_scope ~ident ~value ~is_mutable:false ~is_optional:false + in + let state = + match index_ident with + | Some (Lowercase_Id ident) -> + state + |> State.add_value_to_scope + ~ident + ~value:(Int !index) + ~is_mutable:false + ~is_optional:false + | None -> state + in + match eval_statement ~state body with + | exception Loop_Continue -> loop acc tl + | exception Loop_Break -> List.rev acc + | v -> loop (State.get_output v :: acc) tl) in let iter = function | Array l -> - let to_seq array = - if reverse - then ( - array |> Array.stable_sort (fun _ _ -> 1); - array |> Array.to_seq) - else Array.to_seq array - in - let res = l |> to_seq |> List.of_seq |> loop [] |> Value.of_list in - state |> State.add_output ~output:res + let to_seq array = + if reverse then ( + array |> Array.stable_sort (fun _ _ -> 1); + array |> Array.to_seq) + else + Array.to_seq array + in + let res = l |> to_seq |> List.of_seq |> loop [] |> Value.of_list in + state |> State.add_output ~output:res | String s -> - let res = - let map = - if reverse - then List.rev_map (fun c -> String (String.make 1 c)) - else List.map (fun c -> String (String.make 1 c)) + let res = + let map = + if reverse then + List.rev_map (fun c -> String (String.make 1 c)) + else + List.map (fun c -> String (String.make 1 c)) + in + s |> String.to_seq |> List.of_seq |> map |> loop [] |> Value.of_list in - s |> String.to_seq |> List.of_seq |> map |> loop [] |> Value.of_list - in - state |> State.add_output ~output:res + state |> State.add_output ~output:res | Null -> state |> State.add_output ~output:Null | HtmlTemplateNode _ -> failwith "Cannot iterate over template node" | ComponentTemplateNode _ -> failwith "Cannot iterate over template node" @@ -904,26 +913,31 @@ and eval_range ~state ~inclusive from upto = let from = from |> eval_expression ~state |> State.get_output in let upto = upto |> eval_expression ~state |> State.get_output in let get_range from upto = - match from, upto with - | Int from, Int upto -> from, upto + match (from, upto) with + | Int from, Int upto -> (from, upto) | Int _, _ -> - failwith - "Can't construct range in for loop. The end of your range is not of type int." + failwith + "Can't construct range in for loop. The end of your range is not of type int." | _, Int _ -> - failwith - "Can't construct range in for loop. The start of your range is not of type int." + failwith + "Can't construct range in for loop. The start of your range is not of type int." | _, _ -> - failwith - "Can't construct range in for loop. The start and end of your range are not of \ - type int." + failwith + "Can't construct range in for loop. The start and end of your range are not of \ + type int." in let from, upto = get_range from upto in let iter = - if from > upto - then [||] + if from > upto then + [||] else ( let start = from in - let stop = if not inclusive then upto else upto + 1 in + let stop = + if not inclusive then + upto + else + upto + 1 + in Array.init (stop - start) (fun i -> Int (i + start))) in state |> State.add_output ~output:(Array iter) @@ -934,28 +948,28 @@ and eval_block ~state statements = and eval_slot ~attributes ~slotted_elements key = let find_slot_key attributes = - attributes - |> StringMap.find_opt "slot" - |> Option.value ~default:(String "") + attributes |> StringMap.find_opt "slot" |> Option.value ~default:(String "") |> function | String s -> s | _ -> failwith "Expected slot attribute to be of type string" in let rec keep_slotted acc = function | HtmlTemplateNode (tag, attributes, children, self_closing) -> - if find_slot_key attributes = key - then HtmlTemplateNode (tag, attributes, children, self_closing) :: acc - else acc + if find_slot_key attributes = key then + HtmlTemplateNode (tag, attributes, children, self_closing) :: acc + else + acc | ComponentTemplateNode (fn, tag, attributes, result) -> - if find_slot_key attributes = key - then ComponentTemplateNode (fn, tag, attributes, result) :: acc - else acc + if find_slot_key attributes = key then + ComponentTemplateNode (fn, tag, attributes, result) :: acc + else + acc | Array l -> l |> Array.fold_left keep_slotted acc | String s when String.trim s = "" -> acc | _ -> - failwith - "Only nodes may be placed into slots. If you want to put a plain text into a \ - slot, you have to wrap it in a

tag for example." + failwith + "Only nodes may be placed into slots. If you want to put a plain text into a \ + slot, you have to wrap it in a

tag for example." in let slotted_elements = slotted_elements |> List.fold_left keep_slotted [] |> List.rev in let min = @@ -977,61 +991,66 @@ and eval_slot ~attributes ~slotted_elements key = match constraints with | None -> Result.ok () | Some restrictions -> - let is_in_list = ref false in - let allowed, disallowed = - restrictions - |> List.partition_map (fun (_typ, name, negated) -> - if name = tag then is_in_list := true; - if negated then Either.right name else Either.left name) - in - let is_allowed = - match allowed, disallowed with - | [], _disallowed -> not !is_in_list - | _allowed, [] -> !is_in_list - | allowed, _disallowed -> List.mem tag allowed - in - if not is_allowed - then - Result.error - ("Child with tag `" - ^ tag - ^ "` may not be used inside this #Slot . The following restrictions are set: \ - [ " - ^ (constraints + let is_in_list = ref false in + let allowed, disallowed = + restrictions + |> List.partition_map (fun (_typ, name, negated) -> + if name = tag then + is_in_list := true; + if negated then + Either.right name + else + Either.left name) + in + let is_allowed = + match (allowed, disallowed) with + | [], _disallowed -> not !is_in_list + | _allowed, [] -> !is_in_list + | allowed, _disallowed -> List.mem tag allowed + in + if not is_allowed then + Result.error + ("Child with tag `" + ^ tag + ^ "` may not be used inside this #Slot . The following restrictions are set: \ + [ " + ^ (constraints |> Option.value ~default:[] |> List.map (fun (_typ, name, negated) -> - if negated then "!" ^ name else name) + if negated then + "!" ^ name + else + name) |> String.concat ",") - ^ " ]") - else Result.ok () + ^ " ]") + else + Result.ok () in let num_slotted_elements = List.length slotted_elements in - if num_slotted_elements < min - then + if num_slotted_elements < min then failwith ("#Slot did not reach the minimum amount of nodes (specified as " - ^ string_of_int min - ^ ").") - else if num_slotted_elements > max - then + ^ string_of_int min + ^ ").") + else if num_slotted_elements > max then failwith ("#Slot includes more than the maximum amount of nodes (specified as " - ^ string_of_int max - ^ ").") + ^ string_of_int max + ^ ").") else ( let passed, failed = slotted_elements |> List.partition_map (function - | (HtmlTemplateNode (tag, _, _, _) | ComponentTemplateNode (_, tag, _, _)) as v - -> - (match check_instance_restriction tag with - | Ok () -> Either.left v - | Error e -> Either.right e) - | _ -> - Either.right - "Tried to assign a non node value to a #Slot. Only nodes template nodes \ - are allowed inside slots. If you want to put another value (like a \ - string) into a slot, you have to wrap it in some node.") + | (HtmlTemplateNode (tag, _, _, _) | ComponentTemplateNode (_, tag, _, _)) as + v -> ( + match check_instance_restriction tag with + | Ok () -> Either.left v + | Error e -> Either.right e) + | _ -> + Either.right + "Tried to assign a non node value to a #Slot. Only nodes template \ + nodes are allowed inside slots. If you want to put another value \ + (like a string) into a slot, you have to wrap it in some node.") in match failed with | [] -> Array (passed |> Array.of_list) @@ -1040,100 +1059,100 @@ and eval_slot ~attributes ~slotted_elements key = and eval_internal_tag ~state ~key ~attributes ~value_bag tag_name = match tag_name with | `String -> - value_bag - |> Pinc_Typer.Expect.(attribute key string) - |> Option.map Value.of_string - |> Option.value ~default:Null + value_bag + |> Pinc_Typer.Expect.(attribute key string) + |> Option.map Value.of_string + |> Option.value ~default:Null | `Int -> - value_bag - |> Pinc_Typer.Expect.(attribute key int) - |> Option.map Value.of_int - |> Option.value ~default:Null + value_bag + |> Pinc_Typer.Expect.(attribute key int) + |> Option.map Value.of_int + |> Option.value ~default:Null | `Float -> - value_bag - |> Pinc_Typer.Expect.(attribute key float) - |> Option.map Value.of_float - |> Option.value ~default:Null + value_bag + |> Pinc_Typer.Expect.(attribute key float) + |> Option.map Value.of_float + |> Option.value ~default:Null | `Boolean -> - value_bag - |> Pinc_Typer.Expect.(attribute key bool) - |> Option.map Value.of_bool - |> Option.value ~default:Null + value_bag + |> Pinc_Typer.Expect.(attribute key bool) + |> Option.map Value.of_bool + |> Option.value ~default:Null | `Array -> - let of' = attributes |> Pinc_Typer.Expect.(required (attribute "of" tag_info)) in - value_bag - |> Pinc_Typer.Expect.(attribute key (array any_value)) - |> Option.map (fun array -> - array - |> List.mapi (fun index item -> - let key = string_of_int index in - { of' with key } - |> eval_internal_or_external_tag - ~state - ~value:(StringMap.singleton key item)) - |> Value.of_list) - |> Option.value ~default:Null + let of' = attributes |> Pinc_Typer.Expect.(required (attribute "of" tag_info)) in + value_bag + |> Pinc_Typer.Expect.(attribute key (array any_value)) + |> Option.map (fun array -> + array + |> List.mapi (fun index item -> + let key = string_of_int index in + { of' with key } + |> eval_internal_or_external_tag + ~state + ~value:(StringMap.singleton key item)) + |> Value.of_list) + |> Option.value ~default:Null | `Record -> - let of' = - attributes |> Pinc_Typer.Expect.(required (attribute "of" record_with_order)) - in - value_bag - |> Pinc_Typer.Expect.(attribute key record) - |> Option.map (fun record -> - StringMap.merge - (fun _key x y -> - match x, y with - | Some _, Some (idx, TagInfo info) -> - Some (idx, info |> eval_internal_or_external_tag ~state ~value:record) - | None, Some (idx, TagInfo _) -> Some (idx, Null) - | (None | Some _), Some (idx, value) -> Some (idx, value) - | (None | Some _), None -> None) - record - of' - |> Value.of_string_map) - |> Option.value ~default:Null + let of' = + attributes |> Pinc_Typer.Expect.(required (attribute "of" record_with_order)) + in + value_bag + |> Pinc_Typer.Expect.(attribute key record) + |> Option.map (fun record -> + StringMap.merge + (fun _key x y -> + match (x, y) with + | Some _, Some (idx, TagInfo info) -> + Some (idx, info |> eval_internal_or_external_tag ~state ~value:record) + | None, Some (idx, TagInfo _) -> Some (idx, Null) + | (None | Some _), Some (idx, value) -> Some (idx, value) + | (None | Some _), None -> None) + record + of' + |> Value.of_string_map) + |> Option.value ~default:Null and eval_internal_or_external_tag ~state ?value tag_info = let { tag; key; required = _; attributes; transformer } = tag_info in - match value, state.parent_component with + match (value, state.parent_component) with | None, Some (_, value_bag, slotted_elements) - | Some value_bag, Some (_, _, slotted_elements) -> - (match tag with - | (`Array | `Boolean | `Float | `Int | `Record | `String) as tag -> - tag |> eval_internal_tag ~state ~key ~attributes ~value_bag |> transformer - | `Slot -> key |> eval_slot ~attributes ~slotted_elements |> transformer - | `Custom _ -> tag_info |> call_tag_listener ~state ~value_bag:(Some value_bag)) + | Some value_bag, Some (_, _, slotted_elements) -> ( + match tag with + | (`Array | `Boolean | `Float | `Int | `Record | `String) as tag -> + tag |> eval_internal_tag ~state ~key ~attributes ~value_bag |> transformer + | `Slot -> key |> eval_slot ~attributes ~slotted_elements |> transformer + | `Custom _ -> tag_info |> call_tag_listener ~state ~value_bag:(Some value_bag)) | value_bag, _ -> tag_info |> call_tag_listener ~state ~value_bag and call_tag_listener ~state ~value_bag t = let { tag; key; required; attributes; transformer } = t in let listener = Hashtbl.find_opt state.tag_listeners tag in (match listener with - | Some (`String fn) -> fn ~required ~attributes ~key - | Some (`Int fn) -> fn ~required ~attributes ~key - | Some (`Float fn) -> fn ~required ~attributes ~key - | Some (`Boolean fn) -> fn ~required ~attributes ~key - | Some (`Array fn) -> - let child = attributes |> Pinc_Typer.Expect.(required (attribute "of" tag_info)) in - fn ~required ~attributes ~child ~key - | Some (`Record fn) -> - let children = - attributes - |> Pinc_Typer.Expect.(required (attribute "of" record_with_order)) - |> StringMap.filter_map (fun _key (index, value) -> - value - |> Pinc_Typer.Expect.(maybe tag_info) - |> Option.map (fun tag_info -> index, tag_info)) - |> StringMap.to_seq - |> List.of_seq - |> List.fast_sort (fun (_key, (index_a, _value)) (_key, (index_b, _value)) -> - index_a - index_b) - |> List.map (fun (key, (_index, value)) -> key, value) - in - fn ~required ~attributes ~children ~key - | Some (`Slot fn) -> fn ~required ~attributes ~key - | Some (`Custom fn) -> fn ~required ~attributes ~parent_value:value_bag ~key - | None -> Result.ok Null) + | Some (`String fn) -> fn ~required ~attributes ~key + | Some (`Int fn) -> fn ~required ~attributes ~key + | Some (`Float fn) -> fn ~required ~attributes ~key + | Some (`Boolean fn) -> fn ~required ~attributes ~key + | Some (`Array fn) -> + let child = attributes |> Pinc_Typer.Expect.(required (attribute "of" tag_info)) in + fn ~required ~attributes ~child ~key + | Some (`Record fn) -> + let children = + attributes + |> Pinc_Typer.Expect.(required (attribute "of" record_with_order)) + |> StringMap.filter_map (fun _key (index, value) -> + value + |> Pinc_Typer.Expect.(maybe tag_info) + |> Option.map (fun tag_info -> (index, tag_info))) + |> StringMap.to_seq + |> List.of_seq + |> List.fast_sort (fun (_key, (index_a, _value)) (_key, (index_b, _value)) -> + index_a - index_b) + |> List.map (fun (key, (_index, value)) -> (key, value)) + in + fn ~required ~attributes ~children ~key + | Some (`Slot fn) -> fn ~required ~attributes ~key + | Some (`Custom fn) -> fn ~required ~attributes ~parent_value:value_bag ~key + | None -> Result.ok Null) |> function | Ok v -> v |> transformer | Error e -> failwith e @@ -1150,11 +1169,11 @@ and eval_tag ~state tag = |> StringMap.map (fun it -> it |> eval_expression ~state |> State.get_output) in let key, state = - match StringMap.find_opt "key" tag_attributes, state.binding_identifier with - | None, Some (_optional, ident) -> ident, { state with binding_identifier = None } - | Some (String key), _ -> key, state + match (StringMap.find_opt "key" tag_attributes, state.binding_identifier) with + | None, Some (_optional, ident) -> (ident, { state with binding_identifier = None }) + | Some (String key), _ -> (key, state) | Some _, _ -> failwith "Expected attribute `key` on tag to be of type string" - | None, None -> "", state + | None, None -> ("", state) in let path = (state.parent_tag |> Option.value ~default:[]) @ [ key ] in let tag_attributes = @@ -1163,75 +1182,73 @@ and eval_tag ~state tag = |> StringMap.add "of" (of_attribute - |> Option.map (fun it -> - it - |> eval_expression ~state:{ state with parent_tag = Some path } - |> State.get_output) - |> Option.value ~default:Null) + |> Option.map (fun it -> + it + |> eval_expression ~state:{ state with parent_tag = Some path } + |> State.get_output) + |> Option.value ~default:Null) in let apply_transformer ~transformer value = match transformer with | Some (Ast.Lowercase_Id ident, expr) -> - let state = - state - |> State.add_scope - |> State.add_value_to_scope ~ident ~value ~is_optional:false ~is_mutable:false - in - eval_expression ~state expr |> State.get_output + let state = + state + |> State.add_scope + |> State.add_value_to_scope ~ident ~value ~is_optional:false ~is_mutable:false + in + eval_expression ~state expr |> State.get_output | _ -> value in let value = - match state.mode, tag with + match (state.mode, tag) with | _, `CreatePortal -> Portal (Hashtbl.find_all state.portals key) | _, `SetContext -> - let value = - tag_attributes - |> StringMap.find_opt "value" - |> function - | None -> failwith "attribute value is required when setting a context." - | Some (Function _) -> failwith "a function can not be put into a context." - | Some value -> value - in - Hashtbl.add state.context key value; - Null + let value = + tag_attributes |> StringMap.find_opt "value" |> function + | None -> failwith "attribute value is required when setting a context." + | Some (Function _) -> failwith "a function can not be put into a context." + | Some value -> value + in + Hashtbl.add state.context key value; + Null | _, `GetContext -> Hashtbl.find_opt state.context key |> Option.value ~default:Null | Portal_Collection, `Portal -> - let push = - match tag_attributes |> StringMap.find_opt "push" with - | None -> - failwith "attribute push is required when pushing a value into a portal." - | Some (Function _) -> failwith "a function can not be put into a portal." - | Some value -> value - in - Hashtbl.add state.portals key push; - Null + let push = + match tag_attributes |> StringMap.find_opt "push" with + | None -> + failwith "attribute push is required when pushing a value into a portal." + | Some (Function _) -> failwith "a function can not be put into a portal." + | Some value -> value + in + Hashtbl.add state.portals key push; + Null | Render, `Portal -> Null - | ( Portal_Collection - , ((`Array | `Boolean | `Custom _ | `Float | `Int | `Record | `Slot | `String) as - tag) ) -> - let tag_info = - { tag - ; key - ; required - ; attributes = tag_attributes - ; transformer = apply_transformer ~transformer - } - in - (match state.parent_tag with - | None -> tag_info |> eval_internal_or_external_tag ~state - | Some _ -> TagInfo tag_info) + | ( Portal_Collection, + ((`Array | `Boolean | `Custom _ | `Float | `Int | `Record | `Slot | `String) as + tag) ) -> ( + let tag_info = + { + tag; + key; + required; + attributes = tag_attributes; + transformer = apply_transformer ~transformer; + } + in + match state.parent_tag with + | None -> tag_info |> eval_internal_or_external_tag ~state + | Some _ -> TagInfo tag_info) | Render, _ -> - Option.bind (Hashtbl.find_opt state.tag_cache key) Queue.take_opt - |> Option.value ~default:Null + Option.bind (Hashtbl.find_opt state.tag_cache key) Queue.take_opt + |> Option.value ~default:Null in (* TODO: Cleanup! Ideally the tag_cache would be a Hashtable of unique keys per tag! *) - if state.mode = Portal_Collection - then ( + if state.mode = Portal_Collection then ( match Hashtbl.find_opt state.tag_cache key with | None -> - let q = Queue.create () in - Queue.add value q; - Hashtbl.add state.tag_cache key q + let q = Queue.create () in + Queue.add value q; + Hashtbl.add state.tag_cache key q | Some q -> Queue.add value q); state |> State.add_output ~output:value @@ -1239,49 +1256,47 @@ and eval_template ~state template = match template with | Ast.TextTemplateNode text -> state |> State.add_output ~output:(String text) | Ast.HtmlTemplateNode { tag; attributes; children; self_closing } -> - let attributes = - attributes - |> StringMap.map (eval_expression ~state) - |> StringMap.map State.get_output - in - let children = - children |> List.map (eval_template ~state) |> List.map State.get_output - in - state - |> State.add_output - ~output:(HtmlTemplateNode (tag, attributes, children, self_closing)) + let attributes = + attributes + |> StringMap.map (eval_expression ~state) + |> StringMap.map State.get_output + in + let children = + children |> List.map (eval_template ~state) |> List.map State.get_output + in + state + |> State.add_output + ~output:(HtmlTemplateNode (tag, attributes, children, self_closing)) | Ast.ExpressionTemplateNode expr -> eval_expression ~state expr | Ast.ComponentTemplateNode { identifier = Uppercase_Id tag; attributes; children } -> - let attributes = - attributes - |> StringMap.map (eval_expression ~state) - |> StringMap.map State.get_output - in - let children = - children |> List.map (eval_template ~state) |> List.map State.get_output - in - let render_fn attributes = - let state = - State.make - ~parent_component:(tag, attributes, children) - ~tag_listeners:state.tag_listeners - ~context:state.context - ~portals:state.portals - ~tag_cache:state.tag_cache - ~mode:state.mode - state.declarations + let attributes = + attributes + |> StringMap.map (eval_expression ~state) + |> StringMap.map State.get_output in - eval_declaration ~state tag |> State.get_output - in - let result = render_fn attributes in - state - |> State.add_output - ~output:(ComponentTemplateNode (render_fn, tag, attributes, result)) + let children = + children |> List.map (eval_template ~state) |> List.map State.get_output + in + let render_fn attributes = + let state = + State.make + ~parent_component:(tag, attributes, children) + ~tag_listeners:state.tag_listeners + ~context:state.context + ~portals:state.portals + ~tag_cache:state.tag_cache + ~mode:state.mode + state.declarations + in + eval_declaration ~state tag |> State.get_output + in + let result = render_fn attributes in + state + |> State.add_output + ~output:(ComponentTemplateNode (render_fn, tag, attributes, result)) and eval_declaration ~state declaration = - state.declarations - |> StringMap.find_opt declaration - |> function + state.declarations |> StringMap.find_opt declaration |> function | Some (Ast.ComponentDeclaration (_attrs, body)) | Some (Ast.LibraryDeclaration (_attrs, body)) | Some (Ast.SiteDeclaration (_attrs, body)) @@ -1299,19 +1314,20 @@ let eval_meta ?tag_listeners declarations = in declarations |> StringMap.map (function - | Ast.ComponentDeclaration (attrs, _body) -> `Component (eval attrs) - | Ast.SiteDeclaration (attrs, _body) -> `Site (eval attrs) - | Ast.PageDeclaration (attrs, _body) -> `Page (eval attrs) - | Ast.StoreDeclaration (attrs, _body) -> `Store (eval attrs) - | Ast.LibraryDeclaration (attrs, _body) -> `Library (eval attrs)) + | Ast.ComponentDeclaration (attrs, _body) -> `Component (eval attrs) + | Ast.SiteDeclaration (attrs, _body) -> `Site (eval attrs) + | Ast.PageDeclaration (attrs, _body) -> `Page (eval attrs) + | Ast.StoreDeclaration (attrs, _body) -> `Store (eval attrs) + | Ast.LibraryDeclaration (attrs, _body) -> `Library (eval attrs)) ;; let eval ?tag_listeners ~root declarations = let state = State.make ?tag_listeners declarations ~mode:Portal_Collection in let state = eval_declaration ~state root in - if state.portals |> Hashtbl.length > 0 - then eval_declaration ~state:{ state with mode = Render } root - else state + if state.portals |> Hashtbl.length > 0 then + eval_declaration ~state:{ state with mode = Render } root + else + state ;; let from_source ?(filename = "") ~source root = diff --git a/lib/pinc_backend/Pinc_Interpreter.mli b/lib/pinc_backend/Pinc_Interpreter.mli index b72264f..e963e5e 100644 --- a/lib/pinc_backend/Pinc_Interpreter.mli +++ b/lib/pinc_backend/Pinc_Interpreter.mli @@ -11,11 +11,11 @@ module rec Value : sig val of_list : value list -> value val of_string_map : (int * value) StringMap.t -> value - val make_component - : render:(value StringMap.t -> value) - -> tag:string - -> attributes:value StringMap.t - -> value + val make_component : + render:(value StringMap.t -> value) -> + tag:string -> + attributes:value StringMap.t -> + value end and State : sig @@ -24,21 +24,21 @@ and State : sig val get_parent_component : state -> (string * value StringMap.t * value list) option end -val eval_meta - : ?tag_listeners:Pinc_Interpreter_Types.tag_listeners - -> Ast.declaration StringMap.t - -> [> `Component of value StringMap.t - | `Library of value StringMap.t - | `Page of value StringMap.t - | `Site of value StringMap.t - | `Store of value StringMap.t - ] - StringMap.t +val eval_meta : + ?tag_listeners:Pinc_Interpreter_Types.tag_listeners -> + Ast.declaration StringMap.t -> + [> `Component of value StringMap.t + | `Library of value StringMap.t + | `Page of value StringMap.t + | `Site of value StringMap.t + | `Store of value StringMap.t + ] + StringMap.t -val eval - : ?tag_listeners:Pinc_Interpreter_Types.tag_listeners - -> root:StringMap.key - -> Ast.declaration StringMap.t - -> state +val eval : + ?tag_listeners:Pinc_Interpreter_Types.tag_listeners -> + root:StringMap.key -> + Ast.declaration StringMap.t -> + state val from_source : ?filename:string -> source:string -> string -> state diff --git a/lib/pinc_backend/Pinc_Interpreter_Types.ml b/lib/pinc_backend/Pinc_Interpreter_Types.ml index b5a1daf..922f6b0 100644 --- a/lib/pinc_backend/Pinc_Interpreter_Types.ml +++ b/lib/pinc_backend/Pinc_Interpreter_Types.ml @@ -27,11 +27,11 @@ and definition_info = option * [ `Negated | `NotNegated ] -and function_info = - { parameters : string list - ; state : state - ; exec : arguments:value StringMap.t -> state:state -> unit -> value - } +and function_info = { + parameters : string list; + state : state; + exec : arguments:value StringMap.t -> state:state -> unit -> value; +} and external_tag = [ `String @@ -44,86 +44,86 @@ and external_tag = | `Custom of string ] -and tag_info = - { tag : external_tag - ; key : string - ; required : bool - ; attributes : value StringMap.t - ; transformer : value -> value - } +and tag_info = { + tag : external_tag; + key : string; + required : bool; + attributes : value StringMap.t; + transformer : value -> value; +} and tag_handler = [ `String of - required:bool - -> attributes:value StringMap.t - -> key:string - -> (value, string) Result.t + required:bool -> + attributes:value StringMap.t -> + key:string -> + (value, string) Result.t | `Int of - required:bool - -> attributes:value StringMap.t - -> key:string - -> (value, string) Result.t + required:bool -> + attributes:value StringMap.t -> + key:string -> + (value, string) Result.t | `Float of - required:bool - -> attributes:value StringMap.t - -> key:string - -> (value, string) Result.t + required:bool -> + attributes:value StringMap.t -> + key:string -> + (value, string) Result.t | `Boolean of - required:bool - -> attributes:value StringMap.t - -> key:string - -> (value, string) Result.t + required:bool -> + attributes:value StringMap.t -> + key:string -> + (value, string) Result.t | `Array of - required:bool - -> attributes:value StringMap.t - -> child:tag_info - -> key:string - -> (value, string) Result.t + required:bool -> + attributes:value StringMap.t -> + child:tag_info -> + key:string -> + (value, string) Result.t | `Record of - required:bool - -> attributes:value StringMap.t - -> children:(string * tag_info) list - -> key:string - -> (value, string) Result.t + required:bool -> + attributes:value StringMap.t -> + children:(string * tag_info) list -> + key:string -> + (value, string) Result.t | `Slot of - required:bool - -> attributes:value StringMap.t - -> key:string - -> (value, string) Result.t + required:bool -> + attributes:value StringMap.t -> + key:string -> + (value, string) Result.t | `Custom of - required:bool - -> attributes:value StringMap.t - -> parent_value:value StringMap.t option - -> key:string - -> (value, string) Result.t + required:bool -> + attributes:value StringMap.t -> + parent_value:value StringMap.t option -> + key:string -> + (value, string) Result.t ] and tag_listeners = (external_tag, tag_handler) Hashtbl.t -and state = - { mode : mode - ; binding_identifier : (bool * string) option - ; declarations : Ast.declaration StringMap.t - ; output : value - ; environment : environment - ; tag_listeners : tag_listeners - ; tag_cache : (string, value Queue.t) Hashtbl.t - ; parent_tag : string list option - ; parent_component : (string * value StringMap.t * value list) option - ; context : (string, value) Hashtbl.t - ; portals : (string, value) Hashtbl.t - } +and state = { + mode : mode; + binding_identifier : (bool * string) option; + declarations : Ast.declaration StringMap.t; + output : value; + environment : environment; + tag_listeners : tag_listeners; + tag_cache : (string, value Queue.t) Hashtbl.t; + parent_tag : string list option; + parent_component : (string * value StringMap.t * value list) option; + context : (string, value) Hashtbl.t; + portals : (string, value) Hashtbl.t; +} -and environment = - { mutable scope : (string * binding) list list - ; mutable use_scope : (string * value) list - } +and environment = { + mutable scope : (string * binding) list list; + mutable use_scope : (string * value) list; +} -and binding = - { is_mutable : bool - ; is_optional : bool - ; value : value - } +and binding = { + is_mutable : bool; + is_optional : bool; + value : value; +} and mode = | Portal_Collection diff --git a/lib/pinc_backend/Pinc_Typer.ml b/lib/pinc_backend/Pinc_Typer.ml index 6044989..f032b4b 100644 --- a/lib/pinc_backend/Pinc_Typer.ml +++ b/lib/pinc_backend/Pinc_Typer.ml @@ -31,7 +31,7 @@ module Expect = struct | TagInfo _ -> failwith "expected string, got tag" | HtmlTemplateNode (_, _, _, _) -> failwith "expected string, got HTML template node" | ComponentTemplateNode (_, _, _, _) -> - failwith "expected string, got component template node" + failwith "expected string, got component template node" ;; let int = function @@ -48,7 +48,7 @@ module Expect = struct | TagInfo _ -> failwith "expected int, got tag" | HtmlTemplateNode (_, _, _, _) -> failwith "expected int, got HTML template node" | ComponentTemplateNode (_, _, _, _) -> - failwith "expected int, got component template node" + failwith "expected int, got component template node" ;; let float = function @@ -65,7 +65,7 @@ module Expect = struct | TagInfo _ -> failwith "expected float, got tag" | HtmlTemplateNode (_, _, _, _) -> failwith "expected float, got HTML template node" | ComponentTemplateNode (_, _, _, _) -> - failwith "expected float, got component template node" + failwith "expected float, got component template node" ;; let bool = function @@ -82,7 +82,7 @@ module Expect = struct | TagInfo _ -> failwith "expected bool, got tag" | HtmlTemplateNode (_, _, _, _) -> failwith "expected bool, got HTML template node" | ComponentTemplateNode (_, _, _, _) -> - failwith "expected bool, got component template node" + failwith "expected bool, got component template node" ;; let array fn = function @@ -99,7 +99,7 @@ module Expect = struct | TagInfo _ -> failwith "expected array, got tag" | HtmlTemplateNode (_, _, _, _) -> failwith "expected array, got HTML template node" | ComponentTemplateNode (_, _, _, _) -> - failwith "expected array, got component template node" + failwith "expected array, got component template node" ;; let record = function @@ -116,7 +116,7 @@ module Expect = struct | TagInfo _ -> failwith "expected record, got tag" | HtmlTemplateNode (_, _, _, _) -> failwith "expected record, got HTML template node" | ComponentTemplateNode (_, _, _, _) -> - failwith "expected record, got component template node" + failwith "expected record, got component template node" ;; let record_with_order = function @@ -133,7 +133,7 @@ module Expect = struct | TagInfo _ -> failwith "expected record, got tag" | HtmlTemplateNode (_, _, _, _) -> failwith "expected record, got HTML template node" | ComponentTemplateNode (_, _, _, _) -> - failwith "expected record, got component template node" + failwith "expected record, got component template node" ;; let definition_info ?(typ = `All) = function @@ -147,26 +147,26 @@ module Expect = struct | Record _ -> failwith "expected definition info, got record" | Function _ -> failwith "expected definition info, got function definition" | DefinitionInfo (name, def_typ, negated) -> - let typ = - match typ, def_typ with - | (`Component | `All), Some `Component -> `Component - | (`Page | `All), Some `Page -> `Page - | (`Site | `All), Some `Site -> `Site - | (`Library | `All), Some (`Library _) -> `Library - | (`Store | `All), Some `Store -> `Store - | _, None -> failwith ("definition \"" ^ name ^ "\" does not exist") - | `Component, _ -> failwith "expected a component definition" - | `Page, _ -> failwith "expected a page definition" - | `Site, _ -> failwith "expected a site definition" - | `Library, _ -> failwith "expected a library definition" - | `Store, _ -> failwith "expected a store definition" - in - Some (typ, name, negated = `Negated) + let typ = + match (typ, def_typ) with + | (`Component | `All), Some `Component -> `Component + | (`Page | `All), Some `Page -> `Page + | (`Site | `All), Some `Site -> `Site + | (`Library | `All), Some (`Library _) -> `Library + | (`Store | `All), Some `Store -> `Store + | _, None -> failwith ("definition \"" ^ name ^ "\" does not exist") + | `Component, _ -> failwith "expected a component definition" + | `Page, _ -> failwith "expected a page definition" + | `Site, _ -> failwith "expected a site definition" + | `Library, _ -> failwith "expected a library definition" + | `Store, _ -> failwith "expected a store definition" + in + Some (typ, name, negated = `Negated) | TagInfo _ -> failwith "expected definition info, got tag" | HtmlTemplateNode (_, _, _, _) -> - failwith "expected definition info, got HTML template node" + failwith "expected definition info, got HTML template node" | ComponentTemplateNode (_, _, _, _) -> - failwith "expected definition info, got component template node" + failwith "expected definition info, got component template node" ;; let tag_info = function @@ -183,6 +183,6 @@ module Expect = struct | TagInfo i -> Some i | HtmlTemplateNode (_, _, _, _) -> failwith "expected tag, got HTML template node" | ComponentTemplateNode (_, _, _, _) -> - failwith "expected tag, got component template node" + failwith "expected tag, got component template node" ;; end diff --git a/lib/pinc_diagnostics/Pinc_Location.ml b/lib/pinc_diagnostics/Pinc_Location.ml index ada5bb5..07774f8 100644 --- a/lib/pinc_diagnostics/Pinc_Location.ml +++ b/lib/pinc_diagnostics/Pinc_Location.ml @@ -1,6 +1,6 @@ -type t = - { loc_start : Pinc_Position.t - ; loc_end : Pinc_Position.t - } +type t = { + loc_start : Pinc_Position.t; + loc_end : Pinc_Position.t; +} let make loc_start loc_end = { loc_start; loc_end } diff --git a/lib/pinc_diagnostics/Pinc_Position.ml b/lib/pinc_diagnostics/Pinc_Position.ml index 221314f..52e14d9 100644 --- a/lib/pinc_diagnostics/Pinc_Position.ml +++ b/lib/pinc_diagnostics/Pinc_Position.ml @@ -1,8 +1,8 @@ -type t = - { filename : string - ; line : int - ; beginning_of_line : int - ; column : int - } +type t = { + filename : string; + line : int; + beginning_of_line : int; + column : int; +} let make ~filename ~line ~column = { filename; line; beginning_of_line = 0; column } diff --git a/lib/pinc_diagnostics/Pinc_Position.mli b/lib/pinc_diagnostics/Pinc_Position.mli index 19df8c4..244a196 100644 --- a/lib/pinc_diagnostics/Pinc_Position.mli +++ b/lib/pinc_diagnostics/Pinc_Position.mli @@ -1,8 +1,8 @@ -type t = - { filename : string - ; line : int - ; beginning_of_line : int - ; column : int - } +type t = { + filename : string; + line : int; + beginning_of_line : int; + column : int; +} val make : filename:string -> line:int -> column:int -> t diff --git a/lib/pinc_diagnostics/Pinc_Printer.ml b/lib/pinc_diagnostics/Pinc_Printer.ml index ab7c5f8..fb58353 100644 --- a/lib/pinc_diagnostics/Pinc_Printer.ml +++ b/lib/pinc_diagnostics/Pinc_Printer.ml @@ -5,13 +5,13 @@ let seek_lines_before ~count ic pos = let original_line = pos.Position.line in In_channel.seek ic 0L; let rec loop current_line current_char = - if current_line + count >= original_line - then current_char, current_line + if current_line + count >= original_line then + (current_char, current_line) else ( match In_channel.input_char ic with | Some '\n' -> loop (current_line + 1) (current_char + 1) | Some _ -> loop current_line (current_char + 1) - | None -> current_char, current_line) + | None -> (current_char, current_line)) in loop 1 0 ;; @@ -20,13 +20,13 @@ let seek_lines_after ~count ic pos = let original_line = pos.Position.line in In_channel.seek ic 0L; let rec loop current_line current_char = - if current_line - count - 1 >= original_line - then current_char - 1, current_line + if current_line - count - 1 >= original_line then + (current_char - 1, current_line) else ( match In_channel.input_char ic with | Some '\n' -> loop (current_line + 1) (current_char + 1) | Some _ -> loop current_line (current_char + 1) - | None -> current_char, current_line) + | None -> (current_char, current_line)) in loop 1 0 ;; @@ -51,46 +51,48 @@ let print_code ~color ~loc ic = |> Option.value ~default:"" |> String.split_on_char '\n' |> List.mapi (fun i line -> - let line_number = i + first_shown_line in - line_number, line) + let line_number = i + first_shown_line in + (line_number, line)) in let buf = Buffer.create 100 in let ppf = Format.formatter_of_buffer buf in Fmt.set_style_renderer ppf `Ansi_tty; lines |> List.iter (fun (line_number, line) -> - let is_errored_line = - line_number >= highlight_line_start && line_number <= highlight_line_end - in - if is_errored_line - then Fmt.pf ppf "%a" Fmt.(styled `Bold (styled (`Fg color) int)) line_number - else Fmt.pf ppf "%i" line_number; - Fmt.pf ppf " %a " Fmt.(styled `Faint string) "│"; - line - |> String.iteri (fun i ch -> - if is_errored_line - then - if i >= highlight_column_start - 1 && i <= highlight_column_end - 1 - then Fmt.pf ppf "%a" Fmt.(styled `Bold (styled (`Fg color) char)) ch - else Fmt.pf ppf "%a" Fmt.(styled `None char) ch - else Fmt.pf ppf "%a" Fmt.(styled `None char) ch); - Format.pp_print_newline ppf ()); + let is_errored_line = + line_number >= highlight_line_start && line_number <= highlight_line_end + in + if is_errored_line then + Fmt.pf ppf "%a" Fmt.(styled `Bold (styled (`Fg color) int)) line_number + else + Fmt.pf ppf "%i" line_number; + Fmt.pf ppf " %a " Fmt.(styled `Faint string) "│"; + line + |> String.iteri (fun i ch -> + if is_errored_line then + if i >= highlight_column_start - 1 && i <= highlight_column_end - 1 then + Fmt.pf ppf "%a" Fmt.(styled `Bold (styled (`Fg color) char)) ch + else + Fmt.pf ppf "%a" Fmt.(styled `None char) ch + else + Fmt.pf ppf "%a" Fmt.(styled `None char) ch); + Format.pp_print_newline ppf ()); Buffer.contents buf ;; let print_loc ppf (loc : Location.t) = let loc_string = - if loc.loc_start.line = loc.loc_end.line - then - if loc.loc_start.column = loc.loc_end.column - then Format.sprintf "line %i, character %i" loc.loc_start.line loc.loc_start.column + if loc.loc_start.line = loc.loc_end.line then + if loc.loc_start.column = loc.loc_end.column then + Format.sprintf "line %i, character %i" loc.loc_start.line loc.loc_start.column else Format.sprintf "line %i, characters %i-%i" loc.loc_start.line loc.loc_start.column loc.loc_end.column - else Format.sprintf "lines %i-%i" loc.loc_start.line loc.loc_end.line + else + Format.sprintf "lines %i-%i" loc.loc_start.line loc.loc_end.line in Fmt.pf ppf @@ -106,14 +108,13 @@ let print_header ppf ~color text = let print ~kind ppf (loc : Location.t) = let color, header = match kind with - | `warning -> `Yellow, "WARNING" - | `error -> `Red, "ERROR" + | `warning -> (`Yellow, "WARNING") + | `error -> (`Red, "ERROR") in Fmt.pf ppf "@[%a@] " (print_header ~color) header; Fmt.pf ppf "@[%a@]@," print_loc loc; try In_channel.with_open_bin loc.loc_start.filename (fun ic -> - Fmt.pf ppf "@,%s" (print_code ~color ~loc ic)) - with - | Sys_error _ -> () + Fmt.pf ppf "@,%s" (print_code ~color ~loc ic)) + with Sys_error _ -> () ;; diff --git a/lib/pinc_frontend/Pinc_Ast.ml b/lib/pinc_frontend/Pinc_Ast.ml index 504ff7e..d36354a 100644 --- a/lib/pinc_frontend/Pinc_Ast.ml +++ b/lib/pinc_frontend/Pinc_Ast.ml @@ -15,38 +15,38 @@ and string_template = and component_slot = uppercase_identifier * template_node list and template_node = - | HtmlTemplateNode of - { tag : string - ; attributes : attributes - ; children : template_node list - ; self_closing : bool - } - | ComponentTemplateNode of - { identifier : uppercase_identifier - ; attributes : attributes - ; children : template_node list - } + | HtmlTemplateNode of { + tag : string; + attributes : attributes; + children : template_node list; + self_closing : bool; + } + | ComponentTemplateNode of { + identifier : uppercase_identifier; + attributes : attributes; + children : template_node list; + } | ExpressionTemplateNode of expression | TextTemplateNode of string -and tag = - { tag : - [ `String - | `Int - | `Float - | `Boolean - | `Array - | `Record - | `Slot - | `SetContext - | `GetContext - | `CreatePortal - | `Portal - | `Custom of string - ] - ; attributes : attributes - ; transformer : (lowercase_identifier * expression) option - } +and tag = { + tag : + [ `String + | `Int + | `Float + | `Boolean + | `Array + | `Record + | `Slot + | `SetContext + | `GetContext + | `CreatePortal + | `Portal + | `Custom of string + ]; + attributes : attributes; + transformer : (lowercase_identifier * expression) option; +} and expression = | String of string_template list @@ -60,20 +60,20 @@ and expression = | UppercaseIdentifierExpression of string | LowercaseIdentifierExpression of string | TagExpression of tag - | ForInExpression of - { index : lowercase_identifier option - ; iterator : lowercase_identifier - ; reverse : bool - ; iterable : expression - ; body : statement - } + | ForInExpression of { + index : lowercase_identifier option; + iterator : lowercase_identifier; + reverse : bool; + iterable : expression; + body : statement; + } | TemplateExpression of template_node list | BlockExpression of statement list - | ConditionalExpression of - { condition : expression - ; consequent : statement - ; alternate : statement option - } + | ConditionalExpression of { + condition : expression; + consequent : statement; + alternate : statement option; + } | UnaryExpression of Operators.Unary.typ * expression | BinaryExpression of expression * Operators.Binary.typ * expression diff --git a/lib/pinc_frontend/Pinc_Lexer.ml b/lib/pinc_frontend/Pinc_Lexer.ml index 0e9a493..ad76999 100644 --- a/lib/pinc_frontend/Pinc_Lexer.ml +++ b/lib/pinc_frontend/Pinc_Lexer.ml @@ -14,18 +14,18 @@ type char' = | `EOF ] -type t = - { filename : string - ; src : string - ; src_length : int - ; mutable prev : char' - ; mutable current : char' - ; mutable offset : int - ; mutable line_offset : int - ; mutable line : int - ; mutable column : int - ; mutable mode : mode list - } +type t = { + filename : string; + src : string; + src_length : int; + mutable prev : char'; + mutable current : char'; + mutable offset : int; + mutable line_offset : int; + mutable line : int; + mutable column : int; + mutable mode : mode list; +} let make_position t = Position.make ~filename:t.filename ~line:t.line ~column:(t.column + 1) @@ -72,17 +72,18 @@ let next t = let () = match t.current with | `Chr '\n' -> - t.line_offset <- next_offset; - t.line <- succ t.line + t.line_offset <- next_offset; + t.line <- succ t.line | _ -> () in t.column <- next_offset - t.line_offset; t.offset <- next_offset; t.prev <- t.current; - t.current - <- (if next_offset < t.src_length - then `Chr (String.unsafe_get t.src next_offset) - else `EOF) + t.current <- + (if next_offset < t.src_length then + `Chr (String.unsafe_get t.src next_offset) + else + `EOF) ;; let next_n ~n t = @@ -92,22 +93,28 @@ let next_n ~n t = ;; let peek ?(n = 1) t = - if t.offset + n < t.src_length - then `Chr (String.unsafe_get t.src (t.offset + n)) - else `EOF + if t.offset + n < t.src_length then + `Chr (String.unsafe_get t.src (t.offset + n)) + else + `EOF ;; let make ~filename src = - { filename - ; src - ; src_length = String.length src - ; prev = `EOF - ; current = (if src = "" then `EOF else `Chr (String.unsafe_get src 0)) - ; offset = 0 - ; line_offset = 0 - ; column = 0 - ; line = 1 - ; mode = [ Normal ] + { + filename; + src; + src_length = String.length src; + prev = `EOF; + current = + (if src = "" then + `EOF + else + `Chr (String.unsafe_get src 0)); + offset = 0; + line_offset = 0; + column = 0; + line = 1; + mode = [ Normal ]; } ;; @@ -117,8 +124,7 @@ let is_whitespace = function ;; let rec skip_whitespace t = - if is_whitespace t.current - then ( + if is_whitespace t.current then ( next t; skip_whitespace t) ;; @@ -132,9 +138,9 @@ let scan_ident t = | `Chr ('a' .. 'z' as c) | `Chr ('0' .. '9' as c) | `Chr ('_' as c) -> - next t; - Buffer.add_char buf c; - loop t + next t; + Buffer.add_char buf c; + loop t | _ -> () in let () = loop t in @@ -146,64 +152,64 @@ let scan_string ~start_pos t = let rec loop t = match t.current with | `EOF -> - Diagnostics.error - ~start_pos - ~end_pos:(make_position t) - "This string is not terminated. Please add a double-quote (\") at the end." - | `Chr '\\' -> - (match peek t with - | `Chr ' ' -> - next_n ~n:2 t; - Buffer.add_char buf '\\'; - loop t - | `Chr '"' -> - next_n ~n:2 t; - Buffer.add_char buf '"'; - loop t - | `Chr '\'' -> - next_n ~n:2 t; - Buffer.add_char buf '\''; - loop t - | `Chr 'b' -> - next_n ~n:2 t; - Buffer.add_char buf '\b'; - loop t - | `Chr 'f' -> - next_n ~n:2 t; - Buffer.add_char buf '\012'; - loop t - | `Chr 'n' -> - next_n ~n:2 t; - Buffer.add_char buf '\n'; - loop t - | `Chr 'r' -> - next_n ~n:2 t; - Buffer.add_char buf '\r'; - loop t - | `Chr 't' -> - next_n ~n:2 t; - Buffer.add_char buf '\t'; - loop t - | `Chr '\\' -> - next_n ~n:2 t; - Buffer.add_char buf '\\'; - loop t - | `Chr _ -> - Diagnostics.error - ~start_pos:(make_position t) - ~end_pos:(make_position t) - "Unknown escape sequence in string." - | `EOF -> - Diagnostics.error - ~start_pos - ~end_pos:(make_position t) - "This string is not terminated. Please add a double-quote (\") at the end.") + Diagnostics.error + ~start_pos + ~end_pos:(make_position t) + "This string is not terminated. Please add a double-quote (\") at the end." + | `Chr '\\' -> ( + match peek t with + | `Chr ' ' -> + next_n ~n:2 t; + Buffer.add_char buf '\\'; + loop t + | `Chr '"' -> + next_n ~n:2 t; + Buffer.add_char buf '"'; + loop t + | `Chr '\'' -> + next_n ~n:2 t; + Buffer.add_char buf '\''; + loop t + | `Chr 'b' -> + next_n ~n:2 t; + Buffer.add_char buf '\b'; + loop t + | `Chr 'f' -> + next_n ~n:2 t; + Buffer.add_char buf '\012'; + loop t + | `Chr 'n' -> + next_n ~n:2 t; + Buffer.add_char buf '\n'; + loop t + | `Chr 'r' -> + next_n ~n:2 t; + Buffer.add_char buf '\r'; + loop t + | `Chr 't' -> + next_n ~n:2 t; + Buffer.add_char buf '\t'; + loop t + | `Chr '\\' -> + next_n ~n:2 t; + Buffer.add_char buf '\\'; + loop t + | `Chr _ -> + Diagnostics.error + ~start_pos:(make_position t) + ~end_pos:(make_position t) + "Unknown escape sequence in string." + | `EOF -> + Diagnostics.error + ~start_pos + ~end_pos:(make_position t) + "This string is not terminated. Please add a double-quote (\") at the end.") | `Chr '{' when peek t = `Chr '|' -> () | `Chr '"' -> () | `Chr c -> - next t; - Buffer.add_char buf c; - loop t + next t; + Buffer.add_char buf c; + loop t in let () = loop t in Token.STRING (Buffer.contents buf) @@ -219,9 +225,9 @@ let scan_tag t = | `Chr ('a' .. 'z' as c) | `Chr ('0' .. '9' as c) | `Chr ('_' as c) -> - next t; - Buffer.add_char buf c; - loop t + next t; + Buffer.add_char buf c; + loop t | _ -> () in let () = loop t in @@ -229,13 +235,13 @@ let scan_tag t = match found.[0] with | 'A' .. 'Z' -> found | _ -> - Diagnostics.error - ~start_pos - ~end_pos:(make_position t) - ("Invalid Tag! Tags have to start with an uppercase character. Did you mean to \ - write #" - ^ String.capitalize_ascii found - ^ "?") + Diagnostics.error + ~start_pos + ~end_pos:(make_position t) + ("Invalid Tag! Tags have to start with an uppercase character. Did you mean to \ + write #" + ^ String.capitalize_ascii found + ^ "?") ;; let get_html_tag_ident t = @@ -243,9 +249,9 @@ let get_html_tag_ident t = let rec loop buf t = match t.current with | `Chr ('a' .. 'z' as c) | `Chr ('0' .. '9' as c) | `Chr ('-' as c) -> - next t; - Buffer.add_char buf c; - loop buf t + next t; + Buffer.add_char buf c; + loop buf t | _ -> Buffer.contents buf in let buf = Buffer.create 32 in @@ -254,11 +260,12 @@ let get_html_tag_ident t = match ident.[0] with | 'a' .. 'z' -> ident | _ -> - Diagnostics.error - ~start_pos - ~end_pos:(make_position t) - ("Invalid HTML tag! HTML tags have to start with a lowercase letter. Instead saw: " - ^ ident) + Diagnostics.error + ~start_pos + ~end_pos:(make_position t) + ("Invalid HTML tag! HTML tags have to start with a lowercase letter. Instead \ + saw: " + ^ ident) ;; let get_uppercase_ident t = @@ -269,9 +276,9 @@ let get_uppercase_ident t = | `Chr ('a' .. 'z' as c) | `Chr ('0' .. '9' as c) | `Chr ('_' as c) -> - next t; - Buffer.add_char buf c; - loop buf t + next t; + Buffer.add_char buf c; + loop buf t | _ -> Buffer.contents buf in let buf = Buffer.create 32 in @@ -285,18 +292,18 @@ let scan_component_open_tag t = match t.current with | `Chr 'A' .. 'Z' -> Token.COMPONENT_OPEN_TAG (get_uppercase_ident t) | `Chr c -> - Diagnostics.error - ~start_pos - ~end_pos:(make_position t) - ("Invalid Component tag! Component tags have to start with an uppercase letter. \ - Instead saw: " - ^ String.make 1 c) + Diagnostics.error + ~start_pos + ~end_pos:(make_position t) + ("Invalid Component tag! Component tags have to start with an uppercase letter. \ + Instead saw: " + ^ String.make 1 c) | `EOF -> - Diagnostics.error - ~start_pos - ~end_pos:(make_position t) - "Your Template was not closed correctly. You probably mismatched or forgot a \ - closing tag." + Diagnostics.error + ~start_pos + ~end_pos:(make_position t) + "Your Template was not closed correctly. You probably mismatched or forgot a \ + closing tag." ;; let scan_open_tag t = @@ -306,18 +313,18 @@ let scan_open_tag t = match t.current with | `Chr 'a' .. 'z' -> Token.HTML_OPEN_TAG (get_html_tag_ident t) | `Chr c -> - Diagnostics.error - ~start_pos - ~end_pos:(make_position t) - ("Invalid Template tag! Template tags have to start with a lowercase letter. \ - Instead saw: " - ^ String.make 1 c) + Diagnostics.error + ~start_pos + ~end_pos:(make_position t) + ("Invalid Template tag! Template tags have to start with a lowercase letter. \ + Instead saw: " + ^ String.make 1 c) | `EOF -> - Diagnostics.error - ~start_pos - ~end_pos:(make_position t) - "Your Template was not closed correctly. You probably mismatched or forgot a \ - closing tag." + Diagnostics.error + ~start_pos + ~end_pos:(make_position t) + "Your Template was not closed correctly. You probably mismatched or forgot a \ + closing tag." ;; let scan_component_close_tag t = @@ -328,28 +335,28 @@ let scan_component_close_tag t = match t.current with | `Chr 'A' .. 'Z' -> get_uppercase_ident t | `Chr c -> - Diagnostics.error - ~start_pos - ~end_pos:(make_position t) - ("Invalid Component tag! Component tags have to start with an uppercase letter. \ - Instead saw: " - ^ String.make 1 c) + Diagnostics.error + ~start_pos + ~end_pos:(make_position t) + ("Invalid Component tag! Component tags have to start with an uppercase \ + letter. Instead saw: " + ^ String.make 1 c) | `EOF -> - Diagnostics.error - ~start_pos - ~end_pos:(make_position t) - "Your Template was not closed correctly. You probably mismatched or forgot a \ - closing tag." + Diagnostics.error + ~start_pos + ~end_pos:(make_position t) + "Your Template was not closed correctly. You probably mismatched or forgot a \ + closing tag." in match t.current with | `Chr '>' -> - next t; - Token.COMPONENT_CLOSE_TAG close_tag + next t; + Token.COMPONENT_CLOSE_TAG close_tag | _ -> - Diagnostics.error - ~start_pos - ~end_pos:(make_position t) - ("Expected token " ^ Token.to_string Token.GREATER ^ " at this point.") + Diagnostics.error + ~start_pos + ~end_pos:(make_position t) + ("Expected token " ^ Token.to_string Token.GREATER ^ " at this point.") ;; let scan_close_tag t = @@ -360,28 +367,28 @@ let scan_close_tag t = match t.current with | `Chr 'a' .. 'z' -> Token.HTML_CLOSE_TAG (get_html_tag_ident t) | `Chr c -> - Diagnostics.error - ~start_pos - ~end_pos:(make_position t) - ("Invalid Template tag! Template tags have to start with a lowercase letter. \ - Instead saw: " - ^ String.make 1 c) + Diagnostics.error + ~start_pos + ~end_pos:(make_position t) + ("Invalid Template tag! Template tags have to start with a lowercase letter. \ + Instead saw: " + ^ String.make 1 c) | `EOF -> - Diagnostics.error - ~start_pos - ~end_pos:(make_position t) - "Your Template was not closed correctly. You probably mismatched or forgot a \ - closing tag." + Diagnostics.error + ~start_pos + ~end_pos:(make_position t) + "Your Template was not closed correctly. You probably mismatched or forgot a \ + closing tag." in match t.current with | `Chr '>' -> - next t; - close_tag + next t; + close_tag | _ -> - Diagnostics.error - ~start_pos - ~end_pos:(make_position t) - ("Expected token " ^ Token.to_string Token.GREATER ^ " at this point.") + Diagnostics.error + ~start_pos + ~end_pos:(make_position t) + ("Expected token " ^ Token.to_string Token.GREATER ^ " at this point.") ;; let scan_template_text t = @@ -389,24 +396,24 @@ let scan_template_text t = let rec loop buf t = match t.current with | `EOF -> - Diagnostics.error - ~start_pos - ~end_pos:(make_position t) - "Your Template was not closed correctly. You probably mismatched or forgot a \ - closing tag." + Diagnostics.error + ~start_pos + ~end_pos:(make_position t) + "Your Template was not closed correctly. You probably mismatched or forgot a \ + closing tag." | `Chr '{' -> Buffer.contents buf - | `Chr '<' -> - (match peek t with - | `Chr '/' -> Buffer.contents buf - | `Chr 'a' .. 'z' | `Chr 'A' .. 'Z' -> Buffer.contents buf - | _ -> - next t; - Buffer.add_char buf '<'; - loop buf t) + | `Chr '<' -> ( + match peek t with + | `Chr '/' -> Buffer.contents buf + | `Chr 'a' .. 'z' | `Chr 'A' .. 'Z' -> Buffer.contents buf + | _ -> + next t; + Buffer.add_char buf '<'; + loop buf t) | `Chr c -> - next t; - Buffer.add_char buf c; - loop buf t + next t; + Buffer.add_char buf c; + loop buf t in let buf = Buffer.create 32 in let found = loop buf t in @@ -422,9 +429,9 @@ let scan_html_attribute_ident t = | `Chr ('0' .. '9' as c) | `Chr (':' as c) | `Chr ('-' as c) -> - next t; - Buffer.add_char buf c; - loop buf t + next t; + Buffer.add_char buf c; + loop buf t | _ -> Buffer.contents buf in let buf = Buffer.create 32 in @@ -437,51 +444,52 @@ let scan_number t = let rec scan_digits t = match t.current with | `Chr ('0' .. '9' as c) -> - Buffer.add_char result c; - next t; - scan_digits t + Buffer.add_char result c; + next t; + scan_digits t | `Chr '_' -> - next t; - scan_digits t + next t; + scan_digits t | _ -> () in scan_digits t; let is_float = match t.current with - | `Chr '.' -> - (match peek t with - | `Chr '.' -> false (* Two Dots in a row mean that this is a range operator *) - | _ -> - Buffer.add_char result '.'; - next t; - scan_digits t; - true) + | `Chr '.' -> ( + match peek t with + | `Chr '.' -> false (* Two Dots in a row mean that this is a range operator *) + | _ -> + Buffer.add_char result '.'; + next t; + scan_digits t; + true) | _ -> false in (* exponent part *) let is_float = match t.current with | `Chr 'e' | `Chr 'E' -> - Buffer.add_char result 'e'; - next t; - let () = - match t.current with - | `Chr '+' -> - Buffer.add_char result '+'; - next t - | `Chr '-' -> - Buffer.add_char result '-'; - next t - | _ -> () - in - scan_digits t; - true + Buffer.add_char result 'e'; + next t; + let () = + match t.current with + | `Chr '+' -> + Buffer.add_char result '+'; + next t + | `Chr '-' -> + Buffer.add_char result '-'; + next t + | _ -> () + in + scan_digits t; + true | _ -> is_float in let result = Buffer.contents result in - if is_float - then Token.FLOAT (float_of_string result) - else Token.INT (int_of_string result) + if is_float then + Token.FLOAT (float_of_string result) + else + Token.INT (int_of_string result) ;; let skip_comment t = @@ -490,8 +498,8 @@ let skip_comment t = | `Chr '\n' | `Chr '\r' -> () | `EOF -> () | _ -> - next t; - skip t + next t; + skip t in skip t ;; @@ -499,181 +507,181 @@ let skip_comment t = let rec scan_template_token ~start_pos t = match t.current with | `Chr '{' -> - setMode Normal t; - next t; - Token.LEFT_BRACE + setMode Normal t; + next t; + Token.LEFT_BRACE | `Chr '}' -> - popMode Normal t; - next t; - Token.RIGHT_BRACE - | `Chr '<' -> - (match peek t with - | `Chr '>' -> - next_n ~n:2 t; - setMode Template t; - Token.HTML_OPEN_FRAGMENT - | `Chr 'a' .. 'z' -> - setMode Template t; - setMode TemplateAttributes t; - scan_open_tag t - | `Chr 'A' .. 'Z' -> - setMode Template t; - setMode ComponentAttributes t; - scan_component_open_tag t - | `Chr '/' -> - popMode Template t; - (match peek ~n:2 t with - | `Chr 'a' .. 'z' -> scan_close_tag t - | `Chr 'A' .. 'Z' -> scan_component_close_tag t - | `Chr '>' -> - next_n ~n:3 t; - Token.HTML_CLOSE_FRAGMENT - | `Chr c -> + popMode Normal t; + next t; + Token.RIGHT_BRACE + | `Chr '<' -> ( + match peek t with + | `Chr '>' -> + next_n ~n:2 t; + setMode Template t; + Token.HTML_OPEN_FRAGMENT + | `Chr 'a' .. 'z' -> + setMode Template t; + setMode TemplateAttributes t; + scan_open_tag t + | `Chr 'A' .. 'Z' -> + setMode Template t; + setMode ComponentAttributes t; + scan_component_open_tag t + | `Chr '/' -> ( + popMode Template t; + match peek ~n:2 t with + | `Chr 'a' .. 'z' -> scan_close_tag t + | `Chr 'A' .. 'Z' -> scan_component_close_tag t + | `Chr '>' -> + next_n ~n:3 t; + Token.HTML_CLOSE_FRAGMENT + | `Chr c -> + Diagnostics.error + ~start_pos + ~end_pos:(make_position t) + ("Invalid Template tag! Template tags have to start with an uppercase or \ + lowercase letter. Instead saw: " + ^ String.make 1 c) + | `EOF -> + Diagnostics.error + ~start_pos + ~end_pos:(make_position t) + "Your Template was not closed correctly. You probably mismatched or \ + forgot a closing tag.") + | _ -> scan_template_text t) + | `Chr '/' -> ( + match peek t with + | `Chr '>' -> + popMode Template t; + next_n ~n:2 t; + Token.HTML_OR_COMPONENT_TAG_SELF_CLOSING + | `Chr c -> Diagnostics.error ~start_pos ~end_pos:(make_position t) - ("Invalid Template tag! Template tags have to start with an uppercase or \ - lowercase letter. Instead saw: " - ^ String.make 1 c) - | `EOF -> + ("The character " ^ String.make 1 c ^ " is unknown. You should remove it.") + | `EOF -> Diagnostics.error ~start_pos ~end_pos:(make_position t) "Your Template was not closed correctly. You probably mismatched or forgot a \ closing tag.") - | _ -> scan_template_text t) - | `Chr '/' -> - (match peek t with - | `Chr '>' -> - popMode Template t; - next_n ~n:2 t; - Token.HTML_OR_COMPONENT_TAG_SELF_CLOSING - | `Chr c -> - Diagnostics.error - ~start_pos - ~end_pos:(make_position t) - ("The character " ^ String.make 1 c ^ " is unknown. You should remove it.") - | `EOF -> - Diagnostics.error - ~start_pos - ~end_pos:(make_position t) - "Your Template was not closed correctly. You probably mismatched or forgot a \ - closing tag.") | `Chr '>' -> - next t; - Token.HTML_OR_COMPONENT_TAG_END + next t; + Token.HTML_OR_COMPONENT_TAG_END | `EOF -> - Diagnostics.error - ~start_pos - ~end_pos:(make_position t) - "Your Template was not closed correctly. You probably mismatched or forgot a \ - closing tag." + Diagnostics.error + ~start_pos + ~end_pos:(make_position t) + "Your Template was not closed correctly. You probably mismatched or forgot a \ + closing tag." | _ -> scan_template_text t and scan_string_token ~start_pos t = match t.current with | `Chr '"' -> - popMode String t; - next t; - Token.DOUBLE_QUOTE + popMode String t; + next t; + Token.DOUBLE_QUOTE | `Chr '{' when peek t = `Chr '|' -> - setMode Normal t; - next_n ~n:2 t; - Token.LEFT_PIPE_BRACE + setMode Normal t; + next_n ~n:2 t; + Token.LEFT_PIPE_BRACE | `Chr '|' when peek t = `Chr '}' -> - popMode Normal t; - next_n ~n:2 t; - Token.RIGHT_PIPE_BRACE + popMode Normal t; + next_n ~n:2 t; + Token.RIGHT_PIPE_BRACE | _ -> scan_string ~start_pos t and scan_component_attributes_token ~start_pos t = match t.current with | `Chr '_' | `Chr 'a' .. 'z' -> scan_ident t | `Chr '"' -> - next t; - setMode String t; - Token.DOUBLE_QUOTE + next t; + setMode String t; + Token.DOUBLE_QUOTE | `Chr '=' -> - next t; - Token.EQUAL + next t; + Token.EQUAL | `Chr '{' -> - setMode Normal t; - next t; - Token.LEFT_BRACE + setMode Normal t; + next t; + Token.LEFT_BRACE | `Chr '}' -> - popMode Normal t; - next t; - Token.RIGHT_BRACE - | `Chr '/' -> - (match peek t with - | `Chr '>' -> - popMode ComponentAttributes t; - scan_template_token ~start_pos t - | `Chr c -> - Diagnostics.error - ~start_pos - ~end_pos:(make_position t) - ("The character " ^ String.make 1 c ^ " is unknown. You should remove it.") - | `EOF -> - Diagnostics.error - ~start_pos - ~end_pos:(make_position t) - "Your Template was not closed correctly. You probably mismatched or forgot a \ - closing tag.") + popMode Normal t; + next t; + Token.RIGHT_BRACE + | `Chr '/' -> ( + match peek t with + | `Chr '>' -> + popMode ComponentAttributes t; + scan_template_token ~start_pos t + | `Chr c -> + Diagnostics.error + ~start_pos + ~end_pos:(make_position t) + ("The character " ^ String.make 1 c ^ " is unknown. You should remove it.") + | `EOF -> + Diagnostics.error + ~start_pos + ~end_pos:(make_position t) + "Your Template was not closed correctly. You probably mismatched or forgot a \ + closing tag.") | `Chr '>' -> - popMode ComponentAttributes t; - scan_template_token ~start_pos t + popMode ComponentAttributes t; + scan_template_token ~start_pos t | `EOF -> - Diagnostics.error - ~start_pos - ~end_pos:(make_position t) - "Your Template was not closed correctly. You probably mismatched or forgot a \ - closing tag." + Diagnostics.error + ~start_pos + ~end_pos:(make_position t) + "Your Template was not closed correctly. You probably mismatched or forgot a \ + closing tag." | _ -> scan_template_text t and scan_template_attributes_token ~start_pos t = match t.current with | `Chr 'A' .. 'Z' | `Chr 'a' .. 'z' -> scan_html_attribute_ident t | `Chr '"' -> - next t; - setMode String t; - Token.DOUBLE_QUOTE + next t; + setMode String t; + Token.DOUBLE_QUOTE | `Chr '=' -> - next t; - Token.EQUAL + next t; + Token.EQUAL | `Chr '{' -> - setMode Normal t; - next t; - Token.LEFT_BRACE + setMode Normal t; + next t; + Token.LEFT_BRACE | `Chr '}' -> - popMode Normal t; - next t; - Token.RIGHT_BRACE - | `Chr '/' -> - (match peek t with - | `Chr '>' -> - popMode TemplateAttributes t; - scan_template_token ~start_pos t - | `Chr c -> - Diagnostics.error - ~start_pos - ~end_pos:(make_position t) - ("The character " ^ String.make 1 c ^ " is unknown. You should remove it.") - | `EOF -> - Diagnostics.error - ~start_pos - ~end_pos:(make_position t) - "Your Template was not closed correctly. You probably mismatched or forgot a \ - closing tag.") + popMode Normal t; + next t; + Token.RIGHT_BRACE + | `Chr '/' -> ( + match peek t with + | `Chr '>' -> + popMode TemplateAttributes t; + scan_template_token ~start_pos t + | `Chr c -> + Diagnostics.error + ~start_pos + ~end_pos:(make_position t) + ("The character " ^ String.make 1 c ^ " is unknown. You should remove it.") + | `EOF -> + Diagnostics.error + ~start_pos + ~end_pos:(make_position t) + "Your Template was not closed correctly. You probably mismatched or forgot a \ + closing tag.") | `Chr '>' -> - popMode TemplateAttributes t; - scan_template_token ~start_pos t + popMode TemplateAttributes t; + scan_template_token ~start_pos t | `EOF -> - Diagnostics.error - ~start_pos - ~end_pos:(make_position t) - "Your Template was not closed correctly. You probably mismatched or forgot a \ - closing tag." + Diagnostics.error + ~start_pos + ~end_pos:(make_position t) + "Your Template was not closed correctly. You probably mismatched or forgot a \ + closing tag." | _ -> scan_template_text t and scan_normal_token ~start_pos t = @@ -681,228 +689,227 @@ and scan_normal_token ~start_pos t = | `Chr 'A' .. 'Z' | `Chr 'a' .. 'z' | `Chr '_' -> scan_ident t | `Chr '0' .. '9' -> scan_number t | `Chr '"' -> - next t; - setMode String t; - Token.DOUBLE_QUOTE + next t; + setMode String t; + Token.DOUBLE_QUOTE | `Chr '(' -> - next t; - Token.LEFT_PAREN + next t; + Token.LEFT_PAREN | `Chr ')' -> - next t; - Token.RIGHT_PAREN + next t; + Token.RIGHT_PAREN | `Chr '[' -> - next t; - Token.LEFT_BRACK + next t; + Token.LEFT_BRACK | `Chr ']' -> - next t; - Token.RIGHT_BRACK + next t; + Token.RIGHT_BRACK | `Chr '{' -> - setMode Normal t; - next t; - Token.LEFT_BRACE + setMode Normal t; + next t; + Token.LEFT_BRACE | `Chr '}' -> - popMode Normal t; - next t; - Token.RIGHT_BRACE - | `Chr ':' -> - (match peek t with - | `Chr ':' -> - next_n ~n:2 t; - Token.DOUBLE_COLON - | `Chr '=' -> - next_n ~n:2 t; - Token.COLON_EQUAL - | _ -> - next t; - Token.COLON) + popMode Normal t; + next t; + Token.RIGHT_BRACE + | `Chr ':' -> ( + match peek t with + | `Chr ':' -> + next_n ~n:2 t; + Token.DOUBLE_COLON + | `Chr '=' -> + next_n ~n:2 t; + Token.COLON_EQUAL + | _ -> + next t; + Token.COLON) | `Chr ',' -> - next t; - Token.COMMA + next t; + Token.COMMA | `Chr ';' -> - next t; - Token.SEMICOLON - | `Chr '-' -> - if is_whitespace (peek t) - then ( next t; - Token.MINUS) - else ( + Token.SEMICOLON + | `Chr '-' -> + if is_whitespace (peek t) then ( + next t; + Token.MINUS) + else ( + match peek t with + | `Chr '>' -> + next_n ~n:2 t; + Token.ARROW + | _ -> + next t; + Token.UNARY_MINUS) + | `Chr '+' -> ( match peek t with - | `Chr '>' -> - next_n ~n:2 t; - Token.ARROW + | `Chr '+' -> + next_n ~n:2 t; + Token.PLUSPLUS | _ -> - next t; - Token.UNARY_MINUS) - | `Chr '+' -> - (match peek t with - | `Chr '+' -> - next_n ~n:2 t; - Token.PLUSPLUS - | _ -> - next t; - Token.PLUS) + next t; + Token.PLUS) | `Chr '%' -> - next t; - Token.PERCENT + next t; + Token.PERCENT | `Chr '?' -> - next t; - Token.QUESTIONMARK - | `Chr '/' -> - (match peek t with - | `Chr '/' -> - skip_comment t; - Token.COMMENT - | _ -> - next t; - Token.SLASH) - | `Chr '.' -> - (match peek t with - | `Chr '0' .. '9' -> scan_number t - | `Chr '.' -> - (match peek ~n:2 t with - | `Chr '.' -> - next_n ~n:3 t; - Token.DOTDOTDOT - | _ -> + next t; + Token.QUESTIONMARK + | `Chr '/' -> ( + match peek t with + | `Chr '/' -> + skip_comment t; + Token.COMMENT + | _ -> + next t; + Token.SLASH) + | `Chr '.' -> ( + match peek t with + | `Chr '0' .. '9' -> scan_number t + | `Chr '.' -> ( + match peek ~n:2 t with + | `Chr '.' -> + next_n ~n:3 t; + Token.DOTDOTDOT + | _ -> + next_n ~n:2 t; + Token.DOTDOT) + | _ -> + next t; + Token.DOT) + | `Chr '@' -> ( + match peek t with + | `Chr '@' -> next_n ~n:2 t; - Token.DOTDOT) - | _ -> - next t; - Token.DOT) - | `Chr '@' -> - (match peek t with - | `Chr '@' -> - next_n ~n:2 t; - Token.ATAT - | _ -> - Diagnostics.error - ~start_pos - ~end_pos:(make_position t) - "The character @ is unknown. You should remove it.") - | `Chr '#' -> - (match peek t with - | `Chr 'A' .. 'Z' -> - next t; - Token.TAG (scan_tag t) - | _ -> - Diagnostics.error - ~start_pos - ~end_pos:(make_position t) - "The character # is unknown. You should remove it.") - | `Chr '&' -> - (match peek t with - | `Chr '&' -> - next_n ~n:2 t; - Token.LOGICAL_AND - | _ -> - Diagnostics.error - ~start_pos - ~end_pos:(make_position t) - "The character & is unknown. You should remove it.") - | `Chr '|' -> - (match peek t with - | `Chr '|' -> - next_n ~n:2 t; - Token.LOGICAL_OR - | `Chr '}' -> - popMode Normal t; - next_n ~n:2 t; - Token.RIGHT_PIPE_BRACE - | `Chr '>' -> - next_n ~n:2 t; - Token.PIPE - | _ -> - Diagnostics.error - ~start_pos - ~end_pos:(make_position t) - "The character | is unknown. You should remove it.") - | `Chr '!' -> - (match peek t with - | `Chr '=' -> - next_n ~n:2 t; - Token.NOT_EQUAL - | _ -> - next t; - Token.NOT) - | `Chr '=' -> - (match peek t with - | `Chr '=' -> - next_n ~n:2 t; - Token.EQUAL_EQUAL - | _ -> - next t; - Token.EQUAL) - | `Chr '>' -> - (match peek t with - | `Chr '=' -> - next_n ~n:2 t; - Token.GREATER_EQUAL - | _ -> - next t; - Token.GREATER) - | `Chr '*' -> - (match peek t with - | `Chr '*' -> - next_n ~n:2 t; - Token.STAR_STAR - | _ -> - next t; - Token.STAR) - | `Chr '<' -> - (match peek t with - | `Chr '>' -> - next_n ~n:2 t; - Token.HTML_OPEN_FRAGMENT - | `Chr '-' -> - next_n ~n:2 t; - Token.ARROW_LEFT - | `Chr '=' -> - next_n ~n:2 t; - Token.LESS_EQUAL - | `Chr 'a' .. 'z' -> - setMode Template t; - setMode TemplateAttributes t; - scan_open_tag t - | `Chr 'A' .. 'Z' -> - setMode Template t; - setMode ComponentAttributes t; - scan_component_open_tag t - | c when is_whitespace t.prev && is_whitespace c -> - next t; - Token.LESS - | `Chr '/' -> - popMode Template t; - (match peek ~n:2 t with - | `Chr '>' -> - next_n ~n:3 t; - Token.HTML_CLOSE_FRAGMENT - | `Chr 'a' .. 'z' -> scan_close_tag t - | `Chr 'A' .. 'Z' -> scan_component_close_tag t - | `Chr c -> + Token.ATAT + | _ -> Diagnostics.error ~start_pos ~end_pos:(make_position t) - ("Invalid Template tag! Template tags have to start with an uppercase or \ - lowercase letter. Instead saw: " - ^ String.make 1 c) - | `EOF -> + "The character @ is unknown. You should remove it.") + | `Chr '#' -> ( + match peek t with + | `Chr 'A' .. 'Z' -> + next t; + Token.TAG (scan_tag t) + | _ -> Diagnostics.error ~start_pos ~end_pos:(make_position t) - "Your Template was not closed correctly. You probably mismatched or forgot a \ - closing tag.") - | _ -> - Diagnostics.error - ~start_pos - ~end_pos:(make_position t) - "The character < is unknown. You should remove it.") + "The character # is unknown. You should remove it.") + | `Chr '&' -> ( + match peek t with + | `Chr '&' -> + next_n ~n:2 t; + Token.LOGICAL_AND + | _ -> + Diagnostics.error + ~start_pos + ~end_pos:(make_position t) + "The character & is unknown. You should remove it.") + | `Chr '|' -> ( + match peek t with + | `Chr '|' -> + next_n ~n:2 t; + Token.LOGICAL_OR + | `Chr '}' -> + popMode Normal t; + next_n ~n:2 t; + Token.RIGHT_PIPE_BRACE + | `Chr '>' -> + next_n ~n:2 t; + Token.PIPE + | _ -> + Diagnostics.error + ~start_pos + ~end_pos:(make_position t) + "The character | is unknown. You should remove it.") + | `Chr '!' -> ( + match peek t with + | `Chr '=' -> + next_n ~n:2 t; + Token.NOT_EQUAL + | _ -> + next t; + Token.NOT) + | `Chr '=' -> ( + match peek t with + | `Chr '=' -> + next_n ~n:2 t; + Token.EQUAL_EQUAL + | _ -> + next t; + Token.EQUAL) + | `Chr '>' -> ( + match peek t with + | `Chr '=' -> + next_n ~n:2 t; + Token.GREATER_EQUAL + | _ -> + next t; + Token.GREATER) + | `Chr '*' -> ( + match peek t with + | `Chr '*' -> + next_n ~n:2 t; + Token.STAR_STAR + | _ -> + next t; + Token.STAR) + | `Chr '<' -> ( + match peek t with + | `Chr '>' -> + next_n ~n:2 t; + Token.HTML_OPEN_FRAGMENT + | `Chr '-' -> + next_n ~n:2 t; + Token.ARROW_LEFT + | `Chr '=' -> + next_n ~n:2 t; + Token.LESS_EQUAL + | `Chr 'a' .. 'z' -> + setMode Template t; + setMode TemplateAttributes t; + scan_open_tag t + | `Chr 'A' .. 'Z' -> + setMode Template t; + setMode ComponentAttributes t; + scan_component_open_tag t + | c when is_whitespace t.prev && is_whitespace c -> + next t; + Token.LESS + | `Chr '/' -> ( + popMode Template t; + match peek ~n:2 t with + | `Chr '>' -> + next_n ~n:3 t; + Token.HTML_CLOSE_FRAGMENT + | `Chr 'a' .. 'z' -> scan_close_tag t + | `Chr 'A' .. 'Z' -> scan_component_close_tag t + | `Chr c -> + Diagnostics.error + ~start_pos + ~end_pos:(make_position t) + ("Invalid Template tag! Template tags have to start with an uppercase or \ + lowercase letter. Instead saw: " + ^ String.make 1 c) + | `EOF -> + Diagnostics.error + ~start_pos + ~end_pos:(make_position t) + "Your Template was not closed correctly. You probably mismatched or \ + forgot a closing tag.") + | _ -> + Diagnostics.error + ~start_pos + ~end_pos:(make_position t) + "The character < is unknown. You should remove it.") | `EOF -> Token.END_OF_INPUT | `Chr c -> - Diagnostics.error - ~start_pos - ~end_pos:(make_position t) - ("The character " ^ String.make 1 c ^ " is unknown. You should remove it.") + Diagnostics.error + ~start_pos + ~end_pos:(make_position t) + ("The character " ^ String.make 1 c ^ " is unknown. You should remove it.") (* NOTE: Maybe we can ignore this and continue scanning... *) (* next t; scan_token ~start_pos t *) @@ -918,7 +925,8 @@ and scan_token ~start_pos t = ;; let scan t = - if not (current_mode t = Template || current_mode t = String) then skip_whitespace t; + if not (current_mode t = Template || current_mode t = String) then + skip_whitespace t; let start_pos = make_position t in let token = scan_token ~start_pos t in (* print_endline (Token.to_string token); *) diff --git a/lib/pinc_frontend/Pinc_Operators.ml b/lib/pinc_frontend/Pinc_Operators.ml index 47e189b..db641dc 100644 --- a/lib/pinc_frontend/Pinc_Operators.ml +++ b/lib/pinc_frontend/Pinc_Operators.ml @@ -32,22 +32,23 @@ module Binary = struct | RANGE | INCLUSIVE_RANGE - type t = - { typ : typ - ; closing_token : Token.token_type option - ; precedence : precedence - ; assoc : associativity - } + type t = { + typ : typ; + closing_token : Token.token_type option; + precedence : precedence; + assoc : associativity; + } let make = function | DOT_ACCESS -> - { typ = DOT_ACCESS; precedence = 110; assoc = Left; closing_token = None } + { typ = DOT_ACCESS; precedence = 110; assoc = Left; closing_token = None } | FUNCTION_CALL -> - { typ = FUNCTION_CALL - ; precedence = 100 - ; assoc = Left - ; closing_token = Some Token.RIGHT_PAREN - } + { + typ = FUNCTION_CALL; + precedence = 100; + assoc = Left; + closing_token = Some Token.RIGHT_PAREN; + } | POW -> { typ = POW; precedence = 70; assoc = Right; closing_token = None } | MODULO -> { typ = MODULO; precedence = 60; assoc = Left; closing_token = None } | TIMES -> { typ = TIMES; precedence = 60; assoc = Left; closing_token = None } @@ -57,26 +58,27 @@ module Binary = struct | CONCAT -> { typ = CONCAT; precedence = 40; assoc = Left; closing_token = None } | EQUAL -> { typ = EQUAL; precedence = 30; assoc = Left; closing_token = None } | NOT_EQUAL -> - { typ = NOT_EQUAL; precedence = 30; assoc = Left; closing_token = None } + { typ = NOT_EQUAL; precedence = 30; assoc = Left; closing_token = None } | GREATER -> { typ = GREATER; precedence = 30; assoc = Left; closing_token = None } | GREATER_EQUAL -> - { typ = GREATER_EQUAL; precedence = 30; assoc = Left; closing_token = None } + { typ = GREATER_EQUAL; precedence = 30; assoc = Left; closing_token = None } | LESS -> { typ = LESS; precedence = 30; assoc = Left; closing_token = None } | LESS_EQUAL -> - { typ = LESS_EQUAL; precedence = 30; assoc = Left; closing_token = None } + { typ = LESS_EQUAL; precedence = 30; assoc = Left; closing_token = None } | AND -> { typ = AND; precedence = 20; assoc = Left; closing_token = None } | OR -> { typ = OR; precedence = 10; assoc = Left; closing_token = None } | RANGE -> { typ = RANGE; precedence = 5; assoc = Left; closing_token = None } | INCLUSIVE_RANGE -> - { typ = INCLUSIVE_RANGE; precedence = 5; assoc = Left; closing_token = None } + { typ = INCLUSIVE_RANGE; precedence = 5; assoc = Left; closing_token = None } | ARRAY_ADD -> { typ = ARRAY_ADD; precedence = 0; assoc = Left; closing_token = None } | MERGE -> { typ = MERGE; precedence = 0; assoc = Left; closing_token = None } | BRACKET_ACCESS -> - { typ = BRACKET_ACCESS - ; precedence = 0 - ; assoc = Left - ; closing_token = Some Token.RIGHT_BRACK - } + { + typ = BRACKET_ACCESS; + precedence = 0; + assoc = Left; + closing_token = Some Token.RIGHT_BRACK; + } | PIPE -> { typ = PIPE; precedence = 0; assoc = Left; closing_token = None } ;; @@ -112,10 +114,10 @@ module Unary = struct | MINUS | NOT - type t = - { typ : typ - ; precedence : precedence - } + type t = { + typ : typ; + precedence : precedence; + } let make = function | MINUS -> { typ = MINUS; precedence = 100 } diff --git a/lib/pinc_frontend/Pinc_Parser.ml b/lib/pinc_frontend/Pinc_Parser.ml index b29b259..1881869 100644 --- a/lib/pinc_frontend/Pinc_Parser.ml +++ b/lib/pinc_frontend/Pinc_Parser.ml @@ -4,11 +4,11 @@ module Position = Diagnostics.Position module Token = Pinc_Token module Lexer = Pinc_Lexer -type t = - { lexer : Lexer.t - ; mutable token : Token.t - ; next : Token.t Queue.t - } +type t = { + lexer : Lexer.t; + mutable token : Token.t; + next : Token.t Queue.t; +} let ( let* ) = Option.bind @@ -30,29 +30,30 @@ let rec peek t = match token.typ with | Token.COMMENT -> peek t | typ -> - Queue.add token t.next; - typ + Queue.add token t.next; + typ ;; let optional token t = let test = t.token.typ = token in - if test then next t; + if test then + next t; test ;; let expect token t = let test = t.token.typ = token in - if test - then next t + if test then + next t else Diagnostics.error ~start_pos:t.token.start_pos ~end_pos:t.token.end_pos ("Expected: `" - ^ Token.to_string token - ^ "`, got `" - ^ Token.to_string t.token.typ - ^ "`") + ^ Token.to_string token + ^ "`, got `" + ^ Token.to_string t.token.typ + ^ "`") ;; let make ~filename src = @@ -71,47 +72,47 @@ module Helpers = struct let start_pos = t.token.start_pos in match t.token.typ with | Token.IDENT_UPPER i when typ = `Upper || typ = `All -> - next t; - i + next t; + i | Token.IDENT_LOWER i when typ = `Lower || typ = `All -> - next t; - i + next t; + i | token when typ = `Lower -> - Diagnostics.error - ~start_pos - ~end_pos:t.token.end_pos - (match token with - | Token.IDENT_UPPER i -> - "Expected to see a lowercase identifier at this point. Did you mean " - ^ String.lowercase_ascii i - ^ " instead of " - ^ i - ^ "?" - | t when Token.is_keyword t -> - "`" ^ Token.to_string t ^ "` is a keyword. Please choose another name." - | t -> - "Expected to see a lowercase identifier at this point. Instead saw " - ^ Token.to_string t) + Diagnostics.error + ~start_pos + ~end_pos:t.token.end_pos + (match token with + | Token.IDENT_UPPER i -> + "Expected to see a lowercase identifier at this point. Did you mean " + ^ String.lowercase_ascii i + ^ " instead of " + ^ i + ^ "?" + | t when Token.is_keyword t -> + "`" ^ Token.to_string t ^ "` is a keyword. Please choose another name." + | t -> + "Expected to see a lowercase identifier at this point. Instead saw " + ^ Token.to_string t) | token when typ = `Upper -> - Diagnostics.error - ~start_pos - ~end_pos:t.token.end_pos - (match token with - | Token.IDENT_LOWER i -> - "Expected to see an uppercase identifier at this point. Did you mean " - ^ String.capitalize_ascii i - ^ " instead of " - ^ i - ^ "?" - | _ -> "Expected to see an uppercase identifier at this point.") + Diagnostics.error + ~start_pos + ~end_pos:t.token.end_pos + (match token with + | Token.IDENT_LOWER i -> + "Expected to see an uppercase identifier at this point. Did you mean " + ^ String.capitalize_ascii i + ^ " instead of " + ^ i + ^ "?" + | _ -> "Expected to see an uppercase identifier at this point.") | token -> - Diagnostics.error - ~start_pos - ~end_pos:t.token.end_pos - (match token with - | t when Token.is_keyword t -> - "\"" ^ Token.to_string t ^ "\" is a keyword. Please choose another name." - | _ -> "Expected to see an identifier at this point.") + Diagnostics.error + ~start_pos + ~end_pos:t.token.end_pos + (match token with + | t when Token.is_keyword t -> + "\"" ^ Token.to_string t ^ "\" is a keyword. Please choose another name." + | _ -> "Expected to see an identifier at this point.") ;; let separated_list ~sep ~fn t = @@ -119,13 +120,13 @@ module Helpers = struct let has_sep = optional sep t in match fn t with | Some r -> - if has_sep || acc = [] - then loop (r :: acc) - else - Diagnostics.error - ~start_pos:t.token.start_pos - ~end_pos:t.token.end_pos - ("Expected list to be separated by `" ^ Token.to_string sep ^ "`") + if has_sep || acc = [] then + loop (r :: acc) + else + Diagnostics.error + ~start_pos:t.token.start_pos + ~end_pos:t.token.end_pos + ("Expected list to be separated by `" ^ Token.to_string sep ^ "`") | None -> List.rev acc in loop [] @@ -145,45 +146,44 @@ module Rules = struct let rec parse_string_template t = match t.token.typ with | Token.STRING s -> - next t; - Some (Ast.StringText s) + next t; + Some (Ast.StringText s) | Token.LEFT_PIPE_BRACE -> - next t; - let* expression = parse_expression t in - t |> expect Token.RIGHT_PIPE_BRACE; - Some (Ast.StringInterpolation expression) + next t; + let* expression = parse_expression t in + t |> expect Token.RIGHT_PIPE_BRACE; + Some (Ast.StringInterpolation expression) | _ -> None and parse_fn_param t = match t.token.typ with | Token.IDENT_LOWER key -> - next t; - Some key + next t; + Some key | _ -> None and parse_attribute ?(sep = Token.COLON) t = match t.token.typ with | Token.IDENT_LOWER key -> - next t; - expect sep t; - let value = parse_expression t in - value |> Option.map (fun value -> key, value) + next t; + expect sep t; + let value = parse_expression t in + value |> Option.map (fun value -> (key, value)) | _ -> None and parse_record_field t = match t.token.typ with | Token.IDENT_LOWER key -> - next t; - let nullable = optional Token.QUESTIONMARK t in - expect Token.COLON t; - let value = parse_expression t in - value |> Option.map (fun value -> key, (nullable, value)) + next t; + let nullable = optional Token.QUESTIONMARK t in + expect Token.COLON t; + let value = parse_expression t in + value |> Option.map (fun value -> (key, (nullable, value))) | _ -> None and parse_tag ~name t = let attributes = - if t |> optional Token.LEFT_PAREN - then ( + if t |> optional Token.LEFT_PAREN then ( let res = t |> Helpers.separated_list ~fn:parse_attribute ~sep:Token.COMMA @@ -192,24 +192,25 @@ module Rules = struct in t |> expect Token.RIGHT_PAREN; res) - else StringMap.empty + else + StringMap.empty in let transformer = - if t |> optional Token.DOUBLE_COLON - then ( + if t |> optional Token.DOUBLE_COLON then ( let bind = t |> Helpers.expect_identifier ~typ:`Lower in t |> expect Token.ARROW; let body = match parse_expression t with | None -> - Diagnostics.error - ~start_pos:t.token.start_pos - ~end_pos:t.token.end_pos - "Expected expression as transformer of tag" + Diagnostics.error + ~start_pos:t.token.start_pos + ~end_pos:t.token.end_pos + "Expected expression as transformer of tag" | Some expr -> expr in Some (Ast.Lowercase_Id bind, body)) - else None + else + None in let tag = match name with @@ -231,270 +232,275 @@ module Rules = struct and parse_template_node t = match t.token.typ with | Token.STRING s -> - next t; - Some (Ast.TextTemplateNode s) + next t; + Some (Ast.TextTemplateNode s) | Token.LEFT_BRACE -> - next t; - let expression = - match parse_expression t with - | Some e -> Ast.ExpressionTemplateNode e - | None -> - (* TODO: This is `
{}
` ... Should this be an error? Probably yes... *) - ExpressionTemplateNode (Ast.BlockExpression []) - in - t |> expect Token.RIGHT_BRACE; - Some expression + next t; + let expression = + match parse_expression t with + | Some e -> Ast.ExpressionTemplateNode e + | None -> + (* TODO: This is `
{}
` ... Should this be an error? Probably yes... *) + ExpressionTemplateNode (Ast.BlockExpression []) + in + t |> expect Token.RIGHT_BRACE; + Some expression | Token.HTML_OPEN_TAG tag -> - next t; - let attributes = - t - |> Helpers.list ~fn:(parse_attribute ~sep:Token.EQUAL) - |> List.to_seq - |> StringMap.of_seq - in - let self_closing = t |> optional Token.HTML_OR_COMPONENT_TAG_SELF_CLOSING in - let children = - if self_closing - then [] - else ( - t |> expect Token.HTML_OR_COMPONENT_TAG_END; - let children = t |> Helpers.list ~fn:parse_template_node in - t |> expect (Token.HTML_CLOSE_TAG tag); - children) - in - Some (Ast.HtmlTemplateNode { tag; attributes; children; self_closing }) + next t; + let attributes = + t + |> Helpers.list ~fn:(parse_attribute ~sep:Token.EQUAL) + |> List.to_seq + |> StringMap.of_seq + in + let self_closing = t |> optional Token.HTML_OR_COMPONENT_TAG_SELF_CLOSING in + let children = + if self_closing then + [] + else ( + t |> expect Token.HTML_OR_COMPONENT_TAG_END; + let children = t |> Helpers.list ~fn:parse_template_node in + t |> expect (Token.HTML_CLOSE_TAG tag); + children) + in + Some (Ast.HtmlTemplateNode { tag; attributes; children; self_closing }) | Token.COMPONENT_OPEN_TAG identifier -> - next t; - let attributes = - t - |> Helpers.list ~fn:(parse_attribute ~sep:Token.EQUAL) - |> List.to_seq - |> StringMap.of_seq - in - let self_closing = t |> optional Token.HTML_OR_COMPONENT_TAG_SELF_CLOSING in - let children = - if self_closing - then [] - else ( - t |> expect Token.HTML_OR_COMPONENT_TAG_END; - let children = t |> Helpers.list ~fn:parse_template_node in - t |> expect (Token.COMPONENT_CLOSE_TAG identifier); - children) - in - Some - (Ast.ComponentTemplateNode - { identifier = Uppercase_Id identifier; attributes; children }) + next t; + let attributes = + t + |> Helpers.list ~fn:(parse_attribute ~sep:Token.EQUAL) + |> List.to_seq + |> StringMap.of_seq + in + let self_closing = t |> optional Token.HTML_OR_COMPONENT_TAG_SELF_CLOSING in + let children = + if self_closing then + [] + else ( + t |> expect Token.HTML_OR_COMPONENT_TAG_END; + let children = t |> Helpers.list ~fn:parse_template_node in + t |> expect (Token.COMPONENT_CLOSE_TAG identifier); + children) + in + Some + (Ast.ComponentTemplateNode + { identifier = Uppercase_Id identifier; attributes; children }) | _ -> None and parse_statement t = match t.token.typ with (* PARSING BREAK STATEMENT *) | Token.KEYWORD_BREAK -> - next t; - let _ = optional Token.SEMICOLON t in - Some Ast.BreakStatement + next t; + let _ = optional Token.SEMICOLON t in + Some Ast.BreakStatement (* PARSING CONTINUE STATEMENT *) | Token.KEYWORD_CONTINUE -> - next t; - let _ = optional Token.SEMICOLON t in - Some Ast.ContinueStatement + next t; + let _ = optional Token.SEMICOLON t in + Some Ast.ContinueStatement (* PARSING LET STATEMENT *) - | Token.KEYWORD_LET -> - next t; - let is_mutable = t |> optional Token.KEYWORD_MUTABLE in - let identifier = Helpers.expect_identifier ~typ:`Lower t in - let is_nullable = t |> optional Token.QUESTIONMARK in - t |> expect Token.EQUAL; - let expression = parse_expression t in - let _ = optional Token.SEMICOLON t in - (match is_mutable, is_nullable, expression with - | false, true, Some expression -> - Some (Ast.OptionalLetStatement (Lowercase_Id identifier, expression)) - | true, true, Some expression -> - Some (Ast.OptionalMutableLetStatement (Lowercase_Id identifier, expression)) - | false, false, Some expression -> - Some (Ast.LetStatement (Lowercase_Id identifier, expression)) - | true, false, Some expression -> - Some (Ast.MutableLetStatement (Lowercase_Id identifier, expression)) - | _, _, None -> - Diagnostics.error - ~start_pos:t.token.start_pos - ~end_pos:t.token.end_pos - "Expected expression as right hand side of let declaration") + | Token.KEYWORD_LET -> ( + next t; + let is_mutable = t |> optional Token.KEYWORD_MUTABLE in + let identifier = Helpers.expect_identifier ~typ:`Lower t in + let is_nullable = t |> optional Token.QUESTIONMARK in + t |> expect Token.EQUAL; + let expression = parse_expression t in + let _ = optional Token.SEMICOLON t in + match (is_mutable, is_nullable, expression) with + | false, true, Some expression -> + Some (Ast.OptionalLetStatement (Lowercase_Id identifier, expression)) + | true, true, Some expression -> + Some (Ast.OptionalMutableLetStatement (Lowercase_Id identifier, expression)) + | false, false, Some expression -> + Some (Ast.LetStatement (Lowercase_Id identifier, expression)) + | true, false, Some expression -> + Some (Ast.MutableLetStatement (Lowercase_Id identifier, expression)) + | _, _, None -> + Diagnostics.error + ~start_pos:t.token.start_pos + ~end_pos:t.token.end_pos + "Expected expression as right hand side of let declaration") (* PARSING MUTATION STATEMENT *) | Token.IDENT_LOWER identifier when peek t = Token.COLON_EQUAL -> - next t; - next t; - let expression = - match parse_expression t with - | Some expression -> expression - | None -> - Diagnostics.error - ~start_pos:t.token.start_pos - ~end_pos:t.token.end_pos - "Expected expression as right hand side of mutation statement" - in - let _ = optional Token.SEMICOLON t in - Some (Ast.MutationStatement (Lowercase_Id identifier, expression)) + next t; + next t; + let expression = + match parse_expression t with + | Some expression -> expression + | None -> + Diagnostics.error + ~start_pos:t.token.start_pos + ~end_pos:t.token.end_pos + "Expected expression as right hand side of mutation statement" + in + let _ = optional Token.SEMICOLON t in + Some (Ast.MutationStatement (Lowercase_Id identifier, expression)) (* PARSING USE STATEMENT *) | Token.KEYWORD_USE -> - next t; - let identifier = Helpers.expect_identifier ~typ:`Upper t in - t |> expect Token.EQUAL; - let expression = - match parse_expression t with - | Some expression -> expression - | None -> - Diagnostics.error - ~start_pos:t.token.start_pos - ~end_pos:t.token.end_pos - "Expected expression as right hand side of use statement" - in - let _ = optional Token.SEMICOLON t in - Some (Ast.UseStatement (Uppercase_Id identifier, expression)) + next t; + let identifier = Helpers.expect_identifier ~typ:`Upper t in + t |> expect Token.EQUAL; + let expression = + match parse_expression t with + | Some expression -> expression + | None -> + Diagnostics.error + ~start_pos:t.token.start_pos + ~end_pos:t.token.end_pos + "Expected expression as right hand side of use statement" + in + let _ = optional Token.SEMICOLON t in + Some (Ast.UseStatement (Uppercase_Id identifier, expression)) | _ -> - let expr = parse_expression t in - let _ = optional Token.SEMICOLON t in - expr |> Option.map (fun expression -> Ast.ExpressionStatement expression) + let expr = parse_expression t in + let _ = optional Token.SEMICOLON t in + expr |> Option.map (fun expression -> Ast.ExpressionStatement expression) and parse_expression_part t = match t.token.typ with (* PARSING PARENTHESIZED EXPRESSION *) | Token.LEFT_PAREN -> - next t; - let expr = parse_expression t in - t |> expect Token.RIGHT_PAREN; - expr + next t; + let expr = parse_expression t in + t |> expect Token.RIGHT_PAREN; + expr (* PARSING RECORD or BLOCK EXPRESSION *) | Token.LEFT_BRACE -> - next t; - let is_record = - match t.token.typ with - | Token.IDENT_LOWER _ -> - let token = peek t in - token = Token.COLON || token = Token.QUESTIONMARK - | _ -> false - in - if is_record - then ( - let attrs = - t - |> Helpers.separated_list ~sep:Token.COMMA ~fn:parse_record_field - |> List.to_seq - |> Seq.mapi (fun index (key, (optional, value)) -> - key, (index, optional, value)) - |> StringMap.of_seq + next t; + let is_record = + match t.token.typ with + | Token.IDENT_LOWER _ -> + let token = peek t in + token = Token.COLON || token = Token.QUESTIONMARK + | _ -> false in - t |> expect Token.RIGHT_BRACE; - Some Ast.(Record attrs)) - else ( - let statements = t |> Helpers.list ~fn:parse_statement in - t |> expect Token.RIGHT_BRACE; - Some (Ast.BlockExpression statements)) + if is_record then ( + let attrs = + t + |> Helpers.separated_list ~sep:Token.COMMA ~fn:parse_record_field + |> List.to_seq + |> Seq.mapi (fun index (key, (optional, value)) -> + (key, (index, optional, value))) + |> StringMap.of_seq + in + t |> expect Token.RIGHT_BRACE; + Some Ast.(Record attrs)) + else ( + let statements = t |> Helpers.list ~fn:parse_statement in + t |> expect Token.RIGHT_BRACE; + Some (Ast.BlockExpression statements)) (* PARSING FOR IN EXPRESSION *) - | Token.KEYWORD_FOR -> - next t; - expect Token.LEFT_PAREN t; - let index_or_iterator = Helpers.expect_identifier ~typ:`Lower t in - let index, iterator = - if optional Token.COMMA t - then ( - let identifier = Helpers.expect_identifier ~typ:`Lower t in - Some (Ast.Lowercase_Id index_or_iterator), identifier) - else None, index_or_iterator - in - let iterator = Ast.Lowercase_Id iterator in - expect Token.KEYWORD_IN t; - let reverse = optional Token.KEYWORD_REVERSE t in - let* expr1 = parse_expression t in - expect Token.RIGHT_PAREN t; - let body = parse_statement t in - (match body with - | None -> - Diagnostics.error - ~start_pos:t.token.start_pos - ~end_pos:t.token.end_pos - "Expected statement as body of for loop" - | Some body -> - Some (Ast.ForInExpression { index; iterator; reverse; iterable = expr1; body })) + | Token.KEYWORD_FOR -> ( + next t; + expect Token.LEFT_PAREN t; + let index_or_iterator = Helpers.expect_identifier ~typ:`Lower t in + let index, iterator = + if optional Token.COMMA t then ( + let identifier = Helpers.expect_identifier ~typ:`Lower t in + (Some (Ast.Lowercase_Id index_or_iterator), identifier)) + else + (None, index_or_iterator) + in + let iterator = Ast.Lowercase_Id iterator in + expect Token.KEYWORD_IN t; + let reverse = optional Token.KEYWORD_REVERSE t in + let* expr1 = parse_expression t in + expect Token.RIGHT_PAREN t; + let body = parse_statement t in + match body with + | None -> + Diagnostics.error + ~start_pos:t.token.start_pos + ~end_pos:t.token.end_pos + "Expected statement as body of for loop" + | Some body -> + Some + (Ast.ForInExpression { index; iterator; reverse; iterable = expr1; body })) (* PARSING FN EXPRESSION *) | Token.KEYWORD_FN -> - next t; - expect Token.LEFT_PAREN t; - let parameters = t |> Helpers.separated_list ~sep:Token.COMMA ~fn:parse_fn_param in - expect Token.RIGHT_PAREN t; - expect Token.ARROW t; - let* body = t |> parse_expression in - Some (Ast.Function (parameters, body)) + next t; + expect Token.LEFT_PAREN t; + let parameters = + t |> Helpers.separated_list ~sep:Token.COMMA ~fn:parse_fn_param + in + expect Token.RIGHT_PAREN t; + expect Token.ARROW t; + let* body = t |> parse_expression in + Some (Ast.Function (parameters, body)) (* PARSING IF EXPRESSION *) | Token.KEYWORD_IF -> - next t; - expect Token.LEFT_PAREN t; - let* condition = t |> parse_expression in - expect Token.RIGHT_PAREN t; - let* consequent = t |> parse_statement in - let alternate = - if optional Token.KEYWORD_ELSE t then t |> parse_statement else None - in - Some (Ast.ConditionalExpression { condition; consequent; alternate }) + next t; + expect Token.LEFT_PAREN t; + let* condition = t |> parse_expression in + expect Token.RIGHT_PAREN t; + let* consequent = t |> parse_statement in + let alternate = + if optional Token.KEYWORD_ELSE t then + t |> parse_statement + else + None + in + Some (Ast.ConditionalExpression { condition; consequent; alternate }) (* PARSING TAG EXPRESSION *) | Token.TAG name -> - next t; - parse_tag ~name t + next t; + parse_tag ~name t (* PARSING TEMPLATE EXPRESSION *) | Token.HTML_OPEN_TAG _ | Token.COMPONENT_OPEN_TAG _ -> - let template_nodes = t |> Helpers.list ~fn:parse_template_node in - Some (Ast.TemplateExpression template_nodes) + let template_nodes = t |> Helpers.list ~fn:parse_template_node in + Some (Ast.TemplateExpression template_nodes) (* PARSING TEMPLATE EXPRESSION *) | Token.HTML_OPEN_FRAGMENT -> - next t; - let template_nodes = t |> Helpers.list ~fn:parse_template_node in - t |> expect Token.HTML_CLOSE_FRAGMENT; - Some (Ast.TemplateExpression template_nodes) + next t; + let template_nodes = t |> Helpers.list ~fn:parse_template_node in + t |> expect Token.HTML_CLOSE_FRAGMENT; + Some (Ast.TemplateExpression template_nodes) (* PARSING UNARY NOT EXPRESSION *) | Token.NOT -> - next t; - let operator = Ast.Operators.Unary.make NOT in - let* argument = parse_expression ~prio:operator.precedence t in - Some (Ast.UnaryExpression (Ast.Operators.Unary.NOT, argument)) + next t; + let operator = Ast.Operators.Unary.make NOT in + let* argument = parse_expression ~prio:operator.precedence t in + Some (Ast.UnaryExpression (Ast.Operators.Unary.NOT, argument)) (* PARSING UNARY MINUS EXPRESSION *) | Token.UNARY_MINUS -> - next t; - let operator = Ast.Operators.Unary.make MINUS in - let* argument = parse_expression ~prio:operator.precedence t in - Some (Ast.UnaryExpression (Ast.Operators.Unary.MINUS, argument)) + next t; + let operator = Ast.Operators.Unary.make MINUS in + let* argument = parse_expression ~prio:operator.precedence t in + Some (Ast.UnaryExpression (Ast.Operators.Unary.MINUS, argument)) (* PARSING IDENTIFIER EXPRESSION *) | Token.IDENT_LOWER identifier -> - next t; - Some (Ast.LowercaseIdentifierExpression identifier) + next t; + Some (Ast.LowercaseIdentifierExpression identifier) | Token.IDENT_UPPER identifier -> - next t; - Some (Ast.UppercaseIdentifierExpression identifier) + next t; + Some (Ast.UppercaseIdentifierExpression identifier) (* PARSING VALUE EXPRESSION *) | Token.DOUBLE_QUOTE -> - next t; - let s = t |> Helpers.list ~fn:parse_string_template in - t |> expect Token.DOUBLE_QUOTE; - Some Ast.(String s) + next t; + let s = t |> Helpers.list ~fn:parse_string_template in + t |> expect Token.DOUBLE_QUOTE; + Some Ast.(String s) | Token.INT i -> - next t; - Some Ast.(Int i) + next t; + Some Ast.(Int i) | Token.FLOAT f -> - next t; - Some Ast.(Float f) + next t; + Some Ast.(Float f) | Token.KEYWORD_TRUE -> - next t; - Some Ast.(Bool true) + next t; + Some Ast.(Bool true) | Token.KEYWORD_FALSE -> - next t; - Some Ast.(Bool false) + next t; + Some Ast.(Bool false) | Token.LEFT_BRACK -> - next t; - let expressions = - Helpers.separated_list ~sep:Token.COMMA ~fn:parse_expression t |> Array.of_list - in - expect Token.RIGHT_BRACK t; - Some Ast.(Array expressions) + next t; + let expressions = + Helpers.separated_list ~sep:Token.COMMA ~fn:parse_expression t |> Array.of_list + in + expect Token.RIGHT_BRACK t; + Some Ast.(Array expressions) | _ -> None and parse_binary_operator t = @@ -530,34 +536,34 @@ module Rules = struct | None -> left | Some { precedence; _ } when precedence < prio -> left | Some { typ = Ast.Operators.Binary.FUNCTION_CALL; closing_token; _ } -> - next t; - let arguments = - t |> Helpers.separated_list ~sep:Token.COMMA ~fn:parse_expression - in - let left = Ast.FunctionCall (left, arguments) in - let expect_close token = expect token t in - let () = Option.iter expect_close closing_token in - loop ~left ~prio t - | Some { typ = operator; precedence; assoc; closing_token } -> - next t; - let new_prio = - match assoc with - | Left -> precedence + 1 - | Right -> precedence - in - (match parse_expression ~prio:new_prio t with - | None -> - Diagnostics.error - ~start_pos:t.token.start_pos - ~end_pos:t.token.end_pos - ("Expected expression on right hand side of `" - ^ Ast.Operators.Binary.to_string operator - ^ "`") - | Some right -> - let left = Ast.BinaryExpression (left, operator, right) in - let expect_close token = expect token t in - let () = Option.iter expect_close closing_token in - loop ~left ~prio t) + next t; + let arguments = + t |> Helpers.separated_list ~sep:Token.COMMA ~fn:parse_expression + in + let left = Ast.FunctionCall (left, arguments) in + let expect_close token = expect token t in + let () = Option.iter expect_close closing_token in + loop ~left ~prio t + | Some { typ = operator; precedence; assoc; closing_token } -> ( + next t; + let new_prio = + match assoc with + | Left -> precedence + 1 + | Right -> precedence + in + match parse_expression ~prio:new_prio t with + | None -> + Diagnostics.error + ~start_pos:t.token.start_pos + ~end_pos:t.token.end_pos + ("Expected expression on right hand side of `" + ^ Ast.Operators.Binary.to_string operator + ^ "`") + | Some right -> + let left = Ast.BinaryExpression (left, operator, right) in + let expect_close token = expect token t in + let () = Option.iter expect_close closing_token in + loop ~left ~prio t) in let* left = parse_expression_part t in Some (loop ~prio ~left t) @@ -568,39 +574,41 @@ module Rules = struct | Token.KEYWORD_PAGE | Token.KEYWORD_COMPONENT | Token.KEYWORD_LIBRARY - | Token.KEYWORD_STORE ) as typ -> - next t; - let identifier = Helpers.expect_identifier ~typ:`Upper t in - let attributes = - if optional Token.LEFT_PAREN t - then ( - let attributes = - Helpers.separated_list ~sep:Token.COMMA ~fn:parse_attribute t - |> List.to_seq - |> StringMap.of_seq - in - t |> expect Token.RIGHT_PAREN; - Some attributes) - else None - in - let body = t |> parse_expression in - (match body with - | None -> - Diagnostics.error - ~start_pos:t.token.start_pos - ~end_pos:t.token.end_pos - "Expected declaration to have a body" - | Some body -> - (match typ with - | Token.KEYWORD_SITE -> Some (identifier, Ast.SiteDeclaration (attributes, body)) - | Token.KEYWORD_PAGE -> Some (identifier, Ast.PageDeclaration (attributes, body)) - | Token.KEYWORD_COMPONENT -> - Some (identifier, Ast.ComponentDeclaration (attributes, body)) - | Token.KEYWORD_STORE -> - Some (identifier, Ast.StoreDeclaration (attributes, body)) - | Token.KEYWORD_LIBRARY -> - Some (identifier, Ast.LibraryDeclaration (attributes, body)) - | _ -> assert false)) + | Token.KEYWORD_STORE ) as typ -> ( + next t; + let identifier = Helpers.expect_identifier ~typ:`Upper t in + let attributes = + if optional Token.LEFT_PAREN t then ( + let attributes = + Helpers.separated_list ~sep:Token.COMMA ~fn:parse_attribute t + |> List.to_seq + |> StringMap.of_seq + in + t |> expect Token.RIGHT_PAREN; + Some attributes) + else + None + in + let body = t |> parse_expression in + match body with + | None -> + Diagnostics.error + ~start_pos:t.token.start_pos + ~end_pos:t.token.end_pos + "Expected declaration to have a body" + | Some body -> ( + match typ with + | Token.KEYWORD_SITE -> + Some (identifier, Ast.SiteDeclaration (attributes, body)) + | Token.KEYWORD_PAGE -> + Some (identifier, Ast.PageDeclaration (attributes, body)) + | Token.KEYWORD_COMPONENT -> + Some (identifier, Ast.ComponentDeclaration (attributes, body)) + | Token.KEYWORD_STORE -> + Some (identifier, Ast.StoreDeclaration (attributes, body)) + | Token.KEYWORD_LIBRARY -> + Some (identifier, Ast.LibraryDeclaration (attributes, body)) + | _ -> assert false)) | Token.END_OF_INPUT -> None | _ -> assert false ;; diff --git a/lib/pinc_frontend/Pinc_Token.ml b/lib/pinc_frontend/Pinc_Token.ml index f0e76fe..440ff56 100644 --- a/lib/pinc_frontend/Pinc_Token.ml +++ b/lib/pinc_frontend/Pinc_Token.ml @@ -76,11 +76,11 @@ type token_type = | HTML_OR_COMPONENT_TAG_END | END_OF_INPUT -type t = - { typ : token_type - ; start_pos : Position.t - ; end_pos : Position.t - } +type t = { + typ : token_type; + start_pos : Position.t; + end_pos : Position.t; +} let make ~start_pos ~end_pos typ = { typ; start_pos; end_pos } @@ -263,8 +263,8 @@ let keyword_of_string = function let lookup_keyword str = match keyword_of_string str with | Some t -> t - | None -> - (match str.[0] with - | 'A' .. 'Z' -> IDENT_UPPER str - | _ -> IDENT_LOWER str) + | None -> ( + match str.[0] with + | 'A' .. 'Z' -> IDENT_UPPER str + | _ -> IDENT_LOWER str) ;; diff --git a/lib/pinc_frontend/Pinc_Token.mli b/lib/pinc_frontend/Pinc_Token.mli index 2f3a2f1..bb494d6 100644 --- a/lib/pinc_frontend/Pinc_Token.mli +++ b/lib/pinc_frontend/Pinc_Token.mli @@ -76,11 +76,11 @@ type token_type = | HTML_OR_COMPONENT_TAG_END | END_OF_INPUT -type t = - { typ : token_type - ; start_pos : Position.t - ; end_pos : Position.t - } +type t = { + typ : token_type; + start_pos : Position.t; + end_pos : Position.t; +} val make : start_pos:Position.t -> end_pos:Position.t -> token_type -> t val to_string : token_type -> string -- 2.51.2