extremely basic Rlp2Core

src/Rlp2Core.hs

@@ -26,11 +26,13 @@ import Data.Function                    (on)
 import GHC.Stack
 import Debug.Trace
 import Numeric
+import Misc.MonadicRecursionSchemes
 
 import Data.Fix                         hiding (cata, para, cataM)
 import Data.Functor.Bind
 import Data.Functor.Foldable
 import Control.Comonad
+import Control.Comonad.Cofree
 
 import Effectful.State.Static.Local
 import Effectful.Labeled
@@ -82,27 +84,72 @@ runNameSupply :: Text -> Eff (NameSupply ': es) a -> Eff es a
 runNameSupply pre = runLabeled $ evalState [ pre <> "_" <> tshow name | name <- [0..] ]
     where tshow = T.pack . show
 
+single :: (Monoid s, Applicative f) => ASetter s t a (f b) -> b -> t
+single l a = mempty & l .~ pure a
+
 -- the rl' program is desugared by desugaring each declaration as a separate
 -- program, and taking the monoidal product of the lot :3
 
 rlpProgToCore :: Rlp.Program PsName (TypedRlpExpr PsName) -> Core.Program Var
 rlpProgToCore = foldMapOf (programDecls . each) declToCore
 
-declToCore :: Rlp.Decl PsName (TypedRlpExpr PsName) -> Core.Program Var
+--------------------------------------------------------------------------------
+
+declToCore :: Rlp.Decl PsName TypedRlpExpr' -> Core.Program Var
 
 -- assume full eta-expansion for now
-declToCore (FunD b [] e) = mempty & programScDefs .~ [ScDef b' [] undefined]
-    where
-        b' = MkVar b (typeToCore $ extract e)
-        e' = runPureEff . runNameSupply b . exprToCore $ e
+declToCore (FunD b [] e) = single programScDefs $
+    ScDef b' [] e'
+  where
+    b' = MkVar b (typeToCore $ extract e)
+    e' = runPureEff . runNameSupply b . cataM exprToCore . retype $ e
+
+dummyExpr :: Text -> Core.Expr b
+dummyExpr a = Var ("<" <> a <> ">")
+
+--------------------------------------------------------------------------------
+
+-- | convert rl' types to Core types, annotate binders, and strip excess type
+-- info.
+retype :: Cofree RlpExprF' (Rlp.Type PsName) -> RlpExpr Var
+retype = (_extract %~ unquantify) >>> fmap typeToCore >>> cata \case
+    t :<$ InL (LamF bs e)
+        -> Finl (LamF bs' e)
+      where
+        bs' = zipWith MkVar bs (t ^.. arrowStops)
+
+    t :<$ InL (VarF n)
+        -> Finl (VarF n)
+
+    t :<$ InR (LetEF r bs e)
+        -> Finr (LetEF r _ _)
+
+unquantify :: Rlp.Type b
+           -> Rlp.Type b
+unquantify (ForallT _ x) = unquantify x
+unquantify x             = x
 
 typeToCore :: Rlp.Type PsName -> Core.Type
-typeToCore (VarT n) = TyVar n
+typeToCore = cata \case
+    VarTF n   -> TyVar n
+    ConTF n   -> TyCon n
+    FunTF     -> TyFun
+    AppTF f x -> TyApp f x
+    -- TODO: we assume all quantified tyvars are of kind Type
+    ForallTF x m -> TyForall (MkVar x TyKindType) m
+
+--------------------------------------------------------------------------------
 
 exprToCore :: (NameSupply :> es)
-           => TypedRlpExpr PsName
-           -> Eff es (Cofree (Core.ExprF Var) Core.Type)
-exprToCore = undefined
+           => RlpExprF Var (Core.Expr Var)
+           -> Eff es (Core.Expr Var)
+
+exprToCore (InL e) = pure . embed $ e
+exprToCore (InR _) = _
+
+exprToCore _ = pure $ dummyExpr "expr"
+
+--------------------------------------------------------------------------------
 
 annotateVar :: Core.Type -> Core.ExprF PsName a -> Core.ExprF Var a