{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Wedge.Optics
(
_WedgeIso
, here
, there
, _Nowhere
, _Here
, _There
) where
import Data.Wedge
import Optics.AffineTraversal
import Optics.Each.Core
import Optics.Iso
import Optics.IxTraversal
import Optics.Prism
_WedgeIso :: Iso (Wedge a b) (Wedge c d) (Maybe (Either a b)) (Maybe (Either c d))
_WedgeIso = iso f g
where
f Nowhere = Nothing
f (Here a) = Just (Left a)
f (There b) = Just (Right b)
g Nothing = Nowhere
g (Just (Left a)) = Here a
g (Just (Right b)) = There b
here :: AffineTraversal (Wedge a b) (Wedge a' b) a a'
here = atraversalVL $ \point f -> \case
Nowhere -> point Nowhere
Here a -> Here <$> f a
There b -> point (There b)
there :: AffineTraversal (Wedge a b) (Wedge a b') b b'
there = atraversalVL $ \point f -> \case
Nowhere -> point Nowhere
Here a -> point (Here a)
There b -> There <$> f b
_Nowhere :: Prism' (Wedge a b) ()
_Nowhere = prism (const Nowhere) $ \case
Nowhere -> Right ()
Here a -> Left (Here a)
There b -> Left (There b)
_Here :: Prism (Wedge a b) (Wedge c b) a c
_Here = prism Here $ \case
Here a -> Right a
There b -> Left (There b)
Nowhere -> Left Nowhere
_There :: Prism (Wedge a b) (Wedge a d) b d
_There = prism There $ \case
There b -> Right b
Here a -> Left (Here a)
Nowhere -> Left (Nowhere)
instance Swapped Wedge where
swapped = iso swapWedge swapWedge
instance (a ~ a', b ~ b') => Each Bool (Wedge a a') (Wedge b b') a b where
each = itraversalVL $ \f -> \case
Here a -> Here <$> f True a
There b -> There <$> f False b
Nowhere -> pure Nowhere