How to compile with continuations - Matt Might http://matt.might.net/articles/cps-conversion/

Main.purs

module Main where

import Prelude

import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Show (genericShow)
import Effect (Effect)
import Effect.Console as Console
import Effect.Ref (Ref)
import Effect.Ref as Ref
import Effect.Unsafe (unsafePerformEffect)
import Partial.Unsafe (unsafeCrashWith)

data LC
  = Var String
  | LCInt Int
  | Lam String LC
  | App LC LC
derive instance eqLC :: Eq LC
derive instance genericLC :: Generic LC _
instance showLC :: Show LC where
  show x = genericShow x

lcid :: LC
lcid = Lam "x" (Var "x")

data Atomic
  = AFun (Array String) Complex
  | AVar String
  | AInt Int
derive instance eqAtomic :: Eq Atomic
derive instance genericAtomic :: Generic Atomic _
instance showAtomic :: Show Atomic where
  show x = genericShow x

data Complex = CApp Atomic (Array Atomic)
derive instance eqComplex :: Eq Complex
derive instance genericComplex :: Generic Complex _
instance showComplex :: Show Complex where
  show x = genericShow x

gen :: Ref Int
gen = unsafePerformEffect (Ref.new 0)

reset_gen :: Effect Unit
reset_gen = Ref.write 0 gen

fresh :: String -> String
fresh lbl = unsafePerformEffect do
  last <- Ref.read gen
  Ref.write (last + 1) gen
  pure (lbl <> show last)

naive :: LC -> Complex
naive exp = t exp (AVar "Halt")
  where
    m :: LC -> Atomic
    m = case _ of
      Var x -> AVar x
      LCInt i -> AInt i
      Lam binder body ->
        let freshBinder = fresh binder in
        AFun [binder, freshBinder] (t body (AVar freshBinder))
      App _ _ ->
        unsafeCrashWith "m was fed with an App"

    t :: LC -> Atomic -> Complex
    t expr cont = case expr of
      App func arg ->
        let f = fresh "$f" in
        let e = fresh "$e" in
        t
          (Var f)
          (AFun [f] (t (Var e) (AFun [e] (CApp (AVar f) [ AVar e, cont ]))))
      _ -> CApp cont [ m expr ]

higher_order :: LC -> Complex
higher_order exp = t exp \ans -> CApp (AVar "Halt") [ans]
  where
    m :: LC -> Atomic
    m = case _ of
      Var x -> AVar x
      LCInt i -> AInt i
      Lam binder body ->
        let freshBinder = fresh binder in
        AFun
          [binder, freshBinder]
          (t body \rv -> CApp (AVar freshBinder) [ rv ])
      App _ _ ->
        unsafeCrashWith "m was fed with an App"

    t :: LC -> (Atomic -> Complex) -> Complex
    t expr k = case expr of
      App func arg ->
        let rv = fresh "$rv" in
        let cont = AFun [rv] (k (AVar rv)) in
        t func \f ->
          t arg \e ->
            CApp f [ e, cont ]
      _ ->
        k (m expr)

hybrid :: LC -> Complex
hybrid expr = tc expr (AVar "Halt")
  where
    tc :: LC -> Atomic -> Complex
    tc exp cont = case exp of
      App func arg ->
        tk func \f ->
          tk arg \e ->
           CApp f [ e, cont ]
      _ ->
        CApp cont [ m exp ]

    tk :: LC -> (Atomic -> Complex) -> Complex
    tk exp k = case exp of
      App func arg ->
        let rv = fresh "$rv" in
        let cont = AFun [rv] (k (AVar rv)) in
        tk func \f ->
          tk arg \e ->
            CApp f [ e, cont ]
      _ -> k (m exp)

    m :: LC -> Atomic
    m = case _ of
      Var x -> AVar x
      LCInt i -> AInt i
      Lam binder body ->
        let k = fresh "$k" in
        AFun [binder, k] (tc body (AVar k))
      App _ _ ->
        unsafeCrashWith "m was fed with an App"

main :: Effect Unit
main = do
  Console.log "Naive:"
  Console.logShow (naive (App (Var "g") (Var "a")))

  reset_gen

  Console.log "Higher-Order:"
  Console.logShow (higher_order (App (Var "g") (Var "a")))

  reset_gen

  Console.log "Hybrid:"
  Console.logShow (hybrid (App (Var "g") (Var "a")))

  reset_gen

  Console.log "ID:"
  Console.logShow (hybrid (App lcid (Var "a")))