From a65ae0bd52e7d1f70af8476b46081907411fa63d Mon Sep 17 00:00:00 2001
From: crumbtoo <crumb@disroot.org>
Date: Tue, 12 Dec 2023 13:50:07 -0700
Subject: [PATCH] rlp syntax

gonna work on typechecking now lol.......
---
 rlp.cabal          |  3 +++
 src/Core/Syntax.hs | 18 +++++++-------
 src/RLP/Syntax.hs  | 59 ++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 71 insertions(+), 9 deletions(-)
 create mode 100644 src/RLP/Syntax.hs

diff --git a/rlp.cabal b/rlp.cabal
index c4249e6..b3483f1 100644
--- a/rlp.cabal
+++ b/rlp.cabal
@@ -33,6 +33,7 @@ library
                     , Core.Lex
                     , Control.Monad.Errorful
                     , Core2Core
+                    , RLP.Syntax
 
     build-tool-depends: happy:happy, alex:alex
 
@@ -50,6 +51,8 @@ library
                     , hashable
                     , pretty
                     , recursion-schemes
+                    , megaparsec
+                    , text
 
     hs-source-dirs:   src
     default-language: GHC2021
diff --git a/src/Core/Syntax.hs b/src/Core/Syntax.hs
index 2f66e00..7a1f500 100644
--- a/src/Core/Syntax.hs
+++ b/src/Core/Syntax.hs
@@ -115,33 +115,33 @@ instance Monoid (Program b) where
 
 ----------------------------------------------------------------------------------
 
-class HasRHS s z | s -> z where
-    _rhs :: Lens' s (Expr z)
+class HasRHS s t a b | s -> a, t -> b, s b -> t, t a -> s where
+    _rhs :: Lens s t a b
 
-instance HasRHS (Alter b) b where
+instance HasRHS (Alter b) (Alter b) (Expr b) (Expr b) where
     _rhs = lens
         (\ (Alter _ _ e) -> e)
         (\ (Alter t as _) e' -> Alter t as e')
 
-instance HasRHS (ScDef b) b where
+instance HasRHS (ScDef b) (ScDef b) (Expr b) (Expr b) where
     _rhs = lens
         (\ (ScDef _ _ e) -> e)
         (\ (ScDef n as _) e' -> ScDef n as e')
 
-instance HasRHS (Binding b) b where
+instance HasRHS (Binding b) (Binding b) (Expr b) (Expr b) where
     _rhs = lens
         (\ (_ := e) -> e)
         (\ (k := _) e' -> k := e')
 
-class HasLHS s a | s -> a where
-    _lhs :: Lens' s a
+class HasLHS s t a b | s -> a, t -> b, s b -> t, t a -> s where
+    _lhs :: Lens s t a b
 
-instance HasLHS (Alter b) (AltCon, [b]) where
+instance HasLHS (Alter b) (Alter b) (AltCon, [b]) (AltCon, [b]) where
     _lhs = lens
         (\ (Alter a bs _) -> (a,bs))
         (\ (Alter _ _ e) (a',bs') -> Alter a' bs' e)
 
-instance HasLHS (ScDef b) (b, [b]) where
+instance HasLHS (ScDef b) (ScDef b) (b, [b]) (b, [b]) where
     _lhs = lens
         (\ (ScDef n as _) -> (n,as))
         (\ (ScDef _ _ e) (n',as') -> (ScDef n' as' e))
diff --git a/src/RLP/Syntax.hs b/src/RLP/Syntax.hs
new file mode 100644
index 0000000..6efdc4e
--- /dev/null
+++ b/src/RLP/Syntax.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE OverloadedStrings #-}
+module RLP.Syntax
+    ( RlpExpr
+    )
+    where
+----------------------------------------------------------------------------------
+import Data.Text                    (Text)
+import Lens.Micro
+import Core                         (HasRHS(..), HasLHS(..))
+----------------------------------------------------------------------------------
+
+newtype RlpProgram b = RlpProgram [Decl b]
+
+data Decl b = InfixD  InfixAssoc Int VarId
+            | FunD    VarId [Pat b] (RlpExpr b)
+            | DataD   ConId [ConId] [ConAlt]
+
+data ConAlt = ConAlt ConId [ConId]
+
+data InfixAssoc = Assoc | AssocL | AssocR
+
+data RlpExpr b = LetE  [Bind b] (RlpExpr b)
+               | VarE  VarId
+               | ConE  ConId
+               | LamE  [Pat b] (RlpExpr b)
+               | CaseE (RlpExpr b) [Alt b]
+               | IfE   (RlpExpr b) (RlpExpr b) (RlpExpr b)
+               | AppE  (RlpExpr b) (RlpExpr b)
+               | LitE  (Lit b)
+
+-- do we want guards?
+data Alt b = AltA (Pat b) (RlpExpr b)
+
+data Bind b = PatB (Pat b) (RlpExpr b)
+            | FunB VarId [Pat b] (RlpExpr b)
+
+data VarId = NameVar Text
+           | SymVar Text
+
+data ConId = NameCon Text
+           | SymCon Text
+
+data Pat b = VarP VarId
+           | LitP (Lit b)
+           | ConP ConId [Pat b]
+
+data Lit b = IntL Int
+           | CharL Char
+           | ListL [RlpExpr b]
+
+-- instance HasLHS Alt Alt Pat Pat where
+--     _lhs = lens
+--         (\ (AltA p _) -> p)
+--         (\ (AltA _ e) p' -> AltA p' e)
+
+-- instance HasRHS Alt Alt RlpExpr RlpExpr where
+--     _rhs = lens
+--         (\ (AltA _ e) -> e)
+--         (\ (AltA p _) e' -> AltA p e')