on master help sign in
Merge pull request #33 from kcsongor/wip/boggle-merge
commit2559ecc91d83576565df9f323255b31e40f3e463 authorCsongor Kiss <kiss.csongor.kiss@gmail.com> dateThu 25 Jan 2018, 20:54 (9 years ago) parent876ad1572ccf99
44 files changed+1645−764
.travis.yml+9−1 cabal.project+1 examples/Examples.hs+6−1 generic-lens.cabal+19−31 src/Data/Generics/Internal/Families.hs+1−1 src/Data/Generics/Internal/Families/Collect.hs+3−2 src/Data/Generics/Internal/Families/Has.hs+21−8 src/Data/Generics/Internal/HList.hs−239 src/Data/Generics/Internal/Lens.hs−143 src/Data/Generics/Internal/Profunctor/Iso.hs+98 src/Data/Generics/Internal/Profunctor/Lens.hs+170 src/Data/Generics/Internal/Profunctor/Prism.hs+118 src/Data/Generics/Internal/VL/Iso.hs+45 src/Data/Generics/Internal/VL/Lens.hs+65 src/Data/Generics/Internal/VL/Prism.hs+73 src/Data/Generics/Internal/VL/Traversal.hs+72 src/Data/Generics/Internal/Void.hs+1 src/Data/Generics/Product.hs+4 src/Data/Generics/Product/Any.hs+2−2 src/Data/Generics/Product/Fields.hs+14−13 src/Data/Generics/Product/Internal/Fields.hs−77 src/Data/Generics/Product/Internal/Keyed.hs+60 src/Data/Generics/Product/Internal/List.hs+335 src/Data/Generics/Product/Internal/Positions.hs+17−24 src/Data/Generics/Product/Internal/Subtype.hs+6−6 src/Data/Generics/Product/Internal/Typed.hs−62 src/Data/Generics/Product/Internal/Types.hs+59 src/Data/Generics/Product/List.hs+78 src/Data/Generics/Product/Positions.hs+9−7 src/Data/Generics/Product/Subtype.hs+7−6 src/Data/Generics/Product/Typed.hs+12−10 src/Data/Generics/Product/Types.hs+46 src/Data/Generics/Sum/Any.hs+3−3 src/Data/Generics/Sum/Constructors.hs+7−3 src/Data/Generics/Sum/Internal/Constructors.hs+14−5 src/Data/Generics/Sum/Internal/Subtype.hs+69−35 src/Data/Generics/Sum/Internal/Typed.hs+32−53 src/Data/Generics/Sum/Subtype.hs+11−6 src/Data/Generics/Sum/Typed.hs+16−10 stack.yaml+2−2 test/Spec.hs+127−12 test/24.hs → test/Test24.hs+1−1 test/25.hs → test/Test25.hs+1−1 test/Util.hs+11
.travis.yml+9−1
@@ -25,6 +25,8 @@ before_cache:
2525 - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx
2626
2727matrix:
28+ allow_failures:
29+ - compiler: "ghc-8.4.1"
2830 include:
2931 - compiler: "ghc-8.0.2"
3032 # env: TEST=--disable-tests BENCH=--disable-benchmarks
@@ -32,6 +34,12 @@ matrix:
3234 - compiler: "ghc-8.2.1"
3335 # env: TEST=--disable-tests BENCH=--disable-benchmarks
3436 addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.1], sources: [hvr-ghc]}}
37+ - compiler: "ghc-8.2.2"
38+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
39+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.2], sources: [hvr-ghc]}}
40+ - compiler: "ghc-8.4.1"
41+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
42+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.4.1], sources: [hvr-ghc]}}
3543
3644before_install:
3745 - HC=${CC}
@@ -67,7 +75,7 @@ script:
6775 - mv "."/dist/generic-lens-*.tar.gz ${DISTDIR}/
6876 - cd ${DISTDIR}
6977 - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;
70− - "printf 'packages: generic-lens-*/*.cabal\n' > cabal.project"
78+ - "printf 'packages: generic-lens-*/*.cabal' > cabal.project"
7179 # this builds all libraries and executables (without tests/benchmarks)
7280 - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all
7381
cabal.projectnew file+1
@@ -0,0 +1 @@
1+packages: generic-lens.cabal
examples/Examples.hs+6−1
@@ -17,11 +17,16 @@
1717module Examples where
1818
1919import Data.Function ((&))
20−import Data.Generics.Internal.Lens
20+import Data.Generics.Internal.VL.Lens
2121import Data.Generics.Product
2222import Data.Generics.Sum
2323import GHC.Generics
2424import Data.Generics.Labels
25+import Data.Generics.Internal.VL.Iso
26+import Data.Generics.Internal.VL.Prism
27+import Data.Generics.Internal.Profunctor.Lens
28+import Data.Generics.Internal.Profunctor.Iso
29+import Data.Generics.Internal.Profunctor.Prism
2530
2631data Animal = Animal
2732 { name :: String
generic-lens.cabal+19−31
@@ -29,30 +29,38 @@ library
2929 , Data.Generics.Product.Positions
3030 , Data.Generics.Product.Subtype
3131 , Data.Generics.Product.Typed
32− --, Data.Generics.Labels
32+ , Data.Generics.Product.Types
33+ , Data.Generics.Product.List
3334
3435 , Data.Generics.Sum
3536 , Data.Generics.Sum.Any
3637 , Data.Generics.Sum.Constructors
3738 , Data.Generics.Sum.Typed
3839 , Data.Generics.Sum.Subtype
39− , Data.Generics.Internal.Lens
40+ , Data.Generics.Internal.Profunctor.Lens
41+ , Data.Generics.Internal.Profunctor.Prism
42+ , Data.Generics.Internal.Profunctor.Iso
43+ , Data.Generics.Internal.VL.Lens
44+ , Data.Generics.Internal.VL.Traversal
45+ , Data.Generics.Internal.VL.Prism
46+ , Data.Generics.Internal.VL.Iso
4047
4148 other-modules: Data.Generics.Internal.Families
4249 , Data.Generics.Internal.Families.Changing
4350 , Data.Generics.Internal.Families.Collect
4451 , Data.Generics.Internal.Families.Has
45− , Data.Generics.Internal.HList
4652 , Data.Generics.Internal.Void
4753
4854 , Data.Generics.Sum.Internal.Constructors
4955 , Data.Generics.Sum.Internal.Typed
5056 , Data.Generics.Sum.Internal.Subtype
5157
52− , Data.Generics.Product.Internal.Fields
5358 , Data.Generics.Product.Internal.Positions
5459 , Data.Generics.Product.Internal.Subtype
55− , Data.Generics.Product.Internal.Typed
60+
61+ , Data.Generics.Product.Internal.Types
62+ , Data.Generics.Product.Internal.List
63+ , Data.Generics.Product.Internal.Keyed
5664
5765 build-depends: base >= 4.9 && <= 5.0
5866 , profunctors >= 5.0 && <= 6.0
@@ -65,7 +73,6 @@ library
6573 build-depends: dump-core
6674 ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
6775
68−
6976source-repository head
7077 type: git
7178 location: https://github.com/kcsongor/generic-lens
@@ -74,10 +81,14 @@ test-suite generic-lens-test
7481 type: exitcode-stdio-1.0
7582 hs-source-dirs: test
7683 main-is: Spec.hs
84+ other-modules: Util Test24 Test25
7785
7886 build-depends: base >= 4.9 && <= 5.0
7987 , generic-lens
80− , inspection-testing >= 0.1
88+ , lens
89+ , profunctors
90+ , inspection-testing >= 0.2
91+ , HUnit
8192
8293 default-language: Haskell2010
8394 ghc-options: -Wall
@@ -85,30 +96,6 @@ test-suite generic-lens-test
8596 build-depends: dump-core
8697 ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
8798
88−test-suite generic-lens-test-25
89− type: exitcode-stdio-1.0
90− hs-source-dirs: test
91− main-is: 25.hs
92−
93− build-depends: base >= 4.9 && <= 5.0
94− , generic-lens
95− , lens
96−
97− default-language: Haskell2010
98− ghc-options: -Wall
99−
100−test-suite generic-lens-test-24
101− type: exitcode-stdio-1.0
102− hs-source-dirs: test
103− main-is: 24.hs
104−
105− build-depends: base >= 4.9 && <= 5.0
106− , generic-lens
107− , lens
108−
109− default-language: Haskell2010
110− ghc-options: -Wall
111−
11299test-suite doctests
113100 default-language: Haskell2010
114101 type: exitcode-stdio-1.0
@@ -132,3 +119,4 @@ benchmark generic-lens-bench
132119
133120 default-language: Haskell2010
134121 ghc-options: -Wall
122+
src/Data/Generics/Internal/Families.hs+1−1
@@ -3,7 +3,6 @@
33{-# LANGUAGE FlexibleInstances #-}
44{-# LANGUAGE KindSignatures #-}
55{-# LANGUAGE MultiParamTypeClasses #-}
6−{-# LANGUAGE TypeApplications #-}
76{-# LANGUAGE TypeFamilies #-}
87{-# LANGUAGE TypeOperators #-}
98
@@ -28,6 +27,7 @@ import Data.Generics.Internal.Families.Changing as Families
2827
2928import GHC.TypeLits (ErrorMessage (..), Symbol)
3029
30+-- * Stuff
3131type family ShowSymbols (ctors :: [Symbol]) :: ErrorMessage where
3232 ShowSymbols '[]
3333 = 'Text ""
src/Data/Generics/Internal/Families/Collect.hs+3−2
@@ -28,7 +28,8 @@ import Data.Type.Equality (type (==))
2828import GHC.Generics
2929import GHC.TypeLits (Symbol, CmpSymbol)
3030
31−import Data.Generics.Internal.HList
31+import Data.Generics.Product.Internal.List (type (++))
32+import Data.Generics.Internal.Families.Has (GTypes)
3233
3334data TypeStat
3435 = TypeStat
@@ -83,7 +84,7 @@ type family CollectPartialType t f :: [Symbol] where
8384 CollectPartialType t (l :+: r)
8485 = CollectPartialType t l ++ CollectPartialType t r
8586 CollectPartialType t (C1 ('MetaCons ctor _ _) f)
86− = If (t == ListToTuple (GCollect f)) '[ctor] '[]
87+ = If (t == GTypes f) '[ctor] '[]
8788 CollectPartialType t (D1 _ f)
8889 = CollectPartialType t f
8990
src/Data/Generics/Internal/Families/Has.hs+21−8
@@ -17,8 +17,9 @@
1717module Data.Generics.Internal.Families.Has
1818 ( HasTotalFieldP
1919 , HasTotalTypeP
20− , HasPartialTypeTupleP
20+ , HasPartialTypeP
2121 , HasCtorP
22+ , GTypes
2223 ) where
2324
2425import Data.Type.Bool (type (||), type (&&))
@@ -26,7 +27,7 @@ import Data.Type.Equality (type (==))
2627import GHC.Generics
2728import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
2829
29−import Data.Generics.Internal.HList
30+import Data.Generics.Product.Internal.List
3031
3132type family HasTotalFieldP (field :: Symbol) f :: Bool where
3233 HasTotalFieldP field (S1 ('MetaSel ('Just field) _ _ _) _)
@@ -78,12 +79,14 @@ type family HasTotalTypeP a f :: Bool where
7879 ':<>: 'Text " is not a valid GHC.Generics representation type"
7980 )
8081
81−type family HasPartialTypeTupleP a f :: Bool where
82− HasPartialTypeTupleP t (l :+: r)
83− = HasPartialTypeTupleP t l || HasPartialTypeTupleP t r
84− HasPartialTypeTupleP t (C1 m f)
85− = t == ListToTuple (GCollect f)
86− HasPartialTypeTupleP t _
82+type family HasPartialTypeP a f :: Bool where
83+ HasPartialTypeP t (l :+: r)
84+ = HasPartialTypeP t l || HasPartialTypeP t r
85+ HasPartialTypeP t (C1 m f)
86+ = t == GTypes f
87+ HasPartialTypeP t (M1 _ _ f)
88+ = HasPartialTypeP t f
89+ HasPartialTypeP t _
8790 = 'False
8891
8992type family HasCtorP (ctor :: Symbol) f :: Bool where
@@ -95,3 +98,13 @@ type family HasCtorP (ctor :: Symbol) f :: Bool where
9598 = HasCtorP ctor f
9699 HasCtorP ctor _
97100 = 'False
101+
102+type family GTypes (rep :: * -> *) :: [((), *)] where
103+ GTypes (l :*: r)
104+ = GTypes l ++ GTypes r
105+ GTypes (Rec0 a)
106+ = '[ '( '(), a)]
107+ GTypes (M1 _ m a)
108+ = GTypes a
109+ GTypes U1 = '[]
110+
src/Data/Generics/Internal/HList.hsdeleted−239
@@ -1,239 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE FunctionalDependencies #-}
4−{-# LANGUAGE GADTs #-}
5−{-# LANGUAGE KindSignatures #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE PolyKinds #-}
8−{-# LANGUAGE ScopedTypeVariables #-}
9−{-# LANGUAGE TypeFamilies #-}
10−{-# LANGUAGE TypeOperators #-}
11−{-# LANGUAGE UndecidableInstances #-}
12−
13−-----------------------------------------------------------------------------
14−-- |
15−-- Module : Data.Generics.Internal.HList
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−-----------------------------------------------------------------------------
23−module Data.Generics.Internal.HList
24− ( type (++)
25−
26− , ListTuple (..)
27−
28− , GCollectible (..)
29− ) where
30−
31−import Data.Kind (Type)
32−import GHC.Generics
33−
34−data HList (xs :: [Type]) where
35− Nil :: HList '[]
36− (:>) :: x -> HList xs -> HList (x ': xs)
37−
38−infixr 5 :>
39−
40−type family ((as :: [k]) ++ (bs :: [k])) :: [k] where
41− '[] ++ bs = bs
42− (a ': as) ++ bs = a ': as ++ bs
43−
44−append :: HList as -> HList bs -> HList (as ++ bs)
45−append Nil ys = ys
46−append (x :> xs) ys = x :> append xs ys
47−
48−head' :: HList (a ': as) -> a
49−head' (x :> _) = x
50−
51−--------------------------------------------------------------------------------
52−-- * Split HList
53−
54−class Splittable (as :: [Type]) (bs :: [Type]) (cs :: [Type]) | as bs -> cs, as cs -> bs where
55− split :: HList cs -> (HList as, HList bs)
56−
57−instance Splittable '[] bs bs where
58− split bs = (Nil, bs)
59−
60−instance Splittable as bs cs => Splittable (a ': as) bs (a ': cs) where
61− split (a :> as)
62− = (a :> as', bs)
63− where (as', bs) = split as
64−
65−--------------------------------------------------------------------------------
66−-- * Convert tuples to/from HLists
67−
68−class ListTuple (tuple :: Type) (as :: [Type]) | as -> tuple where
69− type ListToTuple as :: Type
70− tupleToList :: tuple -> HList as
71− listToTuple :: HList as -> tuple
72−
73−instance ListTuple () '[] where
74− type ListToTuple '[] = ()
75− tupleToList _ = Nil
76− listToTuple _ = ()
77−
78−instance ListTuple a '[a] where
79− type ListToTuple '[a] = a
80− tupleToList a
81− = a :> Nil
82− listToTuple (a :> Nil)
83− = a
84−
85−instance ListTuple (a, b) '[a, b] where
86− type ListToTuple '[a, b] = (a, b)
87− tupleToList (a, b)
88− = a :> b :> Nil
89− listToTuple (a :> b :> Nil)
90− = (a, b)
91−
92−instance ListTuple (a, b, c) '[a, b, c] where
93− type ListToTuple '[a, b, c] = (a, b, c)
94− tupleToList (a, b, c)
95− = a :> b :> c :> Nil
96− listToTuple (a :> b :> c :> Nil)
97− = (a, b, c)
98−
99−instance ListTuple (a, b, c, d) '[a, b, c, d] where
100− type ListToTuple '[a, b, c, d] = (a, b, c, d)
101− tupleToList (a, b, c, d)
102− = a :> b :> c :> d:> Nil
103− listToTuple (a :> b :> c :> d :> Nil)
104− = (a, b, c, d)
105−
106−instance ListTuple (a, b, c, d, e) '[a, b, c, d, e] where
107− type ListToTuple '[a, b, c, d, e] = (a, b, c, d, e)
108− tupleToList (a, b, c, d, e)
109− = a :> b :> c :> d:> e :> Nil
110− listToTuple (a :> b :> c :> d :> e :> Nil)
111− = (a, b, c, d, e)
112−
113−instance ListTuple (a, b, c, d, e, f) '[a, b, c, d, e, f] where
114− type ListToTuple '[a, b, c, d, e, f] = (a, b, c, d, e, f)
115− tupleToList (a, b, c, d, e, f)
116− = a :> b :> c :> d:> e :> f :> Nil
117− listToTuple (a :> b :> c :> d :> e :> f :> Nil)
118− = (a, b, c, d, e, f)
119−
120−instance ListTuple (a, b, c, d, e, f, g) '[a, b, c, d, e, f, g] where
121− type ListToTuple '[a, b, c, d, e, f, g] = (a, b, c, d, e, f, g)
122− tupleToList (a, b, c, d, e, f, g)
123− = a :> b :> c :> d:> e :> f :> g :> Nil
124− listToTuple (a :> b :> c :> d :> e :> f :> g :> Nil)
125− = (a, b, c, d, e, f, g)
126−
127−instance ListTuple (a, b, c, d, e, f, g, h) '[a, b, c, d, e, f, g, h] where
128− type ListToTuple '[a, b, c, d, e, f, g, h] = (a, b, c, d, e, f, g, h)
129− tupleToList (a, b, c, d, e, f, g, h)
130− = a :> b :> c :> d:> e :> f :> g :> h :> Nil
131− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> Nil)
132− = (a, b, c, d, e, f, g, h)
133−
134−instance ListTuple (a, b, c, d, e, f, g, h, j) '[a, b, c, d, e, f, g, h, j] where
135− type ListToTuple '[a, b, c, d, e, f, g, h, j] = (a, b, c, d, e, f, g, h, j)
136− tupleToList (a, b, c, d, e, f, g, h, j)
137− = a :> b :> c :> d:> e :> f :> g :> h :> j :> Nil
138− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> Nil)
139− = (a, b, c, d, e, f, g, h, j)
140−
141−instance ListTuple (a, b, c, d, e, f, g, h, j, k) '[a, b, c, d, e, f, g, h, j, k] where
142− type ListToTuple '[a, b, c, d, e, f, g, h, j, k] = (a, b, c, d, e, f, g, h, j, k)
143− tupleToList (a, b, c, d, e, f, g, h, j, k)
144− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> Nil
145− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> Nil)
146− = (a, b, c, d, e, f, g, h, j, k)
147−
148−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l) '[a, b, c, d, e, f, g, h, j, k, l] where
149− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l] = (a, b, c, d, e, f, g, h, j, k, l)
150− tupleToList (a, b, c, d, e, f, g, h, j, k, l)
151− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> Nil
152− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> Nil)
153− = (a, b, c, d, e, f, g, h, j, k, l)
154−
155−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m) '[a, b, c, d, e, f, g, h, j, k, l, m] where
156− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m] = (a, b, c, d, e, f, g, h, j, k, l, m)
157− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m)
158− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> Nil
159− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> Nil)
160− = (a, b, c, d, e, f, g, h, j, k, l, m)
161−
162−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n) '[a, b, c, d, e, f, g, h, j, k, l, m, n] where
163− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n] = (a, b, c, d, e, f, g, h, j, k, l, m, n)
164− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n)
165− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil
166− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil)
167− = (a, b, c, d, e, f, g, h, j, k, l, m, n)
168−
169−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o] where
170− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
171− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
172− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil
173− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil)
174− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
175−
176−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p] where
177− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
178− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
179− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil
180− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil)
181− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
182−
183−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q] where
184− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
185− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
186− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil
187− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil)
188− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
189−
190−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r] where
191− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
192− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
193− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil
194− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil)
195− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
196−
197−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s] where
198− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
199− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
200− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil
201− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil)
202− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
203−
204−--------------------------------------------------------------------------------
205−
206−class GCollectible (f :: Type -> Type) (as :: [Type]) | f -> as where
207− type GCollect f :: [Type]
208− gtoCollection :: f x -> HList as
209− gfromCollection :: HList as -> f x
210−
211−instance
212− ( GCollectible l as
213− , GCollectible r bs
214− , cs ~ (as ++ bs)
215− , Splittable as bs cs
216− ) => GCollectible (l :*: r) cs where
217− type GCollect (l :*: r) = GCollect l ++ GCollect r
218−
219− gtoCollection (l :*: r)
220− = gtoCollection l `append` gtoCollection r
221−
222− gfromCollection cs
223− = gfromCollection as :*: gfromCollection bs
224− where (as, bs) = split cs
225−
226−instance GCollectible (Rec0 a) '[a] where
227− type GCollect (Rec0 a) = '[a]
228− gtoCollection = (:> Nil) . unK1
229− gfromCollection = K1 . head'
230−
231−instance GCollectible U1 '[] where
232− type GCollect U1 = '[]
233− gtoCollection U1 = Nil
234− gfromCollection Nil = U1
235−
236−instance GCollectible f as => GCollectible (M1 m meta f) as where
237− type GCollect (M1 m meta f) = GCollect f
238− gtoCollection = gtoCollection . unM1
239− gfromCollection = M1 . gfromCollection
src/Data/Generics/Internal/Lens.hsdeleted−143
@@ -1,143 +0,0 @@
1−{-# LANGUAGE LambdaCase #-}
2−{-# LANGUAGE GADTs #-}
3−{-# LANGUAGE Rank2Types #-}
4−{-# LANGUAGE TypeOperators #-}
5−
6−-----------------------------------------------------------------------------
7−-- |
8−-- Module : Data.Generics.Internal.Lens
9−-- Copyright : (C) 2017 Csongor Kiss
10−-- License : BSD3
11−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
12−-- Stability : experimental
13−-- Portability : non-portable
14−--
15−-- Internal lens helpers. Only exported for Haddock
16−--
17−-----------------------------------------------------------------------------
18−module Data.Generics.Internal.Lens where
19−
20−import Control.Applicative (Const(..))
21−import Data.Functor.Identity (Identity(..))
22−import Data.Monoid (First (..))
23−import Data.Profunctor (Choice(right'), Profunctor(dimap))
24−import Data.Profunctor.Unsafe ((#.), (.#))
25−import Data.Tagged
26−import GHC.Generics ((:*:)(..), (:+:)(..), Generic(..), M1(..), Rep)
27−
28−-- | Type alias for lens
29−type Lens' s a
30− = Lens s s a a
31−
32−type Lens s t a b
33− = forall f. Functor f => (a -> f b) -> s -> f t
34−
35−-- | Type alias for prism
36−type Prism s t a b
37− = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)
38−
39−type Prism' s a
40− = Prism s s a a
41−
42−type Iso' s a
43− = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s)
44−
45−type Iso s t a b
46− = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
47−
48−-- | Getting
49−(^.) :: s -> ((a -> Const a a) -> s -> Const a s) -> a
50−s ^. l = getConst (l Const s)
51−infixl 8 ^.
52−
53−-- | Setting
54−set :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t
55−set l b
56− = runIdentity . l (\_ -> Identity b)
57−
58−infixr 4 .~
59−(.~) :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t
60−(.~) = set
61−
62−infixl 8 ^?
63−(^?) :: s -> ((a -> Const (First a) a) -> s -> Const (First a) s) -> Maybe a
64−s ^? l = getFirst (fmof l (First #. Just) s)
65− where fmof l' f = getConst #. l' (Const #. f)
66−
67−infixr 8 #
68−(#) :: (Tagged b (Identity b) -> Tagged t (Identity t)) -> b -> t
69−(#) p = runIdentity #. unTagged #. p .# Tagged .# Identity
70−
71−-- | Lens focusing on the first element of a product
72−first :: Lens ((a :*: b) x) ((a' :*: b) x) (a x) (a' x)
73−first f (a :*: b)
74− = fmap (:*: b) (f a)
75−
76−-- | Lens focusing on the second element of a product
77−second :: Lens ((a :*: b) x) ((a :*: b') x) (b x) (b' x)
78−second f (a :*: b)
79− = fmap (a :*:) (f b)
80−
81−left :: Prism ((a :+: c) x) ((b :+: c) x) (a x) (b x)
82−left = prism L1 $ gsum Right (Left . R1)
83−
84−right :: Prism ((a :+: b) x) ((a :+: c) x) (b x) (c x)
85−right = prism R1 $ gsum (Left . L1) Right
86−
87−gsum :: (a x -> c) -> (b x -> c) -> ((a :+: b) x) -> c
88−gsum f _ (L1 x) = f x
89−gsum _ g (R1 y) = g y
90−
91−combine :: Lens' (s x) a -> Lens' (t x) a -> Lens' ((s :+: t) x) a
92−combine sa _ f (L1 s) = fmap (\a -> L1 (set sa a s)) (f (s ^. sa))
93−combine _ ta f (R1 t) = fmap (\a -> R1 (set ta a t)) (f (t ^. ta))
94−
95−prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
96−prism bt seta = dimap seta (either pure (fmap bt)) . right'
97−
98−-- | A type and its generic representation are isomorphic
99−repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
100−repIso = dimap from (fmap to)
101−
102−-- | 'M1' is just a wrapper around `f p`
103−--mIso :: Iso' (M1 i c f p) (f p)
104−mIso :: Iso (M1 i c f p) (M1 i c g p) (f p) (g p)
105−mIso = dimap unM1 (fmap M1)
106−
107−-- These are specialised versions of the Isos above. On GHC 8.0.2, having
108−-- these functions eta-expanded allows the optimiser to inline these functions.
109−mLens :: Lens (M1 i c f p) (M1 i c g p) (f p) (g p)
110−mLens f s = mIso f s
111−
112−repLens :: (Generic a, Generic b) => Lens a b (Rep a x) (Rep b x)
113−repLens f s = repIso f s
114−
115−sumIso :: Iso' ((a :+: b) x) (Either (a x) (b x))
116−sumIso = dimap f (fmap t)
117− where f (L1 x) = Left x
118− f (R1 x) = Right x
119− t (Left x) = L1 x
120− t (Right x) = R1 x
121−
122−_Left :: Prism' (Either a c) a
123−_Left = prism Left $ either Right (Left . Right)
124−
125−_Right :: Prism' (Either c a) a
126−_Right = prism Right $ either (Left . Left) Right
127−
128−--------------------------------------------------------------------------------
129−
130−data Coyoneda f b = forall a. Coyoneda (a -> b) (f a)
131−
132−instance Functor (Coyoneda f) where
133− fmap f (Coyoneda g fa)
134− = Coyoneda (f . g) fa
135−
136−inj :: Functor f => Coyoneda f a -> f a
137−inj (Coyoneda f a) = fmap f a
138−
139−proj :: Functor f => f a -> Coyoneda f a
140−proj fa = Coyoneda id fa
141−
142−ravel :: Functor f => ((a -> Coyoneda f b) -> s -> Coyoneda f t) -> (a -> f b) -> (s -> f t)
143−ravel coy f s = inj $ coy (\a -> proj (f a)) s
src/Data/Generics/Internal/Profunctor/Iso.hsnew file+98
@@ -0,0 +1,98 @@
1+{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE NoMonomorphismRestriction #-}
3+{-# LANGUAGE Rank2Types #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE TypeFamilies #-}
6+{-# LANGUAGE TypeFamilyDependencies #-}
7+{-# LANGUAGE TypeOperators #-}
8+
9+-----------------------------------------------------------------------------
10+-- |
11+-- Module : Data.Generics.Internal.Profunctor.Iso
12+-- Copyright : (C) 2017 Csongor Kiss
13+-- License : BSD3
14+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
15+-- Stability : experimental
16+-- Portability : non-portable
17+--
18+-- Internal lens helpers. Only exported for Haddock
19+--
20+-----------------------------------------------------------------------------
21+module Data.Generics.Internal.Profunctor.Iso where
22+
23+import Data.Profunctor (Profunctor(..))
24+import Data.Profunctor.Unsafe ((#.), (.#))
25+import GHC.Generics ((:*:)(..), (:+:)(..), Generic(..), M1(..), K1(..), Rep)
26+import Data.Coerce
27+
28+type Iso s t a b
29+ = forall p. (Profunctor p) => p a b -> p s t
30+
31+type Iso' s a = Iso s s a a
32+
33+-- | A type and its generic representation are isomorphic
34+repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
35+repIso = iso from to
36+
37+-- | 'M1' is just a wrapper around `f p`
38+--mIso :: Iso' (M1 i c f p) (f p)
39+mIso :: Iso (M1 i c f p) (M1 i c g p) (f p) (g p)
40+mIso = iso unM1 M1
41+{-# INLINE mIso #-}
42+
43+kIso :: Iso (K1 r a p) (K1 r b p) a b
44+kIso = iso unK1 K1
45+{-# INLINE kIso #-}
46+
47+sumIso :: Iso ((a :+: b) x) ((a' :+: b') x) (Either (a x) (b x)) (Either (a' x) (b' x))
48+sumIso = iso back forth
49+ where forth (Left l) = L1 l
50+ forth (Right r) = R1 r
51+ back (L1 l) = Left l
52+ back (R1 r) = Right r
53+{-# INLINE sumIso #-}
54+
55+prodIso :: Iso ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
56+prodIso = iso (\(a :*: b) -> (a, b)) (\(a, b) -> (a :*: b))
57+
58+assoc3 :: Iso ((a, b), c) ((a', b'), c') (a, (b, c)) (a', (b', c'))
59+assoc3 = iso (\((a, b), c) -> (a, (b, c))) (\(a, (b, c)) -> ((a, b), c))
60+
61+--------------------------------------------------------------------------------
62+-- Iso stuff
63+
64+fromIso :: Iso s t a b -> Iso b a t s
65+fromIso l = withIso l $ \ sa bt -> iso bt sa
66+{-# INLINE fromIso #-}
67+
68+iso :: (s -> a) -> (b -> t) -> Iso s t a b
69+iso = dimap
70+{-# INLINE iso #-}
71+
72+withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
73+withIso ai k = case ai (Exchange id id) of
74+ Exchange sa bt -> k sa bt
75+
76+pairing :: Iso s t a b -> Iso s' t' a' b' -> Iso (s, s') (t, t') (a, a') (b, b')
77+pairing f g = withIso f $ \ sa bt -> withIso g $ \s'a' b't' ->
78+ iso (bmap sa s'a') (bmap bt b't')
79+ where bmap f' g' (a, b) = (f' a, g' b)
80+
81+data Exchange a b s t = Exchange (s -> a) (b -> t)
82+
83+instance Functor (Exchange a b s) where
84+ fmap f (Exchange sa bt) = Exchange sa (f . bt)
85+ {-# INLINE fmap #-}
86+
87+instance Profunctor (Exchange a b) where
88+ dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt)
89+ {-# INLINE dimap #-}
90+ lmap f (Exchange sa bt) = Exchange (sa . f) bt
91+ {-# INLINE lmap #-}
92+ rmap f (Exchange sa bt) = Exchange sa (f . bt)
93+ {-# INLINE rmap #-}
94+ ( #. ) _ = coerce
95+ {-# INLINE ( #. ) #-}
96+ ( .# ) p _ = coerce p
97+ {-# INLINE ( .# ) #-}
98+
src/Data/Generics/Internal/Profunctor/Lens.hsnew file+170
@@ -0,0 +1,170 @@
1+{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE NoMonomorphismRestriction #-}
3+{-# LANGUAGE Rank2Types #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE TupleSections #-}
6+{-# LANGUAGE TypeFamilies #-}
7+{-# LANGUAGE TypeFamilyDependencies #-}
8+{-# LANGUAGE TypeOperators #-}
9+
10+-----------------------------------------------------------------------------
11+-- |
12+-- Module : Data.Generics.Internal.Profunctor.Lens
13+-- Copyright : (C) 2017 Csongor Kiss
14+-- License : BSD3
15+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16+-- Stability : experimental
17+-- Portability : non-portable
18+--
19+-- Internal lens helpers. Only exported for Haddock
20+--
21+-----------------------------------------------------------------------------
22+module Data.Generics.Internal.Profunctor.Lens where
23+
24+import Data.Profunctor (Profunctor(..), Strong(..))
25+import Data.Bifunctor
26+import GHC.Generics
27+import Data.Generics.Internal.Profunctor.Iso
28+
29+type Lens s t a b
30+ = forall p . (Strong p) => p a b -> p s t
31+
32+type LensLike p s t a b
33+ = p a b -> p s t
34+
35+
36+ravel :: (ALens a b a b -> ALens a b s t) -> Lens s t a b
37+ravel l pab = conv (l idLens) pab
38+ where
39+ conv :: ALens a b s t -> Lens s t a b
40+ conv (ALens _get _set) = lens _get _set
41+
42+-- | Setting
43+set :: ((a -> b) -> s -> t) -> (s, b) -> t
44+set f (s, b)
45+ = f (const b) s
46+
47+view :: Lens s s a a -> s -> a
48+view l = withLensPrim l (\get _ -> snd . get)
49+
50+--withLens :: Lens s t a b -> ((s -> a) -> ((s, b) -> t) -> r) -> r
51+--ithLens l k =
52+-- case l idLens of
53+-- ALens _get _set -> k (snd . _get) (\(s, b) -> _set ((fst $ _get s), b))
54+
55+withLensPrim :: Lens s t a b -> (forall c . (s -> (c,a)) -> ((c, b) -> t) -> r) -> r
56+withLensPrim l k =
57+ case l idLens of
58+ ALens _get _set -> k _get _set
59+
60+idLens :: ALens a b a b
61+idLens = ALens (fork (const ()) id) snd
62+{-# INLINE idLens #-}
63+
64+-- | Lens focusing on the first element of a product
65+first :: Lens ((a :*: b) x) ((a' :*: b) x) (a x) (a' x)
66+first
67+ = lens (\(a :*: b) -> (b,a)) (\(b, a') -> a' :*: b)
68+
69+-- | Lens focusing on the second element of a product
70+second :: Lens ((a :*: b) x) ((a :*: b') x) (b x) (b' x)
71+second
72+ = lens (\(a :*: b) -> (a,b)) (\(a, b') -> a :*: b')
73+
74+fork :: (a -> b) -> (a -> c) -> a -> (b, c)
75+fork f g a = (f a, g a)
76+
77+swap :: (a, b) -> (b, a)
78+swap (a, b) = (b, a)
79+
80+cross :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
81+cross = bimap
82+
83+--------------------------------------------------------------------------------
84+
85+data Coyoneda f b = forall a. Coyoneda (a -> b) (f a)
86+
87+instance Functor (Coyoneda f) where
88+ fmap f (Coyoneda g fa)
89+ = Coyoneda (f . g) fa
90+
91+inj :: Functor f => Coyoneda f a -> f a
92+inj (Coyoneda f a) = fmap f a
93+
94+proj :: Functor f => f a -> Coyoneda f a
95+proj fa = Coyoneda id fa
96+
97+newtype Alongside p s t a b = Alongside { getAlongside :: p (s, a) (t, b) }
98+
99+instance Profunctor p => Profunctor (Alongside p c d) where
100+ dimap f g (Alongside pab) = Alongside $ dimap (fmap f) (fmap g) pab
101+
102+instance Strong p => Strong (Alongside p c d) where
103+ second' (Alongside pab) = Alongside . dimap shuffle shuffle . second' $ pab
104+ where
105+ shuffle (x,(y,z)) = (y,(x,z))
106+
107+(??) :: Functor f => f (a -> b) -> a -> f b
108+fab ?? a = fmap ($ a) fab
109+
110+-- Could implement this using primitives?
111+alongside :: Profunctor p =>
112+ LensLike (Alongside p s' t') s t a b
113+ -> LensLike (Alongside p a b) s' t' a' b'
114+ -> LensLike p (s, s') (t, t') (a, a') (b, b')
115+alongside l1 l2
116+ = dimap swap swap . getAlongside . l1 . Alongside . dimap swap swap . getAlongside . l2 . Alongside
117+
118+assoc3L :: Lens ((a, b), c) ((a', b'), c') (a, (b, c)) (a', (b', c'))
119+assoc3L f = assoc3 f
120+
121+stron :: (Either s s', b) -> Either (s, b) (s', b)
122+stron (e, b) = bimap (,b) (, b) e
123+
124+choosing :: forall s t a b s' t' . Lens s t a b -> Lens s' t' a b -> Lens (Either s s') (Either t t') a b
125+choosing l r = withLensPrim l (\getl setl ->
126+ withLensPrim r (\getr setr ->
127+ let --g :: Either s s' -> a
128+ g e = case e of
129+ Left v -> let (c, v') = getl v in (Left c, v')
130+ Right v -> let (c, v') = getr v in (Right c, v')
131+ s = bimap setl setr . stron
132+ in lens g s))
133+
134+lens :: (s -> (c,a)) -> ((c,b) -> t) -> Lens s t a b
135+lens get _set = dimap get _set . second'
136+{-# INLINE lens #-}
137+
138+------------------------------------------------------------------------------
139+
140+data ALens a b s t = forall c . ALens (s -> (c,a)) ((c, b) -> t)
141+
142+instance Functor (ALens a b s) where
143+ fmap f (ALens _get _set) = ALens _get (f . _set)
144+
145+instance Profunctor (ALens a b) where
146+ dimap f g (ALens get _set) = ALens (get . f) (g . _set)
147+
148+instance Strong (ALens a b) where
149+ second' (ALens get _set) = ALens get' set' --(bimap id _set . assoc)
150+ where
151+ get' (c, a1) = let (c1, a) = get a1 in ((c, c1), a)
152+ set' ((c, c1), b) = (c, _set (c1, b))
153+ {-# INLINE second' #-}
154+
155+-- These are specialised versions of the Isos. On GHC 8.0.2, having
156+-- these functions eta-expanded allows the optimiser to inline these functions.
157+mLens :: Lens (M1 i c f p) (M1 i c g p) (f p) (g p)
158+mLens f = mIso f
159+
160+repLens :: (Generic a, Generic b) => Lens a b (Rep a x) (Rep b x)
161+repLens f = repIso f
162+
163+prodL :: Lens ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
164+prodL f = prodIso f
165+
166+prodR :: Lens (a' x, b' x) (a x, b x) ((a' :*: b') x) ((a :*: b) x)
167+prodR f = fromIso prodIso f
168+
169+assoc3R :: Lens (a', (b', c')) (a, (b, c)) ((a', b'), c') ((a, b), c)
170+assoc3R f = fromIso assoc3 f
src/Data/Generics/Internal/Profunctor/Prism.hsnew file+118
@@ -0,0 +1,118 @@
1+{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE LambdaCase #-}
3+{-# LANGUAGE NoMonomorphismRestriction #-}
4+{-# LANGUAGE Rank2Types #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TypeFamilies #-}
7+{-# LANGUAGE TypeFamilyDependencies #-}
8+{-# LANGUAGE TypeOperators #-}
9+
10+-----------------------------------------------------------------------------
11+-- |
12+-- Module : Data.Generics.Internal.Profunctor.Prism
13+-- Copyright : (C) 2017 Csongor Kiss
14+-- License : BSD3
15+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16+-- Stability : experimental
17+-- Portability : non-portable
18+--
19+-- Internal lens helpers. Only exported for Haddock
20+--
21+-----------------------------------------------------------------------------
22+module Data.Generics.Internal.Profunctor.Prism where
23+
24+import Data.Profunctor (Choice(..), Profunctor(..))
25+import Data.Tagged
26+import Data.Profunctor.Unsafe ((#.), (.#))
27+import GHC.Generics
28+import Data.Coerce
29+
30+type APrism s t a b = Market a b a b -> Market a b s t
31+
32+type Prism s t a b
33+ = forall p . (Choice p) => p a b -> p s t
34+
35+type Prism' s a = forall p . (Choice p) => p a a -> p s s
36+
37+left :: Prism ((a :+: c) x) ((b :+: c) x) (a x) (b x)
38+left = prism L1 $ gsum Right (Left . R1)
39+
40+right :: Prism ((a :+: b) x) ((a :+: c) x) (b x) (c x)
41+right = prism R1 $ gsum (Left . L1) Right
42+
43+prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
44+prism bt seta eta = dimap seta (either id bt) (right' eta)
45+
46+_Left :: Prism (Either a c) (Either b c) a b
47+_Left = prism Left $ either Right (Left . Right)
48+
49+_Right :: Prism (Either c a) (Either c b) a b
50+_Right = prism Right $ either (Left . Left) Right
51+
52+prismPRavel :: (Market a b a b -> Market a b s t) -> Prism s t a b
53+prismPRavel l pab = (prism2prismp $ l idPrism) pab
54+
55+build :: (Tagged b b -> Tagged t t) -> b -> t
56+build p = unTagged #. p .# Tagged
57+
58+match :: Prism s t a b -> s -> Either t a
59+match k = withPrism k $ \_ _match -> _match
60+
61+--------------------------------------------------------------------------------
62+-- Prism stuff
63+
64+without' :: Prism s t a b -> Prism s t c d -> Prism s t (Either a c) (Either b d)
65+without' k =
66+ withPrism k $ \bt _ k' ->
67+ withPrism k' $ \dt setc ->
68+ prism (foldEither bt dt) $ \s -> fmap Right (setc s)
69+ where foldEither _ g (Right r) = g r
70+ foldEither f _ (Left l) = f l
71+{-# INLINE without' #-}
72+
73+withPrism :: APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
74+withPrism k f = case k idPrism of
75+ Market bt seta -> f bt seta
76+
77+prism2prismp :: Market a b s t -> Prism s t a b
78+prism2prismp (Market bt seta) = prism bt seta
79+
80+idPrism :: Market a b a b
81+idPrism = Market id Right
82+
83+gsum :: (a x -> c) -> (b x -> c) -> ((a :+: b) x) -> c
84+gsum f _ (L1 x) = f x
85+gsum _ g (R1 y) = g y
86+
87+plus :: (a -> b) -> (c -> d) -> Either a c -> Either b d
88+plus f _ (Left x) = Left (f x)
89+plus _ g (Right y) = Right (g y)
90+
91+--------------------------------------------------------------------------------
92+-- Market
93+
94+data Market a b s t = Market (b -> t) (s -> Either t a)
95+
96+instance Functor (Market a b s) where
97+ fmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)
98+ {-# INLINE fmap #-}
99+
100+instance Profunctor (Market a b) where
101+ dimap f g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta . f)
102+ {-# INLINE dimap #-}
103+ lmap f (Market bt seta) = Market bt (seta . f)
104+ {-# INLINE lmap #-}
105+ rmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)
106+ {-# INLINE rmap #-}
107+ ( #. ) _ = coerce
108+ {-# INLINE ( #. ) #-}
109+ ( .# ) p _ = coerce p
110+ {-# INLINE ( .# ) #-}
111+
112+instance Choice (Market a b) where
113+ left' (Market bt seta) = Market (Left . bt) $ \case
114+ Left s -> case seta s of
115+ Left t -> Left (Left t)
116+ Right a -> Right a
117+ Right c -> Left (Right c)
118+ {-# INLINE left' #-}
src/Data/Generics/Internal/VL/Iso.hsnew file+45
@@ -0,0 +1,45 @@
1+{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE NoMonomorphismRestriction #-}
3+{-# LANGUAGE Rank2Types #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE TypeFamilies #-}
6+{-# LANGUAGE TypeFamilyDependencies #-}
7+{-# LANGUAGE TypeOperators #-}
8+
9+-----------------------------------------------------------------------------
10+-- |
11+-- Module : Data.Generics.Internal.VL.Iso
12+-- Copyright : (C) 2017 Csongor Kiss
13+-- License : BSD3
14+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
15+-- Stability : experimental
16+-- Portability : non-portable
17+--
18+-- Internal lens helpers. Only exported for Haddock
19+--
20+-----------------------------------------------------------------------------
21+module Data.Generics.Internal.VL.Iso where
22+
23+import Data.Profunctor (Profunctor(..))
24+import GHC.Generics
25+
26+type Iso' s a
27+ = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s)
28+
29+type Iso s t a b
30+ = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
31+
32+-- | A type and its generic representation are isomorphic
33+repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
34+repIso = iso from to
35+
36+-- | 'M1' is just a wrapper around `f p`
37+mIso :: Iso (M1 i c f p) (M1 i c g p) (f p) (g p)
38+mIso = iso unM1 M1
39+
40+prodIso :: Iso ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
41+prodIso = iso (\(a :*: b) -> (a, b)) (\(a, b) -> (a :*: b))
42+
43+iso :: (s -> a) -> (b -> t) -> Iso s t a b
44+iso sa bt = dimap sa (fmap bt)
45+{-# INLINE iso #-}
src/Data/Generics/Internal/VL/Lens.hsnew file+65
@@ -0,0 +1,65 @@
1+{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE NoMonomorphismRestriction #-}
3+{-# LANGUAGE Rank2Types #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE TypeFamilies #-}
6+{-# LANGUAGE TypeFamilyDependencies #-}
7+{-# LANGUAGE TypeOperators #-}
8+{-# LANGUAGE TupleSections #-}
9+
10+-----------------------------------------------------------------------------
11+-- |
12+-- Module : Data.Generics.Internal.VL.Lens
13+-- Copyright : (C) 2017 Csongor Kiss
14+-- License : BSD3
15+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16+-- Stability : experimental
17+-- Portability : non-portable
18+--
19+-- Internal lens helpers. Only exported for Haddock
20+--
21+-----------------------------------------------------------------------------
22+module Data.Generics.Internal.VL.Lens where
23+
24+import Control.Applicative (Const(..))
25+import Data.Functor.Identity (Identity(..))
26+import Data.Generics.Internal.Profunctor.Lens (ALens (..), idLens)
27+
28+-- | Type alias for lens
29+type Lens' s a
30+ = Lens s s a a
31+
32+type Lens s t a b
33+ = forall f. Functor f => (a -> f b) -> s -> f t
34+
35+view :: ((a -> Const a a) -> s -> Const a s) -> s -> a
36+view l s = (^.) s l
37+
38+-- | Getting
39+(^.) :: s -> ((a -> Const a a) -> s -> Const a s) -> a
40+s ^. l = getConst (l Const s)
41+infixl 8 ^.
42+
43+infixr 4 .~
44+(.~) :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t
45+(.~) f b = runIdentity . f (Identity . const b)
46+
47+set :: Lens s t a b -> b -> s -> t
48+set l x = l .~ x
49+
50+lens2lensvl :: ALens a b s t -> Lens s t a b
51+lens2lensvl (ALens _get _set) =
52+ \f x ->
53+ case _get x of
54+ (c, a) -> _set . (c, ) <$> f a
55+{-# INLINE lens2lensvl #-}
56+
57+ravel :: (ALens a b a b -> ALens a b s t)
58+ -> Lens s t a b
59+ravel l pab = (lens2lensvl $ l idLens) pab
60+
61+
62+lens :: (s -> a) -> ((s, b) -> t) -> Lens s t a b
63+lens get _set = \f x -> curry _set x <$> f (get x)
64+{-# INLINE[0] lens #-}
65+
src/Data/Generics/Internal/VL/Prism.hsnew file+73
@@ -0,0 +1,73 @@
1+{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE NoMonomorphismRestriction #-}
3+{-# LANGUAGE Rank2Types #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE TypeFamilies #-}
6+{-# LANGUAGE TypeFamilyDependencies #-}
7+{-# LANGUAGE TypeOperators #-}
8+
9+-----------------------------------------------------------------------------
10+-- |
11+-- Module : Data.Generics.Internal.VL.Prism
12+-- Copyright : (C) 2017 Csongor Kiss
13+-- License : BSD3
14+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
15+-- Stability : experimental
16+-- Portability : non-portable
17+--
18+-- Internal lens helpers. Only exported for Haddock
19+--
20+-----------------------------------------------------------------------------
21+module Data.Generics.Internal.VL.Prism where
22+
23+import Data.Functor.Identity (Identity(..))
24+import Data.Profunctor (Choice(..), Profunctor(..))
25+import Data.Coerce
26+import Data.Generics.Internal.Profunctor.Prism (Market (..), plus, idPrism)
27+import Data.Tagged
28+import Data.Profunctor.Unsafe ((#.), (.#))
29+import Data.Monoid (First (..))
30+import Control.Applicative (Const(..))
31+
32+-- | Type alias for prism
33+type Prism s t a b
34+ = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)
35+
36+type Prism' s a
37+ = Prism s s a a
38+
39+infixl 8 ^?
40+(^?) :: s -> ((a -> Const (First a) a) -> s -> Const (First a) s) -> Maybe a
41+s ^? l = getFirst (fmof l (First #. Just) s)
42+ where fmof l' f = getConst #. l' (Const #. f)
43+
44+
45+match :: Prism s t a b -> s -> Either t a
46+match k = withPrism k $ \_ _match -> _match
47+{-# INLINE match #-}
48+
49+(#) :: (Tagged b (Identity b) -> Tagged t (Identity t)) -> b -> t
50+(#) = build
51+{-# INLINE (#) #-}
52+
53+prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
54+prism bt seta eta = dimap (\x -> plus pure id (seta x)) (either id (\x -> fmap bt x)) (right' eta)
55+{-# INLINE prism #-}
56+
57+prismRavel :: (Market a b a b -> Market a b s t) -> Prism s t a b
58+prismRavel l pab = (prism2prismvl $ l idPrism) pab
59+{-# INLINE prismRavel #-}
60+
61+type APrismVL s t a b = Market a b a (Identity b) -> Market a b s (Identity t)
62+
63+withPrism :: APrismVL s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
64+withPrism k f = case coerce (k (Market Identity Right)) of
65+ Market bt seta -> f bt seta
66+
67+prism2prismvl :: Market a b s t -> Prism s t a b
68+prism2prismvl (Market bt seta) = prism bt seta
69+{-# INLINE prism2prismvl #-}
70+
71+build :: (Tagged b (Identity b) -> Tagged t (Identity t)) -> b -> t
72+build p = runIdentity #. unTagged #. p .# Tagged .# Identity
73+{-# INLINE build #-}
src/Data/Generics/Internal/VL/Traversal.hsnew file+72
@@ -0,0 +1,72 @@
1+{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE NoMonomorphismRestriction #-}
3+{-# LANGUAGE Rank2Types #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE TypeFamilies #-}
6+{-# LANGUAGE TypeFamilyDependencies #-}
7+{-# LANGUAGE TypeOperators #-}
8+
9+-----------------------------------------------------------------------------
10+-- |
11+-- Module : Data.Generics.Internal.VL.Traversal
12+-- Copyright : (C) 2017 Csongor Kiss
13+-- License : BSD3
14+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
15+-- Stability : experimental
16+-- Portability : non-portable
17+--
18+-- Internal lens helpers. Only exported for Haddock
19+--
20+-----------------------------------------------------------------------------
21+module Data.Generics.Internal.VL.Traversal where
22+
23+-- | Type alias for traversal
24+type Traversal' s a
25+ = forall f. Applicative f => (a -> f a) -> s -> f s
26+
27+type Traversal s t a b
28+ = forall f. Applicative f => (a -> f b) -> s -> f t
29+
30+confusing :: Applicative f => Traversal s t a b -> (a -> f b) -> s -> f t
31+confusing t = \f -> lowerYoneda . lowerCurried . t (liftCurriedYoneda . f)
32+ where
33+ liftCurriedYoneda :: Applicative f => f a -> Curried (Yoneda f) a
34+ liftCurriedYoneda fa = Curried (`yap` fa)
35+ {-# INLINE liftCurriedYoneda #-}
36+ yap :: Applicative f => Yoneda f (a -> b) -> f a -> Yoneda f b
37+ yap (Yoneda k) fa = Yoneda (\ab_r -> k (ab_r .) <*> fa)
38+ {-# INLINE yap #-}
39+{-# INLINE confusing #-}
40+
41+newtype Curried f a =
42+ Curried { runCurried :: forall r. f (a -> r) -> f r }
43+
44+instance Functor f => Functor (Curried f) where
45+ fmap f (Curried g) = Curried (g . fmap (.f))
46+ {-# INLINE fmap #-}
47+
48+instance (Functor f) => Applicative (Curried f) where
49+ pure a = Curried (fmap ($ a))
50+ {-# INLINE pure #-}
51+ Curried mf <*> Curried ma = Curried (ma . mf . fmap (.))
52+ {-# INLINE (<*>) #-}
53+
54+liftCurried :: Applicative f => f a -> Curried f a
55+liftCurried fa = Curried (<*> fa)
56+
57+lowerCurried :: Applicative f => Curried f a -> f a
58+lowerCurried (Curried f) = f (pure id)
59+newtype Yoneda f a = Yoneda { runYoneda :: forall b. (a -> b) -> f b }
60+
61+liftYoneda :: Functor f => f a -> Yoneda f a
62+liftYoneda a = Yoneda (\f -> fmap f a)
63+
64+lowerYoneda :: Yoneda f a -> f a
65+lowerYoneda (Yoneda f) = f id
66+
67+instance Functor (Yoneda f) where
68+ fmap f m = Yoneda (\k -> runYoneda m (k . f))
69+
70+instance Applicative f => Applicative (Yoneda f) where
71+ pure a = Yoneda (\f -> pure (f a))
72+ Yoneda m <*> Yoneda n = Yoneda (\f -> m (f .) <*> n id)
src/Data/Generics/Internal/Void.hs+1
@@ -1,3 +1,4 @@
1+{-# LANGUAGE PolyKinds #-}
12module Data.Generics.Internal.Void where
23
34{-
src/Data/Generics/Product.hs+4
@@ -22,6 +22,8 @@ module Data.Generics.Product
2222 , module Data.Generics.Product.Positions
2323 , module Data.Generics.Product.Subtype
2424 , module Data.Generics.Product.Typed
25+ , module Data.Generics.Product.Types
26+ , module Data.Generics.Product.List
2527 ) where
2628
2729import Data.Generics.Product.Any
@@ -29,3 +31,5 @@ import Data.Generics.Product.Fields
2931import Data.Generics.Product.Positions
3032import Data.Generics.Product.Subtype
3133import Data.Generics.Product.Typed
34+import Data.Generics.Product.Types
35+import Data.Generics.Product.List
src/Data/Generics/Product/Any.hs+2−2
@@ -29,7 +29,7 @@ module Data.Generics.Product.Any
2929 HasAny (..)
3030 ) where
3131
32−import Data.Generics.Internal.Lens
32+import Data.Generics.Internal.VL.Lens
3333import Data.Generics.Product.Fields
3434import Data.Generics.Product.Positions
3535import Data.Generics.Product.Typed
@@ -41,7 +41,7 @@ import Data.Generics.Product.Typed
4141-- >>> :set -XDataKinds
4242-- >>> :set -XDeriveGeneric
4343-- >>> import GHC.Generics
44−-- >>> :m +Data.Generics.Internal.Lens
44+-- >>> :m +Data.Generics.Internal.VL.Lens
4545-- >>> :{
4646-- data Human = Human
4747-- { name :: String
src/Data/Generics/Product/Fields.hs+14−13
@@ -38,13 +38,14 @@ module Data.Generics.Product.Fields
3838 ) where
3939
4040import Data.Generics.Internal.Families
41−import Data.Generics.Internal.Lens
41+import Data.Generics.Internal.VL.Lens as VL
4242import Data.Generics.Internal.Void
43−import Data.Generics.Product.Internal.Fields
43+import Data.Generics.Product.Internal.Keyed
4444
4545import Data.Kind (Constraint, Type)
4646import GHC.Generics
4747import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError)
48+import Data.Generics.Internal.Profunctor.Lens as P
4849
4950-- $setup
5051-- == /Running example:/
@@ -55,7 +56,7 @@ import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError)
5556-- >>> :set -XGADTs
5657-- >>> :set -XFlexibleContexts
5758-- >>> import GHC.Generics
58−-- >>> :m +Data.Generics.Internal.Lens
59+-- >>> :m +Data.Generics.Internal.VL.Lens
5960-- >>> :m +Data.Function
6061-- >>> :{
6162-- data Human a
@@ -76,7 +77,7 @@ import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError)
7677-- :}
7778
7879-- |Records that have a field with a given name.
79−class HasField (field :: Symbol) s t a b | s field -> a, s field b -> t, t field a -> s where
80+class HasField (field :: Symbol) s t a b | s field -> a, t field -> b, s field b -> t, t field a -> s where
8081 -- |A lens that focuses on a field with a given name. Compatible with the
8182 -- lens package's 'Control.Lens.Lens' type.
8283 --
@@ -108,21 +109,21 @@ class HasField (field :: Symbol) s t a b | s field -> a, s field b -> t, t field
108109 -- ... The offending constructors are:
109110 -- ... HumanNoAddress
110111 -- ...
111− field :: Lens s t a b
112+ field :: VL.Lens s t a b
112113
113114type HasField' field s a = HasField field s s a a
114115
115116-- |
116117-- >>> getField @"age" human
117118-- 50
118−getField :: forall f s a. HasField' f s a => s -> a
119−getField s = s ^. field @f
119+getField :: forall f a s. HasField' f s a => s -> a
120+getField = VL.view (field @f)
120121
121122-- |
122123-- >>> setField @"age" 60 human
123124-- Human {name = "Tunyasz", age = 60, address = "London", other = False}
124125setField :: forall f s a. HasField' f s a => a -> s -> s
125−setField = set (field @f)
126+setField = VL.set (field @f)
126127
127128instance -- see Note [Changing type parameters]
128129 ( Generic s
@@ -137,15 +138,15 @@ instance -- see Note [Changing type parameters]
137138#endif
138139 , Generic s'
139140 , Generic t'
140− , GHasField' field (Rep s) a
141− , GHasField' field (Rep s') a'
142− , GHasField' field (Rep t') b'
143− , GHasField field (Rep s) (Rep t) a b
141+ , GHasKey' field (Rep s) a
142+ , GHasKey' field (Rep s') a'
143+ , GHasKey' field (Rep t') b'
144+ , GHasKey field (Rep s) (Rep t) a b
144145 , t ~ Infer s a' b
145146 , s ~ Infer t b' a
146147 ) => HasField field s t a b where
147148
148− field f s = ravel (repLens . gfield @field) f s
149+ field f s = VL.ravel (repLens . gkey @field) f s
149150
150151-- -- See Note [Uncluttering type signatures]
151152instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where
src/Data/Generics/Product/Internal/Fields.hsdeleted−77
@@ -1,77 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE ConstraintKinds #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE FunctionalDependencies #-}
6−{-# LANGUAGE KindSignatures #-}
7−{-# LANGUAGE MultiParamTypeClasses #-}
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.Fields
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−-- Derive record field getters and setters generically.
25−--
26−-----------------------------------------------------------------------------
27−
28−module Data.Generics.Product.Internal.Fields
29− ( GHasField (..)
30− , GHasField'
31− ) where
32−
33−import Data.Generics.Internal.Families
34−import Data.Generics.Internal.Lens
35−
36−import Data.Kind (Type)
37−import GHC.Generics
38−import GHC.TypeLits (Symbol)
39−
40−-- |As 'HasField' but over generic representations as defined by
41−-- "GHC.Generics".
42−class GHasField (field :: Symbol) (s :: Type -> Type) (t :: Type -> Type) a b | s field -> a, t field -> b where
43− gfield :: Lens (s x) (t x) a b
44−
45−type GHasField' field s a = GHasField field s s a a
46−
47−instance GProductHasField field l r l' r' a b (HasTotalFieldP field l)
48− => GHasField field (l :*: r) (l' :*: r') a b where
49−
50− gfield = gproductField @field @_ @_ @_ @_ @_ @_ @(HasTotalFieldP field l)
51−
52−instance (GHasField' field r a, GHasField' field l a, GHasField field l l' a b, GHasField field r r' a b)
53− => GHasField field (l :+: r) (l' :+: r') a b where
54−
55− gfield f (L1 s) = fmap (\a -> L1 (set (gfield @field) a s)) (f (s ^. gfield @field))
56− gfield f (R1 t) = fmap (\a -> R1 (set (gfield @field) a t)) (f (t ^. gfield @field))
57−
58−instance GHasField field (K1 R a) (K1 R b) a b where
59− gfield f (K1 x) = fmap K1 (f x)
60−
61−instance GHasField field (S1 ('MetaSel ('Just field) upkd str infstr) (Rec0 a)) (S1 ('MetaSel ('Just field) upkd str infstr) (Rec0 b)) a b where
62− gfield = mLens . gfield @field
63−
64−instance (Functor g, GHasField field f g a b) => GHasField field (M1 D meta f) (M1 D meta g) a b where
65− gfield = mLens . gfield @field
66−
67−instance GHasField field f g a b => GHasField field (M1 C meta f) (M1 C meta g) a b where
68− gfield = mLens . gfield @field
69−
70−class GProductHasField (field :: Symbol) l r l' r' a b (left :: Bool) | field l r -> a, field l' r' -> b where
71− gproductField :: Lens ((l :*: r) x) ((l' :*: r') x) a b
72−
73−instance GHasField field l l' a b => GProductHasField field l r l' r a b 'True where
74− gproductField = first . gfield @field
75−
76−instance GHasField field r r' a b => GProductHasField field l r l r' a b 'False where
77− gproductField = second . gfield @field
src/Data/Generics/Product/Internal/Keyed.hsnew file+60
@@ -0,0 +1,60 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE ConstraintKinds #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE FunctionalDependencies #-}
6+{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeApplications #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeInType #-}
11+{-# LANGUAGE TypeOperators #-}
12+{-# LANGUAGE UndecidableInstances #-}
13+
14+#if __GLASGOW_HASKELL__ == 802
15+{-# OPTIONS_GHC -fno-solve-constant-dicts #-}
16+#endif
17+
18+--------------------------------------------------------------------------------
19+-- |
20+-- Module : Data.Generics.Product.Internal.Keyed
21+-- Copyright : (C) 2018 Csongor Kiss
22+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
23+-- License : BSD3
24+-- Stability : experimental
25+-- Portability : non-portable
26+--
27+--------------------------------------------------------------------------------
28+
29+module Data.Generics.Product.Internal.Keyed
30+ ( GHasKey (..)
31+ , GHasKey'
32+ ) where
33+
34+import Data.Generics.Product.Internal.List
35+import Data.Kind
36+import GHC.Generics
37+import Data.Generics.Internal.Profunctor.Lens
38+import Data.Generics.Internal.Profunctor.Iso
39+
40+class GHasKey (key :: k) (s :: Type -> Type) (t :: Type -> Type) a b | s key -> a, t key -> b where
41+ gkey :: Lens (s x) (t x) a b
42+
43+type GHasKey' key s a = GHasKey key s s a a
44+
45+instance (GHasKey key l l' a b, GHasKey key r r' a b) => GHasKey key (l :+: r) (l' :+: r') a b where
46+ gkey = sumIso . choosing (gkey @key) (gkey @key)
47+ {-# INLINE gkey #-}
48+
49+instance (GHasKey key f g a b) => GHasKey key (M1 D meta f) (M1 D meta g) a b where
50+ gkey = ravel (mLens . gkey @key)
51+ {-# INLINE gkey #-}
52+
53+instance
54+ ( Elem as key i a
55+ , Elem bs key i b
56+ , IndexList i as bs a b
57+ , GIsList k f g as bs
58+ ) => GHasKey (key :: k) (M1 C meta f) (M1 C meta g) a b where
59+ gkey = mLens . glist @k . point @i
60+ {-# INLINE gkey #-}
src/Data/Generics/Product/Internal/List.hsnew file+335
@@ -0,0 +1,335 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE ConstraintKinds #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE FunctionalDependencies #-}
6+{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TupleSections #-}
9+{-# LANGUAGE TypeApplications #-}
10+{-# LANGUAGE TypeFamilies #-}
11+{-# LANGUAGE TypeInType #-}
12+{-# LANGUAGE TypeOperators #-}
13+{-# LANGUAGE UndecidableInstances #-}
14+
15+#if __GLASGOW_HASKELL__ == 802
16+{-# OPTIONS_GHC -fno-solve-constant-dicts #-}
17+#endif
18+
19+
20+-----------------------------------------------------------------------------
21+-- |
22+-- Module : Data.Generics.Product.Internal.List
23+-- Copyright : (C) 2017 Csongor Kiss
24+-- License : BSD3
25+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
26+-- Stability : experimental
27+-- Portability : non-portable
28+--
29+-- Derive an isomorphism between a product type and a flat HList.
30+--
31+-----------------------------------------------------------------------------
32+
33+module Data.Generics.Product.Internal.List
34+ ( GIsList (..)
35+ , IndexList (..)
36+ , List (..)
37+ , type (++)
38+ , Elem
39+ , ListTuple (..)
40+ , TupleToList
41+ ) where
42+
43+import GHC.TypeLits
44+import Data.Semigroup
45+
46+import Data.Kind (Type)
47+import GHC.Generics
48+import Data.Profunctor
49+import Data.Generics.Internal.Profunctor.Lens
50+import Data.Generics.Internal.Profunctor.Iso
51+
52+data List (as :: [(m, Type)]) where
53+ Nil :: List '[]
54+ (:>) :: a -> List as -> List ('(s, a) ': as)
55+
56+infixr 5 :>
57+
58+type family ((as :: [k]) ++ (bs :: [k])) :: [k] where
59+ '[] ++ bs = bs
60+ (a ': as) ++ bs = a ': as ++ bs
61+
62+instance Semigroup (List '[]) where
63+ _ <> _ = Nil
64+
65+instance Monoid (List '[]) where
66+ mempty = Nil
67+ mappend _ _ = Nil
68+
69+instance (Semigroup a, Semigroup (List as)) => Semigroup (List ('(k, a) ': as)) where
70+ (x :> xs) <> (y :> ys) = (x <> y) :> (xs <> ys)
71+
72+instance (Monoid a, Monoid (List as)) => Monoid (List ('(k, a) ': as)) where
73+ mempty = mempty :> mempty
74+ mappend (x :> xs) (y :> ys) = mappend x y :> mappend xs ys
75+
76+class Elem (as :: [(k, Type)]) (key :: k) (i :: Nat) a | as key -> i a
77+instance {-# OVERLAPPING #-} pos ~ 0 => Elem ('(key, a) ': xs) key pos a
78+instance (Elem xs key i a, pos ~ (i + 1)) => Elem (x ': xs) key pos a
79+
80+class GIsList
81+ (m :: Type)
82+ (f :: Type -> Type)
83+ (g :: Type -> Type)
84+ (as :: [(m, Type)])
85+ (bs :: [(m, Type)]) | m f -> as, m g -> bs, bs f -> g, as g -> f where
86+
87+ glist :: Iso (f x) (g x) (List as) (List bs)
88+
89+ -- We define this reversed version, otherwise uses of `fromIso glist` are not
90+ -- properly inlined by GHC 8.0.2.
91+ -- This is not actually used.
92+ glistR :: Iso (List bs) (List as) (g x) (f x)
93+ glistR = fromIso (glist @m)
94+
95+instance
96+ ( GIsList m l l' as as'
97+ , GIsList m r r' bs bs'
98+ , Appending List as bs cs as' bs' cs'
99+ , cs ~ (as ++ bs)
100+ , cs' ~ (as' ++ bs')
101+ ) => GIsList m (l :*: r) (l' :*: r') cs cs' where
102+
103+ glist = prodIso . pairing (glist @m) (glist @m) . appending
104+ {-# INLINE glist #-}
105+
106+instance GIsList m f g as bs => GIsList m (M1 t meta f) (M1 t meta g) as bs where
107+ glist = mIso . glist @m
108+ {-# INLINE glist #-}
109+
110+instance {-# OVERLAPS #-}
111+ GIsList Symbol
112+ (S1 ('MetaSel ('Just field) u s i) (Rec0 a))
113+ (S1 ('MetaSel ('Just field) u s i) (Rec0 b))
114+ '[ '(field, a)] '[ '(field, b)] where
115+ glist = mIso . kIso . singleton
116+ {-# INLINE glist #-}
117+
118+instance GIsList Type (Rec0 a) (Rec0 a) '[ '(a, a)] '[ '(a, a)] where
119+ glist = kIso . singleton
120+ {-# INLINE glist #-}
121+
122+instance GIsList () (Rec0 a) (Rec0 b) '[ '( '(), a)] '[ '( '(), b)] where
123+ glist = kIso . singleton
124+ {-# INLINE glist #-}
125+
126+instance GIsList m U1 U1 '[] '[] where
127+ glist = iso (const Nil) (const U1)
128+ {-# INLINE glist #-}
129+
130+--------------------------------------------------------------------------------
131+-- | as ++ bs === cs
132+class Appending f (as :: [k]) bs cs (as' :: [k]) bs' cs' | as bs cs cs' -> as' bs', as' bs' cs cs' -> as bs, as bs -> cs, as' bs' -> cs' where
133+ appending :: Iso (f as, f bs) (f as', f bs') (f cs) (f cs')
134+
135+-- | [] ++ bs === bs
136+instance Appending List '[] bs bs '[] bs' bs' where
137+ appending = iso (\(_, b) -> b) (Nil,)
138+
139+-- | (a : as) ++ bs === (a : cs)
140+instance
141+ Appending List as bs cs as' bs' cs' -- as ++ bs == cs
142+ => Appending List ('(f, a) ': as) bs ('(f, a) ': cs) ('(f, a') ': as') bs' ('(f, a') ': cs') where
143+ appending
144+ = pairing (fromIso consing) id -- ((a, as), bs)
145+ . assoc3 -- (a, (as, bs))
146+ . pairing id appending -- (a, cs)
147+ . consing -- (a : cs)
148+
149+singleton :: Iso a b (List '[ '(field, a)]) (List '[ '(field, b)])
150+singleton = iso (:> Nil) (\(x :> _) -> x)
151+
152+consing :: Iso (a, List as) (b, List bs) (List ('(f, a) ': as)) (List ('(f, b) ': bs))
153+consing = iso (\(x, xs) -> x :> xs) (\(x :> xs) -> (x, xs))
154+
155+--------------------------------------------------------------------------------
156+class IndexList (i :: Nat) as bs a b | i as -> a, i bs -> b, i as b -> bs, i bs a -> as where
157+ point :: Lens (List as) (List bs) a b
158+
159+instance {-# OVERLAPPING #-}
160+ ( as ~ ('(f, a) ': as')
161+ , bs ~ ('(f, b) ': as')
162+ ) => IndexList 0 as bs a b where
163+ point = lens (\(x :> xs) -> (xs, x)) (\(xs, x') -> x' :> xs)
164+ {-# INLINE point #-}
165+
166+instance
167+ ( IndexList (n - 1) as' bs' a b
168+ , as ~ ('(f, x) ': as')
169+ , bs ~ ('(f, x) ': bs')
170+ ) => IndexList n as bs a b where
171+ point = fromIso consing . alongside id (point @(n-1)) . second'
172+ {-# INLINE point #-}
173+
174+--------------------------------------------------------------------------------
175+-- * Convert tuples to/from HLists
176+
177+class ListTuple (tuple :: Type) (as :: [(k, Type)]) | as -> tuple where
178+ type ListToTuple as :: Type
179+ tupled :: Iso' (List as) tuple
180+ tupled = iso listToTuple tupleToList
181+
182+ tupleToList :: tuple -> List as
183+ listToTuple :: List as -> tuple
184+
185+instance ListTuple () '[] where
186+ type ListToTuple '[] = ()
187+ tupleToList _ = Nil
188+ listToTuple _ = ()
189+
190+instance ListTuple a '[ '(fa, a)] where
191+ type ListToTuple '[ '(fa, a)] = a
192+ tupleToList a
193+ = a :> Nil
194+ listToTuple (a :> Nil)
195+ = a
196+
197+instance ListTuple (a, b) '[ '(fa, a), '(fb, b)] where
198+ type ListToTuple '[ '(fa, a), '(fb, b)] = (a, b)
199+ tupleToList (a, b)
200+ = a :> b :> Nil
201+ listToTuple (a :> b :> Nil)
202+ = (a, b)
203+
204+instance ListTuple (a, b, c) '[ '(fa, a), '(fb, b), '(fc, c)] where
205+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c)] = (a, b, c)
206+ tupleToList (a, b, c)
207+ = a :> b :> c :> Nil
208+ listToTuple (a :> b :> c :> Nil)
209+ = (a, b, c)
210+
211+instance ListTuple (a, b, c, d) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d)] where
212+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d)] = (a, b, c, d)
213+ tupleToList (a, b, c, d)
214+ = a :> b :> c :> d:> Nil
215+ listToTuple (a :> b :> c :> d :> Nil)
216+ = (a, b, c, d)
217+
218+instance ListTuple (a, b, c, d, e) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e)] where
219+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e)] = (a, b, c, d, e)
220+ tupleToList (a, b, c, d, e)
221+ = a :> b :> c :> d:> e :> Nil
222+ listToTuple (a :> b :> c :> d :> e :> Nil)
223+ = (a, b, c, d, e)
224+
225+instance ListTuple (a, b, c, d, e, f) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f)] where
226+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f)] = (a, b, c, d, e, f)
227+ tupleToList (a, b, c, d, e, f)
228+ = a :> b :> c :> d:> e :> f :> Nil
229+ listToTuple (a :> b :> c :> d :> e :> f :> Nil)
230+ = (a, b, c, d, e, f)
231+
232+instance ListTuple (a, b, c, d, e, f, g) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g)] where
233+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g)] = (a, b, c, d, e, f, g)
234+ tupleToList (a, b, c, d, e, f, g)
235+ = a :> b :> c :> d:> e :> f :> g :> Nil
236+ listToTuple (a :> b :> c :> d :> e :> f :> g :> Nil)
237+ = (a, b, c, d, e, f, g)
238+
239+instance ListTuple (a, b, c, d, e, f, g, h) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h)] where
240+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h)] = (a, b, c, d, e, f, g, h)
241+ tupleToList (a, b, c, d, e, f, g, h)
242+ = a :> b :> c :> d:> e :> f :> g :> h :> Nil
243+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> Nil)
244+ = (a, b, c, d, e, f, g, h)
245+
246+instance ListTuple (a, b, c, d, e, f, g, h, j) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j)] where
247+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j)] = (a, b, c, d, e, f, g, h, j)
248+ tupleToList (a, b, c, d, e, f, g, h, j)
249+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> Nil
250+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> Nil)
251+ = (a, b, c, d, e, f, g, h, j)
252+
253+instance ListTuple (a, b, c, d, e, f, g, h, j, k) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k)] where
254+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k)] = (a, b, c, d, e, f, g, h, j, k)
255+ tupleToList (a, b, c, d, e, f, g, h, j, k)
256+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> Nil
257+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> Nil)
258+ = (a, b, c, d, e, f, g, h, j, k)
259+
260+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l)] where
261+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l)] = (a, b, c, d, e, f, g, h, j, k, l)
262+ tupleToList (a, b, c, d, e, f, g, h, j, k, l)
263+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> Nil
264+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> Nil)
265+ = (a, b, c, d, e, f, g, h, j, k, l)
266+
267+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m)] where
268+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m)] = (a, b, c, d, e, f, g, h, j, k, l, m)
269+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m)
270+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> Nil
271+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> Nil)
272+ = (a, b, c, d, e, f, g, h, j, k, l, m)
273+
274+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n)] where
275+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n)] = (a, b, c, d, e, f, g, h, j, k, l, m, n)
276+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n)
277+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil
278+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil)
279+ = (a, b, c, d, e, f, g, h, j, k, l, m, n)
280+
281+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o)] where
282+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
283+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
284+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil
285+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil)
286+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
287+
288+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p)] where
289+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
290+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
291+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil
292+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil)
293+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
294+
295+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q)] where
296+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
297+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
298+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil
299+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil)
300+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
301+
302+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r)] where
303+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
304+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
305+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil
306+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil)
307+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
308+
309+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r), '(fs, s)] where
310+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r), '(fs, s)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
311+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
312+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil
313+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil)
314+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
315+
316+type family TupleToList a where
317+ TupleToList () = '[]
318+ TupleToList (a, b) = '[ '( '(), a), '( '(), b)]
319+ TupleToList (a, b, c) = '[ '( '(), a), '( '(), b), '( '(), c)]
320+ TupleToList (a, b, c, d) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d)]
321+ TupleToList (a, b, c, d, e) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e)]
322+ TupleToList (a, b, c, d, e, f) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f)]
323+ TupleToList (a, b, c, d, e, f, g) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g)]
324+ TupleToList (a, b, c, d, e, f, g, h) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h)]
325+ TupleToList (a, b, c, d, e, f, g, h, j) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j)]
326+ TupleToList (a, b, c, d, e, f, g, h, j, k) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k)]
327+ TupleToList (a, b, c, d, e, f, g, h, j, k, l) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l)]
328+ TupleToList (a, b, c, d, e, f, g, h, j, k, l, m) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m)]
329+ TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n)]
330+ TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o)]
331+ TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o), '( '(), p)]
332+ TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o), '( '(), p), '( '(), q)]
333+ TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o), '( '(), p), '( '(), q), '( '(), r)]
334+ TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o), '( '(), p), '( '(), q), '( '(), r), '( '(), s)]
335+ TupleToList a = '[ '( '(), a)]
src/Data/Generics/Product/Internal/Positions.hs+17−24
@@ -33,42 +33,35 @@ module Data.Generics.Product.Internal.Positions
3333 , Size
3434 ) where
3535
36−import Data.Generics.Internal.Lens
37−
36+import Data.Generics.Product.Internal.List
3837import Data.Kind (Type)
3938import Data.Type.Bool (If, Not)
4039import GHC.Generics
41−import GHC.TypeLits (type (<=?), type (+), Nat)
40+import GHC.TypeLits (type (<=?), type (+), type (-), Nat)
41+import Data.Generics.Internal.Profunctor.Lens
42+import Data.Generics.Internal.Profunctor.Iso
4243
4344-- |As 'HasPosition' but over generic representations as defined by
4445-- "GHC.Generics".
45−class GHasPosition (offset :: Nat) (i :: Nat) (s :: Type -> Type) (t :: Type -> Type) a b | s offset i -> a, s t offset i -> b where
46+class GHasPosition (i :: Nat) (s :: Type -> Type) (t :: Type -> Type) a b | s i -> a, t i -> b, s t i -> b where
4647 gposition :: Lens (s x) (t x) a b
4748
48−type GHasPosition' i s a = GHasPosition 1 i s s a a
49+type GHasPosition' i s a = GHasPosition i s s a a
4950
50−instance GHasPosition i i (K1 R a) (K1 R b) a b where
51− gposition f (K1 x) = fmap K1 (f x)
51+instance (GHasPosition i l l' a b, GHasPosition i r r' a b) => GHasPosition i (l :+: r) (l' :+: r') a b where
52+ gposition = \x -> sumIso (choosing (gposition @i) (gposition @i) x)
53+ {-# INLINE gposition #-}
5254
53−instance GHasPosition offset i s t a b => GHasPosition offset i (M1 m meta s) (M1 m meta t) a b where
54− gposition = mLens . gposition @offset @i
55+instance GHasPosition i s t a b => GHasPosition i (M1 D meta s) (M1 D meta t) a b where
56+ gposition x = mLens (gposition @i x)
57+ {-# INLINE gposition #-}
5558
5659instance
57− ( goLeft ~ (i <? (offset + Size l))
58− , offset' ~ (If goLeft offset (offset + Size l))
59− , GProductHasPosition offset' i l r l' r' a b goLeft
60− ) => GHasPosition offset i (l :*: r) (l' :*: r') a b where
61−
62− gposition = gproductPosition @offset' @i @_ @_ @_ @_ @_ @_ @goLeft
63−
64−class GProductHasPosition (offset :: Nat) (i :: Nat) l r l' r' a b (left :: Bool) | offset i l r -> a, offset i l r l' r' -> b where
65− gproductPosition :: Lens ((l :*: r) x) ((l' :*: r') x) a b
66−
67−instance GHasPosition offset i l l' a b => GProductHasPosition offset i l r l' r a b 'True where
68− gproductPosition = first . gposition @offset @i
69−
70−instance GHasPosition offset i r r' a b => GProductHasPosition offset i l r l r' a b 'False where
71− gproductPosition = second . gposition @offset @i
60+ ( IndexList (i - 1) as bs a b
61+ , GIsList () f g as bs
62+ ) => GHasPosition i (M1 C meta f) (M1 C meta g) a b where
63+ gposition x = mIso (glist @() (point @(i - 1) x))
64+ {-# INLINE gposition #-}
7265
7366type family Size f :: Nat where
7467 Size (l :*: r)
src/Data/Generics/Product/Internal/Subtype.hs+6−6
@@ -31,11 +31,11 @@ module Data.Generics.Product.Internal.Subtype
3131 ) where
3232
3333import Data.Generics.Internal.Families
34−import Data.Generics.Internal.Lens
35−import Data.Generics.Product.Internal.Fields
34+import Data.Generics.Product.Internal.Keyed
3635
3736import Data.Kind (Type)
3837import GHC.Generics
38+import Data.Generics.Internal.Profunctor.Lens
3939
4040--------------------------------------------------------------------------------
4141-- * Generic upcasting
@@ -47,10 +47,10 @@ instance (GUpcast sub a, GUpcast sub b) => GUpcast sub (a :*: b) where
4747 gupcast rep = gupcast rep :*: gupcast rep
4848
4949instance
50− GHasField field sub sub t t
50+ GHasKey field sub sub t t
5151 => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
5252
53− gupcast r = M1 (K1 (r ^. gfield @field))
53+ gupcast r = M1 (K1 (view (gkey @field) r))
5454
5555instance GUpcast sub sup => GUpcast sub (C1 c sup) where
5656 gupcast = M1 . gupcast
@@ -84,9 +84,9 @@ class GSmashLeaf sub sup (w :: Bool) where
8484 gsmashLeaf :: sup p -> sub p -> sub p
8585
8686instance
87− GHasField field sup sup t t
87+ GHasKey field sup sup t t
8888 => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'True where
89− gsmashLeaf sup _ = M1 (K1 (sup ^. gfield @field))
89+ gsmashLeaf sup _ = M1 (K1 (view (gkey @field) sup))
9090
9191instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'False where
9292 gsmashLeaf _ = id
src/Data/Generics/Product/Internal/Typed.hsdeleted−62
@@ -1,62 +0,0 @@
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 = mLens . 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/Internal/Types.hsnew file+59
@@ -0,0 +1,59 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE KindSignatures #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeFamilies #-}
9+{-# LANGUAGE TypeOperators #-}
10+{-# LANGUAGE UndecidableInstances #-}
11+
12+-----------------------------------------------------------------------------
13+-- |
14+-- Module : Data.Generics.Product.Internal.Types
15+-- Copyright : (C) 2017 Csongor Kiss
16+-- License : BSD3
17+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
18+-- Stability : experimental
19+-- Portability : non-portable
20+--
21+-- Derive traversals of a given type in a product.
22+--
23+-----------------------------------------------------------------------------
24+
25+module Data.Generics.Product.Internal.Types
26+ ( GHasTypes (..)
27+ ) where
28+
29+import Data.Kind (Type)
30+import GHC.Generics
31+
32+-- |As 'HasTypes' but over generic representations as defined by
33+-- "GHC.Generics".
34+class GHasTypes (f :: Type -> Type) a where
35+ gtypes :: forall g x. Applicative g => (a -> g a) -> f x -> g (f x)
36+
37+instance (GHasTypes l a, GHasTypes r a) => GHasTypes (l :*: r) a where
38+ gtypes f (l :*: r) = (:*:) <$> gtypes f l <*> gtypes f r
39+ {-# INLINE gtypes #-}
40+
41+instance (GHasTypes l a, GHasTypes r a) => GHasTypes (l :+: r) a where
42+ gtypes f (L1 l) = L1 <$> gtypes f l
43+ gtypes f (R1 r) = R1 <$> gtypes f r
44+
45+instance GHasTypes (K1 R a) a where
46+ gtypes f (K1 x) = fmap K1 (f x)
47+ {-# INLINE gtypes #-}
48+
49+instance {-# OVERLAPPABLE #-} GHasTypes (K1 R a) b where
50+ gtypes _ k = pure k
51+ {-# INLINE gtypes #-}
52+
53+instance GHasTypes f a => GHasTypes (M1 m meta f) a where
54+ gtypes f (M1 x) = M1 <$> gtypes f x
55+ {-# INLINE gtypes #-}
56+
57+instance GHasTypes U1 a where
58+ gtypes _ U1 = pure U1
59+ {-# INLINE gtypes #-}
src/Data/Generics/Product/List.hsnew file+78
@@ -0,0 +1,78 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE MonoLocalBinds #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE TypeApplications #-}
8+{-# LANGUAGE TypeInType #-}
9+{-# LANGUAGE UndecidableInstances #-}
10+
11+-----------------------------------------------------------------------------
12+-- |
13+-- Module : Data.Generics.Product.List
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+-- Derive an isomorphism between a product type and a flat HList.
21+--
22+-----------------------------------------------------------------------------
23+
24+module Data.Generics.Product.List
25+ ( IsList (..)
26+ , IsRecord
27+ , IsRecord'
28+ ) where
29+
30+import Data.Generics.Product.Internal.List
31+import Data.Kind
32+import GHC.Generics
33+import GHC.TypeLits
34+import Data.Generics.Internal.Profunctor.Iso
35+
36+class IsList
37+ (m :: Type)
38+ (f :: Type)
39+ (g :: Type)
40+ (as :: [(m, Type)])
41+ (bs :: [(m, Type)]) | m f -> as, m g -> bs where
42+ list :: Iso f g (List as) (List bs)
43+
44+instance
45+ ( Generic f
46+ , Generic g
47+ , GIsList m (Rep f) (Rep g) as bs
48+ ) => IsList m f g as bs where
49+ list = repIso . glist @m
50+ {-# INLINE list #-}
51+
52+class IsList Symbol f g as bs => IsRecord f g (as :: [(Symbol, Type)]) (bs :: [(Symbol, Type)]) | f -> as, g -> bs
53+instance IsList Symbol f g as bs => IsRecord f g as bs
54+
55+class IsRecord f f as as => IsRecord' f (as :: [(Symbol, Type)]) | f -> as
56+instance IsRecord f f as as => IsRecord' f as
57+
58+-- example (TODO: move elsewhere)
59+--class PrintRecord (rl :: [(Symbol, Type)]) where
60+-- printRecord' :: List rl -> String
61+--
62+--instance PrintRecord '[] where
63+-- printRecord' _ = ""
64+--
65+--instance (KnownSymbol field, Show a, PrintRecord xs) => PrintRecord ('(field, a) ': xs) where
66+-- printRecord' (x :> xs) = show x ++ ", " ++ printRecord' xs
67+--
68+--printRecord :: (IsRecord' rec rl, PrintRecord rl) => rec -> String
69+--printRecord rec = printRecord' (rec ^. list)
70+--
71+--data MyRecord = MyRecord
72+-- { field1 :: Int
73+-- , field2 :: String
74+-- , field3 :: Bool
75+-- } deriving Generic
76+--
77+-- >>> printRecord (MyRecord 10 "hello" False)
78+-- "10, \"hello\", False, "
src/Data/Generics/Product/Positions.hs+9−7
@@ -38,7 +38,7 @@ module Data.Generics.Product.Positions
3838 , setPosition
3939 ) where
4040
41−import Data.Generics.Internal.Lens
41+import Data.Generics.Internal.VL.Lens as VL
4242import Data.Generics.Internal.Void
4343import Data.Generics.Internal.Families
4444import Data.Generics.Product.Internal.Positions
@@ -47,6 +47,7 @@ import Data.Kind (Constraint, Type)
4747import Data.Type.Bool (type (&&))
4848import GHC.Generics
4949import GHC.TypeLits (type (<=?), Nat, TypeError, ErrorMessage(..))
50+import Data.Generics.Internal.Profunctor.Lens
5051
5152-- $setup
5253-- == /Running example:/
@@ -57,7 +58,7 @@ import GHC.TypeLits (type (<=?), Nat, TypeError, ErrorMessage(..))
5758-- >>> :set -XGADTs
5859-- >>> :set -XFlexibleContexts
5960-- >>> import GHC.Generics
60−-- >>> :m +Data.Generics.Internal.Lens
61+-- >>> :m +Data.Generics.Internal.VL.Lens
6162-- >>> :m +Data.Function
6263-- >>> :{
6364-- data Human = Human
@@ -71,7 +72,7 @@ import GHC.TypeLits (type (<=?), Nat, TypeError, ErrorMessage(..))
7172-- :}
7273
7374-- |Records that have a field at a given position.
74−class HasPosition (i :: Nat) s t a b | s i -> a, s i b -> t, t i a -> s where
75+class HasPosition (i :: Nat) s t a b | s i -> a, t i -> b, s i b -> t, t i a -> s where
7576 -- |A lens that focuses on a field at a given position. Compatible with the
7677 -- lens package's 'Control.Lens.Lens' type.
7778 --
@@ -86,7 +87,7 @@ class HasPosition (i :: Nat) s t a b | s i -> a, s i b -> t, t i a -> s where
8687 -- ...
8788 -- ... The type Human does not contain a field at position 4
8889 -- ...
89− position :: Lens s t a b
90+ position :: VL.Lens s t a b
9091
9192type HasPosition' i s a = HasPosition i s s a a
9293
@@ -94,7 +95,7 @@ getPosition :: forall i s a. HasPosition' i s a => s -> a
9495getPosition s = s ^. position @i
9596
9697setPosition :: forall i s a. HasPosition' i s a => a -> s -> s
97−setPosition = set (position @i)
98+setPosition = VL.set (position @i)
9899
99100instance -- see Note [Changing type parameters]
100101 ( Generic s
@@ -111,13 +112,14 @@ instance -- see Note [Changing type parameters]
111112 , Generic t'
112113 , GHasPosition' i (Rep s) a
113114 , GHasPosition' i (Rep s') a'
114− , GHasPosition 1 i (Rep s) (Rep t) a b
115+ , GHasPosition i (Rep s) (Rep t) a b
115116 , t ~ Infer s a' b
116117 , GHasPosition' i (Rep t') b'
117118 , s ~ Infer t b' a
118119 ) => HasPosition i s t a b where
119120
120− position f s = ravel (repLens . gposition @1 @i) f s
121+ position = VL.ravel (repLens . gposition @i)
122+ {-# INLINE position #-}
121123
122124-- See Note [Uncluttering type signatures]
123125instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where
src/Data/Generics/Product/Subtype.hs+7−6
@@ -33,13 +33,14 @@ module Data.Generics.Product.Subtype
3333 ) where
3434
3535import Data.Generics.Internal.Families
36−import Data.Generics.Internal.Lens
36+import Data.Generics.Internal.VL.Lens as VL
3737import Data.Generics.Internal.Void
3838import Data.Generics.Product.Internal.Subtype
3939
4040import GHC.Generics (Generic (Rep, to, from) )
4141import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
4242import Data.Kind (Type, Constraint)
43+import Data.Generics.Internal.Profunctor.Lens hiding (set)
4344
4445-- $setup
4546-- == /Running example:/
@@ -49,7 +50,7 @@ import Data.Kind (Type, Constraint)
4950-- >>> :set -XDeriveGeneric
5051-- >>> :set -XDuplicateRecordFields
5152-- >>> import GHC.Generics
52−-- >>> :m +Data.Generics.Internal.Lens
53+-- >>> :m +Data.Generics.Internal.VL.Lens
5354-- >>> :{
5455-- data Human = Human
5556-- { name :: String
@@ -80,9 +81,9 @@ class Subtype sup sub where
8081 --
8182 -- >>> set (super @Animal) (Animal "dog" 10) human
8283 -- Human {name = "dog", age = 10, address = "London"}
83− super :: Lens' sub sup
84− super f sub
85− = fmap (`smash` sub) (f (upcast sub))
84+ super :: VL.Lens sub sub sup sup
85+ super
86+ = VL.lens upcast (uncurry smash . swap)
8687
8788 -- |Cast the more specific subtype to the more general supertype
8889 --
@@ -103,7 +104,7 @@ class Subtype sup sub where
103104 -- >>> smash (Animal "dog" 10) human
104105 -- Human {name = "dog", age = 10, address = "London"}
105106 smash :: sup -> sub -> sub
106− smash = set (super @sup)
107+ smash = VL.set (super @sup)
107108
108109 {-# MINIMAL super | smash, upcast #-}
109110
src/Data/Generics/Product/Typed.hs+12−10
@@ -19,7 +19,7 @@
1919-- Stability : experimental
2020-- Portability : non-portable
2121--
22−-- Derive record field getters and setters generically.
22+-- Derive lenses of a given type in a product.
2323--
2424-----------------------------------------------------------------------------
2525
@@ -31,13 +31,14 @@ module Data.Generics.Product.Typed
3131 ) where
3232
3333import Data.Generics.Internal.Families
34−import Data.Generics.Internal.Lens
34+import Data.Generics.Internal.VL.Lens as VL
3535import Data.Generics.Internal.Void
36−import Data.Generics.Product.Internal.Typed
36+import Data.Generics.Product.Internal.Keyed
3737
3838import Data.Kind (Constraint, Type)
3939import GHC.Generics (Generic (Rep))
4040import GHC.TypeLits (TypeError, ErrorMessage (..))
41+import Data.Generics.Internal.Profunctor.Lens
4142
4243-- $setup
4344-- == /Running example:/
@@ -46,7 +47,7 @@ import GHC.TypeLits (TypeError, ErrorMessage (..))
4647-- >>> :set -XDataKinds
4748-- >>> :set -XDeriveGeneric
4849-- >>> import GHC.Generics
49−-- >>> :m +Data.Generics.Internal.Lens
50+-- >>> :m +Data.Generics.Internal.VL.Lens
5051-- >>> :{
5152-- data Human
5253-- = Human
@@ -91,9 +92,10 @@ class HasType a s where
9192 -- ... The offending constructors are:
9293 -- ... HumanNoTall
9394 -- ...
94− typed :: Lens' s a
95− typed f t
96− = fmap (flip (setTyped @a) t) (f (getTyped @a t))
95+ typed :: VL.Lens s s a a
96+ typed
97+ = VL.lens (getTyped @a) (uncurry (setTyped @a) . swap)
98+ {-# INLINE typed #-}
9799
98100 -- |Get field at type.
99101 getTyped :: s -> a
@@ -101,17 +103,17 @@ class HasType a s where
101103
102104 -- |Set field at type.
103105 setTyped :: a -> s -> s
104− setTyped = set (typed @a)
106+ setTyped = VL.set (typed @a)
105107
106108 {-# MINIMAL typed | setTyped, getTyped #-}
107109
108110instance
109111 ( Generic s
110112 , ErrorUnlessOne a s (CollectTotalType a (Rep s))
111− , GHasType (Rep s) a
113+ , GHasKey a (Rep s) (Rep s) a a
112114 ) => HasType a s where
113115
114− typed = ravel (repLens . gtyped)
116+ typed f s = VL.ravel (repLens . gkey @a) f s
115117
116118-- See Note [Uncluttering type signatures]
117119instance {-# OVERLAPPING #-} HasType a Void where
src/Data/Generics/Product/Types.hsnew file+46
@@ -0,0 +1,46 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE TypeFamilies #-}
8+{-# LANGUAGE TypeOperators #-}
9+{-# LANGUAGE UndecidableInstances #-}
10+
11+-----------------------------------------------------------------------------
12+-- |
13+-- Module : Data.Generics.Product.Types
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+-- Derive traversals of a given type in a product.
21+--
22+-----------------------------------------------------------------------------
23+
24+module Data.Generics.Product.Types
25+ ( -- *Traversals
26+ --
27+ -- $example
28+ HasTypes (..)
29+ ) where
30+
31+import Data.Generics.Product.Internal.Types
32+
33+import GHC.Generics (Generic (Rep), from, to)
34+import Data.Generics.Internal.VL.Traversal
35+
36+class HasTypes a s where
37+ types :: Traversal' s a
38+
39+instance
40+ ( Generic s
41+ , GHasTypes (Rep s) a
42+ ) => HasTypes a s where
43+
44+ types = confusing (\f s -> to <$> gtypes f (from s))
45+ {-# INLINE types #-}
46+
src/Data/Generics/Sum/Any.hs+3−3
@@ -28,9 +28,9 @@ module Data.Generics.Sum.Any
2828 AsAny (..)
2929 ) where
3030
31−import Data.Generics.Internal.Lens
3231import Data.Generics.Sum.Constructors
3332import Data.Generics.Sum.Typed
33+import Data.Generics.Internal.VL.Prism
3434
3535-- $setup
3636-- == /Running example:/
@@ -39,7 +39,7 @@ import Data.Generics.Sum.Typed
3939-- >>> :set -XDataKinds
4040-- >>> :set -XDeriveGeneric
4141-- >>> import GHC.Generics
42−-- >>> :m +Data.Generics.Internal.Lens
42+-- >>> :m +Data.Generics.Internal.VL.Prism
4343-- >>> :{
4444-- data Animal
4545-- = Dog Dog
@@ -86,7 +86,7 @@ class AsAny (sel :: k) a s | s sel k -> a where
8686 --
8787 -- >>> duck ^? _As @Age
8888 -- Just 2
89− _As :: Prism' s a
89+ _As :: Prism s s a a
9090
9191instance AsConstructor ctor s s a a => AsAny ctor a s where
9292 _As = _Ctor @ctor
src/Data/Generics/Sum/Constructors.hs+7−3
@@ -10,6 +10,7 @@
1010{-# LANGUAGE TypeFamilies #-}
1111{-# LANGUAGE TypeOperators #-}
1212{-# LANGUAGE UndecidableInstances #-}
13+{-# LANGUAGE FlexibleContexts #-}
1314
1415-----------------------------------------------------------------------------
1516-- |
@@ -32,13 +33,15 @@ module Data.Generics.Sum.Constructors
3233 ) where
3334
3435import Data.Generics.Internal.Families
35−import Data.Generics.Internal.Lens
3636import Data.Generics.Internal.Void
3737import Data.Generics.Sum.Internal.Constructors
3838
3939import Data.Kind (Constraint, Type)
4040import GHC.Generics (Generic (Rep))
4141import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
42+import Data.Generics.Internal.VL.Prism
43+import Data.Generics.Internal.Profunctor.Iso
44+import Data.Generics.Internal.Profunctor.Prism (prismPRavel)
4245
4346-- $setup
4447-- == /Running example:/
@@ -49,7 +52,7 @@ import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
4952-- >>> :set -XFlexibleContexts
5053-- >>> :set -XTypeFamilies
5154-- >>> import GHC.Generics
52−-- >>> :m +Data.Generics.Internal.Lens
55+-- >>> :m +Data.Generics.Internal.VL.Prism
5356-- >>> :m +Data.Generics.Product.Fields
5457-- >>> :m +Data.Function
5558-- >>> :{
@@ -120,7 +123,8 @@ instance
120123 , s ~ Infer t b' a
121124 ) => AsConstructor ctor s t a b where
122125
123− _Ctor = repIso . _GCtor @ctor
126+ _Ctor eta = prismRavel (prismPRavel (repIso . _GCtor @ctor)) eta
127+ {-# INLINE _Ctor #-}
124128
125129-- See Note [Uncluttering type signatures]
126130instance {-# OVERLAPPING #-} AsConstructor ctor (Void1 a) (Void1 b) a b where
src/Data/Generics/Sum/Internal/Constructors.hs+14−5
@@ -30,11 +30,14 @@ module Data.Generics.Sum.Internal.Constructors
3030 ) where
3131
3232import Data.Generics.Internal.Families
33−import Data.Generics.Internal.HList
34−import Data.Generics.Internal.Lens
33+import Data.Generics.Product.Internal.List
3534
3635import GHC.Generics
3736import GHC.TypeLits (Symbol)
37+import Data.Kind
38+import Data.Generics.Internal.Profunctor.Lens
39+import Data.Generics.Internal.Profunctor.Iso
40+import Data.Generics.Internal.Profunctor.Prism
3841
3942-- |As 'AsConstructor' but over generic representations as defined by
4043-- "GHC.Generics".
@@ -44,25 +47,31 @@ class GAsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where
4447type GAsConstructor' ctor s a = GAsConstructor ctor s s a a
4548
4649instance
47− ( GCollectible f as
48− , GCollectible g bs
50+ ( GIsList Type f f as as
51+ , GIsList Type g g bs bs
4952 , ListTuple a as
5053 , ListTuple b bs
5154 ) => GAsConstructor ctor (M1 C ('MetaCons ctor fixity fields) f) (M1 C ('MetaCons ctor fixity fields) g) a b where
5255
53− _GCtor = prism (M1 . gfromCollection . tupleToList) (Right . listToTuple . gtoCollection . unM1)
56+ _GCtor = prism (M1 . view (fromIso (glist @Type)) . tupleToList) (Right . listToTuple . view (glist @Type) . unM1)
57+ {-# INLINE _GCtor #-}
58+
5459
5560instance GSumAsConstructor ctor (HasCtorP ctor l) l r l' r' a b => GAsConstructor ctor (l :+: r) (l' :+: r') a b where
5661 _GCtor = _GSumCtor @ctor @(HasCtorP ctor l)
62+ {-# INLINE _GCtor #-}
5763
5864instance GAsConstructor ctor f f' a b => GAsConstructor ctor (M1 D meta f) (M1 D meta f') a b where
5965 _GCtor = mIso . _GCtor @ctor
66+ {-# INLINE _GCtor #-}
6067
6168class GSumAsConstructor (ctor :: Symbol) (contains :: Bool) l r l' r' a b | ctor l r -> a, ctor l' r' -> b where
6269 _GSumCtor :: Prism ((l :+: r) x) ((l' :+: r') x) a b
6370
6471instance GAsConstructor ctor l l' a b => GSumAsConstructor ctor 'True l r l' r a b where
6572 _GSumCtor = left . _GCtor @ctor
73+ {-# INLINE _GSumCtor #-}
6674
6775instance GAsConstructor ctor r r' a b => GSumAsConstructor ctor 'False l r l r' a b where
6876 _GSumCtor = right . _GCtor @ctor
77+ {-# INLINE _GSumCtor #-}
src/Data/Generics/Sum/Internal/Subtype.hs+69−35
@@ -1,7 +1,10 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE DataKinds #-}
13{-# LANGUAGE FlexibleContexts #-}
24{-# LANGUAGE FlexibleInstances #-}
35{-# LANGUAGE KindSignatures #-}
46{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE PolyKinds #-}
58{-# LANGUAGE ScopedTypeVariables #-}
69{-# LANGUAGE TypeApplications #-}
710{-# LANGUAGE TypeOperators #-}
@@ -25,50 +28,81 @@ module Data.Generics.Sum.Internal.Subtype
2528 ( GAsSubtype (..)
2629 ) where
2730
28−import Data.Generics.Internal.HList
31+import Data.Generics.Product.Internal.List
2932import Data.Generics.Sum.Internal.Typed
3033
3134import Data.Kind
3235import GHC.Generics
36+import Data.Generics.Internal.Profunctor.Iso
37+import Data.Generics.Internal.Profunctor.Prism
38+import Data.Generics.Internal.Families.Has
3339
3440-- |As 'AsSubtype' but over generic representations as defined by
3541-- "GHC.Generics".
3642class GAsSubtype (subf :: Type -> Type) (supf :: Type -> Type) where
37− ginjectSub :: subf x -> supf x
38− gprojectSub :: supf x -> Either (supf x) (subf x)
43+ _GSub :: Prism' (supf x) (subf x)
3944
4045instance
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)
46+ ( GSplash sub sup
47+ , GDowncast sub sup
48+ ) => GAsSubtype sub sup where
49+ _GSub f = (prism _GSplash _GDowncast) f
50+ {-# INLINE[0] _GSub #-}
51+
52+--------------------------------------------------------------------------------
53+
54+class GSplash (sub :: Type -> Type) (sup :: Type -> Type) where
55+ _GSplash :: sub x -> sup x
56+
57+instance (GSplash a sup, GSplash b sup) => GSplash (a :+: b) sup where
58+ _GSplash (L1 rep) = _GSplash rep
59+ _GSplash (R1 rep) = _GSplash rep
60+
61+instance
62+ ( GIsList () subf subf as as
63+ , GAsType supf as
64+ ) => GSplash (C1 meta subf) supf where
65+ _GSplash p = build ((_GTyped . fromIso (glist @()) . fromIso mIso)) p
66+
67+instance GSplash sub sup => GSplash (D1 c sub) sup where
68+ _GSplash (M1 m) = _GSplash m
69+
70+--------------------------------------------------------------------------------
71+
72+class GDowncast sub sup where
73+ _GDowncast :: sup x -> Either (sup x) (sub x)
5274
5375instance
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
76+ ( GIsList () sup sup as as
77+ , GDowncastC (HasPartialTypeP as sub) sub sup
78+ ) => GDowncast sub (C1 m sup) where
79+ _GDowncast (M1 m) = case _GDowncastC @(HasPartialTypeP as sub) m of
80+ Left _ -> Left (M1 m)
81+ Right r -> Right r
82+
83+instance (GDowncast sub l, GDowncast sub r) => GDowncast sub (l :+: r) where
84+ _GDowncast (L1 x) = case _GDowncast x of
85+ Left _ -> Left (L1 x)
86+ Right r -> Right r
87+ _GDowncast (R1 x) = case _GDowncast x of
88+ Left _ -> Left (R1 x)
89+ Right r -> Right r
90+
91+instance GDowncast sub sup => GDowncast sub (D1 m sup) where
92+ _GDowncast (M1 m) = case _GDowncast m of
93+ Left _ -> Left (M1 m)
94+ Right r -> Right r
95+
96+class GDowncastC (contains :: Bool) sub sup where
97+ _GDowncastC :: sup x -> Either (sup x) (sub x)
98+
99+instance GDowncastC 'False sub sup where
100+ _GDowncastC sup = Left sup
101+
102+instance
103+ ( GAsType sub subl
104+ , GIsList () sup sup subl subl
105+ ) => GDowncastC 'True sub sup where
106+ _GDowncastC sup = Right (build (_GTyped . fromIso (glist @())) sup)
107+ {-# INLINE _GDowncastC #-}
108+
src/Data/Generics/Sum/Internal/Typed.hs+32−53
@@ -1,14 +1,14 @@
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 #-}
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 #-}
1212
1313-----------------------------------------------------------------------------
1414-- |
@@ -29,60 +29,39 @@ module Data.Generics.Sum.Internal.Typed
2929
3030import Data.Kind
3131import GHC.Generics
32+import Data.Tagged
3233
3334import Data.Generics.Internal.Families
34−import Data.Generics.Internal.HList
35−import Data.Generics.Internal.Lens
35+import Data.Generics.Product.Internal.List
36+import Data.Generics.Internal.Profunctor.Iso
37+import Data.Generics.Internal.Profunctor.Prism
3638
3739-- |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
40+class GAsType (f :: Type -> Type) (as :: [((), Type)]) where
41+ _GTyped :: Prism (f x) (f x) (List as) (List as)
42+-- We create this specialised version as we use it in the subtype prism
43+-- If we don't create it, the opportunity for specialisation is only
44+-- created after specialisation happens, I think a late specialisation pass
45+-- would pick up this case.
46+{-# SPECIALISE _GTyped :: (Tagged b b -> Tagged t t) #-}
4147
42− ginjectTyped :: a -> f x
43− gprojectTyped :: f x -> Either (f x) a
4448
4549instance
46− ( GCollectible f as
47− , ListTuple a as
48− ) => GAsType (M1 C meta f) a where
50+ ( GIsList () f f as as
51+ ) => GAsType (M1 C meta f) as where
52+ _GTyped = mIso . glist @()
4953
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
54+instance GSumAsType (HasPartialTypeP a l) l r a => GAsType (l :+: r) a where
55+ _GTyped = _GSumTyped @(HasPartialTypeP a l)
6056
6157instance 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)
58+ _GTyped = mIso . _GTyped
7059
71− ginjectSumTyped :: a -> (l :+: r) x
72− gprojectSumTyped :: (l :+: r) x -> Either ((l :+: r) x) a
60+class GSumAsType (contains :: Bool) l r (a :: [((), Type)]) where
61+ _GSumTyped :: Prism ((l :+: r) x) ((l :+: r) x) (List a) (List a)
7362
7463instance 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
64+ _GSumTyped = left . _GTyped
8165
8266instance 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
67+ _GSumTyped = right . _GTyped
src/Data/Generics/Sum/Subtype.hs+11−6
@@ -1,7 +1,9 @@
11{-# LANGUAGE FlexibleContexts #-}
22{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE MonoLocalBinds #-}
34{-# LANGUAGE MultiParamTypeClasses #-}
45{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TypeApplications #-}
57{-# LANGUAGE TypeOperators #-}
68{-# LANGUAGE TypeSynonymInstances #-}
79{-# LANGUAGE UndecidableInstances #-}
@@ -26,11 +28,12 @@ module Data.Generics.Sum.Subtype
2628 AsSubtype (..)
2729 ) where
2830
29−import Data.Generics.Internal.Lens
3031import Data.Generics.Internal.Void
3132import Data.Generics.Sum.Internal.Subtype
3233
33−import GHC.Generics (Generic (Rep, to, from))
34+import GHC.Generics (Generic (Rep))
35+import Data.Generics.Internal.VL.Prism
36+import Data.Generics.Internal.Profunctor.Iso
3437
3538-- $setup
3639-- == /Running example:/
@@ -39,7 +42,7 @@ import GHC.Generics (Generic (Rep, to, from))
3942-- >>> :set -XDataKinds
4043-- >>> :set -XDeriveGeneric
4144-- >>> import GHC.Generics
42−-- >>> :m +Data.Generics.Internal.Lens
45+-- >>> :m +Data.Generics.Internal.VL.Prism
4346-- >>> :{
4447-- data Animal
4548-- = Dog Dog
@@ -90,11 +93,13 @@ class AsSubtype sub sup where
9093
9194 -- |Injects a subtype into a supertype (upcast).
9295 injectSub :: sub -> sup
96+ injectSub = build (_Sub @sub @sup)
9397
9498 -- |Projects a subtype from a supertype (downcast).
9599 projectSub :: sup -> Either sup sub
100+ projectSub = match (_Sub @sub @sup)
96101
97− {-# MINIMAL injectSub, projectSub #-}
102+ {-# MINIMAL (injectSub, projectSub) | _Sub #-}
98103
99104instance
100105 ( Generic sub
@@ -102,8 +107,8 @@ instance
102107 , GAsSubtype (Rep sub) (Rep sup)
103108 ) => AsSubtype sub sup where
104109
105− injectSub = to . ginjectSub . from
106− projectSub = either (Left . to) (Right . to) . gprojectSub . from
110+ _Sub f = prismRavel (repIso . _GSub . fromIso repIso) f
111+ {-# INLINE[2] _Sub #-}
107112
108113-- See Note [Uncluttering type signatures]
109114instance {-# OVERLAPPING #-} AsSubtype a Void where
src/Data/Generics/Sum/Typed.hs+16−10
@@ -1,3 +1,4 @@
1+{-# LANGUAGE TypeApplications #-}
12{-# LANGUAGE AllowAmbiguousTypes #-}
23{-# LANGUAGE DataKinds #-}
34{-# LANGUAGE FlexibleContexts #-}
@@ -35,15 +36,18 @@ import GHC.TypeLits (TypeError, ErrorMessage (..), Symbol)
3536import Data.Generics.Sum.Internal.Typed
3637
3738import Data.Generics.Internal.Families
38−import Data.Generics.Internal.Lens
3939import Data.Generics.Internal.Void
40+import Data.Generics.Product.Internal.List
41+import Data.Generics.Internal.VL.Prism
42+import Data.Generics.Internal.Profunctor.Iso
43+import Data.Generics.Internal.Profunctor.Prism (prismPRavel)
4044
4145-- $setup
4246-- >>> :set -XTypeApplications
4347-- >>> :set -XDataKinds
4448-- >>> :set -XDeriveGeneric
4549-- >>> import GHC.Generics
46−-- >>> :m +Data.Generics.Internal.Lens
50+-- >>> :m +Data.Generics.Internal.VL.Prism
4751-- >>> :{
4852-- data Animal
4953-- = Dog Dog
@@ -87,22 +91,24 @@ class AsType a s where
8791
8892 -- |Inject by type.
8993 injectTyped :: a -> s
94+ injectTyped
95+ = build _Typed
9096
9197 -- |Project by type.
9298 projectTyped :: s -> Maybe a
99+ projectTyped
100+ = either (const Nothing) Just . match _Typed
93101
94102instance
95103 ( Generic s
96− , ErrorUnlessOne a s (CollectPartialType a (Rep s))
97− , GAsType (Rep s) a
104+ , ErrorUnlessOne a s (CollectPartialType as (Rep s))
105+ , as ~ TupleToList a
106+ , ListTuple a as
107+ , GAsType (Rep s) as
98108 ) => AsType a s where
99109
100− _Typed
101− = repIso . _GTyped
102− injectTyped
103− = to . ginjectTyped
104− projectTyped
105− = either (const Nothing) Just . gprojectTyped . from
110+ _Typed eta = prismRavel (prismPRavel (repIso . _GTyped @_ @as . tupled)) eta
111+ {-# INLINE _Typed #-}
106112
107113-- See Note [Uncluttering type signatures]
108114instance {-# OVERLAPPING #-} AsType a Void where
stack.yaml+2−2
@@ -1,10 +1,10 @@
1−resolver: lts-9.2
1+resolver: lts-10.3
22
33packages:
44- '.'
55
66extra-deps:
7−- 'inspection-testing-0.1.1.2'
7+- 'inspection-testing-0.2'
88
99flags: {}
1010
test/Spec.hs+127−12
@@ -1,4 +1,5 @@
11{-# OPTIONS_GHC -O -fplugin Test.Inspection.Plugin #-}
2+{-# OPTIONS_GHC -dsuppress-all #-}
23
34{-# LANGUAGE AllowAmbiguousTypes #-}
45{-# LANGUAGE DataKinds #-}
@@ -14,10 +15,25 @@ module Main where
1415
1516import GHC.Generics
1617import Data.Generics.Product
18+import Data.Generics.Sum
1719import Test.Inspection
20+import Test.HUnit
21+import Util
22+import System.Exit
23+import Data.Generics.Internal.VL.Lens
24+import Data.Generics.Internal.VL.Prism
25+import Data.Generics.Internal.VL.Traversal
26+
27+-- This is sufficient at we only want to test that they typecheck
28+import Test24 ()
29+import Test25 ()
1830
1931main :: IO ()
20−main = putStrLn "Hello world"
32+main = do
33+ res <- runTestTT tests
34+ case errors res + failures res of
35+ 0 -> exitSuccess
36+ _ -> exitFailure
2137
2238data Record = MkRecord
2339 { fieldA :: Int
@@ -33,11 +49,21 @@ data Record3 a = MkRecord3
3349 , fieldB :: Bool
3450 } deriving (Generic, Show)
3551
36−type Lens' s a = Lens s s a a
37−type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t
52+data Record4 a = MkRecord4
53+ { fieldA :: a
54+ , fieldB :: a
55+ } deriving (Generic1)
56+
57+data Record5 = MkRecord5
58+ { fieldA :: Int
59+ , fieldB :: Int
60+ , fieldC :: String
61+ , fieldD :: Int
62+ , fieldE :: Char
63+ , fieldF :: Int
64+ } deriving Generic
65+
3866
39−fieldALensManual :: Lens' Record Int
40−fieldALensManual f (MkRecord a b) = (\a' -> MkRecord a' b) <$> f a
4167
4268typeChangingManual :: Lens (Record3 a) (Record3 b) a b
4369typeChangingManual f (MkRecord3 a b) = (\a' -> MkRecord3 a' b) <$> f a
@@ -47,12 +73,73 @@ typeChangingManualCompose = typeChangingManual . typeChangingManual
4773
4874newtype L s a = L (Lens' s a)
4975
76+intTraversalManual :: Traversal' Record5 Int
77+intTraversalManual f (MkRecord5 a b c d e f') =
78+ pure (\a1 a2 a3 a4 -> MkRecord5 a1 a2 c a3 e a4) <*> f a <*> f b <*> f d <*> f f'
79+
80+intTraversalDerived :: Traversal' Record5 Int
81+intTraversalDerived = types
82+
83+fieldALensManual :: Lens' Record Int
84+fieldALensManual f (MkRecord a b) = (\a' -> MkRecord a' b) <$> f a
85+
5086subtypeLensManual :: Lens' Record Record2
5187subtypeLensManual f record
5288 = fmap (\ds -> case record of
5389 MkRecord _ b -> MkRecord (case ds of {MkRecord2 g1 -> g1}) b
5490 ) (f (MkRecord2 (case record of {MkRecord a _ -> a})))
5591
92+data Sum1 = A Char | B Int | C () | D () deriving (Generic, Show)
93+data Sum2 = A2 Char | B2 Int deriving (Generic, Show)
94+
95+sum1PrismManual :: Prism Sum1 Sum1 Int Int
96+sum1PrismManual eta = prism g f eta
97+ where
98+ f s1 = case s1 of
99+ B i -> Right i
100+ s -> Left s
101+ g = B
102+
103+sum1PrismManualChar :: Prism Sum1 Sum1 Char Char
104+sum1PrismManualChar eta = prism g f eta
105+ where
106+ f s1 = case s1 of
107+ A i -> Right i
108+ B _ -> Left s1
109+ C _ -> Left s1
110+ D _ -> Left s1
111+ g = A
112+
113+sum2PrismManual :: Prism Sum2 Sum2 Int Int
114+sum2PrismManual eta = prism g f eta
115+ where
116+ f s1 = case s1 of
117+ B2 i -> Right i
118+ s -> Left s
119+ g = B2
120+
121+
122+sum2PrismManualChar :: Prism Sum2 Sum2 Char Char
123+sum2PrismManualChar eta = prism g f eta
124+ where
125+ f s1 = case s1 of
126+ A2 i -> Right i
127+ s -> Left s
128+ g = A2
129+
130+-- Note we don't have a catch-all case because of #14684
131+subtypePrismManual :: Prism Sum1 Sum1 Sum2 Sum2
132+subtypePrismManual eta = prism g f eta
133+ where
134+ f s1 = case s1 of
135+ A c -> Right (A2 c)
136+ B i -> Right (B2 i)
137+ C _ -> Left s1
138+ D _ -> Left s1
139+ g (A2 c) = A c
140+ g (B2 i) = B i
141+
142+
56143--------------------------------------------------------------------------------
57144-- * Tests
58145-- The inspection-testing plugin checks that the following equalities hold, by
@@ -81,10 +168,38 @@ typeChangingGenericPos = position @1
81168typeChangingGenericCompose :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b
82169typeChangingGenericCompose = field @"fieldA" . field @"fieldA"
83170
84−inspect $ 'fieldALensManual === 'fieldALensName
85−inspect $ 'fieldALensManual === 'fieldALensType
86−inspect $ 'fieldALensManual === 'fieldALensPos
87−inspect $ 'subtypeLensManual === 'subtypeLensGeneric
88−inspect $ 'typeChangingManual === 'typeChangingGeneric
89−inspect $ 'typeChangingManual === 'typeChangingGenericPos
90−inspect $ 'typeChangingManualCompose === 'typeChangingGenericCompose
171+sum1PrismB :: Prism Sum1 Sum1 Int Int
172+sum1PrismB = _Ctor @"B"
173+
174+subtypePrismGeneric :: Prism Sum1 Sum1 Sum2 Sum2
175+subtypePrismGeneric = _Sub
176+
177+sum1TypePrism :: Prism Sum1 Sum1 Int Int
178+sum1TypePrism = _Typed @Int
179+
180+sum1TypePrismChar :: Prism Sum1 Sum1 Char Char
181+sum1TypePrismChar = _Typed @Char
182+
183+sum2TypePrism :: Prism Sum2 Sum2 Int Int
184+sum2TypePrism = _Typed @Int
185+
186+sum2TypePrismChar :: Prism Sum2 Sum2 Char Char
187+sum2TypePrismChar = _Typed @Char
188+
189+tests :: Test
190+tests = TestList $ map mkHUnitTest
191+ [ $(inspectTest $ 'fieldALensManual === 'fieldALensName)
192+ , $(inspectTest $ 'fieldALensManual === 'fieldALensType)
193+ , $(inspectTest $ 'fieldALensManual === 'fieldALensPos)
194+ , $(inspectTest $ 'subtypeLensManual === 'subtypeLensGeneric)
195+ , $(inspectTest $ 'typeChangingManual === 'typeChangingGeneric)
196+ , $(inspectTest $ 'typeChangingManual === 'typeChangingGenericPos)
197+ , $(inspectTest $ 'typeChangingManualCompose === 'typeChangingGenericCompose)
198+ , $(inspectTest $ 'intTraversalManual === 'intTraversalDerived)
199+ , $(inspectTest $ 'sum1PrismManual === 'sum1PrismB)
200+ , $(inspectTest $ 'subtypePrismManual === 'subtypePrismGeneric)
201+ , $(inspectTest $ 'sum2PrismManualChar === 'sum2TypePrismChar)
202+ , $(inspectTest $ 'sum2PrismManual === 'sum2TypePrism)
203+ , $(inspectTest $ 'sum1PrismManualChar === 'sum1TypePrismChar)
204+ , $(inspectTest $ 'sum2PrismManualChar === 'sum2TypePrismChar)
205+ , $(inspectTest $ 'sum1PrismManual === 'sum1TypePrism) ]
test/24.hs → test/Test24.hsrenamed+1−1
@@ -1,6 +1,6 @@
11{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications #-}
22
3−module Main where
3+module Test24 where
44
55-- Test case from #24, comments preserved
66import Control.Lens
test/25.hs → test/Test25.hsrenamed+1−1
@@ -4,7 +4,7 @@
44{-# LANGUAGE DeriveGeneric #-}
55{-# OPTIONS_GHC -Wall #-}
66
7−module Main where
7+module Test25 where
88
99import Control.Lens
1010import Data.Generics.Product
test/Util.hsnew file+11
@@ -0,0 +1,11 @@
1+module Util where
2+
3+import Test.Inspection
4+import Test.HUnit.Base
5+
6+mkHUnitTest :: Result -> Test
7+mkHUnitTest r = TestCase $
8+ case r of
9+ Success _s -> return ()
10+ Failure s -> assertFailure s
11+