module Records.Generic
(
HasField (..)
, Subtype (..)
) where
import GHC.TypeLits (Symbol, TypeError, ErrorMessage(..))
import Data.Kind (Type)
import Data.Proxy (Proxy(..))
import GHC.Generics
import Control.Applicative ((<|>))
type family ((xs :: [k]) ++ (ys :: [k])) :: [k] where
'[] ++ ys = ys
(x ': xs) ++ ys = x ': (xs ++ ys)
type family (Collect a) :: [(Symbol, Type)] where
Collect (D1 m cs)
= Collect cs
Collect (C1 mc cs)
= Collect cs
Collect (a :*: b)
= Collect a ++ Collect b
Collect (S1 ('MetaSel ('Just n) p f b) (Rec0 t))
= '[ '(n, t) ]
Collect x = TypeError ('Text "Invalid type")
class GHasField rec (field :: Symbol) a where
ggetField :: rec x -> Proxy field -> a
instance
( Contains field (Collect rec) ~ 'Just a
, LookupField rec field a
) => GHasField rec field a where
ggetField rec p = res
where Just res = lookupField rec p :: Maybe a
type family Contains (sym :: Symbol) (xs :: [(Symbol, Type)]) :: Maybe Type where
Contains s ('(s, t) ': _)
= 'Just t
Contains s (_ ': xs)
= Contains s xs
Contains s _
= TypeError ('Text "Field " ':<>: 'ShowType s ':<>: 'Text " not found in source record")
class LookupField a field ret where
lookupField :: a x -> Proxy field -> Maybe ret
instance (LookupField a field ret, LookupField b field ret) => LookupField (a :*: b) field ret where
lookupField (a :*: b) p = lookupField a p <|> lookupField b p
instance LookupField (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) field t where
lookupField (M1 x) = lookupField x
instance LookupField (S1 ('MetaSel ms su ss ds) t) field x where
lookupField _ _ = Nothing
instance LookupField f field ret => LookupField (M1 i c f) field ret where
lookupField (M1 x) = lookupField x
instance LookupField (K1 R a) field a where
lookupField (K1 x) _ = Just x
class Convert (rep :: Type -> Type) (f :: Type -> Type) where
convert :: rep p -> f p
instance (Convert rep a, Convert rep b) => Convert rep (a :*: b) where
convert rep = (convert rep) :*: (convert rep)
instance GHasField rep field t => Convert rep (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
convert rep = M1 (K1 (ggetField rep (Proxy @field)))
instance Convert rep f => Convert rep (M1 i c f) where
convert = M1 . convert
class Subtype a b where
upcast :: a -> b
instance (Convert (Rep a) (Rep b), Generic a, Generic b) => Subtype a b where
upcast = to . convert . from
class Generic rec => HasField rec (field :: Symbol) a where
getField :: rec -> Proxy field -> a
instance
( Contains field (Collect (Rep rec)) ~ 'Just a
, Generic rec
, LookupField (Rep rec) field a
) => HasField rec field a where
getField rec p = res
where Just res = lookupField (from rec) p :: Maybe a