calculus/Control/Monad/Classes/StateFix.hs

   1 {-# LANGUAGE DataKinds #-}
   2 {-# LANGUAGE DeriveFunctor #-}
   3 {-# LANGUAGE ConstraintKinds #-}
   4 {-# LANGUAGE EmptyDataDecls #-}
   5 {-# LANGUAGE FlexibleContexts #-}
   6 {-# LANGUAGE FlexibleInstances #-}
   7 {-# LANGUAGE KindSignatures #-}
   8 {-# LANGUAGE MagicHash #-}
   9 {-# LANGUAGE MultiParamTypeClasses #-}
  10 {-# LANGUAGE ScopedTypeVariables #-}
  11 {-# LANGUAGE TypeFamilies #-}
  12 {-# LANGUAGE TypeOperators #-}
  13 module Control.Monad.Classes.StateFix where
  14 -- | 'MonadState' whose state is parameterized by the 'Monad' stack.
  15
  16 import Control.Applicative (Applicative(..))
  17 import Control.Monad
  18 import Control.Monad.Classes
  19 import Control.Monad.Classes.EffectsFix
  20 import Control.Monad.Trans.Class
  21 import qualified Control.Monad.Trans.State.Lazy as SL
  22 -- import qualified Control.Monad.Trans.State.Strict as SS -- TODO: when needed :)
  23 import Data.Bool (Bool(..))
  24 import Data.Function ((.))
  25 import Data.Functor.Identity (Identity)
  26 import GHC.Prim (Proxy#, proxy#)
  27 import Prelude (seq)
  28
  29 -- * Type 'StateLazyFixT'
  30
  31 data StateLazyFixT
  32  (st::{-StateLazyFixT st m-}(* -> *) -> *)
  33  (m::{-a-}* -> *)
  34  (a:: *)
  35  =   StateLazyFixT
  36  { unStateLazyFixT :: SL.StateT (st (StateLazyFixT st m)) m a }
  37  deriving (Functor)
  38 instance Monad m => Applicative (StateLazyFixT st m) where
  39         pure = return
  40         (<*>) = ap
  41 instance Monad m => Monad (StateLazyFixT st m) where
  42         return  = StateLazyFixT . return
  43         m >>= f = StateLazyFixT (unStateLazyFixT m >>= unStateLazyFixT . f)
  44 instance MonadTrans (StateLazyFixT st) where
  45         lift = StateLazyFixT . lift
  46
  47 -- ** Type 'StateLazyFix'
  48 type StateLazyFix  st
  49  =   StateLazyFixT st Identity
  50
  51 -- * Type family 'StateFixCanDo'
  52
  53 type instance CanDo (StateLazyFixT s m) eff
  54  = StateFixCanDo s eff
  55
  56 type family StateFixCanDo s eff where
  57         StateFixCanDo s (EffStateFix s)  = 'True
  58         StateFixCanDo s (EffReaderFix s) = 'True
  59         StateFixCanDo s (EffLocalFix s)  = 'True
  60         StateFixCanDo s (EffWriterFix s) = 'True
  61         StateFixCanDo s eff              = 'False
  62
  63 -- * Class 'MonadStateFixN'
  64
  65 class Monad m => MonadStateFixN (n :: Peano) s m where
  66         stateFixN :: Proxy# n -> (s m -> (a, s m)) -> m a
  67
  68 -- | Warning: only work when 'StateLazyFixT'
  69 -- is the outermost 'Monad' (i.e. when @n@ @~@ 'Zero'),
  70 -- because the state is paramaterized by this 'Monad'.
  71 instance Monad m => MonadStateFixN 'Zero s (StateLazyFixT s m) where
  72         stateFixN _ = StateLazyFixT . SL.state
  73
  74 -- ** Type 'MonadStateFixN'
  75
  76 -- | The @'MonadStateFix' s m@ constraint asserts that @m@ is a 'Monad' stack
  77 -- that supports state operations on type @s@
  78 type MonadStateFix (s::(* -> *) -> *) m
  79  =   MonadStateFixN (Find (EffStateFix s) m) s m
  80
  81 -- | Construct a state 'Monad' computation from a function
  82 stateFix
  83  :: forall s m a. (MonadStateFix s m)
  84  => (s m -> (a, s m)) -> m a
  85 stateFix = stateFixN (proxy# :: Proxy# (Find (EffStateFix s) m))
  86
  87 -- | @'put' s@ sets the state within the 'Monad' to @s@
  88 putFix :: MonadStateFix s m => s m -> m ()
  89 putFix s = stateFix (\_ -> ((), s))
  90
  91 -- | Fetch the current value of the state within the 'Monad'
  92 getFix :: MonadStateFix s m => m (s m)
  93 getFix = stateFix (\s -> (s, s))
  94
  95 -- | Gets specific component of the state,
  96 -- using a projection function supplied.
  97 getsFix :: MonadStateFix s m => (s m -> a) -> m a
  98 getsFix f = do
  99         s <- getFix
 100         return (f s)
 101
 102 -- | Maps an old state to a new state inside a state 'Monad' layer
 103 modifyFix :: MonadStateFix s m => (s m -> s m) -> m ()
 104 modifyFix f = stateFix (\s -> ((), f s))
 105
 106 -- | A variant of 'modify' in which the computation
 107 -- is strict in the new state.
 108 modifyFix' :: MonadStateFix s m => (s m -> s m) -> m ()
 109 modifyFix' f = stateFix (\s -> let s' = f s in s' `seq` ((), s'))
 110
 111 -- Return the 'Monad' parameter and the state.
 112 runStateLazyFix
 113  :: st (StateLazyFixT st m)
 114  ->     StateLazyFixT st m  a
 115  ->                      m (a, st (StateLazyFixT st m))
 116 runStateLazyFix s m = SL.runStateT (unStateLazyFixT m) s
 117
 118 -- Return the 'Monad' parameter.
 119 evalStateLazyFix
 120  :: Monad m
 121  => st (StateLazyFixT st m)
 122  ->     StateLazyFixT st m a
 123  ->                      m a
 124 evalStateLazyFix s m = SL.evalStateT (unStateLazyFixT m) s
 125
 126 -- Return the state.
 127 execStateLazyFix
 128  :: Monad m
 129  => st (StateLazyFixT st m)
 130  ->     StateLazyFixT st m a
 131  ->                      m (st (StateLazyFixT st m))
 132 execStateLazyFix s m = SL.execStateT (unStateLazyFixT m) s