git.iko.soy/generic-lens
on master help sign in
Begin clean-up and adding HasType.
commit6bd22cad234d5ddcf3ae2adf61fda990bc5d9a41 authorWill Jones <will@sacharissa.co.uk> dateFri 28 Jul 2017, 17:52 (9 years ago) parent8a9bc63
11 files changed+281−77
compare with master
unifiedsplit
generic-lens.cabal+10−3 src/Data/Generics/Internal/Families.hs+6 src/Data/Generics/Internal/Families/Count.hs+51 src/Data/Generics/Internal/Families/Find.hs+49 src/Data/Generics/Internal/Lens.hs+5−15 src/Data/Generics/Product/Fields.hs+60 src/Data/Generics/Product/HasFieldAt.hs+14−14 src/Data/Generics/Product/Typed.hs+39 src/Data/Generics/Record/HasField.hs+12−12 src/Data/Generics/Record/Internal/Contains.hs+33−31 src/Data/Generics/Record/Subtype.hs+2−2
generic-lens.cabal+10−3
@@ -32,15 +32,22 @@ cabal-version: >= 1.10
3232
3333
3434library
35− exposed-modules: Data.Generics.Record
36− , Data.Generics.Product
35+ exposed-modules: Data.Generics.Product
36+ , Data.Generics.Product.Fields
37+ , Data.Generics.Product.Typed
38+
39+ , Data.Generics.Record
3740 , Data.Generics.Record.Subtype
3841 , Data.Generics.Record.HasField
3942 , Data.Generics.Product.HasFieldAt
4043 , Data.Generics.Internal.Lens
4144 , Data.Generics.Sum.HasConstructor
4245
43− other-modules: Data.Generics.Record.Internal.Contains
46+ other-modules: Data.Generics.Internal.Families
47+ , Data.Generics.Internal.Families.Count
48+ , Data.Generics.Internal.Families.Find
49+
50+ , Data.Generics.Record.Internal.Contains
4451
4552 other-extensions: AllowAmbiguousTypes
4653 , DataKinds
src/Data/Generics/Internal/Families.hsnew file+6
@@ -0,0 +1,6 @@
1+module Data.Generics.Internal.Families
2+ ( module Families
3+ ) where
4+
5+import Data.Generics.Internal.Families.Count as Families
6+import Data.Generics.Internal.Families.Find as Families
src/Data/Generics/Internal/Families/Count.hsnew file+51
@@ -0,0 +1,51 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE PolyKinds #-}
3+{-# LANGUAGE TypeFamilies #-}
4+{-# LANGUAGE TypeOperators #-}
5+{-# LANGUAGE UndecidableInstances #-}
6+
7+module Data.Generics.Internal.Families.Count
8+ ( CountType
9+ ) where
10+
11+import GHC.Generics
12+import GHC.TypeLits
13+
14+type family CountType t f :: Counted where
15+ CountType t (S1 _ (Rec0 t))
16+ = 'One
17+ CountType t (l :*: r)
18+ = CountType t l <|> CountType t r
19+ CountType t (l :+: r)
20+ = CountType t l <&> CountType t r
21+ CountType t (S1 _ _)
22+ = 'None
23+ CountType t (C1 _ f)
24+ = CountType t f
25+ CountType t (D1 _ f)
26+ = CountType t f
27+ CountType t (Rec0 _)
28+ = 'None
29+ CountType t U1
30+ = 'None
31+ CountType t V1
32+ = 'None
33+ CountType t f
34+ = TypeError
35+ ( 'ShowType f
36+ ':<>: 'Text " is not a valid GHC.Generics representation type"
37+ )
38+
39+data Counted
40+ = None
41+ | One
42+ | Multiple
43+
44+type family (a :: Counted) <|> (b :: Counted) :: Counted where
45+ 'None <|> b = b
46+ a <|> 'None = a
47+ a <|> b = 'Multiple
48+
49+type family (a :: Counted) <&> (b :: Counted) :: Counted where
50+ a <&> a = a
51+ _ <&> _ = 'Multiple
src/Data/Generics/Internal/Families/Find.hsnew file+49
@@ -0,0 +1,49 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE PolyKinds #-}
3+{-# LANGUAGE TypeFamilies #-}
4+{-# LANGUAGE TypeOperators #-}
5+{-# LANGUAGE UndecidableInstances #-}
6+
7+module Data.Generics.Internal.Families.Find
8+ ( FindField
9+ ) where
10+
11+import Data.Kind (Type)
12+import GHC.Generics
13+import GHC.TypeLits
14+
15+-- | Look up a record field by name in the generic representation, and return
16+-- its corresponding type, if exists.
17+type family FindField (field :: Symbol) f :: Maybe Type where
18+ FindField field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 t))
19+ = 'Just t
20+ FindField field (l :*: r)
21+ = FindField field l <|> FindField field r
22+ FindField field (l :+: r)
23+ = FindField field l <&> FindField field r
24+ FindField field (S1 _ _)
25+ = 'Nothing
26+ FindField field (C1 m f)
27+ = FindField field f
28+ FindField field (D1 m f)
29+ = FindField field f
30+ FindField field (Rec0 _)
31+ = 'Nothing
32+ FindField field U1
33+ = 'Nothing
34+ FindField field V1
35+ = 'Nothing
36+ FindField field f
37+ = TypeError
38+ ( 'ShowType f
39+ ':<>: 'Text " is not a valid GHC.Generics representation type"
40+ )
41+
42+-- | Type-level alternative monomorphised to @Maybe@.
43+type family (a :: Maybe k) <|> (b :: Maybe k) :: Maybe k where
44+ 'Just a <|> _ = 'Just a
45+ _ <|> b = b
46+
47+type family (a :: Maybe k) <&> (b :: Maybe k) :: Maybe k where
48+ 'Just a <&> 'Just a = 'Just a
49+ _ <&> _ = 'Nothing
src/Data/Generics/Internal/Lens.hs+5−15
@@ -15,18 +15,10 @@
1515-----------------------------------------------------------------------------
1616module Data.Generics.Internal.Lens where
1717
18−import Control.Applicative ( Const (..) )
19−import GHC.Generics ( (:*:) (..), Generic (..), M1 (..), Rep, (:+:) (..) )
20−import Data.Profunctor ( Choice (right'), Profunctor (dimap) )
21−
22−-- | Identity functor
23−newtype Identity a
24− = Identity { runIdentity :: a }
25−
26−-- | Functor instance
27−instance Functor Identity where
28− fmap f (Identity a)
29− = Identity (f a)
18+import Control.Applicative (Const(..))
19+import Data.Functor.Identity (Identity(..))
20+import Data.Profunctor (Choice(right'), Profunctor(dimap))
21+import GHC.Generics ((:*:)(..), Generic(..), M1(..), Rep, (:+:)(..))
3022
3123-- | Type alias for lens
3224type Lens' s a
@@ -36,7 +28,6 @@ type Lens' s a
3628type Prism' s a
3729 = forall p f. (Choice p, Applicative f) => p a (f a) -> p s (f s)
3830
39−
4031type Iso' s a
4132 = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s)
4233
@@ -70,7 +61,7 @@ right = prism R1 $ \x -> case x of
7061 L1 _ -> Left x
7162 R1 a -> Right a
7263
73−combine :: Lens' (s x) a -> Lens' (t x) a -> Lens' ((:+:) s t x) a
64+combine :: Lens' (s x) a -> Lens' (t x) a -> Lens' ((s :+: t) x) a
7465combine sa _ f (L1 s) = fmap (\a -> L1 (set sa a s)) (f (s ^. sa))
7566combine _ ta f (R1 t) = fmap (\a -> R1 (set ta a t)) (f (t ^. ta))
7667
@@ -97,4 +88,3 @@ _Left = prism Left $ either Right (Left . Right)
9788
9889_Right :: Prism' (Either c a) a
9990_Right = prism Right $ either (Left . Left) Right
100−
src/Data/Generics/Product/Fields.hsnew file+60
@@ -0,0 +1,60 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE KindSignatures #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeApplications #-}
9+{-# LANGUAGE TypeOperators #-}
10+{-# LANGUAGE UndecidableInstances #-}
11+
12+module Data.Generics.Product.Fields
13+ ( HasField (..)
14+
15+ , GHasField (..)
16+ ) where
17+
18+import Data.Generics.Internal.Families
19+import Data.Generics.Internal.Lens
20+
21+import Data.Kind (Type)
22+import GHC.Generics
23+import GHC.TypeLits
24+
25+class HasField (field :: Symbol) a s | s field -> a where
26+ field :: Lens' s a
27+
28+class GHasField (field :: Symbol) (f :: Type -> Type) a | field f -> a where
29+ gfield :: Lens' (f x) a
30+
31+instance GProductHasField field l r a (FindField field l)
32+ => GHasField field (l :*: r) a where
33+
34+ gfield = gproductField @field @_ @_ @_ @(FindField field l)
35+
36+instance (GHasField field l a, GHasField field r a)
37+ => GHasField field (l :+: r) a where
38+
39+ gfield = combine (gfield @field @l) (gfield @field @r)
40+
41+instance GHasField field (S1 ('MetaSel ('Just field) upkd str infstr) (Rec0 a)) a where
42+ gfield = mIso . gfield @field
43+
44+instance GHasField field (K1 R a) a where
45+ gfield f (K1 x) = fmap K1 (f x)
46+
47+instance GHasField field f a => GHasField field (M1 D meta f) a where
48+ gfield = mIso . gfield @field
49+
50+instance GHasField field f a => GHasField field (M1 C meta f) a where
51+ gfield = mIso . gfield @field
52+
53+class GProductHasField (field :: Symbol) l r a (contains :: Maybe Type) | field l r -> a where
54+ gproductField :: Lens' ((l :*: r) x) a
55+
56+instance GHasField field l a => GProductHasField field l r a ('Just a) where
57+ gproductField = first . gfield @field
58+
59+instance GHasField field r a => GProductHasField field l r a 'Nothing where
60+ gproductField = second . gfield @field
src/Data/Generics/Product/HasFieldAt.hs+14−14
@@ -1,14 +1,14 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleInstances #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleInstances #-}
44{-# LANGUAGE FunctionalDependencies #-}
5−{-# LANGUAGE PolyKinds #-}
6−{-# LANGUAGE Rank2Types #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE TypeApplications #-}
9−{-# LANGUAGE TypeFamilies #-}
10−{-# LANGUAGE TypeOperators #-}
11−{-# LANGUAGE UndecidableInstances #-}
5+{-# LANGUAGE PolyKinds #-}
6+{-# LANGUAGE Rank2Types #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeApplications #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeOperators #-}
11+{-# LANGUAGE UndecidableInstances #-}
1212
1313-----------------------------------------------------------------------------
1414-- |
@@ -103,9 +103,9 @@ type family Search offset index f g :: Choice where
103103 Search offset index f g = Choose (ContainsAt offset index f) (ContainsAt (offset + Size f) index g)
104104
105105type family Choose f g :: Choice where
106− Choose 'True _ = 'GoLeft
106+ Choose 'True _ = 'GoLeft
107107 Choose _ 'True = 'GoRight
108− Choose _ _ = TypeError ('Text "Could not find type")
108+ Choose _ _ = TypeError ('Text "Could not find type")
109109
110110-- | Try find a field by position in the generic representation.
111111type family ContainsAt (offset :: Nat) (index :: Nat) f :: Bool where
@@ -157,8 +157,8 @@ class GHasFieldAt (offset :: Nat) (index :: Nat) (s :: Type -> Type) a | offset
157157instance
158158 ( choice ~ (Search offset index s s')
159159 , offset' ~ Offset offset choice (Size s)
160− , GHasFieldAtProd offset' index s s' a choice
161− )
160+ , GHasFieldAtProd offset' index s s' a choice
161+ )
162162 => GHasFieldAt offset index (s :*: s') a where
163163 gItemAt = prodItemAt @offset' @index @_ @_ @_ @choice
164164
src/Data/Generics/Product/Typed.hsnew file+39
@@ -0,0 +1,39 @@
1+{-# LANGUAGE FlexibleInstances #-}
2+{-# LANGUAGE KindSignatures #-}
3+{-# LANGUAGE MultiParamTypeClasses #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE TypeApplications #-}
6+{-# LANGUAGE TypeOperators #-}
7+
8+module Data.Generics.Product.Typed
9+ ( HasType (..)
10+
11+ ) where
12+
13+import Data.Generics.Internal.Families
14+import Data.Generics.Internal.Lens
15+
16+import Data.Kind (Type)
17+import GHC.Generics
18+import GHC.TypeLits
19+
20+class HasType a s where
21+ typed :: Lens' s a
22+
23+class GHasType (f :: Type -> Type) a where
24+ gtyped :: Lens' (f x) a
25+
26+instance (GHasType l a, GHasType r a) => GHasType (l :+: r) a where
27+ gtyped = combine (gtyped @l) (gtyped @r)
28+
29+instance GHasType (S1 meta (Rec0 a)) a where
30+ gtyped = mIso . gtyped
31+
32+instance GHasType (K1 R a) a where
33+ gtyped f (K1 x) = fmap K1 (f x)
34+
35+instance GHasType f a => GHasType (M1 D meta f) a where
36+ gtyped = mIso . gtyped
37+
38+instance GHasType f a => GHasType (M1 C meta f) a where
39+ gtyped = mIso . gtyped
src/Data/Generics/Record/HasField.hs+12−12
@@ -94,29 +94,20 @@ class HasField (field :: Symbol) a s | s field -> a where
9494-- field.
9595instance
9696 ( Generic s
97− , Contains field (Rep s) ~ 'Just a -- this is needed for the fundep
97+ , ContainsField field (Rep s) ~ 'Just a -- this is needed for the fundep
9898 , GHasField field (Rep s) a
9999 ) => HasField field a s where
100100 label = repIso . glabel @field
101101
102102
103−class GHasFieldProd field a b ret (w :: Maybe Type) | field a b -> ret where
104− prodLabel :: Lens' ((a :*: b) x) ret
105−
106−instance (GHasField field f ret) => GHasFieldProd field f g ret ('Just ret) where
107− prodLabel = first . glabel @field
108−
109−instance (GHasField field g ret) => GHasFieldProd field f g ret 'Nothing where
110− prodLabel = second . glabel @field
111−
112103--------------------------------------------------------------------------------
113104
114105-- | Like 'HasField', but on the generic representation
115106class GHasField (field :: Symbol) (s :: Type -> Type) a | field s -> a where
116107 glabel :: Lens' (s x) a
117108
118−instance (GHasFieldProd field s s' a (Contains field s)) => GHasField field (s :*: s') a where
119− glabel = prodLabel @field @_ @_ @_ @(Contains field s)
109+instance (GHasFieldProd field s s' a (ContainsField field s)) => GHasField field (s :*: s') a where
110+ glabel = prodLabel @field @_ @_ @_ @(ContainsField field s)
120111
121112instance (GHasField field s a, GHasField field s' a) => GHasField field (s :+: s') a where
122113 glabel = combine (glabel @field @s) (glabel @field @s')
@@ -132,3 +123,12 @@ instance GHasField field s a => GHasField field (M1 D c s) a where
132123
133124instance GHasField field s a => GHasField field (M1 C c s) a where
134125 glabel = mIso . glabel @field
126+
127+class GHasFieldProd field a b ret (w :: Maybe Type) | field a b -> ret where
128+ prodLabel :: Lens' ((a :*: b) x) ret
129+
130+instance (GHasField field f ret) => GHasFieldProd field f g ret ('Just ret) where
131+ prodLabel = first . glabel @field
132+
133+instance (GHasField field g ret) => GHasFieldProd field f g ret 'Nothing where
134+ prodLabel = second . glabel @field
src/Data/Generics/Record/Internal/Contains.hs+33−31
@@ -1,11 +1,11 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE PolyKinds #-}
5−{-# LANGUAGE Rank2Types #-}
6−{-# LANGUAGE ScopedTypeVariables #-}
7−{-# LANGUAGE TypeFamilies #-}
8−{-# LANGUAGE TypeOperators #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE PolyKinds #-}
5+{-# LANGUAGE Rank2Types #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE TypeFamilies #-}
8+{-# LANGUAGE TypeOperators #-}
99{-# LANGUAGE UndecidableInstances #-}
1010
1111-----------------------------------------------------------------------------
@@ -21,43 +21,45 @@
2121--
2222-----------------------------------------------------------------------------
2323module Data.Generics.Record.Internal.Contains
24− ( Contains
24+ ( ContainsField
2525 ) where
2626
27−import Data.Kind (Type)
27+import Data.Kind (Type)
2828import GHC.Generics
29−
3029import GHC.TypeLits
3130
3231-- | Look up a record field by name in the generic representation, and return
3332-- its corresponding type, if exists.
34−type family Contains (field :: Symbol) f :: Maybe Type where
35− Contains field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 t))
33+type family ContainsField (field :: Symbol) f :: Maybe Type where
34+ ContainsField field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 t))
3635 = 'Just t
37− Contains field (f :*: g)
38− = Contains field f <|> Contains field g
39− Contains field (f :+: g)
40− = Contains field f <&> Contains field g
41− Contains field (S1 _ _)
36+ ContainsField field (f :*: g)
37+ = ContainsField field f <|> ContainsField field g
38+ ContainsField field (f :+: g)
39+ = ContainsField field f <&> ContainsField field g
40+ ContainsField field (S1 _ _)
4241 = 'Nothing
43− Contains field (C1 m f)
44− = Contains field f
45− Contains field (D1 m f)
46− = Contains field f
47− Contains field (Rec0 _)
42+ ContainsField field (C1 m f)
43+ = ContainsField field f
44+ ContainsField field (D1 m f)
45+ = ContainsField field f
46+ ContainsField field (Rec0 _)
4847 = 'Nothing
49− Contains field U1
48+ ContainsField field U1
5049 = 'Nothing
51− Contains field V1
50+ ContainsField field V1
5251 = 'Nothing
53− Contains x t = TypeError ('ShowType t)
52+ ContainsField x t
53+ = TypeError
54+ ( 'ShowType t
55+ ':<>: 'Text " is not a valid GHC.Generics representation type"
56+ )
5457
5558-- | Type-level alternative
5659type family (a :: Maybe k) <|> (b :: Maybe k) :: Maybe k where
57− 'Just x <|> _ = 'Just x
58− _ <|> b = b
60+ 'Just x <|> _ = 'Just x
61+ _ <|> b = b
5962
6063type family (a :: Maybe k) <&> (b :: Maybe k) :: Maybe k where
61− 'Just x <&> 'Just x = 'Just x
62− _ <&> _ = 'Nothing
63−
64+ 'Just x <&> 'Just x = 'Just x
65+ _ <&> _ = 'Nothing
src/Data/Generics/Record/Subtype.hs+2−2
@@ -121,9 +121,9 @@ instance (GSmash a sup, GSmash b sup) => GSmash (a :*: b) sup where
121121
122122instance {-# OVERLAPPING #-}
123123 ( leaf ~ (S1 ('MetaSel ('Just field) p f b) t)
124− , GSmashLeaf leaf sup (Contains field sup)
124+ , GSmashLeaf leaf sup (ContainsField field sup)
125125 ) => GSmash (S1 ('MetaSel ('Just field) p f b) t) sup where
126− gsmash = gsmashLeaf @_ @_ @(Contains field sup)
126+ gsmash = gsmashLeaf @_ @_ @(ContainsField field sup)
127127
128128instance GSmash sub sup => GSmash (M1 i c sub) sup where
129129 gsmash sup (M1 sub) = M1 (gsmash sup sub)