{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Data.Barbie.Internal.Generics
( Target (..)
, unsafeTargetBarbie
, unsafeUntarget
, unsafeTarget
, unsafeUntargetBarbie
, W
, Repl, Repl'
, RecRep
, RecUsage(..), NonRec(..)
, AnnRec, DeannRec
, toWithRecAnn
, fromWithRecAnn
)
where
import GHC.Generics
import Unsafe.Coerce (unsafeCoerce)
data Target (f :: * -> *) a
= Target (f a)
unsafeTargetBarbie :: forall t b f . b f -> b (Target t)
unsafeTargetBarbie = unsafeCoerce
unsafeUntarget :: forall t f a . Target t a -> f a
unsafeUntarget = unsafeCoerce
unsafeTarget :: forall t f a . f a -> Target t a
unsafeTarget = unsafeCoerce
unsafeUntargetBarbie :: forall t b f . b (Target t) -> b f
unsafeUntargetBarbie = unsafeCoerce
type family Repl f g rep where
Repl f g (M1 i c x) = M1 i c (Repl f g x)
Repl f g V1 = V1
Repl f g U1 = U1
Repl (Target f) (Target g) (K1 i (Target (W f) a)) = K1 i (Target (W g) a)
Repl f g (K1 i (f a)) = K1 i (g a)
Repl f g (K1 i (b f)) = K1 i (b g)
Repl f g (K1 i (h (b f))) = K1 i (h (b g))
Repl f g (K1 i c) = K1 i c
Repl f g (l :+: r) = (Repl f g l) :+: (Repl f g r)
Repl f g (l :*: r) = (Repl f g l) :*: (Repl f g r)
newtype RecUsage a
= RecUsage a
newtype NonRec a
= NonRec a
type family AnnRec a rep where
AnnRec a (M1 i c x) = M1 i c (AnnRec a x)
AnnRec a V1 = V1
AnnRec a U1 = U1
AnnRec a (K1 i a) = K1 i (RecUsage a)
AnnRec a (K1 i a') = K1 i (NonRec a')
AnnRec a (l :*: r) = AnnRec a l :*: AnnRec a r
AnnRec a (l :+: r) = AnnRec a l :+: AnnRec a r
type family DeannRec rep where
DeannRec (M1 i c x) = M1 i c (DeannRec x)
DeannRec V1 = V1
DeannRec U1 = U1
DeannRec (K1 i (RecUsage a)) = K1 i a
DeannRec (K1 i (NonRec a)) = K1 i a
DeannRec (l :*: r) = DeannRec l :*: DeannRec r
DeannRec (l :+: r) = DeannRec l :+: DeannRec r
fromWithRecAnn :: Generic a => a -> RecRep a x
fromWithRecAnn = unsafeCoerce . from
toWithRecAnn :: Generic a => RecRep a x -> a
toWithRecAnn = to . unsafeCoerce
type RecRep a = AnnRec a (Rep a)
type Repl' f g rep
= Repl f g (DeannRec rep)
data W (f :: * -> *) a