CPS.hs

{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}


module CPS where

import qualified TTF as Sym

-- * Extending Symantics:
-- * Parameterizing the arrows by the interpreter

-- *  CBAny.hs: type Arr exp a b = exp a -> exp b
-- That is different from the R interpreter we did earlier.
-- Evaluating an object term rep (Arr a b) in CBAny
-- would give us a function, but not of the type a -> b.
-- In the case of R, it would be R a -> R b.
-- It didn't matter for CBAny: We can't observe functional 
-- values anyway. In contrast, the term (repr Int) was interpreted 
-- in CBAny as Haskell Int, which we can observe. 
-- Thus, CBAny is suitable for encoding ``the whole code'' (a typical program),
-- whose result is something we can observe (but not apply).

-- Can we be flexible and permit interpretations of
-- repr (a->b) as truly Haskell functions a->b?
-- We need to make the interpretations of arrows dependent
-- on a particular interpreter.

-- * Emulating ML modules in Haskell
-- Making arrows dependent on the interpreter looks better in OCaml: 
-- we write a signature that contains the type ('a,'b) arrow.
-- Different structures implementing the signature will specify
-- the concrete type for ('a,'b) arrow.
-- To emulate this facility -- structures (modules) containing not 
-- only values but also types -- we need type functions.
-- We can use multi-parameter type classes with functional dependencies.
-- It seems more elegant here to use type families.

-- * //
-- * How to interpret arrows and other types
type family Arr (repr :: * -> *) (a :: *) (b :: *) :: *

class ESymantics repr where
    int :: Int  -> repr Int
    add :: repr Int  -> repr Int -> repr Int

    lam :: (repr a -> repr b) -> repr (Arr repr a b)
    app :: repr (Arr repr a b) -> repr a -> repr b

-- * Like Symantics in CBAny.hs
-- The class declaration looks exactly like that in CBAny.hs.
-- However, there Arr was a type synonym. Here it is a type
-- function, indexed by repr.

-- * //
-- * All old Symantics terms can be re-interpreted in the
-- * extended Symantics
-- That is, we do not have to re-write the terms written
-- using the methods of the old Symantics (e.g., the terms
-- Sym.th1, Sym.th2, etc.) We merely have to re-interpret them,

-- generalizing the arrow
type family GenArr repr a :: *
type instance GenArr repr Int    = Int
type instance GenArr repr (a->b) = 
    Arr repr (GenArr repr a) (GenArr repr b)

newtype ExtSym repr a = ExtSym{unExtSym:: repr (GenArr repr a)}

-- The re-interpretation, essentially the identity
instance ESymantics repr => Sym.Symantics (ExtSym repr) where
    int       = ExtSym . int
    add e1 e2 = ExtSym $ add (unExtSym e1) (unExtSym e2)

    lam e     = ExtSym $ lam (unExtSym . e . ExtSym)
    app e1 e2 = ExtSym $ app (unExtSym e1) (unExtSym e2)


-- Sample terms

te1 = unExtSym Sym.th1 -- re-interpreting the old Symantics term th1
-- te1 = add (int 1) (int 2)
-- te1 :: (ESymantics repr) => repr Int

te2 = unExtSym Sym.th2
-- te2 = lam (\x -> add x x)
-- te2 :: (ESymantics repr) => repr (Arr repr Int Int)

-- We don't have to re-write th3 as te3; we merely re-interpret it
te3 = unExtSym Sym.th3
-- te3 = lam (\x -> (app x (int 1)) `add` (int 2))
-- te3 :: (ESymantics repr) => repr (Arr repr (Arr repr Int Int) Int)

te4 = let c3 = lam (\f -> lam (\x -> f `app` (f `app` (f `app` x))))
      in (c3 `app` (lam (\x -> x `add` int 14))) `app` (int 0)

-- The inferred type is interesting
-- te4
--   :: (Arr repr (Arr repr Int Int) (Arr repr Int Int)
--         ~
--       Arr repr (Arr repr Int Int) (Arr repr Int b),
--       ESymantics repr) =>
--      repr b
-- Because Arr is a type family, and type families are not
-- injective

-- * //
-- * The converse: ESymantics => Symantics
-- All extended symantics terms can be interpreted using
-- any old, legacy, Symantics interpeter
-- * Inject _all_ old interpreters into the new one
newtype Lg repr a = Lg{unLg :: repr a}

type instance Arr (Lg repr) a b = a -> b

instance Sym.Symantics repr => ESymantics (Lg repr) where
    int       = Lg . Sym.int
    add e1 e2 = Lg $ Sym.add (unLg e1) (unLg e2)
    lam e     = Lg $ Sym.lam (unLg . e . Lg)
    app e1 e2 = Lg $ Sym.app (unLg e1) (unLg e2)

