calculus/Control/Monad/Classes/StateInstance.hs

   1 {-# LANGUAGE ConstraintKinds #-}
   2 {-# LANGUAGE DataKinds #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# LANGUAGE FlexibleInstances #-}
   5 {-# LANGUAGE MagicHash #-}
   6 {-# LANGUAGE MultiParamTypeClasses #-}
   7 {-# LANGUAGE PolyKinds #-}
   8 {-# LANGUAGE ScopedTypeVariables #-}
   9 {-# LANGUAGE TypeFamilies #-}
  10 {-# LANGUAGE TypeOperators #-}
  11 {-# LANGUAGE UndecidableInstances #-} -- NOTE: for CansMonadStateInstance
  12 module Control.Monad.Classes.StateInstance where
  13 -- | Collect in a 'Monad' stack, the states of 'MC.MonadState' 'Monad'
  14 -- which are instances of a given type class.
  15
  16 import Control.Monad
  17 import qualified Control.Monad.Classes as MC
  18 import Control.Monad.Classes.Instance
  19 import Control.Monad.Trans.Class
  20 import qualified Control.Monad.Trans.State.Lazy as SL
  21 import qualified Control.Monad.Trans.State.Strict as SS
  22 import Data.Bool (Bool(..))
  23 import GHC.Prim (Proxy#, proxy#, Constraint)
  24
  25 -- * Class 'MonadStateInstance'
  26
  27 -- ** Type family 'CanMonadStateInstance'
  28
  29 -- | An close type family to know whether a 'Monad' @m@
  30 -- support an effect 'eff' whose state is an instance of the type class @cl@.
  31 --
  32 -- NOTE: the closeness enables to define 'Class' instances
  33 -- only for the states of the 'Monad's in a 'Monad' stack
  34 -- which support the effects 'MC.EffState' or 'MC.EffReader'.
  35 type family CanMonadStateInstance (cl:: * -> Constraint) (m:: * -> *) (eff:: k) :: Bool where
  36         CanMonadStateInstance cl (SL.StateT s m) (MC.EffState  _s) = Class cl s
  37         CanMonadStateInstance cl (SS.StateT s m) (MC.EffState  _s) = Class cl s
  38         -- CanMonadStateInstance cl (SL.StateT s m) (MC.EffReader _s) = Class cl s
  39         -- CanMonadStateInstance cl (SS.StateT s m) (MC.EffReader _s) = Class cl s
  40         CanMonadStateInstance cl s eff = 'False
  41
  42 -- ** Type family 'CansMonadStateInstance'
  43
  44 -- | A close type family to know which 'Monad's in a 'Monad' stack @stack@
  45 -- support an effect 'eff' whose state is an instance of the type class @cl@.
  46 type family CansMonadStateInstance (cl:: * -> Constraint) (eff :: k) (stack :: * -> *) :: [Bool] where
  47         CansMonadStateInstance cl eff (t m) = CanMonadStateInstance cl (t m) eff ': CansMonadStateInstance cl eff m
  48         CansMonadStateInstance cl eff m     = CanMonadStateInstance cl m     eff ': '[]
  49
  50 -- | A type synonym to constrain a 'Monad' @m@
  51 -- to support an 'MC.EffState' whose state is an instance of the type class @cl@.
  52 type MonadStateInstance cl m
  53  =   MonadStateInstanceN cl (CansMonadStateInstance cl (MC.EffState ()) m) m
  54
  55 getInstance :: forall cl m. MonadStateInstance cl m => m [Instance cl]
  56 getInstance = getInstanceN (proxy# :: Proxy# (CansMonadStateInstance cl (MC.EffState ()) m))
  57
  58 -- ** Class 'MonadStateInstanceN'
  59
  60 -- | A type class to recurse over the 'Monad' stack
  61 -- to collect the states which are instance of the type class @cl@.
  62 class Monad m => MonadStateInstanceN cl (cans::[Bool]) m where
  63         getInstanceN :: Proxy# cans -> m [Instance cl]
  64
  65 -- | Collect the lazy 'SL.StateT', and recurse.
  66 instance (cl s, Monad m, MonadStateInstanceN cl cans m)
  67  => MonadStateInstanceN cl ('True ': cans) (SL.StateT s m) where
  68         getInstanceN _ = do
  69                 s <- SL.get
  70                 ss <- lift (getInstanceN (proxy# :: Proxy# cans))
  71                 return (Instance s : ss)
  72
  73 -- | Collect the strict 'SS.StateT', and recurse.
  74 instance (cl s, Monad m, MonadStateInstanceN cl cans m)
  75  => MonadStateInstanceN cl ('True ': cans) (SS.StateT s m) where
  76         getInstanceN _ = do
  77                 s <- SS.get
  78                 ss <- lift (getInstanceN (proxy# :: Proxy# cans))
  79                 return (Instance s : ss)
  80
  81 -- | Recurse the 'Monad' stack, passing over 'Monad' @t m@
  82 -- such that 'CanMonadStateInstance' @cl@ @t m@ @MC.EffState ()@ @~@ 'False'.
  83 instance
  84  ( Monad m
  85  , Monad (t m)
  86  , MonadTrans t
  87  , MonadStateInstanceN cl cans m
  88  ) => MonadStateInstanceN cl ('False ': cans) (t m) where
  89         getInstanceN _ = lift (getInstanceN (proxy# :: Proxy# cans))
  90
  91 -- | Terminating instance, when the deepest 'Monad' on the stack
  92 -- is such that 'CanMonadStateInstance' @cl@ @t m@ @MC.EffState ()@ @~@ 'False':
  93 -- then there is no need to recurse,
  94 -- and thus no 'MonadStateInstanceN' @cl@ @[]@ @m@ constraint to impose.
  95 instance Monad m => MonadStateInstanceN cl ('False ': '[]) m where
  96         getInstanceN _ = return []