Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- {-# LANGUAGE GeneralizedNewtypeDeriving #-}
- {-# LANGUAGE FlexibleContexts #-}
- {-# LANGUAGE FlexibleInstances #-}
- {-# LANGUAGE ScopedTypeVariables #-}
- module ExceptionTest where
- import Control.Concurrent
- import Control.Exception
- import Control.Monad
- import Control.Monad.Except
- import Control.Monad.Reader
- import Control.Monad.Trans.Class (lift)
- import Data.Typeable
- import qualified Data.Map.Strict as M
- data SaunaError = SaunaTooHot deriving Show
- data DbError = NoSuchUser deriving Show
- data SpaErrors = SaunaErr SaunaError | DbErr DbError deriving (Show, Typeable)
- instance Exception SpaErrors
- type Name = String
- type TempPreference = Int
- data User = User Name TempPreference deriving Show
- type Database = M.Map Name User
- newtype Connection = Connection (MVar Database)
- newtype TempController = TempController (MVar TempPreference)
- -------------------------
- ---- IO (Either a b) ----
- -------------------------
- database :: Database
- database = M.fromList [ ("Joe", User "Joe" 65) , ("Fred", User "Fred" 101) ]
- getUserFromDb :: Connection -> Name -> IO (Either SpaErrors User)
- getUserFromDb (Connection m) name = do
- db <- takeMVar m
- putMVar m db
- case M.lookup name db of
- Just user -> return $ Right user
- Nothing -> return . Left . DbErr $ NoSuchUser
- setServerTemp :: TempController -> TempPreference -> IO ()
- setServerTemp (TempController m) newTemp = do
- _ <- takeMVar m
- putMVar m newTemp
- checkServerTemp :: TempController -> IO (Either SpaErrors String)
- checkServerTemp (TempController m) = do
- tc <- takeMVar m
- putMVar m tc
- if tc > 100
- then return . Left . SaunaErr $ SaunaTooHot
- else return $ Right "New temp set"
- main0 :: IO ()
- main0 = do
- db <- newMVar database
- tc <- newMVar 65
- -- Our External Services:
- let dbConn = Connection db
- let tempController = TempController tc
- user <- getUserFromDb dbConn "Joe"
- case user of
- Left err -> print err
- Right (User _ newTemp) -> do
- setServerTemp tempController newTemp
- res <- checkServerTemp tempController
- case res of
- Left err -> print err
- Right res -> print res -- irl this would call some other function
- -- Using a Let statement to try to flatten the case statements:
- main1 :: IO ()
- main1 = do
- db <- newMVar database
- tc <- newMVar 65
- -- Our External Services:
- let dbConn = Connection db
- let tempController = TempController tc
- user <- getUserFromDb dbConn "Fred"
- let res :: Either SpaErrors TempPreference
- res = do
- User _ temp <- user
- -- You might want to do this:
- -- setServerTemp tempController temp :: IO (Either SaunaError String)
- -- but it doesn't typecheck because we are in an Either do block
- -- not an IO do block.
- return temp
- case res of
- Left err -> print err
- Right newTemp -> do
- setServerTemp tempController newTemp
- res' <- checkServerTemp tempController
- print res'
- --performCombinedIO :: Connection -> TempController -> Name -> ExceptT SpaErrors IO String
- --performCombinedIO conn tempCont user = do
- -- -- Notice how we got rid of the case tree
- -- User _ temp <- ExceptT $ getUserFromDb conn user
- -- -- setServerTemp is an IO action, but we are in ExceptT.
- -- -- So we must lift it:
- -- lift $ setServerTemp tempCont temp
- -- res <- ExceptT $ checkServerTemp tempCont
- -- return res
- ------------------------
- ---- ExceptT a IO b ----
- ------------------------
- getUserFromDb2 :: Connection -> Name -> ExceptT SpaErrors IO User
- getUserFromDb2 (Connection m) name = do
- db <- liftIO $ takeMVar m
- liftIO $ putMVar m db
- case M.lookup name db of
- Just user -> return user
- Nothing -> throwError $ DbErr NoSuchUser
- checkServerTemp2 :: TempController -> ExceptT SpaErrors IO String
- checkServerTemp2 (TempController m) = do
- tc <- liftIO $ takeMVar m
- liftIO $ putMVar m tc
- if tc > 100
- then throwError $ SaunaErr SaunaTooHot
- else return "New temp set"
- performCombinedIO2 :: Connection -> TempController -> Name -> ExceptT SpaErrors IO String
- performCombinedIO2 conn tempCont user = do
- -- Notice how we got rid of the case tree
- User _ temp <- getUserFromDb2 conn user
- -- setServerTemp is an IO action, but we are in ExceptT.
- -- So we must lift it:
- liftIO $ setServerTemp tempCont temp
- res <- checkServerTemp2 tempCont
- return res
- main2 :: IO ()
- main2 = do
- db <- newMVar database
- tc <- newMVar 65
- -- Our External Services:
- let dbConn = Connection db
- let tempCont = TempController tc
- -- 3 examples to demonstrate the handling of the Lefts and Right
- res0 <- runExceptT $ performCombinedIO2 dbConn tempCont "Joe"
- res1 <- runExceptT $ performCombinedIO2 dbConn tempCont "Fred"
- res2 <- runExceptT $ performCombinedIO2 dbConn tempCont "unknown"
- print res0
- print res1
- print res2
- -------------------------------------
- ---- Adding ReaderT to the stack ----
- -------------------------------------
- -- Context (DB Connection and TempController) are avalaible
- -- everywhere we want it implicitely, however we end up doing
- -- lots of lifting. Also execution order in main is confusing.
- data Env = Env { getDB :: Connection, getTC :: TempController }
- -- Alternate Structure:
- getUserFromDb3' :: Connection -> Name -> ReaderT Env (ExceptT SpaErrors IO) User
- getUserFromDb3' = undefined
- getUserFromDb3 :: Name -> ExceptT SpaErrors (ReaderT Env IO) User
- getUserFromDb3 name = do
- (Connection m) <- asks getDB
- db <- liftIO $ takeMVar m
- liftIO $ putMVar m db
- case M.lookup name db of
- Just user -> return user
- Nothing -> throwError $ DbErr NoSuchUser
- setServerTemp' :: TempPreference -> ReaderT Env IO ()
- setServerTemp' newTemp = do
- TempController m <- asks getTC
- _ <- lift $ takeMVar m
- lift $ putMVar m newTemp
- checkServerTemp3 :: ExceptT SpaErrors (ReaderT Env IO) String
- checkServerTemp3 = do
- TempController m <- asks getTC
- tc <- liftIO $ takeMVar m
- liftIO $ putMVar m tc
- if tc > 100
- then throwError $ SaunaErr SaunaTooHot
- else return "New temp set"
- performCombinedIO' :: Name -> ExceptT SpaErrors (ReaderT Env IO) String
- performCombinedIO' user = do
- User _ temp <- getUserFromDb3 user
- lift $ setServerTemp' temp
- res <- checkServerTemp3
- return res
- main3 :: IO ()
- main3 = do
- db <- newMVar database
- tc <- newMVar 65
- -- Our External Services:
- let dbConn = Connection db
- let tempCont = TempController tc
- let env = Env dbConn tempCont
- -- 3 examples to demonstrate the handling of the Lefts and Right
- res1 <- flip runReaderT env $ runExceptT (performCombinedIO' "Joe")
- res2 <- flip runReaderT env $ runExceptT (performCombinedIO' "Fred")
- res3 <- flip runReaderT env $ runExceptT (performCombinedIO' "unknown")
- print res1
- print res2
- print res3
- --------------------------------------------
- ---- Wrapping The Stack In a Type Alias ----
- --------------------------------------------
- -- Simplified the execution in Main
- type App a = ExceptT SpaErrors (ReaderT Env IO) a
- runApp :: Env -> App a -> IO (Either SpaErrors a)
- runApp env = flip runReaderT env . runExceptT
- getUserFromDb4 :: Name -> App User
- getUserFromDb4 name = do
- (Connection m) <- asks getDB
- db <- liftIO $ takeMVar m
- liftIO $ putMVar m db
- case M.lookup name db of
- Just user -> return user
- Nothing -> throwError $ DbErr NoSuchUser
- checkServerTemp4 :: App String
- checkServerTemp4 = do
- TempController m <- asks getTC
- tc <- liftIO $ takeMVar m
- liftIO $ putMVar m tc
- if tc > 100
- then throwError $ SaunaErr SaunaTooHot
- else return "New temp set"
- performCombinedIO4 :: Name -> App String
- performCombinedIO4 user = do
- User _ temp <- getUserFromDb4 user
- lift $ setServerTemp' temp
- res <- checkServerTemp4
- return res
- main4 :: IO ()
- main4 = do
- db <- newMVar database
- tc <- newMVar 65
- -- Our External Services:
- let dbConn = Connection db
- let tempCont = TempController tc
- let env = Env dbConn tempCont
- res1 <- runApp env (performCombinedIO4 "Joe")
- res2 <- runApp env (performCombinedIO4 "Fred")
- res3 <- runApp env (performCombinedIO4 "unknown")
- print res1
- print res2
- print res3
- ----------------------------
- ---- MTL Style: Round 1 ----
- ----------------------------
- getUserFromDb5 ::
- ( MonadReader Env m
- , MonadIO m
- , MonadError SpaErrors m
- ) => Name -> m User
- getUserFromDb5 name = do
- (Connection m) <- asks getDB
- db <- liftIO $ takeMVar m
- liftIO $ putMVar m db
- case M.lookup name db of
- Just user -> return user
- Nothing -> throwError . DbErr $ NoSuchUser
- setServerTemp5 ::
- ( MonadReader Env m
- , MonadIO m
- ) => TempPreference -> m ()
- setServerTemp5 newTemp = do
- TempController m <- asks getTC
- _ <- liftIO $ takeMVar m
- liftIO $ putMVar m newTemp
- checkServerTemp5 ::
- ( MonadReader Env m
- , MonadIO m
- , MonadError SpaErrors m
- ) => m String
- checkServerTemp5 = do
- TempController m <- asks getTC
- tc <- liftIO $ takeMVar m
- liftIO $ putMVar m tc
- if tc > 100
- then throwError . SaunaErr $ SaunaTooHot
- else return "New temp set"
- performCombinedIO5 ::
- ( MonadReader Env m
- , MonadIO m
- , MonadError SpaErrors m
- ) => Name -> m String
- performCombinedIO5 user = do
- User _ temp <- getUserFromDb5 user
- setServerTemp5 temp
- res <- checkServerTemp5
- return res
- main5 :: IO ()
- main5 = do
- db <- newMVar database
- tc <- newMVar 65
- -- Our External Services:
- let dbConn = Connection db
- let tempCont = TempController tc
- let env = Env dbConn tempCont
- -- 3 examples to demonstrate the handling of the Lefts and Right
- res1 <- flip runReaderT env $ runExceptT (performCombinedIO5 "Joe")
- res2 <- flip runReaderT env $ runExceptT (performCombinedIO5 "Fred")
- res3 <- flip runReaderT env $ runExceptT (performCombinedIO5 "unknown")
- print res1
- print res2
- print res3
- --------------------------------------
- ---- MTL Style Round2: HasPattern ----
- --------------------------------------
- class HasTempController a where
- getTempControl :: a -> TempController
- instance HasTempController Env where
- getTempControl = getTC
- instance HasTempController TempController where
- getTempControl = id
- class HasDatabase a where
- getDatabase :: a -> Connection
- instance HasDatabase Env where
- getDatabase = getDB
- instance HasDatabase Connection where
- getDatabase = id
- getUserFromDb6 ::
- ( MonadReader Env m
- , MonadIO m
- , MonadError SpaErrors m
- ) => Name -> m User
- getUserFromDb6 name = do
- (Connection m) <- asks getDatabase
- db <- liftIO $ takeMVar m
- liftIO $ putMVar m db
- case M.lookup name db of
- Just user -> return user
- Nothing -> throwError . DbErr $ NoSuchUser
- setServerTemp6 ::
- ( MonadReader Env m
- , MonadIO m
- ) => TempPreference -> m ()
- setServerTemp6 newTemp = do
- TempController m <- asks getTempControl
- _ <- liftIO $ takeMVar m
- liftIO $ putMVar m newTemp
- checkServerTemp6 ::
- ( MonadReader Env m
- , MonadIO m
- , MonadError SpaErrors m
- ) => m String
- checkServerTemp6 = do
- TempController m <- asks getTempControl
- tc <- liftIO $ takeMVar m
- liftIO $ putMVar m tc
- if tc > 100
- then throwError . SaunaErr $ SaunaTooHot
- else return "New temp set"
- performCombinedIO6 ::
- ( MonadReader Env m
- , MonadIO m
- , MonadError SpaErrors m
- ) => Name -> m String
- performCombinedIO6 user = do
- User _ temp <- getUserFromDb5 user
- setServerTemp5 temp
- res <- checkServerTemp5
- return res
- main6 :: IO ()
- main6 = do
- db <- newMVar database
- tc <- newMVar 65
- -- Our External Services:
- let dbConn = Connection db
- let tempCont = TempController tc
- let env = Env dbConn tempCont
- -- 3 examples to demonstrate the handling of the Lefts and Right
- res1 <- flip runReaderT env $ runExceptT (performCombinedIO6 "Joe")
- res2 <- flip runReaderT env $ runExceptT (performCombinedIO6 "Fred")
- res3 <- flip runReaderT env $ runExceptT (performCombinedIO6 "unknown")
- print res1
- print res2
- print res3
- ----------------------------------
- ---- MTL Style Round3: Purity ----
- ----------------------------------
- newtype AppM a = AppM { unAppM :: ExceptT SpaErrors (ReaderT Env IO) a}
- deriving (Functor, Applicative, Monad, MonadIO, MonadReader Env, MonadError SpaErrors)
- runAppM :: Env -> AppM a -> IO (Either SpaErrors a)
- runAppM env = flip runReaderT env . runExceptT . unAppM
- class Monad m => MonadDatabase m where
- readDatabase :: m Database
- instance (MonadIO m, MonadReader Env m) => MonadDatabase (ReaderT Env m) where
- readDatabase = do
- Connection m <- asks getDatabase
- db <- liftIO $ takeMVar m
- liftIO $ putMVar m db
- return db
- class Monad m => MonadTemp m where
- setTemp :: TempPreference -> m ()
- checkTemp :: m TempPreference
- instance (MonadIO m, MonadReader Env m) => MonadTemp (ReaderT Env m) where
- setTemp newTemp = do
- TempController m <- asks getTempControl
- _ <- liftIO $ takeMVar m
- liftIO $ putMVar m newTemp
- return ()
- checkTemp = do
- TempController m <- asks getTempControl
- temp <- liftIO $ takeMVar m
- liftIO $ putMVar m temp
- return temp
- -- This function can no longer do arbitary IO or asks
- getUserFromDb7 ::
- ( MonadError SpaErrors m
- , MonadDatabase m
- ) => Name -> m User
- getUserFromDb7 name = do
- db <- readDatabase
- case M.lookup name db of
- Just user -> return user
- Nothing -> throwError . DbErr $ NoSuchUser
- -- Kinda silly function now that its all been moved to the class instance.
- -- However, the point is that all the specific sideeffects have been enumerated
- -- and GHC wont let this function do anything other then what is specified by
- -- MonadTemp.
- setServerTemp7 ::
- MonadTemp m => TempPreference -> m ()
- setServerTemp7 = setTemp
- checkServerTemp7 ::
- ( MonadError SpaErrors m
- , MonadTemp m
- ) => m String
- checkServerTemp7 = do
- tc <- checkTemp
- if tc > 100
- then throwError . SaunaErr $ SaunaTooHot
- else return "New temp set"
- -- This function can do anything baked into AppM:
- performCombinedIO7 :: Name -> AppM String
- performCombinedIO7 user = do
- User _ temp <- getUserFromDb5 user
- setServerTemp5 temp
- checkServerTemp5
- main7 :: IO ()
- main7 = do
- db <- newMVar database
- tc <- newMVar 75
- -- Our External Services:
- let dbConn = Connection db
- let tempCont = TempController tc
- let env = Env dbConn tempCont
- -- 3 examples to demonstrate the handling of the Lefts and Right
- res1 <- runAppM env (performCombinedIO7 "Joe")
- res2 <- runAppM env (performCombinedIO7 "Fred")
- res3 <- runAppM env (performCombinedIO7 "unknown")
- print res1
- print res2
- print res3
- forallTest :: forall m. (MonadTemp m) => m ()
- forallTest =
- let g :: TempPreference -> m ()
- g = setTemp
- in return ()
- --f :: IO (Either () Bool)
- --f :: ExceptT () IO Bool
- f :: (MonadIO m, MonadError () m) => m Bool
- f = return True
- --g :: IO (Either () Bool)
- --g :: ExceptT () IO Bool
- g :: (MonadIO m, MonadError () m) => m Bool
- g = return True
- h :: (MonadIO m, MonadError () m) => m Bool
- h = do
- f' <- f
- g' <- g
- return $ f' && g'
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement