path: root/parser.fun

functor Parser(P: PPC): PARSER = struct

  structure P = P
  structure T = P.T

  datatype unop =
    UnopPreInc |
    UnopPreDec |
    UnopAddr |
    UnopDeref |
    UnopPos |
    UnopNeg |
    UnopComp |
    UnopLogNeg |

    UnopPostInc |
    UnopPostDec

  datatype binop =
    BinopSubscript |

    BinopMul |
    BinopDiv |
    BinopMod |
    BinopSum |
    BinopSub |
    BinopShiftLeft |
    BinopShiftRight |
    BinopGreater |
    BinopLess |
    BinopLessEqual |
    BinopGreaterEqual |
    BinopEqual |
    BinopNotEqual |
    BinopBitAnd |
    BinopBitXor |
    BinopBitOr |
    BinopLogAnd |
    BinopLogOr |

    BinopAssign |
    BinopMulAssign |
    BinopDivAssign |
    BinopModAssign |
    BinopSumAssign |
    BinopSubAssign |
    BinopLeftShiftAssign |
    BinopRightShiftAssign |
    BinopBitAndAssign |
    BinopBitXorAssign |
    BinopBitOrAssign |

    BinopComma

  val binopTable = [
    (BinopSubscript, T.Invalid, 0, false),

    (BinopMul, T.Asterisk, 13, true),
    (BinopDiv, T.Slash, 13, true),
    (BinopMod, T.Percent, 13, true),
    (BinopSum, T.Plus, 12, true),
    (BinopSub, T.Minus, 12, true),
    (BinopShiftLeft, T.DoubleLess, 11, true),
    (BinopShiftRight, T.DoubleGreater, 11, true),
    (BinopGreater, T.Greater, 10, true),
    (BinopLess, T.Less, 10, true),
    (BinopLessEqual, T.LessEqualSign, 10, true),
    (BinopGreaterEqual, T.GreaterEqualSign, 10, true),
    (BinopEqual, T.DoubleEqualSign, 9, true),
    (BinopNotEqual, T.ExclMarkEqualSign, 9, true),
    (BinopBitAnd, T.Ampersand, 8, true),
    (BinopBitXor, T.Cap, 7, true),
    (BinopBitOr, T.VerticalBar, 6, true),
    (BinopLogAnd, T.DoubleAmpersand, 5, true),
    (BinopLogOr, T.DoubleVerticalBar, 4, true),

    (BinopAssign, T.EqualSign, 2, false),
    (BinopMulAssign, T.AmpersandEqualSign, 2, false),
    (BinopDivAssign, T.SlashEqualSign, 2, false),
    (BinopModAssign, T.PercentEqualSign, 2, false),
    (BinopSumAssign, T.PlusEqualSign, 2, false),
    (BinopSubAssign, T.MinusEqualSign, 2, false),
    (BinopLeftShiftAssign, T.DoubleLessEqualSign, 2, false),
    (BinopRightShiftAssign, T.DoubleGreaterEqualSign, 2, false),
    (BinopBitAndAssign, T.AmpersandEqualSign, 2, false),
    (BinopBitXorAssign, T.CapEqualSign, 2, false),
    (BinopBitOrAssign, T.VerticalBarEqualSign, 2, false),

    (BinopComma, T.Comma, 1, true)
  ]

  datatype expr =
    Enum |
    Eid of string |
    Estrlit of string |
    EmemberByV of string * exprAug |
    EmemberByP of string * exprAug |
    EfuncCall of exprAug * exprAug list |
    Eunop of unop * exprAug |
    Ebinop of binop * exprAug * exprAug

  and exprAug = EAug of expr * P.tkPos

  datatype exprPart =
    EPexpr of exprAug |
    (* last two are prio and leftAssoc *)
    EPbinop of binop * P.tkPos * int * bool

  type def = expr

  datatype token =
    Tk of T.token |
    TkParens of (token * P.tkPos) list |
    TkBrackets of (token * P.tkPos) list |
    TkBraces of (token * P.tkPos) list

  fun PtokenL (_, []) = ()
    | PtokenL (out, head :: tail) =
    let
      fun printL list s e =
        Printf out `s`"| " A1 PtokenL list `" |"`e `", " A1 PtokenL tail %
      val (tk, _) = head
    in
      case tk of
        Tk tk => Printf out T.Ptk tk `"," A1 PtokenL tail %
      | TkParens list => printL list "(" ")"
      | TkBrackets list => printL list "[" "]"
      | TkBraces list => printL list "{" "}"
    end

  type parseCtx = P.t * (token * P.tkPos) list list

  fun createParseCtx fname incDirs =
    (P.create { fname, incDirs, debugMode = false }, [])

  fun getTokenCtx (ppc, []) =
  let
    fun first T.RParen = "'('"
      | first T.RBracket = "'['"
      | first T.RBrace = "'{'"
      | first _ = raise Unreachable

    fun newFrom start pos =
    let
      fun new con tkEnd = SOME (con, pos, tkEnd, [])
    in
      case start of
        T.LParen => new TkParens T.RParen
      | T.LBracket => new TkBrackets T.RBracket
      | T.LBrace => new TkBraces T.RBrace
      | _ => NONE
    end

    fun collect ppc (S as ((con, pos, tkEnd, list) :: tail)) =
    let
      val (tk, pos1, ppc) = P.getToken ppc
    in
      if tk = tkEnd then
        let
          val tk = con (rev $ (Tk T.EOS, pos1) :: list)
        in
          case tail of
            [] => (tk, pos, ppc)
          | ((con', pos', tkEnd, list) :: tail) =>
              collect ppc ((con', pos', tkEnd, (tk, pos) :: list) :: tail)
        end
      else
        collect ppc (
          case newFrom tk pos1 of
            SOME layer => (layer :: S)
          | NONE => (
            case tk of
              T.RParen | T.RBracket | T.RBrace =>
                P.error pos `"unmatched " `(first tkEnd) %
              | _ => (con, pos, tkEnd, (Tk tk, pos1) :: list) :: tail
          )
        )
    end
      | collect _ _ = raise Unreachable

    val (tk, pos, ppc) = P.getToken ppc
  in
    case newFrom tk pos of
      SOME layer =>
        (fn (tk, pos, ppc) => (tk, pos, (ppc, []))) $ collect ppc [layer]
    | NONE => (Tk tk, pos, (ppc, []))
  end
  | getTokenCtx (C as (_, [(Tk T.EOS, pos)] :: _)) =
    (Tk T.EOS, pos, C)
  | getTokenCtx (_, [_] :: _) = raise Unreachable
  | getTokenCtx (_, [] :: _) = raise Unreachable
  | getTokenCtx (ppc, ((tk, pos) :: tail) :: layers) =
    (tk, pos, (ppc, tail :: layers))

  fun ctxWithLayer (ppc, layers) list cl =
  let
    val ctx = (ppc, list :: layers)
    val (v, ctx) = cl ctx
  in
    (v, (fn (ppc, layers) => (ppc, tl layers)) ctx)
  end

  val Punop = fn z =>
  let
    fun Punop (out, unop) =
      Printf out `(case unop of
        UnopPreInc | UnopPostInc => "++"
      | UnopPreDec | UnopPostDec => "--"
      | UnopPos => "+"
      | UnopNeg => "-"
      | UnopAddr => "&"
      | UnopDeref => "*"
      | UnopComp => "~"
      | UnopLogNeg => "!") %
  in
    bind A1 Punop
  end z

  val Pbinop = fn z =>
  let
    fun Pbinop (out, binop) =
      case List.find (fn (binop', _, _, _) => binop' = binop) binopTable
      of
        SOME (_, tk, _, _) => Printf out T.Ptk tk %
      | NONE => raise Unreachable
  in
    bind A1 Pbinop
  end z

  fun printExpr (out, off, ea) =
  let
    fun printExpr' (out, off, EAug (e, pos)) =
    let
      val P = fn z =>
      let
        fun Ppos out = Printf out `"| " P.PtkPos pos %
      in
        bind A0 Ppos
      end z

      fun member (member, ea) s = Printf out
        `"(" `s `member P `"\n" A2 printExpr' (off + 1) ea `")" %;
    in
      printf R off %;
      case e of
        Eid id => Printf out `id P %
      | Enum => Printf out `"num" P %
      | Estrlit s => Printf out `"\"" `s `"\"" P %
      | EmemberByV pair => member pair "."
      | EmemberByP pair => member pair "->"
      | EfuncCall (func, args) => (
        Printf out `"(fcall" P `"\n" A2 printExpr' (off + 1) func `"\n" %;
        app (fn arg =>
            (Printf out A2 printExpr' (off + 1) arg `"\n" %)) args;
        Printf out R off `")" %
      )
      | Eunop (unop, ea) => Printf out
        `"(" Punop unop P `"\n" A2 printExpr' (off + 1) ea `")" %
      | Ebinop (binop, left, right) =>
        let
          val binop =
            if binop = BinopSubscript then
              "[]"
            else
              sprintf Pbinop binop %
        in
          Printf out `"(" `binop P `"\n"
            A2 printExpr (off + 1) left
            A2 printExpr' (off + 1) right `")" %
        end
    end
  in
    Printf out A2 printExpr' off ea `"\n" %
  end

  fun parseUnaryPrefix ctx acc =
  let
    val unopPreTable = [
      (T.DoublePlus, UnopPreInc),
      (T.DoubleMinus, UnopPreDec),
      (T.Plus, UnopPos),
      (T.Minus, UnopNeg)
    ]
    val (tk, pos, ctx') = getTokenCtx ctx
  in
    case tk of
      Tk tk => (
        case List.find (fn (tk', _) => tk' = tk) unopPreTable of
          SOME (_, unop) => parseUnaryPrefix ctx' ((unop, pos) :: acc)
        | _ => (acc, ctx)
      )
    | _ => (acc, ctx)
  end

  fun parseBinop ctx endTk =
  let
    val (tk, pos, ctx) = getTokenCtx ctx
  in
    case tk of
      Tk tk =>
        if tk = T.EOS orelse (isSome endTk andalso tk = valOf endTk) then
          NONE
        else (
          case List.find (fn (_, tk', _, _) => tk' = tk) binopTable of
            SOME (binop, _, prio, leftAssoc) =>
              SOME (EPbinop (binop, pos, prio, leftAssoc), ctx)
          | NONE => P.clerror pos [P.Cbinop]
        )
    | _ => P.clerror pos [P.Cbinop]
  end

  fun parseFuncArgs ctx ea list pos =
  let
    fun collect ctx acc =
    let
      val (ea, ctx) = parseExpr ctx (SOME T.Comma)
      val (tk, _, ctx) = getTokenCtx ctx
    in
      case tk of
        Tk T.EOS => (rev $ ea :: acc, ctx)
      | _ => collect ctx (ea :: acc)
    end
    val (acc, ctx) = ctxWithLayer ctx list (fn ctx => collect ctx [])
  in
    (SOME $ EAug (EfuncCall (ea, acc), pos), ctx)
  end

  and parseExprSuffix1 eAug ctx =
  let
    val (tk, pos1, ctx1) = getTokenCtx ctx

    fun formUnop1 unop = (SOME (EAug (Eunop (unop, eAug), pos1)), ctx1)
    fun formMemberOp unop =
    let
      val (tk, pos2, ctx2) = getTokenCtx ctx1
    in
      case tk of
        Tk (T.Id id) => (SOME (EAug (unop (id, eAug), pos1)), ctx2)
      | _ => P.clerror pos2 [P.Cid]
    end
  in
    case tk of
      Tk T.DoublePlus => formUnop1 UnopPostInc
    | Tk T.DoubleMinus => formUnop1 UnopPostDec
    | Tk T.Dot => formMemberOp EmemberByV
    | Tk T.Arrow => formMemberOp EmemberByP
    | TkBrackets list =>
        let
          val (ea, ctx) =
            ctxWithLayer ctx1 list (fn ctx => parseExpr ctx NONE)
        in
          (SOME $ EAug (Ebinop (BinopSubscript, eAug, ea), pos1), ctx)
        end
    | TkParens list => parseFuncArgs ctx1 eAug list pos1
    | _ => (NONE, ctx)
  end

  and parseExprSuffix eAug ctx =
  let
    val (eAug', ctx) = parseExprSuffix1 eAug ctx
  in
    case eAug' of
      SOME eAug => parseExprSuffix eAug ctx
    | NONE => (eAug, ctx)
  end

  and parsePrimaryExpr ctx =
  let
    val (tk, pos, ctx) = getTokenCtx ctx
    fun wrap e = (EAug (e, pos), ctx)
  in
    case tk of
      Tk (T.Id id) => wrap $ Eid id
    | Tk (T.StringConst s) => wrap $ Estrlit s
    | Tk (T.CharConst _) => raise Unimplemented
    | Tk (T.Num _) => wrap Enum
    | TkParens list =>
        ctxWithLayer ctx list (fn (ctx: parseCtx) => parseExpr ctx NONE)
    | _ => P.clerror pos [P.Cid, P.Cconst]
  end

  and parseUnary ctx =
  let
    val (prefix, ctx) = parseUnaryPrefix ctx []
    val (eAug, ctx) = parsePrimaryExpr ctx
    val (eAug, ctx) = parseExprSuffix eAug ctx

    val eAug = List.foldl
        (fn ((unop, pos), e) => EAug (Eunop (unop, e), pos)) eAug prefix
  in
    (EPexpr eAug, ctx)
  end

  and constructExpr parts =
  let
    fun shouldTakePrev _ [] = false
      | shouldTakePrev (_, _, p, assoc) ((_, _, p') :: _) =
        case Int.compare (p', p) of
          GREATER => true
        | EQUAL => assoc
        | LESS => false

    fun moveHead vstack opstack =
    let
      fun take2 (x :: y :: tl) = (x, y, tl)
        | take2 _ = raise Unreachable
      val (right, left, vstack) = take2 vstack
      val (binop', pos, _) = hd opstack

      val head = EAug (Ebinop (binop', left, right), pos)
    in
      (head :: vstack, tl opstack)
    end

    fun insert (Q as (binop, pos, p, _)) (vstack, opstack) =
      if shouldTakePrev Q opstack then
        insert Q (moveHead vstack opstack)
      else
        (vstack, (binop, pos, p) :: opstack)

    fun finish ([ea], []) = ea
      | finish (_, []) = raise Unreachable
      | finish (vstack, opstack) = finish $ moveHead vstack opstack

    fun construct (vstack, opstack) (EPexpr ea :: acc) =
      construct (ea :: vstack, opstack) acc
    | construct stacks (EPbinop Q :: acc) =
      construct (insert Q stacks) acc
    | construct stacks [] = finish stacks
  in
    construct ([], []) parts
  end

  and parseExpr ctx endTk =
  let
    fun collect ctx expVal acc =
      if expVal then
        let
          val (unary, ctx) = parseUnary ctx
        in
          collect ctx (not expVal) (unary :: acc)
        end
      else
          case parseBinop ctx endTk of
            SOME (binop, ctx) => collect ctx (not expVal) (binop :: acc)
          | NONE => (rev acc, ctx)

    val (parts, ctx) = collect ctx true []
    val expr = constructExpr parts
  in
    (expr, ctx)
  end

  fun parseDef ctx =
  let
    val (expr, ctx) = parseExpr ctx NONE
    val () = printf A2 printExpr 0 expr %
  in
    (raise Unimplemented, ctx)
  end
end