Nested expressions

6 files changed, 238 insertions, 114 deletions

diff --git a/common.sml b/common.sml
index 02c3724..e947e0f 100644
--- a/common.sml
+++ b/common.sml
@@ -134,6 +134,15 @@ in
   fun printf g = Fold.fold ctx g
 end
 
+fun sprintf g =
+let
+  val buf = ref []
+  fun output s = buf := s :: !buf
+  fun finish _ = String.concat $ rev $ !buf
+in
+  Fold.fold ((false, makePrintfBase output), finish)
+end g
+
 fun Printf out g = Fold.fold ((false, out), fn _ => ()) g
 
 local
diff --git a/parser.fun b/parser.fun
index ccd467e..0d5605b 100644
--- a/parser.fun
+++ b/parser.fun
@@ -3,8 +3,6 @@ functor Parser(P: PPC): PARSER = struct
   structure P = P
   structure T = P.T
 
-  type parseCtx = P.t
-
   datatype unop =
     UnopPreInc |
     UnopPreDec |
@@ -19,6 +17,8 @@ functor Parser(P: PPC): PARSER = struct
     UnopPostDec
 
   datatype binop =
+    BinopSubscript |
+
     BinopMul |
     BinopDiv |
     BinopMod |
@@ -48,9 +48,13 @@ functor Parser(P: PPC): PARSER = struct
     BinopRightShiftAssign |
     BinopBitAndAssign |
     BinopBitXorAssign |
