printf F

4 files changed, 61 insertions, 44 deletions

diff --git a/common.sml b/common.sml
index f2020e2..5429a5f 100644
--- a/common.sml
+++ b/common.sml
@@ -107,50 +107,69 @@ fun exit code = (
 
 fun output stream s = TextIO.output (stream, s)
 
-fun fprint stream g = Fold.fold ((false, output stream), fn _ => ()) g
-fun printf g = fprint TextIO.stdOut g
-fun sprintf g =
+fun makePrintfBase output =
 let
-  val buf = ref []
-  fun output s = (buf := s :: (!buf))
-  fun finish _ = String.concat (rev (!buf))
+  val firstOnLine = ref true
+  fun endsWithNL "" = raise Unreachable
+    | endsWithNL s = String.sub (s, size s - 1) = #"\n"
+
+  fun output' "" = ()
+    | output' s = (
+    output s;
+    firstOnLine := endsWithNL s
+  )
+  fun mf () =
+    if not $ !firstOnLine then
+      (output "\n"; firstOnLine := true)
+    else
+      ()
 in
-  Fold.fold ((false, output), finish)
-end g
-fun Printf output g = Fold.fold ((false, output), fn _ => ()) g
+  (output', mf)
+end
+
+local
+  val ctx = ((false, makePrintfBase $ output TextIO.stdOut),
+    fn (_: bool * ((string -> unit) * (unit -> unit))) => ())
+in
+  fun printf g = Fold.fold ctx g
+end
+
+fun Printf out g = Fold.fold ((false, out), fn _ => ()) g
 
 local
   fun ifF flag cl = if not flag then cl () else ()
 in
-  fun ` z = Fold.step1 (fn (s, (ign, output)) =>
-    (ifF ign (fn () => output s); (ign, output))) z
-
-  fun A0 z = Fold.step1 (fn (f, (ign, output)) =>
-    (ifF ign (fn () => f output); (ign, output))) z
-  fun A1 z = Fold.step2 (fn (f, v, (ign, output)) =>
-    (ifF ign (fn () => f (output, v)); (ign, output))) z
-  fun A2 z = Fold.step3 (fn (f, v1, v2, (ign, output)) =>
-    (ifF ign (fn () => f (output, v1, v2)); (ign, output))) z
+  fun ` z = Fold.step1 (fn (s, (ign, out as (output, _))) =>
+    (ifF ign (fn () => output s); (ign, out))) z
+
+  fun A0 z = Fold.step1 (fn (f, (ign, out)) =>
+    (ifF ign (fn () => f out); (ign, out))) z
+  fun A1 z = Fold.step2 (fn (f, v, (ign, out)) =>
+    (ifF ign (fn () => f (out, v)); (ign, out))) z
+  fun A2 z = Fold.step3 (fn (f, v1, v2, (ign, out)) =>
+    (ifF ign (fn () => f (out, v1, v2)); (ign, out))) z
 end
 
-fun Ign z = Fold.step0 (fn (_, output) => (true, output)) z
+fun Ign z = Fold.step0 (fn (_, out) => (true, out)) z
 
 fun bind A f = fn z => Fold.fold z A f
-fun bindWith2str to = bind A1 (fn (output, v) => output (to v))
+fun bindWith2str to = bind A1 (fn ((output, _), v) => output $ to v)
+
+fun F z = bind A0 (fn (_, mf) => mf ()) z
 
 val I = fn z => bindWith2str Int.toString z
 val C = fn z => bindWith2str str z
 val B = fn z => bindWith2str Bool.toString z
-val R = fn z => bind A1 (fn (output, n) => app (fn f => f ())
+val R = fn z => bind A1 (fn ((output, _), n) => app (fn f => f ())
         (List.tabulate (n, fn _ => fn () => output "\t"))) z
 
-type ('t, 'a, 'b) a1printer = (bool * (string -> unit)) * 'a -> 't ->
-        ((bool * (string -> unit)) * 'a -> 'b) -> 'b
+type ('t, 'a, 'b, 'c) a1printer = (bool * ((string -> unit) * 'a)) * 'b
+        -> 't -> ((bool * ((string -> unit) * 'a)) * 'b -> 'c) -> 'c
 
 fun die code g =
 let
   fun finish (true, _) = raise Unreachable
-    | finish (false, output) = (
+    | finish (false, (output, _)) = (
         output "\n";
         exit code
     )
diff --git a/ppc.fun b/ppc.fun
index 2872848..0aae7b6 100644
--- a/ppc.fun
+++ b/ppc.fun
@@ -42,7 +42,7 @@ struct
   val PlayersU = fn z =>
   let
     fun PlayersU (out, ((macroName, pos) :: layers)) =
-      Printf out `"\tfrom " `macroName `" at " T.S.Ppos pos `"\n"
+      Printf out F `"\tfrom " `macroName `" at " T.S.Ppos pos `"\n"
         A1 PlayersU layers %
       | PlayersU (_, []) = ()
   in
@@ -50,7 +50,7 @@ struct
   end z
 
   fun warningLow (TkPos (pos, layers)) msg f g =
-    printf `"\n" T.S.Ppos pos `":" `msg `": "
+    printf F T.S.Ppos pos `":" `msg `": "
       (fn (a, _) => g (a, fn (_, out) =>
         (Printf out `"\n" PlayersU layers %; f ())))
 
