From 2895e3cb480c75223586175c266fa71cedcfdbf7 Mon Sep 17 00:00:00 2001
From: crumbtoo <crumb@disroot.org>
Date: Tue, 6 Feb 2024 13:39:01 -0700
Subject: [PATCH] case unrolling

---
 .ghci              |  3 ---
 rlp.cabal          |  1 +
 src/Core/Syntax.hs |  2 +-
 src/Rlp/Parse.y    | 12 ++++++++++--
 src/Rlp/Syntax.hs  |  2 +-
 src/Rlp2Core.hs    | 28 +++++++++++++++++++++++-----
 6 files changed, 36 insertions(+), 12 deletions(-)

diff --git a/.ghci b/.ghci
index 21ffd96..75be915 100644
--- a/.ghci
+++ b/.ghci
@@ -22,6 +22,3 @@ _reload_and_make _ = do
 
 --------------------------------------------------------------------------------
 
--- import rlpc quasiquoters
-:m + Core.TH Rlp.TH
-
diff --git a/rlp.cabal b/rlp.cabal
index 2f0d553..a2bcd50 100644
--- a/rlp.cabal
+++ b/rlp.cabal
@@ -84,6 +84,7 @@ library
         OverloadedStrings
         TypeFamilies
         LambdaCase
+        ViewPatterns
 
 executable rlpc
     import:           warnings
diff --git a/src/Core/Syntax.hs b/src/Core/Syntax.hs
index cad53be..7b71f91 100644
--- a/src/Core/Syntax.hs
+++ b/src/Core/Syntax.hs
@@ -121,7 +121,7 @@ data Rec = Rec
 data AltCon = AltData Name
             | AltTag Tag
             | AltLit Lit
-            | Default
+            | AltDefault
             deriving (Show, Read, Eq, Lift)
 
 newtype Lit = IntL Int
diff --git a/src/Rlp/Parse.y b/src/Rlp/Parse.y
index 5623a70..c48ff38 100644
--- a/src/Rlp/Parse.y
+++ b/src/Rlp/Parse.y
@@ -154,11 +154,19 @@ Params      : {- epsilon -}             { [] }
             | Params Pat1               { $1 `snoc` $2 }
 
 Pat         :: { Pat' RlpcPs }
-            : Pat1                      { $1 }
+            : Con Pat1s                 { $1 =>> \cn ->
+                                          ConP (extract $1) $2 }
+            | Pat1                      { $1 }
+
+Pat1s       :: { [Pat' RlpcPs] }
+            : Pat1s Pat1                { $1 `snoc` $2 }
+            | Pat1                      { [$1] }
 
 Pat1        :: { Pat' RlpcPs }
-            : Var                       { fmap VarP $1 }
+            : Con                       { fmap (`ConP` []) $1 }
+            | Var                       { fmap VarP $1 }
             | Lit                       { LitP <<= $1 }
+            | '(' Pat ')'               { $1 .> $2 <. $3 }
 
 Expr        :: { RlpExpr' RlpcPs }
             : Expr1 InfixOp Expr        { $2 =>> \o ->
diff --git a/src/Rlp/Syntax.hs b/src/Rlp/Syntax.hs
index f44e989..771ee3b 100644
--- a/src/Rlp/Syntax.hs
+++ b/src/Rlp/Syntax.hs
@@ -11,7 +11,7 @@ module Rlp.Syntax
     , progDecls
     , Decl(..), Decl', RlpExpr(..), RlpExpr'
     , Pat(..), Pat'
-    , Alt(..)
+    , Alt(..), Where
     , Assoc(..)
     , Lit(..), Lit'
     , RlpType(..), RlpType'
diff --git a/src/Rlp2Core.hs b/src/Rlp2Core.hs
index ee9e0e0..f079ebf 100644
--- a/src/Rlp2Core.hs
+++ b/src/Rlp2Core.hs
@@ -18,6 +18,7 @@ import Data.HashMap.Strict              qualified as H
 import Data.Monoid                      (Endo(..))
 import Data.Foldable
 import Data.Functor.Bind
+import Debug.Trace
 
 import Core.Syntax                      as Core
 import Compiler.Types
@@ -63,7 +64,23 @@ exprToCore :: RlpExpr RlpcPs -> Expr'
 
 exprToCore (VarE n) = Var (dsNameToName n)
 
-exprToCore (CaseE e as) = undefined
+exprToCore (CaseE (unXRec -> e) as) = Case (exprToCore e) (caseAltToCore <$> as)
+
+-- TODO: where-binds
+caseAltToCore :: (Alt RlpcPs, Where RlpcPs) -> Alter'
+caseAltToCore (AltA (VarP'' x) e, wh) =
+    Alter AltDefault [] (exprToCore $ unXRec e)
+caseAltToCore (AltA rootPat@(ConP'' cn as) e, wh) =
+    case firstNestedPat of
+        -- this case matches a nested pattern, which must be unrolled:
+        Just (c,p) -> undefined
+        -- no nested patterns! direct translation:
+        Nothing    -> Alter (AltData cn) as' e'
+            where
+                as' = (\ (VarP'' x) -> dsNameToName x) <$> traceShowId as
+                e' = exprToCore (unXRec e)
+  where
+    firstNestedPat = expandableAlt "NAME" . unXRec $ rootPat
 
 -- >>> pat1 = nolo $ ConP "C" [nolo $ ConP "P" []]
 -- >>> expandableAlt "name" (AltA pat1 (nolo $ VarE "e"))
@@ -72,10 +89,10 @@ exprToCore (CaseE e as) = undefined
 -- >>> pat2 = nolo $ ConP "C" [nolo $ VarP "p", nolo $ ConP "P" []]
 -- >>> expandableAlt "name" (AltA pat2 (nolo $ VarE "e"))
 -- Just (ConP "C" [Located (SrcSpan 0 0 0 0) (VarP "p"),Located (SrcSpan 0 0 0 0) (VarP "name")],ConP "P" [],VarE' () "e")
-expandableAlt :: IdP RlpcPs -> Alt RlpcPs
-              -> Maybe (Pat RlpcPs, Pat RlpcPs, RlpExpr RlpcPs)
-expandableAlt n (AltA c@(ConP'' cn as) e) =
-    nestedPat <&> (c', , extract e)
+expandableAlt :: IdP RlpcPs -> Pat RlpcPs
+              -> Maybe (Pat RlpcPs, Pat RlpcPs)
+expandableAlt n c@(ConP cn as) =
+    nestedPat <&> (c',)
   where
     l :: Lens' [Pat RlpcPs] (Maybe (Pat RlpcPs))
     l = atFound (has _ConP)
@@ -84,6 +101,7 @@ expandableAlt n (AltA c@(ConP'' cn as) e) =
     nestedPat = (unXRec <$> as) ^. l
     as' = (unXRec <$> as) & l ?~ VarP n
                           & fmap nolo
+expandableAlt _ _ = Nothing
 
 -- this is an illegal lens, and we're using it illegally. it's convenient :3
 -- TODO: adhere to the holy laws of the Lens Herself