git.iko.soy/generic-lens
on master help sign in
Clean up and add more documentation.
bd4a0daWill Jones
src/Data/Generics/Product.hs+7−9
compare with master
unifiedsplit
@@ -15,14 +15,12 @@
15--
15--
16-----------------------------------------------------------------------------
16-----------------------------------------------------------------------------
17module Data.Generics.Product
17module Data.Generics.Product
18− (
18+ ( -- * Lenses
19− -- * Magic lens
19+ HasField (..)
20− HasFieldAt (..)
20+ , HasPosition (..)
21−
21+ , HasType (..)
22− -- * Getter and setter
23− , getFieldAt
24− , setFieldAt
25−
26 ) where
22 ) where
27
23
28−import Data.Generics.Product.HasFieldAt
24+import Data.Generics.Product.Fields
25+import Data.Generics.Product.Numbered
26+import Data.Generics.Product.Typed
src/Data/Generics/Product/Fields.hs+46−1
@@ -10,9 +10,26 @@
10{-# LANGUAGE TypeOperators #-}
10{-# LANGUAGE TypeOperators #-}
11{-# LANGUAGE UndecidableInstances #-}
11{-# LANGUAGE UndecidableInstances #-}
12
12
13+-----------------------------------------------------------------------------
14+-- |
15+-- Module : Data.Generics.Record.HasField
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+-- Derive record field getters and setters generically.
23+--
24+-----------------------------------------------------------------------------
25+
13module Data.Generics.Product.Fields
26module Data.Generics.Product.Fields
27+ ( -- * Lenses
28+ --
29+ -- $example
14− ( HasField (..)
30+ HasField (..)
15
31
32+ -- * Internals
16 , GHasField (..)
33 , GHasField (..)
17 ) where
34 ) where
18
35
@@ -23,7 +40,33 @@ import Data.Kind (Constraint, Type)
23import GHC.Generics
40import GHC.Generics
24import GHC.TypeLits
41import GHC.TypeLits
25
42
43+-- $example
44+-- @
45+-- module Example where
46+--
47+-- import Data.Generics.Product
48+-- import GHC.Generics
49+--
50+-- data Human = Human
51+-- { name :: String
52+-- , age :: Int
53+-- , address :: String
54+-- }
55+-- deriving (Generic, Show)
56+--
57+-- human :: Human
58+-- human = Human \"Tunyasz\" 50 \"London\"
59+-- @
60+
61+-- | Records that have a field with a given name.
26class HasField (field :: Symbol) a s | s field -> a where
62class HasField (field :: Symbol) a s | s field -> a where
63+ -- | A lens that focuses on a field with a given name. Compatible with the
64+ -- lens package's 'Control.Lens.Lens' type.
65+ --
66+ -- >>> human ^. field @"age"
67+ -- 50
68+ -- >>> human & field @"name" .~ "Tamas"
69+ -- Human {name = "Tamas", age = 50, address = "London"}
27 field :: Lens' s a
70 field :: Lens' s a
28
71
29instance (Generic s,
72instance (Generic s,
@@ -48,6 +91,8 @@ type family ErrorUnlessJust (field :: Symbol) (s :: Type) (found :: Maybe Type)
48 ErrorUnlessJust _ _ ('Just _)
91 ErrorUnlessJust _ _ ('Just _)
49 = ()
92 = ()
50
93
94+-- | As 'HasField' but over generic representations as defined by
95+-- "GHC.Generics".
51class GHasField (field :: Symbol) (f :: Type -> Type) a | field f -> a where
96class GHasField (field :: Symbol) (f :: Type -> Type) a | field f -> a where
52 gfield :: Lens' (f x) a
97 gfield :: Lens' (f x) a
53
98
src/Data/Generics/Product/HasFieldAt.hsdeleted−176
@@ -1,176 +0,0 @@
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.Generics.Product.HasFieldAt
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−-- Derive product items lenses generically.
23−--
24−-- @
25−--
26−-- module Example where
27−--
28−-- import GHC.Generics
29−-- import Data.Generics.Product
30−--
31−-- data Human = Human String Int String
32−-- deriving (Generic, Show)
33−--
34−-- human :: Human
35−-- human = Human \"Tunyasz\" 50 \"London\"
36−--
37−-- @
38−--
39−-----------------------------------------------------------------------------
40−
41−module Data.Generics.Product.HasFieldAt
42− ( HasFieldAt (..)
43− -- * Getter and setter functions
44− , getFieldAt
45− , setFieldAt
46− ) where
47−
48−import Data.Generics.Internal.Lens
49−
50−import GHC.TypeLits
51−import Data.Kind (Type)
52−import GHC.Generics
53−
54−-- | Get positional field
55−--
56−-- >>> getFieldAt @1 human
57−-- "Tunyasz"
58−getFieldAt :: forall index a s. HasFieldAt index a s => s -> a
59−getFieldAt s = s ^. itemAt @index
60−
61−-- | Set positional field
62−--
63−-- >>> setFieldAt @2 (setField @1 "Tamas" human) 30
64−-- Human "Tamas" 30 "London"
65−setFieldAt :: forall index a s. HasFieldAt index a s => a -> s -> s
66−setFieldAt = set (itemAt @index)
67−
68−-- | Types that have a field at given position.
69−class HasFieldAt (index :: Nat) a s | s index -> a where
70− -- ^ Lens focusing on a field at a given index.
71− -- Compatible with the lens package.
72− --
73− -- >>> human & itemAt @1 .~ "Tamas"
74− -- Human "Tamas" 50 "London"
75− itemAt :: Lens' s a
76−
77−-- | Fields are indexed from BaseIndex upwards.
78−type BaseIndex = 1
79−
80−-- | Instances are generated on the fly for all types that have the required
81−-- positional field.
82−instance
83− ( Generic s
84− , ContainsAt BaseIndex index (Rep s) ~ 'True -- this is needed for the fundep
85− , GHasFieldAt BaseIndex index (Rep s) a
86− ) => HasFieldAt index a s where
87− itemAt = repIso . gItemAt @BaseIndex @index
88−
89−data Choice = GoLeft | GoRight
90−
91−class GHasFieldAtProd offset index a b ret (w :: Choice) | offset index a b w -> ret where
92− prodItemAt :: Lens' ((a :*: b) x) ret
93−
94−instance (GHasFieldAt offset index f ret) => GHasFieldAtProd offset index f g ret 'GoLeft where
95− prodItemAt = first . gItemAt @offset @index
96−
97−instance (GHasFieldAt offset index g ret) => GHasFieldAtProd offset index f g ret 'GoRight where
98− prodItemAt = second . gItemAt @offset @index
99−
100−--------------------------------------------------------------------------------
101−
102−type family Search offset index f g :: Choice where
103− Search offset index f g = Choose (ContainsAt offset index f) (ContainsAt (offset + Size f) index g)
104−
105−type family Choose f g :: Choice where
106− Choose 'True _ = 'GoLeft
107− Choose _ 'True = 'GoRight
108− Choose _ _ = TypeError ('Text "Could not find type")
109−
110−-- | Try find a field by position in the generic representation.
111−type family ContainsAt (offset :: Nat) (index :: Nat) f :: Bool where
112− ContainsAt offset index (D1 m f)
113− = ContainsAt offset index f
114− ContainsAt n n (S1 _ _)
115− = 'True
116− ContainsAt _ _ (S1 _ _)
117− = 'False
118− ContainsAt offset index (f :*: g)
119− = ContainsAt offset index f || ContainsAt (Size f + offset) index g
120− ContainsAt offset index (C1 m f)
121− = ContainsAt offset index f
122− ContainsAt offset index (Rec0 _)
123− = 'False
124− ContainsAt offset index U1
125− = 'False
126− ContainsAt offset index V1
127− = 'False
128− ContainsAt offset index t = TypeError ('ShowType offset ':<>: 'Text " " ':<>: 'ShowType index)
129−
130−-- | Returns the count of terminal nodes in the generic representation.
131−type family Size f :: Nat where
132− Size (D1 m f)
133− = Size f
134− Size (f :*: g)
135− = Size f + Size g
136− Size (C1 m f)
137− = Size f
138− Size t = 1
139−
140−-- | If traversing to the left, offset does not change.
141−-- If traversing to the right, offset is incremented by size of left subtree.
142−type family Offset (offset :: Nat) (choice :: Choice) (size :: Nat) :: Nat where
143− Offset n 'GoLeft _ = n
144− Offset n 'GoRight s = n + s
145−
146−-- | Type-level or
147−type family (a :: Bool) || (b :: Bool) :: Bool where
148− 'True || _ = 'True
149− _ || b = b
150−
151−--------------------------------------------------------------------------------
152−
153−-- | Like 'HasFieldAt', but on the generic representation
154−class GHasFieldAt (offset :: Nat) (index :: Nat) (s :: Type -> Type) a | offset index s -> a where
155− gItemAt :: Lens' (s x) a
156−
157−instance
158− ( choice ~ (Search offset index s s')
159− , offset' ~ Offset offset choice (Size s)
160− , GHasFieldAtProd offset' index s s' a choice
161− )
162− => GHasFieldAt offset index (s :*: s') a where
163− gItemAt = prodItemAt @offset' @index @_ @_ @_ @choice
164−
165−instance GHasFieldAt offset index (K1 R a) a where
166− gItemAt f (K1 x) = fmap K1 (f x)
167−
168−instance GHasFieldAt n n (S1 ('MetaSel m p f b) (Rec0 a)) a where
169− gItemAt = mIso . gItemAt @n @n
170−
171−instance GHasFieldAt offset index s a => GHasFieldAt offset index (M1 D c s) a where
172− gItemAt = mIso . gItemAt @offset @index
173−
174−instance GHasFieldAt offset index s a => GHasFieldAt offset index (M1 C c s) a where
175− gItemAt = mIso . gItemAt @offset @index
176−
src/Data/Generics/Product/Numbered.hs+47−1
@@ -10,9 +10,26 @@
10{-# LANGUAGE TypeOperators #-}
10{-# LANGUAGE TypeOperators #-}
11{-# LANGUAGE UndecidableInstances #-}
11{-# LANGUAGE UndecidableInstances #-}
12
12
13+-----------------------------------------------------------------------------
14+-- |
15+-- Module : Data.Generics.Record.HasField
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+-- Derive positional product type getters and setters generically.
23+--
24+-----------------------------------------------------------------------------
25+
13module Data.Generics.Product.Numbered
26module Data.Generics.Product.Numbered
27+ ( -- * Lenses
28+ --
29+ -- $example
14− ( HasPosition (..)
30+ HasPosition (..)
15
31
32+ -- * Internals
16 , GHasPosition (..)
33 , GHasPosition (..)
17 ) where
34 ) where
18
35
@@ -22,9 +39,36 @@ import Data.Kind (Constraint, Type)
22import GHC.Generics
39import GHC.Generics
23import GHC.TypeLits
40import GHC.TypeLits
24
41
42+-- $example
43+-- @
44+-- module Example where
45+--
46+-- import Data.Generics.Product
47+-- import GHC.Generics
48+--
49+-- data Human = Human
50+-- { name :: String
51+-- , age :: Int
52+-- , address :: String
53+-- }
54+-- deriving (Generic, Show)
55+--
56+-- human :: Human
57+-- human = Human \"Tunyasz\" 50 \"London\"
58+-- @
59+
60+-- | Records that have a field at a given position.
25class HasPosition (i :: Nat) a s | s i -> a where
61class HasPosition (i :: Nat) a s | s i -> a where
62+ -- | A lens that focuses on a field at a given position. Compatible with the
63+ -- lens package's 'Control.Lens.Lens' type.
64+ --
65+ -- >>> human ^. numbered @1
66+ -- "Tunyasz"
67+ -- >>> human & numbered @2 .~ "Berlin"
68+ -- Human {name = "Tunyasz", age = 50, address = "Berlin"}
26 numbered :: Lens' s a
69 numbered :: Lens' s a
27
70
71+-- | The base index from which positions are counted.
28type BaseIndex
72type BaseIndex
29 = 1
73 = 1
30
74
@@ -50,6 +94,8 @@ type family ErrorUnlessTrue (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint
50 ErrorUnlessTrue _ _ 'True
94 ErrorUnlessTrue _ _ 'True
51 = ()
95 = ()
52
96
97+-- | As 'HasPosition' but over generic representations as defined by
98+-- "GHC.Generics".
53class GHasPosition (offset :: Nat) (i :: Nat) (f :: Type -> Type) a | offset i f -> a where
99class GHasPosition (offset :: Nat) (i :: Nat) (f :: Type -> Type) a | offset i f -> a where
54 gnumbered :: Lens' (f x) a
100 gnumbered :: Lens' (f x) a
55
101
src/Data/Generics/Product/Typed.hs+44−1
@@ -10,9 +10,26 @@
10{-# LANGUAGE TypeOperators #-}
10{-# LANGUAGE TypeOperators #-}
11{-# LANGUAGE UndecidableInstances #-}
11{-# LANGUAGE UndecidableInstances #-}
12
12
13+-----------------------------------------------------------------------------
14+-- |
15+-- Module : Data.Generics.Record.HasField
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+-- Derive record field getters and setters generically.
23+--
24+-----------------------------------------------------------------------------
25+
13module Data.Generics.Product.Typed
26module Data.Generics.Product.Typed
27+ ( -- * Lenses
28+ --
29+ -- $example
14− ( HasType (..)
30+ HasType (..)
15
31
32+ -- * Internals
16 , GHasType (..)
33 , GHasType (..)
17 ) where
34 ) where
18
35
@@ -23,7 +40,31 @@ import Data.Kind (Constraint, Type)
23import GHC.Generics
40import GHC.Generics
24import GHC.TypeLits
41import GHC.TypeLits
25
42
43+-- $example
44+-- @
45+-- module Example where
46+--
47+-- import Data.Generics.Product
48+-- import GHC.Generics
49+--
50+-- data Human = Human
51+-- { name :: String
52+-- , age :: Int
53+-- , address :: String
54+-- }
55+-- deriving (Generic, Show)
56+--
57+-- human :: Human
58+-- human = Human \"Tunyasz\" 50 \"London\"
59+-- @
60+
61+-- | Records that have a field with a unique type.
26class HasType a s where
62class HasType a s where
63+ -- | A lens that focuses on a field with a unique type in its parent type.
64+ -- Compatible with the lens package's 'Control.Lens.Lens' type.
65+ --
66+ -- >>> human ^. @typed Int
67+ -- 50
27 typed :: Lens' s a
68 typed :: Lens' s a
28
69
29instance (Generic s,
70instance (Generic s,
@@ -56,6 +97,8 @@ type family ErrorUnlessOne (a :: Type) (s :: Type) (count :: Count) :: Constrain
56 ErrorUnlessOne _ _ 'One
97 ErrorUnlessOne _ _ 'One
57 = ()
98 = ()
58
99
100+-- | As 'HasType' but over generic representations as defined by
101+-- "GHC.Generics".
59class GHasType (f :: Type -> Type) a where
102class GHasType (f :: Type -> Type) a where
60 gtyped :: Lens' (f x) a
103 gtyped :: Lens' (f x) a
61
104
src/Data/Generics/Record.hs−8
@@ -20,14 +20,6 @@ module Data.Generics.Record
20 Subtype (..)
20 Subtype (..)
21 , super
21 , super
22
22
23− -- * Magic lens
24− , HasField (..)
25−
26− -- * Getter and setter
27− , getField
28− , setField
29−
30 ) where
23 ) where
31
24
32−import Data.Generics.Record.HasField
33import Data.Generics.Record.Subtype
25import Data.Generics.Record.Subtype
src/Data/Generics/Record/HasField.hsdeleted−134
@@ -1,134 +0,0 @@
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.Generics.Record.HasField
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−-- Derive record field getters and setters generically.
23−--
24−-----------------------------------------------------------------------------
25−
26−module Data.Generics.Record.HasField
27− ( -- * Lens
28− -- $example
29− HasField (..)
30− -- * Getter and setter functions
31− , getField
32− , setField
33− -- * Internals
34− , GHasField (..)
35− ) where
36−
37−import Data.Generics.Record.Internal.Contains
38−
39−import Data.Generics.Internal.Lens
40−
41−import GHC.TypeLits (Symbol)
42−import Data.Kind (Type)
43−import GHC.Generics
44−
45−
46−-- $example
47−-- @
48−--
49−-- module Example where
50−--
51−-- import GHC.Generics
52−-- import Data.Generics.Record
53−--
54−-- data Human = Human
55−-- { name :: String
56−-- , age :: Int
57−-- , address :: String
58−-- } deriving (Generic, Show)
59−--
60−-- human :: Human
61−-- human = Human \"Tunyasz\" 50 \"London\"
62−--
63−-- @
64−
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 ^. label @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 (label @field)
78−
79−-- | Records that have a field with a given name.
80−class HasField (field :: Symbol) a s | s field -> a where
81− -- ^ Lens focusing on a field with a given name.
82− -- Compatible with the lens package.
83− --
84− -- @
85− -- type Lens' s a
86− -- = forall f. Functor f => (a -> f a) -> s -> f s
87− -- @
88− --
89− -- >>> human & label @"name" .~ "Tamas"
90− -- Human {name = "Tamas", age = 50, address = "London"}
91− label :: Lens' s a
92−
93−-- | Instances are generated on the fly for all records that have the required
94−-- field.
95−instance
96− ( Generic s
97− , ContainsField field (Rep s) ~ 'Just a -- this is needed for the fundep
98− , GHasField field (Rep s) a
99− ) => HasField field a s where
100− label = repIso . glabel @field
101−
102−
103−--------------------------------------------------------------------------------
104−
105−-- | Like 'HasField', but on the generic representation
106−class GHasField (field :: Symbol) (s :: Type -> Type) a | field s -> a where
107− glabel :: Lens' (s x) a
108−
109−instance (GHasFieldProd field s s' a (ContainsField field s)) => GHasField field (s :*: s') a where
110− glabel = prodLabel @field @_ @_ @_ @(ContainsField field s)
111−
112−instance (GHasField field s a, GHasField field s' a) => GHasField field (s :+: s') a where
113− glabel = combine (glabel @field @s) (glabel @field @s')
114−
115−instance GHasField field (S1 ('MetaSel ('Just field) p f b) (Rec0 a)) a where
116− glabel = mIso . glabel @field
117−
118−instance GHasField field (K1 R a) a where
119− glabel f (K1 x) = fmap K1 (f x)
120−
121−instance GHasField field s a => GHasField field (M1 D c s) a where
122− glabel = mIso . glabel @field
123−
124−instance GHasField field s a => GHasField field (M1 C c s) a where
125− glabel = mIso . glabel @field
126−
127−class GHasFieldProd field a b ret (w :: Maybe Type) | field a b -> ret where
128− prodLabel :: Lens' ((a :*: b) x) ret
129−
130−instance (GHasField field f ret) => GHasFieldProd field f g ret ('Just ret) where
131− prodLabel = first . glabel @field
132−
133−instance (GHasField field g ret) => GHasFieldProd field f g ret 'Nothing where
134− prodLabel = second . glabel @field
src/Data/Generics/Record/Subtype.hs+3−3
@@ -52,7 +52,7 @@ module Data.Generics.Record.Subtype
52 , super
52 , super
53 ) where
53 ) where
54
54
55−import Data.Generics.Record.HasField
55+import Data.Generics.Product.Fields
56import Data.Generics.Record.Internal.Contains
56import Data.Generics.Record.Internal.Contains
57
57
58import Data.Generics.Internal.Lens
58import Data.Generics.Internal.Lens
@@ -105,7 +105,7 @@ instance (GUpcast sub a, GUpcast sub b) => GUpcast sub (a :*: b) where
105 gupcast rep = gupcast rep :*: gupcast rep
105 gupcast rep = gupcast rep :*: gupcast rep
106
106
107instance {-# OVERLAPPING #-} GHasField field sub t => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
107instance {-# 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))
108+ gupcast r = M1 (K1 (r ^. gfield @field))
109
109
110instance GUpcast sub sup => GUpcast sub (M1 i c sup) where
110instance GUpcast sub sup => GUpcast sub (M1 i c sup) where
111 gupcast = M1 . gupcast
111 gupcast = M1 . gupcast
@@ -132,7 +132,7 @@ class GSmashLeaf sub sup (w :: Maybe Type) where
132 gsmashLeaf :: sup p -> sub p -> sub p
132 gsmashLeaf :: sup p -> sub p -> sub p
133
133
134instance (GHasField field sup t) => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup ('Just t) where
134instance (GHasField field sup t) => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup ('Just t) where
135− gsmashLeaf sup (M1 (K1 _)) = M1 (K1 (sup ^. glabel @field))
135+ gsmashLeaf sup (M1 (K1 _)) = M1 (K1 (sup ^. gfield @field))
136
136
137instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'Nothing where
137instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'Nothing where
138 gsmashLeaf _ = id
138 gsmashLeaf _ = id