mirror of
https://github.com/ilyakooo0/semi-iso-optics.git
synced 2024-09-11 07:55:36 +03:00
Add category instances for ReifiedSemiIso'.
This commit is contained in:
parent
f0d5d26b21
commit
67c1554771
@ -16,6 +16,7 @@ module Control.Category.Reader (
|
||||
) where
|
||||
|
||||
import Control.Category
|
||||
import Control.Category.Structures
|
||||
import Control.SIArrow
|
||||
import Prelude hiding (id, (.))
|
||||
|
||||
@ -34,7 +35,7 @@ instance Products cat => Products (ReaderCT env cat) where
|
||||
instance Coproducts cat => Coproducts (ReaderCT env cat) where
|
||||
ReaderCT f +++ ReaderCT g = ReaderCT $ \x -> f x +++ g x
|
||||
|
||||
instance CategoryPlus cat => CategoryPlus (ReaderCT env cat) where
|
||||
instance CatPlus cat => CatPlus (ReaderCT env cat) where
|
||||
cempty = clift cempty
|
||||
ReaderCT f /+/ ReaderCT g = ReaderCT $ \x -> f x /+/ g x
|
||||
|
||||
|
@ -97,9 +97,9 @@ module Control.Lens.SemiIso (
|
||||
bifoldl1_
|
||||
) where
|
||||
|
||||
import Prelude hiding (id, (.))
|
||||
import Control.Arrow
|
||||
import Control.Arrow (Kleisli(..))
|
||||
import Control.Category
|
||||
import Control.Category.Structures
|
||||
import Control.Lens.Internal.SemiIso
|
||||
import Control.Lens.Iso
|
||||
import Data.Foldable
|
||||
@ -107,6 +107,7 @@ import Data.Functor.Identity
|
||||
import Data.Profunctor.Exposed
|
||||
import Data.Traversable
|
||||
import Data.Tuple.Morph
|
||||
import Prelude hiding (id, (.))
|
||||
|
||||
-- | A semi-isomorphism is a partial isomorphism with weakened laws.
|
||||
--
|
||||
@ -140,11 +141,7 @@ instance Category ReifiedSemiIso' where
|
||||
id = ReifiedSemiIso' id
|
||||
ReifiedSemiIso' f . ReifiedSemiIso' g = ReifiedSemiIso' (g . f)
|
||||
|
||||
-- | This in an __/incomplete/__ instance, 'arr' and '(&&&)' are undefined.
|
||||
instance Arrow ReifiedSemiIso' where
|
||||
arr = undefined
|
||||
(&&&) = undefined
|
||||
|
||||
instance Products ReifiedSemiIso' where
|
||||
-- TODO: pattern synonyms dont work here for some reason
|
||||
first (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
|
||||
ReifiedSemiIso' $ cloneSemiIso $
|
||||
@ -161,6 +158,30 @@ instance Arrow ReifiedSemiIso' where
|
||||
semiIso (runKleisli $ Kleisli f *** Kleisli f')
|
||||
(runKleisli $ Kleisli g *** Kleisli g')
|
||||
|
||||
instance Coproducts ReifiedSemiIso' where
|
||||
left (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
|
||||
ReifiedSemiIso' $ cloneSemiIso $
|
||||
semiIso (runKleisli $ left $ Kleisli f)
|
||||
(runKleisli $ left $ Kleisli g)
|
||||
|
||||
right (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
|
||||
ReifiedSemiIso' $ cloneSemiIso $
|
||||
semiIso (runKleisli $ right $ Kleisli f)
|
||||
(runKleisli $ right $ Kleisli g)
|
||||
|
||||
ReifiedSemiIso' ai +++ ReifiedSemiIso' ai' = ReifiedSemiIso' $
|
||||
withSemiIso ai $ \f g -> withSemiIso ai' $ \f' g' ->
|
||||
semiIso (runKleisli $ Kleisli f +++ Kleisli f')
|
||||
(runKleisli $ Kleisli g +++ Kleisli g')
|
||||
|
||||
instance CatPlus ReifiedSemiIso' where
|
||||
cempty = ReifiedSemiIso' $ alwaysFailing "cempty"
|
||||
|
||||
ReifiedSemiIso' ai /+/ ReifiedSemiIso' ai' = ReifiedSemiIso' $
|
||||
withSemiIso ai $ \f g -> withSemiIso ai' $ \f' g' ->
|
||||
semiIso (runKleisli $ Kleisli f /+/ Kleisli f')
|
||||
(runKleisli $ Kleisli g /+/ Kleisli g')
|
||||
|
||||
-- | Constructs a semi isomorphism from a pair of functions that can
|
||||
-- fail with an error message.
|
||||
semiIso :: (s -> Either String a) -> (b -> Either String t) -> SemiIso s t a b
|
||||
|
@ -44,6 +44,9 @@ class (Products cat, Coproducts cat, CatPlus cat) => SIArrow cat where
|
||||
instance MonadPlus m => SIArrow (Kleisli m) where
|
||||
siarr ai = Kleisli $ either fail return . apply ai
|
||||
|
||||
instance SIArrow ReifiedSemiIso' where
|
||||
siarr = reifySemiIso
|
||||
|
||||
(^>>) :: SIArrow cat => ASemiIso' a b -> cat b c -> cat a c
|
||||
f ^>> a = a . siarr f
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user