module Numbers
(
    numbers
)
where

import Isomorphism
import MonadF
import Package
import Char

-- Figure 8: The numbers building block

data TermN u t = Con Int | Add u u | OtherTN t

data ValueN u v = Num Int | OtherVN v

instance PseudounitF TermN where
    pseudounit = OtherTN

instance (MonadF m) => PseudobindF m TermN where
    pseudobind (Con x    ) f = unit (Con x  )
    pseudobind (Add x y  ) f = unit (Add x y)
    pseudobind (OtherTN x) f = f x

instance Wrap (TermN u t) t where
    wiso (OtherTN x) = x
    wosi             = pseudounit

instance PseudounitF ValueN where
    pseudounit = OtherVN

instance (MonadF m) => PseudobindF m ValueN where
    pseudobind (Num x)     f = unit (Num x)
    pseudobind (OtherVN x) f = f x

instance Wrap (ValueN u v) v where
    wiso (OtherVN x) = x
    wosi             = pseudounit

numbers :: (MonadF mt, MonadF mv)
        => Prepackage t v
                      (Amp mt TermN ut t) (Amp mv ValueN uv v)
                      ve ut uv
        -> Prepackage (TermN ut t) (ValueN uv v)
                      (mt ut (TermN ut t)) (mv uv (ValueN uv v))
                      ve ut uv

numbers 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   = parseN
                                 , interpr  = interpN
                                 , showvalr = showvalN
                                 , makenumr = makenumN
                                 , namer    = nameN }
      where
        oldpkg = old_finalize realTop
        top = lowerTop my_isom_t'' my_isom_v'' realTop
        vosi = osi my_isom_v''

        parseN s = (pcon s ++ psum s ++ parser oldpkg s) where
            psum s = [(unit (Add x y), s5) | ('(':s1) <- [dropWhile isSpace s],
                                             (x, s2) <- parser realTop s1,
                                             ('+':s3) <- [dropWhile isSpace s2],
                                             (y, s4) <- parser realTop s3,
                                             (')':s5) <- [dropWhile isSpace s4]]
            pcon (c:s) | isDigit c = pcon' s (digitToInt c) where
                pcon' (c:s) n | isDigit c = pcon' s (10 * n + digitToInt c)
                pcon' s n = [(unit (Con n), s)]
            pcon _ = []

        interpN (Con x) _ = unit (Num x)
        interpN (Add x y) env = vosi (interpr realTop x env) <<>> (\u ->
                                vosi (interpr realTop y env) <<>> (\v ->
                                case (u, v) of
                                    (Num j, Num k) -> unit (Num (j+k))
                                    _ -> complainr top ("should be numbers: " ++
                                         showvalr top (unit u) ++ ", " ++
                                         showvalr top (unit v))))
        interpN x env = interpr oldpkg x env

        showvalN (Num x) = show x
        showvalN x = showvalr oldpkg x

        makenumN x = unit (Num x)

        nameN = "numbers " ++ namer oldpkg