{-# 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 ktail . (:[])
  pure [cps|(λ (##{bs} #{ktail}) #{m'})|]

convertProgram :: forall es. (GenSym :> es) => Scm.Program -> Eff es Program
convertProgram p =
  MkProgram <$> telescope (convert @es) (p ^.. each . _Left) (pure . Halt)

convertExp :: forall es. (GenSym :> es) => Scm.Exp -> Eff es Exp
convertExp e = convert e (pure . Halt1)