76 lines
1.8 KiB
Haskell
76 lines
1.8 KiB
Haskell
{-# LANGUAGE OverloadedLists #-}
|
|
{- HLINT ignore "Use camelCase" -}
|
|
module Gyehoek.CPS.Convert
|
|
( convertProgram
|
|
) where
|
|
|
|
import Gyehoek.CPS.Syntax
|
|
import Gyehoek.Scheme.Syntax qualified as Scm
|
|
import Gyehoek.GenSym
|
|
import Data.List.NonEmpty (NonEmpty((:|)))
|
|
import Effectful
|
|
import Control.Monad.Cont qualified as Cont
|
|
import Control.Lens
|
|
import qualified Data.List.NonEmpty as NE
|
|
import qualified Gyehoek.Sexp
|
|
|
|
|
|
-- 뻘짓이어라
|
|
telescope
|
|
:: Traversable t
|
|
=> (a -> (b -> r) -> r)
|
|
-> t a -> (t b -> r) -> r
|
|
telescope f = Cont.runCont . traverse (Cont.cont . f)
|
|
|
|
|
|
|
|
pattern Atomic e <-
|
|
e@( Scm.ExpLambda _ _
|
|
; Scm.ExpVar _
|
|
; Scm.ExpLit _ )
|
|
|
|
-- | 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 $ ValLit l
|
|
|
|
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' "λ-body"
|
|
ktail <- gensym' "λ-tail"
|
|
m <- convert e $ \e' -> pure $ ExpContinue ktail [e']
|
|
ke <- k $ ValVar f
|
|
pure [cps|
|
|
(letrec ((#{f} (λ (##{xs} #{ktail}) #{m})))
|
|
#{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
|
|
|
|
convert _ k = _
|
|
|
|
convertProgram :: forall es. (GenSym :> es) => Scm.Program -> Eff es Program
|
|
convertProgram p =
|
|
MkProgram <$> telescope (convert @es) (p ^.. each . _Left) \exps ->
|
|
pure . Halt1 $ case NE.nonEmpty exps of
|
|
Nothing -> ValLit Void
|
|
Just es -> NE.last es
|