Better debug info

1 files changed, 175 insertions, 132 deletions

diff --git a/ppc.fun b/ppc.fun
index 5c0cb2b..c590ff5 100644
--- a/ppc.fun
+++ b/ppc.fun
@@ -16,7 +16,7 @@ struct
   type t = {
     buffer: layer list,
 
-    macros: (string, bool * tkPos * macro) Tree.t,
+    macros: (string, bool * T.S.pos * macro) Tree.t,
 
     debugMode: bool,
     incDirs: string list
@@ -48,15 +48,15 @@ struct
   fun raiseTkErrorP pos g =
     sprintf (fn (a, f) => g (a, raiseTkError pos o f))
 
-  fun printLayers ((macroName, pos) :: layers) = (
-    printf `"\t" `macroName `" " T.S.Ppos pos %;
-    printLayers layers
+  fun printLayersU ((macroName, pos) :: layers) = (
+    printf `"\tfrom " `macroName `" at " T.S.Ppos pos `"\n" %;
+    printLayersU layers
   )
-    | printLayers [] = ()
+    | printLayersU [] = ()
 
   fun tkErrorPrint (TkPos (pos, layers), msg) = (
     printf T.S.Ppos pos `": " `msg `"\n" %;
-    printLayers layers
+    printLayersU layers
   )
 
   fun raiseTkClassError pos cls = raise TkClassError (pos, cls)
@@ -87,7 +87,7 @@ struct
     printf T.S.Ppos pos `": expected " %;
     printClassList cls;
     printf `"\n";
-    printLayers layers
+    printLayersU layers
   end
 
   val updatePpc = fn z =>
@@ -104,92 +104,89 @@ struct
     { buffer = [Stream $ T.S.create fname], macros = Tree.empty, debugMode,
         incDirs }
 
-  fun compareLayers cached macroLayers =
+  fun printLayer out (macro, pos) = Printf out `macro `" " T.S.Ppos pos %
+
+  fun printLayers _ [] = ()
+    | printLayers out [layer] = printLayer out layer
+    | printLayers out (layer :: layers) = (
+      printLayer out layer;
+      Printf out `", ";
+      printLayers out layers
+    )
+
+  val Players = fn z =>
   let
-    fun dropCommonPrefix [] l2 = ([], l2)
-      | dropCommonPrefix l1 [] = (l1, [])
-      | dropCommonPrefix (e1 :: l1) (e2 :: l2) =
-        if e1 = e2 then
-          dropCommonPrefix l1 l2
-        else
-          (e1 :: l1, e2 :: l2)
-    val (cachedTail, macroTail) =
-      dropCommonPrefix (rev cached) (rev macroLayers)
+    fun Players (out, layers) = printLayers out layers
   in
-    (length cachedTail, macroTail)
+    bind A1 Players
+  end z
+
+  fun convPos (T.S.Pos (fname, line, col)) plen =
+  let
+    val fname = String.extract (fname, plen, NONE)
+  in
+    T.S.Pos ("@" ^ fname, line, col)
   end
 
-  fun printClosure offset _ 0 = offset
-    | printClosure offset out toClose =
+  fun findPrefix s1 s2 =
   let
-    fun printBrace offset 1 = Printf out R offset `"}" %
-      | printBrace offset toClose = (
-      Printf out R offset `"}\n";
-      printBrace (offset - 1) (toClose - 1)
-    )
+    fun findPrefix' i s1 s2 =
+      if i = size s1 orelse i = size s2 then
+        String.substring (s1, 0, i)
+      else if String.sub (s1, i) = String.sub (s2, i) then
+        findPrefix' (i + 1) s1 s2
+      else
+        String.substring (s1, 0, i)
   in
-    Printf out `"\n";
-    printBrace (offset - 1) toClose;
-    offset - toClose
+    findPrefix' 0 s1 s2
   end
 
-  fun printNewLayers offset _ [] = offset
-    | printNewLayers offset out layers =
+  fun PlayersCompact (_, (_, [])) = ""
+    | PlayersCompact (out, (startPrx, L as (layer :: layers))) =
   let
-    fun printLayer offset (macro, pos) =
-      Printf out R offset `macro `" " T.S.Ppos pos `" {" %
-    val () = Printf out `"\n" %
+    fun getFname (_, T.S.Pos (fname, _, _)) = fname
 
-    fun printLayers offset [layer] = printLayer offset layer
-      | printLayers offset (layer :: tail) = (
-      printLayer offset layer;
-      Printf out `"\n";
-      printLayers (offset + 1) tail
-    )
-      | printLayers _ [] = raise Unreachable
+    fun findCommonPrefix prefix [] = prefix
+      | findCommonPrefix prefix (layer :: layers) =
+        findCommonPrefix (findPrefix prefix $ getFname layer) layers
+
+    val (startPrx, layers) =
+      case startPrx of
+        SOME prx => (prx, L)
+      | NONE => (getFname layer, layers)
+    val prefix = findCommonPrefix startPrx layers
+    val plen = size prefix
   in
-    printLayers offset layers;
-    offset + length layers
+    Printf out `prefix `" | " %;
+    printLayers out $ map (fn (m, pos) => (m, convPos pos plen)) L;
+    prefix
   end
 
-  fun printToken (offset, layers, (fname, line)) out (tk, pos) =
+  val startCache = (0, [], ("", 0))
+
+  fun printTokenCompact (off, layers, (fname, line)) out (tk, pos) =
   let
     val TkPos (T.S.Pos (fname', line', col'), layers') = pos
-    val (toClose, newLayers) = compareLayers layers layers'
 
-    val offset1 = printClosure offset out toClose
-    val offset2 = printNewLayers offset1 out newLayers
+    fun Ppos out =
+      case layers' of
+        [] => Printf out `fname' `":" I line' `"| \t" %
+      | _ =>
+        let
+          val prefix = PlayersCompact (out, (SOME fname', layers'))
+          val fname' = String.extract (fname', size prefix, NONE)
+        in
+          Printf out `"; @" `fname' `":" I line' `"| \t" %
+        end
   in
-    if offset1 <> offset orelse offset2 <> offset1 orelse
-      fname' <> fname orelse line' <> line
-    then
-      Printf out `"\n" R offset2 `fname' `":" I line' `"|\t" %
+    if layers <> layers' orelse fname' <> fname orelse line' <> line then
+      Printf out `"\n" R off A0 Ppos %
     else
       ();
     Printf out I col' `":" T.Ptk tk `" ";
-    (offset2, layers', (fname', line'))
+    (off, layers', (fname', line'))
   end
 
-  val Players = fn z =>
-  let
-    fun Players (out, layers) =
-    let
-      fun printLayer (macro, pos) =
-        Printf out `macro `" " T.S.Ppos pos %
-      fun printLayers [] = ()
-        | printLayers [layer] = printLayer layer
-        | printLayers (layer :: layers) = (
-          printLayer layer;
-          out ", ";
-          printLayers layers
-        )
-    in
-      printLayers layers
-    end
-  in
-    bind A1 Players
-  end z
-
   val PtkPos = fn z =>
   let
     fun PtkPos (out, TkPos (pos, layers)) = (
@@ -203,31 +200,49 @@ struct
     bind A1 PtkPos
   end z
 
-  fun warning pos g = printf `"\n" PtkPos pos `":warning: " g
+  fun warning (TkPos (pos, layers)) g =
+    printf `"\n" T.S.Ppos pos `":warning: "
+      (fn (a, _) => g (a, fn (_, output) =>
+        (output "\n"; printLayersU layers)))
 
   val printMacroHeader = fn z =>
   let
     fun printMacroHeader (out, (id, mLayers)) =
-      Printf out `"\n" `"(" Players (rev mLayers) `"): macro " `id %
+    let
+      fun Players (out, v) = ignore $ PlayersCompact (out, v)
+    in
+      Printf out `"\nexpanding (" A1 Players (NONE, rev mLayers)
+        `") macro " `id %
+    end
   in
     bind A1 printMacroHeader
   end z
 
-  val startCache = (0, [], ("", 0))
-
   val printTokenL = fn z =>
   let
-    fun printTokenL (out, (offset, layers, l)) =
+    fun printTokenL (out, (offset, l)) =
     let
-      fun printList cache [] = cache
+      fun printList _ [] = ()
         | printList cache (tk :: tail) =
-          printList (printToken cache out tk) tail
+          printList (printTokenCompact cache out tk) tail
+
+      fun getLast5 (l as _ :: _ :: _ :: _ :: _ :: []) = l
+        | getLast5 (_ :: xs) = getLast5 xs
+        | getLast5 _ = raise Unreachable
 
-      val cache = (offset, layers, ("", 0))
-      val (offset, layers', _) = printList cache l
-      val toClose = length layers' - length layers
+      val cache = (offset, [], ("", 0))
     in
-      printClosure offset out toClose;
+      if length l <= 10 then
+        printList cache l
+      else
+        let
+          val first5 = List.take (l, 5)
+          val last5 = getLast5 l
+        in
+          printList cache first5;
+          Printf out `"\n\t...";
+          printList cache last5
+        end;
       Printf out `"\n" %
     end
   in
@@ -236,9 +251,24 @@ struct
 
   fun updateH head = fn s => Stream head :: tl s
 
+  fun handleMacroEnd id ppc =
+  let
+    val f = fn (_, pos, macro) => (SOME (false, pos, macro), ())
+    val ((), tree) = macrosLookup (#macros ppc) id (f, ())
+  in
+    updatePpc ppc s#macros tree %
+  end
+
   fun getTokenNoexpand (P as { buffer = Tokens tks :: _, ... }: t) = (
     case tks of
-      (tk, pos) :: tail =>
+      (T.MacroEnd id, _) :: tail =>
+      let
+        val ppc = handleMacroEnd id P
+        val ppc = updatePpc ppc u#buffer (fn buf => Tokens tail :: tl buf) %
+      in
+        getTokenNoexpand ppc
+      end
+    | (tk, pos) :: tail =>
         (tk, pos, updatePpc P u#buffer (fn buf => Tokens tail :: tl buf) %)
     | [] => getTokenNoexpand $ updatePpc P u#buffer tl %
   )
@@ -248,7 +278,7 @@ struct
   in
     (tk, pos2tkPos pos, updatePpc P u#buffer (updateH head) %)
   end
-    | getTokenNoexpand _ = raise Unreachable
+    | getTokenNoexpand ppc = (T.EOS, dummyEOSpos, ppc)
 
   fun checkClass (tk, pos) clList raiseClassErr =
   let
@@ -339,10 +369,10 @@ struct
     val start = String.sub (arg, 0)
     val check = checkEndsWith pos arg
   in
-    if start = #"<" then
-      LocalInc (dir, check #">")
-    else if start = #"\"" then
-      ExternalInc $ check #"\""
+    if start = #"\"" then
+      LocalInc (dir, check #"\"")
+    else if start = #"<" then
+      ExternalInc $ check #">"
     else
       raiseTkError pos "invalid #include argument"
   end
@@ -374,20 +404,19 @@ struct
     | _ => getDefineMacroBody ppc ((tk, pos) :: acc)
   end
 
-  fun isFuncMacroDefine len (TkPos (T.S.Pos (_, line1, col1), [])) ppc =
+  fun isFuncMacroDefine len (T.S.Pos (_, line1, col1)) ppc =
   let
     val (tk, TkPos (T.S.Pos (_, line2, col2), _), _) = getTokenNoexpand ppc
   in
     tk = T.LParen andalso line1 = line2 andalso col1 + len = col2
   end
-    | isFuncMacroDefine _ _ _ = raise Unreachable
 
   fun PrintMacroBody (out, body) =
     if body = [] then
       ()
     else (
       Printf out `" {";
-      Printf out printTokenL (0, [], body);
+      Printf out printTokenL (1, body);
       Printf out `"}" %
     )
 
@@ -477,6 +506,7 @@ struct
   fun parseDefine ppc =
   let
     val (macroName, pos, ppc) = getClassNoexpand ppc [Cid]
+    val TkPos (pos, _) = pos
     val macroName =
       case macroName of T.Id id => id | _ => raise Unreachable
 
@@ -499,10 +529,25 @@ struct
 
     val (prevVal, macros) =
         insertMacro (#macros ppc) macroName (false, pos, macro)
+
+    fun eqMacroBody [] [] = true
+      | eqMacroBody [] _ = false
+      | eqMacroBody _ [] = false
+      | eqMacroBody ((tk1, _) :: tl1) ((tk2, _) :: tl2) =
+        if tk1 <> tk2 then false else eqMacroBody tl1 tl2
+
+    fun eqMacro (ObjMacro b1, ObjMacro b2) = eqMacroBody b1 b2
+      | eqMacro (FuncMacro (pl1, b1), FuncMacro (pl2, b2)) =
+        pl1 = pl2 andalso eqMacroBody b1 b2
+      | eqMacro _ = false
   in
     case prevVal of
-      SOME (_, pos', _) => warning pos
-        `"macro redefinition (see " PtkPos pos' `")" %
+      SOME (_, pos', macro') =>
+        if not $ eqMacro (macro, macro') then (
+            warning (pos2tkPos pos) `macroName `" macro redefinition" %;
+            printf `"See " T.S.Ppos pos' %
+        ) else
+          ()
     | NONE => ();
     updatePpc ppc s#macros macros %
   end
@@ -528,9 +573,9 @@ struct
 
   val printBody = fn z =>
   let
-    fun printBody (out, (mLayers, msg, body)) = (
+    fun printBody (out, (msg, body)) = (
       Printf out `"\n" `msg `" {";
-      Printf out printTokenL (1, mLayers, body);
+      Printf out printTokenL (1, body);
       Printf out `"}\n" %
     )
   in
@@ -548,7 +593,7 @@ struct
     val mLayers = addLayer (id, pos)
   in
     dprintf ppc printMacroHeader (id, mLayers);
-    dprintf ppc printBody (mLayers, "body", rev revBody);
+    dprintf ppc printBody ("body", rev revBody);
     insertRevBody revBody ppc
   end
 
@@ -615,8 +660,12 @@ struct
     getAll ppc []
   end
 
-  and subst _ [] (acc: (T.token * tkPos) list) = rev acc
-    | subst bindedParams ((P as (T.Id id, _)) :: tail) acc =
+  and subst (id, pos)_ [] acc =
+    if acc = [] then
+      [(T.MacroEnd id, pos)]
+    else
+      rev $ (T.MacroEnd id, #2 o hd $ acc) :: acc
+    | subst idPos bindedParams ((P as (T.Id id, _)) :: tail) acc =
   let
     fun findArg ((id', args) :: tail) =
       if id' = id then
@@ -626,21 +675,21 @@ struct
       | findArg [] = NONE
   in
     case findArg bindedParams of
-        NONE => subst bindedParams tail (P :: acc)
+        NONE => subst idPos bindedParams tail (P :: acc)
       | SOME arg =>
-          subst bindedParams tail (List.revAppend (arg, acc))
+          subst idPos bindedParams tail (List.revAppend (arg, acc))
   end
-    | subst bindedParams (P :: tail) acc =
-        subst bindedParams tail (P :: acc)
+    | subst bindedParams idPos (P :: tail) acc =
+        subst bindedParams idPos tail (P :: acc)
 
   and printBinded z =
   let
-    fun printBinded (out, (mLayer, msg, params)) =
+    fun printBinded (out, (msg, params)) =
     let
       fun print [] = ()
         | print ((p, args) :: tail) = (
         Printf out `p `": ";
-        Printf out printTokenL (1, mLayer, args);
+        Printf out printTokenL (1, args);
         print tail
       )
     in
@@ -667,15 +716,15 @@ struct
     val (bindedParams, ppc) = parseFuncMacroArgs mPos params ppc
 
     val bp1 = apply addLayers2args bindedParams
-    val () = dprintf ppc printBinded (mLayers, "args", bp1) %
+    val () = dprintf ppc printBinded ("args", bp1) %
 
     val bp2 = apply (expandArgument ppc) bp1
-    val () = dprintf ppc printBinded (mLayers, "expanded args", bp2) %
+    val () = dprintf ppc printBinded ("expanded args", bp2) %
 
     val body = setLayers (id, mPos) body
-    val body = subst bp2 body []
+    val body = subst (id, mPos) bp2 body []
   in
-    dprintf ppc printBody (mLayers, "subst", body);
+    dprintf ppc printBody ("subst", body);
     insertRevBody (rev body) ppc
   end
 
@@ -826,10 +875,25 @@ struct
     val (cond, ppc) = eval ifPos ppc
     val (revBody, ppc) = getRevBody ifPos cond ppc
   in
-    dprintf `" {" printTokenL (1, [], rev revBody) `"}\n";
+    dprintf `" {" printTokenL (1, rev revBody) `"}\n";
     insertRevBody revBody ppc
   end
 
+  and handleUndef _ ppc =
+  let
+    val (tk, pos, ppc) = getTokenNoexpand ppc
+    val id = case tk of T.Id id => id | _ => raise Unreachable
+    val (_, _, ppc) = getClassNoexpand ppc [Ctk T.NewLine]
+    val (prevVal, macros) = Tree.delete macroCompare (#macros ppc) id
+  in
+    dprintf ppc `"\n#undef " `id %;
+    case prevVal of
+      NONE => warning pos
+        `"#undef: no macro with provided name was defined" %
+    | SOME _ => ();
+    updatePpc ppc s#macros macros %
+  end
+
   and handleRegularToken tk pos ppc =
   let
     fun checkAndMark (true, _, _) = (NONE, NONE)
@@ -853,31 +917,10 @@ struct
   in
     case tk of
       T.Id id => handleMacro id
-    | T.MacroEnd id =>
-    let
-      val f = fn (_, pos, macro) => (SOME (false, pos, macro), ())
-      val ((), tree) = macrosLookup (#macros ppc) id (f, ())
-    in
-      getToken $ updatePpc ppc s#macros tree %
-    end
+    | T.MacroEnd id => getToken $ handleMacroEnd id ppc
     | _ => def ()
   end
 
-  and handleUndef _ ppc =
-  let
-    val (tk, pos, ppc) = getTokenNoexpand ppc
-    val id = case tk of T.Id id => id | _ => raise Unreachable
-    val (_, _, ppc) = getClassNoexpand ppc [Ctk T.NewLine]
-    val (prevVal, macros) = Tree.delete macroCompare (#macros ppc) id
-  in
-    dprintf ppc `"\n#undef " `id %;
-    case prevVal of
-      NONE => warning pos
-        `"#undef: no macro with provided name was defined" %
-    | SOME _ => ();
-    updatePpc ppc s#macros macros %
-  end
-
   and ppcFallback (_, pos) _ =
     raiseTkError pos "directive is not implemented"
 
@@ -932,7 +975,7 @@ struct
   fun debugPrint' cache ppc =
   let
     val (tk, pos, ppc) = getToken ppc
-    val cache = printToken cache (output TextIO.stdOut) (tk, pos)
+    val cache = printTokenCompact cache (output TextIO.stdOut) (tk, pos)
   in
     if tk = T.EOS then
       ()