module Cont
(
    continuation
)
where

import Isomorphism
import MonadF
import Package
import Char
import Parsing

-- Figure 15: The continuation building block

data TermC u t = Catch String u | OtherTC t

newtype ValueC u v = Cont ((v -> v) -> v)

ic :: Isomorphism ((v -> v) -> v) (IdMonadF u (ValueC u v))
ic = Isomorphism { iso = IdMonadF . Cont, osi = \(IdMonadF (Cont x)) -> x }

ac :: Isomorphism (IdMonadF u (ValueC u v)) (Amp IdMonadF ValueC u v)
ac = wisom

instance PseudounitF TermC where
    pseudounit = OtherTC

instance (MonadF m) => PseudobindF m TermC where
    pseudobind (Catch v x) f = unit (Catch v x)
    pseudobind (OtherTC x) f = f x

instance Wrap (TermC u t) t where
    wiso (OtherTC x) = x
    wosi             = pseudounit

instance PseudounitF ValueC where
    pseudounit x = Cont (\c -> c x)

instance PseudobindF IdMonadF ValueC where
    pseudobind (Cont x) f = iso ic (\cc -> x (\a -> osi ic (f a) cc))

instance Wrap (ValueC u v) v where
    wiso (Cont f) = f id
    wosi          = pseudounit

callcc :: ((v -> (IdMonadF u (ValueC u v)))
              -> (IdMonadF u (ValueC u v)))
              -> (IdMonadF u (ValueC u v))
callcc h = iso ic (\q -> osi ic (h (\b -> iso ic (\d -> q b))) q)

continuation :: (MonadF mt)
        => Prepackage t v
                      (Amp mt TermC ut t) (Amp IdMonadF ValueC uv v)
                      ve ut uv
        -> Prepackage (TermC ut t) (ValueC uv v)
                      (mt ut (TermC ut t)) (IdMonadF uv (ValueC uv v))
                      ve ut uv

continuation oldprepkg = Prepackage my_isom_t'' my_isom_v'' my_finalize
  where
    Prepackage my_isom_t'' my_isom_v'' old_finalize = wosi oldprepkg
    my_finalize realTop = oldpkg { parser   = parseC
                                 , interpr  = interpC
                                 , namer    = nameC }
      where
        oldpkg = old_finalize realTop
        top = lowerTop my_isom_t'' my_isom_v'' realTop
        viso = iso my_isom_v''
        vosi = osi my_isom_v''

        parseC s = (pcatch s ++ parser oldpkg s) where
            pcatch s = [(unit (Catch v x), s3)
                       | ('C':'a':'t':'c':'h':c1:s1) <- [dropWhile isSpace s],
                         isSpace c1,
                         (v, c2:s2) <- parseVar s1,
                         isSpace c2,
                         (x, s3) <- parser realTop s2]

        interpC (Catch v x) env =
            callcc (\k -> vosi $
                let k' z = osi ac (iso ac z <<>> iso ac . k)
                in interpr realTop x ((v, makefunr top k'):env))
        interpC x env = interpr oldpkg x env

        nameC = "continuation " ++ namer oldpkg