@@ -1,19 +1,19 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
12{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE DuplicateRecordFields #-}
43{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE UndecidableInstances #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
4+{-# LANGUAGE FunctionalDependencies #-}
75{-# LANGUAGE PolyKinds #-}
6+{-# LANGUAGE Rank2Types #-}
87{-# LANGUAGE ScopedTypeVariables #-}
9−{-# LANGUAGE TypeFamilies #-}
108{-# LANGUAGE TypeApplications #-}
9+{-# LANGUAGE TypeFamilies #-}
1110{-# LANGUAGE TypeOperators #-}
11+{-# LANGUAGE UndecidableInstances #-}
1212
1313-----------------------------------------------------------------------------
1414-- |
1515-- Module : Records.Generic
16−-- Copyright : (C) 2016 Csongor Kiss
16+-- Copyright : (C) 2017 Csongor Kiss
1717-- License : BSD3
1818-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1919-- Stability : experimental
@@ -28,98 +28,136 @@
2828-----------------------------------------------------------------------------
2929module Records.Generic
3030 (
31− -- * Magic getter
31+ -- * Magic lens
3232 HasField (..)
3333
34+ -- * Getter and setter
35+ , getField
36+ , setField
37+
3438 -- * Subtype relationship
3539 , Subtype (..)
3640 ) where
3741
38−import GHC.TypeLits (Symbol, TypeError, ErrorMessage(..))
39−import Data.Kind (Type)
40−import Data.Proxy (Proxy(..))
42+import GHC.TypeLits (Symbol, TypeError, ErrorMessage(..))
43+import Data.Kind (Type)
4144import GHC.Generics
42−import Control.Applicative ((<|>))
45+
46+import Control.Applicative (Const (..))
47+
48+-- TODO: cleanup
4349
4450--------------------------------------------------------------------------------
51+-- Lens helpers
4552
46−-- |Type-level list append
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
53+newtype Identity a = Identity { runIdentity :: a }
6454
65−instance
66− ( Contains field (Collect rec) ~ 'Just 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")
55+instance Functor Identity where
56+ fmap f (Identity a) = Identity (f a)
8057
81−{-
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.
58+type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s
8459
85− That will possibly require an extra argument to differentiate between the two
86− cases in the instance definition (and not just the constraints thereof) to
87− avoid duplicate instances
88−-}
89−class LookupField a field ret where
90− lookupField :: a x -> Proxy field -> Maybe ret
60+(^.) :: s -> ((a -> Const a a) -> s -> Const a s) -> a
61+s ^. l = getConst (l Const s)
9162
92−instance (LookupField a field ret, LookupField b field ret) => LookupField (a :*: b) field ret where
93− lookupField (a :*: b) p = lookupField a p <|> lookupField b p
63+set :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t
64+set l b = runIdentity . l (\_ -> Identity b)
9465
95−instance LookupField (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) field t where
96− lookupField (M1 x) = lookupField x
66+first :: Lens' ((a :*: b) x) (a x)
67+first f (a :*: b) = fmap (:*: b) (f a)
9768
98−instance {-# OVERLAPS #-} LookupField (S1 ('MetaSel ms su ss ds) t) field x where
99− lookupField _ _ = Nothing
69+second :: Lens' ((a :*: b) x) (b x)
70+second f (a :*: b) = fmap (a :*:) (f b)
10071
101−instance {-# OVERLAPS #-} LookupField f field ret => LookupField (M1 i c f) field ret where
102− lookupField (M1 x) = lookupField x
72+type Iso' s a = forall f. Functor f => (a -> f a) -> (s -> f s)
10373
104−instance LookupField (K1 R a) field a where
105− lookupField (K1 x) _ = Just x
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)
10679
10780--------------------------------------------------------------------------------
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+
108113class Convert (rep :: Type -> Type) (f :: Type -> Type) where
109114 convert :: rep p -> f p
110115
111116instance (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
113118
114−instance GHasField rep field t => Convert rep (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
115− convert rep = M1 (K1 (ggetField rep (Proxy @field)))
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))
116121
117122instance {-# OVERLAPS #-} Convert rep f => Convert rep (M1 i c f) where
118123 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+
119150--------------------------------------------------------------------------------
120151
121152-- Exported stuff
122153
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+
123161-- |Structural subtype relationship
124162class Subtype a b where
125163 upcast :: a -> b
@@ -128,14 +166,18 @@ instance (Convert (Rep a) (Rep b), Generic a, Generic b) => Subtype a b where
128166 upcast = to . convert . from
129167
130168-- |Records that have a field with a given name
131−class Generic rec => HasField rec (field :: Symbol) a where
132− getField :: rec -> Proxy field -> a
169+class HasField (field :: Symbol) a s | s field -> a where
170+ label :: Lens' s a
133171
134172instance
135− ( Contains field (Collect (Rep rec)) ~ 'Just a
136− , Generic rec
137− , LookupField (Rep rec) field a
138− ) => HasField rec field a where
139− getField rec p = res
140− where Just res = lookupField (from rec) p :: Maybe a
141−
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)