module Errors
(
    errors
)
where

import Isomorphism
import MonadF
import Package

-- Figure 17: The errors building block

newtype TermE u t = Correct t

data ValueE u v = Err String | OtherVE v

instance PseudounitF TermE where
    pseudounit = Correct

instance (MonadF m) => PseudobindF m TermE where
    pseudobind (Correct x) f = f x

instance Wrap (TermE u t) t where
    wiso (Correct x) = x
    wosi             = Correct

instance PseudounitF ValueE where
    pseudounit = OtherVE

instance (MonadF m) => PseudobindF m ValueE where
    pseudobind (Err x)     f = unit (Err x)
    pseudobind (OtherVE x) f = f x

instance Wrap (ValueE u v) v where
    wiso (OtherVE x) = x
    wosi             = pseudounit

errors :: (MonadF mt, MonadF mv)
        => Prepackage t v
                      (Amp mt TermE ut t) (Amp mv ValueE uv v)
                      ve ut uv
        -> Prepackage (TermE ut t) (ValueE uv v)
                      (mt ut (TermE ut t)) (mv uv (ValueE uv v))
                      ve ut uv

errors 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 { showvalr  = showvalE
                                 , complainr = complainE
                                 , namer     = nameE }
      where
        oldpkg = old_finalize realTop
        top = lowerTop my_isom_t'' my_isom_v'' realTop
        vosi = osi my_isom_v''

        complainE s = unit (Err s)

        showvalE (Err x) = "Error: " ++ x
        showvalE x = showvalr oldpkg x

        nameE = "errors " ++ namer oldpkg