how to use monad-control

monad-ctrl.hs

{-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-}

import Control.Applicative
import Control.Exception.Lifted
import Control.Monad
import Control.Monad.Base
import Control.Monad.Trans
import Control.Monad.Trans.Control
import Control.Monad.Trans.Maybe
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Prelude hiding (catch)

newtype MyT m a = MyT { unwrapMyT :: MaybeT m a }
    deriving ( Functor
             , Applicative
             , Monad
             , MonadBase base
             , MonadIO
             , MonadTrans )

instance MonadTransControl MyT where
    newtype StT MyT a = StMyT { unStMyT :: Maybe a }
    liftWith f = MyT $ MaybeT $ liftM Just $ f $ liftM StMyT . runMyT
    restoreT m = do
        x <- lift m
        val $ unStMyT x

instance MonadBaseControl b m => MonadBaseControl b (MyT m) where
    newtype StM (MyT m) a = StMMyT { unStMMyT :: ComposeSt MyT m a } -- 基本的にはComposeStを使い、defaultLiftBaseWithとdefaultRestoreMを使えば良い。
    -- fは、MyT m aのcontextを受け取りそれの状態をStM (MyT m) aでパックしたのをbのcontextで返す関数gを受け取り、gを用いてbのcontextで何か計算する関数。f :: (forall a. MyT m a -> b (StM (MyT m) a)) -> b a
    -- liftBaseWithはgをfに与え、fがbのcontextで計算した結果をMyT mにする関数。
    -- モナドスタック直下(m)のliftBaseWithを実行し、その結果をMyTのコンテクストで包めば良い。
    liftBaseWith = defaultLiftBaseWith StMMyT
    -- StM (MyT m) a から MyT m aを作るだけの簡単なお仕事。
    -- liftBaseWith同様、モナドスタック直下(m)のrestoreMを実行し、m aまで持ってきてからMyTのcontextで包む。
    restoreM = defaultRestoreM unStMMyT

runMyT :: MyT m a -> m (Maybe a)
runMyT (MyT m) = runMaybeT m

val :: Monad m => Maybe a -> MyT m a
val (Just a)  = return a
val Nothing = fail ""

main :: IO ()
main = runMyT func >>= print

func :: (Functor m, MonadBaseControl IO m, MonadIO m) => MyT m Int
func = do
    x <- return 51
    if x > 50
        then do
            liftIO $ putStrLn "ももんが"
            l <- T.length <$> readFileMyT "hogehoge.txt"
                `catch` (\(SomeException _) -> liftIO (putStrLn "error!!!!!") >> return T.empty)
            return (l `mod` x)
        else do
            liftIO $ putStrLn "ふくろう"
            fail ""

readFileMyT :: MonadIO m => FilePath -> MyT m T.Text
readFileMyT = liftIO . TIO.readFile