Rlp2Core: simple let binds

src/Compiler/Types.hs

@@ -4,6 +4,7 @@ module Compiler.Types
     , srcspanLine, srcspanColumn, srcspanAbs, srcspanLen
     , Located(..)
     , _Located
+    , located
     , nolo
     , (<<~), (<~>), (<#>)
 
@@ -25,6 +26,9 @@ import Language.Haskell.TH.Syntax   (Lift)
 data Located a = Located SrcSpan a
     deriving (Show, Lift, Functor)
 
+located :: Lens (Located a) (Located b) a b
+located = lens extract ($>)
+
 instance Apply Located where
     liftF2 f (Located sa p) (Located sb q)
             = Located (sa <> sb) (p `f` q)

src/Core/Syntax.hs

@@ -270,14 +270,14 @@ instance (Pretty b) => Pretty (Expr b) where
     prettyPrec _ (Con t a)    = "Pack{" <> (ttext t <+> ttext a) <> "}"
     prettyPrec _ (Lam bs e)   = hsep ["λ", hsep (prettyPrec 1 <$> bs), "->", pretty e]
     prettyPrec _ (Let r bs e) = hsep [word, explicitLayout bs]
-                             $$ hsep ["in", pretty e]
+                            $+$ hsep ["in", pretty e]
         where word = if r == Rec then "letrec" else "let"
     prettyPrec p (App f x)    = maybeParens (p>0) $
         prettyPrec 0 f <+> prettyPrec 1 x
     prettyPrec _ (Lit l)      = pretty l
     prettyPrec p (Case e as)  = maybeParens (p>0) $
         "case" <+> pretty e <+> "of"
-        $$ nest 2 (explicitLayout as)
+        $+$ nest 2 (explicitLayout as)
 
 instance (Pretty b) => Pretty (Alter b) where
     pretty (Alter c as e) =

src/Rlp/Lex.x

@@ -85,7 +85,7 @@ $white_no_nl+       ;
 <0>
 {
     "let"               { constToken TokenLet `thenBeginPush` layout_let }
-    "letrec"            { constToken TokenLet `thenBeginPush` layout_let }
+    "letrec"            { constToken TokenLetrec `thenBeginPush` layout_let }
     "of"                { constToken TokenOf `thenBeginPush` layout_of }
 }
 

src/Rlp/Syntax.hs

@@ -18,6 +18,7 @@ module Rlp.Syntax
     , ConAlt(..)
     , Binding(..), Binding'
 
+    , _PatB, _FunB
     , _VarP, _LitP, _ConP
 
     -- * Trees That Grow boilerplate
@@ -41,6 +42,8 @@ module Rlp.Syntax
     , pattern ConT''
     -- *** Pat
     , pattern VarP'', pattern LitP'', pattern ConP''
+    -- *** Binding
+    , pattern PatB''
     )
     where
 ----------------------------------------------------------------------------------
@@ -253,6 +256,9 @@ data Binding p = PatB (Pat' p) (RlpExpr' p)
 
 type Binding' p = XRec p (Binding p)
 
+pattern PatB'' :: (UnXRec p) => Pat' p -> RlpExpr' p -> Binding' p
+pattern PatB'' p e <- (unXRec -> PatB p e)
+
 deriving instance (Show (XRec p (Pat p)), Show (XRec p (RlpExpr p)), Show (IdP p)
                   ) => Show (Binding p)
 
@@ -308,6 +314,7 @@ type Lit' p = XRec p (Lit p)
 
 makeLenses ''RlpModule
 makePrisms ''Pat
+makePrisms ''Binding
 
 --------------------------------------------------------------------------------
 

src/Rlp2Core.hs

@@ -17,11 +17,12 @@ import Control.Comonad
 -- import Lens.Micro.Internal
 import Control.Lens
 import Compiler.RLPC
-import Data.List                        (mapAccumL)
+import Data.List                        (mapAccumL, partition)
 import Data.Text                        (Text)
 import Data.Text                        qualified as T
 import Data.HashMap.Strict              qualified as H
 import Data.Monoid                      (Endo(..))
+import Data.Either                      (partitionEithers)
 import Data.Foldable
 import Data.Fix
 import Data.Maybe                       (fromJust, fromMaybe)
@@ -111,7 +112,7 @@ patArgsToCase e (x,p) = (e', x') where
 type NameSupply = Labeled NameSupplyLabel (State [IdP RlpcPs])
 type NameSupplyLabel = "expr-name-supply"
 
-exprToCore :: (NameSupply :> es) => RlpExpr RlpcPs -> Eff es Expr'
+exprToCore :: forall es. (NameSupply :> es) => RlpExpr RlpcPs -> Eff es Expr'
 
 exprToCore (VarE n) = pure $ Var (dsNameToName n)
 
@@ -125,11 +126,44 @@ exprToCore (CaseE (unXRec -> e) as) = do
     e' <- exprToCore e
     Case e' <$> caseAltToCore `traverse` as
 
+exprToCore (LetE bs e) = letToCore NonRec bs e
+exprToCore (LetrecE bs e) = letToCore Rec bs e
+
 exprToCore (LitE l) = litToCore l
 
+letToCore :: forall es. (NameSupply :> es)
+          => Rec -> [Rlp.Binding' RlpcPs] -> RlpExpr' RlpcPs -> Eff es Expr'
+letToCore r bs e = do
+    (bs',as) <- getParts
+    e' <- caseify as (unXRec e)
+    pure $ Let r bs' e'
+  where
+    -- partition & map the list of binders into:
+    --  bs'   : the let-binds that may be directly translated to Core
+    --          let-binds (we do exactly that). this is all the binders that
+    --          are a simple variable rather than a pattern match.
+    -- and as : the let-binds that may **not** be directly translated to
+    --          Core let-exprs. they get turned into case alternates.
+    getParts = traverse f bs <&> partitionEithers
+
+    f :: Rlp.Binding' RlpcPs
+      -> Eff es (Either Core.Binding' (Alt RlpcPs))
+    f (PatB'' (VarP'' n) e) = Left . (n :=) <$> exprToCore (unXRec e)
+    f (PatB'' p          e) = undefined
+
+    varPatB :: Traversal' (Rlp.Binding' RlpcPs) (IdP RlpcPs)
+    varPatB = located . _PatB . _1 . located . _VarP
+
 litToCore :: (NameSupply :> es) => Rlp.Lit RlpcPs -> Eff es Expr'
 litToCore (Rlp.IntL n) = pure . Lit $ Core.IntL n
 
+caseify :: (NameSupply :> es) => [Alt RlpcPs] -> RlpExpr RlpcPs -> Eff es Expr'
+caseify as ee = do
+    ee' <- exprToCore ee
+    foldrM go ee' as
+  where
+    go a e = Case e . pure <$> altToCore a
+
 -- TODO: where-binds
 caseAltToCore :: (NameSupply :> es)
               => (Alt RlpcPs, Where RlpcPs) -> Eff es Alter'
@@ -137,6 +171,12 @@ caseAltToCore (AltA (unXRec -> p) e, wh) = do
     e' <- exprToCore . unXRec $ e
     conToRose p <&> foldFix (branchToCore e')
 
+altToCore :: (NameSupply :> es)
+          => Alt RlpcPs -> Eff es Alter'
+altToCore (AltA (unXRec -> p) e) = do
+    e' <- exprToCore . unXRec $ e
+    conToRose p <&> foldFix (branchToCore e')
+
 conToRose :: forall es. (NameSupply :> es) => Pat RlpcPs -> Eff es Rose
 conToRose (ConP cn as) = Fix . Branch cn <$> patToForrest `traverse` as
     where