path: root/ppc.fun

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

  structure T = T

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

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

  type t = {
    streams: T.S.t list,

    buffer: (T.token * tkPos) list,

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

    restricted: bool,
    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 msg pos = raise TkError (pos, msg)
  fun raiseTkErrorSPos pos msg = raiseTkError msg $ 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 raiseTkClassErrorSPos pos cls = raiseTkClassError (pos2tkPos 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 streams buffer macros restricted debugMode incDirs =
        { streams, buffer, macros, restricted, debugMode, incDirs }
      fun to f { streams, buffer, macros, restricted, debugMode,
        incDirs } =
        f streams buffer macros restricted debugMode incDirs
    in
      FRU.makeUpdate6 (from, from, to)
    end z

  fun create { fname, incDirs, debugMode } =
    { streams = [T.S.create fname], buffer = [], macros = Tree.empty,
        restricted = false, 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 printMacroHeader = fn z =>
  let
    fun printMacroHeader (out, (id, mLayers)) =
    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

      val layers = rev mLayers
    in
      Printf out `"\n" `"(" A1 Players layers `"): macro " `id %
    end
  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

  datatype IncludeArg =
    LocalInc of string * T.S.pos |
    ExternalInc of string * T.S.pos

  fun parseIncludeArg stream =
  let
    fun eat pred stream skipFirst acc =
    let
      val (c, stream') = T.S.getcharEx stream
    in
      if pred c then
        eat pred stream' skipFirst (c :: acc)
      else
        (implode o rev $ acc, if skipFirst then stream' else stream)
    end
    val (_, stream) = eat Char.isSpace stream false []
    val (pos, stream) = T.S.getPos stream
    val (start, stream) = T.S.getcharEx stream
    val finish =
      if start = #"\"" then
        #"\""
      else if start = #"<" then
        #">"
      else
        raiseTkErrorSPos pos "expected \" or <"

    val (arg, stream) = eat (fn c => c <> finish) stream true []
    val (_, stream) =
      eat (fn c => c = #" " orelse c = #"\t") stream false []
    val (c, stream) = T.S.getcharEx stream
  in
    if c <> #"\n" then
      let
        val (pos, _) = T.S.getPosAfterChar stream
      in
        raiseTkErrorSPos pos "expected '\n'"
      end
    else
      (if start = #"\"" then LocalInc (arg, pos)
        else ExternalInc (arg, pos), stream)
  end handle T.S.EOF =>
  let
    val (pos, _) = T.S.EOFpos stream
  in
    raiseTkErrorSPos pos "unexpected EOF during #include argument parsing"
  end

  fun findFile arg (stream, incDirs) = 
    case arg of
      LocalInc (arg, pos) => (
      let
        val dir = OS.Path.getParent o T.S.getFname $ stream
        val path = OS.Path.concat (dir, arg)

        val (path, instream) = (path, TextIO.openIn path)
      in
        (path, instream)
      end handle
      OS.Path.Path => raiseTkErrorSPos pos "invalid argument"
      | Size => raiseTkErrorSPos pos "resulting path is too long"
      | IO.Io v => raise IO.Io v
    )
    | ExternalInc (arg, pos) =>
    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 => raiseTkErrorSPos pos "unable to find header"
    end

  fun handleInclude (P as { streams = head :: tail, incDirs, ... }: t) =
  let
    val (arg, oldHead) = parseIncludeArg head
    val (path, instream) = findFile arg (head, incDirs)
    val head = T.S.createFromInstream path instream
  in
    updatePpc P s#streams (head :: oldHead :: tail) %
  end
    | handleInclude _ = raise Unreachable

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

  fun isFuncMacroDefine nameLength (T.S.Pos (_, line1, col1)) stream =
  let
    val (tk, T.S.Pos (_, line2, col2), _) = T.getToken stream
  in
    tk = T.LParen andalso line1 = line2 andalso col1 + nameLength = col2
  end

  fun dBprintf debugMode =
    if debugMode then
      printf
    else
      printf Ign true
  fun dprintf ppc = dBprintf (#debugMode ppc)

  fun PrintMacroBody (out, body) =
  let
    val body = List.map (fn (tk, pos) => (tk, pos2tkPos pos)) body
  in
    Printf out `" {";
    Printf out printTokenL (0, [], body);
    Printf out `"}" %
  end

  fun parseDefineObjMacro debugMode stream =
  let
    val (body, stream) = getDefineMacroBody stream []
  in
    dBprintf debugMode A1 PrintMacroBody body;
    (ObjMacro body, stream)
  end

  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 getClassFromStream stream clList =
    getClassGeneric clList T.getToken raiseTkClassErrorSPos stream

  fun validateArgs args =
  let
    fun validateArg (id, _) [] = id
      | validateArg (id, pos) ((id', pos') :: tail) =
        if id = id' then
          raiseTkErrorSPos 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 stream =
  let
    datatype arg =
        Arg of string * T.S.pos |
        LastArg of string * T.S.pos

    fun parseArg stream =
    let
      val (tkId, posId, stream) = getClassFromStream stream [Cid]
      val (tk, _, stream) = getClassFromStream stream [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), stream)
         | T.Coma => (Arg (id, posId), stream)
         | _ => raise Unreachable
    end

    fun parseArgs stream =
    let
      val (tk, _, stream) = T.getToken stream

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

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

    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
    dBprintf debugMode A0 printParams;
    dBprintf debugMode A1 PrintMacroBody body;
    (FuncMacro (params, rev body), stream)
  end

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

    val () = dBprintf debugMode `"\ndefine " `macroName %

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

    val (macro, stream) = parser debugMode stream
  in
    ((macroName, pos), macro, stream)
  end

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

  fun handleDefine (P as { streams = head :: _, ... }: t) =
  let
    val ((macroName, pos), macro, head) = parseDefine head (#debugMode P)

    val macros = insertMacro (#macros P) macroName (false, macro) handle
        Tree.Exists => raiseTkErrorSPos pos "macro redefinition"
  in
    updatePpc P u#streams (updateH head) s#macros macros %
  end
    | handleDefine _ = raise Unreachable

  val directiveTable = [
      (T.PpcInclude, handleInclude),
      (T.PpcDefine, handleDefine)
  ]

  fun addLayer (id, TkPos (pos, layers)) = (id, pos) :: layers
  fun addLayers idPos body =
  let
    fun formLayers (tk, pos) = (tk, TkPos (pos, addLayer idPos))
  in
    List.map formLayers body
  end

  fun insertRevBody body ppc =
    updatePpc ppc u#buffer (fn buf => List.revAppend (body, buf)) %

  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 TkPos (pos', _) = pos
    val mend = (T.MacroEnd id, if body = [] then pos' else (#2 o hd) body)
    val revBody = addLayers (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 parseArg ppc acc =
    let
      val (tk, pos, ppc) = getToken ppc (* TODO: should be restricted *)
    in
      case tk of
        T.EOS => raiseTkError "unfinished argument list" mPos
      | 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 "too many arguments" mPos
        | 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 "not enough arguments" mPos
        else
          (rev (bindedParam :: acc), ppc)
    end

    val ppc = updatePpc ppc s#restricted true %
    val (_, _, ppc) = getClass ppc [Ctk T.LParen]
    val (res, ppc) = parseArgs ppc params []
    val ppc = updatePpc ppc s#restricted false %
  in
    (res, ppc)
  end

  and expandArgument ppc arg =
  let
    val ppc = updatePpc ppc s#streams [] s#buffer 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 = addLayers (id, mPos) body
    val body = subst bp2 body []
  in
    dprintf ppc printBody (mLayers, "subst", body);
    insertRevBody (rev body) 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 => if (#restricted ppc) then def () else 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 handleToken tk pos ppc =
  let
    fun checkMode () =
      if (#restricted ppc) then
        raiseTkError "directive in unexpected place" pos
      else
        ppc
  in
    case List.find (fn (tk', _) => tk' = tk) directiveTable of
      SOME (_, f) => getToken o f $ checkMode ()
    | NONE => handleRegularToken tk pos ppc
  end

  and getToken (P as { buffer = (tk, pos) :: tail, ... }: t) =
      handleToken tk pos (updatePpc P s#buffer tail %)
    | getToken (P as { streams = [], ... }: t) = (T.EOS, dummyEOSpos, P)
    | getToken (P as { streams = head :: tail, restricted, ... }: t) =
  let
    val (tk, pos, head) = T.getToken head
  in
    if tk = T.EOS then
        case (restricted, tail) of
          (true, _) =>
            (T.EOS, dummyEOSpos, updatePpc P u#streams (updateH head) %)
        | (false, []) =>
          let
            val (pos, head) = T.S.EOFpos head
          in
            (T.EOS, pos2tkPos pos, updatePpc P s#streams [head] %)
          end
        | _ => getToken $ updatePpc P s#streams tail %
    else
        handleToken tk (pos2tkPos pos) $
            updatePpc P u#streams (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