Merge pull request #60 from nberth/contexts-refactor

Various module simplifications in `cobol_parser`

src/lsp/cobol_lsp/lsp_document.ml

@@ -110,7 +110,7 @@ let lazy_references ptree cus defs =
             (CUs.find_by_name cu_name cus)
           (Lsp_lookup.references cu_defs cu) map
         with Not_found -> map
-    end CUMap.empty ptree
+    end CUMap.empty ptree.Cobol_ptree.compilation_units
   end
 
 let no_artifacts =

src/lsp/cobol_lsp/lsp_lookup.ml

@@ -106,7 +106,8 @@ let name_of_compunit (cu: Cobol_ptree.compilation_unit with_loc) =
 
 let compilation_unit_by_name (cu_name: Cobol_ptree.name)
     (ptree: Cobol_ptree.compilation_group) =
-  List.find_opt (fun cu -> cu_name = name_of_compunit cu) ptree
+  List.find_opt (fun cu -> cu_name = name_of_compunit cu)
+    ptree.compilation_units
 
 (* --- *)
 
@@ -329,7 +330,7 @@ let update_definitions_based_on_compilation_group_ptree ~f ptree defs =
         Some (f cu' @@ Option.value cu_defs ~default:Cobol_data.Qualmap.empty)
       end defs
     with Not_found -> defs
-  end defs ptree
+  end defs ptree.Cobol_ptree.compilation_units
 
 
 (*TODO: remove this once Cobol_typeck implements Renames*)

src/lsp/cobol_parser/cobol_parser.ml

@@ -19,7 +19,6 @@ module Options = Parser_options
 (** Output types for the engine *)
 module Outputs = Parser_outputs
 
-module Contexts = Grammar_contexts
 module Tokens = Grammar_tokens
 module Keywords = Text_keywords
 

src/lsp/cobol_parser/context.ml

@@ -24,19 +24,14 @@
     - exited whenever the annotated rule is reduced.
 *)
 
-(** {2 Context types}
-
-    We concretely represent a context [ctx] as the set of keywords that are
-    sensitive to [ctx].
-*)
+(** {2 Context types} *)
 
 module TH = Text_lexer.TokenHandles
 
-type context = TH.t
-let pp_context ppf c =
-  Pretty.list ~fopen:"{@[" ~fclose:"@]}" ~fempty:"{}" begin fun ppf h ->
-    Pretty.string ppf (Text_lexer.show_token_of_handle h)
-  end ppf (TH.elements c)
+type context = Grammar_contexts.context
+let pp_context context_tokens ppf c =
+  Text_lexer.pp_tokens_via_handles ppf
+    (Grammar_contexts.tokens_of_context context_tokens c)
 
 type t = context
 
@@ -60,9 +55,11 @@ and tokens_diff = TH.t
 
 let empty_stack: stack = []
 
-let push: context -> stack -> stack = fun ctx -> function
-  | [] -> [ { ctx; diff = ctx } ]
-  | { diff = top; _ } :: _ as t -> { ctx; diff = TH.diff ctx top } :: t
+let push ths : context -> stack -> stack = fun ctx ->
+  let toks = Grammar_contexts.tokens_of_context ths ctx in
+  function
+  | [] -> [ { ctx; diff = toks } ]
+  | { diff = top; _ } :: _ as t -> { ctx; diff = TH.diff toks top } :: t
 
 let top: stack -> context option = function
   | { ctx; _ } :: _ -> Some ctx

src/lsp/cobol_parser/context.mli

@@ -13,18 +13,19 @@
 
 (** {2 Context(s)} *)
 
-type context = Grammar_contexts.t
-val pp_context: context Pretty.printer
+type context = Grammar_contexts.context
+val pp_context: Grammar_contexts.context_tokens -> context Pretty.printer
 
 type t = context
+
 (** {2 Context stack} *)
 
 type stack
 
 (** {3 Usual operations on context stacks} *)
 
 val empty_stack: stack
-val push: context -> stack -> stack
+val push: Grammar_contexts.context_tokens -> context -> stack -> stack
 val top: stack -> context option
 
 (** {3 Context-specific operations} *)

src/lsp/cobol_parser/context/gen_context.ml

@@ -61,13 +61,14 @@ let emit_nonterminal_contexts ppf =
           Fmt.epr "%a:@\n\
                    @[<2>** Warning:@ context@ `%s'@ on@ nullable@ \
                    non-terminal@]@." pp_pos pos s;
-        Fmt.pf ppf "  | N_%s -> Some %s\n" (Nonterminal.name n) s
+        Fmt.pf ppf "  | N_%s -> Some %s\n" (Nonterminal.name n) (String.capitalize_ascii s)
     | None -> ()
   end;
   Fmt.pf ppf "\
     \  | _ -> None\n"
 
