module CBV
(
    cbv
)
where

import Isomorphism
import MonadF
import Package
import Char
import Parsing

-- Figure 12: The call-by-value building block

data TermCBV u t = Var String | Lambda String u | App u u | OtherTCBV t

data ValueCBV u v = Fun (ValueCBV u v -> u) | OtherVCBV v

instance PseudounitF TermCBV where
    pseudounit = OtherTCBV

instance (MonadF m) => PseudobindF m TermCBV 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 (OtherTCBV x) f = f x

instance Wrap (TermCBV u t) t where
    wiso (OtherTCBV x) = x
    wosi               = pseudounit

instance PseudounitF ValueCBV where
    pseudounit = OtherVCBV

instance (MonadF m) => PseudobindF m ValueCBV where
    pseudobind (Fun x      ) f = unit (Fun x)
    pseudobind (OtherVCBV x) f = f x

instance Wrap (ValueCBV u v) v where
    wiso (OtherVCBV x) = x
    wosi               = pseudounit

cbv :: (MonadF mt, MonadF mv)
        => Prepackage t v
                      (Amp mt TermCBV ut t) (Amp mv ValueCBV uv v)
                      (ValueCBV uv v) ut uv
        -> Prepackage (TermCBV ut t) (ValueCBV uv v)
                      (mt ut (TermCBV ut t)) (mv uv (ValueCBV uv v))
                      (ValueCBV uv v) ut uv

cbv 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   = parseCBV
                                 , interpr  = interpCBV
                                 , showvalr = showvalCBV
                                 , makefunr = makefunCBV
                                 , applyr   = applyCBV
                                 , namer    = nameCBV }
      where
        oldpkg = old_finalize realTop
        top = lowerTop my_isom_t'' my_isom_v'' realTop
        viso = iso my_isom_v''
        vosi = osi my_isom_v''

        parseCBV 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]]

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

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

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

        makefunCBV f = Fun (viso . f . unit)

        nameCBV = "call-by-value " ++ namer oldpkg