git.iko.soy/generic-lens
on ccc8bcf help sign in
generic-lens/src/Data/Generics/Sum/Subtype.hs
114 lines 3.3 kB history raw
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE TypeSynonymInstances #-}
7{-# LANGUAGE UndecidableInstances #-}
9-----------------------------------------------------------------------------
10-- |
11-- Module : Data.Generics.Sum.Subtype
12-- Copyright : (C) 2017 Csongor Kiss
13-- License : BSD3
14-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
15-- Stability : experimental
16-- Portability : non-portable
17--
18-- Structural subtype relationships between sum types.
19--
20-----------------------------------------------------------------------------
22module Data.Generics.Sum.Subtype
23 ( -- *Prisms
24 --
25 -- $setup
26 AsSubtype (..)
27 ) where
29import Data.Generics.Internal.Lens
30import Data.Generics.Internal.Void
31import Data.Generics.Sum.Internal.Subtype
33import GHC.Generics (Generic (Rep, to, from))
35-- $setup
36-- == /Running example:/
37--
38-- >>> :set -XTypeApplications
39-- >>> :set -XDataKinds
40-- >>> :set -XDeriveGeneric
41-- >>> import GHC.Generics
42-- >>> :m +Data.Generics.Internal.Lens
43-- >>> :{
44-- data Animal
45-- = Dog Dog
46-- | Cat Name Age
47-- | Duck Age
48-- deriving (Generic, Show)
49-- data FourLeggedAnimal
50-- = Dog4 Dog
51-- | Cat4 Name Age
52-- deriving (Generic, Show)
53-- data Dog = MkDog
54-- { name :: Name
55-- , age :: Age
56-- }
57-- deriving (Generic, Show)
58-- type Name = String
59-- type Age = Int
60-- dog, cat, duck :: Animal
61-- dog = Dog (MkDog "Shep" 3)
62-- cat = Cat "Mog" 5
63-- duck = Duck 2
64-- dog4, cat4 :: FourLeggedAnimal
65-- dog4 = Dog4 (MkDog "Snowy" 4)
66-- cat4 = Cat4 "Garfield" 6
67-- :}
69-- |Structural subtyping between sums. A sum 'Sub' is a subtype of another sum
70-- 'Sup' if a value of 'Sub' can be given (modulo naming of constructors)
71-- whenever a value of 'Sup' is expected. In the running example for instance,
72-- 'FourLeggedAnimal` is a subtype of 'Animal' since a value of the former can
73-- be given as a value of the latter (renaming 'Dog4' to 'Dog' and 'Cat4' to
74-- 'Cat').
75class AsSubtype sub sup where
76 -- |A prism that captures structural subtyping. Allows a substructure to be
77 -- injected (upcast) into a superstructure or a superstructure to be downcast
78 -- into a substructure (which may fail).
79 --
80 -- >>> _Sub # dog4 :: Animal
81 -- Dog (MkDog {name = "Snowy", age = 4})
82 --
83 -- >>> cat ^? _Sub :: Maybe FourLeggedAnimal
84 -- Just (Cat4 "Mog" 5)
85 --
86 -- >>> duck ^? _Sub :: Maybe FourLeggedAnimal
87 -- Nothing
88 _Sub :: Prism' sup sub
89 _Sub = prism injectSub projectSub
91 -- |Injects a subtype into a supertype (upcast).
92 injectSub :: sub -> sup
94 -- |Projects a subtype from a supertype (downcast).
95 projectSub :: sup -> Either sup sub
97 {-# MINIMAL injectSub, projectSub #-}
99instance
100 ( Generic sub
101 , Generic sup
102 , GAsSubtype (Rep sub) (Rep sup)
103 ) => AsSubtype sub sup where
105 injectSub = to . ginjectSub . from
106 projectSub = either (Left . to) (Right . to) . gprojectSub . from
108-- See Note [Uncluttering type signatures]
109instance {-# OVERLAPPING #-} AsSubtype a Void where
110 injectSub = undefined
111 projectSub = undefined
112instance {-# OVERLAPPING #-} AsSubtype Void a where
113 injectSub = undefined
114 projectSub = undefined