never executed always true always false
    1 {-|
    2 Module: Flaw.Stack
    3 Description: Stack monad for faking "destructors".
    4 License: MIT
    5 -}
    6 
    7 {-# LANGUAGE RankNTypes #-}
    8 
    9 module Flaw.Stack
   10   ( StackT(..)
   11   , after
   12   , runStackT
   13   , scope
   14   ) where
   15 
   16 import Control.Monad.Catch
   17 import Control.Monad.Fail as F
   18 import Control.Monad.IO.Class
   19 import Control.Monad.Trans.Class
   20 
   21 -- | Stacking monad transformer.
   22 newtype StackT m a = StackT (forall b. (a -> m b) -> m b)
   23 
   24 instance Functor (StackT m) where
   25   {-# INLINE fmap #-}
   26   fmap f (StackT h) = StackT $ \q -> h $ \r -> q $ f r
   27 
   28 instance Applicative (StackT m) where
   29   {-# INLINE pure #-}
   30   pure a = StackT $ \q -> q a
   31   {-# INLINE (<*>) #-}
   32   (StackT f) <*> (StackT h) = StackT $ \q -> h $ \r -> f $ \z -> q $ z r
   33 
   34 instance Monad (StackT m) where
   35   {-# INLINE return #-}
   36   return a = StackT $ \q -> q a
   37   {-# INLINE (>>=) #-}
   38   (StackT h) >>= f = StackT $ \q -> h $ \r -> let StackT z = f r in z q
   39 
   40 instance MonadFail m => MonadFail (StackT m) where
   41   {-# INLINE fail #-}
   42   fail s = StackT (F.fail s >>=)
   43 
   44 instance MonadTrans StackT where
   45   {-# INLINE lift #-}
   46   lift a = StackT $ \q -> a >>= q
   47 
   48 instance MonadIO m => MonadIO (StackT m) where
   49   {-# INLINE liftIO #-}
   50   liftIO = lift . liftIO
   51 
   52 instance MonadThrow m => MonadThrow (StackT m) where
   53   {-# INLINE throwM #-}
   54   throwM e = StackT (=<< throwM e)
   55 
   56 instance MonadCatch m => MonadCatch (StackT m) where
   57   {-# INLINE catch #-}
   58   catch (StackT h) f = StackT $ \q -> catch (h q) (\e -> let StackT z = f e in z q)
   59 
   60 instance MonadMask m => MonadMask (StackT m) where
   61   {-# INLINE mask #-}
   62   mask f = f $ \(StackT h) -> StackT $ \q -> mask $ \restore -> restore $ h q
   63   {-# INLINE uninterruptibleMask #-}
   64   uninterruptibleMask f = f $ \(StackT h) -> StackT $ \q -> uninterruptibleMask $ \restore -> restore $ h q
   65   {-# INLINE generalBracket #-}
   66   generalBracket (StackT acquire) release f = StackT $ \q ->
   67     q =<< generalBracket
   68       (acquire return)
   69       (\e exitCase -> let StackT h = release e exitCase in h return)
   70       (\e -> let StackT h = f e in h return)
   71 
   72 {-# INLINE after #-}
   73 after :: Monad m => m () -> StackT m ()
   74 after f = StackT $ \q -> do
   75   r <- q ()
   76   f
   77   return r
   78 
   79 {-# INLINE runStackT #-}
   80 runStackT :: Monad m => StackT m a -> m a
   81 runStackT (StackT f) = f return
   82 
   83 {-# INLINE scope #-}
   84 scope :: Monad m => StackT m a -> StackT m a
   85 scope (StackT f) = StackT $ \q -> q =<< f return