CountLog.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Demonstrates how to derive user-defined capabilities using this library.
module CountLog where

import Capability.Reader
import Capability.State
import Control.Monad.IO.Class
import Control.Monad.Reader (ReaderT (..), runReaderT)
-- The @StateT@ constructor has to be imported even though it is not used
-- explicitly. Otherwise, the deriving via of @Counter CounterM@ would fail.
import Control.Monad.State.Strict (State, StateT (..), runState)
import qualified Data.Char
import Data.Coerce (coerce)
import Data.IORef
import Data.Kind (Type)
import GHC.Generics (Generic)
import Test.Common
import Test.Hspec


----------------------------------------------------------------------
-- Logger Capability


class Monad m => Logger m where
  logStr :: String -> m ()

-- | Any @HasReader "logger" (String -> IO ())@ can be a @Logger@.
newtype TheLoggerReader m a = TheLoggerReader (m a)
  deriving (Functor, Applicative, Monad)
instance
  (HasReader "logger" (String -> IO ()) m, MonadIO m)
  => Logger (TheLoggerReader m)
  where
    logStr msg =
      coerce (ask @"logger" >>= liftIO . ($ msg) :: m ())

-- Example program ---------------------------------------------------

-- | Log the given number.
logNum :: Logger m => Int -> m ()
logNum = logStr . ("num: " ++) . show

-- ReaderT instance --------------------------------------------------

data LogCtx = LogCtx { logger :: String -> IO () }
  deriving Generic

regularLogger :: LogCtx
regularLogger = LogCtx { logger = putStrLn }

loudLogger :: LogCtx
loudLogger = LogCtx { logger = putStrLn . map Data.Char.toUpper }


-- | Deriving @HasReader@ from @MonadReader@.
newtype LogM m (a :: Type) = LogM (ReaderT LogCtx m a)
  deriving (Functor, Applicative, Monad)
  deriving Logger via
    (TheLoggerReader (Field "logger" ()
    (MonadReader (ReaderT LogCtx m))))

runLogM :: LogCtx -> LogM m a -> m a
runLogM ctx (LogM m) = runReaderT m ctx


----------------------------------------------------------------------
-- Counter Capability


class Monad m => Counter m where
  count :: m Int

-- | Any @HasState "counter" Int m@ can be a @Counter@.
newtype TheCounterState m a = TheCounterState (m a)
  deriving (Functor, Applicative, Monad)
instance
  (HasState "counter" Int m, Monad m)
  => Counter (TheCounterState m)
  where
    count = coerce @(m Int) $
      state @"counter" $ \n -> let !n' = n + 1 in (n', n')

-- Example program ---------------------------------------------------

-- | Use a counter to count up twice.
doubleCount :: Counter m => m Int
doubleCount = count >> count

-- StateT instance ---------------------------------------------------

-- | Deriving @HasState@ from @MonadState@.
newtype CounterM a = CounterM (State Int a)
  deriving (Functor, Applicative, Monad)
  deriving Counter via
    TheCounterState (MonadState (State Int))

runCounterM :: CounterM a -> (a, Int)
runCounterM (CounterM m) = runState m 0

-- ReaderT IORef instance --------------------------------------------

-- | Deriving @HasState@ from @HasReader@ of an @IORef@.
newtype Counter'M m (a :: Type) = Counter'M (ReaderT (IORef Int) m a)
  deriving (Functor, Applicative, Monad)
  deriving Counter via
    TheCounterState (ReaderIORef (MonadReader (ReaderT (IORef Int) m)))

runCounter'M :: MonadIO m => Counter'M m a -> m a
runCounter'M (Counter'M m) = runReaderT m =<< liftIO (newIORef 0)


----------------------------------------------------------------------
-- Mixed Capabilities

-- Example program ---------------------------------------------------

-- | Double count and log the result, repeat once.
mixed :: (Counter m, Logger m) => m ()
mixed = do
  doubleCount >>= logNum
  doubleCount >>= logNum

-- ReaderT instance --------------------------------------------------

data CountLogCtx = CountLogCtx
  { countCtx :: IORef Int
  , logCtx :: LogCtx
  } deriving Generic


-- | Deriving two capabilities from the record fields of @MonadReader@.
newtype CountLogM m (a :: Type) = CountLogM (ReaderT CountLogCtx m a)
  deriving (Functor, Applicative, Monad)
  deriving Counter via
    TheCounterState (ReaderIORef (Rename "countCtx" (Field "countCtx" ()
    (MonadReader (ReaderT CountLogCtx m)))))
  deriving Logger via
    (TheLoggerReader (Field "logger" "logCtx" (Field "logCtx" ()
    (MonadReader (ReaderT CountLogCtx m)))))

runCountLogM :: MonadIO m => CountLogM m b -> m b
runCountLogM (CountLogM m) = do
  ref <- liftIO $ newIORef 0
  runReaderT m CountLogCtx
    { countCtx = ref
    , logCtx = regularLogger
    }


----------------------------------------------------------------------
-- Test Cases

spec :: Spec
spec = do
  describe "LogM" $ do
    context "regularLogger" $
      it "evaluates logNum" $
        runLogM regularLogger (logNum 8) `shouldPrint` "num: 8\n"
    context "loudLogger" $
      it "evaluates logNum" $
        runLogM loudLogger (logNum 8) `shouldPrint` "NUM: 8\n"
  describe "CounterM" $
    it "evaluates doubleCount" $
      runCounterM doubleCount `shouldBe` (2, 2)
  describe "Counter'M" $
    it "evaluates doubleCount" $
      runCounter'M doubleCount `shouldReturn` 2
  describe "CountLogM" $ do
    it "evaluates logNum" $
      runCountLogM (logNum 8) `shouldPrint` "num: 8\n"
    it "evaluates doubleCount" $
      runCountLogM doubleCount `shouldReturn` 2
    it "evaluates mixed" $
      runCountLogM mixed `shouldPrint` "num: 2\nnum: 4\n"