172 lines
5.3 KiB
Haskell
172 lines
5.3 KiB
Haskell
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE DeriveTraversable #-}
|
|
module Rlp2Core
|
|
( desugarRlpProgR
|
|
, desugarRlpProg
|
|
, desugarRlpExpr
|
|
)
|
|
where
|
|
--------------------------------------------------------------------------------
|
|
import Control.Monad
|
|
import Control.Monad.Writer.CPS
|
|
import Control.Monad.Utils
|
|
import Control.Arrow
|
|
import Control.Applicative
|
|
import Control.Lens hiding ((:<))
|
|
import Compiler.RLPC
|
|
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.Maybe (fromJust, fromMaybe)
|
|
import Data.Function (on)
|
|
import GHC.Stack
|
|
import Debug.Trace
|
|
import Numeric
|
|
import Misc.MonadicRecursionSchemes
|
|
|
|
import Data.Fix hiding (cata, para, cataM)
|
|
import Data.Functor.Bind
|
|
import Data.Functor.Foldable
|
|
import Control.Comonad
|
|
import Control.Comonad.Cofree
|
|
|
|
import Effectful.State.Static.Local
|
|
import Effectful.Labeled
|
|
import Effectful
|
|
import Text.Show.Deriving
|
|
|
|
import Core.Syntax as Core
|
|
import Rlp.AltSyntax as Rlp
|
|
import Compiler.Types
|
|
import Data.Pretty
|
|
--------------------------------------------------------------------------------
|
|
|
|
type Tree a = Either Name (Name, Branch a)
|
|
|
|
-- | Rose tree branch representing "nested" "patterns" in the Core language. That
|
|
-- is, a constructor with children that are either a normal binder (Left (Given)
|
|
-- name) or an indirection to another pattern (Right (Generated name) (Pattern))
|
|
|
|
data Branch a = Branch Name [Tree a]
|
|
deriving (Show, Functor, Foldable, Traversable)
|
|
|
|
-- | The actual rose tree.
|
|
-- @type Rose = 'Data.Fix.Fix' 'Branch'@
|
|
|
|
type Rose = Fix Branch
|
|
|
|
deriveShow1 ''Branch
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- desugarRlpProgR :: forall m a. (Monad m)
|
|
-- => Rlp.Program PsName (TypedRlpExpr PsName)
|
|
-- -> RLPCT m (Core.Program Var)
|
|
-- desugarRlpProgR p = do
|
|
-- let p' = desugarRlpProg p
|
|
-- addDebugMsg "dump-desugared" $ show (out p')
|
|
-- pure p'
|
|
|
|
desugarRlpProgR = undefined
|
|
|
|
desugarRlpProg :: Rlp.Program PsName (TypedRlpExpr PsName) -> Core.Program Var
|
|
desugarRlpProg = rlpProgToCore
|
|
|
|
desugarRlpExpr = undefined
|
|
|
|
type NameSupply = Labeled "NameSupply" (State [Name])
|
|
|
|
runNameSupply :: Text -> Eff (NameSupply ': es) a -> Eff es a
|
|
runNameSupply pre = runLabeled $ evalState [ pre <> "_" <> tshow name | name <- [0..] ]
|
|
where tshow = T.pack . show
|
|
|
|
single :: (Monoid s, Applicative f) => ASetter s t a (f b) -> b -> t
|
|
single l a = mempty & l .~ pure a
|
|
|
|
-- the rl' program is desugared by desugaring each declaration as a separate
|
|
-- program, and taking the monoidal product of the lot :3
|
|
|
|
rlpProgToCore :: Rlp.Program PsName (TypedRlpExpr PsName) -> Core.Program Var
|
|
rlpProgToCore = foldMapOf (programDecls . each) declToCore
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
declToCore :: Rlp.Decl PsName TypedRlpExpr' -> Core.Program Var
|
|
|
|
-- assume full eta-expansion for now
|
|
declToCore (FunD b [] e) = single programScDefs $
|
|
ScDef b' [] e'
|
|
where
|
|
b' = MkVar b (typeToCore $ extract e)
|
|
e' = runPureEff . runNameSupply b . cataM exprToCore . retype $ e
|
|
|
|
dummyExpr :: Text -> Core.Expr b
|
|
dummyExpr a = Var ("<" <> a <> ">")
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- | convert rl' types to Core types, annotate binders, and strip excess type
|
|
-- info.
|
|
retype :: Cofree RlpExprF' (Rlp.Type PsName) -> RlpExpr Var
|
|
retype = (_extract %~ unquantify) >>> fmap typeToCore >>> cata \case
|
|
t :<$ InL (LamF bs e)
|
|
-> Finl (LamF bs' e)
|
|
where
|
|
bs' = zipWith MkVar bs (t ^.. arrowStops)
|
|
|
|
t :<$ InL (VarF n)
|
|
-> Finl (VarF n)
|
|
|
|
t :<$ InR (LetEF r bs e)
|
|
-> Finr (LetEF r _ _)
|
|
|
|
unquantify :: Rlp.Type b
|
|
-> Rlp.Type b
|
|
unquantify (ForallT _ x) = unquantify x
|
|
unquantify x = x
|
|
|
|
typeToCore :: Rlp.Type PsName -> Core.Type
|
|
typeToCore = cata \case
|
|
VarTF n -> TyVar n
|
|
ConTF n -> TyCon n
|
|
FunTF -> TyFun
|
|
AppTF f x -> TyApp f x
|
|
-- TODO: we assume all quantified tyvars are of kind Type
|
|
ForallTF x m -> TyForall (MkVar x TyKindType) m
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
exprToCore :: (NameSupply :> es)
|
|
=> RlpExprF Var (Core.Expr Var)
|
|
-> Eff es (Core.Expr Var)
|
|
|
|
exprToCore (InL e) = pure . embed $ e
|
|
exprToCore (InR _) = _
|
|
|
|
exprToCore _ = pure $ dummyExpr "expr"
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
annotateVar :: Core.Type -> Core.ExprF PsName a -> Core.ExprF Var a
|
|
|
|
-- fixed points:
|
|
annotateVar _ (VarF n) = VarF n
|
|
annotateVar _ (ConF t a) = ConF t a
|
|
annotateVar _ (AppF f x) = AppF f x
|
|
annotateVar _ (LitF l) = LitF l
|
|
annotateVar _ (TypeF t) = TypeF t
|
|
|
|
rlpExprToCore :: (NameSupply :> es)
|
|
=> Rlp.ExprF PsName Core.Expr' -> Eff es Core.Expr'
|
|
|
|
-- assume all binders are simple variable patterns for now
|
|
rlpExprToCore (LetEF r bs e) = pure $ Let r bs' e
|
|
where
|
|
bs' = b2b <$> bs
|
|
b2b (VarB (VarP k) v) = Binding k v
|
|
|