{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Can.Optics
(
_CanIso
, _Non
, _One
, _Eno
, _Two
, oneing
, enoing
, twoed
, twoing
) where
import Data.Can
import Optics.AffineTraversal
import Optics.Each.Core
import Optics.Iso
import Optics.IxTraversal
import Optics.Prism
import Optics.Traversal
_CanIso :: Iso (Can a b) (Can c d) (Maybe a, Maybe b) (Maybe c, Maybe d)
_CanIso = iso f g
where
f t = (canFst t, canSnd t)
g (Nothing, Nothing) = Non
g (Just a, Nothing) = One a
g (Nothing, Just b) = Eno b
g (Just a, Just b) = Two a b
oneing :: AffineTraversal (Can a c) (Can b c) a b
oneing = atraversalVL $ \point f -> \case
Non -> point Non
One a -> One <$> f a
Eno c -> point (Eno c)
Two a c -> flip Two c <$> f a
enoing :: AffineTraversal (Can a b) (Can a c) b c
enoing = atraversalVL $ \point f -> \case
Non -> point Non
One a -> point (One a)
Eno b -> Eno <$> f b
Two a b -> Two a <$> f b
twoed :: AffineTraversal' (Can a b) (a,b)
twoed = atraversalVL $ \point f -> \case
Non -> point Non
One a -> point (One a)
Eno b -> point (Eno b)
Two a b -> uncurry Two <$> f (a,b)
twoing :: Traversal (Can a a) (Can b b) a b
twoing = traversalVL $ \f -> \case
Non -> pure Non
One a -> One <$> f a
Eno a -> Eno <$> f a
Two a b -> Two <$> f a <*> f b
_Non :: Prism' (Can a b) ()
_Non = prism (const Non) $ \case
Non -> Right ()
One a -> Left (One a)
Eno b -> Left (Eno b)
Two a b -> Left (Two a b)
_One :: Prism' (Can a b) a
_One = prism One $ \case
Non -> Left Non
One a -> Right a
Eno b -> Left (Eno b)
Two a b -> Left (Two a b)
_Eno :: Prism' (Can a b) b
_Eno = prism Eno $ \case
Non -> Left Non
One a -> Left (One a)
Eno b -> Right b
Two a b -> Left (Two a b)
_Two :: Prism' (Can a b) (a,b)
_Two = prism (uncurry Two) $ \case
Non -> Left Non
One a -> Left (One a)
Eno b -> Left (Eno b)
Two a b -> Right (a,b)
instance Swapped Can where
swapped = iso swapCan swapCan
instance (a ~ a', b ~ b') => Each Bool (Can a a') (Can b b') a b where
each = itraversalVL $ \f -> \case
Non -> pure Non
One a -> One <$> f True a
Eno a -> Eno <$> f False a
Two a b -> Two <$> f True a <*> f False b