@@ -19,20 +19,9 @@
1919-- Stability : experimental
2020-- Portability : non-portable
2121--
22−-- Structural subtyping
22+-- Structural subtype relationship between record types.
2323--
24−-----------------------------------------------------------------------------
25−module Data.Generic.Record.Subtype
26− ( Subtype (..)
27− ) where
28−
29−import Data.Generic.Record.HasField
30−import Data.Generic.Internal.Lens
31−
32−import Data.Kind (Type)
33−import GHC.Generics
34−
35−-- |Structural subtype relationship
24+-- The running example in this module is the following two types:
3625--
3726-- @
3827--
@@ -57,30 +46,93 @@ import GHC.Generics
5746--
5847-- @
5948--
49+-----------------------------------------------------------------------------
50+module Data.Generic.Record.Subtype
51+ ( Subtype (..)
52+ , subtype
53+ ) where
54+
55+import Data.Generic.Record.HasField
56+import Data.Generic.Record.Internal.Contains
57+
58+import Data.Generic.Internal.Lens
59+
60+import Data.Kind (Type)
61+import GHC.Generics
62+
63+-- |Structural subtype relationship
6064--
61−-- >>> human
62−-- Human {name = "Tunyasz", age = 50, address = "London"}
63−--
64−-- >>> upcast human :: Animal
65−-- Animal {name = "Tunyasz", age = 50}
65+-- @sub@ is a (structural) `subtype' of @sup@, if its fields are a subset of
66+-- those of @sup@.
6667--
6768class Subtype sub sup where
6869 -- | Cast the more specific subtype to the more general supertype
70+ --
71+ -- >>> upcast human :: Animal
72+ -- Animal {name = "Tunyasz", age = 50}
73+ --
6974 upcast :: sub -> sup
75+ -- | Plug a smaller structure into a larger one
76+ --
77+ -- >>> smash (Animal "dog" 10) human
78+ -- Human {name = "dog", age = 10, address = "London"}
79+ smash :: sup -> sub -> sub
7080
7181-- | Instances are created by the compiler
72−instance (Convert (Rep a) (Rep b), Generic a, Generic b) => Subtype a b where
73− upcast = to . convert . from
82+instance (GSmash (Rep a) (Rep b), GUpcast (Rep a) (Rep b), Generic a, Generic b) => Subtype a b where
83+ upcast = to . gupcast . from
84+ smash p b = to $ gsmash (from p) (from b)
85+
86+-- | Structural subtype lens. Given a subtype relationship @sub :< sup@,
87+-- we can focus on the @sub@ structure of @sup@.
88+--
89+-- >>> human ^. subtype @Animal
90+-- Animal {name = "Tunyasz", age = 50}
91+--
92+-- >>> set (subtype @Animal) (Animal "dog" 10) human
93+-- Human {name = "dog", age = 10, address = "London"}
94+subtype :: forall sup sub. Subtype sub sup => Lens' sub sup
95+subtype f sub = fmap (flip smash sub) (f (upcast sub))
96+
97+--------------------------------------------------------------------------------
98+-- * Generic upcasting
99+
100+-- | Upcast 'sub to 'sup' (generic rep)
101+class GUpcast (sub :: Type -> Type) (sup :: Type -> Type) where
102+ gupcast :: sub p -> sup p
103+
104+instance (GUpcast sub a, GUpcast sub b) => GUpcast sub (a :*: b) where
105+ gupcast rep = gupcast rep :*: gupcast rep
106+
107+instance {-# OVERLAPPING #-} GHasField field sub t => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
108+ gupcast r = M1 (K1 (r ^. glabel @field))
109+
110+instance GUpcast sub sup => GUpcast sub (M1 i c sup) where
111+ gupcast = M1 . gupcast
112+
113+--------------------------------------------------------------------------------
114+-- * Generic smashing
115+
116+class GSmash sub sup where
117+ gsmash :: sup p -> sub p -> sub p
118+
119+instance (GSmash a sup, GSmash b sup) => GSmash (a :*: b) sup where
120+ gsmash rep (a :*: b) = gsmash rep a :*: gsmash rep b
121+
122+instance {-# OVERLAPPING #-}
123+ ( leaf ~ (S1 ('MetaSel ('Just field) p f b) t)
124+ , GSmashLeaf leaf sup (Contains field sup)
125+ ) => GSmash (S1 ('MetaSel ('Just field) p f b) t) sup where
126+ gsmash = gsmashLeaf @_ @_ @(Contains field sup)
74127
75−-- | Convert 'rep' into 'f'
76−class Convert (rep :: Type -> Type) (f :: Type -> Type) where
77− convert :: rep p -> f p
128+instance GSmash sub sup => GSmash (M1 i c sub) sup where
129+ gsmash sup (M1 sub) = M1 (gsmash sup sub)
78130
79−instance (Convert rep a, Convert rep b) => Convert rep (a :*: b) where
80− convert rep = convert rep :*: convert rep
131+class GSmashLeaf sub sup (w :: Maybe Type) where
132+ gsmashLeaf :: sup p -> sub p -> sub p
81133
82−instance {-# OVERLAPPING #-} GHasField field rep t => Convert rep (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
83− convert rep = M1 (K1 (rep ^. glabel @field))
134+instance (GHasField field sup t) => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup ('Just t) where
135+ gsmashLeaf sup (M1 (K1 _)) = M1 (K1 (sup ^. glabel @field))
84136
85−instance Convert rep f => Convert rep (M1 i c f) where
86− convert = M1 . convert
137+instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'Nothing where
138+ gsmashLeaf _ = id