git.iko.soy/generic-lens
on master help sign in
Separate internals
commitbfcd00a83d9284ead43de9e6481d34c4677d772e authorCsongor Kiss <kiss.csongor.kiss@gmail.com> dateTue 8 Aug 2017, 20:17 (9 years ago) parent7665edc
18 files changed+563−322
compare with master
unifiedsplit
.gitignore+1 generic-lens.cabal+11−1 src/Data/Generics/Internal/HList.hs−1 src/Data/Generics/Product/Fields.hs+1−36 src/Data/Generics/Product/Internal/Fields.hs+68 src/Data/Generics/Product/Internal/Positions.hs+89 src/Data/Generics/Product/Internal/Subtype.hs+92 src/Data/Generics/Product/Internal/Typed.hs+62 src/Data/Generics/Product/Positions.hs+3−56 src/Data/Generics/Product/Subtype.hs+2−58 src/Data/Generics/Product/Typed.hs+2−32 src/Data/Generics/Sum.hs+2 src/Data/Generics/Sum/Constructors.hs+2−29 src/Data/Generics/Sum/Internal/Constructors.hs+63 src/Data/Generics/Sum/Internal/Subtype.hs+74 src/Data/Generics/Sum/Internal/Typed.hs+88 src/Data/Generics/Sum/Subtype.hs+2−48 src/Data/Generics/Sum/Typed.hs+1−61
.gitignore+1
@@ -3,3 +3,4 @@ dist*
33.stack-work
44.cabal-sandbox
55cabal.sandbox.config
6+.ghc*
generic-lens.cabal+11−1
@@ -24,11 +24,12 @@ library
2424 , Data.Generics.Product.Positions
2525 , Data.Generics.Product.Subtype
2626 , Data.Generics.Product.Typed
27+
2728 , Data.Generics.Sum
2829 , Data.Generics.Sum.Any
2930 , Data.Generics.Sum.Constructors
3031 , Data.Generics.Sum.Typed
31−
32+ , Data.Generics.Sum.Subtype
3233 , Data.Generics.Internal.Lens
3334
3435 other-modules: Data.Generics.Internal.Families
@@ -36,6 +37,15 @@ library
3637 , Data.Generics.Internal.Families.Has
3738 , Data.Generics.Internal.HList
3839
40+ , Data.Generics.Sum.Internal.Constructors
41+ , Data.Generics.Sum.Internal.Typed
42+ , Data.Generics.Sum.Internal.Subtype
43+
44+ , Data.Generics.Product.Internal.Fields
45+ , Data.Generics.Product.Internal.Positions
46+ , Data.Generics.Product.Internal.Subtype
47+ , Data.Generics.Product.Internal.Typed
48+
3949 build-depends: base >= 4.9 && <= 5.0
4050 , profunctors >= 5.0 && <= 6.0
4151
src/Data/Generics/Internal/HList.hs−1
@@ -6,7 +6,6 @@
66{-# LANGUAGE MultiParamTypeClasses #-}
77{-# LANGUAGE PolyKinds #-}
88{-# LANGUAGE ScopedTypeVariables #-}
9−{-# LANGUAGE TypeApplications #-}
109{-# LANGUAGE TypeFamilies #-}
1110{-# LANGUAGE TypeOperators #-}
1211{-# LANGUAGE UndecidableInstances #-}
src/Data/Generics/Product/Fields.hs+1−36
@@ -28,13 +28,11 @@ module Data.Generics.Product.Fields
2828
2929 -- $example
3030 HasField (..)
31−
32− -- *Internals
33− , GHasField (..)
3431 ) where
3532
3633import Data.Generics.Internal.Families
3734import Data.Generics.Internal.Lens
35+import Data.Generics.Product.Internal.Fields
3836
3937import Data.Kind (Constraint, Type)
4038import GHC.Generics
@@ -106,36 +104,3 @@ type family ErrorUnless (field :: Symbol) (s :: Type) (contains :: Bool) :: Cons
106104
107105 ErrorUnless _ _ 'True
108106 = ()
109−
110−-- |As 'HasField' but over generic representations as defined by
111−-- "GHC.Generics".
112−class GHasField (field :: Symbol) (f :: Type -> Type) a | field f -> a where
113− gfield :: Lens' (f x) a
114−
115−instance GProductHasField field l r a (HasTotalFieldP field l)
116− => GHasField field (l :*: r) a where
117−
118− gfield = gproductField @field @_ @_ @_ @(HasTotalFieldP field l)
119−
120−instance (GHasField field l a, GHasField field r a)
121− => GHasField field (l :+: r) a where
122−
123− gfield = combine (gfield @field @l) (gfield @field @r)
124−
125−instance GHasField field (S1 ('MetaSel ('Just field) upkd str infstr) (Rec0 a)) a where
126− gfield = mIso . kIso
127−
128−instance GHasField field f a => GHasField field (M1 D meta f) a where
129− gfield = mIso . gfield @field
130−
131−instance GHasField field f a => GHasField field (M1 C meta f) a where
132− gfield = mIso . gfield @field
133−
134−class GProductHasField (field :: Symbol) l r a (left :: Bool) | left field l r -> a where
135− gproductField :: Lens' ((l :*: r) x) a
136−
137−instance GHasField field l a => GProductHasField field l r a 'True where
138− gproductField = first . gfield @field
139−
140−instance GHasField field r a => GProductHasField field l r a 'False where
141− gproductField = second . gfield @field
src/Data/Generics/Product/Internal/Fields.hsnew file+68
@@ -0,0 +1,68 @@
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 TypeFamilies #-}
10+{-# LANGUAGE TypeOperators #-}
11+{-# LANGUAGE UndecidableInstances #-}
12+
13+-----------------------------------------------------------------------------
14+-- |
15+-- Module : Data.Generics.Product.Internal.Fields
16+-- Copyright : (C) 2017 Csongor Kiss
17+-- License : BSD3
18+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19+-- Stability : experimental
20+-- Portability : non-portable
21+--
22+-- Derive record field getters and setters generically.
23+--
24+-----------------------------------------------------------------------------
25+
26+module Data.Generics.Product.Internal.Fields
27+ ( GHasField (..)
28+ ) where
29+
30+import Data.Generics.Internal.Families
31+import Data.Generics.Internal.Lens
32+
33+import Data.Kind (Type)
34+import GHC.Generics
35+import GHC.TypeLits (Symbol)
36+
37+-- |As 'HasField' but over generic representations as defined by
38+-- "GHC.Generics".
39+class GHasField (field :: Symbol) (f :: Type -> Type) a | field f -> a where
40+ gfield :: Lens' (f x) a
41+
42+instance GProductHasField field l r a (HasTotalFieldP field l)
43+ => GHasField field (l :*: r) a where
44+
45+ gfield = gproductField @field @_ @_ @_ @(HasTotalFieldP field l)
46+
47+instance (GHasField field l a, GHasField field r a)
48+ => GHasField field (l :+: r) a where
49+
50+ gfield = combine (gfield @field @l) (gfield @field @r)
51+
52+instance GHasField field (S1 ('MetaSel ('Just field) upkd str infstr) (Rec0 a)) a where
53+ gfield = mIso . kIso
54+
55+instance GHasField field f a => GHasField field (M1 D meta f) a where
56+ gfield = mIso . gfield @field
57+
58+instance GHasField field f a => GHasField field (M1 C meta f) a where
59+ gfield = mIso . gfield @field
60+
61+class GProductHasField (field :: Symbol) l r a (left :: Bool) | left field l r -> a where
62+ gproductField :: Lens' ((l :*: r) x) a
63+
64+instance GHasField field l a => GProductHasField field l r a 'True where
65+ gproductField = first . gfield @field
66+
67+instance GHasField field r a => GProductHasField field l r a 'False where
68+ gproductField = second . gfield @field
src/Data/Generics/Product/Internal/Positions.hsnew file+89
@@ -0,0 +1,89 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE KindSignatures #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE PolyKinds #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE TypeApplications #-}
10+{-# LANGUAGE TypeFamilies #-}
11+{-# LANGUAGE TypeOperators #-}
12+{-# LANGUAGE UndecidableInstances #-}
13+
14+-----------------------------------------------------------------------------
15+-- |
16+-- Module : Data.Generics.Product.Internal.Positions
17+-- Copyright : (C) 2017 Csongor Kiss
18+-- License : BSD3
19+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20+-- Stability : experimental
21+-- Portability : non-portable
22+--
23+-- Derive positional product type getters and setters generically.
24+--
25+-----------------------------------------------------------------------------
26+
27+module Data.Generics.Product.Internal.Positions
28+ ( GHasPosition (..)
29+ , type (<?)
30+ , Size
31+ ) where
32+
33+import Data.Generics.Internal.Lens
34+
35+import Data.Kind (Type)
36+import Data.Type.Bool (If, Not)
37+import GHC.Generics
38+import GHC.TypeLits (type (<=?), type (+), Nat)
39+
40+-- |As 'HasPosition' but over generic representations as defined by
41+-- "GHC.Generics".
42+class GHasPosition (offset :: Nat) (i :: Nat) (f :: Type -> Type) a | offset i f -> a where
43+ gposition :: Lens' (f x) a
44+
45+instance GHasPosition i i (S1 meta (Rec0 a)) a where
46+ gposition = mIso . kIso
47+
48+instance GHasPosition offset i f a => GHasPosition offset i (M1 D meta f) a where
49+ gposition = mIso . gposition @offset @i
50+
51+instance GHasPosition offset i f a => GHasPosition offset i (M1 C meta f) a where
52+ gposition = mIso . gposition @offset @i
53+
54+instance
55+ ( goLeft ~ (i <? (offset + Size l))
56+ , offset' ~ (If goLeft offset (offset + Size l))
57+ , GProductHasPosition offset' i l r a goLeft
58+ ) => GHasPosition offset i (l :*: r) a where
59+
60+ gposition = gproductPosition @offset' @i @_ @_ @_ @goLeft
61+
62+
63+class GProductHasPosition (offset :: Nat) (i :: Nat) l r a (left :: Bool) | offset i l r left -> a where
64+ gproductPosition :: Lens' ((l :*: r) x) a
65+
66+instance GHasPosition offset i l a => GProductHasPosition offset i l r a 'True where
67+ gproductPosition = first . gposition @offset @i
68+
69+instance GHasPosition offset i r a => GProductHasPosition offset i l r a 'False where
70+ gproductPosition = second . gposition @offset @i
71+
72+type family Size f :: Nat where
73+ Size (l :*: r)
74+ = Size l + Size r
75+ Size (l :+: r)
76+ = Min (Size l) (Size r)
77+ Size (D1 meta f)
78+ = Size f
79+ Size (C1 meta f)
80+ = Size f
81+ Size f
82+ = 1
83+
84+--------------------------------------------------------------------------------
85+
86+type x <? y = Not (y <=? x)
87+infixl 4 <?
88+
89+type Min a b = If (a <? b) a b
src/Data/Generics/Product/Internal/Subtype.hsnew file+92
@@ -0,0 +1,92 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE NoMonomorphismRestriction #-}
7+{-# LANGUAGE PolyKinds #-}
8+{-# LANGUAGE Rank2Types #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TypeApplications #-}
11+{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE TypeOperators #-}
13+{-# LANGUAGE UndecidableInstances #-}
14+
15+-----------------------------------------------------------------------------
16+-- |
17+-- Module : Data.Generics.Product.Internal.Subtype
18+-- Copyright : (C) 2017 Csongor Kiss
19+-- License : BSD3
20+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21+-- Stability : experimental
22+-- Portability : non-portable
23+--
24+-- Structural subtype relationships between product types.
25+--
26+-----------------------------------------------------------------------------
27+
28+module Data.Generics.Product.Internal.Subtype
29+ ( GUpcast (..)
30+ , GSmash (..)
31+ ) where
32+
33+import Data.Generics.Internal.Families
34+import Data.Generics.Internal.Lens
35+import Data.Generics.Product.Internal.Fields
36+
37+import Data.Kind (Type)
38+import GHC.Generics
39+
40+--------------------------------------------------------------------------------
41+-- * Generic upcasting
42+
43+class GUpcast (sub :: Type -> Type) (sup :: Type -> Type) where
44+ gupcast :: sub p -> sup p
45+
46+instance (GUpcast sub a, GUpcast sub b) => GUpcast sub (a :*: b) where
47+ gupcast rep = gupcast rep :*: gupcast rep
48+
49+instance
50+ GHasField field sub t
51+ => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
52+
53+ gupcast r = M1 (K1 (r ^. gfield @field))
54+
55+instance GUpcast sub sup => GUpcast sub (C1 c sup) where
56+ gupcast = M1 . gupcast
57+
58+instance GUpcast sub sup => GUpcast sub (D1 c sup) where
59+ gupcast = M1 . gupcast
60+
61+--------------------------------------------------------------------------------
62+-- * Generic smashing
63+
64+class GSmash sub sup where
65+ gsmash :: sup p -> sub p -> sub p
66+
67+instance (GSmash a sup, GSmash b sup) => GSmash (a :*: b) sup where
68+ gsmash rep (a :*: b) = gsmash rep a :*: gsmash rep b
69+
70+instance
71+ ( leaf ~ (S1 ('MetaSel ('Just field) p f b) t)
72+ , GSmashLeaf leaf sup (HasTotalFieldP field sup)
73+ ) => GSmash (S1 ('MetaSel ('Just field) p f b) t) sup where
74+
75+ gsmash = gsmashLeaf @_ @_ @(HasTotalFieldP field sup)
76+
77+instance GSmash sub sup => GSmash (C1 c sub) sup where
78+ gsmash sup (M1 sub) = M1 (gsmash sup sub)
79+
80+instance GSmash sub sup => GSmash (D1 c sub) sup where
81+ gsmash sup (M1 sub) = M1 (gsmash sup sub)
82+
83+class GSmashLeaf sub sup (w :: Bool) where
84+ gsmashLeaf :: sup p -> sub p -> sub p
85+
86+instance
87+ GHasField field sup t
88+ => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'True where
89+ gsmashLeaf sup _ = M1 (K1 (sup ^. gfield @field))
90+
91+instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'False where
92+ gsmashLeaf _ = id
src/Data/Generics/Product/Internal/Typed.hsnew file+62
@@ -0,0 +1,62 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE KindSignatures #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeApplications #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeOperators #-}
11+{-# LANGUAGE UndecidableInstances #-}
12+
13+-----------------------------------------------------------------------------
14+-- |
15+-- Module : Data.Generics.Product.Internal.Typed
16+-- Copyright : (C) 2017 Csongor Kiss
17+-- License : BSD3
18+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19+-- Stability : experimental
20+-- Portability : non-portable
21+--
22+-- Derive record field getters and setters generically.
23+--
24+-----------------------------------------------------------------------------
25+
26+module Data.Generics.Product.Internal.Typed
27+ ( GHasType (..)
28+ ) where
29+
30+import Data.Generics.Internal.Families
31+import Data.Generics.Internal.Lens
32+
33+import Data.Kind (Type)
34+import GHC.Generics
35+
36+-- |As 'HasType' but over generic representations as defined by
37+-- "GHC.Generics".
38+class GHasType (f :: Type -> Type) a where
39+ gtyped :: Lens' (f x) a
40+
41+instance GProductHasType l r a (HasTotalTypeP a l)
42+ => GHasType (l :*: r) a where
43+
44+ gtyped = gproductTyped @_ @_ @_ @(HasTotalTypeP a l)
45+
46+instance (GHasType l a, GHasType r a) => GHasType (l :+: r) a where
47+ gtyped = combine (gtyped @l) (gtyped @r)
48+
49+instance GHasType (K1 R a) a where
50+ gtyped f (K1 x) = fmap K1 (f x)
51+
52+instance GHasType f a => GHasType (M1 m meta f) a where
53+ gtyped = mIso . gtyped
54+
55+class GProductHasType l r a (contains :: Bool) where
56+ gproductTyped :: Lens' ((l :*: r) x) a
57+
58+instance GHasType l a => GProductHasType l r a 'True where
59+ gproductTyped = first . gtyped
60+
61+instance GHasType r a => GProductHasType l r a 'False where
62+ gproductTyped = second . gtyped
src/Data/Generics/Product/Positions.hs+3−56
@@ -29,17 +29,15 @@ module Data.Generics.Product.Positions
2929
3030 -- $example
3131 HasPosition (..)
32−
33− -- *Internals
34− , GHasPosition (..)
3532 ) where
3633
3734import Data.Generics.Internal.Lens
35+import Data.Generics.Product.Internal.Positions
3836
3937import Data.Kind (Constraint, Type)
40−import Data.Type.Bool (If, type (&&), Not)
38+import Data.Type.Bool (type (&&))
4139import GHC.Generics
42−import GHC.TypeLits (type (<=?), type (+), Nat, TypeError, ErrorMessage(..))
40+import GHC.TypeLits (type (<=?), Nat, TypeError, ErrorMessage(..))
4341
4442-- $example
4543-- @
@@ -108,54 +106,3 @@ type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint wher
108106
109107 ErrorUnless _ _ 'True
110108 = ()
111−
112−-- |As 'HasPosition' but over generic representations as defined by
113−-- "GHC.Generics".
114−class GHasPosition (offset :: Nat) (i :: Nat) (f :: Type -> Type) a | offset i f -> a where
115− gposition :: Lens' (f x) a
116−
117−instance GHasPosition i i (S1 meta (Rec0 a)) a where
118− gposition = mIso . kIso
119−
120−instance GHasPosition offset i f a => GHasPosition offset i (M1 D meta f) a where
121− gposition = mIso . gposition @offset @i
122−
123−instance GHasPosition offset i f a => GHasPosition offset i (M1 C meta f) a where
124− gposition = mIso . gposition @offset @i
125−
126−instance
127− ( goLeft ~ (i <? (offset + Size l))
128− , offset' ~ (If goLeft offset (offset + Size l))
129− , GProductHasPosition offset' i l r a goLeft
130− ) => GHasPosition offset i (l :*: r) a where
131−
132− gposition = gproductPosition @offset' @i @_ @_ @_ @goLeft
133−
134−
135−class GProductHasPosition (offset :: Nat) (i :: Nat) l r a (left :: Bool) | offset i l r left -> a where
136− gproductPosition :: Lens' ((l :*: r) x) a
137−
138−instance GHasPosition offset i l a => GProductHasPosition offset i l r a 'True where
139− gproductPosition = first . gposition @offset @i
140−
141−instance GHasPosition offset i r a => GProductHasPosition offset i l r a 'False where
142− gproductPosition = second . gposition @offset @i
143−
144−type family Size f :: Nat where
145− Size (l :*: r)
146− = Size l + Size r
147− Size (l :+: r)
148− = Min (Size l) (Size r)
149− Size (D1 meta f)
150− = Size f
151− Size (C1 meta f)
152− = Size f
153− Size f
154− = 1
155−
156−--------------------------------------------------------------------------------
157−
158−type x <? y = Not (y <=? x)
159−infixl 4 <?
160−
161−type Min a b = If (a <? b) a b
src/Data/Generics/Product/Subtype.hs+2−58
@@ -32,12 +32,10 @@ module Data.Generics.Product.Subtype
3232 Subtype (..)
3333 ) where
3434
35−import Data.Generics.Internal.Families
3635import Data.Generics.Internal.Lens
37−import Data.Generics.Product.Fields
36+import Data.Generics.Product.Internal.Subtype
3837
39−import Data.Kind (Type)
40−import GHC.Generics
38+import GHC.Generics (Generic (Rep, to, from) )
4139
4240-- $example
4341-- @
@@ -104,57 +102,3 @@ instance
104102 ) => Subtype b a where
105103 smash p b = to $ gsmash (from p) (from b)
106104 upcast = to . gupcast . from
107−
108−--------------------------------------------------------------------------------
109−-- * Generic upcasting
110−
111−class GUpcast (sub :: Type -> Type) (sup :: Type -> Type) where
112− gupcast :: sub p -> sup p
113−
114−instance (GUpcast sub a, GUpcast sub b) => GUpcast sub (a :*: b) where
115− gupcast rep = gupcast rep :*: gupcast rep
116−
117−instance
118− GHasField field sub t
119− => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
120−
121− gupcast r = M1 (K1 (r ^. gfield @field))
122−
123−instance GUpcast sub sup => GUpcast sub (C1 c sup) where
124− gupcast = M1 . gupcast
125−
126−instance GUpcast sub sup => GUpcast sub (D1 c sup) where
127− gupcast = M1 . gupcast
128−
129−--------------------------------------------------------------------------------
130−-- * Generic smashing
131−
132−class GSmash sub sup where
133− gsmash :: sup p -> sub p -> sub p
134−
135−instance (GSmash a sup, GSmash b sup) => GSmash (a :*: b) sup where
136− gsmash rep (a :*: b) = gsmash rep a :*: gsmash rep b
137−
138−instance
139− ( leaf ~ (S1 ('MetaSel ('Just field) p f b) t)
140− , GSmashLeaf leaf sup (HasTotalFieldP field sup)
141− ) => GSmash (S1 ('MetaSel ('Just field) p f b) t) sup where
142−
143− gsmash = gsmashLeaf @_ @_ @(HasTotalFieldP field sup)
144−
145−instance GSmash sub sup => GSmash (C1 c sub) sup where
146− gsmash sup (M1 sub) = M1 (gsmash sup sub)
147−
148−instance GSmash sub sup => GSmash (D1 c sub) sup where
149− gsmash sup (M1 sub) = M1 (gsmash sup sub)
150−
151−class GSmashLeaf sub sup (w :: Bool) where
152− gsmashLeaf :: sup p -> sub p -> sub p
153−
154−instance
155− GHasField field sup t
156− => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'True where
157− gsmashLeaf sup _ = M1 (K1 (sup ^. gfield @field))
158−
159−instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'False where
160− gsmashLeaf _ = id
src/Data/Generics/Product/Typed.hs+2−32
@@ -28,16 +28,14 @@ module Data.Generics.Product.Typed
2828 --
2929 -- $example
3030 HasType (..)
31−
32− -- *Internals
33− , GHasType (..)
3431 ) where
3532
3633import Data.Generics.Internal.Families
3734import Data.Generics.Internal.Lens
35+import Data.Generics.Product.Internal.Typed
3836
3937import Data.Kind (Constraint, Type)
40−import GHC.Generics
38+import GHC.Generics (Generic (Rep))
4139import GHC.TypeLits (TypeError, ErrorMessage (..))
4240
4341-- $example
@@ -107,31 +105,3 @@ type family ErrorUnlessOne (a :: Type) (s :: Type) (count :: Count) :: Constrain
107105
108106 ErrorUnlessOne _ _ 'One
109107 = ()
110−
111−-- |As 'HasType' but over generic representations as defined by
112−-- "GHC.Generics".
113−class GHasType (f :: Type -> Type) a where
114− gtyped :: Lens' (f x) a
115−
116−instance GProductHasType l r a (HasTotalTypeP a l)
117− => GHasType (l :*: r) a where
118−
119− gtyped = gproductTyped @_ @_ @_ @(HasTotalTypeP a l)
120−
121−instance (GHasType l a, GHasType r a) => GHasType (l :+: r) a where
122− gtyped = combine (gtyped @l) (gtyped @r)
123−
124−instance GHasType (K1 R a) a where
125− gtyped f (K1 x) = fmap K1 (f x)
126−
127−instance GHasType f a => GHasType (M1 m meta f) a where
128− gtyped = mIso . gtyped
129−
130−class GProductHasType l r a (contains :: Bool) where
131− gproductTyped :: Lens' ((l :*: r) x) a
132−
133−instance GHasType l a => GProductHasType l r a 'True where
134− gproductTyped = first . gtyped
135−
136−instance GHasType r a => GProductHasType l r a 'False where
137− gproductTyped = second . gtyped
src/Data/Generics/Sum.hs+2
@@ -20,9 +20,11 @@ module Data.Generics.Sum
2020 AsAny (..)
2121
2222 , AsConstructor (..)
23+ , AsSubtype (..)
2324 , AsType (..)
2425 ) where
2526
2627import Data.Generics.Sum.Any
2728import Data.Generics.Sum.Constructors
29+import Data.Generics.Sum.Subtype
2830import Data.Generics.Sum.Typed
src/Data/Generics/Sum/Constructors.hs+2−29
@@ -31,11 +31,11 @@ module Data.Generics.Sum.Constructors
3131 ) where
3232
3333import Data.Generics.Internal.Families
34−import Data.Generics.Internal.HList
3534import Data.Generics.Internal.Lens
35+import Data.Generics.Sum.Internal.Constructors
3636
3737import Data.Kind (Constraint, Type)
38−import GHC.Generics
38+import GHC.Generics (Generic (Rep))
3939import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
4040
4141-- $example
@@ -104,30 +104,3 @@ type family ErrorUnless (ctor :: Symbol) (s :: Type) (contains :: Bool) :: Const
104104
105105 ErrorUnless _ _ 'True
106106 = ()
107−
108−-- |As 'AsConstructor' but over generic representations as defined by
109−-- "GHC.Generics".
110−class GAsConstructor (ctor :: Symbol) (f :: Type -> Type) a | ctor f -> a where
111− _GCtor :: Prism' (f x) a
112−
113−instance
114− ( GCollectible f as
115− , ListTuple a as
116− ) => GAsConstructor ctor (M1 C ('MetaCons ctor fixity fields) f) a where
117−
118− _GCtor = prism (M1 . gfromCollection . tupleToList) (Right . listToTuple @_ @as . gtoCollection . unM1)
119−
120−instance GSumAsConstructor ctor l r a (HasCtorP ctor l) => GAsConstructor ctor (l :+: r) a where
121− _GCtor = _GSumCtor @ctor @l @r @a @(HasCtorP ctor l)
122−
123−instance GAsConstructor ctor f a => GAsConstructor ctor (M1 D meta f) a where
124− _GCtor = mIso . _GCtor @ctor
125−
126−class GSumAsConstructor (ctor :: Symbol) l r a (contains :: Bool) | ctor l r contains -> a where
127− _GSumCtor :: Prism' ((l :+: r) x) a
128−
129−instance GAsConstructor ctor l a => GSumAsConstructor ctor l r a 'True where
130− _GSumCtor = left . _GCtor @ctor
131−
132−instance GAsConstructor ctor r a => GSumAsConstructor ctor l r a 'False where
133− _GSumCtor = right . _GCtor @ctor
src/Data/Generics/Sum/Internal/Constructors.hsnew file+63
@@ -0,0 +1,63 @@
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 TypeFamilies #-}
10+{-# LANGUAGE TypeOperators #-}
11+{-# LANGUAGE UndecidableInstances #-}
12+
13+-----------------------------------------------------------------------------
14+-- |
15+-- Module : Data.Generics.Sum.Internal.Constructors
16+-- Copyright : (C) 2017 Csongor Kiss
17+-- License : BSD3
18+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19+-- Stability : experimental
20+-- Portability : non-portable
21+--
22+-- Derive constructor-name-based prisms generically.
23+--
24+-----------------------------------------------------------------------------
25+
26+module Data.Generics.Sum.Internal.Constructors
27+ ( GAsConstructor (..)
28+ ) where
29+
30+import Data.Generics.Internal.Families
31+import Data.Generics.Internal.HList
32+import Data.Generics.Internal.Lens
33+
34+import Data.Kind (Type)
35+import GHC.Generics
36+import GHC.TypeLits (Symbol)
37+
38+-- |As 'AsConstructor' but over generic representations as defined by
39+-- "GHC.Generics".
40+class GAsConstructor (ctor :: Symbol) (f :: Type -> Type) a | ctor f -> a where
41+ _GCtor :: Prism' (f x) a
42+
43+instance
44+ ( GCollectible f as
45+ , ListTuple a as
46+ ) => GAsConstructor ctor (M1 C ('MetaCons ctor fixity fields) f) a where
47+
48+ _GCtor = prism (M1 . gfromCollection . tupleToList) (Right . listToTuple @_ @as . gtoCollection . unM1)
49+
50+instance GSumAsConstructor ctor l r a (HasCtorP ctor l) => GAsConstructor ctor (l :+: r) a where
51+ _GCtor = _GSumCtor @ctor @l @r @a @(HasCtorP ctor l)
52+
53+instance GAsConstructor ctor f a => GAsConstructor ctor (M1 D meta f) a where
54+ _GCtor = mIso . _GCtor @ctor
55+
56+class GSumAsConstructor (ctor :: Symbol) l r a (contains :: Bool) | ctor l r contains -> a where
57+ _GSumCtor :: Prism' ((l :+: r) x) a
58+
59+instance GAsConstructor ctor l a => GSumAsConstructor ctor l r a 'True where
60+ _GSumCtor = left . _GCtor @ctor
61+
62+instance GAsConstructor ctor r a => GSumAsConstructor ctor l r a 'False where
63+ _GSumCtor = right . _GCtor @ctor
src/Data/Generics/Sum/Internal/Subtype.hsnew file+74
@@ -0,0 +1,74 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE KindSignatures #-}
4+{-# LANGUAGE MultiParamTypeClasses #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TypeApplications #-}
7+{-# LANGUAGE TypeOperators #-}
8+{-# LANGUAGE TypeSynonymInstances #-}
9+{-# LANGUAGE UndecidableInstances #-}
10+
11+-----------------------------------------------------------------------------
12+-- |
13+-- Module : Data.Generics.Sum.Internal.Subtype
14+-- Copyright : (C) 2017 Csongor Kiss
15+-- License : BSD3
16+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17+-- Stability : experimental
18+-- Portability : non-portable
19+--
20+-- Structural subtype relationships between sum types.
21+--
22+-----------------------------------------------------------------------------
23+
24+module Data.Generics.Sum.Internal.Subtype
25+ ( GAsSubtype (..)
26+ ) where
27+
28+import Data.Generics.Internal.HList
29+import Data.Generics.Sum.Internal.Typed
30+
31+import Data.Kind
32+import GHC.Generics
33+
34+-- |As 'AsSubtype' but over generic representations as defined by
35+-- "GHC.Generics".
36+class GAsSubtype (subf :: Type -> Type) (supf :: Type -> Type) where
37+ ginjectSub :: subf x -> supf x
38+ gprojectSub :: supf x -> Either (supf x) (subf x)
39+
40+instance
41+ ( GAsSubtype l supf
42+ , GAsSubtype r supf
43+ ) => GAsSubtype (l :+: r) supf where
44+
45+ ginjectSub x = case x of
46+ L1 l -> ginjectSub l
47+ R1 r -> ginjectSub r
48+ gprojectSub x
49+ = case gprojectSub x of
50+ Left _ -> fmap R1 (gprojectSub x)
51+ Right y -> Right (L1 y)
52+
53+instance
54+ ( GAsType supf a
55+ , GCollectible subf as
56+ , ListTuple a as
57+ ) => GAsSubtype (C1 meta subf) supf where
58+
59+ ginjectSub
60+ = ginjectTyped . listToTuple . gtoCollection . unM1
61+ gprojectSub
62+ = fmap (M1 . gfromCollection . tupleToList) . gprojectTyped
63+
64+instance GAsType supf a => GAsSubtype (S1 meta (Rec0 a)) supf where
65+ ginjectSub
66+ = ginjectTyped @supf . unK1 . unM1
67+ gprojectSub
68+ = fmap (M1 . K1) . gprojectTyped @supf
69+
70+instance GAsSubtype subf supf => GAsSubtype (D1 meta subf) supf where
71+ ginjectSub
72+ = ginjectSub . unM1
73+ gprojectSub
74+ = fmap M1 . gprojectSub
src/Data/Generics/Sum/Internal/Typed.hsnew file+88
@@ -0,0 +1,88 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE KindSignatures #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeApplications #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeOperators #-}
11+{-# LANGUAGE UndecidableInstances #-}
12+
13+-----------------------------------------------------------------------------
14+-- |
15+-- Module : Data.Generics.Sum.Internal.Typed
16+-- Copyright : (C) 2017 Csongor Kiss
17+-- License : BSD3
18+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19+-- Stability : experimental
20+-- Portability : non-portable
21+--
22+-- Derive constructor-field-type-based prisms generically.
23+--
24+-----------------------------------------------------------------------------
25+
26+module Data.Generics.Sum.Internal.Typed
27+ ( GAsType (..)
28+ ) where
29+
30+import Data.Kind
31+import GHC.Generics
32+
33+import Data.Generics.Internal.Families
34+import Data.Generics.Internal.HList
35+import Data.Generics.Internal.Lens
36+
37+-- |As 'AsType' but over generic representations as defined by "GHC.Generics".
38+class GAsType (f :: Type -> Type) a where
39+ _GTyped :: Prism' (f x) a
40+ _GTyped = prism ginjectTyped gprojectTyped
41+
42+ ginjectTyped :: a -> f x
43+ gprojectTyped :: f x -> Either (f x) a
44+
45+instance
46+ ( GCollectible f as
47+ , ListTuple a as
48+ ) => GAsType (M1 C meta f) a where
49+
50+ ginjectTyped
51+ = M1 . gfromCollection . tupleToList
52+ gprojectTyped
53+ = Right . listToTuple . gtoCollection . unM1
54+
55+instance GSumAsType (HasPartialTypeTupleP a l) l r a => GAsType (l :+: r) a where
56+ ginjectTyped
57+ = ginjectSumTyped @(HasPartialTypeTupleP a l) @l @r @a
58+ gprojectTyped
59+ = gprojectSumTyped @(HasPartialTypeTupleP a l) @l @r @a
60+
61+instance GAsType f a => GAsType (M1 D meta f) a where
62+ ginjectTyped
63+ = M1 . ginjectTyped
64+ gprojectTyped
65+ = either (Left . M1) Right . gprojectTyped . unM1
66+
67+class GSumAsType (contains :: Bool) l r a where
68+ _GSumTyped :: Prism' ((l :+: r) x) a
69+ _GSumTyped = prism (ginjectSumTyped @contains) (gprojectSumTyped @contains)
70+
71+ ginjectSumTyped :: a -> (l :+: r) x
72+ gprojectSumTyped :: (l :+: r) x -> Either ((l :+: r) x) a
73+
74+instance GAsType l a => GSumAsType 'True l r a where
75+ ginjectSumTyped
76+ = L1 . ginjectTyped
77+ gprojectSumTyped x
78+ = case x of
79+ L1 l -> either (Left . L1) Right (gprojectTyped l)
80+ R1 _ -> Left x
81+
82+instance GAsType r a => GSumAsType 'False l r a where
83+ ginjectSumTyped
84+ = R1 . ginjectTyped
85+ gprojectSumTyped x
86+ = case x of
87+ R1 r -> either (Left . R1) Right (gprojectTyped r)
88+ L1 _ -> Left x
src/Data/Generics/Sum/Subtype.hs+2−48
@@ -1,9 +1,7 @@
11{-# LANGUAGE FlexibleContexts #-}
22{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE KindSignatures #-}
43{-# LANGUAGE MultiParamTypeClasses #-}
54{-# LANGUAGE ScopedTypeVariables #-}
6−{-# LANGUAGE TypeApplications #-}
75{-# LANGUAGE TypeOperators #-}
86{-# LANGUAGE TypeSynonymInstances #-}
97{-# LANGUAGE UndecidableInstances #-}
@@ -28,12 +26,10 @@ module Data.Generics.Sum.Subtype
2826 AsSubtype (..)
2927 ) where
3028
31−import Data.Generics.Internal.HList
3229import Data.Generics.Internal.Lens
33−import Data.Generics.Sum.Typed
30+import Data.Generics.Sum.Internal.Subtype
3431
35−import Data.Kind
36−import GHC.Generics
32+import GHC.Generics (Generic (Rep, to, from))
3733
3834-- $example
3935-- @
@@ -110,45 +106,3 @@ instance
110106
111107 injectSub = to . ginjectSub . from
112108 projectSub = either (Left . to) (Right . to) . gprojectSub . from
113−
114−-- |As 'AsSubtype' but over generic representations as defined by
115−-- "GHC.Generics".
116−class GAsSubtype (subf :: Type -> Type) (supf :: Type -> Type) where
117− ginjectSub :: subf x -> supf x
118− gprojectSub :: supf x -> Either (supf x) (subf x)
119−
120−instance
121− ( GAsSubtype l supf
122− , GAsSubtype r supf
123− ) => GAsSubtype (l :+: r) supf where
124−
125− ginjectSub x = case x of
126− L1 l -> ginjectSub l
127− R1 r -> ginjectSub r
128− gprojectSub x
129− = case gprojectSub x of
130− Left _ -> fmap R1 (gprojectSub x)
131− Right y -> Right (L1 y)
132−
133−instance
134− ( GAsType supf a
135− , GCollectible subf as
136− , ListTuple a as
137− ) => GAsSubtype (C1 meta subf) supf where
138−
139− ginjectSub
140− = ginjectTyped . listToTuple . gtoCollection . unM1
141− gprojectSub
142− = fmap (M1 . gfromCollection . tupleToList) . gprojectTyped
143−
144−instance GAsType supf a => GAsSubtype (S1 meta (Rec0 a)) supf where
145− ginjectSub
146− = ginjectTyped @supf . unK1 . unM1
147− gprojectSub
148− = fmap (M1 . K1) . gprojectTyped @supf
149−
150−instance GAsSubtype subf supf => GAsSubtype (D1 meta subf) supf where
151− ginjectSub
152− = ginjectSub . unM1
153− gprojectSub
154− = fmap M1 . gprojectSub
src/Data/Generics/Sum/Typed.hs+1−61
@@ -2,17 +2,13 @@
22{-# LANGUAGE DataKinds #-}
33{-# LANGUAGE FlexibleContexts #-}
44{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE FunctionalDependencies #-}
65{-# LANGUAGE KindSignatures #-}
76{-# LANGUAGE MultiParamTypeClasses #-}
87{-# LANGUAGE ScopedTypeVariables #-}
9−{-# LANGUAGE TypeApplications #-}
108{-# LANGUAGE TypeFamilies #-}
119{-# LANGUAGE TypeOperators #-}
1210{-# LANGUAGE UndecidableInstances #-}
1311
14−{-# LANGUAGE DeriveGeneric #-}
15−
1612-----------------------------------------------------------------------------
1713-- |
1814-- Module : Data.Generics.Sum.Typed
@@ -31,17 +27,14 @@ module Data.Generics.Sum.Typed
3127 --
3228 -- $example
3329 AsType (..)
34−
35− -- *Internals
36− , GAsType (..)
3730 ) where
3831
3932import Data.Kind
4033import GHC.Generics
4134import GHC.TypeLits (TypeError, ErrorMessage (..))
35+import Data.Generics.Sum.Internal.Typed
4236
4337import Data.Generics.Internal.Families
44−import Data.Generics.Internal.HList
4538import Data.Generics.Internal.Lens
4639
4740-- $example
@@ -116,56 +109,3 @@ type family ErrorUnlessOne (a :: Type) (s :: Type) (count :: Count) :: Constrain
116109
117110 ErrorUnlessOne _ _ 'One
118111 = ()
119−
120−-- |As 'AsType' but over generic representations as defined by "GHC.Generics".
121−class GAsType (f :: Type -> Type) a where
122− _GTyped :: Prism' (f x) a
123− _GTyped = prism ginjectTyped gprojectTyped
124−
125− ginjectTyped :: a -> f x
126− gprojectTyped :: f x -> Either (f x) a
127−
128−instance
129− ( GCollectible f as
130− , ListTuple a as
131− ) => GAsType (M1 C meta f) a where
132−
133− ginjectTyped
134− = M1 . gfromCollection . tupleToList
135− gprojectTyped
136− = Right . listToTuple . gtoCollection . unM1
137−
138−instance GSumAsType (HasPartialTypeTupleP a l) l r a => GAsType (l :+: r) a where
139− ginjectTyped
140− = ginjectSumTyped @(HasPartialTypeTupleP a l) @l @r @a
141− gprojectTyped
142− = gprojectSumTyped @(HasPartialTypeTupleP a l) @l @r @a
143−
144−instance GAsType f a => GAsType (M1 D meta f) a where
145− ginjectTyped
146− = M1 . ginjectTyped
147− gprojectTyped
148− = either (Left . M1) Right . gprojectTyped . unM1
149−
150−class GSumAsType (contains :: Bool) l r a where
151− _GSumTyped :: Prism' ((l :+: r) x) a
152− _GSumTyped = prism (ginjectSumTyped @contains) (gprojectSumTyped @contains)
153−
154− ginjectSumTyped :: a -> (l :+: r) x
155− gprojectSumTyped :: (l :+: r) x -> Either ((l :+: r) x) a
156−
157−instance GAsType l a => GSumAsType 'True l r a where
158− ginjectSumTyped
159− = L1 . ginjectTyped
160− gprojectSumTyped
161− = \x -> case x of
162− L1 l -> either (Left . L1) Right (gprojectTyped l)
163− R1 _ -> Left x
164−
165−instance GAsType r a => GSumAsType 'False l r a where
166− ginjectSumTyped
167− = R1 . ginjectTyped
168− gprojectSumTyped
169− = \x -> case x of
170− R1 r -> either (Left . R1) Right (gprojectTyped r)
171− L1 _ -> Left x