.ghci

@@ -1,5 +1,9 @@
+-- repl extensions
 :set -XOverloadedStrings
 
+--------------------------------------------------------------------------------
+
+-- happy/alex: override :r to rebuild parsers
 :set -package process
 
 :{
@@ -16,3 +20,8 @@ _reload_and_make _ = do
 
 :def! r _reload_and_make
 
+--------------------------------------------------------------------------------
+
+-- import rlpc quasiquoters
+:m + Core.TH Rlp.TH
+

rlp.cabal

@@ -75,6 +75,7 @@ library
                     , comonad
                     , lens
                     , text-ansi
+                    , microlens-pro ^>=0.2.0
 
     hs-source-dirs:   src
     default-language: GHC2021

src/Compiler/Types.hs

@@ -2,6 +2,7 @@ module Compiler.Types
     ( SrcSpan(..)
     , srcspanLine, srcspanColumn, srcspanAbs, srcspanLen
     , Located(..)
+    , locating
     , nolo
     , (<<~), (<~>)
 
@@ -57,6 +58,9 @@ srcspanLen = tupling . _4
 nolo :: a -> Located a
 nolo = Located (SrcSpan 0 0 0 0)
 
+locating :: Lens (Located a) (Located b) a b
+locating = lens extract ($>)
+
 instance Semigroup SrcSpan where
     SrcSpan la ca aa sa <> SrcSpan lb cb ab sb = SrcSpan l c a s where
         l = min la lb

src/Rlp/Syntax.hs

@@ -18,6 +18,8 @@ module Rlp.Syntax
     , ConAlt(..)
     , Binding(..), Binding'
 
+    , _VarP, _LitP, _ConP
+
     -- * Trees That Grow boilerplate
     -- ** Extension points
     , IdP, IdP', XRec, UnXRec(..), MapXRec(..)
@@ -39,8 +41,6 @@ module Rlp.Syntax
     , pattern ConT''
     -- *** Pat
     , pattern VarP'', pattern LitP'', pattern ConP''
-    -- ** NoLocated
-    , NoLocated
     )
     where
 ----------------------------------------------------------------------------------
@@ -52,8 +52,8 @@ import Data.Functor.Classes
 import Data.Functor.Identity
 import Data.Kind                    (Type)
 import Language.Haskell.TH.Syntax   (Lift)
-import Lens.Micro
-import Lens.Micro.TH
+import Lens.Micro.Pro
+import Lens.Micro.Pro.TH
 import Core.Syntax                  hiding (Lit, Type, Binding, Binding')
 import Core                         (HasRHS(..), HasLHS(..))
 ----------------------------------------------------------------------------------
@@ -297,13 +297,5 @@ type Lit' p = XRec p (Lit p)
 --------------------------------------------------------------------------------
 
 makeLenses ''RlpModule
-
---------------------------------------------------------------------------------
-
-data NoLocated
-
-type instance XRec NoLocated a = Identity a
-
-stripLocation :: (UnXRec p) => XRec p a -> f NoLocated
-stripLocation p = undefined
+makePrisms ''Pat
 

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) =