git.iko.soy/generic-lens
on ef002d2 help sign in
generic-lens/src/Data/Generics/Sum/Subtype.hs
119 lines 3.5 kB history raw
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE MonoLocalBinds #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE TypeApplications #-}
7{-# LANGUAGE TypeOperators #-}
8{-# LANGUAGE TypeSynonymInstances #-}
9{-# LANGUAGE UndecidableInstances #-}
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-----------------------------------------------------------------------------
24module Data.Generics.Sum.Subtype
25 ( -- *Prisms
26 --
27 -- $setup
28 AsSubtype (..)
29 ) where
31import Data.Generics.Internal.Void
32import Data.Generics.Sum.Internal.Subtype
34import GHC.Generics (Generic (Rep))
35import Data.Generics.Internal.VL.Prism
36import Data.Generics.Internal.Profunctor.Iso
38-- $setup
39-- == /Running example:/
40--
41-- >>> :set -XTypeApplications
42-- >>> :set -XDataKinds
43-- >>> :set -XDeriveGeneric
44-- >>> import GHC.Generics
45-- >>> :m +Data.Generics.Internal.VL.Prism
46-- >>> :{
47-- data Animal
48-- = Dog Dog
49-- | Cat Name Age
50-- | Duck Age
51-- deriving (Generic, Show)
52-- data FourLeggedAnimal
53-- = Dog4 Dog
54-- | Cat4 Name Age
55-- deriving (Generic, Show)
56-- data Dog = MkDog
57-- { name :: Name
58-- , age :: Age
59-- }
60-- deriving (Generic, Show)
61-- type Name = String
62-- type Age = Int
63-- dog, cat, duck :: Animal
64-- dog = Dog (MkDog "Shep" 3)
65-- cat = Cat "Mog" 5
66-- duck = Duck 2
67-- dog4, cat4 :: FourLeggedAnimal
68-- dog4 = Dog4 (MkDog "Snowy" 4)
69-- cat4 = Cat4 "Garfield" 6
70-- :}
72-- |Structural subtyping between sums. A sum 'Sub' is a subtype of another sum
73-- 'Sup' if a value of 'Sub' can be given (modulo naming of constructors)
74-- whenever a value of 'Sup' is expected. In the running example for instance,
75-- 'FourLeggedAnimal` is a subtype of 'Animal' since a value of the former can
76-- be given as a value of the latter (renaming 'Dog4' to 'Dog' and 'Cat4' to
77-- 'Cat').
78class AsSubtype sub sup where
79 -- |A prism that captures structural subtyping. Allows a substructure to be
80 -- injected (upcast) into a superstructure or a superstructure to be downcast
81 -- into a substructure (which may fail).
82 --
83 -- >>> _Sub # dog4 :: Animal
84 -- Dog (MkDog {name = "Snowy", age = 4})
85 --
86 -- >>> cat ^? _Sub :: Maybe FourLeggedAnimal
87 -- Just (Cat4 "Mog" 5)
88 --
89 -- >>> duck ^? _Sub :: Maybe FourLeggedAnimal
90 -- Nothing
91 _Sub :: Prism' sup sub
92 _Sub = prism injectSub projectSub
94 -- |Injects a subtype into a supertype (upcast).
95 injectSub :: sub -> sup
96 injectSub = build (_Sub @sub @sup)
98 -- |Projects a subtype from a supertype (downcast).
99 projectSub :: sup -> Either sup sub
100 projectSub = match (_Sub @sub @sup)
102 {-# MINIMAL (injectSub, projectSub) | _Sub #-}
104instance
105 ( Generic sub
106 , Generic sup
107 , GAsSubtype (Rep sub) (Rep sup)
108 ) => AsSubtype sub sup where
110 _Sub f = prismRavel (repIso . _GSub . fromIso repIso) f
111 {-# INLINE[2] _Sub #-}
113-- See Note [Uncluttering type signatures]
114instance {-# OVERLAPPING #-} AsSubtype a Void where
115 injectSub = undefined
116 projectSub = undefined
117instance {-# OVERLAPPING #-} AsSubtype Void a where
118 injectSub = undefined
119 projectSub = undefined