git.iko.soy/generic-lens
on master help sign in
Expose a lens
758bcbcCsongor Kiss
src/Records/Generic.hs+117−75
compare with master
unifiedsplit
@@ -1,19 +1,19 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE DuplicateRecordFields #-}
4{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE UndecidableInstances #-}
4+{-# LANGUAGE FunctionalDependencies #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE PolyKinds #-}
5{-# LANGUAGE PolyKinds #-}
6+{-# LANGUAGE Rank2Types #-}
8{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE ScopedTypeVariables #-}
9−{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE TypeApplications #-}
8{-# LANGUAGE TypeApplications #-}
9+{-# LANGUAGE TypeFamilies #-}
11{-# LANGUAGE TypeOperators #-}
10{-# LANGUAGE TypeOperators #-}
11+{-# LANGUAGE UndecidableInstances #-}
12
12
13-----------------------------------------------------------------------------
13-----------------------------------------------------------------------------
14-- |
14-- |
15-- Module : Records.Generic
15-- Module : Records.Generic
16−-- Copyright : (C) 2016 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>
19-- Stability : experimental
19-- Stability : experimental
@@ -28,98 +28,136 @@
28-----------------------------------------------------------------------------
28-----------------------------------------------------------------------------
29module Records.Generic
29module Records.Generic
30 (
30 (
31− -- * Magic getter
31+ -- * Magic lens
32 HasField (..)
32 HasField (..)
33
33
34+ -- * Getter and setter
35+ , getField
36+ , setField
37+
34 -- * Subtype relationship
38 -- * Subtype relationship
35 , Subtype (..)
39 , Subtype (..)
36 ) where
40 ) where
37
41
38−import GHC.TypeLits (Symbol, TypeError, ErrorMessage(..))
42+import GHC.TypeLits (Symbol, TypeError, ErrorMessage(..))
39−import Data.Kind (Type)
43+import Data.Kind (Type)
40−import Data.Proxy (Proxy(..))
41import GHC.Generics
44import GHC.Generics
45+
42−import Control.Applicative ((<|>))
46+import Control.Applicative (Const (..))
47+
48+-- TODO: cleanup
43
49
44--------------------------------------------------------------------------------
50--------------------------------------------------------------------------------
51+-- Lens helpers
45
52
46−-- |Type-level list append
53+newtype Identity a = Identity { runIdentity :: a }
47−type family ((xs :: [k]) ++ (ys :: [k])) :: [k] where
48− '[] ++ ys = ys
49− (x ': xs) ++ ys = x ': (xs ++ ys)
50−
51−type family (Collect a) :: [(Symbol, Type)] where
52− Collect (D1 m cs)
53− = Collect cs
54− Collect (C1 mc cs)
55− = Collect cs
56− Collect (a :*: b)
57− = Collect a ++ Collect b
58− Collect (S1 ('MetaSel ('Just n) p f b) (Rec0 t))
59− = '[ '(n, t) ]
60− Collect x = TypeError ('Text "Invalid type")
61−
62−class GHasField rec (field :: Symbol) a where
63− ggetField :: rec x -> Proxy field -> a
64
54
65−instance
55+instance Functor Identity where
66− ( Contains field (Collect rec) ~ 'Just a
56+ fmap f (Identity a) = Identity (f a)
67− , LookupField rec field a
68− ) => GHasField rec field a where
69− ggetField rec p = res
70− where Just res = lookupField rec p :: Maybe a
71−
72−-- This could be kind polymorphic, but the error message implies this kind anyway
73−type family Contains (sym :: Symbol) (xs :: [(Symbol, Type)]) :: Maybe Type where
74− Contains s ('(s, t) ': _)
75− = 'Just t
76− Contains s (_ ': xs)
77− = Contains s xs
78− Contains s _
79− = TypeError ('Text "Field " ':<>: 'ShowType s ':<>: 'Text " not found in source record")
80
57
81−{-
58+type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s
82− TODO: It's be possible to determine which branch contains the field
83− (e.g. with a type family) and then we won't need the `Maybe` business.
84
59
85− That will possibly require an extra argument to differentiate between the two
60+(^.) :: s -> ((a -> Const a a) -> s -> Const a s) -> a
86− cases in the instance definition (and not just the constraints thereof) to
61+s ^. l = getConst (l Const s)
87− avoid duplicate instances
88−-}
89−class LookupField a field ret where
90− lookupField :: a x -> Proxy field -> Maybe ret
91
62
92−instance (LookupField a field ret, LookupField b field ret) => LookupField (a :*: b) field ret where
63+set :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t
93− lookupField (a :*: b) p = lookupField a p <|> lookupField b p
64+set l b = runIdentity . l (\_ -> Identity b)
94
65
95−instance LookupField (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) field t where
66+first :: Lens' ((a :*: b) x) (a x)
96− lookupField (M1 x) = lookupField x
67+first f (a :*: b) = fmap (:*: b) (f a)
97
68
98−instance {-# OVERLAPS #-} LookupField (S1 ('MetaSel ms su ss ds) t) field x where
69+second :: Lens' ((a :*: b) x) (b x)
99− lookupField _ _ = Nothing
70+second f (a :*: b) = fmap (a :*:) (f b)
100
71
101−instance {-# OVERLAPS #-} LookupField f field ret => LookupField (M1 i c f) field ret where
72+type Iso' s a = forall f. Functor f => (a -> f a) -> (s -> f s)
102− lookupField (M1 x) = lookupField x
103
73
104−instance LookupField (K1 R a) field a where
74+repIso :: Generic a => Iso' a (Rep a x)
105− lookupField (K1 x) _ = Just 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)
106
79
107--------------------------------------------------------------------------------
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+
108class Convert (rep :: Type -> Type) (f :: Type -> Type) where
113class Convert (rep :: Type -> Type) (f :: Type -> Type) where
109 convert :: rep p -> f p
114 convert :: rep p -> f p
110
115
111instance (Convert rep a, Convert rep b) => Convert rep (a :*: b) where
116instance (Convert rep a, Convert rep b) => Convert rep (a :*: b) where
112− convert rep = (convert rep) :*: (convert rep)
117+ convert rep = convert rep :*: convert rep
113
118
114−instance GHasField rep field t => Convert rep (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
119+instance GHasField field rep t => Convert rep (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
115− convert rep = M1 (K1 (ggetField rep (Proxy @field)))
120+ convert rep = M1 (K1 (rep ^. glabel @field))
116
121
117instance {-# OVERLAPS #-} Convert rep f => Convert rep (M1 i c f) where
122instance {-# OVERLAPS #-} Convert rep f => Convert rep (M1 i c f) where
118 convert = M1 . convert
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+
119--------------------------------------------------------------------------------
150--------------------------------------------------------------------------------
120
151
121-- Exported stuff
152-- Exported stuff
122
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+
123-- |Structural subtype relationship
161-- |Structural subtype relationship
124class Subtype a b where
162class Subtype a b where
125 upcast :: a -> b
163 upcast :: a -> b
@@ -128,14 +166,18 @@ instance (Convert (Rep a) (Rep b), Generic a, Generic b) => Subtype a b where
128 upcast = to . convert . from
166 upcast = to . convert . from
129
167
130-- |Records that have a field with a given name
168-- |Records that have a field with a given name
131−class Generic rec => HasField rec (field :: Symbol) a where
169+class HasField (field :: Symbol) a s | s field -> a where
132− getField :: rec -> Proxy field -> a
170+ label :: Lens' s a
133
171
134instance
172instance
173+ ( Generic s
135− ( Contains field (Collect (Rep rec)) ~ 'Just a
174+ , Contains field (Rep s) ~ 'Just a -- this is needed for the fundep for some reason
136− , Generic rec
175+ , GHasField field (Rep s) a
137− , LookupField (Rep rec) field a
138− ) => HasField rec field a where
176+ ) => HasField field a s where
139− getField rec p = res
177+ label = repIso . glabel @field
140− where Just res = lookupField (from rec) p :: Maybe a
178+
141−
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)