{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Smash.Optics
(
_SmashIso
, _Nada
, _Smash
, smashed
, smashing
) where
import Optics.AffineTraversal
import Optics.Each.Core
import Optics.Iso
import Optics.IxTraversal
import Optics.Prism
import Data.Smash
_SmashIso :: Iso (Smash a b) (Smash c d) (Maybe (a,b)) (Maybe (c,d))
_SmashIso = iso f g
where
f Nada = Nothing
f (Smash a b) = Just (a,b)
g Nothing = Nada
g (Just (a,b)) = Smash a b
smashed :: AffineTraversal (Smash a b) (Smash c d) (a,b) (c,d)
smashed = atraversalVL $ \point f -> \case
Nada -> point Nada
Smash a b -> uncurry Smash <$> f (a,b)
smashing :: IxTraversal Bool (Smash a a) (Smash b b) a b
smashing = itraversalVL $ \f -> \case
Nada -> pure Nada
Smash a b -> Smash <$> f True a <*> f False b
_Nada :: Prism' (Smash a b) ()
_Nada = prism (const Nada) $ \case
Nada -> Right ()
Smash a b -> Left (Smash a b)
_Smash :: Prism' (Smash a b) (a,b)
_Smash = prism (uncurry Smash) $ \case
Smash a b -> Right (a,b)
Nada -> Left Nada
instance Swapped Smash where
swapped = iso swapSmash swapSmash
instance (a ~ a', b ~ b') => Each Bool (Smash a a') (Smash b b') a b where
each = smashing