legacy :: Sym.Symantics repr => (repr a -> b) -> Lg repr a -> b
legacy int e = int (unLg e)

-- * //
-- * We can use all existing interpreters _as they are_

te3_eval = legacy Sym.eval te3
-- te3_eval :: Arr (Lg Sym.R) (Arr (Lg Sym.R) Int Int) Int

te3_eval' = te3_eval id
-- 3

te3_view = legacy Sym.view te3
-- "(\\x0 -> ((x0 1)+2))"

te4_eval = legacy Sym.eval te4
-- 42

te4_view = legacy Sym.view te4
-- "(((\\x0 -> (\\x1 -> (x0 (x0 (x0 x1))))) (\\x0 -> (x0+14))) 0)"

-- We haven't gained anything though. Now we will

-- * //
-- * CBV CPS transform
-- *  CPS[ value ] = \k -> k $ CPSV[ value ]
-- *  CPS[ e1 e2 ] =
-- *   \k ->
-- *     CPS[ e1 ] (\v1 ->
-- *       CPS[ e2 ] (\v2 ->
-- *         v1 v2 k))
-- * (similar for addition)
-- *
-- *  CPSV[ basec ] = basec
-- *  CPSV[ x ]     = x
-- *  CPSV[ \x.e ]  = \x -> CPS[ e ]
-- We chose left-to-right evaluation order
-- * Danvy: CPS is *the* canonical transform
-- * CPS on types is NOT the identity
-- Why? Try to work out the types first

-- * //
newtype CPS repr w a = 
   CPS{cpsr :: repr (Arr repr (Arr repr a w) w)}
-- Here, w is the answer-type
-- We observe the similarity with the double negation
-- CPS is the transform: we use the arrows of the base interpreter

type instance Arr (CPS repr w) a b = 
   Arr repr a (Arr repr (Arr repr b w) w)

-- Auxiliary functions
-- Using (Arr repr a b) instead of (a->b) hinders the type
-- inference since type functions are not in general injective.
-- We need the following functions to constrain the types
-- so that the inference will work.
-- I wish there were a way to declare a type family injective!
cpsk :: ESymantics repr => (repr (Arr repr a w) -> repr w) -> CPS repr w a
cpsk = CPS . lam

appk :: ESymantics repr =>
	CPS repr w a -> (repr a -> repr w) -> repr w
appk (CPS e) f = app e $ lam f

-- * CPS of a value
cpsv :: ESymantics repr => repr a -> CPS repr w a
cpsv v = cpsk $ \k -> app k v

instance ESymantics repr => ESymantics (CPS repr w) where
    int x = cpsv $ int x
    add e1 e2 = cpsk $ \k ->
 		  appk e1 $ \v1 ->
 		  appk e2 $ \v2 ->
 		     app k (add v1 v2)
    lam e = cpsv $ lam (\x -> cpsr $ e (cpsv x))
    app ef ea = cpsk $ \k ->
 		  appk ef $ \vf ->
 		  appk ea $ \va ->
 		     app (app vf va) k


-- * //
-- * Applying the transform, evaluate afterwards

tec1 = cpsr te1
-- tec1 :: (ESymantics repr) => repr (Arr repr (Arr repr Int w) w)

-- We need to pass the identity continuation
tec1_eval = legacy Sym.eval tec1 id
-- 3

-- * The case of administrative redices
tec1_view = legacy Sym.view tec1
-- "(\\x0 -> ((\\x1 -> (x1 1)) 
--    (\\x1 -> ((\\x2 -> (x2 2)) (\\x2 -> (x0 (x1+x2)))))))"

-- The result is a bit of a mess: lots of administrative redices

tec2 = cpsr te2
tec2_eval = legacy Sym.eval tec2

