git.iko.soy/generic-lens
on bfcd00a help sign in
generic-lens/src/Data/Generics/Sum/Subtype.hs
108 lines 3.0 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 -- $example
26 AsSubtype (..)
27 ) where
29import Data.Generics.Internal.Lens
30import Data.Generics.Sum.Internal.Subtype
32import GHC.Generics (Generic (Rep, to, from))
34-- $example
35-- @
36-- module Example where
37--
38-- import Data.Generics.Sum
39-- import GHC.Generics
40--
41-- data Animal
42-- = Dog Dog
43-- | Cat Name Age
44-- | Duck Age
45-- deriving (Generic, Show)
46--
47-- data FourLeggedAnimal
48-- = Dog4 Dog
49-- | Cat4 Name Age
50-- deriving (Generic, Show)
51--
52-- data Dog = MkDog
53-- { name :: Name
54-- , age :: Age
55-- }
56-- deriving (Generic, Show)
57--
58-- type Name = String
59-- type Age = Int
60--
61-- dog, cat, duck :: Animal
62--
63-- dog = Dog (MkDog "Shep" 3)
64-- cat = Cat "Mog" 5
65-- duck = Duck 2
66--
67-- dog4, cat4 :: FourLeggedAnimal
68--
69-- dog4 = Dog4 (MkDog "Snowy" 4)
70-- cat4 = Cat4 "Garfield" 6
71-- @
73-- |Structural subtyping between sums. A sum 'Sub' is a subtype of another sum
74-- 'Sup' if a value of 'Sub' can be given (modulo naming of constructors)
75-- whenever a value of 'Sup' is expected. In the running example for instance,
76-- 'FourLeggedAnimal` is a subtype of 'Animal' since a value of the former can
77-- be given as a value of the latter (renaming 'Dog4' to 'Dog' and 'Cat4' to
78-- 'Cat').
79class AsSubtype sub sup where
80 -- |A prism that captures structural subtyping. Allows a substructure to be
81 -- injected (upcast) into a superstructure or a superstructure to be downcast
82 -- into a substructure (which may fail).
83 --
84 -- >>> _Sub # dog4 :: Animal
85 -- Dog (MkDog {name = "Snowy", age = 4})
86 -- >>> cat ^? _Sub :: Maybe FourLeggedAnimal
87 -- Just (Cat4 "Mog" 5)
88 -- >>> duck ^? _Sub :: Maybe FourLeggedAnimal
89 -- Nothing
90 _Sub :: Prism' sup sub
91 _Sub = prism injectSub projectSub
93 -- |Injects a subtype into a supertype (upcast).
94 injectSub :: sub -> sup
96 -- |Projects a subtype from a supertype (downcast).
97 projectSub :: sup -> Either sup sub
99 {-# MINIMAL injectSub, projectSub #-}
101instance
102 ( Generic sub
103 , Generic sup
104 , GAsSubtype (Rep sub) (Rep sup)
105 ) => AsSubtype sub sup where
107 injectSub = to . ginjectSub . from
108 projectSub = either (Left . to) (Right . to) . gprojectSub . from