From 15884336f18d7077f3ef468d44aaeb7f53b5f405 Mon Sep 17 00:00:00 2001
From: crumbtoo <crumb@disroot.org>
Date: Tue, 6 Feb 2024 13:04:36 -0700
Subject: [PATCH] parse case exprs

---
 src/Compiler/Types.hs |  9 ++++++++-
 src/Rlp/Lex.x         | 15 +++++++++------
 src/Rlp/Parse.y       | 33 +++++++++++++++++++++++++++++++--
 3 files changed, 48 insertions(+), 9 deletions(-)

diff --git a/src/Compiler/Types.hs b/src/Compiler/Types.hs
index 5352850..7329844 100644
--- a/src/Compiler/Types.hs
+++ b/src/Compiler/Types.hs
@@ -4,7 +4,7 @@ module Compiler.Types
     , Located(..)
     , locating
     , nolo
-    , (<<~), (<~>)
+    , (<<~), (<~>), (<#>)
 
     -- * Re-exports
     , Comonad
@@ -86,3 +86,10 @@ mc <~> ma = mc >>- \f -> ma =>> f
 
 infixl 4 <~>
 
+-- this is getting silly
+
+(<#>) :: (Functor f) => f (a -> b) -> a -> f b
+fab <#> a = fmap ($ a) fab
+
+infixl 4 <#>
+
diff --git a/src/Rlp/Lex.x b/src/Rlp/Lex.x
index 6552fdc..4222694 100644
--- a/src/Rlp/Lex.x
+++ b/src/Rlp/Lex.x
@@ -85,6 +85,7 @@ $white_no_nl+       ;
 <0>
 {
     "let"               { constToken TokenLet `thenBeginPush` layout_let }
+    "of"                { constToken TokenOf `thenBeginPush` layout_of }
 }
 
 -- scan various identifiers and reserved words. order is important here!
@@ -124,18 +125,19 @@ $white_no_nl+       ;
     ()                  { doBol }
 }
 
-<layout_let>
+<layout, layout_let, layout_of>
 {
     \n                  { beginPush bol }
     "{"                 { explicitLBrace `thenDo` popLexState }
-    "in"                { constToken TokenIn `thenDo` (popLexState *> popLayout) }
-    ()                  { doLayout }
 }
 
-<layout_top>
+<layout_let>
+{
+    "in"                { constToken TokenIn `thenDo` (popLexState *> popLayout) }
+}
+
+<layout, layout_top, layout_let, layout_of>
 {
-    \n                  ;
-    "{"                 { explicitLBrace `thenDo` popLexState }
     ()                  { doLayout }
 }
 
@@ -157,6 +159,7 @@ lexReservedOp = \case
     "="     -> TokenEquals
     "::"    -> TokenHasType
     "|"     -> TokenPipe
+    "->"    -> TokenArrow
 
 -- | @andBegin@, with the subtle difference that the start code is set
 --   /after/ the action
diff --git a/src/Rlp/Parse.y b/src/Rlp/Parse.y
index 398d7a3..5623a70 100644
--- a/src/Rlp/Parse.y
+++ b/src/Rlp/Parse.y
@@ -25,6 +25,7 @@ import Data.Semigroup.Traversable
 import Data.Text                    (Text)
 import Data.Text                    qualified as T
 import Data.Void
+import Compiler.Types
 }
 
 %name parseRlpProg StandaloneProgram
@@ -42,6 +43,8 @@ import Data.Void
     consym          { Located _ (TokenConSym _) }
     varsym          { Located _ (TokenVarSym _) }
     data            { Located _ TokenData }
+    case            { Located _ TokenCase }
+    of              { Located _ TokenOf }
     litint          { Located _ (TokenLitInt _) }
     '='             { Located _ TokenEquals }
     '|'             { Located _ TokenPipe }
@@ -150,6 +153,9 @@ Params      :: { [Pat' RlpcPs] }
 Params      : {- epsilon -}             { [] }
             | Params Pat1               { $1 `snoc` $2 }
 
+Pat         :: { Pat' RlpcPs }
+            : Pat1                      { $1 }
+
 Pat1        :: { Pat' RlpcPs }
             : Var                       { fmap VarP $1 }
             | Lit                       { LitP <<= $1 }
@@ -157,20 +163,43 @@ Pat1        :: { Pat' RlpcPs }
 Expr        :: { RlpExpr' RlpcPs }
             : Expr1 InfixOp Expr        { $2 =>> \o ->
                                           OAppE (extract o) $1 $3 }
-            | Expr1                     { $1 }
             | LetExpr                   { $1 }
+            | CaseExpr                  { $1 }
+            | Expr1                     { $1 }
 
 LetExpr     :: { RlpExpr' RlpcPs }
             : let layout1(Binding) in Expr { $1 \$> LetE $2 $4 }
 
+CaseExpr    :: { RlpExpr' RlpcPs }
+            : case Expr of layout0(CaseAlt)
+                { CaseE <<~ $2 <#> $4 }
+
+-- TODO: where-binds
+CaseAlt     :: { (Alt RlpcPs, Where RlpcPs) }
+            : Alt                           { ($1, []) }
+
+Alt         :: { Alt RlpcPs }
+            : Pat '->' Expr                 { AltA $1 $3 }
+
+-- layout0(p : β) :: [β]
+layout0(p)  : '{' layout_list0(';',p) '}'   { $2 }
+            | VL  layout_list0(VS,p)  VR    { $2 }
+
+-- layout_list0(sep : α, p : β) :: [β]
+layout_list0(sep,p) : p                          { [$1] }
+                    | layout_list1(sep,p) sep p  { $1 `snoc` $3 }
+                    | {- epsilon -}              { [] }
+
+-- layout1(p : β) :: [β]
 layout1(p)  : '{' layout_list1(';',p) '}'   { $2 }
             | VL  layout_list1(VS,p) VR     { $2 }
 
+-- layout_list1(sep : α, p : β) :: [β]
 layout_list1(sep,p) : p                          { [$1] }
                     | layout_list1(sep,p) sep p  { $1 `snoc` $3 }
 
 Binding     :: { Binding' RlpcPs }
-            : Pat1 '=' Expr              { PatB <<~ $1 <~> $3 }
+            : Pat '=' Expr              { PatB <<~ $1 <~> $3 }
 
 Expr1       :: { RlpExpr' RlpcPs }
             : '(' Expr ')'              { $1 .> $2 <. $3 }