-- The interpretation of a function is not usable, because of w...
-- Here we really need the answer-type polymorphism
-- OTH, like in CBAny.hs, the transform of a generally 'effectful'
-- function can be used in a `pure' code.
-- We can get a pure function out of tec2_eval; but
-- we have to do differently (from passing an identity continuation)
tec2_eval' = \a -> tec2_eval (\k -> k a id)
-- tec2_eval' :: Int -> Int

tec2_eval'' = tec2_eval' 21
-- 42

tec2_view = legacy Sym.view tec2
-- even bigger mess

tec4 = cpsr te4
tec4_eval = legacy Sym.eval tec4 id
-- 42

tec4_view = legacy Sym.view tec4
-- view is a mess... makes a good wall-paper pattern though...

-- * //
-- * Composing interpreters: doing CPS twice
-- We have already seen how to chain tagless final interpreters.
-- We push this further: we do CPS twice

tecc1 = cpsr tec1
-- The type makes it clear we did CPS twice

-- To evaluate the doubly-CPSed term, we have to do
-- more than just apply the identity continuation
-- flip($) is \v\k -> k v, which is sort of cpsv
tecc1_eval = legacy Sym.eval tecc1
tecc1_eval' = tecc1_eval (\k -> k (flip ($)) id)
-- 3

tecc1_view = legacy Sym.view tecc1
-- very big mess


-- * //
-- * One-pass CPS transform
-- Taking advantage of the metalanguage to get rid of the
-- administrative redices

newtype CPS1 repr w a = 
   CPS1{cps1r :: (repr a -> repr w) -> repr w}

reflect :: ESymantics repr =>
	   ((repr a -> repr w) -> repr w) ->
	   repr (Arr repr (Arr repr a w) w)
reflect e = lam (\k -> e (\v -> app k v))
-- * reflect e = lam (e . app)

-- The same as in CPS
-- After all, CPS1 is an optimization of CPS
type instance Arr (CPS1 repr w) a b = 
   Arr repr a (Arr repr (Arr repr b w) w)

-- * CPS1 of a value
cps1v :: ESymantics repr => repr a -> CPS1 repr w a
cps1v v = CPS1 $ \k -> k v

instance ESymantics repr => ESymantics (CPS1 repr w) where
    int x = cps1v $ int x
    add e1 e2 = CPS1 $ \k ->
 		  cps1r e1 $ \v1 ->
 		  cps1r e2 $ \v2 ->
 		     k (add v1 v2)

    lam e = cps1v $ lam $ reflect . cps1r . e . cps1v

    app ef ea = CPS1 $ \k ->
 		  cps1r ef $ \vf ->
 		  cps1r ea $ \va ->
 		     app (app vf va) (lam k)

cps1 = reflect . cps1r

-- * //
-- * Applying the transform, evaluate afterwards

tek1 = cps1 te1
-- tek1 :: (ESymantics repr) => repr (Arr repr (Arr repr Int w) w)

-- We need to pass the identity continuation
tek1_eval = legacy Sym.eval tek1 id
-- 3

-- * The result is indeed much nicer
-- Administrative redices are gone, serious operations
-- (like addition) remain
tek1_view = legacy Sym.view tek1
-- "(\\x0 -> (x0 (1+2)))"

tek2 = cps1 te2
tek2_eval = legacy Sym.eval tek2
tek2_eval'' = tek2_eval (\k -> k 21 id)
-- 42

-- Again, only serious redices remain
tek2_view = legacy Sym.view tek2
-- "(\\x0 -> (x0 (\\x1 -> (\\x2 -> (x2 (x1+x1))))))"


tek4 = cps1 te4
tek4_eval = legacy Sym.eval tek4 id
-- 42

tek4_view = legacy Sym.view tek4
-- The result is large, but comprehensible...
-- "(\\x0 -> 
--   (((\\x1 -> (\\x2 -> (x2 (\\x3 -> (\\x4 -> ((x1 x3) (\\x5 -> ((x1 x5) 
--                         (\\x6 -> ((x1 x6) (\\x7 -> (x4 x7)))))))))))) 
--     (\\x1 -> (\\x2 -> (x2 (x1+14))))) 
--   (\\x1 -> ((x1 0) (\\x2 -> (x0 x2))))))"

-- * //
-- * Composing interpreters: doing CPS twice
-- We have already seen how to chain tagless final interpreters.
-- We push this further: we do CPS twice

tekk1 = cps1 tek1
-- The type makes it clear we did CPS twice

tekk1_eval = legacy Sym.eval tekk1

-- tekk1_eval ::
--   (((Int -> (w1 ->w) -> w) -> (w1->w) -> w) -> w) -> w
tekk1_eval' = tekk1_eval (\k -> k (flip ($)) id)
-- 3

tekk1_view = legacy Sym.view tekk1
-- "(\\x0 -> (x0 (\\x1 -> (\\x2 -> ((x1 (1+2)) (\\x3 -> (x2 x3)))))))"
-- Can be eta-reduced
-- "(\\x0 -> (x0 (\\x1 -> (\\x2 -> ((x1 (1+2)) x2)))))"
-- "(\\x0 -> (x0 (\\x1 -> (x1 (1+2)) )))"

-- * Lessons
-- * The output of CPS is assuredly typed
-- * The conversion is patently total
-- * Composable transformers in the tagless final style



main = do
       print te3_eval'
       print te3_view
       print te4_eval
       print te4_view

       print tec1_eval
       print tec1_view
       print tec2_eval''
       print tec2_view
       print tec4_eval
       print tec4_view

       print tecc1_view
       print tecc1_eval'

       print tek1_eval
       print tek1_view
       print tek2_eval''
       print tek2_view
       print tek4_eval
       print tek4_view

       print tekk1_eval'
       print tekk1_view