{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeApplications #-}

import Control.Monad.Reader (ReaderT, runReaderT)
import Control.Monad.State  (StateT, evalStateT)
import Control.Monad        (void)


data Msg = Msg {_payload :: MsgPayload}

data MsgPayload
    = FooMsgPayload' FooMsgPayload
    | BarMsgPayload' BarMsgPayload
    | ZzzMsgPayload' ZzzMsgPayload

data FooMsgPayload = FooMsgA String | FooMsgB (Int, Int)
data BarMsgPayload = BarMsgA Double
data ZzzMsgPayload = ZzzMsgA | ZzzMsgB (Char -> Char) | ZzzMsgC

class IsMsgPayload a where
    toMsgPayload :: a -> MsgPayload

instance IsMsgPayload FooMsgPayload where
    toMsgPayload = FooMsgPayload'
instance IsMsgPayload BarMsgPayload where
    toMsgPayload = BarMsgPayload'
instance IsMsgPayload ZzzMsgPayload where
    toMsgPayload = ZzzMsgPayload'

class Monad m => MsgsRead m where
    readMsgPayloads :: IsMsgPayload a => m [a]
class Monad m => MsgsWrite m where
    writeMsgs :: [Msg] -> m ()

initMsg :: IsMsgPayload a => a -> Msg
initMsg payload = Msg (toMsgPayload payload)


newtype AppEnv a = AppEnv (ReaderT () (StateT () IO) a)  -- pretend the () are useful types
    deriving (Functor, Applicative, Monad)

instance MsgsRead AppEnv where
    readMsgPayloads = return []  -- implementation omitted
instance MsgsWrite AppEnv where
    writeMsgs _ = return ()      -- implementation omitted

runAppEnv :: AppEnv () -> IO ()
runAppEnv (AppEnv appEnv) = evalStateT (runReaderT appEnv ()) ()


data AllowFooZzzMsgs  -- only allow FooMsgPayload/ZzzMsgPayload messages
data AllowBarMsgs     -- only allow BarMsgPayload messages

newtype RMsg r = RMsg Msg  -- r is a phantom type

class IsMsgPayload a => RIsMsgPayloadRead r a where
class IsMsgPayload a => RIsMsgPayloadWrite r a where

instance RIsMsgPayloadRead AllowBarMsgs BarMsgPayload where
instance RIsMsgPayloadWrite AllowFooZzzMsgs FooMsgPayload where
instance RIsMsgPayloadWrite AllowFooZzzMsgs ZzzMsgPayload where

class MsgsRead m => RMsgsRead r m where
    rReadMsgPayloads :: RIsMsgPayloadRead r a => m [a]
    rReadMsgPayloads = readMsgPayloads

class MsgsWrite m => RMsgsWrite r m where
    rWriteMsgs :: [RMsg r] -> m ()
    rWriteMsgs msgs = writeMsgs [msg | RMsg msg <- msgs]

initRMsg :: RIsMsgPayloadWrite r a => a -> RMsg r
initRMsg payload = RMsg (initMsg payload)

-- AppEnv is allowed to read/write any message if no RIsMsgPayloadRead/RIsMsgPayloadWrite constraints are specified
instance RMsgsRead AllowFooZzzMsgs AppEnv
instance RMsgsRead AllowBarMsgs AppEnv
instance RMsgsWrite AllowFooZzzMsgs AppEnv
instance RMsgsWrite AllowBarMsgs AppEnv


f1 :: forall m. MsgsRead m => m ()
f1 = void (readMsgPayloads :: m [FooMsgPayload])

f2 :: MsgsWrite m => m ()
f2 = writeMsgs [initMsg ZzzMsgA]

f3 :: forall m. (MsgsRead m, MsgsWrite m) => m ()
f3 = do
    void (readMsgPayloads :: m [BarMsgPayload])
    writeMsgs [initMsg ZzzMsgC]

rF1 :: forall m. RMsgsRead AllowBarMsgs m => m ()
rF1 = void (rReadMsgPayloads @AllowBarMsgs :: m [BarMsgPayload])

rF2 :: RMsgsWrite AllowFooZzzMsgs m => m ()
rF2 = rWriteMsgs @AllowFooZzzMsgs [initRMsg ZzzMsgA]

main :: IO ()
main = do
    runAppEnv $ f1 >> f2 >> f3  -- pretend this is doing something useful
    runAppEnv $ rF1 >> rF2      -- pretend this is doing something useful