expandableAlt

src/Rlp2Core.hs

@@ -52,8 +52,6 @@ declToCore fd@(FunD'' n as e _) = mempty & programScDefs .~ [ScDef n' as' e'']
         names = [ nolo $ "$x_" <> tshow n | n <- [0..] ]
         tshow = T.pack . show
 
--- mapAccumL :: Traversable t => (s -> a -> (s, b)) -> s -> t a -> (s, t b)
-
 caseify :: RlpExpr RlpcPs -> (IdP' RlpcPs, Pat' RlpcPs)
         -> (RlpExpr RlpcPs, Name)
 caseify e (x,p) = (e', x') where
@@ -62,7 +60,50 @@ caseify e (x,p) = (e', x') where
     alt = AltA p (nolo e)
 
 exprToCore :: RlpExpr RlpcPs -> Expr'
-exprToCore = undefined
+
+exprToCore (VarE n) = Var (dsNameToName n)
+
+exprToCore (CaseE e as) = undefined
+
+-- >>> pat1 = nolo $ ConP "C" [nolo $ ConP "P" []]
+-- >>> expandableAlt "name" (AltA pat1 (nolo $ VarE "e"))
+-- Just (ConP "C" [Located (SrcSpan 0 0 0 0) (VarP "name")],ConP "P" [],VarE' () "e")
+-- 
+-- >>> 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) = do
+    p <- nestedPat
+    let c' = ConP cn as'
+    pure (c', p, extract e)
+  where
+    l :: Lens' [Pat RlpcPs] (Maybe (Pat RlpcPs))
+    l = atFound (has _ConP)
+    nestedPat = (unXRec <$> as) ^. l
+    as' = (unXRec <$> as) & l ?~ VarP n
+                          & fmap nolo
+
+-- 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
+atFound :: forall a. (a -> Bool) -> Lens' [a] (Maybe a)
+atFound p = lens (find p) alter where
+    alter :: [a] -> Maybe a -> [a]
+    alter l Nothing  = deleteFound l
+    alter l (Just x') = setFound x' l
+
+    deleteFound :: [a] -> [a]
+    deleteFound []  = []
+    deleteFound (x:xs)
+        | p x       = xs
+        | otherwise = x : deleteFound xs
+
+    setFound :: a -> [a] -> [a]
+    setFound _  []  = []
+    setFound x' (x:xs)
+        | p x       = x' : xs
+        | otherwise = x : setFound x' xs
 
 constructorToCore :: Type -> Tag -> ConAlt RlpcPs -> Program'
 constructorToCore t tag (ConAlt cn as) =