On Github mkawalec / monad-transformers
By Michal Kawalec @monad_cat
newtype IdentityT f a = IdentityT {runIdentityT :: f a}
which is, without record syntax:
newtype IdentityT f a = IdentityT (f a)
newtype IdentityT m a = IdentityT {runIdentityT :: m a} instance (Functor m) => Functor (IdentityT m) where fmap f (IdentityT fa) = IdentityT (fmap f fa) instance (Applicative m) => Applicative (IdentityT m) where pure x = IdentityT (pure x) (IdentityT fab) <*> (IdentityT fa) = IdentityT (fab <*> fa) instance (Monad m) => Monad (IdentityT m) where return = pure (>>=) :: IdentityT m a -> (a -> IdentityT m b) -> IdentityT m b (IdentityT ma) >>= f = IdentityT $ ma >>= runIdentityT . f
newtype MaybeT m a = MaybeT {runMaybeT :: m (Maybe a)} instance (Monad a) => Monad (MaybeT m) where return = pure (MaybeT ma) >>= f = MaybeT $ do v <- ma case v of Nothing -> return Nothing Just y -> runMaybeT (f y)
newtype StateT s m a = StateT {runStateT :: s -> m (a, s)} instance (Monad m) => Monad (StateT s m) where return a = StateT $ \s -> return (a,s) (>>=) :: StateT s m a -> (a -> StateT s m b) -> StateT s m b (StateT x) >>= f = StateT $ \s -> do (v,s') <- x s runStateT (f v) s'
getParsedChunk :: Connection -> (BSC.ByteString -> Result ParseResult) -> IO ParseResult getParsedChunk conn parser = do (parsed, cont) <- connectionGetChunk'' conn $ parseChunk parser if isJust cont then getParsedChunk conn $ fromJust cont else return . fromJust $ parsed
class Monad m => Universe m where connectionPut' :: Connection -> BSC.ByteString -> m () connectionGetChunk'' :: Connection -> (BSC.ByteString -> (a, BSC.ByteString)) -> m a instance Universe IO where connectionPut' = connectionPut connectionGetChunk'' = connectionGetChunk'
getParsedChunk :: (MonadIO m, Universe m) => Connection -> (BSC.ByteString -> Result ParseResult) -> m ParseResult getParsedChunk conn parser = do (parsed, cont) <- connectionGetChunk'' conn $ parseChunk parser if isJust cont then getParsedChunk conn $ fromJust cont else return . fromJust $ parsed
instance {-# OVERLAPPING #-} Universe (S.StateT FakeState IO) where connectionPut' = testConnectionPut connectionGetChunk'' = testConnectionGetChunk data FakeState = FS { bytesWritten :: TVar BS.ByteString, bytesToRead :: TVar BS.ByteString, reactToInput :: (BS.ByteString -> BS.ByteString) }
testConnectionGetChunk :: Connection -> (BS.ByteString -> (a, BS.ByteString)) -> S.StateT FakeState IO a testConnectionGetChunk c proc = do st <- S.get toRead <- liftIO . atomically $ do bytes <- readTVar . bytesToRead $ st if (BS.length bytes) == 0 then retry else return bytes let (result, left) = proc toRead liftIO . atomically $ writeTVar (bytesToRead st) left return result
testLoginFailure :: IO () testLoginFailure = do conn <- getConn let testState = defState atomically . writeTVar . bytesToRead $ testState "NO [ALERT] Invalid credentials (Failure)" (res, _) <- flip runStateT testState $ do login conn "a" "b" resultState res @?= NO