module Network.Haskoin.Util.BuildMonad
(
Build(..)
, isComplete
, isPartial
, isBroken
, eitherToBuild
, buildToEither
, guardPartial
, BuildT(..)
, liftBuild
) where
import Control.Monad (liftM)
import Control.Monad.Trans
( MonadTrans
, MonadIO
, lift
, liftIO
)
data Build a
= Complete { runBuild :: a }
| Partial { runBuild :: a }
| Broken { runBroken :: String }
deriving Eq
instance Show a => Show (Build a) where
show (Complete a) = "Complete " ++ (show a)
show (Partial a) = "Partial " ++ (show a)
show (Broken str) = "Broken " ++ str
instance Functor Build where
fmap f (Complete x) = Complete (f x)
fmap f (Partial x) = Partial (f x)
fmap _ (Broken s) = Broken s
instance Monad Build where
return = Complete
Complete x >>= f = f x
Partial x >>= f = case f x of
e@(Broken _) -> e
a -> Partial $ runBuild a
Broken s >>= _ = Broken s
isComplete :: Build a -> Bool
isComplete (Complete _) = True
isComplete _ = False
isPartial :: Build a -> Bool
isPartial (Partial _) = True
isPartial _ = False
isBroken :: Build a -> Bool
isBroken (Broken _) = True
isBroken _ = False
eitherToBuild :: Either String a -> Build a
eitherToBuild m = case m of
Left err -> Broken err
Right res -> Complete res
buildToEither :: Build a -> Either String a
buildToEither m = case m of
Complete a -> Right a
Partial a -> Right a
Broken err -> Left err
guardPartial :: Bool -> Build ()
guardPartial True = Complete ()
guardPartial False = Partial ()
newtype BuildT m a = BuildT { runBuildT :: m (Build a) }
mapBuildT :: (m (Build a) -> n (Build b)) -> BuildT m a -> BuildT n b
mapBuildT f = BuildT . f . runBuildT
instance Functor m => Functor (BuildT m) where
fmap f = mapBuildT (fmap (fmap f))
instance Monad m => Monad (BuildT m) where
return = lift . return
x >>= f = BuildT $ do
v <- runBuildT x
case v of Complete a -> runBuildT (f a)
Partial a -> runBuildT (f a)
Broken str -> return $ Broken str
instance MonadTrans BuildT where
lift = BuildT . liftM Complete
instance MonadIO m => MonadIO (BuildT m) where
liftIO = lift . liftIO
liftBuild :: Monad m => Build a -> BuildT m a
liftBuild = BuildT . return