@@ -0,0 +1,120 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DuplicateRecordFields #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE UndecidableInstances #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE PolyKinds #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeApplications #-}
11+{-# LANGUAGE TypeOperators #-}
12+
13+module Records.Generic
14+ ( HasField (..)
15+ , Subtype (..)
16+ ) where
17+
18+import GHC.TypeLits (Symbol, TypeError, ErrorMessage(..))
19+import Data.Kind (Type)
20+import Data.Proxy (Proxy(..))
21+import GHC.Generics
22+import Control.Applicative ((<|>))
23+
24+--------------------------------------------------------------------------------
25+
26+-- |Type-level list append
27+type family ((xs :: [k]) ++ (ys :: [k])) :: [k] where
28+ '[] ++ ys = ys
29+ (x ': xs) ++ ys = x ': (xs ++ ys)
30+
31+type family (Collect a) :: [(Symbol, Type)] where
32+ Collect (D1 m cs)
33+ = Collect cs
34+ Collect (C1 mc cs)
35+ = Collect cs
36+ Collect (a :*: b)
37+ = Collect a ++ Collect b
38+ Collect (S1 ('MetaSel ('Just n) p f b) (Rec0 t))
39+ = '[ '(n, t) ]
40+ Collect x = TypeError ('Text "Invalid type")
41+
42+class GHasField rec (field :: Symbol) a where
43+ ggetField :: rec x -> Proxy field -> a
44+
45+instance
46+ ( Contains field (Collect rec) ~ 'Just a
47+ , LookupField rec field a
48+ ) => GHasField rec field a where
49+ ggetField rec p = res
50+ where Just res = lookupField rec p :: Maybe a
51+
52+-- This could be kind polymorphic, but the error message implies this kind anyway
53+type family Contains (sym :: Symbol) (xs :: [(Symbol, Type)]) :: Maybe Type where
54+ Contains s ('(s, t) ': _)
55+ = 'Just t
56+ Contains s (_ ': xs)
57+ = Contains s xs
58+ Contains s _
59+ = TypeError ('Text "Field " ':<>: 'ShowType s ':<>: 'Text " not found in source record")
60+
61+{-
62+ TODO: It's be possible to determine which branch contains the field
63+ (e.g. with a type family) and then we won't need the `Maybe` business.
64+
65+ That will possibly require an extra argument to differentiate between the two
66+ cases in the instance definition (and not just the constraints thereof) to
67+ avoid duplicate instances
68+-}
69+class LookupField a field ret where
70+ lookupField :: a x -> Proxy field -> Maybe ret
71+
72+instance (LookupField a field ret, LookupField b field ret) => LookupField (a :*: b) field ret where
73+ lookupField (a :*: b) p = lookupField a p <|> lookupField b p
74+
75+instance LookupField (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) field t where
76+ lookupField (M1 x) = lookupField x
77+
78+instance {-# OVERLAPS #-} LookupField (S1 ('MetaSel ms su ss ds) t) field x where
79+ lookupField _ _ = Nothing
80+
81+instance {-# OVERLAPS #-} LookupField f field ret => LookupField (M1 i c f) field ret where
82+ lookupField (M1 x) = lookupField x
83+
84+instance LookupField (K1 R a) field a where
85+ lookupField (K1 x) _ = Just x
86+
87+--------------------------------------------------------------------------------
88+class Convert (rep :: Type -> Type) (f :: Type -> Type) where
89+ convert :: rep p -> f p
90+
91+instance (Convert rep a, Convert rep b) => Convert rep (a :*: b) where
92+ convert rep = (convert rep) :*: (convert rep)
93+
94+instance GHasField rep field t => Convert rep (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
95+ convert rep = M1 (K1 (ggetField rep (Proxy @field)))
96+
97+instance {-# OVERLAPS #-} Convert rep f => Convert rep (M1 i c f) where
98+ convert = M1 . convert
99+--------------------------------------------------------------------------------
100+
101+-- Exported stuff
102+
103+-- Structural subtype relationship
104+class Subtype a b where
105+ upcast :: a -> b
106+
107+instance (Convert (Rep a) (Rep b), Generic a, Generic b) => Subtype a b where
108+ upcast = to . convert . from
109+
110+class Generic rec => HasField rec (field :: Symbol) a where
111+ getField :: rec -> Proxy field -> a
112+
113+instance
114+ ( Contains field (Collect (Rep rec)) ~ 'Just a
115+ , Generic rec
116+ , LookupField (Rep rec) field a
117+ ) => HasField rec field a where
118+ getField rec p = res
119+ where Just res = lookupField (from rec) p :: Maybe a
120+