git.iko.soy/generic-lens
on master help sign in
Move get* and set* functions to the type classes
commit7686468211b8a1b359469999cfc8df121afaa75e authorCsongor Kiss <kiss.csongor.kiss@gmail.com> dateSun 30 Jul 2017, 21:22 (9 years ago) parent7a33e39
6 files changed+106−250
compare with master
unifiedsplit
src/Data/Generics/Product.hs+1−7 src/Data/Generics/Product/Fields.hs+18−18 src/Data/Generics/Product/Numbered.hs−177 src/Data/Generics/Product/Positions.hs+19−16 src/Data/Generics/Product/Subtype.hs+56−32 src/Data/Generics/Product/Typed.hs+12
src/Data/Generics/Product.hs+1−7
@@ -19,18 +19,12 @@ module Data.Generics.Product
1919 HasAny (..)
2020
2121 , HasField (..)
22− , setField
23− , getField
24−
2522 , HasPosition (..)
26− , setPosition
27− , getPosition
28−
2923 , HasType (..)
3024
3125 -- * Subtype relationship
3226 , Subtype (..)
33− , super
27+
3428 ) where
3529
3630import Data.Generics.Product.Any
src/Data/Generics/Product/Fields.hs+18−18
@@ -29,10 +29,6 @@ module Data.Generics.Product.Fields
2929 -- $example
3030 HasField (..)
3131
32− -- *Getter and setter functions
33− , getField
34− , setField
35−
3632 -- *Internals
3733 , GHasField (..)
3834 ) where
@@ -62,20 +58,6 @@ import GHC.TypeLits
6258-- human = Human \"Tunyasz\" 50 \"London\"
6359-- @
6460
65−-- | Get 'field'
66−--
67−-- >>> getField @"name" human
68−-- "Tunyasz"
69−getField :: forall field a s. HasField field a s => s -> a
70−getField s = s ^. field @field
71−
72−-- | Set 'field'
73−--
74−-- >>> setField @"age" (setField @"name" "Tamas" human) 30
75−-- Human {name = "Tamas", age = 30, address = "London"}
76−setField :: forall field a s. HasField field a s => a -> s -> s
77−setField = set (field @field)
78−
7961-- | Records that have a field with a given name.
8062class HasField (field :: Symbol) a s | s field -> a where
8163 -- |A lens that focuses on a field with a given name. Compatible with the
@@ -86,6 +68,24 @@ class HasField (field :: Symbol) a s | s field -> a where
8668 -- >>> human & field @"name" .~ "Tamas"
8769 -- Human {name = "Tamas", age = 50, address = "London"}
8870 field :: Lens' s a
71+ field f s
72+ = fmap (flip (setField @field) s) (f (getField @field s))
73+
74+ -- | Get 'field'
75+ --
76+ -- >>> getField @"name" human
77+ -- "Tunyasz"
78+ getField :: s -> a
79+ getField s = s ^. field @field
80+
81+ -- | Set 'field'
82+ --
83+ -- >>> setField @"age" (setField @"name" "Tamas" human) 30
84+ -- Human {name = "Tamas", age = 30, address = "London"}
85+ setField :: a -> s -> s
86+ setField = set (field @field)
87+
88+ {-# MINIMAL field | setField, getField #-}
8989
9090instance
9191 ( Generic s
src/Data/Generics/Product/Numbered.hsdeleted−177
@@ -1,177 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE FunctionalDependencies #-}
5−{-# LANGUAGE KindSignatures #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE PolyKinds #-}
8−{-# LANGUAGE ScopedTypeVariables #-}
9−{-# LANGUAGE TypeApplications #-}
10−{-# LANGUAGE TypeFamilies #-}
11−{-# LANGUAGE TypeOperators #-}
12−{-# LANGUAGE UndecidableInstances #-}
13−
14−-----------------------------------------------------------------------------
15−-- |
16−-- Module : Data.Generics.Record.HasField
17−-- Copyright : (C) 2017 Csongor Kiss
18−-- License : BSD3
19−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20−-- Stability : experimental
21−-- Portability : non-portable
22−--
23−-- Derive positional product type getters and setters generically.
24−--
25−-----------------------------------------------------------------------------
26−
27−module Data.Generics.Product.Positions
28− ( -- *Lenses
29−
30− -- $example
31− HasPosition (..)
32− , setPosition
33− , getPosition
34−
35− -- *Internals
36− , GHasPosition (..)
37− ) where
38−
39−import Data.Generics.Internal.Lens
40−
41−import Data.Kind (Constraint, Type)
42−import GHC.Generics
43−import GHC.TypeLits
44−
45−-- $example
46−-- @
47−-- module Example where
48−--
49−-- import Data.Generics.Product
50−-- import GHC.Generics
51−--
52−-- data Human = Human
53−-- { name :: String
54−-- , age :: Int
55−-- , address :: String
56−-- }
57−-- deriving (Generic, Show)
58−--
59−-- human :: Human
60−-- human = Human \"Tunyasz\" 50 \"London\"
61−-- @
62−
63−-- | Get positional field
64−--
65−-- >>> getPosition @1 human
66−-- "Tunyasz"
67−getPosition :: forall i a s. HasPosition i a s => s -> a
68−getPosition s = s ^. position @i
69−
70−-- | Set positional field
71−--
72−-- >>> setPosition @2 (setField @1 "Tamas" human) 30
73−-- Human "Tamas" 30 "London"
74−setPosition :: forall i a s. HasPosition i a s => a -> s -> s
75−setPosition = set (position @i)
76−
77−-- |Records that have a field at a given position.
78−class HasPosition (i :: Nat) a s | s i -> a where
79− -- |A lens that focuses on a field at a given position. Compatible with the
80− -- lens package's 'Control.Lens.Lens' type.
81− --
82− -- >>> human ^. position @1
83− -- "Tunyasz"
84− -- >>> human & position @2 .~ "Berlin"
85− -- Human {name = "Tunyasz", age = 50, address = "Berlin"}
86− position :: Lens' s a
87−
88−instance
89− ( Generic s
90− , ErrorUnlessTrue i s (0 <? i && i <=? Size (Rep s))
91− , GHasPosition 1 i (Rep s) a
92− ) => HasPosition i a s where
93−
94− position = repIso . gposition @1 @i
95−
96−type family ErrorUnlessTrue (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint where
97− ErrorUnlessTrue i s 'False
98− = TypeError
99− ( 'Text "The type "
100− ':<>: 'ShowType s
101− ':<>: 'Text " does not contain a field at position "
102− ':<>: 'ShowType i
103− )
104−
105− ErrorUnlessTrue _ _ 'True
106− = ()
107−
108−-- |As 'HasPosition' but over generic representations as defined by
109−-- "GHC.Generics".
110−class GHasPosition (offset :: Nat) (i :: Nat) (f :: Type -> Type) a | offset i f -> a where
111− gposition :: Lens' (f x) a
112−
113−instance GHasPosition i i (S1 meta (Rec0 a)) a where
114− gposition = mIso . gposition @i @i
115−
116−instance GHasPosition offset i (K1 R a) a where
117− gposition f (K1 x) = fmap K1 (f x)
118−
119−instance GHasPosition offset i f a => GHasPosition offset i (M1 D meta f) a where
120− gposition = mIso . gposition @offset @i
121−
122−instance GHasPosition offset i f a => GHasPosition offset i (M1 C meta f) a where
123− gposition = mIso . gposition @offset @i
124−
125−instance
126− ( goLeft ~ (i <? (offset + Size l))
127− , offset' ~ (If goLeft offset (offset + Size l))
128− , GProductHasPosition offset' i l r a goLeft
129− ) => GHasPosition offset i (l :*: r) a where
130−
131− gposition = gproductPosition @offset' @i @_ @_ @_ @goLeft
132−
133−
134−class GProductHasPosition (offset :: Nat) (i :: Nat) l r a (left :: Bool) | offset i l r left -> a where
135− gproductPosition :: Lens' ((l :*: r) x) a
136−
137−instance GHasPosition offset i l a => GProductHasPosition offset i l r a 'True where
138− gproductPosition = first . gposition @offset @i
139−
140−instance GHasPosition offset i r a => GProductHasPosition offset i l r a 'False where
141− gproductPosition = second . gposition @offset @i
142−
143−type family Size f :: Nat where
144− Size (l :*: r)
145− = Size l + Size r
146− Size (l :+: r)
147− = Size l + Size r
148− Size (D1 meta f)
149− = Size f
150− Size (C1 meta f)
151− = Size f
152− Size f
153− = 1
154−
155−--------------------------------------------------------------------------------
156−
157−type family Not (b :: Bool) where
158− Not 'True = 'False
159− Not 'False = 'True
160−
161−type family (<?) (x :: Nat) (y :: Nat) :: Bool where
162− x <? y = Not (y <=? x)
163−
164−infixl 4 <?
165−
166−type family If (c :: Bool) (x :: k) (y :: k) :: k where
167− If 'True x _ = x
168− If 'False _ y = y
169−
170−type family Min (a :: Nat) (b :: Nat) :: Nat where
171− Min a b = If (a <? b) a b
172−
173−type family (a :: Bool) && (b :: Bool) :: Bool where
174− 'True && 'True = 'True
175− _ && _ = 'False
176−
177−infix 3 &&
src/Data/Generics/Product/Positions.hs+19−16
@@ -29,8 +29,6 @@ module Data.Generics.Product.Positions
2929
3030 -- $example
3131 HasPosition (..)
32− , setPosition
33− , getPosition
3432
3533 -- *Internals
3634 , GHasPosition (..)
@@ -60,20 +58,6 @@ import GHC.TypeLits
6058-- human = Human \"Tunyasz\" 50 \"London\"
6159-- @
6260
63−-- | Get positional field
64−--
65−-- >>> getPosition @1 human
66−-- "Tunyasz"
67−getPosition :: forall i a s. HasPosition i a s => s -> a
68−getPosition s = s ^. position @i
69−
70−-- | Set positional field
71−--
72−-- >>> setPosition @2 (setField @1 "Tamas" human) 30
73−-- Human "Tamas" 30 "London"
74−setPosition :: forall i a s. HasPosition i a s => a -> s -> s
75−setPosition = set (position @i)
76−
7761-- |Records that have a field at a given position.
7862class HasPosition (i :: Nat) a s | s i -> a where
7963 -- |A lens that focuses on a field at a given position. Compatible with the
@@ -84,6 +68,25 @@ class HasPosition (i :: Nat) a s | s i -> a where
8468 -- >>> human & position @2 .~ "Berlin"
8569 -- Human {name = "Tunyasz", age = 50, address = "Berlin"}
8670 position :: Lens' s a
71+ position f s
72+ = fmap (flip (setPosition @i) s) (f (getPosition @i s))
73+ -- = fmap (setPosition s) (f (getPosition s))
74+
75+ -- |Get positional field
76+ --
77+ -- >>> getPosition @1 human
78+ -- "Tunyasz"
79+ getPosition :: s -> a
80+ getPosition s = s ^. position @i
81+
82+ -- |Set positional field
83+ --
84+ -- >>> setPosition @2 (setField @1 "Tamas" human) 30
85+ -- Human "Tamas" 30 "London"
86+ setPosition :: a -> s -> s
87+ setPosition = set (position @i)
88+
89+ {-# MINIMAL position | setPosition, getPosition #-}
8790
8891instance
8992 ( Generic s
src/Data/Generics/Product/Subtype.hs+56−32
@@ -1,14 +1,16 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE MultiParamTypeClasses #-}
5−{-# LANGUAGE PolyKinds #-}
6−{-# LANGUAGE Rank2Types #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE TypeApplications #-}
9−{-# LANGUAGE TypeFamilies #-}
10−{-# LANGUAGE TypeOperators #-}
11−{-# LANGUAGE UndecidableInstances #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE NoMonomorphismRestriction #-}
7+{-# LANGUAGE PolyKinds #-}
8+{-# LANGUAGE Rank2Types #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TypeApplications #-}
11+{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE TypeOperators #-}
13+{-# LANGUAGE UndecidableInstances #-}
1214
1315-----------------------------------------------------------------------------
1416-- |
@@ -49,7 +51,6 @@
4951-----------------------------------------------------------------------------
5052module Data.Generics.Product.Subtype
5153 ( Subtype (..)
52− , super
5354 ) where
5455
5556import Data.Generics.Product.Fields
@@ -65,34 +66,45 @@ import GHC.Generics
6566-- @sub@ is a (structural) `subtype' of @sup@, if its fields are a subset of
6667-- those of @sup@.
6768--
68−class Subtype sub sup where
69+class Subtype sup sub where
70+ -- | Structural subtype lens. Given a subtype relationship @sub :< sup@,
71+ -- we can focus on the @sub@ structure of @sup@.
72+ --
73+ -- >>> human ^. super @Animal
74+ -- Animal {name = "Tunyasz", age = 50}
75+ --
76+ -- >>> set (super @Animal) (Animal "dog" 10) human
77+ -- Human {name = "dog", age = 10, address = "London"}
78+ super :: Lens' sub sup
79+ super f sub
80+ = fmap (`smash` sub) (f (upcast sub))
81+
6982 -- | Cast the more specific subtype to the more general supertype
7083 --
7184 -- >>> upcast human :: Animal
7285 -- Animal {name = "Tunyasz", age = 50}
7386 --
7487 upcast :: sub -> sup
88+ upcast s = s ^. super @sup
89+
7590 -- | Plug a smaller structure into a larger one
7691 --
7792 -- >>> smash (Animal "dog" 10) human
7893 -- Human {name = "dog", age = 10, address = "London"}
7994 smash :: sup -> sub -> sub
95+ smash = set (super @sup)
8096
81−-- | Instances are created by the compiler
82−instance (GSmash (Rep a) (Rep b), GUpcast (Rep a) (Rep b), Generic a, Generic b) => Subtype a b where
83− upcast = to . gupcast . from
84− smash p b = to $ gsmash (from p) (from b)
97+ {-# MINIMAL super | smash, upcast #-}
8598
86−-- | Structural subtype lens. Given a subtype relationship @sub :< sup@,
87−-- we can focus on the @sub@ structure of @sup@.
88−--
89−-- >>> human ^. super @Animal
90−-- Animal {name = "Tunyasz", age = 50}
91−--
92−-- >>> set (super @Animal) (Animal "dog" 10) human
93−-- Human {name = "dog", age = 10, address = "London"}
94−super :: forall sup sub. Subtype sub sup => Lens' sub sup
95−super f sub = fmap (`smash` sub) (f (upcast sub))
99+-- | Instances are created by the compiler
100+instance
101+ ( GSmash (Rep a) (Rep b)
102+ , GUpcast (Rep a) (Rep b)
103+ , Generic a
104+ , Generic b
105+ ) => Subtype b a where
106+ smash p b = to $ gsmash (from p) (from b)
107+ upcast = to . gupcast . from
96108
97109--------------------------------------------------------------------------------
98110-- * Generic upcasting
@@ -104,10 +116,16 @@ class GUpcast (sub :: Type -> Type) (sup :: Type -> Type) where
104116instance (GUpcast sub a, GUpcast sub b) => GUpcast sub (a :*: b) where
105117 gupcast rep = gupcast rep :*: gupcast rep
106118
107−instance {-# OVERLAPPING #-} GHasField field sub t => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
119+instance
120+ GHasField field sub t
121+ => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
122+
108123 gupcast r = M1 (K1 (r ^. gfield @field))
109124
110−instance GUpcast sub sup => GUpcast sub (M1 i c sup) where
125+instance GUpcast sub sup => GUpcast sub (C1 c sup) where
126+ gupcast = M1 . gupcast
127+
128+instance GUpcast sub sup => GUpcast sub (D1 c sup) where
111129 gupcast = M1 . gupcast
112130
113131--------------------------------------------------------------------------------
@@ -119,19 +137,25 @@ class GSmash sub sup where
119137instance (GSmash a sup, GSmash b sup) => GSmash (a :*: b) sup where
120138 gsmash rep (a :*: b) = gsmash rep a :*: gsmash rep b
121139
122−instance {-# OVERLAPPING #-}
140+instance
123141 ( leaf ~ (S1 ('MetaSel ('Just field) p f b) t)
124142 , GSmashLeaf leaf sup (HasFieldP field sup)
125143 ) => GSmash (S1 ('MetaSel ('Just field) p f b) t) sup where
144+
126145 gsmash = gsmashLeaf @_ @_ @(HasFieldP field sup)
127146
128−instance GSmash sub sup => GSmash (M1 i c sub) sup where
147+instance GSmash sub sup => GSmash (C1 c sub) sup where
148+ gsmash sup (M1 sub) = M1 (gsmash sup sub)
149+
150+instance GSmash sub sup => GSmash (D1 c sub) sup where
129151 gsmash sup (M1 sub) = M1 (gsmash sup sub)
130152
131153class GSmashLeaf sub sup (w :: Bool) where
132154 gsmashLeaf :: sup p -> sub p -> sub p
133155
134−instance (GHasField field sup t) => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'True where
156+instance
157+ GHasField field sup t
158+ => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'True where
135159 gsmashLeaf sup (M1 (K1 _)) = M1 (K1 (sup ^. gfield @field))
136160
137161instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'False where
src/Data/Generics/Product/Typed.hs+12
@@ -66,6 +66,18 @@ class HasType a s where
6666 -- >>> human ^. typed @Int
6767 -- 50
6868 typed :: Lens' s a
69+ typed f t
70+ = fmap (flip (setTyped @a) t) (f (getTyped @a t))
71+
72+ -- |Get field at type
73+ getTyped :: s -> a
74+ getTyped s = s ^. typed @a
75+
76+ -- |Set field at type
77+ setTyped :: a -> s -> s
78+ setTyped = set (typed @a)
79+
80+ {-# MINIMAL typed | setTyped, getTyped #-}
6981
7082instance
7183 ( Generic s