src/Rlp/Syntax.hs

@@ -11,6 +11,7 @@ module Rlp.Syntax
     , progDecls
     , Decl(..), Decl', RlpExpr(..), RlpExpr'
     , Pat(..), Pat'
+    , Alt(..)
     , Assoc(..)
     , Lit(..), Lit'
     , RlpType(..), RlpType'
@@ -19,7 +20,7 @@ module Rlp.Syntax
 
     -- * Trees That Grow boilerplate
     -- ** Extension points
-    , IdP, XRec, UnXRec(..), MapXRec(..)
+    , IdP, IdP', XRec, UnXRec(..), MapXRec(..)
     -- *** Decl
     , XFunD, XTySigD, XInfixD, XDataD, XXDeclD
     -- *** RlpExpr
@@ -36,6 +37,10 @@ module Rlp.Syntax
     -- *** RlpType
     , pattern FunConT'', pattern FunT'', pattern AppT'', pattern VarT''
     , pattern ConT''
+    -- *** Pat
+    , pattern VarP'', pattern LitP'', pattern ConP''
+    -- ** NoLocated
+    , NoLocated
     )
     where
 ----------------------------------------------------------------------------------
@@ -223,6 +228,8 @@ type family XRec p a = (r :: Type) | r -> p a
 
 type family IdP p
 
+type IdP' p = XRec p (IdP p)
+
 type Where p = [Binding p]
 
 -- do we want guards?
@@ -242,6 +249,14 @@ data Pat p = VarP (IdP p)
            | LitP (Lit' p)
            | ConP (IdP p) [Pat' p]
 
+pattern VarP'' :: (UnXRec p) => IdP p -> Pat' p
+pattern LitP'' :: (UnXRec p) => Lit' p -> Pat' p
+pattern ConP'' :: (UnXRec p) => IdP p -> [Pat' p] -> Pat' p
+
+pattern VarP'' n    <- (unXRec -> VarP n)
+pattern LitP'' l    <- (unXRec -> LitP l)
+pattern ConP'' c as <- (unXRec -> ConP c as)
+
 deriving instance (PhaseShow p) => Show (Pat p)
 
 type Pat' p = XRec p (Pat p)
@@ -284,6 +299,10 @@ makeLenses ''RlpModule
 
 --------------------------------------------------------------------------------
 
--- stripLocation :: (UnXRec p) => XRec p a -> f NoLocated
+data NoLocated
--- stripLocation p = undefined
+
+type instance XRec NoLocated a = Identity a
+
+stripLocation :: (UnXRec p) => XRec p a -> f NoLocated
+stripLocation p = undefined
 

src/Rlp/TH.hs

@@ -0,0 +1,6 @@
+module Rlp.TH
+    ( rlpProg
+    , rlpExpr
+    )
+    where
+

src/Rlp2Core.hs

@@ -7,17 +7,20 @@ import Control.Monad
 import Control.Monad.Writer.CPS
 import Control.Arrow
 import Control.Applicative
-import Lens.Micro
+import Control.Comonad
-import Lens.Micro.Internal
+-- import Lens.Micro
+-- import Lens.Micro.Internal
+import Control.Lens
 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 Data.Functor.Bind
 
 import Core.Syntax                      as Core
 import Rlp.Syntax                       as Rlp
-import Rlp.Parse.Types                  (RlpcPs)
+import Rlp.Parse.Types                  (RlpcPs, PsName)
 --------------------------------------------------------------------------------
 
 -- the rl' program is desugared by desugaring each declaration as a separate
@@ -38,7 +41,14 @@ declToCore (DataD'' n as ds) = fold . getZipList $
         -- arguments
         t' = foldl TyApp (TyCon n) (TyVar . dsNameToName <$> as)
 
-declToCore (FunD'' n as e wh) = mempty &
+declToCore fd@(FunD'' n as e wh) = undefined
+
+caseify :: IdP' RlpcPs -> RlpExpr' RlpcPs -> Pat' RlpcPs
+        -> (RlpExpr RlpcPs, Pat RlpcPs)
+caseify x e p = (e', p') where
+    p' = VarP (extract x)
+    e' = CaseE (VarE <$> x) [(alt, [])]
+    alt = AltA p e
 
 constructorToCore :: Type -> Tag -> ConAlt RlpcPs -> Program'
 constructorToCore t tag (ConAlt cn as) =