@@ -1,20 +1,25 @@
11{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE FlexibleInstances #-}
23{-# LANGUAGE GeneralizedNewtypeDeriving #-}
34{-# LANGUAGE MultiParamTypeClasses #-}
45{-# LANGUAGE OverloadedStrings #-}
56{-# LANGUAGE TemplateHaskell #-}
7+{-# LANGUAGE TypeFamilies #-}
8+{-# LANGUAGE UndecidableInstances #-}
69module Main
710 ( main
811 ) where
912
1013
1114-------------------------------------------------------------------------------
12−import Control.Applicative as A
13−import Control.Lens hiding ((.=))
15+import Control.Applicative as A
16+import Control.Lens hiding ((.=))
17+import Control.Monad.Base
1418import Control.Monad.Reader
19+import Control.Monad.Trans.Control
1520import Data.Aeson
16−import Data.Monoid as M
17−import System.IO (stdout)
21+import Data.Monoid as M
22+import System.IO (stdout)
1823-------------------------------------------------------------------------------
1924import Katip
2025-------------------------------------------------------------------------------
@@ -86,9 +91,28 @@ confrabulateWidgets = return ()
8691-------------------------------------------------------------------------------
8792newtype MyStack m a = MyStack {
8893 unStack :: ReaderT MyState m a
89− } deriving (MonadReader MyState, Functor, A.Applicative, Monad, MonadIO)
94+ } deriving (MonadReader MyState, Functor, A.Applicative, Monad, MonadIO, MonadTrans)
9095
9196
97+-- MonadBase, MonadTransControl, and MonadBaseControl aren't strictly
98+-- needed for this example, but they are commonly required and
99+-- MonadTransControl/MonadBaseControl are a pain to implement, so I've
100+-- included them. Note that KatipT and KatipContextT already do this work for you.
101+instance MonadBase b m => MonadBase b (MyStack m) where
102+ liftBase = liftBaseDefault
103+
104+
105+instance MonadTransControl MyStack where
106+ type StT MyStack a = StT (ReaderT Int) a
107+ liftWith = defaultLiftWith MyStack unStack
108+ restoreT = defaultRestoreT MyStack
109+
110+
111+instance MonadBaseControl b m => MonadBaseControl b (MyStack m) where
112+ type StM (MyStack m) a = ComposeSt MyStack m a
113+ liftBaseWith = defaultLiftBaseWith
114+ restoreM = defaultRestoreM
115+
92116instance (MonadIO m) => Katip (MyStack m) where
93117 getLogEnv = view msLogEnv
94118