From 1d8ef02b97cc626bf169845a1475d25006e9a976 Mon Sep 17 00:00:00 2001
From: Mario Carneiro <di.gama@gmail.com>
Date: Thu, 14 Nov 2024 14:46:37 +0100
Subject: [PATCH] expose some more internals

---
 tools/Holmake/HolParser.sig | 12 ++++++
 tools/Holmake/HolParser.sml | 75 ++++++++++++++++++++++---------------
 2 files changed, 57 insertions(+), 30 deletions(-)

diff --git a/tools/Holmake/HolParser.sig b/tools/Holmake/HolParser.sig
index 3487b0a90e..ca6c5a00c9 100644
--- a/tools/Holmake/HolParser.sig
+++ b/tools/Holmake/HolParser.sig
@@ -58,7 +58,19 @@ structure ToSML: sig
     strcode: int * substring -> unit,
     strstr: int * substring -> unit
   }
+  val strstr: (string -> unit) -> int * substring -> unit
+  val strcode: (string -> unit) -> int * substring -> unit
   val mkStrcode: (string -> unit) -> strcode
+
+  val mkPushTranslatorCore:
+    {read: int -> string, filename: string, parseError: int * int -> string -> unit} ->
+    strcode -> {
+      doDecl: bool -> int -> Simple.decl -> int,
+      feed: unit -> Simple.topdecl,
+      finishThmVal: unit -> unit,
+      regular: int * int -> unit
+    }
+
   val mkPushTranslator:
     {read: int -> string, filename: string, parseError: int * int -> string -> unit} ->
     strcode -> unit -> bool
diff --git a/tools/Holmake/HolParser.sml b/tools/Holmake/HolParser.sml
index f761c1dd48..7a442b4f15 100644
--- a/tools/Holmake/HolParser.sml
+++ b/tools/Holmake/HolParser.sml
@@ -263,8 +263,8 @@ structure ToSML = struct
     strstr: int * substring -> unit
   }
 
-  fun mkStrcode push: strcode = let
-    fun encoder st f (_, s) = let
+  local
+    fun encoder f push (_, s) = let
       val (s, start, len) = Substring.base s
       val stop = start + len
       fun loop start p =
@@ -278,19 +278,24 @@ structure ToSML = struct
             push r;
             loop (p+1) (p+1))
       in loop start start end
-    in {
-      regular = fn s => push (Substring.string (#2 s)),
-      aux = push,
-      strstr = encoder "str" (fn ch =>
-        if ch < #"\128" then NONE else SOME (AttributeSyntax.bslash_escape ch)),
-      strcode = encoder "code" (fn
-          #"\\" => SOME "\\\\"
-        | #"\"" => SOME "\\\""
-        | #"\n" => SOME "\\n\\\n\\"
-        | ch => if Char.isPrint ch then NONE else SOME (AttributeSyntax.bslash_escape ch))
-    } end
+  in
+    val strstr = encoder (fn ch =>
+      if ch < #"\128" then NONE else SOME (AttributeSyntax.bslash_escape ch))
+    val strcode = encoder (fn
+        #"\\" => SOME "\\\\"
+      | #"\"" => SOME "\\\""
+      | #"\n" => SOME "\\n\\\n\\"
+      | ch => if Char.isPrint ch then NONE else SOME (AttributeSyntax.bslash_escape ch))
+  end
+
+  fun mkStrcode push: strcode = {
+    regular = fn s => push (Substring.string (#2 s)),
+    aux = push,
+    strstr = strstr push,
+    strcode = strcode push
+  }
 
-  fun mkPushTranslator {read, filename, parseError}
+  fun mkPushTranslatorCore {read, filename, parseError}
       ({regular, aux, strstr, strcode = strcode0}:strcode) = let
     open Simple
     val ss = Substring.string
@@ -333,12 +338,12 @@ structure ToSML = struct
     fun magicBind name =
       aux (" " ^ Systeml.bindstr (concat ["val ", name, " = DB.fetch \"-\" \"", name,
         "\" handle Feedback.HOL_ERR _ => boolTheory.TRUTH;"]) ^ ";")
-    fun doThmAttrs false p attrs name_attrs = strcode' (p, name_attrs)
+    fun doThmAttrs false p attrs name_attrs = aux (ss name_attrs)
       | doThmAttrs true p attrs name_attrs =
         if Substring.isEmpty attrs then
-          (strcode' (p, name_attrs); aux "[local]")
+          (aux (ss name_attrs); aux "[local]")
         else (
-          strcode' (p, Substring.slice (name_attrs, 0, SOME (Substring.size name_attrs - 1)));
+          aux (ss (Substring.slice (name_attrs, 0, SOME (Substring.size name_attrs - 1))));
           aux ",local]")
     fun doQuoteCore start ds stop f = case ds of
         [] => quote (start, stop)
@@ -536,25 +541,35 @@ structure ToSML = struct
           aux " "; p + size text)
     and doDecls start [] stop = regular (start, stop)
       | doDecls start (d :: ds) stop = doDecls (doDecl false start d) ds stop
+    in {
+      feed = feed',
+      regular = regular,
+      finishThmVal = finishThmVal,
+      doDecl = doDecl
+    } end
+
+  fun mkPushTranslator args strcode = let
+    open Simple
+    val {feed, regular, finishThmVal, doDecl, ...} = mkPushTranslatorCore args strcode
     val pos = ref 0
     in fn () =>
-      case feed' () of
+      case feed () of
         TopDecl d => (pos := doDecl true (!pos) d; false)
       | Simple.EOF p => (regular (!pos, p); finishThmVal (); pos := p; true)
     end
 
-fun mkPullTranslator args = let
-  val queue = ref []
-  val atEnd = ref false
-  val push = mkPushTranslator args (mkStrcode (fn s => queue := s :: !queue))
-  fun loop () =
-    case !queue of
-      s :: rest => (queue := rest; s)
-    | [] => if !atEnd then "" else (
-      atEnd := push ();
-      queue := rev (!queue);
-      loop ())
-  in loop end
+  fun mkPullTranslator args = let
+    val queue = ref []
+    val atEnd = ref false
+    val push = mkPushTranslator args (mkStrcode (fn s => queue := s :: !queue))
+    fun loop () =
+      case !queue of
+        s :: rest => (queue := rest; s)
+      | [] => if !atEnd then "" else (
+        atEnd := push ();
+        queue := rev (!queue);
+        loop ())
+    in loop end
 
 end