Class.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}

{-# OPTIONS_HADDOCK hide #-}

module Capability.State.Internal.Class
  ( HasState(..)
  , get
  , put
  , state
  , modify
  , modify'
  , gets
  , zoom
  , Reified (..)
  ) where

import Capability.Constraints
import Capability.Derive (derive)
import Capability.Reflection
import Capability.Source.Internal.Class
import Capability.Sink.Internal.Class
import Data.Coerce (Coercible, coerce)
import Data.Kind (Type)
import GHC.Exts (Proxy#, proxy#)

-- | State capability
--
-- An instance should fulfill the following laws.
-- At this point these laws are not definitive,
-- see <https://github.com/haskell/mtl/issues/5>.
--
-- prop> get @t >>= \s1 -> get @t >>= \s2 -> pure (s1, s2) = get @t >>= \s -> pure (s, s)
-- prop> get @t >>= \_ -> put @t s = put @t s
-- prop> put @t s1 >> put @t s2 = put @t s2
-- prop> put @t s >> get @t = put @t s >> pure s
-- prop> state @t f = get @t >>= \s -> let (a, s') = f s in put @t s' >> pure a
class (Monad m, HasSource tag s m, HasSink tag s m)
  => HasState (tag :: k) (s :: Type) (m :: Type -> Type) | tag m -> s
  where
    -- | For technical reasons, this method needs an extra proxy argument.
    -- You only need it if you are defining new instances of 'HasState.
    -- Otherwise, you will want to use 'state'.
    -- See 'state' for more documentation.
    state_ :: Proxy# tag -> (s -> (a, s)) -> m a

-- | @get \@tag@
-- retrieve the current state of the state capability @tag@.
get :: forall tag s m. HasState tag s m => m s
get = await @tag
{-# INLINE get #-}

-- | @put \@tag s@
-- replace the current state of the state capability @tag@ with @s@.
put :: forall tag s m. HasState tag s m => s -> m ()
put = yield @tag
{-# INLINE put #-}

-- | @state \@tag f@
-- lifts a pure state computation @f@ to a monadic action in an arbitrary
-- monad @m@ with capability @HasState@.
--
-- Given the current state @s@ of the state capability @tag@
-- and @(a, s') = f s@, update the state to @s'@ and return @a@.
state :: forall tag s m a. HasState tag s m => (s -> (a, s)) -> m a
state = state_ (proxy# @tag)
{-# INLINE state #-}

-- | @modify \@tag f@
-- given the current state @s@ of the state capability @tag@
-- and @s' = f s@, updates the state of the capability @tag@ to @s'@.
modify :: forall tag s m. HasState tag s m => (s -> s) -> m ()
modify f = state @tag $ \s -> ((), f s)
{-# INLINE modify #-}

-- | Same as 'modify' but strict in the new state.
modify' :: forall tag s m. HasState tag s m => (s -> s) -> m ()
modify' f = do
  s' <- get @tag
  put @tag $! f s'
{-# INLINE modify' #-}

-- | @gets \@tag f@
-- retrieves the image, by @f@ of the current state
-- of the state capability @tag@.
--
-- prop> gets @tag f = f <$> get @tag
gets :: forall tag s m a. HasState tag s m => (s -> a) -> m a
gets f = do
  s <- get @tag
  pure (f s)
{-# INLINE gets #-}

-- | Execute the given state action on a sub-component of the current state as
-- defined by the given transformer @t@. The set of retained capabilities must
-- be passed as @cs. If no capabilities are required,
-- 'Capabilities.Constraints.None' can be used.
--
-- Examples:
--
-- > foo :: HasState "foo" Int m => m ()
-- > zoom @"foo" @(Field "foo" "foobar") @None foo
-- >   :: (HasField' "foobar" record Int, HasState "foobar" record m) => m ()
-- >
-- > zoom @"foo" @(Field "foo" "foobar") @('[MonadIO]) bar
-- >   :: ( HasField' "foobar" record Int, HasState "foobar" record m
-- >      , MonadIO m) => m ()
-- >
-- > foo :: HasState "foo" Int m => m ()
-- > bar :: (MonadIO m, HasState "foo" Int m) => m ()
--
-- Note: the 'Data.Generics.Product.Fields.HasField'' constraint comes from the
-- @generic-lens@ package.
--
-- This function is experimental and subject to change.
-- See <https://github.com/tweag/capability/issues/46>.
zoom :: forall innertag t (cs :: [Capability]) inner m a.
  ( forall x. Coercible (t m x) (m x)
  , HasState innertag inner (t m)
  , All cs m )
  => (forall m'. All (HasState innertag inner ': cs) m' => m' a) -> m a
zoom action =
  derive @t @'[HasState innertag inner] @cs action
{-# INLINE zoom #-}

--------------------------------------------------------------------------------

data instance Reified tag (HasState tag s) m = ReifiedState
  { _stateSource :: Reified tag (HasSource tag s) m,
    _stateSink :: Reified tag (HasSink tag s) m,
    _state :: forall a. (s -> (a, s)) -> m a
  }

instance
  ( Monad m,
    Reifies s' (Reified tag (HasState tag s) m)
  ) =>
  HasSource tag s (Reflected s' (HasState tag s) m)
  where
  await_ _ = coerce $ _await $ _stateSource $ reified @s'
  {-# INLINE await_ #-}

instance
  ( Monad m,
    Reifies s' (Reified tag (HasState tag s) m)
  ) =>
  HasSink tag s (Reflected s' (HasState tag s) m)
  where
  yield_ _ = coerce $ _yield $ _stateSink $ reified @s'
  {-# INLINE yield_ #-}

instance
  ( Monad m,
    Reifies s' (Reified tag (HasState tag s) m)
  ) =>
  HasState tag s (Reflected s' (HasState tag s) m)
  where
  state_ :: forall a. Proxy# tag -> (s -> (a, s)) -> Reflected s' (HasState tag s) m a
  state_ _ = coerce @((s -> (a, s)) -> m a) $ _state (reified @s')
  {-# INLINE state_ #-}