git.iko.soy/generic-lens
on master help sign in
Structural subtype lens
d3e8458Csongor Kiss
generic-records.cabal+2−1
compare with master
unifiedsplit
@@ -32,8 +32,9 @@ library
32 exposed-modules: Data.Generic.Record
32 exposed-modules: Data.Generic.Record
33 , Data.Generic.Record.Subtype
33 , Data.Generic.Record.Subtype
34 , Data.Generic.Record.HasField
34 , Data.Generic.Record.HasField
35+ , Data.Generic.Internal.Lens
35
36
36− other-modules: Data.Generic.Internal.Lens
37+ other-modules: Data.Generic.Record.Internal.Contains
37
38
38 other-extensions: AllowAmbiguousTypes
39 other-extensions: AllowAmbiguousTypes
39 , DataKinds
40 , DataKinds
src/Data/Generic/Internal/Lens.hs+1−1
@@ -10,7 +10,7 @@
10-- Stability : experimental
10-- Stability : experimental
11-- Portability : non-portable
11-- Portability : non-portable
12--
12--
13−-- Unexported lens helpers
13+-- Internal lens helpers. Only exported for Haddock
14--
14--
15-----------------------------------------------------------------------------
15-----------------------------------------------------------------------------
16module Data.Generic.Internal.Lens where
16module Data.Generic.Internal.Lens where
src/Data/Generic/Record/HasField.hs+3−29
@@ -34,9 +34,11 @@ module Data.Generic.Record.HasField
34 , GHasField (..)
34 , GHasField (..)
35 ) where
35 ) where
36
36
37+import Data.Generic.Record.Internal.Contains
38+
37import Data.Generic.Internal.Lens
39import Data.Generic.Internal.Lens
38
40
39−import GHC.TypeLits (Symbol, TypeError, ErrorMessage(..))
41+import GHC.TypeLits (Symbol)
40import Data.Kind (Type)
42import Data.Kind (Type)
41import GHC.Generics
43import GHC.Generics
42
44
@@ -109,34 +111,6 @@ instance (GHasField field g ret) => GHasFieldProd field f g ret 'Nothing where
109
111
110--------------------------------------------------------------------------------
112--------------------------------------------------------------------------------
111
113
112−-- | Look up a record field by name in the generic representation, and return
113−-- its corresponding type, if exists.
114−type family Contains (field :: Symbol) f :: Maybe Type where
115− Contains field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 t))
116− = 'Just t
117− Contains field (f :*: g)
118− = Contains field f <|> Contains field g
119− Contains field (S1 _ _)
120− = 'Nothing
121− Contains field (C1 m f)
122− = Contains field f
123− Contains field (D1 m f)
124− = Contains field f
125− Contains field (Rec0 _)
126− = 'Nothing
127− Contains field U1
128− = 'Nothing
129− Contains field V1
130− = 'Nothing
131− Contains x t = TypeError ('ShowType t)
132−
133−-- | Type-level alternative
134−type family (a :: Maybe k) <|> (b :: Maybe k) :: Maybe k where
135− 'Just x <|> _ = 'Just x
136− _ <|> b = b
137−
138−--------------------------------------------------------------------------------
139−
140-- | Like 'HasField', but on the generic representation
114-- | Like 'HasField', but on the generic representation
141class GHasField (field :: Symbol) (s :: Type -> Type) a | field s -> a where
115class GHasField (field :: Symbol) (s :: Type -> Type) a | field s -> a where
142 glabel :: Lens' (s x) a
116 glabel :: Lens' (s x) a
src/Data/Generic/Record/Internal/Contains.hsnew file+57
@@ -0,0 +1,57 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE PolyKinds #-}
6+{-# LANGUAGE Rank2Types #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeApplications #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeOperators #-}
11+{-# LANGUAGE UndecidableInstances #-}
12+
13+-----------------------------------------------------------------------------
14+-- |
15+-- Module : Data.Generic.Record.Internal.Contains
16+-- Copyright : (C) 2017 Csongor Kiss
17+-- License : BSD3
18+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19+-- Stability : experimental
20+-- Portability : non-portable
21+--
22+-- Look up fields in the generic representation
23+--
24+-----------------------------------------------------------------------------
25+module Data.Generic.Record.Internal.Contains where
26+
27+import Data.Kind (Type)
28+import GHC.Generics
29+
30+import GHC.TypeLits
31+
32+-- | Look up a record field by name in the generic representation, and return
33+-- its corresponding type, if exists.
34+type family Contains (field :: Symbol) f :: Maybe Type where
35+ Contains field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 t))
36+ = 'Just t
37+ Contains field (f :*: g)
38+ = Contains field f <|> Contains field g
39+ Contains field (S1 _ _)
40+ = 'Nothing
41+ Contains field (C1 m f)
42+ = Contains field f
43+ Contains field (D1 m f)
44+ = Contains field f
45+ Contains field (Rec0 _)
46+ = 'Nothing
47+ Contains field U1
48+ = 'Nothing
49+ Contains field V1
50+ = 'Nothing
51+ Contains x t = TypeError ('ShowType t)
52+
53+-- | Type-level alternative
54+type family (a :: Maybe k) <|> (b :: Maybe k) :: Maybe k where
55+ 'Just x <|> _ = 'Just x
56+ _ <|> b = b
57+
src/Data/Generic/Record/Subtype.hs+81−29
@@ -19,20 +19,9 @@
19-- Stability : experimental
19-- Stability : experimental
20-- Portability : non-portable
20-- Portability : non-portable
21--
21--
22−-- Structural subtyping
22+-- Structural subtype relationship between record types.
23--
23--
24−-----------------------------------------------------------------------------
24+-- The running example in this module is the following two types:
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
36--
25--
37-- @
26-- @
38--
27--
@@ -57,30 +46,93 @@ import GHC.Generics
57--
46--
58-- @
47-- @
59--
48--
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
60--
64--
61−-- >>> human
65+-- @sub@ is a (structural) `subtype' of @sup@, if its fields are a subset of
62−-- Human {name = "Tunyasz", age = 50, address = "London"}
66+-- those of @sup@.
63−--
64−-- >>> upcast human :: Animal
65−-- Animal {name = "Tunyasz", age = 50}
66--
67--
67class Subtype sub sup where
68class Subtype sub sup where
68 -- | Cast the more specific subtype to the more general supertype
69 -- | Cast the more specific subtype to the more general supertype
70+ --
71+ -- >>> upcast human :: Animal
72+ -- Animal {name = "Tunyasz", age = 50}
73+ --
69 upcast :: sub -> sup
74 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
70
80
71-- | Instances are created by the compiler
81-- | Instances are created by the compiler
72−instance (Convert (Rep a) (Rep b), Generic a, Generic b) => Subtype a b where
82+instance (GSmash (Rep a) (Rep b), GUpcast (Rep a) (Rep b), Generic a, Generic b) => Subtype a b where
73− upcast = to . convert . from
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)
74
127
75−-- | Convert 'rep' into 'f'
128+instance GSmash sub sup => GSmash (M1 i c sub) sup where
76−class Convert (rep :: Type -> Type) (f :: Type -> Type) where
129+ gsmash sup (M1 sub) = M1 (gsmash sup sub)
77− convert :: rep p -> f p
78
130
79−instance (Convert rep a, Convert rep b) => Convert rep (a :*: b) where
131+class GSmashLeaf sub sup (w :: Maybe Type) where
80− convert rep = convert rep :*: convert rep
132+ gsmashLeaf :: sup p -> sub p -> sub p
81
133
82−instance {-# OVERLAPPING #-} GHasField field rep t => Convert rep (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
134+instance (GHasField field sup t) => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup ('Just t) where
83− convert rep = M1 (K1 (rep ^. glabel @field))
135+ gsmashLeaf sup (M1 (K1 _)) = M1 (K1 (sup ^. glabel @field))
84
136
85−instance Convert rep f => Convert rep (M1 i c f) where
137+instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'Nothing where
86− convert = M1 . convert
138+ gsmashLeaf _ = id