{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
module Raaz.Core.MonoidalAction
(
LAction (..), Distributive, SemiR (..), semiRSpace, semiRMonoid
, LActionF(..), DistributiveF, TwistRF(..), twistFunctorValue, twistMonoidValue
, FieldA, FieldM, Field, computeField, runFieldM, liftToFieldM
) where
import Control.Arrow
import Raaz.Core.Prelude
import Raaz.Core.Types.Pointer
class Monoid m => LAction m space where
(<.>) :: m -> space -> space
infixr 5 <.>
class (Monoid m, Functor f) => LActionF m f where
(<<.>>) :: m -> f a -> f a
infixr 5 <<.>>
class (LAction m space, Monoid space) => Distributive m space
data SemiR space m = SemiR space !m
instance Distributive m space => Semigroup (SemiR space m) where
<> :: SemiR space m -> SemiR space m -> SemiR space m
(<>) (SemiR space
x m
a) (SemiR space
y m
b) = space -> m -> SemiR space m
forall space m. space -> m -> SemiR space m
SemiR (space
x space -> space -> space
forall a. Monoid a => a -> a -> a
`mappend` (m
a m -> space -> space
forall m space. LAction m space => m -> space -> space
<.> space
y)) (m
a m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` m
b)
instance Distributive m space => Monoid (SemiR space m) where
mempty :: SemiR space m
mempty = space -> m -> SemiR space m
forall space m. space -> m -> SemiR space m
SemiR space
forall a. Monoid a => a
mempty m
forall a. Monoid a => a
mempty
{-# INLINE mempty #-}
mappend :: SemiR space m -> SemiR space m -> SemiR space m
mappend = SemiR space m -> SemiR space m -> SemiR space m
forall a. Semigroup a => a -> a -> a
(<>)
{-# INLINE mappend #-}
semiRSpace :: SemiR space m -> space
{-# INLINE semiRSpace #-}
semiRSpace :: forall space m. SemiR space m -> space
semiRSpace (SemiR space
space m
_) = space
space
semiRMonoid :: SemiR space m -> m
{-# INLINE semiRMonoid #-}
semiRMonoid :: forall space m. SemiR space m -> m
semiRMonoid (SemiR space
_ m
m) = m
m
class (Applicative f, LActionF m f) => DistributiveF m f
data TwistRF f m a = TwistRF (f a) !m
twistFunctorValue :: TwistRF f m a -> f a
twistFunctorValue :: forall (f :: * -> *) m a. TwistRF f m a -> f a
twistFunctorValue (TwistRF f a
fa m
_) = f a
fa
{-# INLINE twistFunctorValue #-}
twistMonoidValue :: TwistRF f m a -> m
twistMonoidValue :: forall (f :: * -> *) m a. TwistRF f m a -> m
twistMonoidValue (TwistRF f a
_ m
m) = m
m
{-# INLINE twistMonoidValue #-}
instance Functor f => Functor (TwistRF f m) where
fmap :: forall a b. (a -> b) -> TwistRF f m a -> TwistRF f m b
fmap a -> b
f (TwistRF f a
x m
m) = f b -> m -> TwistRF f m b
forall (f :: * -> *) m a. f a -> m -> TwistRF f m a
TwistRF ((a -> b) -> f a -> f b
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f f a
x) m
m
instance DistributiveF m f => Applicative (TwistRF f m) where
pure :: forall a. a -> TwistRF f m a
pure a
a = f a -> m -> TwistRF f m a
forall (f :: * -> *) m a. f a -> m -> TwistRF f m a
TwistRF (a -> f a
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a) m
forall a. Monoid a => a
mempty
{-# INLINE pure #-}
(TwistRF f (a -> b)
f m
mf) <*> :: forall a b. TwistRF f m (a -> b) -> TwistRF f m a -> TwistRF f m b
<*> (TwistRF f a
val m
mval) = f b -> m -> TwistRF f m b
forall (f :: * -> *) m a. f a -> m -> TwistRF f m a
TwistRF f b
res m
mres
where res :: f b
res = f (a -> b)
f f (a -> b) -> f a -> f b
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m
mf m -> f a -> f a
forall a. m -> f a -> f a
forall m (f :: * -> *) a. LActionF m f => m -> f a -> f a
<<.>> f a
val
mres :: m
mres = m
mf m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` m
mval
type FieldA arrow = WrappedArrow arrow
type Field = FieldA (->)
computeField :: Field space b -> space -> b
computeField :: forall space b. Field space b -> space -> b
computeField = WrappedArrow (->) space b -> space -> b
forall (a :: * -> * -> *) b c. WrappedArrow a b c -> a b c
unwrapArrow
{-# INLINE computeField #-}
type FieldM monad = FieldA (Kleisli monad)
liftToFieldM :: (a -> m b) -> FieldM m a b
liftToFieldM :: forall a (m :: * -> *) b. (a -> m b) -> FieldM m a b
liftToFieldM = Kleisli m a b -> WrappedArrow (Kleisli m) a b
forall (a :: * -> * -> *) b c. a b c -> WrappedArrow a b c
WrapArrow (Kleisli m a b -> WrappedArrow (Kleisli m) a b)
-> ((a -> m b) -> Kleisli m a b)
-> (a -> m b)
-> WrappedArrow (Kleisli m) a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m b) -> Kleisli m a b
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli
{-# INLINE liftToFieldM #-}
runFieldM :: FieldM monad space b -> space -> monad b
runFieldM :: forall (monad :: * -> *) space b.
FieldM monad space b -> space -> monad b
runFieldM = Kleisli monad space b -> space -> monad b
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli (Kleisli monad space b -> space -> monad b)
-> (FieldM monad space b -> Kleisli monad space b)
-> FieldM monad space b
-> space
-> monad b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldM monad space b -> Kleisli monad space b
forall (a :: * -> * -> *) b c. WrappedArrow a b c -> a b c
unwrapArrow
{-# INLINE runFieldM #-}
instance (Arrow arrow, LAction m space) => LActionF m (WrappedArrow arrow space) where
m
m <<.>> :: forall a.
m -> WrappedArrow arrow space a -> WrappedArrow arrow space a
<<.>> WrappedArrow arrow space a
field = arrow space a -> WrappedArrow arrow space a
forall (a :: * -> * -> *) b c. a b c -> WrappedArrow a b c
WrapArrow (arrow space a -> WrappedArrow arrow space a)
-> arrow space a -> WrappedArrow arrow space a
forall a b. (a -> b) -> a -> b
$ WrappedArrow arrow space a -> arrow space a
forall (a :: * -> * -> *) b c. WrappedArrow a b c -> a b c
unwrapArrow WrappedArrow arrow space a
field arrow space a -> (space -> space) -> arrow space a
forall (a :: * -> * -> *) c d b.
Arrow a =>
a c d -> (b -> c) -> a b d
<<^ (m
mm -> space -> space
forall m space. LAction m space => m -> space -> space
<.>)
{-# INLINE (<<.>>) #-}
instance (Arrow arrow, LAction m space) => DistributiveF m (WrappedArrow arrow space)
instance LengthUnit u => LAction u (Ptr a) where
u
a <.> :: u -> Ptr a -> Ptr a
<.> Ptr a
ptr = Ptr a -> u -> Ptr a
forall l a. LengthUnit l => Ptr a -> l -> Ptr a
movePtr Ptr a
ptr u
a
{-# INLINE (<.>) #-}