on master help sign in
Merge pull request #33 from kcsongor/wip/boggle-merge
2559eccCsongor Kiss
.travis.yml+9−1
@@ -25,6 +25,8 @@ before_cache:
25 - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx
25 - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx
26
26
27matrix:
27matrix:
28+ allow_failures:
29+ - compiler: "ghc-8.4.1"
28 include:
30 include:
29 - compiler: "ghc-8.0.2"
31 - compiler: "ghc-8.0.2"
30 # env: TEST=--disable-tests BENCH=--disable-benchmarks
32 # env: TEST=--disable-tests BENCH=--disable-benchmarks
@@ -32,6 +34,12 @@ matrix:
32 - compiler: "ghc-8.2.1"
34 - compiler: "ghc-8.2.1"
33 # env: TEST=--disable-tests BENCH=--disable-benchmarks
35 # env: TEST=--disable-tests BENCH=--disable-benchmarks
34 addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.1], sources: [hvr-ghc]}}
36 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]}}
35
43
36before_install:
44before_install:
37 - HC=${CC}
45 - HC=${CC}
@@ -67,7 +75,7 @@ script:
67 - mv "."/dist/generic-lens-*.tar.gz ${DISTDIR}/
75 - mv "."/dist/generic-lens-*.tar.gz ${DISTDIR}/
68 - cd ${DISTDIR}
76 - cd ${DISTDIR}
69 - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;
77 - 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"
71 # this builds all libraries and executables (without tests/benchmarks)
79 # this builds all libraries and executables (without tests/benchmarks)
72 - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all
80 - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all
73
81
cabal.projectnew file+1
@@ -0,0 +1 @@
1+packages: generic-lens.cabal
examples/Examples.hs+6−1
@@ -17,11 +17,16 @@
17module Examples where
17module Examples where
18
18
19import Data.Function ((&))
19import Data.Function ((&))
20−import Data.Generics.Internal.Lens
20+import Data.Generics.Internal.VL.Lens
21import Data.Generics.Product
21import Data.Generics.Product
22import Data.Generics.Sum
22import Data.Generics.Sum
23import GHC.Generics
23import GHC.Generics
24import Data.Generics.Labels
24import 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
25
30
26data Animal = Animal
31data Animal = Animal
27 { name :: String
32 { name :: String
generic-lens.cabal+19−31
@@ -29,30 +29,38 @@ library
29 , Data.Generics.Product.Positions
29 , Data.Generics.Product.Positions
30 , Data.Generics.Product.Subtype
30 , Data.Generics.Product.Subtype
31 , Data.Generics.Product.Typed
31 , Data.Generics.Product.Typed
32− --, Data.Generics.Labels
32+ , Data.Generics.Product.Types
33+ , Data.Generics.Product.List
33
34
34 , Data.Generics.Sum
35 , Data.Generics.Sum
35 , Data.Generics.Sum.Any
36 , Data.Generics.Sum.Any
36 , Data.Generics.Sum.Constructors
37 , Data.Generics.Sum.Constructors
37 , Data.Generics.Sum.Typed
38 , Data.Generics.Sum.Typed
38 , Data.Generics.Sum.Subtype
39 , 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
40
47
41 other-modules: Data.Generics.Internal.Families
48 other-modules: Data.Generics.Internal.Families
42 , Data.Generics.Internal.Families.Changing
49 , Data.Generics.Internal.Families.Changing
43 , Data.Generics.Internal.Families.Collect
50 , Data.Generics.Internal.Families.Collect
44 , Data.Generics.Internal.Families.Has
51 , Data.Generics.Internal.Families.Has
45− , Data.Generics.Internal.HList
46 , Data.Generics.Internal.Void
52 , Data.Generics.Internal.Void
47
53
48 , Data.Generics.Sum.Internal.Constructors
54 , Data.Generics.Sum.Internal.Constructors
49 , Data.Generics.Sum.Internal.Typed
55 , Data.Generics.Sum.Internal.Typed
50 , Data.Generics.Sum.Internal.Subtype
56 , Data.Generics.Sum.Internal.Subtype
51
57
52− , Data.Generics.Product.Internal.Fields
53 , Data.Generics.Product.Internal.Positions
58 , Data.Generics.Product.Internal.Positions
54 , Data.Generics.Product.Internal.Subtype
59 , Data.Generics.Product.Internal.Subtype
60+
55− , Data.Generics.Product.Internal.Typed
61+ , Data.Generics.Product.Internal.Types
62+ , Data.Generics.Product.Internal.List
63+ , Data.Generics.Product.Internal.Keyed
56
64
57 build-depends: base >= 4.9 && <= 5.0
65 build-depends: base >= 4.9 && <= 5.0
58 , profunctors >= 5.0 && <= 6.0
66 , profunctors >= 5.0 && <= 6.0
@@ -65,7 +73,6 @@ library
65 build-depends: dump-core
73 build-depends: dump-core
66 ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
74 ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
67
75
68−
69source-repository head
76source-repository head
70 type: git
77 type: git
71 location: https://github.com/kcsongor/generic-lens
78 location: https://github.com/kcsongor/generic-lens
@@ -74,10 +81,14 @@ test-suite generic-lens-test
74 type: exitcode-stdio-1.0
81 type: exitcode-stdio-1.0
75 hs-source-dirs: test
82 hs-source-dirs: test
76 main-is: Spec.hs
83 main-is: Spec.hs
84+ other-modules: Util Test24 Test25
77
85
78 build-depends: base >= 4.9 && <= 5.0
86 build-depends: base >= 4.9 && <= 5.0
79 , generic-lens
87 , generic-lens
88+ , lens
89+ , profunctors
80− , inspection-testing >= 0.1
90+ , inspection-testing >= 0.2
91+ , HUnit
81
92
82 default-language: Haskell2010
93 default-language: Haskell2010
83 ghc-options: -Wall
94 ghc-options: -Wall
@@ -85,30 +96,6 @@ test-suite generic-lens-test
85 build-depends: dump-core
96 build-depends: dump-core
86 ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
97 ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
87
98
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−
112test-suite doctests
99test-suite doctests
113 default-language: Haskell2010
100 default-language: Haskell2010
114 type: exitcode-stdio-1.0
101 type: exitcode-stdio-1.0
@@ -132,3 +119,4 @@ benchmark generic-lens-bench
132
119
133 default-language: Haskell2010
120 default-language: Haskell2010
134 ghc-options: -Wall
121 ghc-options: -Wall
122+
src/Data/Generics/Internal/Families.hs+1−1
@@ -3,7 +3,6 @@
3{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE KindSignatures #-}
4{-# LANGUAGE KindSignatures #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
6−{-# LANGUAGE TypeApplications #-}
7{-# LANGUAGE TypeFamilies #-}
6{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE TypeOperators #-}
7{-# LANGUAGE TypeOperators #-}
9
8
@@ -28,6 +27,7 @@ import Data.Generics.Internal.Families.Changing as Families
28
27
29import GHC.TypeLits (ErrorMessage (..), Symbol)
28import GHC.TypeLits (ErrorMessage (..), Symbol)
30
29
30+-- * Stuff
31type family ShowSymbols (ctors :: [Symbol]) :: ErrorMessage where
31type family ShowSymbols (ctors :: [Symbol]) :: ErrorMessage where
32 ShowSymbols '[]
32 ShowSymbols '[]
33 = 'Text ""
33 = 'Text ""
src/Data/Generics/Internal/Families/Collect.hs+3−2
@@ -28,7 +28,8 @@ import Data.Type.Equality (type (==))
28import GHC.Generics
28import GHC.Generics
29import GHC.TypeLits (Symbol, CmpSymbol)
29import GHC.TypeLits (Symbol, CmpSymbol)
30
30
31−import Data.Generics.Internal.HList
31+import Data.Generics.Product.Internal.List (type (++))
32+import Data.Generics.Internal.Families.Has (GTypes)
32
33
33data TypeStat
34data TypeStat
34 = TypeStat
35 = TypeStat
@@ -83,7 +84,7 @@ type family CollectPartialType t f :: [Symbol] where
83 CollectPartialType t (l :+: r)
84 CollectPartialType t (l :+: r)
84 = CollectPartialType t l ++ CollectPartialType t r
85 = CollectPartialType t l ++ CollectPartialType t r
85 CollectPartialType t (C1 ('MetaCons ctor _ _) f)
86 CollectPartialType t (C1 ('MetaCons ctor _ _) f)
86− = If (t == ListToTuple (GCollect f)) '[ctor] '[]
87+ = If (t == GTypes f) '[ctor] '[]
87 CollectPartialType t (D1 _ f)
88 CollectPartialType t (D1 _ f)
88 = CollectPartialType t f
89 = CollectPartialType t f
89
90
src/Data/Generics/Internal/Families/Has.hs+21−8
@@ -17,8 +17,9 @@
17module Data.Generics.Internal.Families.Has
17module Data.Generics.Internal.Families.Has
18 ( HasTotalFieldP
18 ( HasTotalFieldP
19 , HasTotalTypeP
19 , HasTotalTypeP
20− , HasPartialTypeTupleP
20+ , HasPartialTypeP
21 , HasCtorP
21 , HasCtorP
22+ , GTypes
22 ) where
23 ) where
23
24
24import Data.Type.Bool (type (||), type (&&))
25import Data.Type.Bool (type (||), type (&&))
@@ -26,7 +27,7 @@ import Data.Type.Equality (type (==))
26import GHC.Generics
27import GHC.Generics
27import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
28import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
28
29
29−import Data.Generics.Internal.HList
30+import Data.Generics.Product.Internal.List
30
31
31type family HasTotalFieldP (field :: Symbol) f :: Bool where
32type family HasTotalFieldP (field :: Symbol) f :: Bool where
32 HasTotalFieldP field (S1 ('MetaSel ('Just field) _ _ _) _)
33 HasTotalFieldP field (S1 ('MetaSel ('Just field) _ _ _) _)
@@ -78,12 +79,14 @@ type family HasTotalTypeP a f :: Bool where
78 ':<>: 'Text " is not a valid GHC.Generics representation type"
79 ':<>: 'Text " is not a valid GHC.Generics representation type"
79 )
80 )
80
81
81−type family HasPartialTypeTupleP a f :: Bool where
82+type family HasPartialTypeP a f :: Bool where
82− HasPartialTypeTupleP t (l :+: r)
83+ HasPartialTypeP t (l :+: r)
83− = HasPartialTypeTupleP t l || HasPartialTypeTupleP t r
84+ = HasPartialTypeP t l || HasPartialTypeP t r
84− HasPartialTypeTupleP t (C1 m f)
85+ HasPartialTypeP t (C1 m f)
85− = t == ListToTuple (GCollect f)
86+ = t == GTypes f
86− HasPartialTypeTupleP t _
87+ HasPartialTypeP t (M1 _ _ f)
88+ = HasPartialTypeP t f
89+ HasPartialTypeP t _
87 = 'False
90 = 'False
88
91
89type family HasCtorP (ctor :: Symbol) f :: Bool where
92type family HasCtorP (ctor :: Symbol) f :: Bool where
@@ -95,3 +98,13 @@ type family HasCtorP (ctor :: Symbol) f :: Bool where
95 = HasCtorP ctor f
98 = HasCtorP ctor f
96 HasCtorP ctor _
99 HasCtorP ctor _
97 = 'False
100 = '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 #-}
1module Data.Generics.Internal.Void where
2module Data.Generics.Internal.Void where
2
3
3{-
4{-
src/Data/Generics/Product.hs+4
@@ -22,6 +22,8 @@ module Data.Generics.Product
22 , module Data.Generics.Product.Positions
22 , module Data.Generics.Product.Positions
23 , module Data.Generics.Product.Subtype
23 , module Data.Generics.Product.Subtype
24 , module Data.Generics.Product.Typed
24 , module Data.Generics.Product.Typed
25+ , module Data.Generics.Product.Types
26+ , module Data.Generics.Product.List
25 ) where
27 ) where
26
28
27import Data.Generics.Product.Any
29import Data.Generics.Product.Any
@@ -29,3 +31,5 @@ import Data.Generics.Product.Fields
29import Data.Generics.Product.Positions
31import Data.Generics.Product.Positions
30import Data.Generics.Product.Subtype
32import Data.Generics.Product.Subtype
31import Data.Generics.Product.Typed
33import 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
29 HasAny (..)
29 HasAny (..)
30 ) where
30 ) where
31
31
32−import Data.Generics.Internal.Lens
32+import Data.Generics.Internal.VL.Lens
33import Data.Generics.Product.Fields
33import Data.Generics.Product.Fields
34import Data.Generics.Product.Positions
34import Data.Generics.Product.Positions
35import Data.Generics.Product.Typed
35import Data.Generics.Product.Typed
@@ -41,7 +41,7 @@ import Data.Generics.Product.Typed
41-- >>> :set -XDataKinds
41-- >>> :set -XDataKinds
42-- >>> :set -XDeriveGeneric
42-- >>> :set -XDeriveGeneric
43-- >>> import GHC.Generics
43-- >>> import GHC.Generics
44−-- >>> :m +Data.Generics.Internal.Lens
44+-- >>> :m +Data.Generics.Internal.VL.Lens
45-- >>> :{
45-- >>> :{
46-- data Human = Human
46-- data Human = Human
47-- { name :: String
47-- { name :: String
src/Data/Generics/Product/Fields.hs+14−13
@@ -38,13 +38,14 @@ module Data.Generics.Product.Fields
38 ) where
38 ) where
39
39
40import Data.Generics.Internal.Families
40import Data.Generics.Internal.Families
41−import Data.Generics.Internal.Lens
41+import Data.Generics.Internal.VL.Lens as VL
42import Data.Generics.Internal.Void
42import Data.Generics.Internal.Void
43−import Data.Generics.Product.Internal.Fields
43+import Data.Generics.Product.Internal.Keyed
44
44
45import Data.Kind (Constraint, Type)
45import Data.Kind (Constraint, Type)
46import GHC.Generics
46import GHC.Generics
47import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError)
47import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError)
48+import Data.Generics.Internal.Profunctor.Lens as P
48
49
49-- $setup
50-- $setup
50-- == /Running example:/
51-- == /Running example:/
@@ -55,7 +56,7 @@ import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError)
55-- >>> :set -XGADTs
56-- >>> :set -XGADTs
56-- >>> :set -XFlexibleContexts
57-- >>> :set -XFlexibleContexts
57-- >>> import GHC.Generics
58-- >>> import GHC.Generics
58−-- >>> :m +Data.Generics.Internal.Lens
59+-- >>> :m +Data.Generics.Internal.VL.Lens
59-- >>> :m +Data.Function
60-- >>> :m +Data.Function
60-- >>> :{
61-- >>> :{
61-- data Human a
62-- data Human a
@@ -76,7 +77,7 @@ import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError)
76-- :}
77-- :}
77
78
78-- |Records that have a field with a given name.
79-- |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
80 -- |A lens that focuses on a field with a given name. Compatible with the
81 -- |A lens that focuses on a field with a given name. Compatible with the
81 -- lens package's 'Control.Lens.Lens' type.
82 -- lens package's 'Control.Lens.Lens' type.
82 --
83 --
@@ -108,21 +109,21 @@ class HasField (field :: Symbol) s t a b | s field -> a, s field b -> t, t field
108 -- ... The offending constructors are:
109 -- ... The offending constructors are:
109 -- ... HumanNoAddress
110 -- ... HumanNoAddress
110 -- ...
111 -- ...
111− field :: Lens s t a b
112+ field :: VL.Lens s t a b
112
113
113type HasField' field s a = HasField field s s a a
114type HasField' field s a = HasField field s s a a
114
115
115-- |
116-- |
116-- >>> getField @"age" human
117-- >>> getField @"age" human
117-- 50
118-- 50
118−getField :: forall f s a. HasField' f s a => s -> a
119+getField :: forall f a s. HasField' f s a => s -> a
119−getField s = s ^. field @f
120+getField = VL.view (field @f)
120
121
121-- |
122-- |
122-- >>> setField @"age" 60 human
123-- >>> setField @"age" 60 human
123-- Human {name = "Tunyasz", age = 60, address = "London", other = False}
124-- Human {name = "Tunyasz", age = 60, address = "London", other = False}
124setField :: forall f s a. HasField' f s a => a -> s -> s
125setField :: forall f s a. HasField' f s a => a -> s -> s
125−setField = set (field @f)
126+setField = VL.set (field @f)
126
127
127instance -- see Note [Changing type parameters]
128instance -- see Note [Changing type parameters]
128 ( Generic s
129 ( Generic s
@@ -137,15 +138,15 @@ instance -- see Note [Changing type parameters]
137#endif
138#endif
138 , Generic s'
139 , Generic s'
139 , Generic t'
140 , Generic t'
140− , GHasField' field (Rep s) a
141+ , GHasKey' field (Rep s) a
141− , GHasField' field (Rep s') a'
142+ , GHasKey' field (Rep s') a'
142− , GHasField' field (Rep t') b'
143+ , GHasKey' field (Rep t') b'
143− , GHasField field (Rep s) (Rep t) a b
144+ , GHasKey field (Rep s) (Rep t) a b
144 , t ~ Infer s a' b
145 , t ~ Infer s a' b
145 , s ~ Infer t b' a
146 , s ~ Infer t b' a
146 ) => HasField field s t a b where
147 ) => HasField field s t a b where
147
148
148− field f s = ravel (repLens . gfield @field) f s
149+ field f s = VL.ravel (repLens . gkey @field) f s
149
150
150-- -- See Note [Uncluttering type signatures]
151-- -- See Note [Uncluttering type signatures]
151instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where
152instance {-# 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
33 , Size
33 , Size
34 ) where
34 ) where
35
35
36−import Data.Generics.Internal.Lens
36+import Data.Generics.Product.Internal.List
37−
38import Data.Kind (Type)
37import Data.Kind (Type)
39import Data.Type.Bool (If, Not)
38import Data.Type.Bool (If, Not)
40import GHC.Generics
39import 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
42
43
43-- |As 'HasPosition' but over generic representations as defined by
44-- |As 'HasPosition' but over generic representations as defined by
44-- "GHC.Generics".
45-- "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
46 gposition :: Lens (s x) (t x) a b
47 gposition :: Lens (s x) (t x) a b
47
48
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
49
50
50−instance GHasPosition i i (K1 R a) (K1 R b) a b where
51+instance (GHasPosition i l l' a b, GHasPosition i r r' a b) => GHasPosition i (l :+: r) (l' :+: r') a b where
51− gposition f (K1 x) = fmap K1 (f x)
52+ gposition = \x -> sumIso (choosing (gposition @i) (gposition @i) x)
53+ {-# INLINE gposition #-}
52
54
53−instance GHasPosition offset i s t a b => GHasPosition offset i (M1 m meta s) (M1 m meta t) a b where
55+instance GHasPosition i s t a b => GHasPosition i (M1 D meta s) (M1 D meta t) a b where
54− gposition = mLens . gposition @offset @i
56+ gposition x = mLens (gposition @i x)
57+ {-# INLINE gposition #-}
55
58
56instance
59instance
57− ( goLeft ~ (i <? (offset + Size l))
60+ ( IndexList (i - 1) as bs a b
58− , offset' ~ (If goLeft offset (offset + Size l))
61+ , GIsList () f g as bs
59− , GProductHasPosition offset' i l r l' r' a b goLeft
60− ) => GHasPosition offset i (l :*: r) (l' :*: r') a b where
62+ ) => GHasPosition i (M1 C meta f) (M1 C meta g) a b where
61−
63+ gposition x = mIso (glist @() (point @(i - 1) x))
62− gposition = gproductPosition @offset' @i @_ @_ @_ @_ @_ @_ @goLeft
64+ {-# INLINE gposition #-}
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
72
65
73type family Size f :: Nat where
66type family Size f :: Nat where
74 Size (l :*: r)
67 Size (l :*: r)
src/Data/Generics/Product/Internal/Subtype.hs+6−6
@@ -31,11 +31,11 @@ module Data.Generics.Product.Internal.Subtype
31 ) where
31 ) where
32
32
33import Data.Generics.Internal.Families
33import Data.Generics.Internal.Families
34−import Data.Generics.Internal.Lens
34+import Data.Generics.Product.Internal.Keyed
35−import Data.Generics.Product.Internal.Fields
36
35
37import Data.Kind (Type)
36import Data.Kind (Type)
38import GHC.Generics
37import GHC.Generics
38+import Data.Generics.Internal.Profunctor.Lens
39
39
40--------------------------------------------------------------------------------
40--------------------------------------------------------------------------------
41-- * Generic upcasting
41-- * Generic upcasting
@@ -47,10 +47,10 @@ instance (GUpcast sub a, GUpcast sub b) => GUpcast sub (a :*: b) where
47 gupcast rep = gupcast rep :*: gupcast rep
47 gupcast rep = gupcast rep :*: gupcast rep
48
48
49instance
49instance
50− GHasField field sub sub t t
50+ GHasKey field sub sub t t
51 => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
51 => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
52
52
53− gupcast r = M1 (K1 (r ^. gfield @field))
53+ gupcast r = M1 (K1 (view (gkey @field) r))
54
54
55instance GUpcast sub sup => GUpcast sub (C1 c sup) where
55instance GUpcast sub sup => GUpcast sub (C1 c sup) where
56 gupcast = M1 . gupcast
56 gupcast = M1 . gupcast
@@ -84,9 +84,9 @@ class GSmashLeaf sub sup (w :: Bool) where
84 gsmashLeaf :: sup p -> sub p -> sub p
84 gsmashLeaf :: sup p -> sub p -> sub p
85
85
86instance
86instance
87− GHasField field sup sup t t
87+ GHasKey field sup sup t t
88 => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'True where
88 => 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))
90
90
91instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'False where
91instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'False where
92 gsmashLeaf _ = id
92 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
38 , setPosition
38 , setPosition
39 ) where
39 ) where
40
40
41−import Data.Generics.Internal.Lens
41+import Data.Generics.Internal.VL.Lens as VL
42import Data.Generics.Internal.Void
42import Data.Generics.Internal.Void
43import Data.Generics.Internal.Families
43import Data.Generics.Internal.Families
44import Data.Generics.Product.Internal.Positions
44import Data.Generics.Product.Internal.Positions
@@ -47,6 +47,7 @@ import Data.Kind (Constraint, Type)
47import Data.Type.Bool (type (&&))
47import Data.Type.Bool (type (&&))
48import GHC.Generics
48import GHC.Generics
49import GHC.TypeLits (type (<=?), Nat, TypeError, ErrorMessage(..))
49import GHC.TypeLits (type (<=?), Nat, TypeError, ErrorMessage(..))
50+import Data.Generics.Internal.Profunctor.Lens
50
51
51-- $setup
52-- $setup
52-- == /Running example:/
53-- == /Running example:/
@@ -57,7 +58,7 @@ import GHC.TypeLits (type (<=?), Nat, TypeError, ErrorMessage(..))
57-- >>> :set -XGADTs
58-- >>> :set -XGADTs
58-- >>> :set -XFlexibleContexts
59-- >>> :set -XFlexibleContexts
59-- >>> import GHC.Generics
60-- >>> import GHC.Generics
60−-- >>> :m +Data.Generics.Internal.Lens
61+-- >>> :m +Data.Generics.Internal.VL.Lens
61-- >>> :m +Data.Function
62-- >>> :m +Data.Function
62-- >>> :{
63-- >>> :{
63-- data Human = Human
64-- data Human = Human
@@ -71,7 +72,7 @@ import GHC.TypeLits (type (<=?), Nat, TypeError, ErrorMessage(..))
71-- :}
72-- :}
72
73
73-- |Records that have a field at a given position.
74-- |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
75 -- |A lens that focuses on a field at a given position. Compatible with the
76 -- |A lens that focuses on a field at a given position. Compatible with the
76 -- lens package's 'Control.Lens.Lens' type.
77 -- lens package's 'Control.Lens.Lens' type.
77 --
78 --
@@ -86,7 +87,7 @@ class HasPosition (i :: Nat) s t a b | s i -> a, s i b -> t, t i a -> s where
86 -- ...
87 -- ...
87 -- ... The type Human does not contain a field at position 4
88 -- ... The type Human does not contain a field at position 4
88 -- ...
89 -- ...
89− position :: Lens s t a b
90+ position :: VL.Lens s t a b
90
91
91type HasPosition' i s a = HasPosition i s s a a
92type HasPosition' i s a = HasPosition i s s a a
92
93
@@ -94,7 +95,7 @@ getPosition :: forall i s a. HasPosition' i s a => s -> a
94getPosition s = s ^. position @i
95getPosition s = s ^. position @i
95
96
96setPosition :: forall i s a. HasPosition' i s a => a -> s -> s
97setPosition :: forall i s a. HasPosition' i s a => a -> s -> s
97−setPosition = set (position @i)
98+setPosition = VL.set (position @i)
98
99
99instance -- see Note [Changing type parameters]
100instance -- see Note [Changing type parameters]
100 ( Generic s
101 ( Generic s
@@ -111,13 +112,14 @@ instance -- see Note [Changing type parameters]
111 , Generic t'
112 , Generic t'
112 , GHasPosition' i (Rep s) a
113 , GHasPosition' i (Rep s) a
113 , GHasPosition' i (Rep s') a'
114 , GHasPosition' i (Rep s') a'
114− , GHasPosition 1 i (Rep s) (Rep t) a b
115+ , GHasPosition i (Rep s) (Rep t) a b
115 , t ~ Infer s a' b
116 , t ~ Infer s a' b
116 , GHasPosition' i (Rep t') b'
117 , GHasPosition' i (Rep t') b'
117 , s ~ Infer t b' a
118 , s ~ Infer t b' a
118 ) => HasPosition i s t a b where
119 ) => HasPosition i s t a b where
119
120
120− position f s = ravel (repLens . gposition @1 @i) f s
121+ position = VL.ravel (repLens . gposition @i)
122+ {-# INLINE position #-}
121
123
122-- See Note [Uncluttering type signatures]
124-- See Note [Uncluttering type signatures]
123instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where
125instance {-# 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
33 ) where
33 ) where
34
34
35import Data.Generics.Internal.Families
35import Data.Generics.Internal.Families
36−import Data.Generics.Internal.Lens
36+import Data.Generics.Internal.VL.Lens as VL
37import Data.Generics.Internal.Void
37import Data.Generics.Internal.Void
38import Data.Generics.Product.Internal.Subtype
38import Data.Generics.Product.Internal.Subtype
39
39
40import GHC.Generics (Generic (Rep, to, from) )
40import GHC.Generics (Generic (Rep, to, from) )
41import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
41import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
42import Data.Kind (Type, Constraint)
42import Data.Kind (Type, Constraint)
43+import Data.Generics.Internal.Profunctor.Lens hiding (set)
43
44
44-- $setup
45-- $setup
45-- == /Running example:/
46-- == /Running example:/
@@ -49,7 +50,7 @@ import Data.Kind (Type, Constraint)
49-- >>> :set -XDeriveGeneric
50-- >>> :set -XDeriveGeneric
50-- >>> :set -XDuplicateRecordFields
51-- >>> :set -XDuplicateRecordFields
51-- >>> import GHC.Generics
52-- >>> import GHC.Generics
52−-- >>> :m +Data.Generics.Internal.Lens
53+-- >>> :m +Data.Generics.Internal.VL.Lens
53-- >>> :{
54-- >>> :{
54-- data Human = Human
55-- data Human = Human
55-- { name :: String
56-- { name :: String
@@ -80,9 +81,9 @@ class Subtype sup sub where
80 --
81 --
81 -- >>> set (super @Animal) (Animal "dog" 10) human
82 -- >>> set (super @Animal) (Animal "dog" 10) human
82 -- Human {name = "dog", age = 10, address = "London"}
83 -- Human {name = "dog", age = 10, address = "London"}
83− super :: Lens' sub sup
84+ super :: VL.Lens sub sub sup sup
84− super f sub
85+ super
85− = fmap (`smash` sub) (f (upcast sub))
86+ = VL.lens upcast (uncurry smash . swap)
86
87
87 -- |Cast the more specific subtype to the more general supertype
88 -- |Cast the more specific subtype to the more general supertype
88 --
89 --
@@ -103,7 +104,7 @@ class Subtype sup sub where
103 -- >>> smash (Animal "dog" 10) human
104 -- >>> smash (Animal "dog" 10) human
104 -- Human {name = "dog", age = 10, address = "London"}
105 -- Human {name = "dog", age = 10, address = "London"}
105 smash :: sup -> sub -> sub
106 smash :: sup -> sub -> sub
106− smash = set (super @sup)
107+ smash = VL.set (super @sup)
107
108
108 {-# MINIMAL super | smash, upcast #-}
109 {-# MINIMAL super | smash, upcast #-}
109
110
src/Data/Generics/Product/Typed.hs+12−10
@@ -19,7 +19,7 @@
19-- Stability : experimental
19-- Stability : experimental
20-- Portability : non-portable
20-- Portability : non-portable
21--
21--
22−-- Derive record field getters and setters generically.
22+-- Derive lenses of a given type in a product.
23--
23--
24-----------------------------------------------------------------------------
24-----------------------------------------------------------------------------
25
25
@@ -31,13 +31,14 @@ module Data.Generics.Product.Typed
31 ) where
31 ) where
32
32
33import Data.Generics.Internal.Families
33import Data.Generics.Internal.Families
34−import Data.Generics.Internal.Lens
34+import Data.Generics.Internal.VL.Lens as VL
35import Data.Generics.Internal.Void
35import Data.Generics.Internal.Void
36−import Data.Generics.Product.Internal.Typed
36+import Data.Generics.Product.Internal.Keyed
37
37
38import Data.Kind (Constraint, Type)
38import Data.Kind (Constraint, Type)
39import GHC.Generics (Generic (Rep))
39import GHC.Generics (Generic (Rep))
40import GHC.TypeLits (TypeError, ErrorMessage (..))
40import GHC.TypeLits (TypeError, ErrorMessage (..))
41+import Data.Generics.Internal.Profunctor.Lens
41
42
42-- $setup
43-- $setup
43-- == /Running example:/
44-- == /Running example:/
@@ -46,7 +47,7 @@ import GHC.TypeLits (TypeError, ErrorMessage (..))
46-- >>> :set -XDataKinds
47-- >>> :set -XDataKinds
47-- >>> :set -XDeriveGeneric
48-- >>> :set -XDeriveGeneric
48-- >>> import GHC.Generics
49-- >>> import GHC.Generics
49−-- >>> :m +Data.Generics.Internal.Lens
50+-- >>> :m +Data.Generics.Internal.VL.Lens
50-- >>> :{
51-- >>> :{
51-- data Human
52-- data Human
52-- = Human
53-- = Human
@@ -91,9 +92,10 @@ class HasType a s where
91 -- ... The offending constructors are:
92 -- ... The offending constructors are:
92 -- ... HumanNoTall
93 -- ... HumanNoTall
93 -- ...
94 -- ...
94− typed :: Lens' s a
95+ typed :: VL.Lens s s a a
95− typed f t
96+ typed
96− = fmap (flip (setTyped @a) t) (f (getTyped @a t))
97+ = VL.lens (getTyped @a) (uncurry (setTyped @a) . swap)
98+ {-# INLINE typed #-}
97
99
98 -- |Get field at type.
100 -- |Get field at type.
99 getTyped :: s -> a
101 getTyped :: s -> a
@@ -101,17 +103,17 @@ class HasType a s where
101
103
102 -- |Set field at type.
104 -- |Set field at type.
103 setTyped :: a -> s -> s
105 setTyped :: a -> s -> s
104− setTyped = set (typed @a)
106+ setTyped = VL.set (typed @a)
105
107
106 {-# MINIMAL typed | setTyped, getTyped #-}
108 {-# MINIMAL typed | setTyped, getTyped #-}
107
109
108instance
110instance
109 ( Generic s
111 ( Generic s
110 , ErrorUnlessOne a s (CollectTotalType a (Rep s))
112 , ErrorUnlessOne a s (CollectTotalType a (Rep s))
111− , GHasType (Rep s) a
113+ , GHasKey a (Rep s) (Rep s) a a
112 ) => HasType a s where
114 ) => HasType a s where
113
115
114− typed = ravel (repLens . gtyped)
116+ typed f s = VL.ravel (repLens . gkey @a) f s
115
117
116-- See Note [Uncluttering type signatures]
118-- See Note [Uncluttering type signatures]
117instance {-# OVERLAPPING #-} HasType a Void where
119instance {-# 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
28 AsAny (..)
28 AsAny (..)
29 ) where
29 ) where
30
30
31−import Data.Generics.Internal.Lens
32import Data.Generics.Sum.Constructors
31import Data.Generics.Sum.Constructors
33import Data.Generics.Sum.Typed
32import Data.Generics.Sum.Typed
33+import Data.Generics.Internal.VL.Prism
34
34
35-- $setup
35-- $setup
36-- == /Running example:/
36-- == /Running example:/
@@ -39,7 +39,7 @@ import Data.Generics.Sum.Typed
39-- >>> :set -XDataKinds
39-- >>> :set -XDataKinds
40-- >>> :set -XDeriveGeneric
40-- >>> :set -XDeriveGeneric
41-- >>> import GHC.Generics
41-- >>> import GHC.Generics
42−-- >>> :m +Data.Generics.Internal.Lens
42+-- >>> :m +Data.Generics.Internal.VL.Prism
43-- >>> :{
43-- >>> :{
44-- data Animal
44-- data Animal
45-- = Dog Dog
45-- = Dog Dog
@@ -86,7 +86,7 @@ class AsAny (sel :: k) a s | s sel k -> a where
86 --
86 --
87 -- >>> duck ^? _As @Age
87 -- >>> duck ^? _As @Age
88 -- Just 2
88 -- Just 2
89− _As :: Prism' s a
89+ _As :: Prism s s a a
90
90
91instance AsConstructor ctor s s a a => AsAny ctor a s where
91instance AsConstructor ctor s s a a => AsAny ctor a s where
92 _As = _Ctor @ctor
92 _As = _Ctor @ctor
src/Data/Generics/Sum/Constructors.hs+7−3
@@ -10,6 +10,7 @@
10{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE TypeFamilies #-}
11{-# LANGUAGE TypeOperators #-}
11{-# LANGUAGE TypeOperators #-}
12{-# LANGUAGE UndecidableInstances #-}
12{-# LANGUAGE UndecidableInstances #-}
13+{-# LANGUAGE FlexibleContexts #-}
13
14
14-----------------------------------------------------------------------------
15-----------------------------------------------------------------------------
15-- |
16-- |
@@ -32,13 +33,15 @@ module Data.Generics.Sum.Constructors
32 ) where
33 ) where
33
34
34import Data.Generics.Internal.Families
35import Data.Generics.Internal.Families
35−import Data.Generics.Internal.Lens
36import Data.Generics.Internal.Void
36import Data.Generics.Internal.Void
37import Data.Generics.Sum.Internal.Constructors
37import Data.Generics.Sum.Internal.Constructors
38
38
39import Data.Kind (Constraint, Type)
39import Data.Kind (Constraint, Type)
40import GHC.Generics (Generic (Rep))
40import GHC.Generics (Generic (Rep))
41import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
41import 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)
42
45
43-- $setup
46-- $setup
44-- == /Running example:/
47-- == /Running example:/
@@ -49,7 +52,7 @@ import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
49-- >>> :set -XFlexibleContexts
52-- >>> :set -XFlexibleContexts
50-- >>> :set -XTypeFamilies
53-- >>> :set -XTypeFamilies
51-- >>> import GHC.Generics
54-- >>> import GHC.Generics
52−-- >>> :m +Data.Generics.Internal.Lens
55+-- >>> :m +Data.Generics.Internal.VL.Prism
53-- >>> :m +Data.Generics.Product.Fields
56-- >>> :m +Data.Generics.Product.Fields
54-- >>> :m +Data.Function
57-- >>> :m +Data.Function
55-- >>> :{
58-- >>> :{
@@ -120,7 +123,8 @@ instance
120 , s ~ Infer t b' a
123 , s ~ Infer t b' a
121 ) => AsConstructor ctor s t a b where
124 ) => AsConstructor ctor s t a b where
122
125
123− _Ctor = repIso . _GCtor @ctor
126+ _Ctor eta = prismRavel (prismPRavel (repIso . _GCtor @ctor)) eta
127+ {-# INLINE _Ctor #-}
124
128
125-- See Note [Uncluttering type signatures]
129-- See Note [Uncluttering type signatures]
126instance {-# OVERLAPPING #-} AsConstructor ctor (Void1 a) (Void1 b) a b where
130instance {-# 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
30 ) where
30 ) where
31
31
32import Data.Generics.Internal.Families
32import Data.Generics.Internal.Families
33−import Data.Generics.Internal.HList
33+import Data.Generics.Product.Internal.List
34−import Data.Generics.Internal.Lens
35
34
36import GHC.Generics
35import GHC.Generics
37import GHC.TypeLits (Symbol)
36import 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
38
41
39-- |As 'AsConstructor' but over generic representations as defined by
42-- |As 'AsConstructor' but over generic representations as defined by
40-- "GHC.Generics".
43-- "GHC.Generics".
@@ -44,25 +47,31 @@ class GAsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where
44type GAsConstructor' ctor s a = GAsConstructor ctor s s a a
47type GAsConstructor' ctor s a = GAsConstructor ctor s s a a
45
48
46instance
49instance
47− ( GCollectible f as
50+ ( GIsList Type f f as as
48− , GCollectible g bs
51+ , GIsList Type g g bs bs
49 , ListTuple a as
52 , ListTuple a as
50 , ListTuple b bs
53 , ListTuple b bs
51 ) => GAsConstructor ctor (M1 C ('MetaCons ctor fixity fields) f) (M1 C ('MetaCons ctor fixity fields) g) a b where
54 ) => GAsConstructor ctor (M1 C ('MetaCons ctor fixity fields) f) (M1 C ('MetaCons ctor fixity fields) g) a b where
52
55
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+
54
59
55instance GSumAsConstructor ctor (HasCtorP ctor l) l r l' r' a b => GAsConstructor ctor (l :+: r) (l' :+: r') a b where
60instance GSumAsConstructor ctor (HasCtorP ctor l) l r l' r' a b => GAsConstructor ctor (l :+: r) (l' :+: r') a b where
56 _GCtor = _GSumCtor @ctor @(HasCtorP ctor l)
61 _GCtor = _GSumCtor @ctor @(HasCtorP ctor l)
62+ {-# INLINE _GCtor #-}
57
63
58instance GAsConstructor ctor f f' a b => GAsConstructor ctor (M1 D meta f) (M1 D meta f') a b where
64instance GAsConstructor ctor f f' a b => GAsConstructor ctor (M1 D meta f) (M1 D meta f') a b where
59 _GCtor = mIso . _GCtor @ctor
65 _GCtor = mIso . _GCtor @ctor
66+ {-# INLINE _GCtor #-}
60
67
61class GSumAsConstructor (ctor :: Symbol) (contains :: Bool) l r l' r' a b | ctor l r -> a, ctor l' r' -> b where
68class GSumAsConstructor (ctor :: Symbol) (contains :: Bool) l r l' r' a b | ctor l r -> a, ctor l' r' -> b where
62 _GSumCtor :: Prism ((l :+: r) x) ((l' :+: r') x) a b
69 _GSumCtor :: Prism ((l :+: r) x) ((l' :+: r') x) a b
63
70
64instance GAsConstructor ctor l l' a b => GSumAsConstructor ctor 'True l r l' r a b where
71instance GAsConstructor ctor l l' a b => GSumAsConstructor ctor 'True l r l' r a b where
65 _GSumCtor = left . _GCtor @ctor
72 _GSumCtor = left . _GCtor @ctor
73+ {-# INLINE _GSumCtor #-}
66
74
67instance GAsConstructor ctor r r' a b => GSumAsConstructor ctor 'False l r l r' a b where
75instance GAsConstructor ctor r r' a b => GSumAsConstructor ctor 'False l r l r' a b where
68 _GSumCtor = right . _GCtor @ctor
76 _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 #-}
1{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE KindSignatures #-}
5{-# LANGUAGE KindSignatures #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE PolyKinds #-}
5{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE TypeApplications #-}
9{-# LANGUAGE TypeApplications #-}
7{-# LANGUAGE TypeOperators #-}
10{-# LANGUAGE TypeOperators #-}
@@ -25,50 +28,81 @@ module Data.Generics.Sum.Internal.Subtype
25 ( GAsSubtype (..)
28 ( GAsSubtype (..)
26 ) where
29 ) where
27
30
28−import Data.Generics.Internal.HList
31+import Data.Generics.Product.Internal.List
29import Data.Generics.Sum.Internal.Typed
32import Data.Generics.Sum.Internal.Typed
30
33
31import Data.Kind
34import Data.Kind
32import GHC.Generics
35import GHC.Generics
36+import Data.Generics.Internal.Profunctor.Iso
37+import Data.Generics.Internal.Profunctor.Prism
38+import Data.Generics.Internal.Families.Has
33
39
34-- |As 'AsSubtype' but over generic representations as defined by
40-- |As 'AsSubtype' but over generic representations as defined by
35-- "GHC.Generics".
41-- "GHC.Generics".
36class GAsSubtype (subf :: Type -> Type) (supf :: Type -> Type) where
42class GAsSubtype (subf :: Type -> Type) (supf :: Type -> Type) where
37− ginjectSub :: subf x -> supf x
43+ _GSub :: Prism' (supf x) (subf x)
38− gprojectSub :: supf x -> Either (supf x) (subf x)
39
44
40instance
45instance
41− ( GAsSubtype l supf
46+ ( GSplash sub sup
47+ , GDowncast sub sup
42− , GAsSubtype r supf
48+ ) => GAsSubtype sub sup where
43− ) => GAsSubtype (l :+: r) supf where
49+ _GSub f = (prism _GSplash _GDowncast) f
44−
50+ {-# INLINE[0] _GSub #-}
45− ginjectSub x = case x of
51+
46− L1 l -> ginjectSub l
52+--------------------------------------------------------------------------------
47− R1 r -> ginjectSub r
53+
48− gprojectSub x
54+class GSplash (sub :: Type -> Type) (sup :: Type -> Type) where
49− = case gprojectSub x of
55+ _GSplash :: sub x -> sup x
50− Left _ -> fmap R1 (gprojectSub x)
56+
51− Right y -> Right (L1 y)
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)
52
74
53instance
75instance
54− ( GAsType supf a
76+ ( GIsList () sup sup as as
55− , GCollectible subf as
77+ , GDowncastC (HasPartialTypeP as sub) sub sup
56− , ListTuple a as
78+ ) => GDowncast sub (C1 m sup) where
57− ) => GAsSubtype (C1 meta subf) supf where
79+ _GDowncast (M1 m) = case _GDowncastC @(HasPartialTypeP as sub) m of
58−
80+ Left _ -> Left (M1 m)
59− ginjectSub
81+ Right r -> Right r
60− = ginjectTyped . listToTuple . gtoCollection . unM1
82+
61− gprojectSub
83+instance (GDowncast sub l, GDowncast sub r) => GDowncast sub (l :+: r) where
62− = fmap (M1 . gfromCollection . tupleToList) . gprojectTyped
84+ _GDowncast (L1 x) = case _GDowncast x of
63−
85+ Left _ -> Left (L1 x)
64−instance GAsType supf a => GAsSubtype (S1 meta (Rec0 a)) supf where
86+ Right r -> Right r
65− ginjectSub
87+ _GDowncast (R1 x) = case _GDowncast x of
66− = ginjectTyped @supf . unK1 . unM1
88+ Left _ -> Left (R1 x)
67− gprojectSub
89+ Right r -> Right r
68− = fmap (M1 . K1) . gprojectTyped @supf
90+
69−
91+instance GDowncast sub sup => GDowncast sub (D1 m sup) where
70−instance GAsSubtype subf supf => GAsSubtype (D1 meta subf) supf where
92+ _GDowncast (M1 m) = case _GDowncast m of
71− ginjectSub
93+ Left _ -> Left (M1 m)
72− = ginjectSub . unM1
94+ Right r -> Right r
73− gprojectSub
95+
74− = fmap M1 . gprojectSub
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 #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE KindSignatures #-}
5+{-# LANGUAGE KindSignatures #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE TypeApplications #-}
8+{-# LANGUAGE TypeApplications #-}
9−{-# LANGUAGE TypeFamilies #-}
9+{-# LANGUAGE TypeFamilies #-}
10−{-# LANGUAGE TypeOperators #-}
10+{-# LANGUAGE TypeOperators #-}
11−{-# LANGUAGE UndecidableInstances #-}
11+{-# LANGUAGE UndecidableInstances #-}
12
12
13-----------------------------------------------------------------------------
13-----------------------------------------------------------------------------
14-- |
14-- |
@@ -29,60 +29,39 @@ module Data.Generics.Sum.Internal.Typed
29
29
30import Data.Kind
30import Data.Kind
31import GHC.Generics
31import GHC.Generics
32+import Data.Tagged
32
33
33import Data.Generics.Internal.Families
34import Data.Generics.Internal.Families
34−import Data.Generics.Internal.HList
35+import Data.Generics.Product.Internal.List
36+import Data.Generics.Internal.Profunctor.Iso
35−import Data.Generics.Internal.Lens
37+import Data.Generics.Internal.Profunctor.Prism
36
38
37-- |As 'AsType' but over generic representations as defined by "GHC.Generics".
39-- |As 'AsType' but over generic representations as defined by "GHC.Generics".
38−class GAsType (f :: Type -> Type) a where
40+class GAsType (f :: Type -> Type) (as :: [((), Type)]) where
39− _GTyped :: Prism' (f x) a
41+ _GTyped :: Prism (f x) (f x) (List as) (List as)
40− _GTyped = prism ginjectTyped gprojectTyped
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) #-}
41
47
42− ginjectTyped :: a -> f x
43− gprojectTyped :: f x -> Either (f x) a
44
48
45instance
49instance
46− ( GCollectible f as
50+ ( GIsList () f f as as
47− , ListTuple a as
48− ) => GAsType (M1 C meta f) a where
51+ ) => GAsType (M1 C meta f) as where
52+ _GTyped = mIso . glist @()
49
53
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
54+instance GSumAsType (HasPartialTypeP a l) l r a => GAsType (l :+: r) a where
56− ginjectTyped
55+ _GTyped = _GSumTyped @(HasPartialTypeP a l)
57− = ginjectSumTyped @(HasPartialTypeTupleP a l) @l @r @a
58− gprojectTyped
59− = gprojectSumTyped @(HasPartialTypeTupleP a l) @l @r @a
60
56
61instance GAsType f a => GAsType (M1 D meta f) a where
57instance GAsType f a => GAsType (M1 D meta f) a where
62− ginjectTyped
58+ _GTyped = mIso . _GTyped
63− = M1 . ginjectTyped
64− gprojectTyped
65− = either (Left . M1) Right . gprojectTyped . unM1
66−
67−class GSumAsType (contains :: Bool) l r a where
68− _GSumTyped :: Prism' ((l :+: r) x) a
69− _GSumTyped = prism (ginjectSumTyped @contains) (gprojectSumTyped @contains)
70
59
71− ginjectSumTyped :: a -> (l :+: r) x
60+class GSumAsType (contains :: Bool) l r (a :: [((), Type)]) where
72− gprojectSumTyped :: (l :+: r) x -> Either ((l :+: r) x) a
61+ _GSumTyped :: Prism ((l :+: r) x) ((l :+: r) x) (List a) (List a)
73
62
74instance GAsType l a => GSumAsType 'True l r a where
63instance GAsType l a => GSumAsType 'True l r a where
75− ginjectSumTyped
64+ _GSumTyped = left . _GTyped
76− = L1 . ginjectTyped
77− gprojectSumTyped x
78− = case x of
79− L1 l -> either (Left . L1) Right (gprojectTyped l)
80− R1 _ -> Left x
81
65
82instance GAsType r a => GSumAsType 'False l r a where
66instance GAsType r a => GSumAsType 'False l r a where
83− ginjectSumTyped
67+ _GSumTyped = right . _GTyped
84− = R1 . ginjectTyped
85− gprojectSumTyped x
86− = case x of
87− R1 r -> either (Left . R1) Right (gprojectTyped r)
88− L1 _ -> Left x
src/Data/Generics/Sum/Subtype.hs+11−6
@@ -1,7 +1,9 @@
1{-# LANGUAGE FlexibleContexts #-}
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE MonoLocalBinds #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TypeApplications #-}
5{-# LANGUAGE TypeOperators #-}
7{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE TypeSynonymInstances #-}
8{-# LANGUAGE TypeSynonymInstances #-}
7{-# LANGUAGE UndecidableInstances #-}
9{-# LANGUAGE UndecidableInstances #-}
@@ -26,11 +28,12 @@ module Data.Generics.Sum.Subtype
26 AsSubtype (..)
28 AsSubtype (..)
27 ) where
29 ) where
28
30
29−import Data.Generics.Internal.Lens
30import Data.Generics.Internal.Void
31import Data.Generics.Internal.Void
31import Data.Generics.Sum.Internal.Subtype
32import Data.Generics.Sum.Internal.Subtype
32
33
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
34
37
35-- $setup
38-- $setup
36-- == /Running example:/
39-- == /Running example:/
@@ -39,7 +42,7 @@ import GHC.Generics (Generic (Rep, to, from))
39-- >>> :set -XDataKinds
42-- >>> :set -XDataKinds
40-- >>> :set -XDeriveGeneric
43-- >>> :set -XDeriveGeneric
41-- >>> import GHC.Generics
44-- >>> import GHC.Generics
42−-- >>> :m +Data.Generics.Internal.Lens
45+-- >>> :m +Data.Generics.Internal.VL.Prism
43-- >>> :{
46-- >>> :{
44-- data Animal
47-- data Animal
45-- = Dog Dog
48-- = Dog Dog
@@ -90,11 +93,13 @@ class AsSubtype sub sup where
90
93
91 -- |Injects a subtype into a supertype (upcast).
94 -- |Injects a subtype into a supertype (upcast).
92 injectSub :: sub -> sup
95 injectSub :: sub -> sup
96+ injectSub = build (_Sub @sub @sup)
93
97
94 -- |Projects a subtype from a supertype (downcast).
98 -- |Projects a subtype from a supertype (downcast).
95 projectSub :: sup -> Either sup sub
99 projectSub :: sup -> Either sup sub
100+ projectSub = match (_Sub @sub @sup)
96
101
97− {-# MINIMAL injectSub, projectSub #-}
102+ {-# MINIMAL (injectSub, projectSub) | _Sub #-}
98
103
99instance
104instance
100 ( Generic sub
105 ( Generic sub
@@ -102,8 +107,8 @@ instance
102 , GAsSubtype (Rep sub) (Rep sup)
107 , GAsSubtype (Rep sub) (Rep sup)
103 ) => AsSubtype sub sup where
108 ) => AsSubtype sub sup where
104
109
105− injectSub = to . ginjectSub . from
110+ _Sub f = prismRavel (repIso . _GSub . fromIso repIso) f
106− projectSub = either (Left . to) (Right . to) . gprojectSub . from
111+ {-# INLINE[2] _Sub #-}
107
112
108-- See Note [Uncluttering type signatures]
113-- See Note [Uncluttering type signatures]
109instance {-# OVERLAPPING #-} AsSubtype a Void where
114instance {-# OVERLAPPING #-} AsSubtype a Void where
src/Data/Generics/Sum/Typed.hs+16−10
@@ -1,3 +1,4 @@
1+{-# LANGUAGE TypeApplications #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
@@ -35,15 +36,18 @@ import GHC.TypeLits (TypeError, ErrorMessage (..), Symbol)
35import Data.Generics.Sum.Internal.Typed
36import Data.Generics.Sum.Internal.Typed
36
37
37import Data.Generics.Internal.Families
38import Data.Generics.Internal.Families
38−import Data.Generics.Internal.Lens
39import Data.Generics.Internal.Void
39import 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)
40
44
41-- $setup
45-- $setup
42-- >>> :set -XTypeApplications
46-- >>> :set -XTypeApplications
43-- >>> :set -XDataKinds
47-- >>> :set -XDataKinds
44-- >>> :set -XDeriveGeneric
48-- >>> :set -XDeriveGeneric
45-- >>> import GHC.Generics
49-- >>> import GHC.Generics
46−-- >>> :m +Data.Generics.Internal.Lens
50+-- >>> :m +Data.Generics.Internal.VL.Prism
47-- >>> :{
51-- >>> :{
48-- data Animal
52-- data Animal
49-- = Dog Dog
53-- = Dog Dog
@@ -87,22 +91,24 @@ class AsType a s where
87
91
88 -- |Inject by type.
92 -- |Inject by type.
89 injectTyped :: a -> s
93 injectTyped :: a -> s
94+ injectTyped
95+ = build _Typed
90
96
91 -- |Project by type.
97 -- |Project by type.
92 projectTyped :: s -> Maybe a
98 projectTyped :: s -> Maybe a
99+ projectTyped
100+ = either (const Nothing) Just . match _Typed
93
101
94instance
102instance
95 ( Generic s
103 ( Generic s
96− , ErrorUnlessOne a s (CollectPartialType a (Rep s))
104+ , ErrorUnlessOne a s (CollectPartialType as (Rep s))
105+ , as ~ TupleToList a
106+ , ListTuple a as
97− , GAsType (Rep s) a
107+ , GAsType (Rep s) as
98 ) => AsType a s where
108 ) => AsType a s where
99
109
100− _Typed
110+ _Typed eta = prismRavel (prismPRavel (repIso . _GTyped @_ @as . tupled)) eta
101− = repIso . _GTyped
111+ {-# INLINE _Typed #-}
102− injectTyped
103− = to . ginjectTyped
104− projectTyped
105− = either (const Nothing) Just . gprojectTyped . from
106
112
107-- See Note [Uncluttering type signatures]
113-- See Note [Uncluttering type signatures]
108instance {-# OVERLAPPING #-} AsType a Void where
114instance {-# OVERLAPPING #-} AsType a Void where
stack.yaml+2−2
@@ -1,10 +1,10 @@
1−resolver: lts-9.2
1+resolver: lts-10.3
2
2
3packages:
3packages:
4- '.'
4- '.'
5
5
6extra-deps:
6extra-deps:
7−- 'inspection-testing-0.1.1.2'
7+- 'inspection-testing-0.2'
8
8
9flags: {}
9flags: {}
10
10
test/Spec.hs+127−12
@@ -1,4 +1,5 @@
1{-# OPTIONS_GHC -O -fplugin Test.Inspection.Plugin #-}
1{-# OPTIONS_GHC -O -fplugin Test.Inspection.Plugin #-}
2+{-# OPTIONS_GHC -dsuppress-all #-}
2
3
3{-# LANGUAGE AllowAmbiguousTypes #-}
4{-# LANGUAGE AllowAmbiguousTypes #-}
4{-# LANGUAGE DataKinds #-}
5{-# LANGUAGE DataKinds #-}
@@ -14,10 +15,25 @@ module Main where
14
15
15import GHC.Generics
16import GHC.Generics
16import Data.Generics.Product
17import Data.Generics.Product
18+import Data.Generics.Sum
17import Test.Inspection
19import 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 ()
18
30
19main :: IO ()
31main :: 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
21
37
22data Record = MkRecord
38data Record = MkRecord
23 { fieldA :: Int
39 { fieldA :: Int
@@ -33,11 +49,21 @@ data Record3 a = MkRecord3
33 , fieldB :: Bool
49 , fieldB :: Bool
34 } deriving (Generic, Show)
50 } deriving (Generic, Show)
35
51
36−type Lens' s a = Lens s s a a
52+data Record4 a = MkRecord4
37−type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t
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+
38
66
39−fieldALensManual :: Lens' Record Int
40−fieldALensManual f (MkRecord a b) = (\a' -> MkRecord a' b) <$> f a
41
67
42typeChangingManual :: Lens (Record3 a) (Record3 b) a b
68typeChangingManual :: Lens (Record3 a) (Record3 b) a b
43typeChangingManual f (MkRecord3 a b) = (\a' -> MkRecord3 a' b) <$> f a
69typeChangingManual f (MkRecord3 a b) = (\a' -> MkRecord3 a' b) <$> f a
@@ -47,12 +73,73 @@ typeChangingManualCompose = typeChangingManual . typeChangingManual
47
73
48newtype L s a = L (Lens' s a)
74newtype L s a = L (Lens' s a)
49
75
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+
50subtypeLensManual :: Lens' Record Record2
86subtypeLensManual :: Lens' Record Record2
51subtypeLensManual f record
87subtypeLensManual f record
52 = fmap (\ds -> case record of
88 = fmap (\ds -> case record of
53 MkRecord _ b -> MkRecord (case ds of {MkRecord2 g1 -> g1}) b
89 MkRecord _ b -> MkRecord (case ds of {MkRecord2 g1 -> g1}) b
54 ) (f (MkRecord2 (case record of {MkRecord a _ -> a})))
90 ) (f (MkRecord2 (case record of {MkRecord a _ -> a})))
55
91
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+
56--------------------------------------------------------------------------------
143--------------------------------------------------------------------------------
57-- * Tests
144-- * Tests
58-- The inspection-testing plugin checks that the following equalities hold, by
145-- The inspection-testing plugin checks that the following equalities hold, by
@@ -81,10 +168,38 @@ typeChangingGenericPos = position @1
81typeChangingGenericCompose :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b
168typeChangingGenericCompose :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b
82typeChangingGenericCompose = field @"fieldA" . field @"fieldA"
169typeChangingGenericCompose = field @"fieldA" . field @"fieldA"
83
170
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
84−inspect $ 'fieldALensManual === 'fieldALensName
191+ [ $(inspectTest $ 'fieldALensManual === 'fieldALensName)
85−inspect $ 'fieldALensManual === 'fieldALensType
192+ , $(inspectTest $ 'fieldALensManual === 'fieldALensType)
86−inspect $ 'fieldALensManual === 'fieldALensPos
193+ , $(inspectTest $ 'fieldALensManual === 'fieldALensPos)
87−inspect $ 'subtypeLensManual === 'subtypeLensGeneric
194+ , $(inspectTest $ 'subtypeLensManual === 'subtypeLensGeneric)
88−inspect $ 'typeChangingManual === 'typeChangingGeneric
195+ , $(inspectTest $ 'typeChangingManual === 'typeChangingGeneric)
89−inspect $ 'typeChangingManual === 'typeChangingGenericPos
196+ , $(inspectTest $ 'typeChangingManual === 'typeChangingGenericPos)
90−inspect $ 'typeChangingManualCompose === 'typeChangingGenericCompose
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 @@
1{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications #-}
1{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications #-}
2
2
3−module Main where
3+module Test24 where
4
4
5-- Test case from #24, comments preserved
5-- Test case from #24, comments preserved
6import Control.Lens
6import Control.Lens
test/25.hs → test/Test25.hsrenamed+1−1
@@ -4,7 +4,7 @@
4{-# LANGUAGE DeriveGeneric #-}
4{-# LANGUAGE DeriveGeneric #-}
5{-# OPTIONS_GHC -Wall #-}
5{-# OPTIONS_GHC -Wall #-}
6
6
7−module Main where
7+module Test25 where
8
8
9import Control.Lens
9import Control.Lens
10import Data.Generics.Product
10import 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+