module Data.Piso.Generic (mkPisoList, PisoList(..), PisoLhs) where
import Data.Piso
import GHC.Generics
mkPisoList :: (Generic a, MkPisoList (Rep a)) => PisoList (Rep a) a
mkPisoList = mkPisoList' to (Just . from)
class MkPisoList (f :: * -> *) where
data PisoList (f :: * -> *) (a :: *)
mkPisoList' :: (f p -> a) -> (a -> Maybe (f q)) -> PisoList f a
instance MkPisoList f => MkPisoList (M1 D c f) where
data PisoList (M1 D c f) a = PisoList (PisoList f a)
mkPisoList' f' g' = PisoList (mkPisoList' (f' . M1) (fmap unM1 . g'))
infixr :&
instance (MkPisoList f, MkPisoList g) => MkPisoList (f :+: g) where
data PisoList (f :+: g) a = PisoList f a :& PisoList g a
mkPisoList' f' g' = f f' g' :& g f' g'
where
f :: forall a p q. ((f :+: g) p -> a) -> (a -> Maybe ((f :+: g) q)) -> PisoList f a
f _f' _g' = mkPisoList' (\fp -> _f' (L1 fp)) (matchL _g')
g :: forall a p q. ((f :+: g) p -> a) -> (a -> Maybe ((f :+: g) q)) -> PisoList g a
g _f' _g' = mkPisoList' (\gp -> _f' (R1 gp)) (matchR _g')
matchL :: (a -> Maybe ((f :+: g) q)) -> a -> Maybe (f q)
matchL _g' a = case _g' a of
Just (L1 f'') -> Just f''
_ -> Nothing
matchR :: (a -> Maybe ((f :+: g) q)) -> a -> Maybe (g q)
matchR _g' a = case _g' a of
Just (R1 g'') -> Just g''
_ -> Nothing
instance MkPiso f => MkPisoList (M1 C c f) where
data PisoList (M1 C c f) a = I (forall t cat. FromPiso cat => cat (PisoLhs f t) (a :- t))
mkPisoList' f' g' = I (fromPiso (Piso (f f') (g g')))
where
f :: forall a p t. (M1 C c f p -> a) -> PisoLhs f t -> a :- t
f _f' lhs = mapHead (_f' . M1) (mkR lhs)
g :: forall a p t. (a -> Maybe (M1 C c f p)) -> (a :- t) -> Maybe (PisoLhs f t)
g _g' (a :- t) = fmap (mkL . (:- t) . unM1) (_g' a)
class MkPiso (f :: * -> *) where
type PisoLhs (f :: * -> *) (t :: *) :: *
mkR :: forall p t. PisoLhs f t -> (f p :- t)
mkL :: forall p t. (f p :- t) -> PisoLhs f t
instance MkPiso U1 where
type PisoLhs U1 t = t
mkR t = U1 :- t
mkL (U1 :- t) = t
instance MkPiso (K1 i a) where
type PisoLhs (K1 i a) t = a :- t
mkR (h :- t) = K1 h :- t
mkL (K1 h :- t) = h :- t
instance MkPiso f => MkPiso (M1 i c f) where
type PisoLhs (M1 i c f) t = PisoLhs f t
mkR = mapHead M1 . mkR
mkL = mkL . mapHead unM1
instance (MkPiso f, MkPiso g) => MkPiso (f :*: g) where
type PisoLhs (f :*: g) t = PisoLhs f (PisoLhs g t)
mkR t = (hf :*: hg) :- tg
where
hf :- tf = mkR t
hg :- tg = mkR tf
mkL ((hf :*: hg) :- t) = mkL (hf :- mkL (hg :- t))
mapHead :: (a -> b) -> (a :- t) -> (b :- t)
mapHead f (h :- t) = f h :- t