-let pp_contexts = Fmt.(list ~sep:(any ";@ ") string)
+let pp_contexts =
+  Fmt.(list ~sep:(any ";@ ") (fun ppf s -> pf ppf "%s" (String.capitalize_ascii s)))
 
 let emit_contexts_mapping ppf =
   Fmt.pf ppf "\

src/lsp/cobol_parser/context/gen_contexts.ml

@@ -37,8 +37,6 @@ let tokens_module =
   | "" -> String.capitalize_ascii @@ Filename.basename Grammar.basename
   | s -> s
 
-let all_ctxts = ref []
-
 let context_list str =
   String.split_on_char ',' str |>
   List.filter_map (fun ctxt ->
@@ -55,6 +53,32 @@ let contexts attrs =
   List.find_opt (Attribute.has_label "contexts") attrs |>
   Option.fold ~none:[] ~some:(fun attr -> context_list @@ Attribute.payload attr)
 
+let all_ctxts =
+  List.sort_uniq (String.compare) @@
+  Terminal.fold begin fun t acc ->
+    let attrs = Terminal.attributes t in
+    if has_contexts attrs
+    then List.rev_append (contexts attrs) acc
+    else acc
+  end []
+
+let emit_prelude ppf =
+  Fmt.pf ppf "module TH = Text_lexer.TokenHandles@\n\
+              @[<v 2>type context =@;| %a@]@\n\
+              type t = context@\n@\n\
+              @[<v 2>type context_tokens =@;\
+              @[<v 2>{@;%a;@]@;}@]@;@\n\
+              @[<v 2>type handles =@;\
+              @[<v 2>{@;\
+              context_tokens: context_tokens;@;\
+              context_sensitive_tokens: TH.t;@;\
+              context_sensitive_tokens_unimplemented: TH.t;@]@;\
+              }@]@\n"
+    Fmt.(list ~sep:(any "@;| ")
+           (fun ppf c -> Fmt.string ppf (String.capitalize_ascii c))) all_ctxts
+    Fmt.(list ~sep:(any ";@;")
+           (fun ppf n -> Fmt.pf ppf "%s: TH.t" n)) all_ctxts
+
 let emit_contexts ppf t =
   match Terminal.kind t with
   | `ERROR | `EOF | `PSEUDO ->
@@ -76,26 +100,19 @@ let emit_specs ppf =
   Fmt.pf ppf "@]]@\nin@\n"
 
 let emit_empty_record ppf =
-  Fmt.(list ~sep:(any ";@\n") (fun ppf c -> Fmt.pf ppf "    %s = empty" c) ppf) !all_ctxts
+  Fmt.(list ~sep:(any ";@\n") (fun ppf c -> Fmt.pf ppf "    %s = empty" c) ppf)
+    all_ctxts
 
 let emit_ctxt_funs ppf =
-  Fmt.(list
-         ~sep:(any "@\n")
+  Fmt.(list ~sep:(any "@\n")
          (fun ppf c ->
-            Fmt.pf ppf "let %s t c = { c with %s = add t c.%s } in" c c c)
-         ppf)
-    !all_ctxts
-
-let emit_fold ppf =
-  Fmt.pf ppf "List.fold_left (fun (acc, cstoks, unimpl) (t, add_contexts) ->@\n\
-             \  let h = Text_lexer.handle_of_token t in@\n\
-             \  List.fold_left (fun acc f -> f h acc) acc add_contexts,@\n\
-             \  TH.add h cstoks,@\n\
-             \  if add_contexts = [] then TH.add h unimpl else unimpl)@\n\
-             (empty, TH.empty, TH.empty) specs"
+            pf ppf "let %s t c = { c with %s = add t c.%s } in" c c c))
+    ppf
+    all_ctxts
 
 let emit_tokens_contexts ppf =
-  Fmt.pf ppf "let all, sensitive_tokens, sensitive_tokens_unimplemented =@\n\
+  (* Fmt.pf ppf "let all, sensitive_tokens, sensitive_tokens_unimplemented =@\n\ " *)
+  Fmt.pf ppf "let init ~handle_of_token =@\n\
               @[<2>  let open TH in@\n\
               let empty =@\n\
              \  {@\n\
@@ -104,38 +121,30 @@ let emit_tokens_contexts ppf =
               in@\n\
               %t@\n\
               %t\
-              %t@]"
+              @[<v 2>let @[<v>context_tokens,@;\
+              context_sensitive_tokens,@;\
+              context_sensitive_tokens_unimplemented@] =@;\
+              List.fold_left (fun (acc, cstoks, unimpl) (t, add_contexts) ->@\n\
+             \  let h = handle_of_token t in@\n\
+             \  List.fold_left (fun acc f -> f h acc) acc add_contexts,@\n\
+             \  TH.add h cstoks,@\n\
+             \  if add_contexts = [] then TH.add h unimpl else unimpl)@\n\
+              (empty, TH.empty, TH.empty) specs@]@;\
+              in@;\
+              @[<v 2>{ context_tokens;@;\
+              context_sensitive_tokens;@;\
+              context_sensitive_tokens_unimplemented }@]@]"
     emit_empty_record
     emit_ctxt_funs
     emit_specs
-    emit_fold
-
-let emit_context_type ppf =
-  let ctxts = ref [] in
-  Terminal.iter (fun t ->
-      let attrs = Terminal.attributes t in
-      if has_contexts attrs then
-        begin
-          ctxts := (contexts attrs) @ !ctxts
-        end);
-  let ctxts = List.sort_uniq (String.compare) !ctxts in
-  all_ctxts := ctxts;
-  Fmt.(list ~sep:(any ";@\n") (fun ppf n -> Fmt.pf ppf "    %s: t" n) ppf) ctxts
 
-let emit_prelude ppf =
-  Fmt.pf ppf "module TH = Text_lexer.TokenHandles@\n\
-              type context = TH.t@\n@\n\
-              type t = context@\n\
-              type contexts =@\n\
-              \  {@\n\
-              %t;@\n\
-              \  }@\n"
-    emit_context_type
-
-let emit_context_values ppf =
-  List.iter (fun ctxt ->
-      Fmt.pf ppf "let %s = all.%s@\n" ctxt ctxt)
-    !all_ctxts
+let emit_context_mapping ppf =
+  Fmt.pf ppf "@[<v 2>let tokens_of_context context_tokens : t -> TH.t = \
+              function@;| %a@]@\n"
+    Fmt.(list ~sep:(any "@;| ")
+           (fun ppf c -> Fmt.pf ppf "%s -> context_tokens.%s"
+               (String.capitalize_ascii c) c))
+    all_ctxts
 
 let emit ppf =
   Fmt.pf ppf
@@ -146,8 +155,7 @@ let emit ppf =
     !name
     emit_prelude
     emit_tokens_contexts
-    emit_context_values
+    emit_context_mapping
 
 let () =
   emit Fmt.stdout
-

src/lsp/cobol_parser/grammar.mly

@@ -42,8 +42,8 @@ let dual_handler_none =
    single production by means of an attribute to the last item of its producers.
    When both attributes are given, the latter takes precedence.  *)
 
-(* Parameter module specific to post-actions *)
-%[@post.parameter Config: Cobol_config.T]
+(* (\* Parameter module specific to post-actions *\) *)
+(* %[@post.parameter Config: Cobol_config.T] *)
 
 (* Tag declaration for post-actions.
 
@@ -53,8 +53,8 @@ let dual_handler_none =
    this definition, grammar attributes "[@post.diagnostic ...]" may be used to
    create diagnostics based on the result of configuration feature
    verifications. *)
-%[@post.tag diagnostic loc:Cobol_common.Srcloc.srcloc option ->
-                           unit Cobol_common.Diagnostics.in_result]
+(* %[@post.tag diagnostic loc:Cobol_common.Srcloc.srcloc option -> *)
+(*                            unit Cobol_common.Diagnostics.in_result] *)
 
 %[@post.tag special_names Cobol_ptree.special_names_clause]
 
@@ -228,20 +228,22 @@ let ioloc (X) ==
 (* --------------------- COMPILATION GROUPS AND UNITS ---------------------- *)
 
 let compilation_group :=
-  | option(control_division);
+  | control_division = option(loc(control_division));
     ul = ll(loc(compilation_unit));
     pdo = loc(program_definition_no_end)?; EOF;
-    { match pdo with
-        | None -> ul
-        | Some pd -> ul @ [((Program ~&pd): compilation_unit) &@<- pd] }
+    { { control_division;
+        compilation_units =
+          match pdo with
+            | None -> ul
+            | Some pd -> ul @ [((Program ~&pd): compilation_unit) &@<- pd] } }
 
 (* --- CONTROL DIVISION --- *)
 
 (* TODO: leave a flag/source location in the parse tree, and check support for
    CONTROL DIVISION later. *)
-let control_division [@post.diagnostic fun _ -> Config.control_division#verify] :=
+let control_division (* [@post.diagnostic fun _ -> Config.control_division#verify] *) :=
   | CONTROL; DIVISION; ".";
-    option(default_section)
+    option(default_section); {()} (* TODO: actually keep the section's contents *)
 
 let default_section :=
   | DEFAULT; SECTION; "."; default_section_clauses