120 lines
3.2 KiB
Haskell
120 lines
3.2 KiB
Haskell
{-# LANGUAGE OverloadedLists #-}
|
|
{- HLINT ignore "Use camelCase" -}
|
|
module Gyehoek.CPS.Convert
|
|
( convertProgram
|
|
, convertExp
|
|
) where
|
|
|
|
import Gyehoek.CPS.Syntax
|
|
import Gyehoek.Scheme.Syntax qualified as Scm
|
|
import Gyehoek.GenSym
|
|
import Data.List.NonEmpty (NonEmpty((:|)))
|
|
import Control.Monad.Cont qualified as Cont
|
|
import qualified Data.List.NonEmpty as NE
|
|
import Gyehoek.Prelude
|
|
|
|
|
|
-- 뻘짓이어라
|
|
telescope
|
|
:: Traversable t
|
|
=> (a -> (b -> r) -> r)
|
|
-> t a -> (t b -> r) -> r
|
|
telescope f = Cont.runCont . traverse (Cont.cont . f)
|
|
|
|
|
|
|
|
-- | Transform an expression with a meta-continuation.
|
|
convert
|
|
:: forall es. (GenSym :> es)
|
|
=> Scm.Exp -> (Val -> Eff es Exp) -> Eff es Exp
|
|
|
|
convert (Scm.ExpVar x) k = k $ ValVar x
|
|
convert (Scm.ExpLit l) k = k . ValImm $ case l of
|
|
LitInt n -> ImmInt n
|
|
LitBool b -> ImmBool b
|
|
_ -> _
|
|
|
|
-- special case: call/cc is desugared during cps-conversion...
|
|
convert (Scm.ExpPrim (PrimCallCC withcc)) k = do
|
|
convert withcc \withcc' -> do
|
|
cc <- gensym' @Name "cc"
|
|
r <- gensym' "r"
|
|
m <- k $ ValVar r
|
|
ccish <- gensym' @Name "cc-ish"
|
|
x <- gensym' @Name "x"
|
|
pure [cps|
|
|
(letrec ((#{cc} (κ (#{r}) #{m})))
|
|
(letrec ((#{ccish} (λ (#{x} _) (continue #{cc} #{x}))))
|
|
(#{withcc'} #{ccish} #{cc})))
|
|
|]
|
|
|
|
-- ...while all other prims are left as-is for later stages to
|
|
-- handle..
|
|
convert (Scm.ExpPrim p) k =
|
|
telescope (convert @es) p \p' -> do
|
|
r <- gensym' "r"
|
|
ExpPrim p' . MkKappa [r] <$> k (ValVar r)
|
|
|
|
convert (Scm.ExpLambda xs e) k = do
|
|
f <- gensym' "lambda-body"
|
|
lam <- convertLambda xs e
|
|
ke <- k $ ValVar f
|
|
pure [cps|
|
|
(letrec ((#{f} #{lam}))
|
|
#{ke})
|
|
|]
|
|
|
|
convert (Scm.ExpApply f xs) k =
|
|
telescope (convert @es) (f:|xs) \(f':|xs') -> do
|
|
r <- gensym' "r"
|
|
x <- gensym' "x"
|
|
m <- k (ValVar x)
|
|
pure $ ExpLetRec [(r, AbsKappa' [x] m)] $ ExpApply f' xs' r
|
|
|
|
convert (Scm.ExpBegin xs) k = _
|
|
|
|
convert (Scm.ExpIf c t f) k =
|
|
convert c \c' ->
|
|
ExpIf c' <$> convert t k <*> convert f k
|
|
|
|
-- let-bindings are desugared into continuation calls whose parameters
|
|
-- are the left-hand sides and whose arguments are the right-hand
|
|
-- sides.
|
|
convert (Scm.ExpLet bs e) k =
|
|
let rhss = bs ^.. each . _2
|
|
in telescope (convert @es) rhss \rhss' -> do
|
|
e' <- convert e k
|
|
kbody <- gensym' @Name "let-body"
|
|
let bs' = bs ^.. each . _1
|
|
pure [cps|
|
|
(letrec ((#{kbody} (κ #{bs'} #{e'})))
|
|
(continue #{kbody} ##{rhss'}))
|
|
|]
|
|
|
|
convert (Scm.ExpLetRec bs m) k = do
|
|
let bs' = bs & each . _2 %~ (^?! #ExpLambda)
|
|
let conv = traverseOf _2 (uncurry $ convertLambda @es)
|
|
bs'' <- traverse conv bs'
|
|
m' <- convert m k
|
|
pure [cps|
|
|
(letrec #{bs''} #{m'})
|
|
|]
|
|
|
|
convertLambda
|
|
:: GenSym :> es
|
|
=> List Name -> Scm.Exp -> Eff es Lambda
|
|
convertLambda bs m = do
|
|
ktail <- gensym' "lambda-tail"
|
|
m' <- convert m $ pure . ExpContinue (ValVar ktail) . (:[])
|
|
pure [cps|(λ (##{bs} #{ktail}) #{m'})|]
|
|
|
|
convertProgram :: forall es. (GenSym :> es) => Scm.Program -> Eff es Program
|
|
convertProgram p = do
|
|
ktail <- gensym' "start-ktail"
|
|
m <- telescope (convert @es) (p ^.. each . _Left)
|
|
(pure . ExpContinue (ValVar ktail))
|
|
pure . MkProgram $ MkLambda [] ktail m
|
|
|
|
convertExp :: forall es. (GenSym :> es) => Scm.Exp -> Eff es Exp
|
|
convertExp e = convert e (pure . Halt1)
|