path: root/parser.fun

functor Parser(P: PPC): PARSER = struct

  structure P = P
  structure T = P.T

  type parseCtx = P.t

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

    UnopPostInc |
    UnopPostDec

  datatype binop =
    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

  val binopTable = [
    (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, 3, false),
    (BinopMulAssign, T.AmpersandEqualSign, 3, false),
    (BinopDivAssign, T.SlashEqualSign, 3, false),
    (BinopModAssign, T.PercentEqualSign, 3, false),
    (BinopSumAssign, T.PlusEqualSign, 3, false),
    (BinopSubAssign, T.MinusEqualSign, 3, false),
    (BinopLeftShiftAssign, T.DoubleLessEqualSign, 3, false),
    (BinopRightShiftAssign, T.DoubleGreaterEqualSign, 3, false),
    (BinopBitAndAssign, T.AmpersandEqualSign, 3, false),
    (BinopBitXorAssign, T.CapEqualSign, 3, false),
    (BinopBitOrAssign, T.VerticalBarEqualSign, 3, false)
  ]

  datatype expr =
    Enum |
    Eid of string |
    Estrlit of string |
    EmemberByV of string * exprAug |
    EmemberByP of string * exprAug |
    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 createParseCtx fname incDirs =
    P.create { fname, incDirs, debugMode = false }

  fun getToken ppc =
  let
    val (tk, pos, ppc) = P.getToken ppc
  in
    case tk of
      T.LParen | T.LBracket | T.LBrace => raise Unimplemented
    | _ => (Tk tk, pos, ppc)
  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 off ea =
  let
    fun printExpr' off (EAug (e, pos)) =
    let
      fun Pprintf g = printf R off (fn (a, _) =>
        g (a, fn (_, out) => Printf out `"| " P.PtkPos pos %))

      fun member (member, ea) s = (
        Pprintf `"(" `s `member %;
        printf `"\n" %;
        printExpr' (off + 1) ea;
        printf `")" %
      )
    in
      case e of
        Eid id => Pprintf `id %
      | Enum => Pprintf `"num" %
      | Estrlit s => Pprintf `"\"" `s `"\"" %
      | EmemberByV pair => member pair "."
      | EmemberByP pair => member pair "->"
      | Eunop (unop, ea) => (
        Pprintf `"(" Punop unop %;
        printf `"\n" %;
        printExpr' (off + 1) ea;
        printf `")" %
      )
      | Ebinop (binop, left, right) => (
        Pprintf `"(" Pbinop binop %;
        printf `"\n" %;
        printExpr (off + 1) left;
        printExpr' (off + 1) right;
        printf `")" %
      )
    end
  in
    printExpr' off ea;
    printf `"\n" %
  end

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

  fun parsePrimaryExpr ppc =
  let
    val (tk, pos, ppc) = getToken ppc
  in
    (fn e => (EAug (e, pos), ppc))
      (case tk of
        Tk (T.Id id) => Eid id
      | Tk (T.StringConst s) => Estrlit s
      | Tk (T.CharConst _) => raise Unimplemented
      | Tk (T.Num _) => Enum
      | _ => P.clerror pos [P.Cid, P.Cconst])
  end

  fun parseExprSuffix1 eAug ppc =
  let
    val (tk, pos1, ppc1) = getToken ppc

    fun formUnop1 unop = (SOME (EAug (Eunop (unop, eAug), pos1)), ppc1)
    fun formMemberOp unop =
    let
      val (tk, pos2, ppc2) = getToken ppc1
    in
      case tk of
        Tk (T.Id id) => (SOME (EAug (unop (id, eAug), pos1)), ppc2)
      | _ => 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
    | _ => (NONE, ppc)
  end

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

  fun parseUnary ppc =
  let
    val (prefix, ppc) = parseUnaryPrefix ppc []
    val (eAug, ppc) = parsePrimaryExpr ppc
    val (eAug, ppc) = parseExprSuffix eAug ppc

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

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

  fun 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

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

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

  fun parseDef ppc =
  let
    val (expr, ppc) = parseExpr ppc
    val () = printExpr 0 expr
  in
    (raise Unimplemented, ppc)
  end
end