{-# LANGUAGE Arrows #-} {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TupleSections #-} -- | 'MSF's in the 'ExceptT' monad are monadic stream functions -- that can throw exceptions, -- i.e. return an exception value instead of a continuation. -- This module gives ways to throw exceptions in various ways, -- and to handle them through a monadic interface. module Control.Monad.Trans.MSF.Except ( module Control.Monad.Trans.MSF.Except , module Control.Monad.Trans.Except ) where -- External import Control.Applicative import qualified Control.Category as Category import Control.Monad (liftM, ap) import Control.Monad.Trans.Class import Control.Monad.Trans.Except hiding (liftCallCC, liftListen, liftPass) -- Avoid conflicting exports import Control.Monad.Trans.Maybe -- Internal import Data.MonadicStreamFunction import Data.MonadicStreamFunction.InternalCore -- External, necessary for older base versions #if __GLASGOW_HASKELL__ < 802 fromLeft :: a -> Either a b -> a fromLeft _ (Left a) = a fromLeft a (Right _) = a fromRight :: b -> Either a b -> b fromRight _ (Right b) = b fromRight b (Left _) = b #else import Data.Either (fromLeft, fromRight) #endif -- * Throwing exceptions -- | Throw the exception 'e' whenever the function evaluates to 'True'. throwOnCond :: Monad m => (a -> Bool) -> e -> MSF (ExceptT e m) a a throwOnCond cond e = proc a -> if cond a then throwS -< e else returnA -< a -- | Variant of 'throwOnCond' for Kleisli arrows. -- | Throws the exception when the input is 'True'. throwOnCondM :: Monad m => (a -> m Bool) -> e -> MSF (ExceptT e m) a a throwOnCondM cond e = proc a -> do b <- arrM (lift . cond) -< a if b then throwS -< e else returnA -< a -- | Throw the exception when the input is 'True'. throwOn :: Monad m => e -> MSF (ExceptT e m) Bool () throwOn e = proc b -> throwOn' -< (b, e) -- | Variant of 'throwOn', where the exception may change every tick. throwOn' :: Monad m => MSF (ExceptT e m) (Bool, e) () throwOn' = proc (b, e) -> if b then throwS -< e else returnA -< () -- | When the input is @Just e@, throw the exception @e@. -- (Does not output any actual data.) throwMaybe :: Monad m => MSF (ExceptT e m) (Maybe e) (Maybe a) throwMaybe = mapMaybeS throwS -- | Immediately throw the incoming exception. throwS :: Monad m => MSF (ExceptT e m) e a throwS = arrM throwE -- | Immediately throw the given exception. throw :: Monad m => e -> MSF (ExceptT e m) a b throw = constM . throwE -- | Do not throw an exception. pass :: Monad m => MSF (ExceptT e m) a a pass = Category.id -- | Converts an 'MSF' in 'MaybeT' to an 'MSF' in 'ExceptT'. -- Whenever 'Nothing' is thrown, throw @()@ instead. maybeToExceptS :: (Functor m, Monad m) => MSF (MaybeT m) a b -> MSF (ExceptT () m) a b maybeToExceptS = morphS (ExceptT . (maybe (Left ()) Right <$>) . runMaybeT) -- * Catching exceptions -- | Catch an exception in an 'MSF'. As soon as an exception occurs, -- the current continuation is replaced by a new 'MSF', the exception handler, -- based on the exception value. -- For exception catching where the handler can throw further exceptions, -- see 'MSFExcept' further below. catchS :: Monad m => MSF (ExceptT e m) a b -> (e -> MSF m a b) -> MSF m a b catchS msf f = safely $ do e <- try msf safe $ f e -- | Similar to Yampa's delayed switching. Loses a @b@ in case of an exception. untilE :: Monad m => MSF m a b -> MSF m b (Maybe e) -> MSF (ExceptT e m) a b untilE msf msfe = proc a -> do b <- liftTransS msf -< a me <- liftTransS msfe -< b inExceptT -< ExceptT $ return $ maybe (Right b) Left me -- TODO This needs to be renamed as 'runExceptS'! -- 'exceptS' would have type @MSF m a (Either e b) -> MSF (ExceptT e m) a b@ -- | Escape an 'ExceptT' layer by outputting the exception whenever it occurs. -- If an exception occurs, the current 'MSF' continuation is tested again -- on the next input. exceptS :: (Functor m, Monad m) => MSF (ExceptT e m) a b -> MSF m a (Either e b) exceptS = transG return $ const $ fmap f . runExceptT where f (Left e) = (Left e , Nothing) f (Right (b, c)) = (Right b, Just c ) -- | Embed an 'ExceptT' value inside the 'MSF'. -- Whenever the input value is an ordinary value, -- it is passed on. If it is an exception, it is raised. inExceptT :: Monad m => MSF (ExceptT e m) (ExceptT e m a) a inExceptT = arrM id -- | In case an exception occurs in the first argument, -- replace the exception by the second component of the tuple. tagged :: Monad m => MSF (ExceptT e1 m) a b -> MSF (ExceptT e2 m) (a, e2) b tagged msf = runMSFExcept $ do _ <- try $ msf <<< arr fst (_, e2) <- currentInput return e2 -- * Monad interface for Exception MSFs -- | 'MSF's with an 'ExceptT' transformer layer -- are in fact monads /in the exception type/. -- -- * 'return' corresponds to throwing an exception immediately. -- * '>>=' is exception handling: -- The first value throws an exception, -- while the Kleisli arrow handles the exception -- and produces a new signal function, -- which can throw exceptions in a different type. -- * @m@: The monad that the 'MSF' may take side effects in. -- * @a@: The input type -- * @b@: The output type -- * @e@: The type of exceptions that can be thrown newtype MSFExcept m a b e = MSFExcept { runMSFExcept :: MSF (ExceptT e m) a b } -- | An alias for the 'MSFExcept' constructor, -- used to enter the 'MSFExcept' monad context. -- Execute an 'MSF' in 'ExceptT' until it raises an exception. try :: MSF (ExceptT e m) a b -> MSFExcept m a b e try = MSFExcept -- | Immediately throw the current input as an exception. currentInput :: Monad m => MSFExcept m e b e currentInput = try throwS -- | Functor instance for MSFs on the 'Either' monad. Fmapping is the same as -- applying a transformation to the 'Left' values. instance Monad m => Functor (MSFExcept m a b) where fmap = liftM -- | Applicative instance for MSFs on the 'Either' monad. The function 'pure' -- throws an exception. instance Monad m => Applicative (MSFExcept m a b) where pure = MSFExcept . throw (<*>) = ap -- | Monad instance for 'MSFExcept'. Bind uses the exception as the 'return' -- value in the monad. instance Monad m => Monad (MSFExcept m a b) where return = pure MSFExcept msf >>= f = MSFExcept $ handleExceptT msf $ runMSFExcept . f handleExceptT :: Monad m => MSF (ExceptT e1 m) a b -> (e1 -> MSF (ExceptT e2 m) a b) -> MSF (ExceptT e2 m) a b handleExceptT msf f = flip handleGen msf $ \a mbcont -> do ebcont <- lift $ runExceptT mbcont case ebcont of Left e -> unMSF (f e) a Right (b, msf') -> return (b, handleExceptT msf' f) -- | The empty type. As an exception type, it encodes "no exception possible". data Empty -- | If no exception can occur, the 'MSF' can be executed without the 'ExceptT' layer. safely :: Monad m => MSFExcept m a b Empty -> MSF m a b safely (MSFExcept msf) = morphS fromExcept msf where -- We can assume that the pattern @Left e@ will not occur, -- since @e@ would have to be of type @Empty@. fromExcept ma = do rightMa <- runExceptT ma return $ fromRight (error "safely: Received `Left`") rightMa -- | An 'MSF' without an 'ExceptT' layer never throws an exception, -- and can thus have an arbitrary exception type. safe :: Monad m => MSF m a b -> MSFExcept m a b e safe = try . liftTransS -- | Inside the 'MSFExcept' monad, execute an action of the wrapped monad. -- This passes the last input value to the action, -- but doesn't advance a tick. once :: Monad m => (a -> m e) -> MSFExcept m a b e once f = try $ arrM (lift . f) >>> throwS -- | Variant of 'once' without input. once_ :: Monad m => m e -> MSFExcept m a b e once_ = once . const -- | Advances a single tick with the given Kleisli arrow, -- and then throws an exception. step :: Monad m => (a -> m (b, e)) -> MSFExcept m a b e step f = try $ proc a -> do n <- count -< () (b, e) <- arrM (lift . f) -< a _ <- throwOn' -< (n > (1 :: Int), e) returnA -< b -- | Advances a single tick outputting the value, -- and then throws '()'. step_ :: Monad m => b -> MSFExcept m a b () step_ = step . const . return . (, ()) -- | Converts a list to an 'MSFExcept', -- which outputs an element of the list at each step, -- throwing '()' when the list ends. listToMSFExcept :: Monad m => [b] -> MSFExcept m a b () listToMSFExcept = mapM_ step_ -- * Utilities definable in terms of 'MSFExcept' -- TODO This is possibly not the best location for these functions, -- but moving them to Data.MonadicStreamFunction.Util would form an import cycle -- that could only be broken by moving a few things to Data.MonadicStreamFunction.Core -- (that probably belong there anyways). -- | Extract an 'MSF' from a monadic action. -- -- Runs a monadic action that produces an 'MSF' on the first iteration/step, and -- uses that 'MSF' as the main signal function for all inputs (including the -- first one). performOnFirstSample :: Monad m => m (MSF m a b) -> MSF m a b performOnFirstSample sfaction = safely $ do msf <- once_ sfaction safe msf -- | Reactimates an 'MSFExcept' until it throws an exception. reactimateExcept :: Monad m => MSFExcept m () () e -> m e reactimateExcept msfe = do leftMe <- runExceptT $ reactimate $ runMSFExcept msfe return $ fromLeft (error "reactimateExcept: Received `Right`") leftMe -- | Reactimates an 'MSF' until it returns 'True'. reactimateB :: Monad m => MSF m () Bool -> m () reactimateB sf = reactimateExcept $ try $ liftTransS sf >>> throwOn () -- * Analog to Yampa's switch, with Maybe instead of Event switch :: Monad m => MSF m a (b, Maybe c) -> (c -> MSF m a b) -> MSF m a b switch sf f = catchS ef f where ef = proc a -> do (b,me) <- liftTransS sf -< a inExceptT -< ExceptT $ return $ maybe (Right b) Left me -- | More general lifting combinator that enables recovery. Note that, unlike a -- polymorphic lifting function @forall a . m a -> m1 a@, this auxiliary -- function needs to be a bit more structured, and produces a Maybe value. The -- previous 'MSF' is used if a new one is not produced. transG :: (Monad m1, Monad m2) => (a2 -> m1 a1) -> (forall c. a2 -> m1 (b1, c) -> m2 (b2, Maybe c)) -> MSF m1 a1 b1 -> MSF m2 a2 b2 transG transformInput transformOutput msf = go where go = MSF $ \a2 -> do (b2, msf') <- transformOutput a2 $ unMSF msf =<< transformInput a2 case msf' of Just msf'' -> return (b2, transG transformInput transformOutput msf'') Nothing -> return (b2, go) handleGen :: (a -> m1 (b1, MSF m1 a b1) -> m2 (b2, MSF m2 a b2)) -> MSF m1 a b1 -> MSF m2 a b2 handleGen handler msf = MSF $ \a -> handler a (unMSF msf a)