git.iko.soy/generic-lens
on master help sign in
0.2.0.0
246c17aCsongor Kiss
examples/StarWars.hs+2−3
compare with master
unifiedsplit
@@ -9,7 +9,6 @@
9-- (although I would be really surprised if it did, I haven't seen the films)
9-- (although I would be really surprised if it did, I haven't seen the films)
10module StarWars where
10module StarWars where
11
11
12−import Data.Proxy
13import GHC.Generics
12import GHC.Generics
14import Records.Generic
13import Records.Generic
15
14
@@ -60,8 +59,8 @@ c3po = Droid
60 , primaryFunction = "protocol and human relations"
59 , primaryFunction = "protocol and human relations"
61 }
60 }
62
61
63−getName :: HasField r "name" a => r -> a
62+getName :: HasField "name" a r => r -> a
64−getName r = getField r (Proxy @"name")
63+getName = getField @"name"
65
64
66-- upcast :: Subtype a b => a -> b
65-- upcast :: Subtype a b => a -> b
67characters :: [Character]
66characters :: [Character]
generic-records.cabal+27−38
@@ -1,69 +1,58 @@
1−-- Initial generic-records.cabal generated by cabal init. For further
2−-- documentation, see http://haskell.org/cabal/users-guide/
3−
4−-- The name of the package.
5name: generic-records
1name: generic-records
6
2
7−-- The package version. See the Haskell package versioning policy (PVP)
8−-- for standards guiding when and how versions should be incremented.
9−-- https://wiki.haskell.org/Package_versioning_policy
10−-- PVP summary: +-+------- breaking API changes
11−-- | | +----- non-breaking API additions
12−-- | | | +--- code changes with no API change
13−version: 0.1.0.0
3+version: 0.2.0.0
14
4
15−-- A short (one-line) description of the package.
16synopsis: Magic record operations using generics
5synopsis: Magic record operations using generics
17
6
18−-- A longer description of the package.
19description: This package uses the GHC8 Generic representation of records to derive magic classes (a la OverloadedRecordLabels), and prove structural subtyping relationship between records. The latter can be used to upcast the "sub-record" to the more general "interface".
7description: This package uses the GHC8 Generic representation of records to derive magic classes (a la OverloadedRecordLabels), and prove structural subtyping relationship between records. The latter can be used to upcast the "sub-record" to the more general "interface".
20
8
21homepage: https://github.com/kcsongor/generic-records
9homepage: https://github.com/kcsongor/generic-records
22
10
23−-- The license under which the package is released.
24license: BSD3
11license: BSD3
25
12
26−-- The file containing the license text.
27license-file: LICENSE
13license-file: LICENSE
28
14
29−-- The package author(s).
30author: Csongor Kiss
15author: Csongor Kiss
31
16
32−-- An email address to which users can send suggestions, bug reports, and
33−-- patches.
34maintainer: kiss.csongor.kiss@gmail.com
17maintainer: kiss.csongor.kiss@gmail.com
35
18
36−-- A copyright notice.
37−-- copyright:
38−
39category: Generics, Records
19category: Generics, Records
40
20
41build-type: Simple
21build-type: Simple
42
22
43−-- Extra files to be distributed with the package, such as examples or a
23+-- Extra files to be distributed with the package, such as examples or a
44-- README.
24-- README.
45extra-source-files: ChangeLog.md
25extra-source-files: ChangeLog.md
46
26
47-- Constraint on the version of Cabal needed to build this package.
27-- Constraint on the version of Cabal needed to build this package.
48−cabal-version: >=1.10
28+cabal-version: >= 1.10
49
29
50
30
51library
31library
52− -- Modules exported by the library.
53− exposed-modules: Records.Generic
32+ exposed-modules: Records.Generic
54−
33+ , Records.Generic.Subtype
55− -- Modules included in this library but not exported.
34+ , Records.Generic.HasField
56− -- other-modules:
35+
57−
36+ other-modules: Records.Generic.Lens
58− -- LANGUAGE extensions used by modules in this package.
37+
59− other-extensions: DataKinds, DeriveGeneric, DuplicateRecordFields, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, PolyKinds, ScopedTypeVariables, TypeFamilies, TypeApplications, TypeOperators
38+ other-extensions: AllowAmbiguousTypes
60−
39+ , DataKinds
40+ , FlexibleInstances
41+ , FunctionalDependencies
42+ , PolyKinds
43+ , Rank2Types
44+ , ScopedTypeVariables
45+ , TypeApplications
46+ , TypeFamilies
47+ , TypeOperators
48+ , UndecidableInstances
49+
61 -- Other library packages from which modules are imported.
50 -- Other library packages from which modules are imported.
62− build-depends: base >=4.9 && <4.10
51+ build-depends: base >= 4.9 && <= 5.0
63−
52+
64 -- Directories containing source files.
53 -- Directories containing source files.
65− hs-source-dirs: src
54+ hs-source-dirs: src
66−
55+
67 -- Base language which the package is written in.
56 -- Base language which the package is written in.
68− default-language: Haskell2010
57+ default-language: Haskell2010
69−
58+ ghc-options: -Wall
src/Records/Generic.hs+6−157
@@ -1,15 +1,3 @@
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-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
14-- |
2-- |
15-- Module : Records.Generic
3-- Module : Records.Generic
@@ -28,156 +16,17 @@
28-----------------------------------------------------------------------------
16-----------------------------------------------------------------------------
29module Records.Generic
17module Records.Generic
30 (
18 (
19+ -- * Subtype relationship
20+ Subtype (..)
21+
31 -- * Magic lens
22 -- * Magic lens
32− HasField (..)
23+ , HasField (..)
33
24
34 -- * Getter and setter
25 -- * Getter and setter
35 , getField
26 , getField
36 , setField
27 , setField
37
28
38− -- * Subtype relationship
39− , Subtype (..)
40 ) where
29 ) where
41
30
42−import GHC.TypeLits (Symbol, TypeError, ErrorMessage(..))
31+import Records.Generic.HasField
43−import Data.Kind (Type)
32+import Records.Generic.Subtype
44−import GHC.Generics
45−
46−import Control.Applicative (Const (..))
47−
48−-- TODO: cleanup
49−
50−--------------------------------------------------------------------------------
51−-- Lens helpers
52−
53−newtype Identity a = Identity { runIdentity :: a }
54−
55−instance Functor Identity where
56− fmap f (Identity a) = Identity (f a)
57−
58−type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s
59−
60−(^.) :: s -> ((a -> Const a a) -> s -> Const a s) -> a
61−s ^. l = getConst (l Const s)
62−
63−set :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t
64−set l b = runIdentity . l (\_ -> Identity b)
65−
66−first :: Lens' ((a :*: b) x) (a x)
67−first f (a :*: b) = fmap (:*: b) (f a)
68−
69−second :: Lens' ((a :*: b) x) (b x)
70−second f (a :*: b) = fmap (a :*:) (f b)
71−
72−type Iso' s a = forall f. Functor f => (a -> f a) -> (s -> f s)
73−
74−repIso :: Generic a => Iso' a (Rep a x)
75−repIso a = fmap to . a . from
76−
77−lensM :: Lens' (M1 i c f p) (f p)
78−lensM f (M1 x) = fmap M1 (f x)
79−
80−--------------------------------------------------------------------------------
81−
82−class GHasField field s a | field s -> a where
83− glabel :: Lens' (s x) a
84−
85−instance (GHasFieldProd field s s' a (Contains field s)) => GHasField field (s :*: s') a where
86− glabel = prodLabel @field @_ @_ @a @(Contains field s)
87−
88−instance GHasField field (S1 ('MetaSel ('Just field) p f b) (Rec0 a)) a where
89− glabel = lensM . glabel @field
90−
91−instance GHasField field (K1 R a) a where
92− glabel f (K1 x) = fmap K1 (f x)
93−
94−instance GHasField field s a => GHasField field (M1 D c s) a where
95− glabel = lensM . glabel @field
96−
97−instance GHasField field s a => GHasField field (M1 C c s) a where
98− glabel = lensM . glabel @field
99−
100−--------------------------------------------------------------------------------
101−
102−class GHasFieldProd field a b ret (w :: Maybe Type) | field a b -> ret where
103− prodLabel :: Lens' ((a :*: b) x) ret
104−
105−instance (GHasField field f ret) => GHasFieldProd field f g ret ('Just ret) where
106− prodLabel = first . glabel @field
107−
108−instance (GHasField field g ret) => GHasFieldProd field f g ret 'Nothing where
109− prodLabel = second . glabel @field
110−
111−--------------------------------------------------------------------------------
112−
113−class Convert (rep :: Type -> Type) (f :: Type -> Type) where
114− convert :: rep p -> f p
115−
116−instance (Convert rep a, Convert rep b) => Convert rep (a :*: b) where
117− convert rep = convert rep :*: convert rep
118−
119−instance GHasField field rep t => Convert rep (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
120− convert rep = M1 (K1 (rep ^. glabel @field))
121−
122−instance {-# OVERLAPS #-} Convert rep f => Convert rep (M1 i c f) where
123− convert = M1 . convert
124−
125−--------------------------------------------------------------------------------
126−
127−type family Contains (field :: Symbol) f :: Maybe Type where
128− Contains field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 t))
129− = 'Just t
130− Contains field (S1 _ _)
131− = 'Nothing
132− Contains field (D1 m f)
133− = Contains field f
134− Contains field (C1 m f)
135− = Contains field f
136− Contains field (f :*: g)
137− = Contains field f <|> Contains field g
138− Contains field (Rec0 _)
139− = 'Nothing
140− Contains field U1
141− = 'Nothing
142− Contains field V1
143− = 'Nothing
144− Contains x t = TypeError ('ShowType t)
145−
146−type family (a :: Maybe k) <|> (b :: Maybe k) :: Maybe k where
147− 'Just x <|> _ = 'Just x
148− _ <|> b = b
149−
150−--------------------------------------------------------------------------------
151−
152−-- Exported stuff
153−
154−getField :: forall field a s. HasField field a s => s -> a
155−getField s = s ^. label @field
156−
157−setField :: forall field a s. HasField field a s => a -> s -> s
158−setField = set (label @field)
159−
160−
161−-- |Structural subtype relationship
162−class Subtype a b where
163− upcast :: a -> b
164−
165−instance (Convert (Rep a) (Rep b), Generic a, Generic b) => Subtype a b where
166− upcast = to . convert . from
167−
168−-- |Records that have a field with a given name
169−class HasField (field :: Symbol) a s | s field -> a where
170− label :: Lens' s a
171−
172−instance
173− ( Generic s
174− , Contains field (Rep s) ~ 'Just a -- this is needed for the fundep for some reason
175− , GHasField field (Rep s) a
176− ) => HasField field a s where
177− label = repIso . glabel @field
178−
179−-- Probably not a good idea to export this orphan...
180−--{-# LANGUAGE OverloadedLabels #-}
181−--import GHC.OverloadedLabels
182−--instance HasField field a s => IsLabel field (s -> a) where
183−-- fromLabel _ = (^. label @field)
src/Records/Generic/HasField.hsnew file+157
@@ -0,0 +1,157 @@
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 : Records.Generic.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 Records.Generic.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 Records.Generic.Lens
38+
39+import GHC.TypeLits (Symbol, TypeError, ErrorMessage(..))
40+import Data.Kind (Type)
41+import GHC.Generics
42+
43+
44+-- $example
45+-- @
46+--
47+-- module Example where
48+--
49+-- import GHC.Generics
50+-- import Record.Generic
51+--
52+-- data Human = Human
53+-- { name :: String
54+-- , age :: Int
55+-- , address :: String
56+-- } deriving (Generic, Show)
57+--
58+-- human :: Human
59+-- human = Human \"Tunyasz\" 50 \"London\"
60+--
61+-- @
62+
63+-- | Get 'field'
64+--
65+-- >>> getField @"name" human
66+-- "Tunyasz"
67+getField :: forall field a s. HasField field a s => s -> a
68+getField s = s ^. label @field
69+
70+-- | Set 'field'
71+--
72+-- >>> setField @"age" (setField @"name" "Tamas" human) 30
73+-- Human {name = "Tamas", age = 30, address = "London"}
74+setField :: forall field a s. HasField field a s => a -> s -> s
75+setField = set (label @field)
76+
77+-- | Records that have a field with a given name.
78+class HasField (field :: Symbol) a s | s field -> a where
79+ -- ^ Lens focusing on a field with a given name.
80+ -- Compatible with the lens package.
81+ --
82+ -- @
83+ -- type Lens' s a
84+ -- = forall f. Functor f => (a -> f a) -> s -> f s
85+ -- @
86+ --
87+ -- >>> human & label @"name" .~ "Tamas"
88+ -- Human {name = "Tamas", age = 50, address = "London"}
89+ label :: Lens' s a
90+
91+-- | Instances are generated on the fly for all records that have the required
92+-- field.
93+instance
94+ ( Generic s
95+ , Contains field (Rep s) ~ 'Just a -- this is needed for the fundep for some reason
96+ , GHasField field (Rep s) a
97+ ) => HasField field a s where
98+ label = repIso . glabel @field
99+
100+
101+class GHasFieldProd field a b ret (w :: Maybe Type) | field a b -> ret where
102+ prodLabel :: Lens' ((a :*: b) x) ret
103+
104+instance (GHasField field f ret) => GHasFieldProd field f g ret ('Just ret) where
105+ prodLabel = first . glabel @field
106+
107+instance (GHasField field g ret) => GHasFieldProd field f g ret 'Nothing where
108+ prodLabel = second . glabel @field
109+
110+--------------------------------------------------------------------------------
111+
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
141+class GHasField (field :: Symbol) (s :: Type -> Type) a | field s -> a where
142+ glabel :: Lens' (s x) a
143+
144+instance (GHasFieldProd field s s' a (Contains field s)) => GHasField field (s :*: s') a where
145+ glabel = prodLabel @field @_ @_ @_ @(Contains field s)
146+
147+instance GHasField field (S1 ('MetaSel ('Just field) p f b) (Rec0 a)) a where
148+ glabel = lensM . glabel @field
149+
150+instance GHasField field (K1 R a) a where
151+ glabel f (K1 x) = fmap K1 (f x)
152+
153+instance GHasField field s a => GHasField field (M1 D c s) a where
154+ glabel = lensM . glabel @field
155+
156+instance GHasField field s a => GHasField field (M1 C c s) a where
157+ glabel = lensM . glabel @field
src/Records/Generic/Lens.hsnew file+59
@@ -0,0 +1,59 @@
1+{-# LANGUAGE Rank2Types #-}
2+{-# LANGUAGE TypeOperators #-}
3+
4+-----------------------------------------------------------------------------
5+-- |
6+-- Module : Records.Generic.Lens
7+-- Copyright : (C) 2017 Csongor Kiss
8+-- License : BSD3
9+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
10+-- Stability : experimental
11+-- Portability : non-portable
12+--
13+-- Unexported lens helpers
14+--
15+-----------------------------------------------------------------------------
16+module Records.Generic.Lens where
17+
18+import Control.Applicative ( Const (..) )
19+import GHC.Generics ( (:*:) (..), Generic (..), M1 (..), Rep )
20+
21+-- | Identity functor
22+newtype Identity a
23+ = Identity { runIdentity :: a }
24+
25+-- | Functor instance
26+instance Functor Identity where
27+ fmap f (Identity a)
28+ = Identity (f a)
29+
30+-- | Type alias for lens
31+type Lens' s a
32+ = forall f. Functor f => (a -> f a) -> s -> f s
33+
34+-- | Getting
35+(^.) :: s -> ((a -> Const a a) -> s -> Const a s) -> a
36+s ^. l = getConst (l Const s)
37+
38+-- | Setting
39+set :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t
40+set l b
41+ = runIdentity . l (\_ -> Identity b)
42+
43+-- | Lens focusing on the first element of a product
44+first :: Lens' ((a :*: b) x) (a x)
45+first f (a :*: b)
46+ = fmap (:*: b) (f a)
47+
48+-- | Lens focusing on the second element of a product
49+second :: Lens' ((a :*: b) x) (b x)
50+second f (a :*: b)
51+ = fmap (a :*:) (f b)
52+
53+-- | A type and its generic representation are isomorphic
54+repIso :: Generic a => Lens' a (Rep a x)
55+repIso a = fmap to . a . from
56+
57+-- | 'M1' is just a wrapper around `f p`
58+lensM :: Lens' (M1 i c f p) (f p)
59+lensM f (M1 x) = fmap M1 (f x)
src/Records/Generic/Subtype.hsnew file+86
@@ -0,0 +1,86 @@
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 : Records.Generic.Subtype
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+-- Structural subtyping
23+--
24+-----------------------------------------------------------------------------
25+module Records.Generic.Subtype
26+ ( Subtype (..)
27+ ) where
28+
29+import Records.Generic.HasField
30+import Records.Generic.Lens
31+
32+import Data.Kind (Type)
33+import GHC.Generics
34+
35+-- |Structural subtype relationship
36+--
37+-- @
38+--
39+-- module Test where
40+--
41+-- import GHC.Generics
42+-- import Record.Generic
43+--
44+-- data Human = Human
45+-- { name :: String
46+-- , age :: Int
47+-- , address :: String
48+-- } deriving (Generic, Show)
49+--
50+-- data Animal = Animal
51+-- { name :: String
52+-- , age :: Int
53+-- } deriving (Generic, Show)
54+--
55+-- human :: Human
56+-- human = Human \"Tunyasz\" 50 \"London\"
57+--
58+-- @
59+--
60+--
61+-- >>> human
62+-- Human {name = "Tunyasz", age = 50, address = "London"}
63+--
64+-- >>> upcast human :: Animal
65+-- Animal {name = "Tunyasz", age = 50}
66+--
67+class Subtype sub sup where
68+ -- | Cast the more specific subtype to the more general supertype
69+ upcast :: sub -> sup
70+
71+-- | Instances are created by the compiler
72+instance (Convert (Rep a) (Rep b), Generic a, Generic b) => Subtype a b where
73+ upcast = to . convert . from
74+
75+-- | Convert 'rep' into 'f'
76+class Convert (rep :: Type -> Type) (f :: Type -> Type) where
77+ convert :: rep p -> f p
78+
79+instance (Convert rep a, Convert rep b) => Convert rep (a :*: b) where
80+ convert rep = convert rep :*: convert rep
81+
82+instance {-# OVERLAPPING #-} GHasField field rep t => Convert rep (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
83+ convert rep = M1 (K1 (rep ^. glabel @field))
84+
85+instance Convert rep f => Convert rep (M1 i c f) where
86+ convert = M1 . convert