iteratee Strange behaviour eneeCheckIfDone

[Michael Baikov]

This is an implementation of typesafe iteratee exceptions. Some
functions are only implemented on the typelevel, some have complete
implementation.

Typelevel tags are applied to Iteratee data type which gets one extra
type parameter and a new name - IterateeE (just to show that this is a
new type). This makes more sense than tagging streams, because seeks
and other actions are performed by Iteratees and handled by
Enumeratees.

In this implementation each eneeCheckIfDoneHandle can handle only one
exception type - this is also makes sense - if your exceptions are
related then you should make them into one type, If they are separate
- maybe they should not be handled in single place.

Here i am reimplemented some stuff from Control.Exception module, but
in production code we should use code from Control.Exception.

{-# LANGUAGE ExistentialQuantification
    , EmptyDataDecls
    , FlexibleInstances
    , RankNTypes
    , TypeSynonymInstances
    , FlexibleContexts
    , DeriveDataTypeable
    , OverlappingInstances
    , MultiParamTypeClasses #-}
import Data.Typeable
import Data.NullPoint

type FileOffset = Int

-- My Iteratee ----------------------------------------------------------------------------
{{{

data Stream c =
  EOF -- (Maybe SomeException)
  | Chunk c
  deriving (Show, Typeable)

newtype IterateeE e s m a = IterateeE { runIter :: forall r.
          (a -> Stream s -> m r) ->
          ((Stream s -> IterateeE e s m a) -> SomeException -> m r) ->
          m r}
type EnumerateeE eFrom eTo sFrom sTo m a =
        IterateeE eTo sTo m a ->
        IterateeE eFrom sFrom m (IterateeE eTo sTo m a)


eneeCheckIfDoneHandle :: (Monad m, NullPoint elo, NullPoint eli,
Exception ex) =>
 ((Stream eli -> IterateeE ei eli m a) -> ex -> IterateeE (Caught ex
e) elo m (IterateeE e eli m a)) ->
 ((Stream eli -> IterateeE ei eli m a) -> SomeException -> IterateeE
(Caught ex e) elo m (IterateeE e eli m a))
 -> EnumerateeE e (Caught ex e) elo eli m a

eneeCheckIfDoneHandle = undefined
{-
eneeCheckIfDoneHandle h f inner = IterateeE $ \od oc ->
   let onDone x s = od (idone x s) (Chunk empty)
       onCont k e = case cast e of
                        Nothing -> runIter (f k e) od oc
                        Just ex -> runIter (h k ex) od oc
   in runIter inner onDone onCont
-}


joinI ::
 (Monad m, NullPoint s) =>
  IterateeE e s m (IterateeE e' s' m a)
  -> IterateeE e s m a
joinI = undefined
{-
joinI = (>>=
  \inner -> IterateeE $ \od oc ->
  let onDone  x _        = od x (Chunk empty)
      onCont = undefined
--      onCont  k Nothing  = runIter (k (EOF Nothing)) onDone onCont'
--      onCont  _ (Just e) = runIter (throwErr e) od oc
--      onCont' _ e        = runIter (throwErr (fromMaybe excDivergent e)) od oc
  in runIter inner onDone onCont)
-}

idone :: Monad m => a -> Stream s -> IterateeE e s m a
idone a s = IterateeE $ \onDone _ -> onDone a s

icont :: (Stream s -> IterateeE e s m a) -> SomeException -> IterateeE e s m a
icont k e = IterateeE $ \_ onCont -> onCont k e

liftI :: (Stream s -> IterateeE e s m a) -> IterateeE e s m a
liftI = flip icont nothingToWorryAbout

nothingToWorryAbout :: SomeException
nothingToWorryAbout = toException NothingToWorryAbout

throwRecoverableErr :: (Throws ex e, Exception ex) =>
        ex -> (Stream s -> IterateeE e s m a) -> IterateeE e s m a
throwRecoverableErr e k = IterateeE $ \_ onCont -> onCont k (toException e )

identity :: (Monad m, NullPoint s) => IterateeE e s m ()
identity = idone () (Chunk empty)

-------------------------------------------------------------------------------------------
}}}

-- my Exception {{{
-- first let's define Exception class with default implementations of
toException/fromException
class (Typeable e, Show e) => Exception e where
    toException :: e -> SomeException
    toException = SomeException

    fromException :: SomeException -> Maybe e
    fromException (SomeException e) = cast e

-- One constructor for that class
data SomeException = forall e. Exception e => SomeException e
    deriving (Typeable)

-- and the Show instance, since this is not haskell-98 type anymore
instance Show SomeException where
    show (SomeException e) = show e
-- }}}

-- Some Test cases {{{

data SeekException = SeekException FileOffset deriving (Typeable, Show)
instance Exception SeekException

data ResetException = ResetException deriving (Typeable, Show)
instance Exception ResetException

seek :: (Monad m, NullPoint s, Throws SeekException e) => IterateeE e s m ()
seek = throwRecoverableErr (SeekException 1000) (const identity)

reset :: (Monad m, NullPoint s, Throws ResetException e) => IterateeE e s m ()
reset = throwRecoverableErr (ResetException) (const identity)

muncher :: Monad m => IterateeE e s m ()
muncher = liftI go
    where
        go c = liftI go

resetE :: Monad m => EnumerateeE ei (Caught ResetException ei) [s] [s] m a
resetE = undefined
{-resetE = eneeCheckIfDoneHandle h (icont . go)
    where
        go k c = eneeCheckIfDoneHandle h (icont . go) (k c)
        h = error "Got reset message"
-}
seekE :: Monad m => EnumerateeE ei (Caught SeekException ei) [s] [s] m a
seekE = undefined
{-seekE = eneeCheckIfDoneHandle h (icont . go)
    where
        go k c = eneeCheckIfDoneHandle h (icont . go) (k c)
        h = error "Got seek message"-}
-- }}}

{-
results:

resetE reset     -- typchecks
resetE muncher   -- typechercks
resetE seek      -- fails
seekE reset      -- fails
seekE seek       -- typechecks
resetE (joinI $ seekE $ head [reset, seek, muncher]) fails
joinI $ seekE $ head [reset, seek, muncher] -- fails


-}


-- Typelevel magic {{{
data Caught e l
class    Exception e => Throws e s
instance Exception e => Throws e (Caught e l)
instance Throws e l  => Throws e (Caught e1 l)
--instance Throws e l  => Throws e (Caught e1 l)
instance Exception e => Throws e (Caught SomeException l)
data NothingToWorryAbout = NothingToWorryAbout deriving (Show, Typeable)
instance Exception NothingToWorryAbout
-- }}}