git.iko.soy/generic-lens
on master help sign in
Move records to product
823792dCsongor Kiss
examples/Examples.hs−1
compare with master
unifiedsplit
@@ -10,7 +10,6 @@
10module Examples where
10module Examples where
11
11
12import GHC.Generics
12import GHC.Generics
13−import Data.Generics.Record
14import Data.Generics.Product
13import Data.Generics.Product
15--import Control.Lens
14--import Control.Lens
16
15
examples/StarWars.hs−1
@@ -10,7 +10,6 @@
10module StarWars where
10module StarWars where
11
11
12import GHC.Generics
12import GHC.Generics
13−import Data.Generics.Record
14import Data.Generics.Product
13import Data.Generics.Product
15
14
16data Episode = NEWHOPE | EMPIRE | JEDI
15data Episode = NEWHOPE | EMPIRE | JEDI
generic-lens.cabal+3−5
@@ -37,18 +37,16 @@ library
37 , Data.Generics.Product.Fields
37 , Data.Generics.Product.Fields
38 , Data.Generics.Product.Positions
38 , Data.Generics.Product.Positions
39 , Data.Generics.Product.Typed
39 , Data.Generics.Product.Typed
40+ , Data.Generics.Product.Subtype
40
41
41− , Data.Generics.Record
42− , Data.Generics.Record.Subtype
43− , Data.Generics.Internal.Lens
44 , Data.Generics.Sum.HasConstructor
42 , Data.Generics.Sum.HasConstructor
45
43
44+ , Data.Generics.Internal.Lens
45+
46 other-modules: Data.Generics.Internal.Families
46 other-modules: Data.Generics.Internal.Families
47 , Data.Generics.Internal.Families.Count
47 , Data.Generics.Internal.Families.Count
48 , Data.Generics.Internal.Families.Has
48 , Data.Generics.Internal.Families.Has
49
49
50− , Data.Generics.Record.Internal.Contains
51−
52 other-extensions: AllowAmbiguousTypes
50 other-extensions: AllowAmbiguousTypes
53 , DataKinds
51 , DataKinds
54 , FlexibleInstances
52 , FlexibleInstances
src/Data/Generics/Product.hs+6−1
@@ -1,6 +1,6 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2-- |
2-- |
3−-- Module : Data.Generics.Record
3+-- Module : Data.Generics.Product
4-- Copyright : (C) 2017 Csongor Kiss
4-- Copyright : (C) 2017 Csongor Kiss
5-- License : BSD3
5-- License : BSD3
6-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
6-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
@@ -27,9 +27,14 @@ module Data.Generics.Product
27 , getPosition
27 , getPosition
28
28
29 , HasType (..)
29 , HasType (..)
30+
31+ -- * Subtype relationship
32+ , Subtype (..)
33+ , super
30 ) where
34 ) where
31
35
32import Data.Generics.Product.Any
36import Data.Generics.Product.Any
33import Data.Generics.Product.Fields
37import Data.Generics.Product.Fields
34import Data.Generics.Product.Positions
38import Data.Generics.Product.Positions
35import Data.Generics.Product.Typed
39import Data.Generics.Product.Typed
40+import Data.Generics.Product.Subtype
src/Data/Generics/Product/Numbered.hsnew file+177
@@ -0,0 +1,177 @@
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/Record/Subtype.hs → src/Data/Generics/Product/Subtype.hsrenamed+8−8
@@ -12,7 +12,7 @@
12
12
13-----------------------------------------------------------------------------
13-----------------------------------------------------------------------------
14-- |
14-- |
15−-- Module : Data.Generics.Record.Subtype
15+-- Module : Data.Generics.Product.Subtype
16-- Copyright : (C) 2017 Csongor Kiss
16-- Copyright : (C) 2017 Csongor Kiss
17-- License : BSD3
17-- License : BSD3
18-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
18-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
@@ -47,13 +47,13 @@
47-- @
47-- @
48--
48--
49-----------------------------------------------------------------------------
49-----------------------------------------------------------------------------
50−module Data.Generics.Record.Subtype
50+module Data.Generics.Product.Subtype
51 ( Subtype (..)
51 ( Subtype (..)
52 , super
52 , super
53 ) where
53 ) where
54
54
55import Data.Generics.Product.Fields
55import Data.Generics.Product.Fields
56−import Data.Generics.Record.Internal.Contains
56+import Data.Generics.Internal.Families.Has (HasFieldP)
57
57
58import Data.Generics.Internal.Lens
58import Data.Generics.Internal.Lens
59
59
@@ -121,18 +121,18 @@ instance (GSmash a sup, GSmash b sup) => GSmash (a :*: b) sup where
121
121
122instance {-# OVERLAPPING #-}
122instance {-# OVERLAPPING #-}
123 ( leaf ~ (S1 ('MetaSel ('Just field) p f b) t)
123 ( leaf ~ (S1 ('MetaSel ('Just field) p f b) t)
124− , GSmashLeaf leaf sup (ContainsField field sup)
124+ , GSmashLeaf leaf sup (HasFieldP field sup)
125 ) => GSmash (S1 ('MetaSel ('Just field) p f b) t) sup where
125 ) => GSmash (S1 ('MetaSel ('Just field) p f b) t) sup where
126− gsmash = gsmashLeaf @_ @_ @(ContainsField field sup)
126+ gsmash = gsmashLeaf @_ @_ @(HasFieldP field sup)
127
127
128instance GSmash sub sup => GSmash (M1 i c sub) sup where
128instance GSmash sub sup => GSmash (M1 i c sub) sup where
129 gsmash sup (M1 sub) = M1 (gsmash sup sub)
129 gsmash sup (M1 sub) = M1 (gsmash sup sub)
130
130
131−class GSmashLeaf sub sup (w :: Maybe Type) where
131+class GSmashLeaf sub sup (w :: Bool) where
132 gsmashLeaf :: sup p -> sub p -> sub p
132 gsmashLeaf :: sup p -> sub p -> sub p
133
133
134−instance (GHasField field sup t) => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup ('Just t) where
134+instance (GHasField field sup t) => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'True where
135 gsmashLeaf sup (M1 (K1 _)) = M1 (K1 (sup ^. gfield @field))
135 gsmashLeaf sup (M1 (K1 _)) = M1 (K1 (sup ^. gfield @field))
136
136
137−instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'Nothing where
137+instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'False where
138 gsmashLeaf _ = id
138 gsmashLeaf _ = id
src/Data/Generics/Record.hsdeleted−25
@@ -1,25 +0,0 @@
1−-----------------------------------------------------------------------------
2−-- |
3−-- Module : Data.Generics.Record
4−-- Copyright : (C) 2017 Csongor Kiss
5−-- License : BSD3
6−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
7−-- Stability : experimental
8−-- Portability : non-portable
9−--
10−-- Magic record operations using Generics
11−--
12−-- These classes need not be instantiated manually, as GHC can automatically
13−-- prove valid instances via Generics. Only the `Generic` class needs to
14−-- be derived (see examples).
15−--
16−-----------------------------------------------------------------------------
17−module Data.Generics.Record
18− (
19− -- * Subtype relationship
20− Subtype (..)
21− , super
22−
23− ) where
24−
25−import Data.Generics.Record.Subtype
src/Data/Generics/Record/Internal/Contains.hsdeleted−65
@@ -1,65 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE PolyKinds #-}
5−{-# LANGUAGE Rank2Types #-}
6−{-# LANGUAGE ScopedTypeVariables #-}
7−{-# LANGUAGE TypeFamilies #-}
8−{-# LANGUAGE TypeOperators #-}
9−{-# LANGUAGE UndecidableInstances #-}
10−
11−-----------------------------------------------------------------------------
12−-- |
13−-- Module : Data.Generics.Record.Internal.Contains
14−-- Copyright : (C) 2017 Csongor Kiss
15−-- License : BSD3
16−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17−-- Stability : experimental
18−-- Portability : non-portable
19−--
20−-- Look up fields in the generic representation
21−--
22−-----------------------------------------------------------------------------
23−module Data.Generics.Record.Internal.Contains
24− ( ContainsField
25− ) where
26−
27−import Data.Kind (Type)
28−import GHC.Generics
29−import GHC.TypeLits
30−
31−-- | Look up a record field by name in the generic representation, and return
32−-- its corresponding type, if exists.
33−type family ContainsField (field :: Symbol) f :: Maybe Type where
34− ContainsField field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 t))
35− = 'Just t
36− ContainsField field (f :*: g)
37− = ContainsField field f <|> ContainsField field g
38− ContainsField field (f :+: g)
39− = ContainsField field f <&> ContainsField field g
40− ContainsField field (S1 _ _)
41− = 'Nothing
42− ContainsField field (C1 m f)
43− = ContainsField field f
44− ContainsField field (D1 m f)
45− = ContainsField field f
46− ContainsField field (Rec0 _)
47− = 'Nothing
48− ContainsField field U1
49− = 'Nothing
50− ContainsField field V1
51− = 'Nothing
52− ContainsField x t
53− = TypeError
54− ( 'ShowType t
55− ':<>: 'Text " is not a valid GHC.Generics representation type"
56− )
57−
58−-- | Type-level alternative
59−type family (a :: Maybe k) <|> (b :: Maybe k) :: Maybe k where
60− 'Just x <|> _ = 'Just x
61− _ <|> b = b
62−
63−type family (a :: Maybe k) <&> (b :: Maybe k) :: Maybe k where
64− 'Just x <&> 'Just x = 'Just x
65− _ <&> _ = 'Nothing