module Data.FailableList
( FailableList (..)
, map
, foldr
, unfoldr
) where
import Prelude hiding (map, foldr)
import qualified Prelude as Prelude
import Data.Monoid (Monoid, mempty, mappend, mconcat)
import Control.Monad (MonadPlus, mzero, mplus, ap)
import Control.Monad.Fix (MonadFix, fix, mfix)
import qualified Control.Applicative as A
import Control.Applicative ((<$>), (<*>))
import qualified Data.Foldable as F
import qualified Data.Traversable as T
data FailableList e a
= Next a (FailableList e a)
| Done
| Fail e
deriving (Eq, Show)
instance Functor (FailableList e) where
fmap = T.fmapDefault
instance Monoid (FailableList e a) where
mempty = Done
mappend x y = foldr Next y Fail x
instance Monad (FailableList e) where
Done >>= _ = Done
Fail e >>= _ = Fail e
(Next x xs) >>= k = mappend (k x) (xs >>= k)
return = flip Next Done
instance MonadPlus (FailableList e) where
mzero = mempty
mplus = mappend
instance A.Alternative (FailableList e) where
empty = mempty
(<|>) = mappend
instance A.Applicative (FailableList e) where
pure = return
(<*>) = ap
instance F.Foldable (FailableList e) where
foldMap = T.foldMapDefault
instance T.Traversable (FailableList e) where
sequenceA Done = A.pure Done
sequenceA (Fail e) = A.pure $ Fail e
sequenceA (Next f fs) = Next <$> f <*> T.sequenceA fs
instance MonadFix (FailableList e) where
mfix f = case fix (f . head') of
Done -> Done
Fail e -> Fail e
(Next x _) -> mappend (return x) (mfix (tail' . f))
map :: (a -> Either e b) -> FailableList e a -> FailableList e b
map f = foldr (\a acc -> either Fail (flip Next acc) (f a)) Done Fail
foldr :: (a -> b -> b) -> b -> (e -> b) -> FailableList e a -> b
foldr f nil fail' = foldr' where
foldr' (Next a as) = f a (foldr' as)
foldr' Done = nil
foldr' (Fail e) = fail' e
unfoldr :: (b -> Either e (Maybe (a, b))) -> b -> FailableList e a
unfoldr f = unfoldr' where
unfoldr' x = case f x of
Right (Just (a, b)) -> Next a (unfoldr' b)
Right Nothing -> Done
Left e -> Fail e
head' :: FailableList e a -> a
head' Done = error "mfix FailableList: Done"
head' (Fail _) = error "mfix FailableList: Fail"
head' (Next x _) = x
tail' :: FailableList e a -> FailableList e a
tail' Done = error "mfix FailableList: Done"
tail' (Fail _) = error "mfix FailableList: Fail"
tail' (Next _ xs) = xs