From 21d13ea73ba078c34d516bc63bd81c8b2b742bab Mon Sep 17 00:00:00 2001
From: crumbtoo <crumb@disroot.org>
Date: Fri, 2 Feb 2024 19:15:39 -0700
Subject: [PATCH] ccoool

---
 src/Core/Syntax.hs | 11 +++++++++--
 src/Rlp2Core.hs    | 27 +++++++++++++++++++++++++--
 2 files changed, 34 insertions(+), 4 deletions(-)

diff --git a/src/Core/Syntax.hs b/src/Core/Syntax.hs
index b624e43..cad53be 100644
--- a/src/Core/Syntax.hs
+++ b/src/Core/Syntax.hs
@@ -59,8 +59,9 @@ import Data.Char
 import GHC.Generics
 -- Lift instances for the Core quasiquoters
 import Language.Haskell.TH.Syntax   (Lift)
-import Lens.Micro.TH                (makeLenses)
-import Lens.Micro
+-- import Lens.Micro.TH                (makeLenses)
+-- import Lens.Micro
+import Control.Lens
 ----------------------------------------------------------------------------------
 
 data Expr b = Var Name
@@ -152,6 +153,12 @@ makeLenses ''Program
 makeBaseFunctor ''Expr
 pure []
 
+-- this is a weird optic, stronger than Lens and Prism, but weaker than Iso.
+programTypeSigsP :: (Hashable b) => Prism' (Program b) (HashMap b Type)
+programTypeSigsP = prism
+    (\b -> mempty & programTypeSigs .~ b)
+    (Right . view programTypeSigs)
+
 type ExprF' = ExprF Name
 
 type Program' = Program Name
diff --git a/src/Rlp2Core.hs b/src/Rlp2Core.hs
index 5210806..a4974d9 100644
--- a/src/Rlp2Core.hs
+++ b/src/Rlp2Core.hs
@@ -5,24 +5,47 @@ module Rlp2Core
 --------------------------------------------------------------------------------
 import Control.Monad
 import Control.Monad.Writer.CPS
+import Control.Arrow
+import Control.Applicative
 import Lens.Micro
 import Lens.Micro.Internal
 import Data.Text                        (Text)
 import Data.Text                        qualified as T
 import Data.HashMap.Strict              qualified as H
+import Data.Monoid                      (Endo(..))
+import Data.Foldable
 
 import Core.Syntax                      as Core
 import Rlp.Syntax                       as Rlp
 import Rlp.Parse.Types                  (RlpcPs)
 --------------------------------------------------------------------------------
 
+-- the rl' program is desugared by desugaring each declaration as a separate
+-- program, and taking the monoidal product of the lot :3
+
 rlpProgToCore :: RlpProgram RlpcPs -> Program'
 rlpProgToCore = foldMapOf (progDecls . each) declToCore
 
 declToCore :: Decl' RlpcPs -> Program'
 
-declToCore (TySigD'' ns t) =
-    mempty & programTypeSigs .~ H.fromList [ (n, typeToCore t) | n <- ns ]
+declToCore (TySigD'' ns t) = mempty &
+    programTypeSigs .~ H.fromList [ (n, typeToCore t) | n <- ns ]
+
+declToCore (DataD'' n as ds) = fold . getZipList $
+    constructorToCore t' <$> ZipList [0..] <*> ZipList ds
+    where
+        -- create the appropriate type from the declared constructor and its
+        -- arguments
+        t' = foldl TyApp (TyCon n) (TyVar . dsNameToName <$> as)
+
+declToCore (FunD'' n as e wh) = mempty &
+
+constructorToCore :: Type -> Tag -> ConAlt RlpcPs -> Program'
+constructorToCore t tag (ConAlt cn as) =
+    mempty & programTypeSigs . at cn ?~ foldr (:->) t as'
+           & programDataTags . at cn ?~ (tag, length as)
+    where
+        as' = typeToCore <$> as
 
 typeToCore :: RlpType' RlpcPs -> Type
 typeToCore FunConT''    = TyFun