path: root/ppc.fun

functor ppc(structure Tree: TREE; structure T: TOKENIZER): PPC =
struct

  structure T = T

  type mLayers = (string * T.S.pos) list
  datatype tkPos = TkPos of T.S.pos * mLayers

  type macroBody = (T.token * tkPos) list
  datatype macro =
    ObjMacro of macroBody |
    FuncMacro of string list * macroBody

  datatype layer = Stream of T.S.t | Tokens of (T.token * tkPos) list

  type t = {
    buffer: layer list,

    macros: (string, bool * macro) Tree.t,

    debugMode: bool,
    incDirs: string list
  }

  val macroCompare = fn s1 => fn s2 => String.compare (s1, s2)
  val insertMacro = Tree.insert macroCompare
  val macrosLookup = fn z => Tree.lookup2 macroCompare z

  type tkErrorVal = tkPos * string
  exception TkError of tkErrorVal

  datatype tkClass =
    Ctk of T.token |
    Cid |
    Cconst |
    Cunop |
    Cbinop |
    Cop

  type tkClassErrorVal = tkPos * tkClass list
  exception TkClassError of tkClassErrorVal

  fun pos2tkPos pos = TkPos (pos, [])

  val dummyEOSpos = pos2tkPos $ T.S.Pos ("<Unreachable>", 0, 0)

  fun raiseTkError pos msg = raise TkError (pos, msg)
  (* fun raiseTkErrorSPos pos = raiseTkError (pos2tkPos pos) *)

  fun printLayers ((macroName, pos) :: layers) = (
    printf `"\t" `macroName `" " T.S.Ppos pos %;
    printLayers layers
  )
    | printLayers [] = ()

  fun tkErrorPrint (TkPos (pos, layers), msg) = (
    printf T.S.Ppos pos `": " `msg `"\n" %;
    printLayers layers
  )

  fun raiseTkClassError pos cls = raise TkClassError (pos, cls)

  fun tkClassErrorPrint (TkPos (pos, layers), cls) =
  let
    val printCtk = fn
        Ctk tk => printf T.Ptoken tk %
      | Cid => printf `"identifier" %
      | Cconst => printf `"constant" %
      | Cunop => printf `"unary operator" %
      | Cbinop => printf `"binary operator" %
      | Cop => printf `"operator" %

    fun printClassList [] = raise Unreachable
      | printClassList [ctk] = printCtk ctk
      | printClassList [ctk1, ctk2] = (
        printCtk ctk1;
        printf `" or ";
        printCtk ctk2
      )
      | printClassList (ctk :: ctks) = (
        printCtk ctk;
        printf `", ";
        printClassList ctks
      )
  in
    printf T.S.Ppos pos `": expected " %;
    printClassList cls;
    printf `"\n";
    printLayers layers
  end

  val updatePpc = fn z =>
    let
      fun from buffer macros debugMode incDirs =
        { buffer, macros, debugMode, incDirs }
      fun to f { buffer, macros, debugMode, incDirs } =
        f buffer macros debugMode incDirs
    in
      FRU.makeUpdate4 (from, from, to)
    end z

  fun create { fname, incDirs, debugMode } =
    { buffer = [Stream $ T.S.create fname], macros = Tree.empty, debugMode,
        incDirs }

  fun compareLayers cached macroLayers =
  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)
  in
    (length cachedTail, macroTail)
  end

  fun printClosure offset _ 0 = offset
    | printClosure offset out toClose =
  let
    fun printBrace offset 1 = Printf out R offset `"}" %
      | printBrace offset toClose = (
      Printf out R offset `"}\n";
      printBrace (offset - 1) (toClose - 1)
    )
  in
    Printf out `"\n";
    printBrace (offset - 1) toClose;
    offset - toClose
  end

  fun printNewLayers offset _ [] = offset
    | printNewLayers offset out layers =
  let
    fun printLayer offset (macro, pos) =
      Printf out R offset `macro `" " T.S.Ppos pos `" {" %
    val () = Printf out `"\n" %

    fun printLayers offset [layer] = printLayer offset layer
      | printLayers offset (layer :: tail) = (
      printLayer offset layer;
      Printf out `"\n";
      printLayers (offset + 1) tail
    )
      | printLayers _ [] = raise Unreachable
  in
    printLayers offset layers;
    offset + length layers
  end

  fun printToken (offset, 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
  in
    if offset1 <> offset orelse offset2 <> offset1 orelse
      fname' <> fname orelse line' <> line
    then
      Printf out `"\n" R offset2 `fname' `":" I line' `"|\t" %
    else
      ();
    Printf out I col' `":" T.Ptoken tk `" ";
    (offset2, 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)) = (
      if layers <> [] then
        Printf out `"(" Players layers `") " %
      else
        ();
      Printf out T.S.Ppos pos %
    )
  in
    bind A1 PtkPos
  end z

  val printMacroHeader = fn z =>
  let
    fun printMacroHeader (out, (id, mLayers)) =
      Printf out `"\n" `"(" Players (rev mLayers) `"): macro " `id %
  in
    bind A1 printMacroHeader
  end z

  val startCache = (0, [], ("", 0))

  val printTokenL = fn z =>
  let
    fun printTokenL (out, (offset, layers, l)) =
    let
      fun printList cache [] = cache
        | printList cache (tk :: tail) =
          printList (printToken cache out tk) tail

      val cache = (offset, layers, ("", 0))
      val (offset, layers', _) = printList cache l
      val toClose = length layers' - length layers
    in
      printClosure offset out toClose;
      Printf out `"\n" %
    end
  in
    bind A1 printTokenL
  end z

  fun updateH head = fn s => Stream head :: tl s

  fun getTokenNoexpand (P as { buffer = Tokens tks :: _, ... }: t) = (
    case tks of
      (tk, pos) :: tail =>
        (tk, pos, updatePpc P u#buffer (fn buf => Tokens tail :: tl buf) %)
    | [] => getTokenNoexpand $ updatePpc P u#buffer tl %
  )
    | getTokenNoexpand (P as { buffer = Stream head :: _, ... }: t) =
  let
    val (tk, pos, head) = T.getToken head
  in
    (tk, pos2tkPos pos, updatePpc P u#buffer (updateH head) %)
  end
    | getTokenNoexpand _ = raise Unreachable

  fun checkClass (tk, pos) clList raiseClassErr =
  let
    fun belongsToClass tk (Ctk tk') = tk = tk'
      | belongsToClass (T.Id _) (Cid) = true
      | belongsToClass _ Cid = false
      | belongsToClass _ _ = raise Unreachable

    fun checkClass' [] = raiseClassErr pos clList
      | checkClass' (cl :: tail) =
        if belongsToClass tk cl then
          ()
        else
          checkClass' tail
  in
    checkClass' clList
  end

  fun getClassGeneric clList getToken raiseClassErr buf =
  let
    val (tk, pos, buf) = getToken buf
    val () = checkClass (tk, pos) clList raiseClassErr
  in
    (tk, pos, buf)
  end

  fun getClassNoexpand (ppc: t) clList =
    getClassGeneric clList getTokenNoexpand raiseTkClassError ppc

  datatype IncludeArg = LocalInc of string * string | ExternalInc of string

  fun findFile pos arg incDirs =
    case arg of
      LocalInc (dir, arg) => (
      let
        val path = OS.Path.concat (dir, arg)
        val (path, instream) = (path, TextIO.openIn path)
      in
        (path, instream)
      end handle
        OS.Path.Path => raiseTkError pos "invalid argument"
      | Size => raiseTkError pos "resulting path is too long"
      | IO.Io v => raise IO.Io v
    )
    | ExternalInc arg =>
    let
      fun try (dir :: tail) = (
        let
          val path = OS.Path.concat (dir, arg)
        in
          SOME (path, TextIO.openIn path)
        end handle _ => try tail
      )
        | try [] = NONE
    in
      case try incDirs of
        SOME pair => pair
      | NONE => raiseTkError pos "unable to find header"
    end

  fun checkEndsWith pos arg c =
  let
    fun find i =
      if i = size arg then
        raiseTkError pos "unfinished #include argument"
      else if String.sub (arg, i) = c then
        if i + 1 = size arg then
          String.extract (arg, 1, SOME $ size arg - 2)
        else
          raiseTkError pos "some garbage after #include argument"
      else
        find (i + 1)
  in
    find 1
  end

  fun parseIncludeArg pos arg dir =
  let
    fun eatSpaces s off =
      if off = size s then
        raiseTkError pos "invalid #include argument"
      else if String.sub (s, off) = #" " then
        eatSpaces s (off + 1)
      else
        String.extract (s, off, NONE)

    val arg = eatSpaces arg 0
    val start = String.sub (arg, 0)
    val check = checkEndsWith pos arg
  in
    if start = #"<" then
      LocalInc (dir, check #">")
    else if start = #"\"" then
      ExternalInc $ check #"\""
    else
      raiseTkError pos "invalid #include argument"
  end

  fun dprintf ppc =
    if #debugMode ppc then
      printf
    else
      printf Ign

  fun handleInclude (T.PpcInclude (dir, arg), pos) ppc =
  let
    val arg = parseIncludeArg pos arg dir
    val (path, instream) = findFile pos arg (#incDirs ppc)
    val () = dprintf ppc `"\n#include: " `path %
    val stream = T.S.createFromInstream path instream
  in
    updatePpc ppc u#buffer (fn buf => Stream stream :: buf) %
  end
    | handleInclude _ _ = raise Unreachable

  fun getDefineMacroBody ppc acc =
  let
    val (tk, pos, ppc) = getTokenNoexpand ppc
  in
    case tk of
      T.NewLine => (acc, ppc)
    | T.EOS => raiseTkClassError pos [Ctk T.NewLine]
    | _ => getDefineMacroBody ppc ((tk, pos) :: acc)
  end

  fun isFuncMacroDefine len (TkPos (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 `"}" %
    )

  fun parseDefineObjMacro ppc =
  let
    val (body, ppc) = getDefineMacroBody ppc []
  in
    dprintf ppc A1 PrintMacroBody body;
    (ObjMacro body, ppc)
  end

  fun validateArgs args =
  let
    fun validateArg (id, _) [] = id
      | validateArg (id, pos) ((id', pos') :: tail) =
        if id = id' then
          raiseTkError pos' "macro argument name is already taken"
        else
          validateArg (id, pos) tail

    fun validate [] = []
      | validate (arg :: args) = validateArg arg args :: validate args
  in
    validate args
  end

  fun parseDefineMacroArgs ppc =
  let
    datatype arg = Arg of string * tkPos | LastArg of string * tkPos

    fun parseArg ppc =
    let
      val (tkId, posId, ppc) = getClassNoexpand ppc [Cid]
      val (tk, _, ppc) = getClassNoexpand ppc [Ctk T.RParen, Ctk T.Coma]
      val id = case tkId of T.Id id => id | _ => raise Unreachable
    in
      case tk of
           T.RParen => (LastArg (id, posId), ppc)
         | T.Coma => (Arg (id, posId), ppc)
         | _ => raise Unreachable
    end

    fun parseArgs ppc =
    let
      val (tk, _, ppc) = getTokenNoexpand ppc

      fun parse ppc acc =
        case parseArg ppc of
             (LastArg p, ppc) => (rev (p :: acc), ppc)
           | (Arg p, ppc) => parse ppc (p :: acc)
    in
      if tk = T.RParen then
        ([], ppc)
      else
        let
          val (args, ppc) = parse ppc []
          val args = validateArgs args
        in
          (args, ppc)
        end
    end
  in
    parseArgs ppc
  end

  fun parseDefineFuncMacro ppc =
  let
    val (params, ppc) = parseDefineMacroArgs ppc
    val (body, ppc) = getDefineMacroBody ppc []

    fun printParams out =
    let
      fun printParams' [] = ()
        | printParams' [p] = Printf out `p %
        | printParams' (p :: ps) = (Printf out `p `", "; printParams' ps)
    in
      Printf out `"(";
      printParams' params;
      Printf out `")" %
    end
  in
    dprintf ppc A0 printParams;
    dprintf ppc A1 PrintMacroBody body;
    (FuncMacro (params, rev body), ppc)
  end

  fun parseDefine ppc =
  let
    val (macroName, pos, ppc) = getClassNoexpand ppc [Cid]
    val macroName =
      case macroName of T.Id id => id | _ => raise Unreachable

    val () = dprintf ppc `"\ndefine " `macroName %

    val parser =
      if isFuncMacroDefine (size macroName) pos ppc then
        parseDefineFuncMacro
      else
        parseDefineObjMacro

    val (macro, ppc) = parser ppc
  in
    ((macroName, pos), macro, ppc)
  end

  fun handleDefine _ ppc =
  let
    val ((macroName, pos), macro, ppc) = parseDefine ppc

    val macros = insertMacro (#macros ppc) macroName (false, macro)
      handle Tree.Exists => raiseTkError pos "macro redefinition"
  in
    updatePpc ppc s#macros macros %
  end

  fun addLayer (id, TkPos (pos, layers)) = (id, pos) :: layers

  fun setLayers idPos body =
  let
    fun formLayers (tk, TkPos (pos, _)) = (tk, TkPos (pos, addLayer idPos))
  in
    List.map formLayers body
  end

  fun insertRevBody body ppc =
  let
    fun f (B as (Stream _ :: _)) = Tokens (rev body) :: B
      | f (Tokens tks :: tail) =
        Tokens (List.revAppend (body, tks)) :: tail
      | f _ = raise Unreachable
  in
    updatePpc ppc u#buffer f %
  end

  val printBody = fn z =>
  let
    fun printBody (out, (mLayers, msg, body)) = (
      Printf out `"\n" `msg `" {";
      Printf out printTokenL (1, mLayers, body);
      Printf out `"}\n" %
    )
  in
    bind A1 printBody
  end z

  fun expandObjMacro (id, pos) body ppc =
  let
    val mend = (T.MacroEnd id, if body = [] then pos else (#2 o hd) body)
    val revBody = setLayers (id, pos) $ List.concat [[mend], body]

    val mLayers = addLayer (id, pos)
  in
    dprintf ppc printMacroHeader (id, mLayers);
    dprintf ppc printBody (mLayers, "body", rev revBody);
    insertRevBody revBody ppc
  end

  fun getClass ppc clList =
    getClassGeneric clList getToken raiseTkClassError ppc

  and parseFuncMacroArgs mPos params ppc =
  let

    fun getTokenRestricted ppc =
    let
      val (tk, pos, ppc) = getTokenNoexpand ppc
    in
      if T.isPpcDir tk then
        raiseTkError pos "preprocessor directive inside macro arguments"
      else
        (tk, pos, ppc)
    end

    fun parseArg ppc acc =
    let
      val (tk, pos, ppc) = getTokenRestricted ppc
    in
      case tk of
        T.EOS => raiseTkError mPos "unfinished argument list"
      | T.Coma => (true, rev acc, ppc)
      | T.RParen => (false, rev acc, ppc)
      | _ => parseArg ppc ((tk, pos) :: acc)
    end

    fun parseArgs ppc params acc =
    let
      fun bind _ [] = raiseTkError mPos "too many arguments"
        | bind body (param :: params) = ((param, body), params)

      val (continue, arg, ppc) = parseArg ppc []
      val (bindedParam, otherParams) = bind arg params
    in
      if continue then
        parseArgs ppc otherParams (bindedParam :: acc)
      else
        if length otherParams > 0 then
          raiseTkError mPos "not enough arguments"
        else
          (rev (bindedParam :: acc), ppc)
    end

    val (_, _, ppc) = getClassGeneric [Ctk T.LParen]
            getTokenRestricted raiseTkClassError ppc
    val (res, ppc) = parseArgs ppc params []
  in
    (res, ppc)
  end

  and expandArgument ppc arg =
  let
    val ppc = updatePpc ppc s#buffer [Tokens arg] %
    fun getAll ppc acc =
    let
      val (tk, pos, ppc) = getToken ppc
    in
      case tk of
        T.EOS => rev acc
      | _ => getAll ppc ((tk, pos) :: acc)
    end
  in
    getAll ppc []
  end

  and subst _ [] (acc: (T.token * tkPos) list) = rev acc
    | subst bindedParams ((P as (T.Id id, _)) :: tail) acc =
  let
    fun findArg ((id', args) :: tail) =
      if id' = id then
        SOME args
      else
        findArg tail
      | findArg [] = NONE
  in
    case findArg bindedParams of
        NONE => subst bindedParams tail (P :: acc)
      | SOME arg =>
          subst bindedParams tail (List.revAppend (arg, acc))
  end
    | subst bindedParams (P :: tail) acc =
        subst bindedParams tail (P :: acc)

  and printBinded z =
  let
    fun printBinded (out, (mLayer, msg, params)) =
    let
      fun print [] = ()
        | print ((p, args) :: tail) = (
        Printf out `p `": ";
        Printf out printTokenL (1, mLayer, args);
        print tail
      )
    in
      Printf out `"\n" `msg `" {\n";
      print params;
      Printf out `"}\n" %
    end
  in
    bind A1 printBinded
  end z

  and expandFuncMacro (id, mPos) (params, body) ppc =
  let
    val mLayers = addLayer (id, mPos)
    fun addLayers2args body =
    let
      fun formLayers (tk, TkPos (pos, _)) = (tk, TkPos (pos, mLayers))
    in
      List.map formLayers body
    end
    fun apply f bp = List.map (fn (p, arg) => (p, f arg)) bp

    val () = dprintf ppc printMacroHeader (id, mLayers) %
    val (bindedParams, ppc) = parseFuncMacroArgs mPos params ppc

    val bp1 = apply addLayers2args bindedParams
    val () = dprintf ppc printBinded (mLayers, "args", bp1) %

    val bp2 = apply (expandArgument ppc) bp1
    val () = dprintf ppc printBinded (mLayers, "expanded args", bp2) %

    val body = setLayers (id, mPos) body
    val body = subst bp2 body []
  in
    dprintf ppc printBody (mLayers, "subst", body);
    insertRevBody (rev body) ppc
  end

  and getIfRevBody ifPos cond (ppc: t) =
  let
    fun collect level f acc ppc =
    let
      val (tk, pos, ppc) = getTokenNoexpand ppc
      fun def dx = collect (level + dx) f (f ((tk, pos), acc)) ppc
    in
      case tk of
        T.PpcEndif =>
          if level = 0 then
            let
              val (_, _, ppc) = getClassNoexpand ppc [Ctk T.NewLine]
            in
              (acc, ppc)
            end
          else
            def (~1)
      | T.EOS => raiseTkError ifPos "unfinished conditional directive"
      | _ =>
        if tk = T.PpcIf orelse tk = T.PpcIfdef
          orelse tk = T.PpcIfndef
        then
          def 1
        else
          def 0
    end

    val skip = collect 0 (fn (_, _) => []) []
    val collect = collect 0 (op ::) []
  in
    (if cond then collect else skip) ppc
  end

  and ifdefEval pos ifPos ppc =
  let
    fun isDefined id =
      case Tree.lookup macroCompare (#macros ppc) id of
           SOME _ => true
         | _ => false

    val (macro, _, ppc) = getClassNoexpand ppc [Cid]
    val id = case macro of T.Id id => id | _ => raise Unreachable
    val (_, _, ppc) = getClassNoexpand ppc [Ctk T.NewLine]

    val defined = isDefined id
    val (cond, form) =
      if pos then
        (defined, "ifdef")
      else
        (not defined, "ifndef")
  in
    dprintf ppc `"\n" PtkPos ifPos `": #" `form `" " `id `" -> " B cond %;
    (cond, ppc)
  end

  and ifEval ifPos ppc =
  let
    fun skip ppc =
    let
      val (tk, _, ppc) = getTokenNoexpand ppc
    in
      case tk of
        T.EOS => raiseTkError ifPos "unfinished #if condition"
      | T.NewLine => ppc
      | _ => skip ppc
    end
  in
    (true, skip ppc)
  end

  and handleIf (tk, ifPos) ppc =
  let
    val dprintf = dprintf ppc `"\n"
    val (cond, ppc) =
      (case tk of
        T.PpcIfdef => ifdefEval true
      | T.PpcIfndef => ifdefEval false
      | _ => ifEval) ifPos ppc

    val (revBody, ppc) = getIfRevBody ifPos cond ppc
  in
    dprintf `"{" printTokenL (1, [], rev revBody) `"}\n";
    insertRevBody revBody ppc
  end

  and handleRegularToken tk pos ppc =
  let
    fun checkAndMark (true, _) = (NONE, NONE)
      | checkAndMark (false, macro) = (SOME (true, macro), SOME macro)
    fun getMacro tree id = macrosLookup tree id (checkAndMark, NONE)
    fun def () = (tk, pos, ppc)

    fun handleMacro id =
    let
      val (macro, tree) = getMacro (#macros ppc) id
      fun newPpc () = updatePpc ppc s#macros tree %
    in
      case macro of
        NONE => def ()
      | SOME (ObjMacro body) =>
          getToken $ expandObjMacro (id, pos) body (newPpc ())
      | SOME (FuncMacro (arg, body)) =>
          getToken $ expandFuncMacro (id, pos) (arg, body) (newPpc ())
    end
  in
    case tk of
      T.Id id => handleMacro id
    | T.MacroEnd id =>
    let
      val f = fn (_, macro) => (SOME (false, macro), ())
      val ((), tree) = macrosLookup (#macros ppc) id (f, ())
    in
      getToken $ updatePpc ppc s#macros tree %
    end
    | _ => def ()
  end

  and ppcFallback (_, pos) _ =
    raiseTkError pos "directive is not implemented"

  and handleToken tk pos (ppc: t) =
  let
    fun %tk = fn tk' => tk' = tk
    val directiveTable = [
        (fn T.PpcInclude _ => true | _ => false, handleInclude),
        (%T.PpcDefine, handleDefine),
        (%T.PpcIfdef, handleIf),
        (%T.PpcIfndef, handleIf),
        (%T.PpcUndef, ppcFallback),
        (%T.PpcIf, handleIf),
        (%T.PpcElse, ppcFallback),
        (%T.PpcElif, ppcFallback),
        (%T.PpcEndif, ppcFallback),
        (%T.PpcWarning, ppcFallback),
        (%T.PpcError, ppcFallback),
        (%T.PpcPragma, ppcFallback)
    ]
  in
    case List.find (fn (f, _) => f tk) directiveTable of
      SOME (_, f) => getToken $ f (tk, pos) ppc
    | NONE => handleRegularToken tk pos ppc
  end

  and getToken (P as { buffer = Tokens tks :: _, ... }: t) = (
    case tks of
      (tk, pos) :: tail =>
        handleToken tk pos
            (updatePpc P u#buffer (fn b => Tokens tail :: tl b) %)
    | [] => getToken $ updatePpc P u#buffer tl %
  )
    | getToken (P as { buffer = [], ... }: t) = (T.EOS, dummyEOSpos, P)
    | getToken (P as { buffer = Stream head :: tail, ... }: t) =
  let
    val (tk, pos, head) = T.getToken head
  in
    case (tk, tail) of
      (T.EOS, []) =>
      let
        val (pos, head) = T.S.EOFpos head
      in
        (T.EOS, pos2tkPos pos, updatePpc P s#buffer [Stream head] %)
      end
    | (T.EOS, tail) => getToken $ updatePpc P s#buffer tail %
    | (_, _) =>
        handleToken tk (pos2tkPos pos) $
            updatePpc P u#buffer (updateH head) %
  end

  fun debugPrint' cache ppc =
  let
    val (tk, pos, ppc) = getToken ppc
    val cache = printToken cache (output TextIO.stdOut) (tk, pos)
  in
    if tk = T.EOS then
      ()
    else
      debugPrint' cache ppc
  end

  fun debugPrint fname incDirs =
  let
    val ppc = create { fname, incDirs, debugMode = true }
  in
    debugPrint' startCache ppc;
    printf `"\n" %
  end
end