@@ -77,7 +77,7 @@ struct
       | Pcls (out, cl :: cls) =
         Printf out A1 Pcl cl `", " A1 Pcls cls %
   in
-    printf `"\n" T.S.Ppos pos `":error: expected " A1 Pcls cls `"\n"
+    printf F T.S.Ppos pos `":error: expected " A1 Pcls cls `"\n"
         PlayersU layers;
     exit 1
   end
@@ -165,7 +165,7 @@ struct
         end
   in
     if layers <> layers' orelse fname' <> fname orelse line' <> line then
-      Printf out `"\n" R off A0 Ppos %
+      Printf out F R off A0 Ppos %
     else
       ();
     Printf out I col' `":" T.Ptk tk `" ";
@@ -178,7 +178,7 @@ struct
     let
       fun Players (out, x, y) = ignore $ PlayersCompact (out, x, y)
     in
-      Printf out `"\nexpanding (" A2 Players NONE (rev mLayers)
+      Printf out F `"expanding (" A2 Players NONE (rev mLayers)
         `") macro " `id %
     end
   in
@@ -350,7 +350,7 @@ struct
     else
       printf Ign
 
-  val PDP = fn z => bind A0 (fn out => out "\n!!! ") z
+  val PDP = fn z => bind A0 (fn out => Printf out F `"!!! " %) z
 
   fun handleInclude (T.PpcInclude (dir, arg), pos) ppc =
   let
@@ -386,7 +386,7 @@ struct
     else (
       Printf out `" {";
       Printf out PtokenL 1 body;
-      Printf out `"}" %
+      Printf out `"}\n" %
     )
 
   fun parseDefineObjMacro ppc =
@@ -514,7 +514,7 @@ struct
       SOME (_, pos', macro') =>
         if not $ eqMacro (macro, macro') then (
             warning (pos2tkPos pos) `macroName `" macro redefinition" %;
-            printf `"See " T.S.Ppos pos' %
+            printf F `"See " T.S.Ppos pos' %
         ) else
           ()
     | NONE => ();
@@ -543,7 +543,7 @@ struct
   val Pbody = fn z =>
   let
     fun printBody (out, msg, body) = (
-      Printf out `"\n" `msg `" {";
+      Printf out F `msg `" {";
       Printf out PtokenL 1 body;
       Printf out `"}\n" %
     )
@@ -662,7 +662,7 @@ struct
         print tail
       )
     in
-      Printf out `"\n" `msg `" {\n";
+      Printf out F `msg `" {\n";
       print params;
       Printf out `"}\n" %
     end
@@ -832,7 +832,6 @@ struct
 
   and handleIf (tk, ifPos) ppc =
   let
-    val dprintf = dprintf ppc `"\n"
     val (eval, getRevBody) =
       case tk of
         T.PpcIfdef => (ifdefEval true, getIfdefRevBody T.PpcIfdef)
@@ -843,7 +842,7 @@ struct
     val (cond, ppc) = eval ifPos ppc
     val (revBody, ppc) = getRevBody ifPos cond ppc
   in
-    dprintf `" {" PtokenL 1 (rev revBody) `"}\n";
+    dprintf ppc `" {" PtokenL 1 (rev revBody) `"}\n";
     insertRevBody revBody ppc
   end
 
@@ -854,7 +853,7 @@ struct
     val (_, _, ppc) = getClassNoexpand ppc [Ctk T.NewLine]
     val (prevVal, macros) = Tree.delete macroCompare (#macros ppc) id
   in
-    dprintf ppc `"\n#undef " `id %;
+    dprintf ppc PDP `"#undef " `id %;
     case prevVal of
       NONE => warning pos
         `"#undef: no macro with provided name was defined" %
@@ -942,23 +941,22 @@ struct
             updatePpc P u#buffer (updateH head) %
   end
 
-  fun debugPrint' cache ppc =
+  fun debugPrint' (out, cache, ppc) =
   let
     val (tk, pos, ppc) = getToken ppc
-    val cache = printTokenCompact cache (output TextIO.stdOut) (tk, pos)
+    val cache = printTokenCompact cache out (tk, pos)
   in
     if tk = T.EOS then
       ()
     else
-      debugPrint' cache ppc
+      Printf out A2 debugPrint' cache ppc %
   end
 
   fun debugPrint fname incDirs =
   let
     val ppc = create { fname, incDirs, debugMode = true }
   in
-    debugPrint' startCache ppc;
-    printf `"\n" %
+    printf A2 debugPrint' startCache ppc F %
   end
 
   fun getClass ppc clList =
diff --git a/stream.sig b/stream.sig
index 2f2c834..4426e62 100644
--- a/stream.sig
+++ b/stream.sig
@@ -8,7 +8,7 @@ signature STREAM = sig
 
   exception EOF
 
-  val Ppos: (pos, 'a, 'b) a1printer
+  val Ppos: (pos, 'a, 'b, 'c) a1printer
 
   val getchar: t -> char option * t
 
diff --git a/tokenizer.sig b/tokenizer.sig
index a1f5c28..97baa17 100644
--- a/tokenizer.sig
+++ b/tokenizer.sig
@@ -124,7 +124,7 @@ signature TOKENIZER = sig
     PpcPragma
 
   val getToken: S.t -> token * S.pos * S.t
-  val Ptk: (token, 'a, 'b) a1printer
+  val Ptk: (token, 'a, 'b, 'c) a1printer
 
   val isPpcDir: token -> bool
   val debugPrint: string -> unit