@@ -1,3 +1,5 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE TypeApplications #-}
13{-# language ConstraintKinds #-}
24{-# language DataKinds #-}
35{-# language FlexibleContexts #-}
@@ -23,64 +25,80 @@
2325-----------------------------------------------------------------------------
2426
2527module Data.Generics.Wrapped
26− ( Wrapped(..)
28+ ( Wrapped (..)
29+ , wrappedTo
30+ , wrappedFrom
2731 , _Unwrapped
2832 , _Wrapped
2933 )
3034where
3135
36+import Control.Applicative (Const(..))
3237import Data.Generics.Internal.Profunctor.Iso
33−import Data.Generics.Internal.VL.Lens ((^.))
3438
3539import qualified Data.Generics.Internal.VL.Iso as VL
40+import Data.Generics.Internal.Families.Changing ( UnifyHead )
3641
3742import Data.Kind (Constraint)
3843import GHC.Generics
3944import GHC.TypeLits
4045
41−class GWrapped a b | a -> b where
42− gWrapped :: Iso' (a x) b
43−
44−instance GWrapped a b => GWrapped (M1 i k a) b where
45− gWrapped = mIso.gWrapped
46−
47−instance GWrapped (K1 i c) c where
48− gWrapped = kIso
49−
50−-- | @since 1.1.0.0
51−class Wrapped a b | a -> b where
52− {-# minimal wrappedIso | wrappedTo, wrappedFrom #-}
53− -- | @since 1.1.0.0
54− wrappedIso :: VL.Iso' a b
55− wrappedIso = VL.iso wrappedTo wrappedFrom
56− {-# INLINE wrappedIso #-}
57−
58− -- | @since 1.1.0.0
59− wrappedTo :: a -> b
60− wrappedTo a = a ^. wrappedIso
61− {-# INLINE wrappedTo #-}
62−
63− -- | @since 1.1.0.0
64− wrappedFrom :: b -> a
65− wrappedFrom a = a ^. VL.fromIso wrappedIso
66− {-# INLINE wrappedFrom #-}
67−
6846type family ErrorUnlessOnlyOne a b :: Constraint where
6947 ErrorUnlessOnlyOne t (M1 i k a) = ErrorUnlessOnlyOne t a
7048 ErrorUnlessOnlyOne t (K1 i a) = ()
7149 ErrorUnlessOnlyOne t a =
7250 TypeError ('ShowType t ':<>: 'Text " is not a single-constructor, single-field datatype")
7351
74−instance (Generic a, ErrorUnlessOnlyOne a (Rep a), GWrapped (Rep a) b) => Wrapped a b where
75− wrappedIso = iso2isovl (repIso . gWrapped)
76− {-# INLINE wrappedIso #-}
77−
7852-- | @since 1.1.0.0
79−_Unwrapped :: Wrapped a b => VL.Iso' a b
53+_Unwrapped :: Wrapped s t a b => VL.Iso s t a b
8054_Unwrapped = wrappedIso
81−{-# INLINE _Unwrapped #-}
55+{-# inline _Unwrapped #-}
8256
8357-- | @since 1.1.0.0
84−_Wrapped :: Wrapped a b => VL.Iso' b a
58+_Wrapped :: Wrapped s t a b => VL.Iso b a t s
8559_Wrapped = VL.fromIso wrappedIso
86−{-# INLINE _Wrapped #-}
60+{-# inline _Wrapped #-}
61+
62+-- TODO: move this into doctets
63+
64+-- newtype FlippedEither a b = FlippedEither (Either b a)
65+-- deriving Generic
66+
67+-- test :: (a -> c) -> FlippedEither a b -> FlippedEither c b
68+-- test f = over wrappedIso (fmap f)
69+
70+class GWrapped s t a b | s -> a, t -> b, s b -> t, t a -> s where
71+ gWrapped :: Iso (s x) (t x) a b
72+
73+instance GWrapped s t a b => GWrapped (M1 i k s) (M1 i k t) a b where
74+ gWrapped = mIso . gWrapped
75+
76+instance (a ~ c, b ~ d) => GWrapped (K1 i a) (K1 i b) c d where
77+ gWrapped = kIso
78+
79+-- | @since 1.1.0.0
80+class Wrapped s t a b | s -> a, t -> b where
81+ -- | @since 1.1.0.0
82+ wrappedIso :: VL.Iso s t a b
83+
84+-- | @since 1.1.0.0
85+wrappedTo :: forall s t a b. Wrapped s t a b => s -> a
86+wrappedTo a = view (wrappedIso @s @t @a @b) a
87+ where view l s = getConst (l Const s)
88+{-# INLINE wrappedTo #-}
89+
90+-- | @since 1.1.0.0
91+wrappedFrom :: forall s t a b. Wrapped s t a b => b -> t
92+wrappedFrom a = view (VL.fromIso (wrappedIso @s @t @a @b)) a
93+ where view l s = getConst (l Const s)
94+{-# INLINE wrappedFrom #-}
95+
96+instance
97+ ( Generic s
98+ , Generic t
99+ , GWrapped (Rep s) (Rep t) a b
100+ , UnifyHead s t
101+ , UnifyHead t s
102+ ) => Wrapped s t a b where
103+ wrappedIso = iso2isovl (repIso . gWrapped)
104+ {-# INLINE wrappedIso #-}