module CBN
(
    cbn
)
where

import Isomorphism
import MonadF
import Package
import Char
import Parsing

-- Figure 14: The call-by-name building block

data TermCBN u t = Var String | Lambda String u | App u u | OtherTCBN t

data ValueCBN u v = Fun (u -> u) | OtherVCBN v

instance PseudounitF TermCBN where
    pseudounit = OtherTCBN

instance (MonadF m) => PseudobindF m TermCBN where
    pseudobind (Var x      ) f = unit (Var x     )
    pseudobind (Lambda v x ) f = unit (Lambda v x)
    pseudobind (App x y    ) f = unit (App x y   )
    pseudobind (OtherTCBN x) f = f x

instance Wrap (TermCBN u t) t where
    wiso (OtherTCBN x) = x
    wosi               = pseudounit

instance PseudounitF ValueCBN where
    pseudounit = OtherVCBN

instance (MonadF m) => PseudobindF m ValueCBN where
    pseudobind (Fun x      ) f = unit (Fun x)
    pseudobind (OtherVCBN x) f = f x

instance Wrap (ValueCBN u v) v where
    wiso (OtherVCBN x) = x
    wosi               = pseudounit

cbn :: (MonadF mt, MonadF mv)
        => Prepackage t v
                      (Amp mt TermCBN ut t) (Amp mv ValueCBN uv v)
                      uv ut uv
        -> Prepackage (TermCBN ut t) (ValueCBN uv v)
                      (mt ut (TermCBN ut t)) (mv uv (ValueCBN uv v))
                      uv ut uv

cbn 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   = parseCBN
                                 , interpr  = interpCBN
                                 , showvalr = showvalCBN
                                 , makefunr = makefunCBN
                                 , applyr   = applyCBN
                                 , namer    = nameCBN }
      where
        oldpkg = old_finalize realTop
        top = lowerTop my_isom_t'' my_isom_v'' realTop
        viso = iso my_isom_v''
        vosi = osi my_isom_v''

        parseCBN s = (pvar s ++ plambda s ++ papp s ++ parser oldpkg s) where
            pvar s = [(unit (Var v), s1) | (v, s1) <- parseVar s]
            plambda s = [(unit (Lambda v x), s4)
                        | ('\\':s1) <- [dropWhile isSpace s],
                          (v, s2) <- parseVar s1,
                          ('.':s3) <- [dropWhile isSpace s2],
                          (x, s4) <- parser realTop s3]
            papp s = [(unit (App x y), s5)
                     | ('(':s1) <- [dropWhile isSpace s],
                       (x, (c:s2)) <- parser realTop s1,
                       isSpace c,
                       s3 <- [dropWhile isSpace s2],
                       (y, s4) <- parser realTop s3,
                       (')':s5) <- [dropWhile isSpace s4]]

        interpCBN (Var v) env = maybe err vosi (lookup v env)
            where err = complainr top ("unbound variable: " ++ v)
        interpCBN (Lambda v x) env = unit (Fun fun)
            where fun z = interpr realTop x ((v,z):env)
        interpCBN (App x y) env = vosi (interpr realTop x env) <<>> (\u ->
                                  applyr top (unit u) (interpr realTop y env))
        interpCBN x env = interpr oldpkg x env

        applyCBN (Fun f) x = vosi (f x)
        applyCBN u       _ = complainr top ("should be function: " ++
                                             showvalr top (unit u))

        showvalCBN (Fun x) = "<function>"
        showvalCBN x = showvalr oldpkg x

        makefunCBN f = viso (unit (Fun (viso . f . vosi)))

        nameCBN = "call-by-name " ++ namer oldpkg