mirror of
https://github.com/coot/free-category.git
synced 2024-10-26 15:15:00 +03:00
Renamed API in Control.Category.FreeEff
Renamed `Control.Category.FreeEff` module as `Control.Category.FreeEffect` and renamed top level terms: - `EffCategory` type class to `EffectCategory` - `FreeEffCat` to `EffCat` - `FreeEffCat` constructor as `Effect` and `lift` as `effect` - `liftCat` to `liftEffect` - `foldNatLift` to `foldNatEffCat`
This commit is contained in:
parent
6786025a6f
commit
863bf9582e
@ -18,3 +18,10 @@
|
||||
|
||||
## Unreleased changes
|
||||
- hoistOp
|
||||
- Renamed `Control.Category.FreeEff` module as `Control.Category.FreeEffect`
|
||||
and renamed top level terms:
|
||||
- `EffCategory` type class to `EffectCategory`
|
||||
- `FreeEffCat` to `EffCat`
|
||||
- `FreeEffCat` constructor as `Effect` and `lift` as `effect`
|
||||
- `liftCat` to `liftEffect`
|
||||
- `foldNatLift` to `foldNatEffCat`
|
||||
|
@ -23,7 +23,7 @@ import Test.QuickCheck
|
||||
import Control.Category.Free (Cat)
|
||||
|
||||
-- Import classes and combintators used in this example
|
||||
import Control.Category.FreeEff
|
||||
import Control.Category.FreeEffect
|
||||
|
||||
{-------------------------------------------------------------------------------
|
||||
-- Example State Machine, inspired by:
|
||||
@ -74,17 +74,17 @@ data Tr a from to where
|
||||
|
||||
login :: Monad m
|
||||
=> SStateType st
|
||||
-> FreeEffCat m (Cat (Tr a)) (State a 'LoggedOutType) (State a st)
|
||||
login = liftCat . Login
|
||||
-> EffCat m (Cat (Tr a)) (State a 'LoggedOutType) (State a st)
|
||||
login = liftEffect . Login
|
||||
|
||||
logout :: Monad m
|
||||
=> Maybe a
|
||||
-> FreeEffCat m (Cat (Tr a)) (State a 'LoggedInType) (State a 'LoggedOutType)
|
||||
logout = liftCat . Logout
|
||||
-> EffCat m (Cat (Tr a)) (State a 'LoggedInType) (State a 'LoggedOutType)
|
||||
logout = liftEffect . Logout
|
||||
|
||||
access :: Monad m
|
||||
=> FreeEffCat m (Cat (Tr a)) (State a 'LoggedInType) (State a 'LoggedInType)
|
||||
access = liftCat Access
|
||||
=> EffCat m (Cat (Tr a)) (State a 'LoggedInType) (State a 'LoggedInType)
|
||||
access = liftEffect Access
|
||||
|
||||
type Username = String
|
||||
|
||||
@ -157,9 +157,9 @@ accessSecret
|
||||
-- @'HandleLogin'@ (with a small modifications) but this way we are able to
|
||||
-- test it with a pure @'HandleLogin'@ (see @'handleLoginPure'@).
|
||||
-> HandleLogin m String a
|
||||
-> FreeEffCat m (Cat (Tr a)) (State a 'LoggedOutType) (State a 'LoggedOutType)
|
||||
accessSecret 0 HandleLogin{handleAccessDenied} = lift $ handleAccessDenied $> id
|
||||
accessSecret n HandleLogin{handleLogin} = lift $ do
|
||||
-> EffCat m (Cat (Tr a)) (State a 'LoggedOutType) (State a 'LoggedOutType)
|
||||
accessSecret 0 HandleLogin{handleAccessDenied} = effect $ handleAccessDenied $> id
|
||||
accessSecret n HandleLogin{handleLogin} = effect $ do
|
||||
st <- handleLogin
|
||||
case st of
|
||||
-- login success
|
||||
@ -167,9 +167,9 @@ accessSecret n HandleLogin{handleLogin} = lift $ do
|
||||
-- login failure
|
||||
Left handler' -> return $ accessSecret (pred n) handler'
|
||||
where
|
||||
handle :: HandleAccess m a -> Maybe a -> FreeEffCat m (Cat (Tr a)) (State a 'LoggedInType) (State a 'LoggedOutType)
|
||||
handle :: HandleAccess m a -> Maybe a -> EffCat m (Cat (Tr a)) (State a 'LoggedInType) (State a 'LoggedOutType)
|
||||
handle LogoutHandler ma = logout ma
|
||||
handle (AccessHandler accessHandler dataHandler) _ = lift $ do
|
||||
handle (AccessHandler accessHandler dataHandler) _ = effect $ do
|
||||
a <- accessHandler
|
||||
accessHandler' <- dataHandler a
|
||||
return $ handle accessHandler' (Just a)
|
||||
@ -184,7 +184,7 @@ getData
|
||||
-> Natural
|
||||
-> HandleLogin m String a
|
||||
-> m (Maybe a)
|
||||
getData nat n handleLogin = case foldNatLift nat (accessSecret n handleLogin) of
|
||||
getData nat n handleLogin = case foldNatEffCat nat (accessSecret n handleLogin) of
|
||||
Kleisli fn -> do
|
||||
ma <- runLoggedOut <$> fn (LoggedOut Nothing)
|
||||
return ma
|
||||
|
@ -29,7 +29,7 @@ library
|
||||
Control.Arrow.Free
|
||||
Control.Category.Free
|
||||
Control.Category.Free.Internal
|
||||
Control.Category.FreeEff
|
||||
Control.Category.FreeEffect
|
||||
other-modules:
|
||||
Paths_free_category
|
||||
hs-source-dirs:
|
||||
|
@ -1,89 +0,0 @@
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
{-# OPTIONS_HADDOCK show-extensions #-}
|
||||
|
||||
module Control.Category.FreeEff
|
||||
( EffCategory (..)
|
||||
, FreeEffCat (..)
|
||||
, liftCat
|
||||
, foldNatLift
|
||||
, liftKleisli
|
||||
) where
|
||||
|
||||
import Prelude hiding (id, (.))
|
||||
|
||||
import Control.Arrow (Kleisli (..))
|
||||
import Control.Category (Category (..))
|
||||
import Data.Functor.Identity (Identity (..))
|
||||
|
||||
import Control.Category.Free (Cat)
|
||||
import Control.Algebra.Free2 (FreeAlgebra2 (..))
|
||||
import Data.Algebra.Free (AlgebraType, AlgebraType0, proof)
|
||||
|
||||
|
||||
-- | Categories which can lift monadic actions, i.e. effectful categories.
|
||||
--
|
||||
class Category c => EffCategory c m | c -> m where
|
||||
lift :: m (c a b) -> c a b
|
||||
|
||||
instance Monad m => EffCategory (Kleisli m) m where
|
||||
lift m = Kleisli (\a -> m >>= \(Kleisli f) -> f a)
|
||||
|
||||
instance EffCategory (->) Identity where
|
||||
lift = runIdentity
|
||||
|
||||
-- | Category transformer, which adds @'EffCategory'@ instance to the
|
||||
-- underlying base category.
|
||||
--
|
||||
data FreeEffCat :: (* -> *) -> (k -> k -> *) -> k -> k -> * where
|
||||
Base :: c a b -> FreeEffCat m c a b
|
||||
Lift :: m (FreeEffCat m c a b) -> FreeEffCat m c a b
|
||||
|
||||
instance (Functor m, Category c) => Category (FreeEffCat m c) where
|
||||
id = Base id
|
||||
Base f . Base g = Base $ f . g
|
||||
f . Lift mg = Lift $ (f .) <$> mg
|
||||
Lift mf . g = Lift $ (. g) <$> mf
|
||||
|
||||
instance (Functor m, Category c) => EffCategory (FreeEffCat m c) m where
|
||||
lift = Lift
|
||||
|
||||
type instance AlgebraType0 (FreeEffCat m) c = (Monad m, Category c)
|
||||
type instance AlgebraType (FreeEffCat m) c = EffCategory c m
|
||||
instance Monad m => FreeAlgebra2 (FreeEffCat m) where
|
||||
liftFree2 = Base
|
||||
foldNatFree2 nat (Base cab) = nat cab
|
||||
foldNatFree2 nat (Lift mcab) = lift $ foldNatFree2 nat <$> mcab
|
||||
|
||||
codom2 = proof
|
||||
forget2 = proof
|
||||
|
||||
-- | Wrap a transition into a free category @'Cat'@ and then in
|
||||
-- @'FreeEffCat'@
|
||||
--
|
||||
-- prop> liftCat tr = Base (tr :.: Id)
|
||||
--
|
||||
liftCat :: Monad m => tr a b -> FreeEffCat m (Cat tr) a b
|
||||
liftCat = liftFree2 . liftFree2
|
||||
|
||||
-- | Fold @'FreeLifing'@ category based on a free category @'Cat' tr@ using
|
||||
-- a functor @tr x y -> c x y@.
|
||||
--
|
||||
foldNatLift
|
||||
:: (Monad m, EffCategory c m)
|
||||
=> (forall x y. tr x y -> c x y)
|
||||
-> FreeEffCat m (Cat tr) a b
|
||||
-> c a b
|
||||
foldNatLift nat = foldNatFree2 (foldNatFree2 nat)
|
||||
|
||||
-- | Functor from @'->'@ category to @'Kleisli' m@. If @m@ is @Identity@ then
|
||||
-- it will respect @'lift'@ i.e. @liftKleisli (lift ar) = lift (liftKleisli <$>
|
||||
-- ar).
|
||||
--
|
||||
liftKleisli :: Applicative m => (a -> b) -> Kleisli m a b
|
||||
liftKleisli f = Kleisli (pure . f)
|
87
src/Control/Category/FreeEffect.hs
Normal file
87
src/Control/Category/FreeEffect.hs
Normal file
@ -0,0 +1,87 @@
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
{-# OPTIONS_HADDOCK show-extensions #-}
|
||||
|
||||
module Control.Category.FreeEffect
|
||||
( EffectCategory (..)
|
||||
, EffCat (..)
|
||||
, liftEffect
|
||||
, foldNatEffCat
|
||||
, liftKleisli
|
||||
) where
|
||||
|
||||
import Prelude hiding (id, (.))
|
||||
|
||||
import Control.Arrow (Kleisli (..))
|
||||
import Control.Category (Category (..))
|
||||
import Data.Functor.Identity (Identity (..))
|
||||
|
||||
import Control.Category.Free (Cat)
|
||||
import Control.Algebra.Free2 (FreeAlgebra2 (..))
|
||||
import Data.Algebra.Free (AlgebraType, AlgebraType0, proof)
|
||||
|
||||
|
||||
-- | Categories which can lift monadic actions, i.e. effectful categories.
|
||||
--
|
||||
class Category c => EffectCategory c m | c -> m where
|
||||
effect :: m (c a b) -> c a b
|
||||
|
||||
instance Monad m => EffectCategory (Kleisli m) m where
|
||||
effect m = Kleisli (\a -> m >>= \(Kleisli f) -> f a)
|
||||
|
||||
instance EffectCategory (->) Identity where
|
||||
effect = runIdentity
|
||||
|
||||
-- | Category transformer, which adds @'EffectCategory'@ instance to the
|
||||
-- underlying base category.
|
||||
--
|
||||
data EffCat :: (* -> *) -> (k -> k -> *) -> k -> k -> * where
|
||||
Base :: c a b -> EffCat m c a b
|
||||
Effect :: m (EffCat m c a b) -> EffCat m c a b
|
||||
|
||||
instance (Functor m, Category c) => Category (EffCat m c) where
|
||||
id = Base id
|
||||
Base f . Base g = Base $ f . g
|
||||
f . Effect mg = Effect $ (f .) <$> mg
|
||||
Effect mf . g = Effect $ (. g) <$> mf
|
||||
|
||||
instance (Functor m, Category c) => EffectCategory (EffCat m c) m where
|
||||
effect = Effect
|
||||
|
||||
type instance AlgebraType0 (EffCat m) c = (Monad m, Category c)
|
||||
type instance AlgebraType (EffCat m) c = EffectCategory c m
|
||||
instance Monad m => FreeAlgebra2 (EffCat m) where
|
||||
liftFree2 = Base
|
||||
foldNatFree2 nat (Base cab) = nat cab
|
||||
foldNatFree2 nat (Effect mcab) = effect $ foldNatFree2 nat <$> mcab
|
||||
|
||||
codom2 = proof
|
||||
forget2 = proof
|
||||
|
||||
-- | Wrap a transition into a free category @'Cat'@ and then in
|
||||
-- @'EffCat'@
|
||||
--
|
||||
liftEffect :: Monad m => tr a b -> EffCat m (Cat tr) a b
|
||||
liftEffect = liftFree2 . liftFree2
|
||||
|
||||
-- | Fold @'FreeLifing'@ category based on a free category @'Cat' tr@ using
|
||||
-- a functor @tr x y -> c x y@.
|
||||
--
|
||||
foldNatEffCat
|
||||
:: (Monad m, EffectCategory c m)
|
||||
=> (forall x y. tr x y -> c x y)
|
||||
-> EffCat m (Cat tr) a b
|
||||
-> c a b
|
||||
foldNatEffCat nat = foldNatFree2 (foldNatFree2 nat)
|
||||
|
||||
-- | Functor from @'->'@ category to @'Kleisli' m@. If @m@ is @Identity@ then
|
||||
-- it will respect @'lift'@ i.e. @liftKleisli (lift ar) = lift (liftKleisli <$>
|
||||
-- ar).
|
||||
--
|
||||
liftKleisli :: Applicative m => (a -> b) -> Kleisli m a b
|
||||
liftKleisli f = Kleisli (pure . f)
|
Loading…
Reference in New Issue
Block a user