git.iko.soy/generic-lens
on master help sign in
Finish HasType sans custom errors.
commitbc2c3bea043dbcf5afe4563d57a60905b4fe18d1 authorWill Jones <will@sacharissa.co.uk> dateFri 28 Jul 2017, 18:14 (9 years ago) parent6bd22ca
4 files changed+65−2
compare with master
unifiedsplit
src/Data/Generics/Internal/Families/Count.hs+1 src/Data/Generics/Internal/Families/Find.hs+26 src/Data/Generics/Product/Fields.hs+10−1 src/Data/Generics/Product/Typed.hs+28−1
src/Data/Generics/Internal/Families/Count.hs+1
@@ -6,6 +6,7 @@
66
77module Data.Generics.Internal.Families.Count
88 ( CountType
9+ , Counted (..)
910 ) where
1011
1112import GHC.Generics
src/Data/Generics/Internal/Families/Find.hs+26
@@ -6,6 +6,7 @@
66
77module Data.Generics.Internal.Families.Find
88 ( FindField
9+ , FindType
910 ) where
1011
1112import Data.Kind (Type)
@@ -39,6 +40,31 @@ type family FindField (field :: Symbol) f :: Maybe Type where
3940 ':<>: 'Text " is not a valid GHC.Generics representation type"
4041 )
4142
43+type family FindType a f :: Maybe Type where
44+ FindType t (S1 meta (Rec0 t))
45+ = 'Just t
46+ FindType t (l :*: r)
47+ = FindType t l <|> FindType t r
48+ FindType t (l :+: r)
49+ = FindType t l <&> FindType t r
50+ FindType t (S1 _ _)
51+ = 'Nothing
52+ FindType t (C1 m f)
53+ = FindType t f
54+ FindType t (D1 m f)
55+ = FindType t f
56+ FindType t (Rec0 _)
57+ = 'Nothing
58+ FindType t U1
59+ = 'Nothing
60+ FindType t V1
61+ = 'Nothing
62+ FindType t f
63+ = TypeError
64+ ( 'ShowType f
65+ ':<>: 'Text " is not a valid GHC.Generics representation type"
66+ )
67+
4268-- | Type-level alternative monomorphised to @Maybe@.
4369type family (a :: Maybe k) <|> (b :: Maybe k) :: Maybe k where
4470 'Just a <|> _ = 'Just a
src/Data/Generics/Product/Fields.hs+10−1
@@ -6,6 +6,7 @@
66{-# LANGUAGE MultiParamTypeClasses #-}
77{-# LANGUAGE ScopedTypeVariables #-}
88{-# LANGUAGE TypeApplications #-}
9+{-# LANGUAGE TypeFamilies #-}
910{-# LANGUAGE TypeOperators #-}
1011{-# LANGUAGE UndecidableInstances #-}
1112
@@ -25,6 +26,14 @@ import GHC.TypeLits
2526class HasField (field :: Symbol) a s | s field -> a where
2627 field :: Lens' s a
2728
29+instance (Generic s,
30+ FindField field (Rep s) ~ 'Just a,
31+ GHasField field (Rep s) a)
32+
33+ => HasField field a s where
34+
35+ field = repIso . gfield @field
36+
2837class GHasField (field :: Symbol) (f :: Type -> Type) a | field f -> a where
2938 gfield :: Lens' (f x) a
3039
@@ -50,7 +59,7 @@ instance GHasField field f a => GHasField field (M1 D meta f) a where
5059instance GHasField field f a => GHasField field (M1 C meta f) a where
5160 gfield = mIso . gfield @field
5261
53−class GProductHasField (field :: Symbol) l r a (contains :: Maybe Type) | field l r -> a where
62+class GProductHasField (field :: Symbol) l r a (found :: Maybe Type) | field l r -> a where
5463 gproductField :: Lens' ((l :*: r) x) a
5564
5665instance GHasField field l a => GProductHasField field l r a ('Just a) where
src/Data/Generics/Product/Typed.hs+28−1
@@ -1,9 +1,14 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
14{-# LANGUAGE FlexibleInstances #-}
25{-# LANGUAGE KindSignatures #-}
36{-# LANGUAGE MultiParamTypeClasses #-}
47{-# LANGUAGE ScopedTypeVariables #-}
58{-# LANGUAGE TypeApplications #-}
9+{-# LANGUAGE TypeFamilies #-}
610{-# LANGUAGE TypeOperators #-}
11+{-# LANGUAGE UndecidableInstances #-}
712
813module Data.Generics.Product.Typed
914 ( HasType (..)
@@ -15,14 +20,27 @@ import Data.Generics.Internal.Lens
1520
1621import Data.Kind (Type)
1722import GHC.Generics
18−import GHC.TypeLits
1923
2024class HasType a s where
2125 typed :: Lens' s a
2226
27+instance (Generic s,
28+ FindType a (Rep s) ~ 'Just a,
29+ CountType a (Rep s) ~ 'One,
30+ GHasType (Rep s) a)
31+
32+ => HasType a s where
33+
34+ typed = repIso . gtyped
35+
2336class GHasType (f :: Type -> Type) a where
2437 gtyped :: Lens' (f x) a
2538
39+instance GProductHasType l r a (FindType a l)
40+ => GHasType (l :*: r) a where
41+
42+ gtyped = gproductTyped @_ @_ @_ @(FindType a l)
43+
2644instance (GHasType l a, GHasType r a) => GHasType (l :+: r) a where
2745 gtyped = combine (gtyped @l) (gtyped @r)
2846
@@ -37,3 +55,12 @@ instance GHasType f a => GHasType (M1 D meta f) a where
3755
3856instance GHasType f a => GHasType (M1 C meta f) a where
3957 gtyped = mIso . gtyped
58+
59+class GProductHasType l r a (found :: Maybe Type) where
60+ gproductTyped :: Lens' ((l :*: r) x) a
61+
62+instance GHasType l a => GProductHasType l r a ('Just a) where
63+ gproductTyped = first . gtyped
64+
65+instance GHasType r a => GProductHasType l r a 'Nothing where
66+ gproductTyped = second . gtyped