Reader.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}

-- | Example uses and instances of the @HasReader@ capability.
module Reader where

import Capability.Reader
import Capability.Source
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader (ReaderT (..))
import Data.Kind (Type)
import GHC.Generics (Generic)
import Test.Common
import Test.Hspec

data Foo
data Bar

type instance TypeOf Type Foo = Int
type instance TypeOf Type Bar = Int

----------------------------------------------------------------------
-- Example Programs

-- | Returns the triple of the number in context "foo".
tripleFoo :: HasReader' Foo m => m Int
tripleFoo = do
  single <- ask @Foo
  double <- asks @Foo (*2)
  pure $ single + double

-- | Prints the triple and sixfold of the number in context "foo".
fooExample :: (HasReader' Foo m, MonadIO m) => m ()
fooExample = do
  liftIO . print =<< tripleFoo
  liftIO . print =<< local @Foo (*2) tripleFoo


-- | Prints the double of "bar" and the triple of "foo".
fooBarExample
  :: (HasReader' Foo m, HasReader' Bar m, MonadIO m) => m ()
fooBarExample = do
  local @Bar (*2) $ do
    liftIO . print =<< ask @Bar
    liftIO . print =<< tripleFoo

-- | Shows the interaction between 'local' and 'magnify'.
fooBarMagnify
  :: (HasReader "foobar" FooBar m, MonadIO m) => m ()
fooBarMagnify = do
  magnify
    @"foo"
    @(Field "foo" "foobar")
    @('[HasReader "foobar" FooBar, MonadIO]) $ do
      FooBar a b <- local @"foo" (const 5) (ask @"foobar")
      c <- local @"foobar" (const $ FooBar 3 4) (ask @"foo")
      liftIO $ print ((a, b), c)

----------------------------------------------------------------------
-- Instances

-- | @HasReader@ instance derived via @MonadReader@.
newtype FooReaderT m (a :: Type) = FooReaderT (ReaderT Int m a)
  deriving (Functor, Applicative, Monad, MonadIO)
  deriving (HasSource Foo Int) via MonadReader (ReaderT Int m)
  deriving (HasReader Foo Int) via MonadReader (ReaderT Int m)

runFooReaderT :: FooReaderT m a -> m a
runFooReaderT (FooReaderT m) = runReaderT m 1


data FooBar = FooBar
  { foo :: Int
  , bar :: Int
  } deriving Generic

-- | Multiple @HasReader@ instances derived via record fields in @MonadReader@.
newtype FooBarReader a = FooBarReader (ReaderT FooBar IO a)
  deriving (Functor, Applicative, Monad, MonadIO)
  deriving (HasSource "foobar" FooBar, HasReader "foobar" FooBar) via
    (MonadReader (ReaderT FooBar IO))
  deriving (HasSource Foo Int, HasReader Foo Int) via
    Rename "foo" (Field "foo" () (MonadReader (ReaderT FooBar IO)))
  deriving (HasSource Bar Int, HasReader Bar Int) via
    Rename "bar" (Field "bar" () (MonadReader (ReaderT FooBar IO)))

runFooBarReader :: FooBarReader a -> IO a
runFooBarReader (FooBarReader m) = runReaderT m FooBar { foo = 1, bar = 2 }


-- | Multiple @HasReader@ instances on the same underlying @MonadReader@.
--
-- Demonstrates colliding instances.
-- Note, do not do this in practice. The derived @HasReader@ instances interact
-- in unexpected ways.
newtype BadFooBarReader a = BadFooBarReader (ReaderT Int IO a)
  deriving (Functor, Applicative, Monad, MonadIO)
  deriving (HasSource Foo Int, HasReader Foo Int)
    via MonadReader (ReaderT Int IO)
  deriving (HasSource Bar Int, HasReader Bar Int)
    via MonadReader (ReaderT Int IO)

runBadFooBarReader :: BadFooBarReader a -> IO a
runBadFooBarReader (BadFooBarReader m) = runReaderT m 1


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

spec :: Spec
spec = do
  describe "FooReaderT" $
    it "evaluates fooExample" $
      runFooReaderT fooExample `shouldPrint` "3\n6\n"
  describe "FooBarReader" $ do
    it "evaluates fooExample" $
      runFooBarReader fooExample `shouldPrint` "3\n6\n"
    it "evaluates fooBarExample" $
      runFooBarReader fooBarExample `shouldPrint` "4\n3\n"
    it "evaluates fooBarMagnify" $
      runFooBarReader fooBarMagnify `shouldPrint` "((5,2),3)\n"
  describe "BadFooBarReader" $ do
    it "evaluates fooExample" $
      runBadFooBarReader fooExample `shouldPrint` "3\n6\n"
    it "evaluates fooBarExample" $
      runBadFooBarReader fooBarExample `shouldNotPrint` "4\n3\n"