@@ -1,9 +1,10 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE PolyKinds #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE DataKinds #-}
33{-# LANGUAGE FlexibleContexts #-}
44{-# LANGUAGE FlexibleInstances #-}
55{-# LANGUAGE KindSignatures #-}
66{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE PolyKinds #-}
78{-# LANGUAGE ScopedTypeVariables #-}
89{-# LANGUAGE TypeApplications #-}
910{-# LANGUAGE TypeOperators #-}
@@ -34,6 +35,7 @@ import Data.Kind
3435import GHC.Generics
3536import Data.Generics.Internal.Profunctor.Iso
3637import Data.Generics.Internal.Profunctor.Prism
38+import Data.Generics.Internal.Families.Has
3739
3840-- |As 'AsSubtype' but over generic representations as defined by
3941-- "GHC.Generics".
@@ -41,22 +43,72 @@ class GAsSubtype (subf :: Type -> Type) (supf :: Type -> Type) where
4143 _GSub :: Prism' (supf x) (subf x)
4244
4345instance
44− ( GAsSubtype l supf
45− , GAsSubtype r supf
46− ) => GAsSubtype (l :+: r) supf where
47− _GSub = without' _GSub _GSub . fromIso sumIso
46+ ( GSplash sub sup
47+ , GDowncast sub sup
48+ ) => GAsSubtype sub sup where
49+ _GSub f = prismPRavel (prism _GSplash _GDowncast) f
4850 {-# INLINE _GSub #-}
4951
52+--------------------------------------------------------------------------------
53+
54+class GSplash (sub :: Type -> Type) (sup :: Type -> Type) where
55+ _GSplash :: sub x -> sup x
56+
57+instance (GSplash a sup, GSplash b sup) => GSplash (a :+: b) sup where
58+ _GSplash (L1 rep) = _GSplash rep
59+ _GSplash (R1 rep) = _GSplash rep
60+ {-# INLINE _GSplash #-}
61+
5062instance
5163 ( GIsList () subf subf as as
5264 , GAsType supf as
53− ) => GAsSubtype (C1 meta subf) supf where
54− _GSub = _GTyped . fromIso (glist @()) . fromIso mIso
55− {-# INLINE _GSub #-}
65+ ) => GSplash (C1 meta subf) supf where
66+ _GSplash p = build (prismPRavel (_GTyped . fromIso (glist @()) . fromIso mIso)) p
67+ {-# INLINE _GSplash #-}
5668
57−-- instance GAsType supf a => GAsSubtype (S1 meta (Rec0 a)) supf where
58−-- _GSub = _GTyped . fromIso (mIso . kIso)
69+instance GSplash sub sup => GSplash (D1 c sub) sup where
70+ _GSplash (M1 m) = _GSplash m
71+ {-# INLINE _GSplash #-}
5972
60−instance GAsSubtype subf supf => GAsSubtype (D1 meta subf) supf where
61− _GSub = _GSub . fromIso mIso
62− {-# INLINE _GSub #-}
73+--------------------------------------------------------------------------------
74+
75+class GDowncast sub sup where
76+ _GDowncast :: sup x -> Either (sup x) (sub x)
77+
78+instance
79+ ( GIsList () sup sup as as
80+ , GDowncastC (HasPartialTypeP as sub) sub sup
81+ ) => GDowncast sub (C1 m sup) where
82+ _GDowncast (M1 m) = case _GDowncastC @(HasPartialTypeP as sub) m of
83+ Left _ -> Left (M1 m)
84+ Right r -> Right r
85+ {-# INLINE _GDowncast #-}
86+
87+instance (GDowncast sub l, GDowncast sub r) => GDowncast sub (l :+: r) where
88+ _GDowncast (L1 x) = case _GDowncast x of
89+ Left _ -> Left (L1 x)
90+ Right r -> Right r
91+ _GDowncast (R1 x) = case _GDowncast x of
92+ Left _ -> Left (R1 x)
93+ Right r -> Right r
94+ {-# INLINE _GDowncast #-}
95+
96+instance GDowncast sub sup => GDowncast sub (D1 m sup) where
97+ _GDowncast (M1 m) = case _GDowncast m of
98+ Left _ -> Left (M1 m)
99+ Right r -> Right r
100+ {-# INLINE _GDowncast #-}
101+
102+class GDowncastC (contains :: Bool) sub sup where
103+ _GDowncastC :: sup x -> Either (sup x) (sub x)
104+
105+instance GDowncastC 'False sub sup where
106+ _GDowncastC sup = Left sup
107+ {-# INLINE _GDowncastC #-}
108+
109+instance
110+ ( GAsType sub subl
111+ , GIsList () sup sup subl subl
112+ ) => GDowncastC 'True sub sup where
113+ _GDowncastC sup = Right (build (prismPRavel (_GTyped . fromIso (glist @()))) sup)
114+ {-# INLINE _GDowncastC #-}