Component.hs

{-# language TypeFamilies #-}
{-# language TypeApplications #-}
{-# language ScopedTypeVariables #-}
{-# language MultiParamTypeClasses #-}
{-# language FlexibleInstances #-}
{-# language FlexibleContexts #-}
{-# language UndecidableInstances #-}
{-# language AllowAmbiguousTypes #-}
{-# language GeneralizedNewtypeDeriving #-}
{-# language DeriveFunctor #-}
{-# language StandaloneDeriving #-}
{-# language TypeOperators #-}

import Control.Monad.Except
import Control.Monad.RWS.Strict
import Control.Monad.Reader

-- | Abstracts away component capabilities.
class (Monad (BaseM comp), Monoid (Msgs comp)) => Component comp where
    data Error      comp :: *
    type Env        comp :: *
    type State      comp :: *
    type Msgs       comp :: *
    type BaseM      comp :: * -> *
    data ComponentM comp :: * -> *

    runComponentM
        :: ComponentM comp a
        -> Env   comp
        -> State comp
        -> BaseM comp
            ( Either (Error comp) a
            , State comp
            , Msgs  comp
            )

-- | The final component monad.
type ERWST e r w s m = ExceptT e (RWST r w s m)

runERWST :: ERWST e r w s m a -> r -> s -> m (Either e a, s, w)
runERWST = runRWST . runExceptT

eRWST :: (r -> s -> m (Either e a, s, w)) -> ERWST e r w s m a
eRWST = ExceptT . RWST

-- | Dumb naive component composer.
--   Its 'ComponentM' deliberately lacks any MonadReader/State/Writer/IO
--   instances.
data comp `Also` box

instance
    (Component comp, Component other, BaseM comp ~ BaseM other)
        =>
    Component (Also comp other)
  where
    data Error (Also comp other)
        = This (Error comp)
        | That (Error other)

    -- | I think, these can be done better.
    --   It should be possible to eliminame (* 1) type-ops here.
    type Env      (Also comp other) = (Env   comp, Env   other)
    type State    (Also comp other) = (State comp, State other)
    type Msgs     (Also comp other) = (Msgs  comp, Msgs  other)
    type BaseM    (Also comp other) = BaseM  comp

    -- | We have no other way, but make it the final monad here.
    newtype ComponentM (Also comp other) a = ComponentM
        { getComponentM :: ERWST
            (Error (Also comp other))
            (Env   (Also comp other))
            (Msgs  (Also comp other))
            (State (Also comp other))
            (BaseM (Also comp other))
             a
        }

    runComponentM  = runERWST . getComponentM
    
-- | Why does GHC ignores class constraints when deriving for newtype of type family?
deriving instance
    (Show (Error comp), Show (Error other), Component (Also comp other))
        =>
    (Show (Error (Also comp other)))

deriving instance
    (Component (Also comp other))
        =>
    (Functor (ComponentM (Also comp other)))

deriving instance
    (Component (Also comp other))
        =>
    (Applicative (ComponentM (Also comp other)))

deriving instance
    (Component (Also comp other))
        =>
    (Monad (ComponentM (Also comp other)))

class
    (Component comp, Component box, BaseM comp ~ BaseM box)
        =>
    HasComponent path comp box
  where
    selectComponent :: ComponentM comp a -> ComponentM box a

-- | Component search path.
data Here
data There r
data Itself

-- | Component search.
type family Find a b where
    Find a (Also a _) = Here
    Find a (Also _ r) = There (Find a r)
    Find a  a         = Itself

-- | Extraction of head component.
instance
    (Component comp, Component other, BaseM comp ~ BaseM other, comp ~ comp')
        =>
    HasComponent Here comp (Also comp' other)
  where
    selectComponent comp = ComponentM . eRWST $ \(env, _) (st, st') -> do
        (it, st1, msgs) <- runComponentM comp env st
        let
          res = case it of
            Left err -> Left (This err)
            Right a  -> Right a
        return (res, (st1, st'), (msgs, mempty))

-- | Extraction of component from tail.
instance
    (HasComponent path comp rest, BaseM comp' ~ BaseM rest, Component comp', Component rest)
        =>
    HasComponent (There path) comp (Also comp' rest)
  where
    selectComponent comp = ComponentM . eRWST $ \(_, env) (st', st) -> do
        (it, st1, msgs) <- runComponentM (selectComponent @path comp) env st
        let
          res = case it of
            Left err -> Left (That err)
            Right a  -> Right a
        return (res, (st', st1), (mempty, msgs))

-- | Extraction of component from itself.
instance
    Component comp
        =>
    HasComponent Itself comp comp
  where
    selectComponent = id

-- | If box has a component, transform component action to whole-box action.
select :: forall comp box a . HasComponent (Find comp box) comp box => ComponentM comp a -> ComponentM box a
select = selectComponent @(Find comp box)

-- | Examples: Database.
data DbComponent

instance Component DbComponent where
    data Error DbComponent
        = NoKey String
        | NoDb  String
        deriving Show

    type Env DbComponent = (String, Int)
    type State DbComponent = ()
    type Msgs DbComponent = ()
    type BaseM DbComponent = IO

    newtype ComponentM DbComponent a = DbComponentM
        { getDbComponentM
            :: ExceptT (Error DbComponent)
            (  ReaderT (Env  DbComponent)
            (  BaseM DbComponent
            )) a
        }
        deriving (Functor, Applicative, Monad, MonadIO, MonadError (Error DbComponent))

    runComponentM  = runERT . getDbComponentM
      where
        runERT action env st = do
            res <- runExceptT action `runReaderT` env
            return (res, st, mempty)

deriving instance MonadReader (String, Int) (ComponentM DbComponent)

-- | Sorry, database is out for dinner.
query :: HasComponent (Find DbComponent box) DbComponent box => String -> ComponentM box ()
query msg = do
    select @DbComponent $ do
        throwError $ NoKey msg
    
-- | A logger.
data LogComponent

instance Component LogComponent where
    data Error LogComponent = Nope
        deriving Show

    type Env   LogComponent = (Float)
    type State LogComponent = ()
    type Msgs  LogComponent = ()
    type BaseM LogComponent = IO

    newtype ComponentM LogComponent a = LogComponentM
        { getLogComponentM 
            :: ReaderT (Env LogComponent) 
              (BaseM LogComponent)
               a
        }
        deriving (Functor, Applicative, Monad, MonadIO)

    runComponentM  = runRT . getLogComponentM
      where
        runRT action env st = do
            res <- runReaderT action env
            return (Right res, st, mempty)            

deriving instance MonadReader Float (ComponentM LogComponent)

info :: HasComponent (Find LogComponent box) LogComponent box => String -> ComponentM box ()
info msg = do
    select @LogComponent $ do
        float <- ask
        liftIO $ print ("INFO", float, msg)

-- | Whole-box
type App = DbComponent `Also` LogComponent

main = print =<< runComponentM @App action (("foo", 42), 0.5) ((), ())
  where
    -- Usage. Notice: all monad stack are concrete; specialise if you want!
    action = do
        info "Logger online"
        query "foo"
        info "Shouldn't be printed"