f.hs

{-# LANGUAGE RankNTypes #-}
newtype ValidT e m a = ValidT { runValidT :: forall r. [e] -> ([e] -> a -> m r) -> m r }

instance Functor (ValidT e m) where
  fmap f (ValidT m) = ValidT $ \s succ -> m s (\s' a' -> succ s' (f a'))
  {-# INLINE fmap #-}

instance Applicative (ValidT e m) where
    {-# INLINE pure #-}
    pure x = ValidT $ \s succ -> succ s x

    {-# INLINE (<*>) #-}
    ValidT f <*> ValidT v = ValidT $ \s succ ->
       f s (\s' g -> v s' (\s'' a -> succ s'' (g a)))

    {-# INLINE (*>) #-}
    m *> k = m >>= \_ -> k

instance Monad (ValidT s m) where
    {-# INLINE return #-}
    return x = ValidT $ \s succ -> succ s x

    {-# INLINE (>>=) #-}
    ValidT m >>= k  = ValidT $ \s succ -> m s (\s' x -> runValidT (k x) s' succ)


addError :: e -> ValidT e m ()
addError e = ValidT $ \s succ -> succ (e:s) ()