-    BinopBitOrAssign
+    BinopBitOrAssign |
+
+    BinopComma
 
   val binopTable = [
+    (BinopSubscript, T.Invalid, 0, false),
+
     (BinopMul, T.Asterisk, 13, true),
     (BinopDiv, T.Slash, 13, true),
     (BinopMod, T.Percent, 13, true),
@@ -70,17 +74,19 @@ functor Parser(P: PPC): PARSER = struct
     (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)
+    (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 =
@@ -89,6 +95,7 @@ functor Parser(P: PPC): PARSER = struct
     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
 
@@ -107,16 +114,90 @@ functor Parser(P: PPC): PARSER = struct
     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 }
+    (P.create { fname, incDirs, debugMode = false }, [])
 
-  fun getToken ppc =
+  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 tk of
-      T.LParen | T.LBracket | T.LBrace => raise Unimplemented
-    | _ => (Tk tk, pos, ppc)
+    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 =>
@@ -140,52 +221,59 @@ functor Parser(P: PPC): PARSER = struct
     fun Pbinop (out, binop) =
       case List.find (fn (binop', _, _, _) => binop' = binop) binopTable
       of
-        SOME (_, tk, _, _) => Printf out T.Ptk tk%
+        SOME (_, tk, _, _) => Printf out T.Ptk tk %
       | NONE => raise Unreachable
   in
     bind A1 Pbinop
   end z
 
-  fun printExpr off ea =
+  fun printExpr (out, off, ea) =
   let
-    fun printExpr' off (EAug (e, pos)) =
+    fun printExpr' (out, 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 `")" %
-      )
+      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 => Pprintf `id %
-      | Enum => Pprintf `"num" %
-      | Estrlit s => Pprintf `"\"" `s `"\"" %
+        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 "->"
-      | 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 `")" %
+      | 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
-    printExpr' off ea;
-    printf `"\n" %
+    Printf out A2 printExpr' off ea `"\n" %
   end
 
-  fun parseUnaryPrefix ppc acc =
+  fun parseUnaryPrefix ctx acc =
   let
     val unopPreTable = [
       (T.DoublePlus, UnopPreInc),
@@ -193,41 +281,61 @@ functor Parser(P: PPC): PARSER = struct
       (T.Plus, UnopPos),
       (T.Minus, UnopNeg)
     ]
-    val (tk, pos, ppc') = getToken ppc
+    val (tk, pos, ctx') = getTokenCtx ctx
   in
     case tk of
       Tk tk => (
         case List.find (fn (tk', _) => tk' = tk) unopPreTable of
-          SOME (_, unop) => parseUnaryPrefix ppc' ((unop, pos) :: acc)
-        | _ => (acc, ppc)
+          SOME (_, unop) => parseUnaryPrefix ctx' ((unop, pos) :: acc)
+        | _ => (acc, ctx)
       )
-    | _ => (acc, ppc)
+    | _ => (acc, ctx)
   end
 
-  fun parsePrimaryExpr ppc =
+  fun parseBinop ctx endTk =
   let
-    val (tk, pos, ppc) = getToken ppc
+    val (tk, pos, ctx) = getTokenCtx ctx
   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])
+    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 parseExprSuffix1 eAug ppc =
+  fun parseFuncArgs ctx ea list pos =
   let
-    val (tk, pos1, ppc1) = getToken ppc
+    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
 
-    fun formUnop1 unop = (SOME (EAug (Eunop (unop, eAug), pos1)), ppc1)
+  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, ppc2) = getToken ppc1
+      val (tk, pos2, ctx2) = getTokenCtx ctx1
     in
       case tk of
-        Tk (T.Id id) => (SOME (EAug (unop (id, eAug), pos1)), ppc2)
+        Tk (T.Id id) => (SOME (EAug (unop (id, eAug), pos1)), ctx2)
       | _ => P.clerror pos2 [P.Cid]
     end
   in
@@ -236,49 +344,54 @@ functor Parser(P: PPC): PARSER = struct
     | Tk T.DoubleMinus => formUnop1 UnopPostDec
     | Tk T.Dot => formMemberOp EmemberByV
     | Tk T.Arrow => formMemberOp EmemberByP
-    | _ => (NONE, ppc)
+    | 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
 
-  fun parseExprSuffix eAug ppc =
+  and parseExprSuffix eAug ctx =
   let
-    val (eAug', ppc) = parseExprSuffix1 eAug ppc
+    val (eAug', ctx) = parseExprSuffix1 eAug ctx
   in
     case eAug' of
-      SOME eAug => parseExprSuffix eAug ppc
-    | NONE => (eAug, ppc)
+      SOME eAug => parseExprSuffix eAug ctx
+    | NONE => (eAug, ctx)
   end
 
-  fun parseUnary ppc =
+  and parsePrimaryExpr ctx =
   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
+    val (tk, pos, ctx) = getTokenCtx ctx
+    fun wrap e = (EAug (e, pos), ctx)
   in
-    (EPexpr eAug, ppc)
+    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
 
-  fun parseBinop ppc =
+  and parseUnary ctx =
   let
-    val (tk, pos, ppc) = getToken ppc
+    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
-    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]
+    (EPexpr eAug, ctx)
   end
 
-  fun constructExpr parts =
+  and constructExpr parts =
   let
     fun shouldTakePrev _ [] = false
       | shouldTakePrev (_, _, p, assoc) ((_, _, p') :: _) =
@@ -318,31 +431,31 @@ functor Parser(P: PPC): PARSER = struct
     construct ([], []) parts
   end
 
-  fun parseExpr ppc =
+  and parseExpr ctx endTk =
   let
-    fun collect ppc expVal acc =
+    fun collect ctx expVal acc =
       if expVal then
         let
-          val (unary, ppc) = parseUnary ppc
+          val (unary, ctx) = parseUnary ctx
         in
-          collect ppc (not expVal) (unary :: acc)
+          collect ctx (not expVal) (unary :: acc)
         end
       else
-          case parseBinop ppc of
-            SOME (binop, ppc) => collect ppc (not expVal) (binop :: acc)
-          | NONE => (rev acc, ppc)
+          case parseBinop ctx endTk of
+            SOME (binop, ctx) => collect ctx (not expVal) (binop :: acc)
+          | NONE => (rev acc, ctx)
 
-    val (parts, ppc) = collect ppc true []
+    val (parts, ctx) = collect ctx true []
     val expr = constructExpr parts
   in
-    (expr, ppc)
+    (expr, ctx)
   end
 
-  fun parseDef ppc =
+  fun parseDef ctx =
   let
-    val (expr, ppc) = parseExpr ppc
-    val () = printExpr 0 expr
+    val (expr, ctx) = parseExpr ctx NONE
+    val () = printf A2 printExpr 0 expr %
   in
-    (raise Unimplemented, ppc)
+    (raise Unimplemented, ctx)
   end
 end
diff --git a/ppc.fun b/ppc.fun
index 6f4e8b2..c3b7412 100644
--- a/ppc.fun
+++ b/ppc.fun
@@ -435,12 +435,12 @@ struct
     fun parseArg ppc =
     let
       val (tkId, posId, ppc) = getClassNoexpand ppc [Cid]
-      val (tk, _, ppc) = getClassNoexpand ppc [Ctk T.RParen, Ctk T.Coma]
+      val (tk, _, ppc) = getClassNoexpand ppc [Ctk T.RParen, Ctk T.Comma]
       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)
+         | T.Comma => (Arg (id, posId), ppc)
          | _ => raise Unreachable
     end
 
@@ -603,7 +603,7 @@ struct
       case tk of
         T.EOS => error mPos `"unfinished argument list" %
       | T.LParen => continue 1
-      | T.Coma =>
+      | T.Comma =>
           if level > 0 then
             continue 0
           else
diff --git a/ppc.sig b/ppc.sig
index b2dcbae..0bfaca7 100644
--- a/ppc.sig
+++ b/ppc.sig
@@ -14,6 +14,8 @@ signature PPC = sig
     Cop
 
   val clerror: tkPos -> tkClass list -> 'a
+  val error: tkPos -> ((bool * ((string -> unit) * (unit -> unit)))
+    * ('a * ((string -> unit) * (unit -> unit)) -> 'b) -> 'c) -> 'c
 
   val create: { fname: string, incDirs: string list, debugMode: bool } -> t
   val getToken: t -> T.token * tkPos * t
diff --git a/tokenizer.fun b/tokenizer.fun
index 24e0211..6859a73 100644
--- a/tokenizer.fun
+++ b/tokenizer.fun
@@ -65,7 +65,7 @@ struct
 
     QuestionMark |
     Colon |
-    Coma |
+    Comma |
     Semicolon |
 
     Arrow |
@@ -192,7 +192,7 @@ struct
 
       (QuestionMark, "?"),
       (Colon, ":"),
-      (Coma, ","),
+      (Comma, ","),
       (Semicolon, ";"),
 
       (Arrow, "->"),
diff --git a/tokenizer.sig b/tokenizer.sig
index 97baa17..3a711a4 100644
--- a/tokenizer.sig
+++ b/tokenizer.sig
@@ -62,7 +62,7 @@ signature TOKENIZER = sig
 
     QuestionMark |
     Colon |
-    Coma |
+    Comma |
     Semicolon |
 
     Arrow |