@@ -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−
131-----------------------------------------------------------------------------
142-- |
153-- Module : Records.Generic
@@ -28,156 +16,17 @@
2816-----------------------------------------------------------------------------
2917module Records.Generic
3018 (
19+ -- * Subtype relationship
20+ Subtype (..)
21+
3122 -- * Magic lens
32− HasField (..)
23+ , HasField (..)
3324
3425 -- * Getter and setter
3526 , getField
3627 , setField
3728
38− -- * Subtype relationship
39− , Subtype (..)
4029 ) where
4130
42−import GHC.TypeLits (Symbol, TypeError, ErrorMessage(..))
43−import Data.Kind (Type)
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)
31+import Records.Generic.HasField
32+import Records.Generic.Subtype