From 5c2e13868c18543cd6d0c12f04b8e662b648fefe Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Miko=C5=82aj=20Swoboda?= <331319@uwr.edu.pl> Date: Wed, 1 Oct 2025 01:49:27 +0200 Subject: [PATCH 1/3] Fram backend - Enabled Printer.ml to output Fram syntax. - Added a Fram code generation module. - Re-added tests from old Fram backend. Use test/sexpr to witness that something works. Effect reconstruction in test/calc still takes too long. - Re-added framtools with the Parsing module. --- bin/main.ml | 1 + framtools/Parsing.fram | 24 +++ lib/Backend/Fram.ml | 454 +++++++++++++++++++++++++++++++++++++++++ lib/Backend/Printer.ml | 217 ++++++++++++++++++++ test/calc/Calc.fram | 41 ++++ test/calc/Parser.mly | 36 ++++ test/calc/dune | 10 + test/sexpr/Parser.mly | 19 ++ test/sexpr/SExpr.fram | 57 ++++++ test/sexpr/dune | 10 + 10 files changed, 869 insertions(+) create mode 100644 framtools/Parsing.fram create mode 100644 lib/Backend/Fram.ml create mode 100644 test/calc/Calc.fram create mode 100644 test/calc/Parser.mly create mode 100644 test/calc/dune create mode 100644 test/sexpr/Parser.mly create mode 100644 test/sexpr/SExpr.fram create mode 100644 test/sexpr/dune diff --git a/bin/main.ml b/bin/main.ml index ab4932b..6fc553e 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -56,6 +56,7 @@ let write (out, name, format) = | ".ml" -> (module Cpspg.Backend.Ml.Make (Settings) (Grammar) (Automaton)) | ".mli" -> (module Cpspg.Backend.Mli.Make (Settings) (Grammar) (Automaton)) | ".dot" -> (module Cpspg.Backend.Dot.Make (Settings) (Grammar) (Automaton)) + | ".fram" -> (module Cpspg.Backend.Fram.Make (Settings) (Grammar) (Automaton)) | _ -> if format == "" then Logger.report_err "could not determine output format for %s" name diff --git a/framtools/Parsing.fram b/framtools/Parsing.fram new file mode 100644 index 0000000..53c4a52 --- /dev/null +++ b/framtools/Parsing.fram @@ -0,0 +1,24 @@ +{# This file should be placed in the same directory as the generated + parser #} + +pub data Pos = Pos of + { fname : String + , lnum : Int + , bol : Int + , cnum : Int } + +pub let dummyPos = Pos {fname = "", lnum = 0, bol = 0, cnum = 0-1} + +pub data Lex E Tok = + { token : Unit ->[E] Tok + , startPos : Unit ->[E] Pos + , curPos : Unit -> [E] Pos } + +pub data Error E = Error of ({type X} -> String ->[E] X) +pub method parseError {E} (Error f : Error E) = f + +{## Error-reporting function. Use this function to report errors + in semantic actions. If an error is reported, the result + returned by the parser will be the passed string wrapped in + a `Left` constructor. ##} +pub let error {E, ~error : Error E} s = ~error.parseError s diff --git a/lib/Backend/Fram.ml b/lib/Backend/Fram.ml new file mode 100644 index 0000000..bc9c3c3 --- /dev/null +++ b/lib/Backend/Fram.ml @@ -0,0 +1,454 @@ +module IntMap = Map.Make (Int) +module SymbolMap = Map.Make (Automaton.Symbol) + +let dummy_span = Lexing.dummy_pos, Lexing.dummy_pos +let verbatim data = { Raw.span = dummy_span; data = String.trim data } + +let rec rev_mapi f i acc = function + | [] -> acc + | x :: xs -> rev_mapi f (i + 1) (f i x :: acc) xs +;; + +let filter_mapi f xs = + let rec aux i = function + | [] -> [] + | x :: xs -> + (match f i x with + | None -> aux (i + 1) xs + | Some v -> v :: aux (i + 1) xs) + in + aux 0 xs +;; + +let prelude = {| +import Parsing +import List +parameter E_err +parameter ~error : Parsing.Error E_err +|} |> verbatim +[@@ocamlformat "disable"] + +let action_lib = {| +parameter ~loc +parameter E_err +parameter ~error : Parsing.Error E_err + +pub let _kw_endpos _ = +match ~loc with +| l :: _ => snd l +| [] => Parsing.dummyPos +end + +pub let _kw_startpos (n : Int) = +match List.nth ~loc (n - 1) with +| Some l => fst l +| None => _kw_endpos n +end + +pub let _kw_symbolstartpos _ = Parsing.error "unimplemented: $symbolstartpos" +pub let _kw_startofs _ = Parsing.error "unimplemented: $startofs" +pub let _kw_endofs _ = Parsing.error "unimplemented: $endofs" +pub let _kw_symbolstartofs _ = Parsing.error "unimplemented: $symbolstartofs" +pub let _kw_loc n = _kw_startpos n, _kw_endpos n +pub let _kw_sloc _ = Parsing.error "unimplemented: $sloc" +|} |> verbatim +[@@ocamlformat "disable"] + +let state_lib = {| +let lexfun {E_err, E_lex, + ~error : Parsing.Error E_err, + ~lex : Parsing.Lex E_lex Tok} ppos = + let (aux : Unit ->[E_err, E_lex] Tok) = + fn () => ~lex.token ppos + in aux () + +pub let shift {E_err, E_lex, + ~error : Parsing.Error E_err, + ~lex : Parsing.Lex E_lex Tok} () = + let (aux : Unit ->[E_err, E_lex] Pair Tok (Pair Parsing.Pos Parsing.Pos)) = + (fn () => + let tok = lexfun () in + let loc = ~lex.startPos (), ~lex.curPos () in + (tok, loc)) + in aux () + + +parameter ~loc +let locShift l = l :: ~loc + +let locDummy xs = + match xs with + | [] => (Parsing.dummyPos, Parsing.dummyPos) + | (_, e) :: _ => (e, e) + end + +let locReduce {E_err, E_lex, + ~error : Parsing.Error E_err, + ~lex : Parsing.Lex E_lex Tok} n = + let (aux : Int ->[E_err, E_lex] List (Pair Parsing.Pos Parsing.Pos)) = + (fn (n : Int) => + if n == 0 then locDummy ~loc :: ~loc + else + (let rec skip (n : Int) xs = + if n == 0 then xs + else skip (n - 1) + (List.tlErr {~onError = (fn () => Parsing.error "tl")} + xs) in + let l = (fst (List.nthErr {~onError = (fn () => Parsing.error "nth")} + ~loc + (n - 1)), + snd (List.hdErr {~onError = (fn () => Parsing.error "hd")} + ~loc)) in + l :: skip n ~loc)) + in aux n + +parameter R_lex +parameter ~lex : Parsing.Lex R_lex Tok +parameter E_err +parameter ~error : Parsing.Error E_err +|} |> verbatim +[@@ocamlformat "disable"] + +let error_handler = {| +Parsing.Error (effect x / _ => Left x) + return x => Right x +|} |> verbatim +[@@ocamlformat "disable"] + +module Make (S : Types.BackEndSettings) (G : Types.Grammar) (A : Types.Automaton) : + Types.Code = struct + open Automaton + module PP = Printer.Fram (S) + module D = Dot.Make (S) (G) (A) + + (* Utils *) + + let term_name t = (G.term t).ti_name.data + let nterm_name n = (G.nterm n).ni_name.data + + let symbol_name = function + | Term t -> term_name t + | NTerm n -> nterm_name n + ;; + + let symbol_has_value = function + | NTerm _ -> true + | Term t -> (G.term t).ti_ty |> Option.is_some + ;; + + (** Checks whether this is the last shift before end-of-stream is (possibly) reached *) + let is_eof_shift state sym = + let closure = state.s_kernel @ state.s_closure in + let group = List.find (shifts_group (Symbol.Term sym)) closure in + let item = List.find (shifts_item (Symbol.Term sym)) group.g_items in + List.length item.i_suffix = 1 + && TermSet.equal group.g_lookahead (TermSet.singleton Terminal.eof) + ;; + + (* Identifiers *) + + let arg_id symbol idx = + if S.readable_ids + then Printf.sprintf "a%d_%s" idx (symbol_name symbol) + else Printf.sprintf "a%d" idx + ;; + + (* Continuations are prefixed with underscore because + precedence declarations could make them unused + (see unary minus in `calc/ParserPres.mly`) *) + let cont_id group idx = + match S.readable_ids, group.g_starting with + | false, _ -> Printf.sprintf "_c%d" idx + | true, false -> Printf.sprintf "_c%d_%s" idx (nterm_name group.g_symbol) + | true, true -> Printf.sprintf "_c%d_%s_starting" idx (nterm_name group.g_symbol) + ;; + + (* TODO: Include rule name in action name when [S.readable_ids] is enabled *) + let semantic_action_id _action idx = Printf.sprintf "a%d" idx + let state_id idx = Printf.sprintf "%s%d" (if S.readable_ids then "state_" else "s") idx + + (* Helpers *) + + let make_vars vars expr = + let binding (name, valu) = PP.{ name; named_args = []; args = []; expr = valu; comment = None } in + let bindings = List.map binding vars in + PP.ExprLet (PP.NonRecursive, bindings, expr) + ;; + + let make_var name valu expr = make_vars [ name, valu ] expr + + (* Rest *) + + let make_token_type symbols = + let get_info = function + | NTerm _ -> None + | Term t -> Some (G.term t) + and cmp a b = String.compare a.ti_name.data b.ti_name.data in + let infos = List.filter_map get_info symbols |> List.sort cmp in + List.map (fun i -> { PP.name = i.ti_name; contents = i.ti_ty }) infos + ;; + + let make_semantic_action_code action = + let n = List.length action.sa_args + and code, keywords = action.sa_code.data in + let s, e = action.sa_code.span in + let make_part l r = + let len = r.Lexing.pos_cnum - l.Lexing.pos_cnum + and ofs = l.pos_cnum - s.pos_cnum - 1 in + { data = String.sub code ofs len; span = l, r } + and get_impl = function + | Raw.KwStartpos -> Printf.sprintf "(_kw_startpos %d)" n + | Raw.KwEndpos -> Printf.sprintf "(_kw_endpos %d)" n + | Raw.KwSymbolstartpos -> Printf.sprintf "(_kw_symbolstartpos %d)" n + | Raw.KwStartofs -> Printf.sprintf "(_kw_startofs %d)" n + | Raw.KwEndofs -> Printf.sprintf "(_kw_endofs %d)" n + | Raw.KwSymbolstartofs -> Printf.sprintf "(_kw_symbolstartofs %d)" n + | Raw.KwLoc -> Printf.sprintf "(_kw_loc %d)" n + | Raw.KwSloc -> Printf.sprintf "(_kw_sloc %d)" n + | Raw.KwArg i -> + (match List.nth_opt action.sa_args (i - 1) with + | Some (Some a) -> a + | Some None -> Printf.sprintf "_arg%d" i + | None -> "()") + in + let rec aux pos = function + | [] -> [ make_part pos { e with pos_cnum = e.pos_cnum - 1 } ] + | (kw, l, r) :: kws -> + let part = make_part pos l + and impl = get_impl kw |> verbatim in + part :: impl :: aux r kws + in + let parts = aux { s with pos_cnum = s.pos_cnum + 1 } keywords in + PP.ExprGrouped (PP.ExprVerbatim parts) + ;; + + let make_semantic_action (id, action) = + let aux i = function + | Some a -> PP.ExprId a + | None -> PP.ExprId (Printf.sprintf "_arg%d" (i + 1)) + in + let args = rev_mapi aux 0 [ PP.ExprUnit ] action.sa_args in + let named_args = [PP.ExprLabeled "loc"] in + let expr = make_semantic_action_code action in + PP.{ name = semantic_action_id action id; named_args; args; expr; comment = None } + ;; + + let make_semantic_actions actions = + let bindings = IntMap.bindings actions |> List.map make_semantic_action in + if IntMap.cardinal actions = 0 + then PP.StructVerbatim (verbatim "(* No actions *)") + else PP.StructLet (PP.Public, PP.NonRecursive, bindings) + ;; + + let make_args_ids symbols = + let f i sym = if symbol_has_value sym then Some (arg_id sym i) else None in + filter_mapi f symbols |> List.map (fun s -> PP.ExprId s) + ;; + + let make_cont_ids p groups = + let iter i g = if p g then Some (cont_id g i) else None in + filter_mapi iter groups |> List.map (fun s -> PP.ExprId s) + ;; + + let make_goto_call state sym = + let closure = state.s_kernel @ state.s_closure + and callee = state_id (SymbolMap.find sym state.s_goto) in + let tok = [ PP.ExprId "t" ] + and valu = if symbol_has_value sym then [ PP.ExprId "x" ] else [] + and args = make_args_ids (List.find (shifts_group sym) closure).g_prefix + and const = make_cont_ids (shifts_group sym) closure in + PP.ExprCall (callee, tok @ valu @ args @ const) + ;; + + let make_continuation state group idx = + let sym = NTerm group.g_symbol in + let name = cont_id group idx + and args = [ PP.ExprId "t"; PP.ExprId "x" ] + and named_args = [ PP.ExprLabeled "loc" ] + and body = make_goto_call state sym in + PP.{ name; named_args; args; expr = body; comment = None } + ;; + + let make_semantic_action_args call symbols = + let rec aux c (sym, i, acc) = + match sym, c with + | s :: sym, None -> + let arg = if symbol_has_value s then PP.ExprId (arg_id s i) else PP.ExprUnit in + sym, i + 1, arg :: acc + | sym, Some inline -> + let action = IntMap.find inline.ac_id A.automaton.a_actions in + let name = semantic_action_id action inline.ac_id |> Printf.sprintf "Actions.%s" + and sym, i, args = List.fold_right aux inline.ac_args (sym, i, []) in + let args = List.rev_append args [ PP.ExprUnit ] in + let expr = PP.ExprGrouped (PP.ExprCall (name, args)) in + sym, i, expr :: acc + | [], _ -> assert false + in + let sym, _, acc = List.fold_right aux call (symbols, 0, []) in + assert (sym = []); + List.rev_append acc [ PP.ExprUnit ] + ;; + + let make_semantic_action_call group = function + | { i_action = None; _ } -> + let args = make_args_ids group.g_prefix in + assert (List.length args = 1); + List.hd args + | { i_action = Some a; _ } -> + let action = IntMap.find a.ac_id A.automaton.a_actions in + let name = semantic_action_id action a.ac_id |> Printf.sprintf "Actions.%s" in + let args = make_semantic_action_args a.ac_args group.g_prefix in + PP.ExprCall (name, args) + ;; + + let make_action_shift state sym = + let patterns = + match symbol_has_value (Term sym) with + | true -> [ term_name sym, Some "x" ] + | false -> [ term_name sym, None ] + in + let shift = PP.ExprVerbatim [ verbatim "shift ()" ] + and locs = PP.ExprVerbatim [ verbatim "locShift (snd t)" ] + and comment = if S.comments then Some " Shift " else None in + let expr = + let expr = make_goto_call state (Term sym) in + (* When, after shifting we can reach the end of stream, we should not look at the token that follows. + Instead, let's reuse the token that we already have, because we shouldn't look at it anyway *) + let expr = if is_eof_shift state sym then expr else make_var "t" shift expr in + if S.locations then make_var "~loc" locs expr else expr + in + PP.{ patterns; cexpr = expr; ccomment = comment } + ;; + + let make_action_reduce state lookahead i j = + let group = List.nth (state.s_kernel @ state.s_closure) i in + let n, item = List.length group.g_prefix, List.nth group.g_items j in + let pattern sym = + match symbol_has_value (Term sym) with + | _ when sym = Terminal.eof -> "_", None + | true -> term_name sym, Some "_" + | false -> term_name sym, None + in + let call = make_semantic_action_call group item + and patterns = TermSet.elements lookahead |> List.map pattern + and comment = if S.comments then Some " Reduce " else None + and locs = PP.ExprVerbatim [ Printf.sprintf "locReduce %d" n |> verbatim ] in + let expr = + let args = [ PP.ExprId "t"; PP.ExprId "x" ] in + let expr = PP.ExprCall (cont_id group i, args) in + let vars = if S.locations then [ "~loc", locs; "x", call ] else [ "x", call ] in + make_vars vars expr + in + PP.{ patterns; cexpr = expr; ccomment = comment } + ;; + + let make_action state lookahead = function + | Shift -> + TermSet.to_seq lookahead |> Seq.map (make_action_shift state) |> List.of_seq + | Reduce (i, j) -> [ make_action_reduce state lookahead i j ] + ;; + + let make_action_failure _ = (* argument is a state *) + let failure = verbatim "Parsing.error \"\"" + (* TODO: expected terms in error message. + List.fold_left (fun acc (t, _) -> TermSet.union t acc) TermSet.empty state.s_action + |> TermSet.elements + |> List.map (fun t -> term_name t |> Printf.sprintf "%S") + |> String.concat "; " + |> Printf.sprintf "fail t [ %s ]" + |> verbatim + *) + in + PP.{ patterns = [ "_", None ]; cexpr = PP.ExprVerbatim [ failure ]; ccomment = None } + ;; + + let make_actions state = + let cases = List.concat_map (fun (l, m) -> make_action state l m) state.s_action + and failure = make_action_failure state in + PP.ExprMatch (PP.ExprCall ("fst", [ PP.ExprId "t" ]), cases @ [ failure ]) + ;; + + let make_starting_actions state = + let group = List.hd state.s_kernel in + let item = List.nth group.g_items 0 in + let expr = PP.ExprCall (cont_id group 0, [ PP.ExprId "t"; PP.ExprId "x" ]) in + let expr = make_var "x" (make_semantic_action_call group item) expr in + expr + ;; + + let make_state_body st = + let kn = List.length st.s_kernel + and group = List.hd st.s_kernel in + let conts = List.mapi (fun i g -> make_continuation st g (i + kn)) st.s_closure in + let body = + if group.g_starting && (List.hd group.g_items).i_suffix = [] + then make_starting_actions st + else make_actions st + in + PP.ExprLet (PP.Recursive, conts, body) + ;; + + let make_state_comment state = + let section name = function + | c when String.trim c = "" -> "" + | c -> + let c = String.trim c |> String.split_on_char '\n' in + let c = List.map (( ^ ) "\n ") c |> String.concat "" in + Printf.sprintf "\n%s:%s\n" name c + in + let ci = Format.asprintf "%a" D.fmt_state state |> section "ITEMS" + and cs = Format.asprintf "%a" D.fmt_state_shifts state |> section "GOTO" + and ca = Format.asprintf "%a" D.fmt_state_actions state |> section "ACTION" in + Printf.sprintf "%s%s%s" ci cs ca + ;; + + let make_state (id, state) = + let name = state_id id + and tok = [ PP.ExprId "t" ] + and args = make_args_ids (List.hd state.s_kernel).g_prefix + and named_args = [ PP.ExprLabeled "loc" ] + and cont = make_cont_ids (Fun.const true) state.s_kernel + and body = make_state_body state + and comment = if S.comments then Some (make_state_comment state) else None in + PP.{ name; named_args; args = tok @ args @ cont; expr = body; comment } + ;; + + let make_states states = + if IntMap.cardinal states = 0 + then PP.StructVerbatim (verbatim "(* No states *)") + else PP.StructLet (PP.Public, PP.Recursive, IntMap.bindings states |> List.map make_state) + ;; + + let make_entry symbol id = + let state = Printf.sprintf "States.%s" (state_id id) + and args = [ PP.ExprUnit ] + and cont = PP.ExprVerbatim [ verbatim "(fn _ x => x)" ] in + let expr = PP.ExprCall (state, [ PP.ExprId "t"; cont ]) in + let expr = make_var "t" (PP.ExprVerbatim [ verbatim "States.shift ()" ]) expr in + let expr = make_var "~loc" (PP.ExprVerbatim [ verbatim "[]" ]) expr in + let expr = PP.ExprHandle ( + { name = "~error"; named_args = []; args = []; + expr = PP.ExprVerbatim [ error_handler ]; comment = None }, + expr) in + let named_args = [ PP.ExprLabeled "lex" ] in + let binding = PP.{ name = nterm_name symbol; named_args; args; expr; comment = None } in + PP.StructLet (PP.Public, PP.NonRecursive, [ binding ]) + ;; + + let make_file { a_header; a_actions; a_states; a_starting } = + let header = List.map (fun n -> PP.StructVerbatim n) a_header + and actions = [ PP.StructVerbatim action_lib; make_semantic_actions a_actions ] + and states = [ PP.StructVerbatim state_lib; make_states a_states ] + and starting = List.map (fun (sym, id) -> make_entry sym id) a_starting in + [] + @ [ PP.StructVerbatim prelude ] + @ header + @ [ PP.StructType (PP.Public, PP.NonRecursive, "Tok", make_token_type G.symbols) + ; PP.StructModule (PP.Public, "Actions", actions) + ; PP.StructModule (PP.Public, "States", states) + ] + @ starting + ;; + + let write () = make_file A.automaton |> PP.pp_structures +end diff --git a/lib/Backend/Printer.ml b/lib/Backend/Printer.ml index 37f8908..5ff9113 100644 --- a/lib/Backend/Printer.ml +++ b/lib/Backend/Printer.ml @@ -238,3 +238,220 @@ module Ml (S : Types.BackEndSettings) = struct and pp_structures xs = iter_sep pp_structure print_newline xs end + + +module Fram (S : Types.BackEndSettings) = struct + include Make (S) + + type public = + | Public + | Private + + type recursive = + | Recursive + | NonRecursive + + type expr = + | ExprUnit + | ExprId of string + | ExprCall of string * expr list + | ExprLabeled of string + | ExprGrouped of expr + | ExprSeq of expr list + | ExprLet of recursive * binding list * expr + | ExprHandle of binding * expr + | ExprMatch of expr * case list + | ExprVerbatim of string Raw.node list + + and binding = + { name : string + ; named_args : expr list + ; args : expr list + ; expr : expr + ; comment : string option + } + + and case = + { patterns : (string * string option) list + ; cexpr : expr + ; ccomment : string option + } + + type constructor = + { name : string Raw.node + ; contents : string Raw.node option + } + + type structure = + | StructVerbatim of string Raw.node + | StructType of public * recursive * string * constructor list + | StructLet of public * recursive * binding list + | StructModule of public * string * structure list + + let if_pub public f g = + match public with + | Public -> f () + | Private -> g () + + let if_rec recursive f g = + match recursive with + | Recursive -> f () + | NonRecursive -> g () + + let pp_pub public = if_pub public (fun () -> "pub ") (fun () -> "") + + let pp_rec recursive = if_rec recursive (fun () -> "rec ") (fun () -> "") + + let pp_line_directive f l c = + if not !at_newline then print_newline (); + Printf.sprintf "#@ %d %s\n%s" l f (String.make c ' ') |> output_string_raw + ;; + + let pp_string_node ?(trim = true) { Raw.span = loc, _; data } = + match loc with + | _ when (not S.line_directives) && trim -> output_string (String.trim data) + | _ when not S.line_directives -> output_string data + | loc when loc = Lexing.dummy_pos -> output_string data + | loc -> + pp_line_directive loc.pos_fname loc.pos_lnum (loc.pos_cnum - loc.pos_bol); + output_string_raw data; + pp_line_directive S.name (!line_number + 2) 0 + ;; + + let pp_comment = function + | None -> () + | Some c -> + output_string "{#"; + indented output_string c; + output_string "#}\n" + ;; + + let rec pp_expr = function + | ExprUnit -> output_string "()" + | ExprId s -> output_string s + | ExprCall (callee, args) -> + let rest expr = + output_string " "; + pp_expr expr + in + output_string callee; + List.iter rest args + | ExprLabeled s -> printf "~%s" s + | ExprGrouped expr -> + output_char '('; + pp_expr expr; + output_char ')' + | ExprSeq [] -> assert false + | ExprSeq (expr :: exprs) -> + let rest expr = + output_string ";\n"; + pp_expr expr + in + pp_expr expr; + List.iter rest exprs + | ExprLet (_, [], expr) -> pp_expr expr + | ExprLet (recursive, bindings, expr) -> + let binding_sep = if_rec recursive (fun () -> "\nlet ") (fun () -> " in\nlet ") in + if_rec recursive (fun () -> output_string "rec let ") (fun () -> output_string "let "); + iter_sep (pp_binding false) (fun () -> output_string binding_sep) bindings; + if_rec recursive (fun () -> output_string " end") (fun () -> ()); + output_string " in\n"; + pp_expr expr + | ExprHandle (binding, expr) -> + output_string "handle "; + pp_binding false binding; + output_string " in\n"; + pp_expr expr + | ExprMatch (expr, cases) -> + output_string "match "; + pp_expr expr; + output_string " with\n"; + iter_sep pp_case print_newline cases; + output_string "\nend\n" + | ExprVerbatim data -> + let trim = List.length data = 1 in + List.iter (pp_string_node ~trim) data + + and pp_binding bl { name; named_args; args; expr; comment = _ } = + let pp_arg a = + output_char ' '; + pp_expr a + and pp_named_arg a = + output_string ", "; + pp_expr a + in let pp_named_args nargs = + match nargs with + | [] -> () + | a :: nargs -> + output_string " {"; + pp_expr a; + List.iter pp_named_arg nargs; + output_char '}' + and pp_block_expr expr = + print_newline (); + indented pp_expr expr; + print_newline () + in + output_string name; + pp_named_args named_args; + List.iter pp_arg args; + output_string " = "; + if bl then pp_block_expr expr else pp_expr expr + + (* We have no disjunctions of patterns yet. + For now, this function copies the same right-hand-side expression + for each left-hand-side pattern in `patterns`. *) + and pp_case { patterns; cexpr; ccomment } = + let pp_pattern = function + | name, None -> printf "| %s " name + | name, Some arg -> printf "| %s %s " name arg + in let pp_simple_case pattern = + pp_comment ccomment; + pp_pattern pattern; + output_string "=>\n"; + indented pp_expr cexpr + in + iter_sep pp_simple_case print_newline patterns + ;; + + let pp_constructor { name; contents } = + output_string "| "; + pp_string_node name; + match contents with + | None -> print_newline () + | Some c -> + output_string " of ("; + pp_string_node c; + output_string ")\n" + ;; + + let rec pp_structure = function + | StructVerbatim text -> + pp_string_node text; + if not S.line_directives then print_newline () + | StructType (public, recursive, name, constructors) -> + printf "%sdata %s%s =\n" (pp_pub public) (pp_rec recursive) name; + indented (List.iter pp_constructor) constructors + | StructLet (_, _, []) -> assert false + | StructLet (public, recursive, binding :: bindings) -> + let pp_binding b1 b2 binding = + output_string b1; + pp_comment binding.comment; + output_string b2; + pp_binding true binding + in + let before = Printf.sprintf "%s%slet " (pp_pub public) (pp_rec recursive) in + pp_binding "" before binding; + List.iter + (pp_binding + "\n" + (if recursive = Recursive || public = Private then "let " else "pub let ")) + bindings; + output_string (if_rec recursive (fun () -> "end\n") (fun () -> "\n")) + | StructModule (public, name, contents) -> + printf "%smodule %s\n" (pp_pub public) name; + indented pp_structures contents; + output_string "end\n" + + and pp_structures xs = iter_sep pp_structure print_newline xs +end diff --git a/test/calc/Calc.fram b/test/calc/Calc.fram new file mode 100644 index 0000000..557d3d6 --- /dev/null +++ b/test/calc/Calc.fram @@ -0,0 +1,41 @@ +import List +import open Parser +import Parsing + +module Feeder + pub let withFeeder {Tok} + (xs : List Tok) + (eof : Tok) + (f : {E} -> Parsing.Lex E Tok -> [E] _) = + handle lex = Parsing.Lex + { token = effect () / r => + fn ys => + match ys with + | [] => r eof ys + | y :: ys => r y ys + end + , curPos = effect () / r => fn ys => r Parsing.dummyPos ys + , startPos = effect () / r => fn ys => r Parsing.dummyPos ys } + return x => fn _ => x + finally f => f xs + in f lex +end + +let tests = + [[INT 2, PLUS, INT 3], + [INT 8, STAR, INT 3, STAR, INT 89, PLUS, INT 1], + [LPAREN, INT 9, PLUS, INT 1, RPAREN, SLASH, INT 5], + [INT 4, SLASH, INT 0], + [INT 1, PLUS, INT 4, CARET, INT 3, CARET, INT 2, PERCENT, INT 5], + [LPAREN, INT 1, PLUS, INT 4, CARET, INT 3, CARET, INT 2, RPAREN, PERCENT, INT 5]] + +let execTest xs = + let res = Feeder.withFeeder xs + EOF + (fn lex => main {~lex = lex} ()) in + match res with + | Left s => printStrLn s + | Right n => printInt n ; printStrLn "" + end + +# let _ = List.iter execTest tests diff --git a/test/calc/Parser.mly b/test/calc/Parser.mly new file mode 100644 index 0000000..b82889f --- /dev/null +++ b/test/calc/Parser.mly @@ -0,0 +1,36 @@ +%{ +let fail () = Parsing.error "arithmetic error" + +let rec pow {~re : {type X} -> Unit ->[_] X} (a : Int) (n : Int) = + if n == 0 then 1 + else if n == 1 then a + else (let (b : Int) = pow a (n / 2) in + b * b * (if n % 2 == 0 then 1 else a)) +%} + +%token INT +%token PLUS MINUS SLASH STAR PERCENT CARET LPAREN RPAREN EOF +%start main + +%left PLUS MINUS +%left SLASH STAR PERCENT +%nonassoc UMINUS +%right CARET + +%% + +main: x=expr EOF { x }; + +expr: + | l=expr PLUS r=expr { let (l : Int) = l in l + r } + | l=expr MINUS r=expr { let (l : Int) = l in l - r } + | l=expr STAR r=expr { let (l : Int) = l in l * r } + | l=expr SLASH r=expr { let ~re = fail in let (l : Int) = l in l / r } + | l=expr PERCENT r=expr { let ~re = fail in let (l : Int) = l in l % r } + | l=expr CARET r=expr { let ~re = fail in let (l : Int) = l in pow l r } + + | MINUS x=expr %prec UMINUS { 0 - x } + + | LPAREN x=expr RPAREN { x } + | x=INT { x } +; diff --git a/test/calc/dune b/test/calc/dune new file mode 100644 index 0000000..a3fe9f8 --- /dev/null +++ b/test/calc/dune @@ -0,0 +1,10 @@ +(rule + (deps Parser.mly) + (target Parser.fram) + (action + (run cpspg -o %{target} %{deps}))) + +(rule + (alias runtest) + (deps Calc.fram Parser.fram (source_tree ../../framtools)) + (action (run dbl -I ../../framtools Calc.fram))) diff --git a/test/sexpr/Parser.mly b/test/sexpr/Parser.mly new file mode 100644 index 0000000..f7d3c4a --- /dev/null +++ b/test/sexpr/Parser.mly @@ -0,0 +1,19 @@ +%{ +pub data rec SExpr = Nil + | Atom of String + | Cons of SExpr, SExpr + +%} +%token ATOM +%token LPAREN RPAREN DOT EOF +%start main + +%% + +main: x=s EOF { x }; + +s: + | LPAREN RPAREN { Nil } + | x=ATOM { Atom x } + | LPAREN x=s DOT y=s RPAREN { Cons x y } +; diff --git a/test/sexpr/SExpr.fram b/test/sexpr/SExpr.fram new file mode 100644 index 0000000..2ef7615 --- /dev/null +++ b/test/sexpr/SExpr.fram @@ -0,0 +1,57 @@ +import List +import open Parser +import Parsing + +module Feeder + pub let withFeeder {Tok} + (xs : List Tok) + (eof : Tok) + (f : {E} -> Parsing.Lex E Tok -> [E] _) = + handle lex = Parsing.Lex + { token = effect () / r => + fn ys => + match ys with + | [] => r eof ys + | y :: ys => r y ys + end + , curPos = effect () / r => fn ys => r Parsing.dummyPos ys + , startPos = effect () / r => fn ys => r Parsing.dummyPos ys } + return x => fn _ => x + finally f => f xs + in f lex +end + +let bye s = (printStrLn s; exit 1) + +let getTree result = + match result with + | Left s => bye s + | Right t => t + end + +let execTest xs = Feeder.withFeeder xs EOF (fn lex => main {~lex = lex} ()) + +let test = [LPAREN, LPAREN, ATOM "x", DOT, ATOM "y", RPAREN, DOT, LPAREN, RPAREN, RPAREN] +# '((x . y)) + +pub let t = getTree (execTest test) + +pub let examine s = + match s with + | Nil => "Nil" + | Atom s => "Atom " + s + | Cons _ _ => "Cons" + end + +pub let left s = + match s with + | Cons l _ => l + | _ => bye "no left" + end + +pub let right s = + match s with + | Cons _ r => r + | _ => bye "no right" + end + diff --git a/test/sexpr/dune b/test/sexpr/dune new file mode 100644 index 0000000..0e41783 --- /dev/null +++ b/test/sexpr/dune @@ -0,0 +1,10 @@ +(rule + (deps Parser.mly) + (target Parser.fram) + (action + (run cpspg -o %{target} %{deps}))) + +(rule + (alias runtest) + (deps SExpr.fram Parser.fram (source_tree ../../framtools)) + (action (run dbl -I ../../framtools SExpr.fram))) From b801b01d730473212b47f514e18e9f3f4d444e49 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Miko=C5=82aj=20Swoboda?= <331319@uwr.edu.pl> Date: Thu, 5 Feb 2026 02:58:04 +0100 Subject: [PATCH 2/3] Fix import issue - Removed awkward parameter declarations which ultimately were redundant. The user may declare the parameters themselves if they wish. - Improved formatting. --- framtools/Parsing.fram | 22 ++++++++++++---------- lib/Backend/Fram.ml | 42 +++++++++++++++++++++++------------------- test/calc/Calc.fram | 36 ++++++++++++++++++------------------ test/calc/Parser.mly | 11 ++++++----- test/sexpr/SExpr.fram | 32 ++++++++++++++++---------------- 5 files changed, 75 insertions(+), 68 deletions(-) diff --git a/framtools/Parsing.fram b/framtools/Parsing.fram index 53c4a52..52806e3 100644 --- a/framtools/Parsing.fram +++ b/framtools/Parsing.fram @@ -1,18 +1,20 @@ -{# This file should be placed in the same directory as the generated - parser #} +{# Place this file in the same directory with the generated parser + or include the framtools directory via the option -L. #} -pub data Pos = Pos of - { fname : String - , lnum : Int - , bol : Int - , cnum : Int } +pub data Pos = + { fname : String + , lnum : Int + , bol : Int + , cnum : Int + } pub let dummyPos = Pos {fname = "", lnum = 0, bol = 0, cnum = 0-1} pub data Lex E Tok = - { token : Unit ->[E] Tok - , startPos : Unit ->[E] Pos - , curPos : Unit -> [E] Pos } + { token : Unit ->[E] Tok + , startPos : Unit ->[E] Pos + , curPos : Unit -> [E] Pos + } pub data Error E = Error of ({type X} -> String ->[E] X) pub method parseError {E} (Error f : Error E) = f diff --git a/lib/Backend/Fram.ml b/lib/Backend/Fram.ml index bc9c3c3..9ab8bd9 100644 --- a/lib/Backend/Fram.ml +++ b/lib/Backend/Fram.ml @@ -23,8 +23,6 @@ let filter_mapi f xs = let prelude = {| import Parsing import List -parameter E_err -parameter ~error : Parsing.Error E_err |} |> verbatim [@@ocamlformat "disable"] @@ -34,16 +32,16 @@ parameter E_err parameter ~error : Parsing.Error E_err pub let _kw_endpos _ = -match ~loc with -| l :: _ => snd l -| [] => Parsing.dummyPos -end + match ~loc with + | l :: _ => snd l + | [] => Parsing.dummyPos + end pub let _kw_startpos (n : Int) = -match List.nth ~loc (n - 1) with -| Some l => fst l -| None => _kw_endpos n -end + match List.nth ~loc (n - 1) with + | Some l => fst l + | None => _kw_endpos n + end pub let _kw_symbolstartpos _ = Parsing.error "unimplemented: $symbolstartpos" pub let _kw_startofs _ = Parsing.error "unimplemented: $startofs" @@ -55,16 +53,20 @@ pub let _kw_sloc _ = Parsing.error "unimplemented: $sloc" [@@ocamlformat "disable"] let state_lib = {| -let lexfun {E_err, E_lex, - ~error : Parsing.Error E_err, - ~lex : Parsing.Lex E_lex Tok} ppos = +let lexfun + {E_err, E_lex + , ~error : Parsing.Error E_err + , ~lex : Parsing.Lex E_lex Tok + } ppos = let (aux : Unit ->[E_err, E_lex] Tok) = fn () => ~lex.token ppos in aux () -pub let shift {E_err, E_lex, - ~error : Parsing.Error E_err, - ~lex : Parsing.Lex E_lex Tok} () = +pub let shift + {E_err, E_lex + , ~error : Parsing.Error E_err + , ~lex : Parsing.Lex E_lex Tok + } () = let (aux : Unit ->[E_err, E_lex] Pair Tok (Pair Parsing.Pos Parsing.Pos)) = (fn () => let tok = lexfun () in @@ -82,9 +84,11 @@ let locDummy xs = | (_, e) :: _ => (e, e) end -let locReduce {E_err, E_lex, - ~error : Parsing.Error E_err, - ~lex : Parsing.Lex E_lex Tok} n = +let locReduce + {E_err, E_lex + , ~error : Parsing.Error E_err + , ~lex : Parsing.Lex E_lex Tok + } n = let (aux : Int ->[E_err, E_lex] List (Pair Parsing.Pos Parsing.Pos)) = (fn (n : Int) => if n == 0 then locDummy ~loc :: ~loc diff --git a/test/calc/Calc.fram b/test/calc/Calc.fram index 557d3d6..6e285bf 100644 --- a/test/calc/Calc.fram +++ b/test/calc/Calc.fram @@ -3,25 +3,25 @@ import open Parser import Parsing module Feeder - pub let withFeeder {Tok} - (xs : List Tok) - (eof : Tok) - (f : {E} -> Parsing.Lex E Tok -> [E] _) = - handle lex = Parsing.Lex - { token = effect () / r => - fn ys => - match ys with - | [] => r eof ys - | y :: ys => r y ys - end - , curPos = effect () / r => fn ys => r Parsing.dummyPos ys - , startPos = effect () / r => fn ys => r Parsing.dummyPos ys } - return x => fn _ => x - finally f => f xs - in f lex + pub let withFeeder {Tok} + (xs : List Tok) + (eof : Tok) + (f : {E} -> Parsing.Lex E Tok -> [E] _) = + handle lex = Parsing.Lex + { token = effect () / r => + fn ys => + match ys with + | [] => r eof ys + | y :: ys => r y ys + end + , curPos = effect () / r => fn ys => r Parsing.dummyPos ys + , startPos = effect () / r => fn ys => r Parsing.dummyPos ys } + return x => fn _ => x + finally f => f xs + in f lex end -let tests = +pub let tests = [[INT 2, PLUS, INT 3], [INT 8, STAR, INT 3, STAR, INT 89, PLUS, INT 1], [LPAREN, INT 9, PLUS, INT 1, RPAREN, SLASH, INT 5], @@ -29,7 +29,7 @@ let tests = [INT 1, PLUS, INT 4, CARET, INT 3, CARET, INT 2, PERCENT, INT 5], [LPAREN, INT 1, PLUS, INT 4, CARET, INT 3, CARET, INT 2, RPAREN, PERCENT, INT 5]] -let execTest xs = +pub let execTest xs = let res = Feeder.withFeeder xs EOF (fn lex => main {~lex = lex} ()) in diff --git a/test/calc/Parser.mly b/test/calc/Parser.mly index b82889f..9c96338 100644 --- a/test/calc/Parser.mly +++ b/test/calc/Parser.mly @@ -1,11 +1,12 @@ %{ -let fail () = Parsing.error "arithmetic error" +let fail {E_err, ~error : Parsing.Error E_err} () = + Parsing.error "arithmetic error" let rec pow {~re : {type X} -> Unit ->[_] X} (a : Int) (n : Int) = - if n == 0 then 1 - else if n == 1 then a - else (let (b : Int) = pow a (n / 2) in - b * b * (if n % 2 == 0 then 1 else a)) + if n == 0 then 1 + else if n == 1 then a + else (let (b : Int) = pow a (n / 2) in + b * b * (if n % 2 == 0 then 1 else a)) %} %token INT diff --git a/test/sexpr/SExpr.fram b/test/sexpr/SExpr.fram index 2ef7615..bed5ea4 100644 --- a/test/sexpr/SExpr.fram +++ b/test/sexpr/SExpr.fram @@ -3,22 +3,22 @@ import open Parser import Parsing module Feeder - pub let withFeeder {Tok} - (xs : List Tok) - (eof : Tok) - (f : {E} -> Parsing.Lex E Tok -> [E] _) = - handle lex = Parsing.Lex - { token = effect () / r => - fn ys => - match ys with - | [] => r eof ys - | y :: ys => r y ys - end - , curPos = effect () / r => fn ys => r Parsing.dummyPos ys - , startPos = effect () / r => fn ys => r Parsing.dummyPos ys } - return x => fn _ => x - finally f => f xs - in f lex + pub let withFeeder {Tok} + (xs : List Tok) + (eof : Tok) + (f : {E} -> Parsing.Lex E Tok -> [E] _) = + handle lex = Parsing.Lex + { token = effect () / r => + fn ys => + match ys with + | [] => r eof ys + | y :: ys => r y ys + end + , curPos = effect () / r => fn ys => r Parsing.dummyPos ys + , startPos = effect () / r => fn ys => r Parsing.dummyPos ys } + return x => fn _ => x + finally f => f xs + in f lex end let bye s = (printStrLn s; exit 1) From 51a8ff1a1d1878577e82c33368b046bc94b90604 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Miko=C5=82aj=20Swoboda?= <331319@uwr.edu.pl> Date: Thu, 5 Feb 2026 03:20:30 +0100 Subject: [PATCH 3/3] More formatting --- test/calc/Calc.fram | 41 ++++++++++++++++++++++------------------- test/sexpr/SExpr.fram | 13 +++++++------ 2 files changed, 29 insertions(+), 25 deletions(-) diff --git a/test/calc/Calc.fram b/test/calc/Calc.fram index 6e285bf..5ecf372 100644 --- a/test/calc/Calc.fram +++ b/test/calc/Calc.fram @@ -11,31 +11,34 @@ module Feeder { token = effect () / r => fn ys => match ys with - | [] => r eof ys - | y :: ys => r y ys - end + | [] => r eof ys + | y :: ys => r y ys + end , curPos = effect () / r => fn ys => r Parsing.dummyPos ys - , startPos = effect () / r => fn ys => r Parsing.dummyPos ys } - return x => fn _ => x - finally f => f xs + , startPos = effect () / r => fn ys => r Parsing.dummyPos ys + } + return x => fn _ => x + finally f => f xs in f lex end pub let tests = - [[INT 2, PLUS, INT 3], - [INT 8, STAR, INT 3, STAR, INT 89, PLUS, INT 1], - [LPAREN, INT 9, PLUS, INT 1, RPAREN, SLASH, INT 5], - [INT 4, SLASH, INT 0], - [INT 1, PLUS, INT 4, CARET, INT 3, CARET, INT 2, PERCENT, INT 5], - [LPAREN, INT 1, PLUS, INT 4, CARET, INT 3, CARET, INT 2, RPAREN, PERCENT, INT 5]] + [[INT 2, PLUS, INT 3], + [INT 8, STAR, INT 3, STAR, INT 89, PLUS, INT 1], + [LPAREN, INT 9, PLUS, INT 1, RPAREN, SLASH, INT 5], + [INT 4, SLASH, INT 0], + [INT 1, PLUS, INT 4, CARET, INT 3, CARET, INT 2, PERCENT, INT 5], + [LPAREN, INT 1, PLUS, INT 4, CARET, INT 3, CARET, INT 2, RPAREN, PERCENT, INT 5]] pub let execTest xs = - let res = Feeder.withFeeder xs - EOF - (fn lex => main {~lex = lex} ()) in - match res with - | Left s => printStrLn s - | Right n => printInt n ; printStrLn "" - end + let res = Feeder.withFeeder + xs + EOF + (fn lex => main {~lex = lex} ()) + in + match res with + | Left s => printStrLn s + | Right n => printInt n ; printStrLn "" + end # let _ = List.iter execTest tests diff --git a/test/sexpr/SExpr.fram b/test/sexpr/SExpr.fram index bed5ea4..c03726d 100644 --- a/test/sexpr/SExpr.fram +++ b/test/sexpr/SExpr.fram @@ -11,13 +11,14 @@ module Feeder { token = effect () / r => fn ys => match ys with - | [] => r eof ys - | y :: ys => r y ys - end + | [] => r eof ys + | y :: ys => r y ys + end , curPos = effect () / r => fn ys => r Parsing.dummyPos ys - , startPos = effect () / r => fn ys => r Parsing.dummyPos ys } - return x => fn _ => x - finally f => f xs + , startPos = effect () / r => fn ys => r Parsing.dummyPos ys + } + return x => fn _ => x + finally f => f xs in f lex end