diff --git a/src/Compiler/Types.hs b/src/Compiler/Types.hs index 28e4ab4..607a0db 100644 --- a/src/Compiler/Types.hs +++ b/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) diff --git a/src/Core/Syntax.hs b/src/Core/Syntax.hs index ae16db0..c7bc9ee 100644 --- a/src/Core/Syntax.hs +++ b/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) = diff --git a/src/Rlp/Lex.x b/src/Rlp/Lex.x index 7b2e75b..d046499 100644 --- a/src/Rlp/Lex.x +++ b/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 } } diff --git a/src/Rlp/Syntax.hs b/src/Rlp/Syntax.hs index 6ef26fb..8b49edc 100644 --- a/src/Rlp/Syntax.hs +++ b/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 -------------------------------------------------------------------------------- diff --git a/src/Rlp2Core.hs b/src/Rlp2Core.hs index 887f40c..9740c10 100644 --- a/src/Rlp2Core.hs +++ b/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