@@ -0,0 +1,154 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE KindSignatures #-}
4+{-# LANGUAGE MultiParamTypeClasses #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TypeApplications #-}
7+{-# LANGUAGE TypeOperators #-}
8+{-# LANGUAGE TypeSynonymInstances #-}
9+{-# LANGUAGE UndecidableInstances #-}
10+
11+-----------------------------------------------------------------------------
12+-- |
13+-- Module : Data.Generics.Sum.Subtype
14+-- Copyright : (C) 2017 Csongor Kiss
15+-- License : BSD3
16+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17+-- Stability : experimental
18+-- Portability : non-portable
19+--
20+-- Structural subtype relationships between sum types.
21+--
22+-----------------------------------------------------------------------------
23+
24+module Data.Generics.Sum.Subtype
25+ ( -- *Prisms
26+ --
27+ -- $example
28+ AsSubtype (..)
29+ ) where
30+
31+import Data.Generics.Internal.HList
32+import Data.Generics.Internal.Lens
33+import Data.Generics.Sum.Typed
34+
35+import Data.Kind
36+import GHC.Generics
37+
38+-- $example
39+-- @
40+-- module Example where
41+--
42+-- import Data.Generics.Sum
43+-- import GHC.Generics
44+--
45+-- data Animal
46+-- = Dog Dog
47+-- | Cat Name Age
48+-- | Duck Age
49+-- deriving (Generic, Show)
50+--
51+-- data FourLeggedAnimal
52+-- = Dog4 Dog
53+-- | Cat4 Name Age
54+-- deriving (Generic, Show)
55+--
56+-- data Dog = MkDog
57+-- { name :: Name
58+-- , age :: Age
59+-- }
60+-- deriving (Generic, Show)
61+--
62+-- type Name = String
63+-- type Age = Int
64+--
65+-- dog, cat, duck :: Animal
66+--
67+-- dog = Dog (MkDog "Shep" 3)
68+-- cat = Cat "Mog" 5
69+-- duck = Duck 2
70+--
71+-- dog4, cat4 :: FourLeggedAnimal
72+--
73+-- dog4 = Dog4 (MkDog "Snowy" 4)
74+-- cat4 = Cat4 "Garfield" 6
75+-- @
76+
77+-- |Structural subtyping between sums. A sum 'Sub' is a subtype of another sum
78+-- 'Sup' if a value of 'Sub' can be given (modulo naming of constructors)
79+-- whenever a value of 'Sup' is expected. In the running example for instance,
80+-- 'FourLeggedAnimal` is a subtype of 'Animal' since a value of the former can
81+-- be given as a value of the latter (renaming 'Dog4' to 'Dog' and 'Cat4' to
82+-- 'Cat').
83+class AsSubtype sub sup where
84+ -- |A prism that captures structural subtyping. Allows a substructure to be
85+ -- injected (upcast) into a superstructure or a superstructure to be downcast
86+ -- into a substructure (which may fail).
87+ --
88+ -- >>> _Sub # dog4 :: Animal
89+ -- Dog (MkDog {name = "Snowy", age = 4})
90+ -- >>> cat ^? _Sub :: Maybe FourLeggedAnimal
91+ -- Just (Cat4 "Mog" 5)
92+ -- >>> duck ^? _Sub :: Maybe FourLeggedAnimal
93+ -- Nothing
94+ _Sub :: Prism' sup sub
95+ _Sub = prism injectSub projectSub
96+
97+ -- |Injects a subtype into a supertype (upcast).
98+ injectSub :: sub -> sup
99+
100+ -- |Projects a subtype from a supertype (downcast).
101+ projectSub :: sup -> Either sup sub
102+
103+ {-# MINIMAL injectSub, projectSub #-}
104+
105+instance
106+ ( Generic sub
107+ , Generic sup
108+ , GAsSubtype (Rep sub) (Rep sup)
109+ ) => AsSubtype sub sup where
110+
111+ injectSub = to . ginjectSub . from
112+ projectSub = either (Left . to) (Right . to) . gprojectSub . from
113+
114+-- |As 'AsSubtype' but over generic representations as defined by
115+-- "GHC.Generics".
116+class GAsSubtype (subf :: Type -> Type) (supf :: Type -> Type) where
117+ ginjectSub :: subf x -> supf x
118+ gprojectSub :: supf x -> Either (supf x) (subf x)
119+
120+instance
121+ ( GAsSubtype l supf
122+ , GAsSubtype r supf
123+ ) => GAsSubtype (l :+: r) supf where
124+
125+ ginjectSub x = case x of
126+ L1 l -> ginjectSub l
127+ R1 r -> ginjectSub r
128+ gprojectSub x
129+ = case gprojectSub x of
130+ Left _ -> fmap R1 (gprojectSub x)
131+ Right y -> Right (L1 y)
132+
133+instance
134+ ( GAsType supf a
135+ , GCollectible subf as
136+ , ListTuple a as
137+ ) => GAsSubtype (C1 meta subf) supf where
138+
139+ ginjectSub
140+ = ginjectTyped . listToTuple . gtoCollection . unM1
141+ gprojectSub
142+ = fmap (M1 . gfromCollection . tupleToList) . gprojectTyped
143+
144+instance GAsType supf a => GAsSubtype (S1 meta (Rec0 a)) supf where
145+ ginjectSub
146+ = ginjectTyped @supf . unK1 . unM1
147+ gprojectSub
148+ = fmap (M1 . K1) . gprojectTyped @supf
149+
150+instance GAsSubtype subf supf => GAsSubtype (D1 meta subf) supf where
151+ ginjectSub
152+ = ginjectSub . unM1
153+ gprojectSub
154+ = fmap M1 . gprojectSub