git.iko.soy/generic-lens
on 78f4bd7 help sign in
17e35a2
swap
0 ahead, 261 behind
.github/FUNDING.ymldeleted−12
since splitsnapshots
unifiedsplit
@@ -1,12 +0,0 @@
1−# These are supported funding model platforms
2−
3−github: [kcsongor] # Replace with up to 4 GitHub Sponsors-enabled usernames e.g., [user1, user2]
4−patreon: # Replace with a single Patreon username
5−open_collective: # Replace with a single Open Collective username
6−ko_fi: # Replace with a single Ko-fi username
7−tidelift: # Replace with a single Tidelift platform-name/package-name e.g., npm/babel
8−community_bridge: # Replace with a single Community Bridge project-name e.g., cloud-foundry
9−liberapay: # Replace with a single Liberapay username
10−issuehunt: # Replace with a single IssueHunt username
11−otechie: # Replace with a single Otechie username
12−custom: # Replace with up to 4 custom sponsorship URLs e.g., ['link1', 'link2']
.gitignore−10
@@ -1,12 +1,2 @@
1−tags
2dist*
1dist*
3.stack-work
2.stack-work
4−.cabal-sandbox
5−cabal.sandbox.config
6−.ghc*
7−*.hi
8−*.o
9−core-html
10−*~
11−*.org
12−cabal.project.local
.travis.yml+16−152
@@ -1,155 +1,19 @@
1−# This Travis job script has been generated by a script via
1+sudo: false
2−#
2+
3−# haskell-ci '--config=cabal.haskell-ci' 'cabal.project'
4−#
5−# For more information, see https://github.com/haskell-CI/haskell-ci
6−#
7−# version: 0.5.20190908
8−#
9language: c
3language: c
10−dist: xenial
4+
11−git:
5+addons:
12− # whether to recursively clone submodules
6+ apt:
13− submodules: false
7+ packages:
14−cache:
8+ - libgmp-dev
15− directories:
9+
16− - $HOME/.cabal/packages
17− - $HOME/.cabal/store
18−before_cache:
19− - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log
20− # remove files that are regenerated by 'cabal update'
21− - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*
22− - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json
23− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache
24− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar
25− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx
26− - rm -rfv $CABALHOME/packages/head.hackage
27−matrix:
28− include:
29− - compiler: ghc-8.8.1
30− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}}
31− - compiler: ghc-8.6.5
32− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-3.0"]}}
33− - compiler: ghc-8.4.4
34− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-3.0"]}}
35− - compiler: ghc-8.4.1
36− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.1","cabal-install-3.0"]}}
37− - compiler: ghc-8.2.2
38− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-3.0"]}}
39− - compiler: ghc-8.0.2
40− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-3.0"]}}
41before_install:
10before_install:
42− - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')
11+- mkdir -p ~/.local/bin
43− - WITHCOMPILER="-w $HC"
12+- export PATH=$HOME/.local/bin:$PATH
44− - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//')
13+- travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
45− - HCPKG="$HC-pkg"
14+
46− - unset CC
15+script: stack --no-terminal --install-ghc test
47− - CABAL=/opt/ghc/bin/cabal
48− - CABALHOME=$HOME/.cabal
49− - export PATH="$CABALHOME/bin:$PATH"
50− - TOP=$(pwd)
51− - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')"
52− - echo $HCNUMVER
53− - CABAL="$CABAL -vnormal+nowrap+markoutput"
54− - set -o pipefail
55− - |
56− echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk
57− echo 'BEGIN { state = "output"; }' >> .colorful.awk
58− echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk
59− echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk
60− echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk
61− echo ' if (state == "cabal") {' >> .colorful.awk
62− echo ' print blue($0)' >> .colorful.awk
63− echo ' } else {' >> .colorful.awk
64− echo ' print $0' >> .colorful.awk
65− echo ' }' >> .colorful.awk
66− echo '}' >> .colorful.awk
67− - cat .colorful.awk
68− - |
69− color_cabal_output () {
70− awk -f $TOP/.colorful.awk
71− }
72− - echo text | color_cabal_output
73−install:
74− - ${CABAL} --version
75− - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
76− - TEST=--enable-tests
77− - if [ $HCNUMVER -ge 80600 ] ; then TEST=--disable-tests ; fi
78− - BENCH=--enable-benchmarks
79− - if [ $HCNUMVER -ge 80800 ] ; then BENCH=--disable-benchmarks ; fi
80− - HEADHACKAGE=false
81− - rm -f $CABALHOME/config
82− - |
83− echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config
84− echo "remote-build-reporting: anonymous" >> $CABALHOME/config
85− echo "write-ghc-environment-files: always" >> $CABALHOME/config
86− echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config
87− echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config
88− echo "world-file: $CABALHOME/world" >> $CABALHOME/config
89− echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config
90− echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config
91− echo "installdir: $CABALHOME/bin" >> $CABALHOME/config
92− echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config
93− echo "store-dir: $CABALHOME/store" >> $CABALHOME/config
94− echo "install-dirs user" >> $CABALHOME/config
95− echo " prefix: $CABALHOME" >> $CABALHOME/config
96− echo "repository hackage.haskell.org" >> $CABALHOME/config
97− echo " url: http://hackage.haskell.org/" >> $CABALHOME/config
98− - |
99− echo "program-default-options" >> $CABALHOME/config
100− echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config
101− - cat $CABALHOME/config
102− - rm -fv cabal.project cabal.project.local cabal.project.freeze
103− - travis_retry ${CABAL} v2-update -v
104− # Generate cabal.project
105− - rm -rf cabal.project cabal.project.local cabal.project.freeze
106− - touch cabal.project
107− - |
108− echo "packages: ." >> cabal.project
109− - |
110− - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(generic-lens)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
111− - cat cabal.project || true
112− - cat cabal.project.local || true
113− - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi
114− - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output
115− - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"
116− - rm cabal.project.freeze
117− - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all | color_cabal_output
118− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all | color_cabal_output
119−script:
120− - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
121− # Packaging...
122− - ${CABAL} v2-sdist all | color_cabal_output
123− # Unpacking...
124− - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
125− - cd ${DISTDIR} || false
126− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \;
127− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \;
128− - PKGDIR_generic_lens="$(find . -maxdepth 1 -type d -regex '.*/generic-lens-[0-9.]*')"
129− # Generate cabal.project
130− - rm -rf cabal.project cabal.project.local cabal.project.freeze
131− - touch cabal.project
132− - |
133− echo "packages: ${PKGDIR_generic_lens}" >> cabal.project
134− - |
135− - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(generic-lens)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
136− - cat cabal.project || true
137− - cat cabal.project.local || true
138− # Building...
139− # this builds all libraries and executables (without tests/benchmarks)
140− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output
141− # Building with tests and benchmarks...
142− # build & run tests, build benchmarks
143− - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output
144− # Testing...
145− - if [ $HCNUMVER -lt 80600 ] ; then ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi
146− # cabal check...
147− - (cd ${PKGDIR_generic_lens} && ${CABAL} -vnormal check)
148− # haddock...
149− - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all | color_cabal_output
150− # Building without installed constraints for packages in global-db...
151− - rm -f cabal.project.local
152− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output
153
16
154−# REGENDATA ["--config=cabal.haskell-ci","cabal.project"]
17+cache:
155−# EOF
18+ directories:
19+ - $HOME/.stack
ChangeLog.md+3−55
@@ -1,57 +1,5 @@
1−## 1.2.0.1
1+# Revision history for generic-lens
2−- Give HasAny/AsAny the same VTA behavior on 8.6 and 8.8 (Ryan Scott)
3
2
4−## 1.2.0.0
3+## 0.1.0.0 -- YYYY-mm-dd
5−- Add `HasTypesUsing` and `HasTypesCustom` for custom traversals (Lysxia)
6−- Improve type errors when no Generic instance is defined
7−- `types` now supports Text by default
8
4
9−### Breaking API changes
5+* First version. Released on an unsuspecting world.
10−- `HasType` now includes a reflexive case so that every type 'contains' itself (Matt Parsons)
11−- `AsSubtype` and `Subtype` now include a reflexive case so that every type is a subtype of itself
12−
13−## 1.1.0.0
14−- Fix regression in type inference for polymorphic optics
15−- Add `HasField0`, `HasPosition0`, `AsConstructor0`, `HasField_`, `HasPositon_`, and `AsConstructor_` (Lysxia)
16−- `types` now supports Data.Word and Data.Int (Lysxia)
17−- Add `Wrapped` iso for newtypes (Isaac Elliott)
18−- Expose internals through Data.GenericLens.Internal
19−- Add labels for prisms (Daniel Winograd-Cort)
20−
21−## 1.0.0.2
22−- Fix compile-time performance regression
23−
24−## 1.0.0.1
25−- Remove dump-core dependency
26−- Relax upper bound on criterion (#42)
27−
28−## 1.0.0.0
29−- Traversals (types, param, constraints)
30−- Prisms are now optimal too
31−- Monomorphic versions of lenses and prisms also included
32−
33−### Breaking API changes
34−- `projectSub` now returns `Maybe sub` instead of `Either sup sub` (#21)
35−
36−## 0.5.1.0
37−- Infer input type from result type (#25)
38−- Allow changing of multiple type parameters (#24)
39−- Allow changing of type parameters that have kinds other than `*` (#23)
40−- Fix error message in subtype lens
41−
42−## 0.5.0.0
43−
44−- Lenses and prisms are now type-changing.
45−- More informative error messages
46−- More readable type signatures in type errors and when using `:t`
47−- Use `doctest`
48−- Include examples in Haddock
49−
50−### Breaking API changes
51−
52−- The type parameters of the classes have been changed to accommodate
53− the type-changing update:
54−
55− `class HasField name a s` -> `class HasField name s t a b` etc.
56−
57− Accordingly, `field :: Lens' s a` -> `field :: Lens s t a b`
LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2019, Csongor Kiss
1+Copyright (c) 2017, Csongor Kiss
2
2
3All rights reserved.
3All rights reserved.
4
4
README.md+44−334
@@ -1,207 +1,86 @@
1# generic-lens
1# generic-lens
2
2
3+[![Build
3−[![Build Status](https://travis-ci.org/kcsongor/generic-lens.svg?branch=master)](https://travis-ci.org/kcsongor/generic-lens)
4+Status](https://travis-ci.org/kcsongor/generic-lens.svg?branch=master)](https://travis-ci.org/kcsongor/generic-lens)
4−[![Hackage](https://img.shields.io/hackage/v/generic-lens.svg)](https://hackage.haskell.org/package/generic-lens)
5
5
6−Generically derive traversals, lenses and prisms.
6+Generically derive lenses for accessing fields of data types.
7
7
8Available on [Hackage](https://hackage.haskell.org/package/generic-lens)
8Available on [Hackage](https://hackage.haskell.org/package/generic-lens)
9
9
10−This library uses `GHC.Generics` to derive efficient optics (traversals, lenses
10+This package uses the GHC 8 Generic representation to derive various operations on data structures with a lens interface, including structural subtype relationship between records and positional indexing into arbitrary product types.
11−and prisms) for algebraic data types in a type-directed way, with a focus on
12−good type inference and error messages when possible.
13−
14−The derived optics use the so-called van Laarhoven representation, thus are
15−fully interoperable with the combinators found in mainstream lens libraries.
16−
17−Examples can be found in the `examples` and `tests` folders.
18−
19−The library is described in the paper:
20−> Csongor Kiss, Matthew Pickering, and Nicolas Wu. 2018. Generic deriving of generic traversals. Proc. ACM Program. Lang. 2, ICFP, Article 85 (July 2018), 30 pages. DOI: https://doi.org/10.1145/3236780
21−
22−Table of contents
23−=================
24−
25−* [Preliminaries](#preliminaries)
26−* [Taxonomy of optics](#taxonomy-of-optics)
27− * [Lenses](#lenses)
28− * [By name](#by-name)
29− * [By position](#by-position)
30− * [By type](#by-type)
31− * [By structure](#by-structure)
32− * [Traversals](#traversals)
33− * [By type](#by-type-1)
34− * [By parameter](#by-parameter)
35− * [By constraint](#by-constraint)
36− * [Prisms](#prisms)
37− * [By name](#by-name-1)
38− * [By type](#by-type-2)
39−* [Performance](#performance)
40− * [Inspection testing](#inspection-testing)
41− * [Benchmarks](#benchmarks)
42−* [Contributors](#contributors)
43−
44−# Preliminaries
45−A typical module using `generic-lens` will usually have the following
46−extensions turned on:
47−```haskell
48−{-# LANGUAGE AllowAmbiguousTypes #-}
49−{-# LANGUAGE DataKinds #-}
50−{-# LANGUAGE DeriveGeneric #-}
51−{-# LANGUAGE DuplicateRecordFields #-}
52−{-# LANGUAGE FlexibleContexts #-}
53−{-# LANGUAGE NoMonomorphismRestriction #-}
54−{-# LANGUAGE TypeApplications #-}
55
11
56−```
12+This is made possible by GHC-8's new Generics API, which provides the meta-data
13+at the type-level (previously only value-level meta-data was available).
57
14
58−# Taxonomy of optics
15+An example can be found in the `examples` folder.
59−Here is a comprehensive list of the optics exposed by `generic-lens`. The
60−combinators each allow a different way of identifying certain parts of
61−algebraic data types.
62
16
63−## Lenses
17+(The library makes heavy use of [Visible Type Applications](https://ghc.haskell.org/trac/ghc/wiki/TypeApplication))
64
18
65−A lens identifies exactly one part of a product type, and allows querying and
19+## Record fields
66−updating it.
67
20
68−### By name
21+Record fields can be accessed by their label.
69
22
70```haskell
23```haskell
71−data Person = Person { name :: String, age :: Int } deriving (Generic, Show)
24+data Person = Person { name :: String, age :: Int } deriving (Show, Generic)
72
25
73sally :: Person
26sally :: Person
74sally = Person "Sally" 25
27sally = Person "Sally" 25
75```
28```
76
29
77−Record fields can be accessed by their label using the `field` lens.
78−
79−```haskell
80−>>> sally ^. field @"name"
81−"Sally"
82−
83−>>> sally & field @"name" .~ "Tamas"
84−Person {name = "Tamas", age = 25}
85−```
86−Here we use [visible type application](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#visible-type-application)
87−to specify which field we're interested in, and use the `^.` and `.~` combinators from a lens library
88−([lens](https://hackage.haskell.org/package/lens), [microlens](https://hackage.haskell.org/package/microlens), etc.)
89−to query and update the field.
90−
91−Or for standalone use, the `getField` and `setField` functions can be used instead.
92```haskell
30```haskell
93>>> getField @"age" sally
31>>> getField @"age" sally
9425
3225
95
33
96>>> setField @"age" 26 sally
34>>> setField @"age" 26 sally
97−Person {name = "Sally", age = 26}
35+Person { name = "Sally", age = 26 }
98−```
99−
100−When a non-existent field is requested, the library generates a helpful type error:
101−```haskell
102−>>> sally ^. field @"pet"
103−error:
104− • The type Person does not contain a field named 'pet'
105−```
106−
107−For types with multiple constructors, we can still use `field` as long as all constructors contain the required field
108−```haskell
109−data Two
110− = First { wurble :: String, banana :: Int }
111− | Second { wurble :: String }
112− deriving (Generic, Show)
113−
114−>>> Second "woops" ^. field @"wurble"
115−"woops"
116−>>> Second "woops" ^. field @"banana"
117− ...
118− • Not all constructors of the type Two
119− contain a field named 'banana'.
120− The offending constructors are:
121− • Second
122− ...
123−```
124−
125−The type of `field` is
126−```haskell
127−field :: HasField name s t a b => Lens s t a b
128−```
129−Therefore it allows polymorphic (type-changing) updates, when the accessed field mentions type parameters.
130
36
131−```haskell
37+>>> sally ^. label @"name"
132−data Foo f a = Foo
38+"Sally"
133− { foo :: f a
134− } deriving (Generic, Show)
135
39
136−foo1 :: Foo Maybe Int
40+>>> sally & label @"name" .~ "Tamas"
137−foo1 = Foo (Just 10)
41+Person { name = "Tamas", age = 25 }
138
42
139−-- |
140−-- >>> foo2
141−-- Foo {foo = ["10"]}
142−foo2 :: Foo [] String
143−foo2 = foo1 & field @"foo" %~ (maybeToList . fmap show)
144```
43```
145−This example shows that higher-kinded parameters can also be changed (`Maybe`
146−-> `[]`). We turn a `Foo Maybe Int` into a `Foo [] String` by turning the inner
147−`Maybe Int` into a `[String]`.
148
44
149−With `DuplicateRecordFields`, multiple data types can share the same field
45+## Positional fields
150−name, and the `field` lens works in this case too. No more field name
151−prefixing!
152
46
153−### By position
154−
155−Fields can be accessed by their position in the data structure (index starting at 1):
47+Fields can be accessed by their position in the data structure (index starting at 1).
156
48
157```haskell
49```haskell
158−data Point = Point Int Int Int deriving (Generic, Show)
50+data Point = Point Int Int Int deriving (Show, Generic)
159−data Polygon = Polygon Point Point Point deriving (Generic, Show)
51+data Polygon = Polygon Point Point Point deriving (Show, Generic)
160
52
161polygon :: Polygon
53polygon :: Polygon
162polygon = Polygon (Point 1 5 3) (Point 2 4 2) (Point 5 7 (-2))
54polygon = Polygon (Point 1 5 3) (Point 2 4 2) (Point 5 7 (-2))
163```
55```
164
56
165```haskell
57```haskell
166−>>> polygon ^. position @1 . position @2
58+
59+>>> getFieldAt @2 polygon
60+Point 2 4 2
61+
62+>>> setFieldAt @1 (Point 26 5 3) polygon
63+Polygon (Point 26 5 3) (Point 2 4 2) (Point 5 7 (-2))
64+
65+>>> polygon ^. itemAt @1 . itemAt @2
1675
665
168
67
169−>>> polygon & position @3 . position @2 %~ (+10)
68+>>> polygon & itemAt @3 . itemAt @2 %~ (+10)
170Polygon (Point 1 5 3) (Point 2 4 2) (Point 5 17 (-2))
69Polygon (Point 1 5 3) (Point 2 4 2) (Point 5 17 (-2))
171
70
172−>>> polygon ^. position @10
173−error:
174− • The type Polygon does not contain a field at position 10
175```
71```
176
72
177−Since tuples are an instance of `Generic`, the positional lens readily works:
73+Since tuples are an instance of Generic, positional lenses can be used with them.
178
74
179```haskell
75```haskell
180−>>> (("hello", True), 5) ^. position @1 . position @2
76+>>> (("hello", True), 5) ^. itemAt @1 . itemAt @2
181True
77True
182−>>> (("hello", True, "or"), 5, "even", "longer") ^. position @1 . position @2
183−True
184−```
185−
186−### By type
187−
188−Fields can be accessed by their type in the data structure, assuming that this
189−type is unique:
190−
191−```haskell
192−>>> sally ^. typed @String
193−"Sally"
194−
195−>>> setTyped @Int sally 26
196−Person {name = "Sally", age = 26}
197```
78```
198
79
199−### By structure
80+## Structural subtyping
200
81
201−The `super` lens generalises the `field` lens to focus on a collection rather
202−than a single field.
203−We can say that a record is a (structural) `subtype' of another, if its fields
82+A record is a (structural) `subtype' of another, if its fields are a superset of
204−are a superset of those of the other.
83+those of the other.
205
84
206```haskell
85```haskell
207data Human = Human
86data Human = Human
@@ -216,15 +95,21 @@ data Animal = Animal
216 } deriving (Generic, Show)
95 } deriving (Generic, Show)
217
96
218human :: Human
97human :: Human
219−human = Human {name = "Tunyasz", age = 50, address = "London"}
98+human = Human { name = "Tunyasz", age = 50, address = "London" }
220```
99```
221
100
222```haskell
101```haskell
223−>>> human ^. super @Animal
224−Animal {name = "Tunyasz", age = 50}
225
102
226>>> upcast human :: Animal
103>>> upcast human :: Animal
227Animal {name = "Tunyasz", age = 50}
104Animal {name = "Tunyasz", age = 50}
105+
106+-- 'smash' plug the smaller structure into the larger one
107+>>> smash (Animal "dog" 10) human
108+Human {name = "dog", age = 10, address = "London"}
109+
110+-- 'super' is a lens that focuses on a subrecord of a larger record:
111+>>> human ^. super @Animal
112+Animal {name = "Tunyasz", age = 50}
228```
113```
229
114
230We can apply a function that operates on a supertype to the larger (subtype)
115We can apply a function that operates on a supertype to the larger (subtype)
@@ -238,181 +123,6 @@ growUp (Animal name age) = Animal name (age + 50)
238Human {name = "Tunyasz", age = 60, address = "London"}
123Human {name = "Tunyasz", age = 60, address = "London"}
239```
124```
240
125
241−## Traversals
242−
243−Traversals allow multiple values to be queried or updated at the same time.
244−
245−As a running example, consider a data type of weighted trees. There are two
246−type parameters, which correspond to the type of elements and weights in the
247−tree:
248−```haskell
249−data WTree a w
250− = Leaf a
251− | Fork (WTree a w) (WTree a w)
252− | WithWeight (WTree a w) w
253− deriving (Generic, Show)
254−
255−mytree :: WTree Int Int
256−mytree = Fork (WithWeight (Leaf 42) 1)
257− (WithWeight (Fork (Leaf 88) (Leaf 37)) 2)
258−```
259−
260−### By type
261−Focus on all values of a given type.
262−
263−```haskell
264−types :: HasTypes s a => Traversal' s a
265−```
266−
267−```haskell
268−>>> toListOf (types @Int) myTree
269−[42,1,88,37,2]
270−```
271−
272−Note that this traversal is "deep": the subtrees are recursively traversed.
273−
274−### By parameter
275−As the above example shows, the `types` traversal is limited in that it cannot
276−distinguish between the two types of `Int`s: the weights and the values.
277−
278−Instead, the `param` traversal allows specifying types that correspond to a
279−certain type parameter.
280−```haskell
281−param :: HasParam pos s t a b => Traversal s t a b
282−```
283−
284−```haskell
285−>>> toListOf (param @1) myTree
286−[42,88,37]
287−```
288−
289−Here, the numbering starts from 0, with 0 being the rightmost parameter.
290−Because `param` is guaranteed to focus on parametric values, it allows the type
291−to be changed as well.
292−
293−For example, we can implement `Functor` for `WTree` as simply as:
294−
295−```haskell
296−instance Functor (WTree a) where
297− fmap = over (param @0)
298−```
299−
300−### By constraint
301−The most general type of traversal: we can apply a given function to every
302−value in a structure, by requiring that all values have an instance for some
303−type class.
304−
305−```haskell
306−constraints :: HasConstraints c s t => Applicative g => (forall a b . c a b => a -> g b) -> s -> g t
307−constraints' :: HasConstraints' c s => Applicative g => (forall a . c a => a -> g a) -> s -> g s
308−```
309−
310−Consider the `Numbers` type, which contains three different numeric types:
311−```haskell
312−data Numbers = Numbers Int Float Double
313− deriving (Show, Generic)
314−
315−numbers = Numbers 10 20.0 30.0
316−```
317−
318−With `constraints'`, we can uniformly add 20 to each number in one go:
319−```haskell
320−>>> constraints' @Num (\x -> pure (x + 20)) numbers
321−Numbers 30 40.0 50.0
322−```
323−
324−## Prisms
325−
326−A prism focuses on one part of a sum type (which might not be present). Other
327−than querying the type, they can be "turned around" to inject the data into the
328−sum (like a constructor).
329−
330−### By name
331−
332−Constructor components can be accessed using the constructor's name:
333−
334−```haskell
335−type Name = String
336−type Age = Int
337−
338−data Dog = MkDog { name :: Name, age :: Age } deriving (Generic, Show)
339−data Animal = Dog Dog | Cat Name Age | Duck Age deriving (Generic, Show)
340−
341−shep = Dog (MkDog "Shep" 4)
342−mog = Cat "Mog" 5
343−donald = Duck 4
344−```
345−
346−```haskell
347−>>> shep ^? _Ctor @"Dog"
348−Just (MkDog {name = "Shep", age = 4})
349−
350−>>> shep ^? _Ctor @"Cat"
351−Nothing
352−```
353−
354−Constructors with multiple fields can be focused as a tuple
355−
356−```
357−>>> mog ^? _Ctor @"Cat"
358−Just ("Mog",5)
359−
360−>>> _Ctor @"Cat" # ("Garfield", 6) :: Animal
361−Cat "Garfield" 6
362−
363−```
364−
365−### By type
366−
367−Constructor components can be accessed using the component's type, assuming
368−that this type is unique:
369−
370−```haskell
371−type Name = String
372−type Age = Int
373−
374−data Dog = MkDog { name :: Name, age :: Age } deriving (Generic, Show)
375−data Animal = Dog Dog | Cat Name Age | Duck Age deriving (Generic, Show)
376−
377−shep = Dog (MkDog "Shep" 4)
378−mog = Cat "Mog" 5
379−donald = Duck 4
380−```
381−
382−```haskell
383−>>> mog ^? _Typed @Dog
384−Nothing
385−
386−>>> shep ^? _Typed @Dog
387−Just (MkDog {name = "Shep", age = 4})
388−
389−>>> donald ^? _Typed @Age
390−Just 4
391−
392−>>> mog ^? _Typed @(Name, Age)
393−("Mog", 5)
394−
395−>>> donald ^? _Typed @Float
396−error:
397− • The type Animal does not contain a constructor whose field is of type Float
398−
399−>>> _Typed @Age # 6 :: Animal
400−Duck 6
401−```
402−
403−# Performance
404−The runtime characteristics of the derived optics is in most cases identical at
405−`-O1`, in some cases only slightly slower than the hand-written version. This
406−is thanks to GHC's optimiser eliminating the generic overhead.
407−
408−The
409−[inspection-testing](https://hackage.haskell.org/package/inspection-testing)
410−library is used to ensure (see [here](test/Spec.hs)) that everything gets
411−inlined away.
412−
413−There is also a [benchmark suite](https://github.com/mpickering/generic-lens-benchmarks) with larger, real-world examples.
414−# Contributors
126+## Contributors
415
127
416−+ [Matthew Pickering](https://github.com/mpickering)
417+ [Toby Shaw](https://github.com/TobyShaw)
128+ [Toby Shaw](https://github.com/TobyShaw)
418−+ [Will Jones](https://github.com/lunaris)
benchmarks/Bench.hsdeleted−64
@@ -1,64 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE NamedFieldPuns #-}
4−{-# LANGUAGE RankNTypes #-}
5−{-# LANGUAGE RecordWildCards #-}
6−{-# LANGUAGE TypeApplications #-}
7−
8−module Main (main) where
9−
10−import Control.DeepSeq
11−import Control.Lens.Operators
12−import Control.Lens.Type
13−import Control.Monad
14−import Criterion.Main
15−import Data.Generics.Product
16−import GHC.Generics
17−import Test.QuickCheck
18−
19−main :: IO ()
20−main = defaultMain
21− [ env (arbitraryAnimalsOfLength 100) $ products 100
22− , env (arbitraryAnimalsOfLength 1000) $ products 1000
23− , env (arbitraryAnimalsOfLength 10000) $ products 10000
24− , env (arbitraryAnimalsOfLength 100000) $ products 100000
25− ]
26−
27−products :: Int -> [Animal] -> Benchmark
28−products n as
29− = bgroup ("products/" ++ show n)
30− [ bench "generic-lens/get" (nf (const $ map (^. field @"name") as) ())
31− , bench "lens/get" (nf (const $ map (^. aName) as) ())
32− , bench "generic-lens/set" (nf (const $ map (\a -> a & field @"name" .~ "Name") as) ())
33− , bench "lens/set" (nf (const $ map (\a -> a & aName .~ "Name") as) ())
34− ]
35−
36−arbitraryAnimalsOfLength :: Int -> IO [Animal]
37−arbitraryAnimalsOfLength n
38− = replicateM n (generate arbitrary)
39−
40−data Animal = Animal
41− { name :: String
42− , age :: Int
43− , eats :: String
44− } deriving (Generic, Show)
45−
46−instance Arbitrary Animal where
47− arbitrary = Animal <$> arbitrary <*> arbitrary <*> arbitrary
48−
49−instance NFData Animal where
50− rnf Animal{..} = rnf name `seq` rnf age `seq` rnf eats
51−
52−aName :: Lens' Animal String
53−aName f Animal{..}
54− = (\x -> Animal { name = x, age, eats }) <$> f name
55−
56−{-
57−aAge :: Lens' Animal Int
58−aAge f Animal{..}
59− = (\x -> Animal { name, age = x, eats }) <$> f age
60−
61−aEats :: Lens' Animal String
62−aEats f Animal{..}
63− = (\x -> Animal { name, age, eats = x }) <$> f eats
64− -}
cabal.haskell-cideleted−5
@@ -1,5 +0,0 @@
1−-- inspection tests fail
2−tests: <8.6
3−
4−-- blocked on vector-th-unbox
5−benchmarks: <8.8
cabal.projectdeleted−2
@@ -1,2 +0,0 @@
1−packages: generic-lens.cabal
2−write-ghc-environment-files: always
examples/Biscuits.hsdeleted−150
@@ -1,150 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE DuplicateRecordFields #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE NoMonomorphismRestriction #-}
6−{-# LANGUAGE TypeApplications #-}
7−
8−module Main where
9−
10−import Control.Lens
11−import Data.Maybe (maybeToList)
12−import Data.Generics.Product
13−import Data.Generics.Sum
14−import GHC.Generics (Generic)
15−
16−-- $setup
17−--
18−-- >>> :set -XTypeApplications
19−-- >>> :set -XDataKinds
20−-- >>> :set -XFlexibleContexts
21−
22−main :: IO ()
23−main = putStrLn "hello"
24−
25−data Item = Item
26− { name :: String
27− , cost :: Cost
28− } deriving (Generic, Show)
29−
30−newtype Cost = Cost Double deriving (Generic, Show)
31−
32−data Invoice p = Invoice
33− { item :: Item
34− , name :: String
35− , number :: Int
36− , priority :: p
37− } deriving (Generic, Show)
38−
39−data Orders = Orders [ Invoice Int ] [ Invoice (Int, Double) ]
40− deriving (Generic, Show)
41−
42−-- |
43−-- >>> view (field @"name") bourbon
44−-- "Bourbon"
45−-- >>> bourbon & field @"cost" .~ Cost 110
46−-- Item {name = "Bourbon", cost = Cost 110.0}
47−--
48−-- >>> bourbon & field @"cost" %~ (\(Cost c) -> (Cost (c + 5)))
49−-- Item {name = "Bourbon", cost = Cost 105.0}
50−--
51−-- >>> Invoice bourbon "Johnny" 2 2 & field @"priority" %~ (\i -> (i, 0))
52−-- Invoice {item = Item {name = "Bourbon", cost = Cost 100.0}, name = "Johnny", number = 2, priority = (2,0)}
53−--
54−-- >>> view (field @"weight") bourbon
55−-- ...
56−-- ... The type Item does not contain a field named 'weight'.
57−-- ...
58−--
59−-- >>> bourbon & typed @Cost .~ Cost 200
60−-- Item {name = "Bourbon", cost = Cost 200.0}
61−--
62−-- >>> bourbon & typed %~ ("Chocolate " ++)
63−-- Item {name = "Chocolate Bourbon", cost = Cost 100.0}
64−--
65−-- >>> view (position @1) (42, "foo")
66−-- 42
67−-- >>> view (position @1) (42, "foo", False)
68−-- 42
69−-- >>> view (position @2) orders
70−-- [Invoice {item = Item {name = "Bourbon", cost = Cost 100.0}, name = "George", number = 2, priority = (0,3.0)}]
71−--
72−-- >>> view (position @2) orders
73−-- [Invoice {item = Item {name = "Bourbon", cost = Cost 100.0}, name = "George", number = 2, priority = (0,3.0)}]
74−--
75−-- >>> view (position @3) orders
76−-- ...
77−-- ... The type Orders does not contain a field at position 3
78−-- ...
79−--
80−-- >>> view (super @Item) (WItem "Bourbon" (Cost 2000) (Weight 0.03))
81−-- Item {name = "Bourbon", cost = Cost 2000.0}
82−--
83−-- >>> (WItem "Bourbon+" (Cost 500) (Weight 0.03)) & super @Item .~ bourbon
84−-- WItem {name = "Bourbon", cost = Cost 100.0, weight = Weight 3.0e-2}
85−--
86−-- >>> DInt 1 ^? _Ctor @"DInt"
87−-- Just 1
88−--
89−-- >>> _Typed # (False, "wurble") :: D
90−-- DPair False "wurble"
91−--
92−-- >>> EChar 'a' ^? _Sub @D
93−-- Nothing
94−--
95−-- >>> _Sub # DInt 10 :: E
96−-- EInt 10
97−bourbon :: Item
98−bourbon = Item "Bourbon" (Cost 100)
99−
100−orders :: Orders
101−orders = Orders [Invoice bourbon "Earl" 1 0 , Invoice bourbon "Johnny" 2 2]
102− [Invoice bourbon "George" 2 (0, 3)]
103−
104−nameOfItem :: Invoice p -> String
105−nameOfItem = view (field @"item" . field @"name")
106−
107−thankYou :: Orders -> Orders
108−thankYou = over (types @Cost) (\(Cost c) -> Cost (c * 0.85))
109−
110−thankYouPriority :: Orders -> Orders
111−thankYouPriority = over (position @2 . types @Cost) (\(Cost c) -> Cost (c * 0.85))
112−
113−upgrade :: Double -> Invoice Int -> Invoice (Int, Double)
114−upgrade bribe invoice = over (param @0) (\i -> (i, bribe)) invoice
115−
116−audit :: Orders -> [Item]
117−audit = toListOf (types @Item)
118−
119−newtype Weight = Weight Double deriving (Generic, Show)
120−data WeighedItem = WItem
121− { name :: String
122− , cost :: Cost
123− , weight :: Weight
124− } deriving (Generic, Show)
125−
126−data D = DInt Int | DPair Bool String
127− deriving (Generic, Show)
128−
129−data E = EInt Int | EPair Bool String | EChar Char
130− deriving (Generic, Show)
131−
132−costInc :: HasTypes t Cost => t -> t
133−costInc = over (types @Cost) (\(Cost c) -> Cost (c + 5))
134−
135−modifyPriority :: (Int -> Int) -> Invoice Int -> Invoice Int
136−modifyPriority = over (types @Int)
137−
138−treeIncParam :: HasParam 0 s s Int Int => s -> s
139−treeIncParam = over (param @0) (+ 1)
140−
141−instance Functor Invoice where
142− fmap = over (param @0)
143−
144−data Numbers = Numbers Int Float Double
145− deriving (Show, Generic)
146−
147−-- |
148−-- >>> constraints' @Num (\x -> pure (x + 20)) numbers
149−-- Numbers 30 40.0 50.0
150−numbers = Numbers 10 20.0 30.0
examples/Examples.hs+25−115
@@ -1,38 +1,16 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DataKinds #-}
1+{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE DeriveGeneric #-}
4−{-# LANGUAGE DuplicateRecordFields #-}
3+{-# LANGUAGE DuplicateRecordFields #-}
5−{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleContexts #-}
6−{-# LANGUAGE GADTs #-}
7−{-# LANGUAGE NoMonomorphismRestriction #-}
8−{-# LANGUAGE OverloadedLabels #-}
9−{-# LANGUAGE PartialTypeSignatures #-}
10−{-# LANGUAGE Rank2Types #-}
11−{-# LANGUAGE ScopedTypeVariables #-}
12−{-# LANGUAGE TypeApplications #-}
5+{-# LANGUAGE TypeApplications #-}
13−{-# LANGUAGE UndecidableInstances #-}
6+{-# LANGUAGE UndecidableInstances #-}
14−{-# OPTIONS_GHC -Wno-missing-signatures #-}
15−{-# OPTIONS_GHC -fno-warn-unused-imports #-}
16
7
17module Examples where
8module Examples where
18
9
19−import Data.Function ((&))
20−import Data.Generics.Internal.VL.Lens
21−import Data.Generics.Product
22−import Data.Generics.Sum
23import GHC.Generics
10import GHC.Generics
24−import Data.Generics.Labels
11+import Data.Generics.Record
25−import Data.Generics.Internal.VL.Iso
12+import Data.Generics.Product
26−import Data.Generics.Internal.VL.Prism
13+import Control.Lens
27−import Data.Generics.Internal.Profunctor.Lens
28−import Data.Generics.Internal.Profunctor.Iso
29−import Data.Generics.Internal.Profunctor.Prism
30−
31−data Animal = Animal
32− { name :: String
33− , age :: Int
34− , eats :: String
35− } deriving (Show, Generic)
36
14
37data Human = Human
15data Human = Human
38 { name :: String
16 { name :: String
@@ -41,92 +19,24 @@ data Human = Human
41 , eats :: String
19 , eats :: String
42 } deriving (Show, Generic)
20 } deriving (Show, Generic)
43
21
44−data Living
22+human :: Human
45− = Animal' { name :: String, eats :: String, age :: Int }
23+human = Human { name = "Tunyasz", age = 10, address = "London", eats = "Bread" }
46− | Human' { name :: String, age :: Int, address :: String, eats :: String }
47− deriving (Show, Generic)
48
24
49−toby :: Human
25+data Animal = Animal
50−toby = Human { name = "Toby", age = 10, address = "London", eats = "Bread" }
26+ { name :: String
27+ , age :: Int
28+ , eats :: String
29+ } deriving (Show, Generic)
51
30
52growUp :: Animal -> Animal
31growUp :: Animal -> Animal
53−growUp (Animal n a _) = Animal n (a + 10) "raw meat"
32+growUp (Animal name age _) = Animal name (age + 10) "raw meat"
54−
55−data MyRecord = MyRecord { field1 :: Int, field2 :: String } deriving Generic
56
33
57−--g :: Subtype s MyRecord => s -> String
34+data WildAnimal = WildAnimal
58−--g s = s ^. super @MyRecord . label @"field2"
59−
60−data Test a b = Test { fieldInt :: Int, fieldA :: a, fieldB :: b } deriving (Generic, Show)
61−
62−-- changedA :: Test Int String
63−-- >>> changedA
64−-- Test {fieldInt = 10, fieldA = 10, fieldB = "world"}
65−changedA = Test 10 "hello" "world" & field @"fieldA" .~ (10 :: Int)
66−
67−-- changedB :: Test String Int
68−-- >>> changedB
69−-- Test {fieldInt = 10, fieldA = "hello", fieldB = 10}
70−changedB = (Test 10 "hello" "world") & field @"fieldB" .~ (10 :: Int)
71−
72−--changedInt = set (field @"fieldInt") ("hello") (Test 10 "hello" "world")
73−-- type error
74−
75−data Animal2 a
76− = Dog (Dog a)
77− | Cat Name Age
78− | Duck Age
79− deriving (Generic, Show)
80−
81−data Dog a
82− = MkDog
83− { name :: Name
84− , age :: Age
85− , fieldA :: a
86− }
87− deriving (Generic, Show)
88−type Name = String
35+ { name :: String
89−type Age = Int
90−dog :: Animal2 Int
91−dog = Dog (MkDog "Shep" 3 30)
92−
93−-- TODO: the error message for this case is ugly
94−-- data Dog a
95−-- = MkDog
96−-- { name :: Name
97−-- , age :: Age
36+ , age :: Int
98−-- , fieldA :: a
37+ , eats :: String
99−-- , fieldA' :: a
38+ , hunts :: Animal
100−-- }
101−-- deriving (Generic, Show)
102−
103−--dog' :: Animal2 String
104−dog' = dog & _Ctor @"Dog" . field @"fieldA" .~ "now it's a String"
105−
106−stuff ::
107− ( HasPosition 15 s t a String
108− , HasField "test" s' t' a' b'
109− , HasField "bar" a' b' s t
110− ) => s' -> t'
111−stuff r = r & field @"test" . field @"bar" . position @15 .~ "hello"
112−
113−stuff' ::
114− ( HasPosition 15 s t a String
115− , HasField "test" s' t' a' b'
116− , HasField "bar" a' b' s t
117− ) => s' -> t'
118−stuff' r = r & #test . #bar . position @15 .~ "hello"
119−
120−data Foo m s = Foo
121− { foo1 :: m s
122− , foo2 :: [s]
123− } deriving Generic
39+ } deriving (Show, Generic)
124−
125−modifyFoo2 :: Foo (Either String) Int -> Foo Maybe Int
126−modifyFoo2 x = x & field @"foo1" .~ pure (1 :: Int)
127−
128−data Bar a b = Bar
129− { barField :: (a, b)
130− } deriving Generic
131
40
132−modifiedBar = (Bar ("hello", "world")) & field @"barField" .~ ('c', 1 :: Int)
41+raiseByWolves :: Human -> Human
42+raiseByWolves human = human & super %~ growUp
examples/StarWars.hs+2−1
@@ -10,6 +10,7 @@
10module StarWars where
10module StarWars where
11
11
12import GHC.Generics
12import GHC.Generics
13+import Data.Generics.Record
13import Data.Generics.Product
14import Data.Generics.Product
14
15
15data Episode = NEWHOPE | EMPIRE | JEDI
16data Episode = NEWHOPE | EMPIRE | JEDI
@@ -59,7 +60,7 @@ c3po = Droid
59 , primaryFunction = "protocol and human relations"
60 , primaryFunction = "protocol and human relations"
60 }
61 }
61
62
62−getName :: HasField' "name" r a => r -> a
63+getName :: HasField "name" a r => r -> a
63getName = getField @"name"
64getName = getField @"name"
64
65
65-- upcast :: Subtype a b => a -> b
66-- upcast :: Subtype a b => a -> b
examples/doctest.hsdeleted−7
@@ -1,7 +0,0 @@
1−import Test.DocTest
2−main
3− = doctest
4− [ "-iexamples"
5− , "-isrc"
6− , "examples/Biscuits.hs"
7− ]
generic-lens.cabal+89−178
@@ -1,185 +1,96 @@
1−name: generic-lens
1+name: generic-lens
2−version: 1.2.0.1
3−synopsis: Generically derive traversals, lenses and prisms.
4−description: This library uses GHC.Generics to derive efficient optics (traversals, lenses and prisms) for algebraic data types in a type-directed way, with a focus on good type inference and error messages when possible.
5−
6−homepage: https://github.com/kcsongor/generic-lens
7−license: BSD3
8−license-file: LICENSE
9−author: Csongor Kiss
10−maintainer: kiss.csongor.kiss@gmail.com
11−category: Generics, Records, Lens
12−build-type: Simple
13−cabal-version: >= 1.10
14−Tested-With: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.1
15−
16−extra-source-files: ChangeLog.md
17− , examples/StarWars.hs
18− , examples/Examples.hs
19− , README.md
20−
21−flag dump-core
22− description: Dump HTML for the core generated by GHC during compilation
23− default: False
24
2
25−library
3+version: 0.2.0.0
26− exposed-modules: Data.Generics.Wrapped
27− , Data.Generics.Product
28− , Data.Generics.Product.Any
29− , Data.Generics.Product.Fields
30− , Data.Generics.Product.Param
31− , Data.Generics.Product.Positions
32− , Data.Generics.Product.Subtype
33− , Data.Generics.Product.Typed
34− , Data.Generics.Product.Types
35− , Data.Generics.Product.Constraints
36− , Data.Generics.Product.HList
37− , Data.Generics.Labels
38− , Data.Generics.Internal.GenericN
39−
40− , Data.Generics.Sum
41− , Data.Generics.Sum.Any
42− , Data.Generics.Sum.Constructors
43− , Data.Generics.Sum.Typed
44− , Data.Generics.Sum.Subtype
45− , Data.Generics.Internal.Profunctor.Lens
46− , Data.Generics.Internal.Profunctor.Prism
47− , Data.Generics.Internal.Profunctor.Iso
48− , Data.Generics.Internal.VL.Lens
49− , Data.Generics.Internal.VL.Traversal
50− , Data.Generics.Internal.VL.Prism
51− , Data.Generics.Internal.VL.Iso
52−
53− , Data.GenericLens.Internal
54−
55− other-modules: Data.Generics.Internal.Families
56− , Data.Generics.Internal.Families.Changing
57− , Data.Generics.Internal.Families.Collect
58− , Data.Generics.Internal.Families.Has
59− , Data.Generics.Internal.Errors
60− , Data.Generics.Internal.Void
61−
62− , Data.Generics.Sum.Internal.Constructors
63− , Data.Generics.Sum.Internal.Typed
64− , Data.Generics.Sum.Internal.Subtype
65−
66− , Data.Generics.Product.Internal.Positions
67− , Data.Generics.Product.Internal.GLens
68− , Data.Generics.Product.Internal.Subtype
69−
70− , Data.Generics.Product.Internal.Constraints
71− , Data.Generics.Product.Internal.HList
72−
73− build-depends: base >= 4.9 && < 5
74− , profunctors >= 5.0 && < 6.0
75− , tagged >= 0.8 && < 1
76− , text >= 1.2 && < 1.3
77−
78− hs-source-dirs: src
79− default-language: Haskell2010
80− ghc-options: -Wall
81−-- if flag(dump-core)
82−-- build-depends: dump-core
83−-- ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
84
4
85−source-repository head
5+synopsis: Generic data-structure operations exposed as lenses.
86− type: git
87− location: https://github.com/kcsongor/generic-lens
88
6
89−test-suite generic-lens-examples
7+description: This package uses the GHC 8 Generic representation to derive various operations on data structures with a lens interface, including structural subtype relationship between records and positional indexing into arbitrary product types.
90− type: exitcode-stdio-1.0
91− hs-source-dirs: examples
92− main-is: Biscuits.hs
93
8
94− build-depends: base >= 4.9 && <= 5.0
95− , generic-lens
9+homepage: https://github.com/kcsongor/generic-lens
96− , lens
97− , profunctors
98− , HUnit
99
10
100− default-language: Haskell2010
11+license: BSD3
101
12
102−test-suite generic-lens-test
13+license-file: LICENSE
103− type: exitcode-stdio-1.0
14+
104− hs-source-dirs: test
15+author: Csongor Kiss
105− main-is: Spec.hs
16+
106− other-modules: Util Test24 Test25 Test40 Test62 Test63 CustomChildren
17+maintainer: kiss.csongor.kiss@gmail.com
107−
18+
108− build-depends: base >= 4.9 && <= 5.0
19+category: Generics, Records, Lens
109− , generic-lens
20+
110− , lens
21+build-type: Simple
111− , profunctors
22+
112− , inspection-testing >= 0.2
23+-- Extra files to be distributed with the package, such as examples or a
113− , HUnit
24+-- README.
114−
25+extra-source-files: ChangeLog.md
115− default-language: Haskell2010
26+ , examples/StarWars.hs
116− ghc-options: -Wall
27+ , README.md
117− if flag(dump-core)
118− build-depends: dump-core
119− ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
120−
121−test-suite generic-lens-bifunctor
122− type: exitcode-stdio-1.0
123− hs-source-dirs: test
124− main-is: Bifunctor.hs
125−
126− build-depends: base >= 4.9 && <= 5.0
127− , generic-lens
128− , lens
129− , HUnit
130−
131− default-language: Haskell2010
132− ghc-options: -Wall
133− if flag(dump-core)
134− build-depends: dump-core
135− ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
136−
137−test-suite generic-lens-syb-tree
138− type: exitcode-stdio-1.0
139− hs-source-dirs: test/syb
140− main-is: Tree.hs
141−
142− build-depends: base >= 4.9 && <= 5.0
143− , generic-lens
144− , lens
145− , profunctors
146− , HUnit
147−
148− default-language: Haskell2010
149− ghc-options: -Wall
150− if flag(dump-core)
151− build-depends: dump-core
152− ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
153−
154−test-suite doctests
155− default-language: Haskell2010
156− type: exitcode-stdio-1.0
157− ghc-options: -threaded
158− main-is: doctest.hs
159− build-depends: base >4 && <5, doctest
160− hs-source-dirs: test
161−
162−test-suite examples-doctests
163− default-language: Haskell2010
164− type: exitcode-stdio-1.0
165− ghc-options: -threaded
166− main-is: doctest.hs
167− build-depends: base >4 && <5, doctest
168− hs-source-dirs: examples
169−
170−benchmark generic-lens-bench
171− type: exitcode-stdio-1.0
172− hs-source-dirs: benchmarks
173− main-is: Bench.hs
174−
175− build-depends: generic-lens
176−
177− , base >= 4.9 && <= 5.0
178− , QuickCheck
179− , criterion >= 1.3.0.0
180− , deepseq
181− , lens
182−
183− default-language: Haskell2010
184− ghc-options: -Wall
185
28
29+-- Constraint on the version of Cabal needed to build this package.
30+cabal-version: >= 1.10
31+
32+
33+library
34+ exposed-modules: Data.Generics.Record
35+ , Data.Generics.Product
36+ , Data.Generics.Record.Subtype
37+ , Data.Generics.Record.HasField
38+ , Data.Generics.Product.HasFieldAt
39+ , Data.Generics.Internal.Lens
40+
41+ other-modules: Data.Generics.Record.Internal.Contains
42+
43+ other-extensions: AllowAmbiguousTypes
44+ , DataKinds
45+ , FlexibleInstances
46+ , FunctionalDependencies
47+ , PolyKinds
48+ , Rank2Types
49+ , ScopedTypeVariables
50+ , TypeApplications
51+ , TypeFamilies
52+ , TypeOperators
53+ , UndecidableInstances
54+
55+ -- Other library packages from which modules are imported.
56+ build-depends: base >= 4.9 && <= 5.0
57+
58+ -- Directories containing source files.
59+ hs-source-dirs: src
60+
61+ -- Base language which the package is written in.
62+ default-language: Haskell2010
63+ ghc-options: -Wall
64+
65+source-repository head
66+ type: git
67+ location: https://github.com/kcsongor/generic-lens
68+
69+test-suite generic-lens-test
70+ type:
71+ exitcode-stdio-1.0
72+ hs-source-dirs:
73+ test
74+ main-is:
75+ Spec.hs
76+
77+ build-depends: base >= 4.9 && <= 5.0
78+ , QuickCheck
79+ , hspec
80+ , generic-lens
81+
82+ ghc-options:
83+ -Wall
84+ other-extensions: AllowAmbiguousTypes
85+ , DataKinds
86+ , FlexibleInstances
87+ , FunctionalDependencies
88+ , PolyKinds
89+ , Rank2Types
90+ , ScopedTypeVariables
91+ , TypeApplications
92+ , TypeFamilies
93+ , TypeOperators
94+ , UndecidableInstances
95+ default-language:
96+ Haskell2010
src/Data/GenericLens/Internal.hsdeleted−64
@@ -1,64 +0,0 @@
1−-----------------------------------------------------------------------------
2−-- |
3−-- Module : Data.GenericLens.Internal
4−-- Copyright : (C) 2019 Csongor Kiss
5−-- License : BSD3
6−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
7−-- Stability : experimental
8−-- Portability : non-portable
9−--
10−-- The library internals are exposed through this module. Please keep
11−-- in mind that everything here is subject to change irrespective of
12−-- the the version numbers.
13−-----------------------------------------------------------------------------
14−
15−module Data.GenericLens.Internal
16− ( module Data.Generics.Internal.Families
17− , module Data.Generics.Internal.Families.Changing
18− , module Data.Generics.Internal.Families.Collect
19− , module Data.Generics.Internal.Families.Has
20− , module Data.Generics.Internal.Void
21− , module Data.Generics.Internal.Errors
22−
23− , module Data.Generics.Sum.Internal.Constructors
24− , module Data.Generics.Sum.Internal.Typed
25− , module Data.Generics.Sum.Internal.Subtype
26−
27− , module Data.Generics.Product.Internal.Positions
28− , module Data.Generics.Product.Internal.GLens
29− , module Data.Generics.Product.Internal.Subtype
30− , module Data.Generics.Product.Internal.Constraints
31− , module Data.Generics.Product.Internal.HList
32−
33− , module Data.Generics.Internal.GenericN
34−
35− -- * van Laarhoven optics
36− , module Data.Generics.Internal.VL.Iso
37− , module Data.Generics.Internal.VL.Lens
38− , module Data.Generics.Internal.VL.Prism
39− , module Data.Generics.Internal.VL.Traversal
40− ) where
41−
42−import Data.Generics.Internal.Families
43−import Data.Generics.Internal.Families.Changing
44−import Data.Generics.Internal.Families.Collect
45−import Data.Generics.Internal.Families.Has
46−import Data.Generics.Internal.Void
47−import Data.Generics.Internal.Errors
48−
49−import Data.Generics.Sum.Internal.Constructors
50−import Data.Generics.Sum.Internal.Typed
51−import Data.Generics.Sum.Internal.Subtype
52−
53−import Data.Generics.Product.Internal.Positions
54−import Data.Generics.Product.Internal.GLens
55−import Data.Generics.Product.Internal.Subtype
56−import Data.Generics.Product.Internal.Constraints
57−import Data.Generics.Product.Internal.HList
58−
59−import Data.Generics.Internal.GenericN
60−
61−import Data.Generics.Internal.VL.Iso
62−import Data.Generics.Internal.VL.Lens
63−import Data.Generics.Internal.VL.Prism
64−import Data.Generics.Internal.VL.Traversal
src/Data/GenericLens/Internal.hs~deleted

No changes to the content.

src/Data/Generics/Internal/Errors.hsdeleted−59
@@ -1,59 +0,0 @@
1−{-# LANGUAGE UndecidableInstances #-}
2−{-# LANGUAGE TypeFamilies #-}
3−{-# LANGUAGE KindSignatures #-}
4−{-# LANGUAGE PolyKinds #-}
5−{-# LANGUAGE DataKinds #-}
6−{-# LANGUAGE TypeOperators #-}
7−{-# LANGUAGE KindSignatures #-}
8−
9−-------------------------------------------------------------------------------
10−---- |
11−---- Module : Data.Generics.Internal.Errors
12−---- Copyright : (C) 2019 Csongor Kiss
13−---- License : BSD3
14−---- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
15−---- Stability : experimental
16−---- Portability : non-portable
17−----
18−---- Provide more legible type errors as described in
19−---- (https://kcsongor.github.io/report-stuck-families/)[this blog post].
20−-------------------------------------------------------------------------------
21−
22−module Data.Generics.Internal.Errors
23− ( NoGeneric
24− , Defined
25− , Defined_list
26−
27− , QuoteType
28− , PrettyError
29− ) where
30−
31−import GHC.Generics
32−import GHC.TypeLits
33−import Data.Kind
34−
35−type family NoGeneric (a :: Type) (ctxt :: [ErrorMessage]) :: Constraint where
36− NoGeneric a ctxt = PrettyError ('Text "No instance for " ':<>: QuoteType (Generic a)
37− ': ctxt)
38−type family PrettyError (ctxt :: [ErrorMessage]) :: k where
39− PrettyError '[] = TypeError ('Text "")
40− PrettyError (c ': cs) = TypeError ('Text "| " ':<>: c ':$$: PrettyLines cs)
41−
42−type family PrettyLines (ctxt :: [ErrorMessage]) :: ErrorMessage where
43− PrettyLines '[] = 'Text ""
44− PrettyLines (c ': cs) = 'Text "| " ':<>: c ':$$: PrettyLines cs
45−
46−type family Defined (break :: Type -> Type) (err :: Constraint) (a :: k) :: k where
47− Defined Void1 _ _ = Any
48− Defined _ _ k = k
49−
50−type family Defined_list (break :: [*]) (err :: Constraint) (a :: k) :: k where
51− Defined_list '[Void] _ _ = Any
52− Defined_list _ _ k = k
53−
54−data Void1 a
55−data Void
56−type family Any :: k
57−
58−type family QuoteType (typ :: k) :: ErrorMessage where
59− QuoteType typ = 'Text "‘" ':<>: 'ShowType typ ':<>: 'Text "’"
src/Data/Generics/Internal/Families.hsdeleted−34
@@ -1,34 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE KindSignatures #-}
5−{-# LANGUAGE MultiParamTypeClasses #-}
6−{-# LANGUAGE TypeFamilies #-}
7−{-# LANGUAGE TypeOperators #-}
8−
9−-----------------------------------------------------------------------------
10−-- |
11−-- Module : Data.Generics.Internal.Families
12−-- Copyright : (C) 2019 Csongor Kiss
13−-- License : BSD3
14−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
15−-- Stability : experimental
16−-- Portability : non-portable
17−--
18−-----------------------------------------------------------------------------
19−module Data.Generics.Internal.Families
20− ( module Families
21− , ShowSymbols
22− ) where
23−
24−import Data.Generics.Internal.Families.Collect as Families
25−import Data.Generics.Internal.Families.Has as Families
26−import Data.Generics.Internal.Families.Changing as Families
27−
28−import GHC.TypeLits (ErrorMessage (..), Symbol)
29−
30−type family ShowSymbols (ctors :: [Symbol]) :: ErrorMessage where
31− ShowSymbols '[]
32− = 'Text ""
33− ShowSymbols (c ': cs)
34− = 'Text "• " ':<>: 'Text c ':$$: ShowSymbols cs
src/Data/Generics/Internal/Families/Changing.hsdeleted−161
@@ -1,161 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE FunctionalDependencies #-}
5−{-# LANGUAGE GADTs #-}
6−{-# LANGUAGE PolyKinds #-}
7−{-# LANGUAGE TypeFamilies #-}
8−{-# LANGUAGE TypeOperators #-}
9−{-# LANGUAGE UndecidableInstances #-}
10−
11−module Data.Generics.Internal.Families.Changing
12− ( Indexed
13− , Infer
14− , PTag (..)
15− , P
16− , LookupParam
17− , ArgAt
18− , ArgCount
19− , UnifyHead
20− ) where
21−
22−import GHC.TypeLits (Nat, type (-), type (+), TypeError, ErrorMessage (..))
23−
24−{-
25− Note [Changing type parameters]
26− ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
27−
28− To get good type inference for type-changing lenses, we want to be able
29− map the field's type back to the type argument it corresponds to. This way,
30− when the field is changed, we know what the result type of the structure is
31− going to be.
32−
33− However, for a given type @t@, its representation @Rep t@ forgets which types
34− in the structure came from type variables, and which didn't. An @Int@ that
35− results from the instantiation of the type paremeter and an @Int@ that was
36− monomorphically specified in the structure are indistinguishable.
37−
38− The solution is to replace the type arguments in the type with unique
39− proxies, like: @T a b@ -> @T (P 1 a) (P 0 b)@. This way, if looking up
40− a field's type yields something of shape @P _ _@, we know it came from a type
41− parameter, and also know which.
42−
43− If the field's type is a proxy, then its type is allowed to change, otherwise
44− not. This also allows us to satisfy the functional dependency @s field b -> t@.
45− If after doing the conversion on @s@, @field@'s type is @(P _ a), then @t@ is
46− @s[b/a]@, otherwise @t ~ s@ and @b ~ a@.
47−-}
48−
49−-- `P` can be used in place of any type parameter, which means that it can have
50−-- any kind, not just *, so a data type won't work.
51−-- (this caused https://github.com/kcsongor/generic-lens/issues/23)
52−-- Instead, we use a matchable type family to wrap any `k` - however, we can no longer directly
53−-- pattern match on `P`, as it's not a type constructor. But we can still take it apart as a polymorphic
54−-- application form. In order to distinguish between applications of P and other type constructors, we use a tag, `PTag`
55−-- to fake a type constructor.
56−data PTag = PTag
57−type family P :: Nat -> k -> PTag -> k
58−
59−type Indexed t = Indexed' t 0
60−
61−type family Indexed' (t :: k) (next :: Nat) :: k where
62− Indexed' (t (a :: j) :: k) next = (Indexed' t (next + 1)) (P next a 'PTag)
63− Indexed' t _ = t
64−
65−data Sub where
66− Sub :: Nat -> k -> Sub
67−
68−type family Unify (a :: k) (b :: k) :: [Sub] where
69− Unify (p n _ 'PTag) a' = '[ 'Sub n a']
70− Unify (a x) (b y) = Unify x y ++ Unify a b
71− Unify a a = '[]
72− Unify a b = TypeError
73− ( 'Text "Couldn't match type "
74− ':<>: 'ShowType a
75− ':<>: 'Text " with "
76− ':<>: 'ShowType b
77− )
78−
79−type family (xs :: [k]) ++ (ys :: [k]) :: [k] where
80− '[] ++ ys = ys
81− (x ': xs) ++ ys = x ': (xs ++ ys)
82−
83−type family Infer (s :: *) (a' :: *) (b :: *) :: * where
84− Infer (s a) a' b
85− = ReplaceArgs (s a) (Unify a' b)
86− Infer s _ _ = s
87−
88−--------------------------------------------------------------------------------
89−
90−-- [TODO]: work this out
91−--
92−--type family ArgKind (t :: k) (pos :: Nat) :: * where
93−-- ArgKind (t (a :: k)) 'Z = k
94−-- ArgKind (t _) ('S pos) = ArgKind t pos
95−--
96−--type family ReplaceArg (t :: k) (pos :: Nat) (to :: ArgKind t pos) :: k where
97−-- ReplaceArg (t a) 'Z to = t to
98−-- ReplaceArg (t a) ('S pos) to = ReplaceArg t pos to a
99−-- ReplaceArg t _ _ = t
100−
101−type family ReplaceArg (t :: k) (pos :: Nat) (to :: j) :: k where
102− ReplaceArg (t a) 0 to = t to
103− ReplaceArg (t a) pos to = ReplaceArg t (pos - 1) to a
104− ReplaceArg t _ _ = t
105−
106−type family ReplaceArgs (t :: k) (subs :: [Sub]) :: k where
107− ReplaceArgs t '[] = t
108− ReplaceArgs t ('Sub n arg ': ss) = ReplaceArgs (ReplaceArg t n arg) ss
109−
110−type family LookupParam (a :: k) (p :: Nat) :: Maybe Nat where
111− LookupParam (param (n :: Nat)) m = 'Nothing
112− LookupParam (a (_ (m :: Nat))) n = IfEq m n ('Just 0) (MaybeAdd (LookupParam a n) 1)
113− LookupParam (a _) n = MaybeAdd (LookupParam a n) 1
114− LookupParam a _ = 'Nothing
115−
116−type family MaybeAdd (a :: Maybe Nat) (b :: Nat) :: Maybe Nat where
117− MaybeAdd 'Nothing _ = 'Nothing
118− MaybeAdd ('Just a) b = 'Just (a + b)
119−
120−type family IfEq (a :: k) (b :: k) (t :: l) (f :: l) :: l where
121− IfEq a a t _ = t
122− IfEq _ _ _ f = f
123−
124−type family ArgCount (t :: k) :: Nat where
125− ArgCount (f a) = 1 + ArgCount f
126− ArgCount a = 0
127−
128−type family ArgAt (t :: k) (n :: Nat) :: j where
129− ArgAt (t a) 0 = a
130− ArgAt (t a) n = ArgAt t (n - 1)
131−
132−
133−-- Note [CPP in instance constraints]
134−-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
135−--
136−-- In GHC 8.0.2, the calculated size of the expressions is too large for the
137−-- inliner to consider them under the default -funfolding-use-threshold value
138−-- (60).
139−--
140−-- To reduce the size, the constraints
141−--
142−-- ```
143−-- s' ~ Proxied s
144−-- t' ~ Proxied t
145−-- ```
146−--
147−-- are written as the following single equality:
148−--
149−-- ```
150−-- '(s', t') ~ '(Proxied s, Proxied t)
151−-- ```
152−--
153−-- However, for some reason, this violates the functional dependencies on 8.2.2.
154−-- Therefore, when using a newer version of the compiler, the original constraints
155−-- are used, as the expression size is smaller under 8.2.2.
156−
157−-- | Ensure that the types @a@ and @b@ are both applications of the same
158−-- constructor. The arguments may be different.
159−class UnifyHead (a :: k) (b :: k)
160−instance {-# OVERLAPPING #-} (gb ~ g b, UnifyHead f g) => UnifyHead (f a) gb
161−instance (a ~ b) => UnifyHead a b
src/Data/Generics/Internal/Families/Collect.hsdeleted−133
@@ -1,133 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE PolyKinds #-}
3−{-# LANGUAGE TypeFamilies #-}
4−{-# LANGUAGE TypeOperators #-}
5−{-# LANGUAGE UndecidableInstances #-}
6−
7−-----------------------------------------------------------------------------
8−-- |
9−-- Module : Data.Generics.Internal.Families.Collect
10−-- Copyright : (C) 2019 Csongor Kiss
11−-- License : BSD3
12−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
13−-- Stability : experimental
14−-- Portability : non-portable
15−--
16−-----------------------------------------------------------------------------
17−module Data.Generics.Internal.Families.Collect
18− ( CollectTotalType
19− , CollectPartialType
20− , CollectField
21− , CollectFieldsOrdered
22− , TypeStat (..)
23− , type (\\)
24− ) where
25−
26−import Data.Type.Bool (If)
27−import Data.Type.Equality (type (==))
28−import GHC.Generics
29−import GHC.TypeLits (Symbol, CmpSymbol)
30−
31−import Data.Generics.Product.Internal.HList (type (++))
32−import Data.Generics.Internal.Families.Has (GTypes)
33−
34−data TypeStat
35− = TypeStat
36− { _containsNone :: [Symbol]
37− , _containsMultiple :: [Symbol]
38− , _containsOne :: [Symbol]
39− }
40−
41−type EmptyStat = 'TypeStat '[] '[] '[]
42−
43−type family CollectTotalType t f :: TypeStat where
44− CollectTotalType t (C1 ('MetaCons ctor _ _) f)
45− = AddToStat ctor (CountType t f) EmptyStat
46− CollectTotalType t (M1 _ _ r)
47− = CollectTotalType t r
48− CollectTotalType t (l :+: r)
49− = MergeStat (CollectTotalType t l) (CollectTotalType t r)
50−
51−type family CollectField t f :: TypeStat where
52− CollectField t (C1 ('MetaCons ctor _ _) f)
53− = AddToStat ctor (CountField t f) EmptyStat
54− CollectField t (M1 _ _ r)
55− = CollectField t r
56− CollectField t (l :+: r)
57− = MergeStat (CollectField t l) (CollectField t r)
58−
59−type family AddToStat (ctor :: Symbol) (count :: Count) (st :: TypeStat) :: TypeStat where
60− AddToStat ctor 'None ('TypeStat n m o) = 'TypeStat (ctor ': n) m o
61− AddToStat ctor 'Multiple ('TypeStat n m o) = 'TypeStat n (ctor ': m) o
62− AddToStat ctor 'One ('TypeStat n m o) = 'TypeStat n m (ctor ': o)
63−
64−type family MergeStat (st1 :: TypeStat) (st2 :: TypeStat) :: TypeStat where
65− MergeStat ('TypeStat n m o) ('TypeStat n' m' o') = 'TypeStat (n ++ n') (m ++ m') (o ++ o')
66−
67−type family CountType t f :: Count where
68− CountType t (S1 _ (Rec0 t))
69− = 'One
70− CountType t (l :*: r)
71− = CountType t l <|> CountType t r
72− CountType t _
73− = 'None
74−
75−type family CountField (field :: Symbol) f :: Count where
76− CountField field (S1 ('MetaSel ('Just field) _ _ _) _)
77− = 'One
78− CountField field (l :*: r)
79− = CountField field l <|> CountField field r
80− CountField _ _
81− = 'None
82−
83−type family CollectPartialType t f :: [Symbol] where
84− CollectPartialType t (l :+: r)
85− = CollectPartialType t l ++ CollectPartialType t r
86− CollectPartialType t (C1 ('MetaCons ctor _ _) f)
87− = If (t == GTypes f) '[ctor] '[]
88− CollectPartialType t (D1 _ f)
89− = CollectPartialType t f
90−
91−data Count
92− = None
93− | One
94− | Multiple
95−
96−type family (a :: Count) <|> (b :: Count) :: Count where
97− 'None <|> b = b
98− a <|> 'None = a
99− a <|> b = 'Multiple
100−
101−type family (a :: Count) <&> (b :: Count) :: Count where
102− a <&> a = a
103− _ <&> _ = 'Multiple
104−
105−type family CollectFieldsOrdered (r :: * -> *) :: [Symbol] where
106− CollectFieldsOrdered (l :*: r)
107− = Merge (CollectFieldsOrdered l) (CollectFieldsOrdered r)
108− CollectFieldsOrdered (S1 ('MetaSel ('Just name) _ _ _) _)
109− = '[name]
110− CollectFieldsOrdered (M1 _ m a)
111− = CollectFieldsOrdered a
112− CollectFieldsOrdered _
113− = '[]
114−
115−type family Merge (xs :: [Symbol]) (ys :: [Symbol]) :: [Symbol] where
116− Merge xs '[] = xs
117− Merge '[] ys = ys
118− Merge (x ': xs) (y ': ys) = Merge' (CmpSymbol x y) x y xs ys
119−
120−type family Merge' (ord :: Ordering) (x :: Symbol) (y :: Symbol) (xs :: [Symbol]) (ys :: [Symbol]) :: [Symbol] where
121− Merge' 'LT x y xs ys = x ': Merge xs (y ': ys)
122− Merge' _ x y xs ys = y ': Merge (x ': xs) ys
123−
124−type family (xs :: [Symbol]) \\ (ys :: [Symbol]) :: [Symbol] where
125− xs \\ '[] = xs
126− '[] \\ xs = '[]
127− (x ': xs) \\ (y ': ys) = Sub' (CmpSymbol x y) x y xs ys
128−
129−infixr 5 \\
130−type family Sub' (ord :: Ordering) (x :: Symbol) (y :: Symbol) (xs :: [Symbol]) (ys :: [Symbol]) :: [Symbol] where
131− Sub' 'LT x y xs ys = x ': (xs \\ y ': ys)
132− Sub' 'GT x _ xs ys = (x ': xs) \\ ys
133− Sub' 'EQ _ _ xs ys = xs \\ ys
src/Data/Generics/Internal/Families/Has.hsdeleted−134
@@ -1,134 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE PolyKinds #-}
3−{-# LANGUAGE TypeFamilies #-}
4−{-# LANGUAGE TypeOperators #-}
5−{-# LANGUAGE UndecidableInstances #-}
6−
7−-----------------------------------------------------------------------------
8−-- |
9−-- Module : Data.Generics.Internal.Families.Has
10−-- Copyright : (C) 2019 Csongor Kiss
11−-- License : BSD3
12−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
13−-- Stability : experimental
14−-- Portability : non-portable
15−--
16−-----------------------------------------------------------------------------
17−module Data.Generics.Internal.Families.Has
18− ( HasTotalFieldP
19− , HasTotalTypeP
20− , HasTotalPositionP
21− , Pos
22− , HasPartialTypeP
23− , HasCtorP
24− , GTypes
25− ) where
26−
27−import Data.Type.Bool (type (||))
28−import Data.Type.Equality (type (==))
29−import GHC.Generics
30−import GHC.TypeLits (Symbol, Nat)
31−import Data.Kind (Type)
32−
33−import Data.Generics.Product.Internal.HList
34−
35−-- Note: these could be factored out into a single traversal
36−
37−type family Both (m1 :: Maybe a) (m2 :: Maybe a) :: Maybe a where
38− Both ('Just a) ('Just a) = 'Just a
39−
40−type family Alt (m1 :: Maybe a) (m2 :: Maybe a) :: Maybe a where
41− Alt ('Just a) _ = 'Just a
42− Alt _ b = b
43−
44−type family HasTotalFieldP (field :: Symbol) f :: Maybe Type where
45− HasTotalFieldP field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 t))
46− = 'Just t
47− HasTotalFieldP field (l :*: r)
48− = Alt (HasTotalFieldP field l) (HasTotalFieldP field r)
49− HasTotalFieldP field (l :+: r)
50− = Both (HasTotalFieldP field l) (HasTotalFieldP field r)
51− HasTotalFieldP field (S1 _ _)
52− = 'Nothing
53− HasTotalFieldP field (C1 _ f)
54− = HasTotalFieldP field f
55− HasTotalFieldP field (D1 _ f)
56− = HasTotalFieldP field f
57− HasTotalFieldP field (K1 _ _)
58− = 'Nothing
59− HasTotalFieldP field U1
60− = 'Nothing
61− HasTotalFieldP field V1
62− = 'Nothing
63−
64−type family HasTotalTypeP (typ :: Type) f :: Maybe Type where
65− HasTotalTypeP typ (S1 _ (K1 _ typ))
66− = 'Just typ
67− HasTotalTypeP typ (l :*: r)
68− = Alt (HasTotalTypeP typ l) (HasTotalTypeP typ r)
69− HasTotalTypeP typ (l :+: r)
70− = Both (HasTotalTypeP typ l) (HasTotalTypeP typ r)
71− HasTotalTypeP typ (S1 _ _)
72− = 'Nothing
73− HasTotalTypeP typ (C1 _ f)
74− = HasTotalTypeP typ f
75− HasTotalTypeP typ (D1 _ f)
76− = HasTotalTypeP typ f
77− HasTotalTypeP typ (K1 _ _)
78− = 'Nothing
79− HasTotalTypeP typ U1
80− = 'Nothing
81− HasTotalTypeP typ V1
82− = 'Nothing
83−
84−data Pos (p :: Nat)
85−
86−type family HasTotalPositionP (pos :: Nat) f :: Maybe Type where
87− HasTotalPositionP pos (S1 _ (K1 (Pos pos) t))
88− = 'Just t
89− HasTotalPositionP pos (l :*: r)
90− = Alt (HasTotalPositionP pos l) (HasTotalPositionP pos r)
91− HasTotalPositionP pos (l :+: r)
92− = Both (HasTotalPositionP pos l) (HasTotalPositionP pos r)
93− HasTotalPositionP pos (S1 _ _)
94− = 'Nothing
95− HasTotalPositionP pos (C1 _ f)
96− = HasTotalPositionP pos f
97− HasTotalPositionP pos (D1 _ f)
98− = HasTotalPositionP pos f
99− HasTotalPositionP pos (K1 _ _)
100− = 'Nothing
101− HasTotalPositionP pos U1
102− = 'Nothing
103− HasTotalPositionP pos V1
104− = 'Nothing
105−
106−type family HasPartialTypeP a f :: Bool where
107− HasPartialTypeP t (l :+: r)
108− = HasPartialTypeP t l || HasPartialTypeP t r
109− HasPartialTypeP t (C1 m f)
110− = t == GTypes f
111− HasPartialTypeP t (M1 _ _ f)
112− = HasPartialTypeP t f
113− HasPartialTypeP t _
114− = 'False
115−
116−type family HasCtorP (ctor :: Symbol) f :: Bool where
117− HasCtorP ctor (C1 ('MetaCons ctor _ _) _)
118− = 'True
119− HasCtorP ctor (f :+: g)
120− = HasCtorP ctor f || HasCtorP ctor g
121− HasCtorP ctor (D1 m f)
122− = HasCtorP ctor f
123− HasCtorP ctor _
124− = 'False
125−
126−type family GTypes (rep :: Type -> Type) :: [Type] where
127− GTypes (l :*: r)
128− = GTypes l ++ GTypes r
129− GTypes (K1 _ a)
130− = '[ a]
131− GTypes (M1 _ m a)
132− = GTypes a
133− GTypes U1 = '[]
134−
src/Data/Generics/Internal/GenericN.hsdeleted−75
@@ -1,75 +0,0 @@
1−{-# OPTIONS_HADDOCK hide #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE InstanceSigs #-}
6−{-# LANGUAGE PolyKinds #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE TypeFamilies #-}
9−{-# LANGUAGE TypeOperators #-}
10−{-# LANGUAGE UndecidableInstances #-}
11−
12−--------------------------------------------------------------------------------
13−-- |
14−-- Module : Data.Generics.Internal.GenericN
15−-- Copyright : (C) 2019 Csongor Kiss
16−-- License : BSD3
17−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
18−-- Stability : experimental
19−-- Portability : non-portable
20−--
21−-- Generic representation of types with multiple parameters
22−--
23−--------------------------------------------------------------------------------
24−
25−module Data.Generics.Internal.GenericN
26− ( Param
27− , Rec (Rec, unRec)
28− , GenericN (..)
29− ) where
30−
31−import Data.Kind
32−import GHC.Generics
33−import GHC.TypeLits
34−import Data.Coerce
35−
36−type family Param :: Nat -> k where
37−
38−type family Indexed (t :: k) (i :: Nat) :: k where
39− Indexed (t a) i = Indexed t (i + 1) (Param i)
40− Indexed t _ = t
41−
42−newtype Rec (p :: Type) a x = Rec { unRec :: K1 R a x }
43−
44−type family Zip (a :: Type -> Type) (b :: Type -> Type) :: Type -> Type where
45− Zip (M1 mt m s) (M1 mt m t)
46− = M1 mt m (Zip s t)
47− Zip (l :+: r) (l' :+: r')
48− = Zip l l' :+: Zip r r'
49− Zip (l :*: r) (l' :*: r')
50− = Zip l l' :*: Zip r r'
51− Zip (Rec0 p) (Rec0 a)
52− = Rec p a
53− Zip U1 U1
54− = U1
55−
56−class
57− ( Coercible (Rep a) (RepN a)
58− , Generic a
59− ) => GenericN (a :: Type) where
60− type family RepN (a :: Type) :: Type -> Type
61− type instance RepN a = Zip (Rep (Indexed a 0)) (Rep a)
62− toN :: RepN a x -> a
63− fromN :: a -> RepN a x
64−
65−instance
66− ( Coercible (Rep a) (RepN a)
67− , Generic a
68− ) => GenericN a where
69− toN :: forall x. RepN a x -> a
70− toN = coerce (to :: Rep a x -> a)
71− {-# INLINE toN #-}
72−
73− fromN :: forall x. a -> RepN a x
74− fromN = coerce (from :: a -> Rep a x)
75− {-# INLINE fromN #-}
src/Data/Generics/Internal/Lens.hsnew file+64
@@ -0,0 +1,64 @@
1+{-# LANGUAGE Rank2Types #-}
2+{-# LANGUAGE TypeOperators #-}
3+
4+-----------------------------------------------------------------------------
5+-- |
6+-- Module : Data.Generics.Internal.Lens
7+-- Copyright : (C) 2017 Csongor Kiss
8+-- License : BSD3
9+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
10+-- Stability : experimental
11+-- Portability : non-portable
12+--
13+-- Internal lens helpers. Only exported for Haddock
14+--
15+-----------------------------------------------------------------------------
16+module Data.Generics.Internal.Lens where
17+
18+import Control.Applicative ( Const (..) )
19+import GHC.Generics ( (:*:) (..), Generic (..), M1 (..), Rep, (:+:) (..) )
20+
21+-- | Identity functor
22+newtype Identity a
23+ = Identity { runIdentity :: a }
24+
25+-- | Functor instance
26+instance Functor Identity where
27+ fmap f (Identity a)
28+ = Identity (f a)
29+
30+-- | Type alias for lens
31+type Lens' s a
32+ = forall f. Functor f => (a -> f a) -> s -> f s
33+
34+-- | Getting
35+(^.) :: s -> ((a -> Const a a) -> s -> Const a s) -> a
36+s ^. l = getConst (l Const s)
37+infixl 8 ^.
38+
39+-- | Setting
40+set :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t
41+set l b
42+ = runIdentity . l (\_ -> Identity b)
43+
44+-- | Lens focusing on the first element of a product
45+first :: Lens' ((a :*: b) x) (a x)
46+first f (a :*: b)
47+ = fmap (:*: b) (f a)
48+
49+-- | Lens focusing on the second element of a product
50+second :: Lens' ((a :*: b) x) (b x)
51+second f (a :*: b)
52+ = fmap (a :*:) (f b)
53+
54+combine :: Lens' (s x) a -> Lens' (t x) a -> Lens' ((:+:) s t x) a
55+combine sa _ f (L1 s) = fmap (\a -> L1 (set sa a s)) (f (s ^. sa))
56+combine _ ta f (R1 t) = fmap (\a -> R1 (set ta a t)) (f (t ^. ta))
57+
58+-- | A type and its generic representation are isomorphic
59+repIso :: Generic a => Lens' a (Rep a x)
60+repIso a = fmap to . a . from
61+
62+-- | 'M1' is just a wrapper around `f p`
63+lensM :: Lens' (M1 i c f p) (f p)
64+lensM f (M1 x) = fmap M1 (f x)
src/Data/Generics/Internal/Profunctor/Iso.hsdeleted−111
@@ -1,111 +0,0 @@
1−{-# OPTIONS_HADDOCK hide #-}
2−{-# LANGUAGE TupleSections #-}
3−{-# LANGUAGE GADTs #-}
4−{-# LANGUAGE NoMonomorphismRestriction #-}
5−{-# LANGUAGE Rank2Types #-}
6−{-# LANGUAGE ScopedTypeVariables #-}
7−{-# LANGUAGE TypeFamilies #-}
8−{-# LANGUAGE TypeFamilyDependencies #-}
9−{-# LANGUAGE TypeOperators #-}
10−
11−-----------------------------------------------------------------------------
12−-- |
13−-- Module : Data.Generics.Internal.Profunctor.Iso
14−-- Copyright : (C) 2019 Csongor Kiss
15−-- License : BSD3
16−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17−-- Stability : experimental
18−-- Portability : non-portable
19−--
20−-- Internal lens helpers. Only exported for Haddock
21−--
22−-----------------------------------------------------------------------------
23−module Data.Generics.Internal.Profunctor.Iso where
24−
25−import Data.Profunctor (Profunctor(..))
26−import Data.Profunctor.Unsafe ((#.), (.#))
27−import GHC.Generics ((:*:)(..), (:+:)(..), Generic(..), M1(..), K1(..), Rep)
28−import Data.Coerce
29−import Data.Generics.Internal.GenericN (Rec (..))
30−
31−import qualified Data.Generics.Internal.VL.Iso as VL
32−
33−type Iso s t a b
34− = forall p. (Profunctor p) => p a b -> p s t
35−
36−type Iso' s a = Iso s s a a
37−
38−-- | A type and its generic representation are isomorphic
39−repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
40−repIso = iso from to
41−
42−-- | 'M1' is just a wrapper around `f p`
43−--mIso :: Iso' (M1 i c f p) (f p)
44−mIso :: Iso (M1 i c f p) (M1 i c g p) (f p) (g p)
45−mIso = iso unM1 M1
46−{-# INLINE mIso #-}
47−
48−kIso :: Iso (K1 r a p) (K1 r b p) a b
49−kIso = iso unK1 K1
50−{-# INLINE kIso #-}
51−
52−recIso :: Iso (Rec r a p) (Rec r b p) a b
53−recIso = iso (unK1 . unRec) (Rec . K1)
54−{-# INLINE recIso #-}
55−
56−sumIso :: Iso ((a :+: b) x) ((a' :+: b') x) (Either (a x) (b x)) (Either (a' x) (b' x))
57−sumIso = iso back forth
58− where forth (Left l) = L1 l
59− forth (Right r) = R1 r
60− back (L1 l) = Left l
61− back (R1 r) = Right r
62−{-# INLINE sumIso #-}
63−
64−prodIso :: Iso ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
65−prodIso = iso (\(a :*: b) -> (a, b)) (\(a, b) -> (a :*: b))
66−
67−assoc3 :: Iso ((a, b), c) ((a', b'), c') (a, (b, c)) (a', (b', c'))
68−assoc3 = iso (\((a, b), c) -> (a, (b, c))) (\(a, (b, c)) -> ((a, b), c))
69−
70−--------------------------------------------------------------------------------
71−-- Iso stuff
72−
73−fromIso :: Iso s t a b -> Iso b a t s
74−fromIso l = withIso l $ \ sa bt -> iso bt sa
75−{-# INLINE fromIso #-}
76−
77−iso :: (s -> a) -> (b -> t) -> Iso s t a b
78−iso = dimap
79−{-# INLINE iso #-}
80−
81−iso2isovl :: Iso s t a b -> VL.Iso s t a b
82−iso2isovl _iso = withIso _iso VL.iso
83−{-# INLINE iso2isovl #-}
84−
85−withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
86−withIso ai k = case ai (Exchange id id) of
87− Exchange sa bt -> k sa bt
88−
89−pairing :: Iso s t a b -> Iso s' t' a' b' -> Iso (s, s') (t, t') (a, a') (b, b')
90−pairing f g = withIso f $ \ sa bt -> withIso g $ \s'a' b't' ->
91− iso (bmap sa s'a') (bmap bt b't')
92− where bmap f' g' (a, b) = (f' a, g' b)
93−
94−data Exchange a b s t = Exchange (s -> a) (b -> t)
95−
96−instance Functor (Exchange a b s) where
97− fmap f (Exchange sa bt) = Exchange sa (f . bt)
98− {-# INLINE fmap #-}
99−
100−instance Profunctor (Exchange a b) where
101− dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt)
102− {-# INLINE dimap #-}
103− lmap f (Exchange sa bt) = Exchange (sa . f) bt
104− {-# INLINE lmap #-}
105− rmap f (Exchange sa bt) = Exchange sa (f . bt)
106− {-# INLINE rmap #-}
107− ( #. ) _ = coerce
108− {-# INLINE ( #. ) #-}
109− ( .# ) p _ = coerce p
110− {-# INLINE ( .# ) #-}
111−
src/Data/Generics/Internal/Profunctor/Lens.hsdeleted−171
@@ -1,171 +0,0 @@
1−{-# OPTIONS_HADDOCK hide #-}
2−{-# LANGUAGE GADTs #-}
3−{-# LANGUAGE NoMonomorphismRestriction #-}
4−{-# LANGUAGE Rank2Types #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
6−{-# LANGUAGE TupleSections #-}
7−{-# LANGUAGE TypeFamilies #-}
8−{-# LANGUAGE TypeFamilyDependencies #-}
9−{-# LANGUAGE TypeOperators #-}
10−
11−-----------------------------------------------------------------------------
12−-- |
13−-- Module : Data.Generics.Internal.Profunctor.Lens
14−-- Copyright : (C) 2019 Csongor Kiss
15−-- License : BSD3
16−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17−-- Stability : experimental
18−-- Portability : non-portable
19−--
20−-- Internal lens helpers. Only exported for Haddock
21−--
22−-----------------------------------------------------------------------------
23−module Data.Generics.Internal.Profunctor.Lens where
24−
25−import Data.Profunctor (Profunctor(..), Strong(..))
26−import Data.Bifunctor
27−import GHC.Generics
28−import Data.Generics.Internal.Profunctor.Iso
29−
30−type Lens s t a b
31− = forall p . (Strong p) => p a b -> p s t
32−
33−type LensLike p s t a b
34− = p a b -> p s t
35−
36−
37−ravel :: (ALens a b a b -> ALens a b s t) -> Lens s t a b
38−ravel l pab = conv (l idLens) pab
39− where
40− conv :: ALens a b s t -> Lens s t a b
41− conv (ALens _get _set) = lens _get _set
42−
43−-- | Setting
44−set :: ((a -> b) -> s -> t) -> (s, b) -> t
45−set f (s, b)
46− = f (const b) s
47−
48−view :: Lens s s a a -> s -> a
49−view l = withLensPrim l (\get _ -> snd . get)
50−
51−--withLens :: Lens s t a b -> ((s -> a) -> ((s, b) -> t) -> r) -> r
52−--ithLens l k =
53−-- case l idLens of
54−-- ALens _get _set -> k (snd . _get) (\(s, b) -> _set ((fst $ _get s), b))
55−
56−withLensPrim :: Lens s t a b -> (forall c . (s -> (c,a)) -> ((c, b) -> t) -> r) -> r
57−withLensPrim l k =
58− case l idLens of
59− ALens _get _set -> k _get _set
60−
61−idLens :: ALens a b a b
62−idLens = ALens (fork (const ()) id) snd
63−{-# INLINE idLens #-}
64−
65−-- | Lens focusing on the first element of a product
66−first :: Lens ((a :*: b) x) ((a' :*: b) x) (a x) (a' x)
67−first
68− = lens (\(a :*: b) -> (b,a)) (\(b, a') -> a' :*: b)
69−
70−-- | Lens focusing on the second element of a product
71−second :: Lens ((a :*: b) x) ((a :*: b') x) (b x) (b' x)
72−second
73− = lens (\(a :*: b) -> (a,b)) (\(a, b') -> a :*: b')
74−
75−fork :: (a -> b) -> (a -> c) -> a -> (b, c)
76−fork f g a = (f a, g a)
77−
78−swap :: (a, b) -> (b, a)
79−swap (a, b) = (b, a)
80−
81−cross :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
82−cross = bimap
83−
84−--------------------------------------------------------------------------------
85−
86−data Coyoneda f b = forall a. Coyoneda (a -> b) (f a)
87−
88−instance Functor (Coyoneda f) where
89− fmap f (Coyoneda g fa)
90− = Coyoneda (f . g) fa
91−
92−inj :: Functor f => Coyoneda f a -> f a
93−inj (Coyoneda f a) = fmap f a
94−
95−proj :: Functor f => f a -> Coyoneda f a
96−proj fa = Coyoneda id fa
97−
98−newtype Alongside p s t a b = Alongside { getAlongside :: p (s, a) (t, b) }
99−
100−instance Profunctor p => Profunctor (Alongside p c d) where
101− dimap f g (Alongside pab) = Alongside $ dimap (fmap f) (fmap g) pab
102−
103−instance Strong p => Strong (Alongside p c d) where
104− second' (Alongside pab) = Alongside . dimap shuffle shuffle . second' $ pab
105− where
106− shuffle (x,(y,z)) = (y,(x,z))
107−
108−(??) :: Functor f => f (a -> b) -> a -> f b
109−fab ?? a = fmap ($ a) fab
110−
111−-- Could implement this using primitives?
112−alongside :: Profunctor p =>
113− LensLike (Alongside p s' t') s t a b
114− -> LensLike (Alongside p a b) s' t' a' b'
115− -> LensLike p (s, s') (t, t') (a, a') (b, b')
116−alongside l1 l2
117− = dimap swap swap . getAlongside . l1 . Alongside . dimap swap swap . getAlongside . l2 . Alongside
118−
119−assoc3L :: Lens ((a, b), c) ((a', b'), c') (a, (b, c)) (a', (b', c'))
120−assoc3L f = assoc3 f
121−
122−stron :: (Either s s', b) -> Either (s, b) (s', b)
123−stron (e, b) = bimap (,b) (, b) e
124−
125−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
126−choosing l r = withLensPrim l (\getl setl ->
127− withLensPrim r (\getr setr ->
128− let --g :: Either s s' -> a
129− g e = case e of
130− Left v -> let (c, v') = getl v in (Left c, v')
131− Right v -> let (c, v') = getr v in (Right c, v')
132− s = bimap setl setr . stron
133− in lens g s))
134−
135−lens :: (s -> (c,a)) -> ((c,b) -> t) -> Lens s t a b
136−lens get _set = dimap get _set . second'
137−{-# INLINE lens #-}
138−
139−------------------------------------------------------------------------------
140−
141−data ALens a b s t = forall c . ALens (s -> (c,a)) ((c, b) -> t)
142−
143−instance Functor (ALens a b s) where
144− fmap f (ALens _get _set) = ALens _get (f . _set)
145−
146−instance Profunctor (ALens a b) where
147− dimap f g (ALens get _set) = ALens (get . f) (g . _set)
148−
149−instance Strong (ALens a b) where
150− second' (ALens get _set) = ALens get' set' --(bimap id _set . assoc)
151− where
152− get' (c, a1) = let (c1, a) = get a1 in ((c, c1), a)
153− set' ((c, c1), b) = (c, _set (c1, b))
154− {-# INLINE second' #-}
155−
156−-- These are specialised versions of the Isos. On GHC 8.0.2, having
157−-- these functions eta-expanded allows the optimiser to inline these functions.
158−mLens :: Lens (M1 i c f p) (M1 i c g p) (f p) (g p)
159−mLens f = mIso f
160−
161−repLens :: (Generic a, Generic b) => Lens a b (Rep a x) (Rep b x)
162−repLens f = repIso f
163−
164−prodL :: Lens ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
165−prodL f = prodIso f
166−
167−prodR :: Lens (a' x, b' x) (a x, b x) ((a' :*: b') x) ((a :*: b) x)
168−prodR f = fromIso prodIso f
169−
170−assoc3R :: Lens (a', (b', c')) (a, (b, c)) ((a', b'), c') ((a, b), c)
171−assoc3R f = fromIso assoc3 f
src/Data/Generics/Internal/Profunctor/Prism.hsdeleted−117
@@ -1,117 +0,0 @@
1−{-# OPTIONS_HADDOCK hide #-}
2−{-# LANGUAGE GADTs #-}
3−{-# LANGUAGE LambdaCase #-}
4−{-# LANGUAGE NoMonomorphismRestriction #-}
5−{-# LANGUAGE Rank2Types #-}
6−{-# LANGUAGE ScopedTypeVariables #-}
7−{-# LANGUAGE TypeFamilies #-}
8−{-# LANGUAGE TypeFamilyDependencies #-}
9−{-# LANGUAGE TypeOperators #-}
10−
11−-----------------------------------------------------------------------------
12−-- |
13−-- Module : Data.Generics.Internal.Profunctor.Prism
14−-- Copyright : (C) 2019 Csongor Kiss
15−-- License : BSD3
16−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17−-- Stability : experimental
18−-- Portability : non-portable
19−--
20−-- Internal lens helpers. Only exported for Haddock
21−--
22−-----------------------------------------------------------------------------
23−module Data.Generics.Internal.Profunctor.Prism where
24−
25−import Data.Bifunctor (bimap)
26−import Data.Profunctor (Choice(..), Profunctor(..))
27−import Data.Tagged
28−import Data.Profunctor.Unsafe ((#.), (.#))
29−import GHC.Generics
30−import Data.Coerce
31−
32−type APrism s t a b = Market a b a b -> Market a b s t
33−
34−type Prism s t a b
35− = forall p . (Choice p) => p a b -> p s t
36−
37−type Prism' s a = forall p . (Choice p) => p a a -> p s s
38−
39−left :: Prism ((a :+: c) x) ((b :+: c) x) (a x) (b x)
40−left = prism L1 $ gsum Right (Left . R1)
41−
42−right :: Prism ((a :+: b) x) ((a :+: c) x) (b x) (c x)
43−right = prism R1 $ gsum (Left . L1) Right
44−
45−prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
46−prism bt seta eta = dimap seta (either id bt) (right' eta)
47−
48−_Left :: Prism (Either a c) (Either b c) a b
49−_Left = left'
50−
51−_Right :: Prism (Either c a) (Either c b) a b
52−_Right = right'
53−
54−prismPRavel :: APrism s t a b -> Prism s t a b
55−prismPRavel l pab = (prism2prismp $ l idPrism) pab
56−
57−build :: (Tagged b b -> Tagged t t) -> b -> t
58−build p = unTagged #. p .# Tagged
59−
60−match :: Prism s t a b -> s -> Either t a
61−match k = withPrism k $ \_ _match -> _match
62−
63−--------------------------------------------------------------------------------
64−-- Prism stuff
65−
66−without' :: Prism s t a b -> Prism s t c d -> Prism s t (Either a c) (Either b d)
67−without' k =
68− withPrism k $ \bt _ k' ->
69− withPrism k' $ \dt setc ->
70− prism (either bt dt) $ \s -> fmap Right (setc s)
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 = bimap
89−
90−--------------------------------------------------------------------------------
91−-- Market
92−
93−data Market a b s t = Market (b -> t) (s -> Either t a)
94−
95−instance Functor (Market a b s) where
96− fmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)
97− {-# INLINE fmap #-}
98−
99−instance Profunctor (Market a b) where
100− dimap f g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta . f)
101− {-# INLINE dimap #-}
102− lmap f (Market bt seta) = Market bt (seta . f)
103− {-# INLINE lmap #-}
104− rmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)
105− {-# INLINE rmap #-}
106− ( #. ) _ = coerce
107− {-# INLINE ( #. ) #-}
108− ( .# ) p _ = coerce p
109− {-# INLINE ( .# ) #-}
110−
111−instance Choice (Market a b) where
112− left' (Market bt seta) = Market (Left . bt) $ \case
113− Left s -> case seta s of
114− Left t -> Left (Left t)
115− Right a -> Right a
116− Right c -> Left (Right c)
117− {-# INLINE left' #-}
src/Data/Generics/Internal/VL/Iso.hsdeleted−80
@@ -1,80 +0,0 @@
1−{-# OPTIONS_HADDOCK hide #-}
2−{-# LANGUAGE GADTs #-}
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.VL.Iso
13−-- Copyright : (C) 2019 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.Iso where
23−
24−import Data.Coerce (coerce)
25−import Data.Functor.Identity (Identity(..))
26−import Data.Profunctor (Profunctor(..))
27−import GHC.Generics
28−import Data.Generics.Internal.GenericN (Rec (..))
29−
30−data Exchange a b s t = Exchange (s -> a) (b -> t)
31−
32−instance Functor (Exchange a b s) where
33− fmap f (Exchange sa bt) = Exchange sa (f . bt)
34− {-# INLINE fmap #-}
35−
36−instance Profunctor (Exchange a b) where
37− dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt)
38− {-# INLINE dimap #-}
39− lmap f (Exchange sa bt) = Exchange (sa . f) bt
40− {-# INLINE lmap #-}
41− rmap f (Exchange sa bt) = Exchange sa (f . bt)
42− {-# INLINE rmap #-}
43−
44−type Iso' s a
45− = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s)
46−
47−type Iso s t a b
48− = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
49−
50−fromIso :: Iso s t a b -> Iso b a t s
51−fromIso l = withIso l $ \ sa bt -> iso bt sa
52−{-# inline fromIso #-}
53−
54−-- | Extract the two functions, one from @s -> a@ and
55−-- one from @b -> t@ that characterize an 'Iso'.
56−withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
57−withIso ai k = case ai (Exchange id Identity) of
58− Exchange sa bt -> k sa (coerce bt)
59−{-# inline withIso #-}
60−
61−-- | A type and its generic representation are isomorphic
62−repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
63−repIso = iso from to
64−
65−-- | 'M1' is just a wrapper around `f p`
66−mIso :: Iso (M1 i c f p) (M1 i c g p) (f p) (g p)
67−mIso = iso unM1 M1
68−
69−kIso :: Iso (K1 r a p) (K1 r b p) a b
70−kIso = iso unK1 K1
71−
72−recIso :: Iso (Rec r a p) (Rec r b p) a b
73−recIso = iso (unK1 . unRec) (Rec . K1)
74−
75−prodIso :: Iso ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
76−prodIso = iso (\(a :*: b) -> (a, b)) (\(a, b) -> (a :*: b))
77−
78−iso :: (s -> a) -> (b -> t) -> Iso s t a b
79−iso sa bt = dimap sa (fmap bt)
80−{-# INLINE iso #-}
src/Data/Generics/Internal/VL/Lens.hsdeleted−70
@@ -1,70 +0,0 @@
1−{-# OPTIONS_HADDOCK hide #-}
2−{-# LANGUAGE GADTs #-}
3−{-# LANGUAGE NoMonomorphismRestriction #-}
4−{-# LANGUAGE Rank2Types #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
6−{-# LANGUAGE TypeFamilies #-}
7−{-# LANGUAGE TypeFamilyDependencies #-}
8−{-# LANGUAGE TypeOperators #-}
9−{-# LANGUAGE TupleSections #-}
10−
11−-----------------------------------------------------------------------------
12−-- |
13−-- Module : Data.Generics.Internal.VL.Lens
14−-- Copyright : (C) 2019 Csongor Kiss
15−-- License : BSD3
16−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17−-- Stability : experimental
18−-- Portability : non-portable
19−--
20−-- Internal lens helpers. Only exported for Haddock
21−--
22−-----------------------------------------------------------------------------
23−module Data.Generics.Internal.VL.Lens where
24−
25−import Control.Applicative (Const(..))
26−import Data.Coerce (coerce)
27−import Data.Functor.Identity (Identity(..))
28−import Data.Generics.Internal.Profunctor.Lens (ALens (..), idLens)
29−
30−-- | Type alias for lens
31−type Lens' s a
32− = Lens s s a a
33−
34−type Lens s t a b
35− = forall f. Functor f => (a -> f b) -> s -> f t
36−
37−view :: ((a -> Const a a) -> s -> Const a s) -> s -> a
38−view l s = (^.) s l
39−
40−-- | Getting
41−(^.) :: s -> ((a -> Const a a) -> s -> Const a s) -> a
42−s ^. l = getConst (l Const s)
43−infixl 8 ^.
44−
45−infixr 4 .~
46−(.~) :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t
47−(.~) f b = runIdentity . f (Identity . const b)
48−
49−set :: Lens s t a b -> b -> s -> t
50−set l x = l .~ x
51−
52−over :: ((a -> Identity b) -> s -> Identity t) -> (a -> b) -> s -> t
53−over = coerce
54−
55−lens2lensvl :: ALens a b s t -> Lens s t a b
56−lens2lensvl (ALens _get _set) =
57− \f x ->
58− case _get x of
59− (c, a) -> _set . (c, ) <$> f a
60−{-# INLINE lens2lensvl #-}
61−
62−ravel :: (ALens a b a b -> ALens a b s t)
63− -> Lens s t a b
64−ravel l pab = (lens2lensvl $ l idLens) pab
65−
66−
67−lens :: (s -> a) -> ((s, b) -> t) -> Lens s t a b
68−lens get _set = \f x -> curry _set x <$> f (get x)
69−{-# INLINE[0] lens #-}
70−
src/Data/Generics/Internal/VL/Prism.hsdeleted−74
@@ -1,74 +0,0 @@
1−{-# OPTIONS_HADDOCK hide #-}
2−{-# LANGUAGE GADTs #-}
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.VL.Prism
13−-- Copyright : (C) 2019 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.Prism where
23−
24−import Data.Functor.Identity (Identity(..))
25−import Data.Profunctor (Choice(..), Profunctor(..))
26−import Data.Coerce
27−import Data.Generics.Internal.Profunctor.Prism (Market (..), plus, idPrism)
28−import Data.Tagged
29−import Data.Profunctor.Unsafe ((#.), (.#))
30−import Data.Monoid (First (..))
31−import Control.Applicative (Const(..))
32−
33−-- | Type alias for prism
34−type Prism s t a b
35− = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)
36−
37−type Prism' s a
38− = Prism s s a a
39−
40−infixl 8 ^?
41−(^?) :: s -> ((a -> Const (First a) a) -> s -> Const (First a) s) -> Maybe a
42−s ^? l = getFirst (fmof l (First #. Just) s)
43− where fmof l' f = getConst #. l' (Const #. f)
44−
45−
46−match :: Prism s t a b -> s -> Either t a
47−match k = withPrism k $ \_ _match -> _match
48−{-# INLINE match #-}
49−
50−(#) :: (Tagged b (Identity b) -> Tagged t (Identity t)) -> b -> t
51−(#) = build
52−{-# INLINE (#) #-}
53−
54−prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
55−prism bt seta eta = dimap (\x -> plus pure id (seta x)) (either id (\x -> fmap bt x)) (right' eta)
56−{-# INLINE prism #-}
57−
58−prismRavel :: (Market a b a b -> Market a b s t) -> Prism s t a b
59−prismRavel l pab = (prism2prismvl $ l idPrism) pab
60−{-# INLINE prismRavel #-}
61−
62−type APrismVL s t a b = Market a b a (Identity b) -> Market a b s (Identity t)
63−
64−withPrism :: APrismVL s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
65−withPrism k f = case coerce (k (Market Identity Right)) of
66− Market bt seta -> f bt seta
67−
68−prism2prismvl :: Market a b s t -> Prism s t a b
69−prism2prismvl (Market bt seta) = prism bt seta
70−{-# INLINE prism2prismvl #-}
71−
72−build :: (Tagged b (Identity b) -> Tagged t (Identity t)) -> b -> t
73−build p = runIdentity #. unTagged #. p .# Tagged .# Identity
74−{-# INLINE build #-}
src/Data/Generics/Internal/VL/Traversal.hsdeleted−92
@@ -1,92 +0,0 @@
1−{-# OPTIONS_HADDOCK hide #-}
2−{-# LANGUAGE AllowAmbiguousTypes #-}
3−{-# LANGUAGE ConstraintKinds #-}
4−{-# LANGUAGE GADTs #-}
5−{-# LANGUAGE NoMonomorphismRestriction #-}
6−{-# LANGUAGE Rank2Types #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE TypeFamilies #-}
9−{-# LANGUAGE TypeFamilyDependencies #-}
10−{-# LANGUAGE TypeOperators #-}
11−
12−-----------------------------------------------------------------------------
13−-- |
14−-- Module : Data.Generics.Internal.VL.Traversal
15−-- Copyright : (C) 2019 Csongor Kiss
16−-- License : BSD3
17−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
18−-- Stability : experimental
19−-- Portability : non-portable
20−--
21−-- Internal lens helpers. Only exported for Haddock
22−--
23−-----------------------------------------------------------------------------
24−module Data.Generics.Internal.VL.Traversal where
25−
26−import Data.Kind (Constraint)
27−
28−-- | Type alias for traversal
29−type Traversal' s a
30− = forall f. Applicative f => (a -> f a) -> s -> f s
31−
32−type TraversalC (c :: * -> * -> Constraint) s t
33− = forall f. Applicative f => (forall a b. c a b => a -> f b) -> s -> f t
34−
35−type TraversalC' (c :: * -> Constraint) s
36− = forall f. Applicative f => (forall a. c a => a -> f a) -> s -> f s
37−
38−type Traversal s t a b
39− = forall f. Applicative f => (a -> f b) -> s -> f t
40−
41−type LensLikeC c f s
42− = (forall a. c a => a -> f a) -> s -> f s
43−
44−confusing :: Applicative f => Traversal s t a b -> (a -> f b) -> s -> f t
45−confusing t = \f -> lowerYoneda . lowerCurried . t (liftCurriedYoneda . f)
46−{-# INLINE confusing #-}
47−
48−-- fuse constrained traversals
49−confusingC :: forall c f s. Applicative f => TraversalC' c s -> LensLikeC c f s
50−confusingC t = \f -> lowerYoneda . lowerCurried . t (liftCurriedYoneda . f)
51−{-# INLINE confusingC #-}
52−
53−liftCurriedYoneda :: Applicative f => f a -> Curried (Yoneda f) a
54−liftCurriedYoneda fa = Curried (`yap` fa)
55−{-# INLINE liftCurriedYoneda #-}
56−
57−yap :: Applicative f => Yoneda f (a -> b) -> f a -> Yoneda f b
58−yap (Yoneda k) fa = Yoneda (\ab_r -> k (ab_r .) <*> fa)
59−{-# INLINE yap #-}
60−
61−newtype Curried f a =
62− Curried { runCurried :: forall r. f (a -> r) -> f r }
63−
64−instance Functor f => Functor (Curried f) where
65− fmap f (Curried g) = Curried (g . fmap (.f))
66− {-# INLINE fmap #-}
67−
68−instance (Functor f) => Applicative (Curried f) where
69− pure a = Curried (fmap ($ a))
70− {-# INLINE pure #-}
71− Curried mf <*> Curried ma = Curried (ma . mf . fmap (.))
72− {-# INLINE (<*>) #-}
73−
74−liftCurried :: Applicative f => f a -> Curried f a
75−liftCurried fa = Curried (<*> fa)
76−
77−lowerCurried :: Applicative f => Curried f a -> f a
78−lowerCurried (Curried f) = f (pure id)
79−newtype Yoneda f a = Yoneda { runYoneda :: forall b. (a -> b) -> f b }
80−
81−liftYoneda :: Functor f => f a -> Yoneda f a
82−liftYoneda a = Yoneda (\f -> fmap f a)
83−
84−lowerYoneda :: Yoneda f a -> f a
85−lowerYoneda (Yoneda f) = f id
86−
87−instance Functor (Yoneda f) where
88− fmap f m = Yoneda (\k -> runYoneda m (k . f))
89−
90−instance Applicative f => Applicative (Yoneda f) where
91− pure a = Yoneda (\f -> pure (f a))
92− Yoneda m <*> Yoneda n = Yoneda (\f -> m (f .) <*> n id)
src/Data/Generics/Internal/Void.hsdeleted−19
@@ -1,19 +0,0 @@
1−{-# LANGUAGE PolyKinds #-}
2−module Data.Generics.Internal.Void where
3−
4−{-
5− Note [Uncluttering type signatures]
6− ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
7−
8− Because the various instances in the library always match (the Has* classes
9− are essentially glorified constraint synonyms), they get replaced with
10− their constraints, resulting in large, unreadable types.
11−
12− Writing an (overlapping instance) for this Void type means that the original
13− instance might not be the one selected, thus GHC leaves the constraints in
14− place until further information is provided, at which point the type
15− machinery has sufficient information to reduce to sensible types.
16−-}
17−data Void
18−data Void1 a
19−data Void2 a b
src/Data/Generics/Labels.hsdeleted−142
@@ -1,142 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE CPP #-}
3−{-# LANGUAGE ConstraintKinds #-}
4−{-# LANGUAGE DataKinds #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE FunctionalDependencies #-}
7−{-# LANGUAGE MultiParamTypeClasses #-}
8−{-# LANGUAGE PolyKinds #-}
9−{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE TypeApplications #-}
11−{-# LANGUAGE TypeOperators #-}
12−{-# LANGUAGE TypeFamilies #-}
13−{-# LANGUAGE UndecidableInstances #-}
14−{-# OPTIONS_GHC -Wno-orphans #-}
15−
16−--------------------------------------------------------------------------------
17−-- |
18−-- Module : Data.Generics.Labels
19−-- Copyright : (C) 2019 Csongor Kiss
20−-- License : BSD3
21−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
22−-- Stability : experimental
23−-- Portability : non-portable
24−--
25−-- Provides an (orphan) IsLabel instance for field lenses and constructor prisms.
26−-- Use at your own risk.
27−--------------------------------------------------------------------------------
28−
29−module Data.Generics.Labels
30− ( -- * Orphan IsLabel Instance
31− -- $sec1
32− Field(..)
33− , Field'
34− , Constructor(..)
35− , Constructor'
36− ) where
37−
38−import Data.Generics.Product
39−import Data.Generics.Sum
40−import Data.Generics.Internal.VL.Lens (Lens)
41−import Data.Generics.Internal.VL.Prism (Prism)
42−
43−import Data.Profunctor (Choice)
44−import Data.Type.Bool (type (&&))
45−import Data.Type.Equality (type (==))
46−
47−import GHC.OverloadedLabels
48−import GHC.TypeLits
49−
50−-- $sec1
51−-- An instance for creating lenses and prisms with @#identifiers@ from the
52−-- @OverloadedLabels@ extension. Note that since overloaded labels do not
53−-- support symbols starting with capital letters, all prisms (which come from
54−-- constructor names, which are capitalized) must be prefixed with an underscore
55−-- (e.g. @#_ConstructorName@).
56−--
57−-- Morally:
58−--
59−-- @
60−-- instance (HasField name s t a b) => IsLabel name (Lens s t a b) where ...
61−-- @
62−-- and
63−--
64−-- @
65−-- instance (AsConstructor name s t a b) => IsLabel name (Prism s t a b) where ...
66−-- @
67−--
68−-- Remember:
69−--
70−-- @
71−-- type Lens = forall f. Functor f => (a -> f b) -> s -> f t
72−--
73−-- type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)
74−-- @
75−--
76−-- The orphan instance is unavoidable if we want to work with
77−-- lenses-as-functions (as opposed to a 'ReifiedLens'-like newtype).
78−
79−-- | 'Field' is morally the same as 'HasField', but it is constructed from an
80−-- incoherent combination of 'HasField' and 'HasField''. In this way, it can be
81−-- seamlessly used in the 'IsLabel' instance even when dealing with data types
82−-- that don't have 'Field' instances (like data instances).
83−class Field name s t a b | s name -> a, t name -> b, s name b -> t, t name a -> s where
84− fieldLens :: Lens s t a b
85−
86−type Field' name s a = Field name s s a a
87−
88−instance {-# INCOHERENT #-} HasField name s t a b => Field name s t a b where
89− fieldLens = field @name
90−
91−instance {-# INCOHERENT #-} HasField' name s a => Field name s s a a where
92− fieldLens = field' @name
93−
94−-- | 'Constructor' is morally the same as 'AsConstructor', but it is constructed from an
95−-- incoherent combination of 'AsConstructor' and 'AsConstructor''. In this way, it can be
96−-- seamlessly used in the 'IsLabel' instance even when dealing with data types
97−-- that don't have 'Constructor' instances (like data instances).
98−class Constructor name s t a b | name s -> a, name t -> b where
99− constructorPrism :: Prism s t a b
100−
101−type Constructor' name s a = Constructor name s s a a
102−
103−instance {-# INCOHERENT #-} AsConstructor name s t a b => Constructor name s t a b where
104− constructorPrism = _Ctor @name
105−
106−instance {-# INCOHERENT #-} AsConstructor' name s a => Constructor name s s a a where
107− constructorPrism = _Ctor' @name
108−
109−type family BeginsWithCapital (name :: Symbol) :: Bool where
110− BeginsWithCapital name = CmpSymbol "_@" name == 'LT && CmpSymbol "_[" name == 'GT
111−
112−instance ( capital ~ BeginsWithCapital name
113− , IsLabelHelper capital name p f s t a b
114− , pafb ~ p a (f b), psft ~ p s (f t)) => IsLabel name (pafb -> psft) where
115−#if __GLASGOW_HASKELL__ >= 802
116− fromLabel = labelOutput @capital @name @p @f
117−#else
118− fromLabel _ = labelOutput @capital @name @p @f
119−#endif
120−
121−-- | This helper class allows us to customize the output type of the lens to be
122−-- either 'Prism' or 'Lens' (by choosing appropriate @p@ and @f@) as well as to
123−-- choose between whether we're dealing with a lens or a prism. The choice is
124−-- made by whether the @capital@ argument is true or false, which is determined by
125−-- whether the symbol starts with an underscore followed by a capital letter
126−-- (a check done in the 'IsLabel' instance above). If so, then we're dealing
127−-- with a constructor name, which should be a prism, and otherwise, it's a field
128−-- name, so we have a lens.
129−class IsLabelHelper capital name p f s t a b where
130− labelOutput :: p a (f b) -> p s (f t)
131−
132−instance (Functor f, Field name s t a b) => IsLabelHelper 'False name (->) f s t a b where
133− labelOutput = fieldLens @name
134−
135−#if __GLASGOW_HASKELL__ >= 802
136−instance ( Applicative f, Choice p, Constructor name s t a b
137− , name' ~ AppendSymbol "_" name) => IsLabelHelper 'True name' p f s t a b where
138− labelOutput = constructorPrism @name
139−#else
140−instance (TypeError ('Text "Labels for Prisms require at least GHC 8.2"), Choice p) => IsLabelHelper 'True name' p f s t a b where
141− labelOutput = undefined
142−#endif
src/Data/Generics/Product.hs+11−23
@@ -1,7 +1,7 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2-- |
2-- |
3−-- Module : Data.Generics.Product
3+-- Module : Data.Generics.Record
4−-- Copyright : (C) 2019 Csongor Kiss
4+-- Copyright : (C) 2017 Csongor Kiss
5-- License : BSD3
5-- License : BSD3
6-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
6-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
7-- Stability : experimental
7-- Stability : experimental
@@ -14,27 +14,15 @@
14-- be derived (see examples).
14-- be derived (see examples).
15--
15--
16-----------------------------------------------------------------------------
16-----------------------------------------------------------------------------
17−
18module Data.Generics.Product
17module Data.Generics.Product
19− ( -- *Lenses
18+ (
20− module Data.Generics.Product.Any
19+ -- * Magic lens
21− , module Data.Generics.Product.Fields
20+ HasFieldAt (..)
22− , module Data.Generics.Product.Positions
21+
23− , module Data.Generics.Product.Subtype
22+ -- * Getter and setter
24− , module Data.Generics.Product.Typed
23+ , getFieldAt
25− , module Data.Generics.Product.HList
24+ , setFieldAt
26− -- *Traversals
25+
27− , module Data.Generics.Product.Types
28− , module Data.Generics.Product.Param
29− , module Data.Generics.Product.Constraints
30 ) where
26 ) where
31
27
32−import Data.Generics.Product.Any
28+import Data.Generics.Product.HasFieldAt
33−import Data.Generics.Product.Fields
34−import Data.Generics.Product.Positions
35−import Data.Generics.Product.Subtype
36−import Data.Generics.Product.Typed
37−import Data.Generics.Product.Types
38−import Data.Generics.Product.Constraints
39−import Data.Generics.Product.Param
40−import Data.Generics.Product.HList
src/Data/Generics/Product/Any.hsdeleted−79
@@ -1,79 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE FunctionalDependencies #-}
4−{-# LANGUAGE MonoLocalBinds #-}
5−{-# LANGUAGE MultiParamTypeClasses #-}
6−{-# LANGUAGE PolyKinds #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE TypeApplications #-}
9−{-# LANGUAGE TypeFamilies #-}
10−{-# LANGUAGE UndecidableInstances #-}
11−
12−-----------------------------------------------------------------------------
13−-- |
14−-- Module : Data.Generics.Product.Any
15−-- Copyright : (C) 2019 Csongor Kiss
16−-- License : BSD3
17−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
18−-- Stability : experimental
19−-- Portability : non-portable
20−--
21−-- Derive a variety of lenses generically.
22−--
23−-----------------------------------------------------------------------------
24−
25−module Data.Generics.Product.Any
26− ( -- *Lenses
27− --
28− -- $setup
29− HasAny (..)
30− ) where
31−
32−import Data.Generics.Internal.VL.Lens
33−import Data.Generics.Product.Fields
34−import Data.Generics.Product.Positions
35−import Data.Generics.Product.Typed
36−
37−-- $setup
38−-- == /Running example:/
39−--
40−-- >>> :set -XTypeApplications
41−-- >>> :set -XDataKinds
42−-- >>> :set -XDeriveGeneric
43−-- >>> import GHC.Generics
44−-- >>> :m +Data.Generics.Internal.VL.Lens
45−-- >>> :{
46−-- data Human = Human
47−-- { name :: String
48−-- , age :: Int
49−-- , address :: String
50−-- }
51−-- deriving (Generic, Show)
52−-- human :: Human
53−-- human = Human "Tunyasz" 50 "London"
54−-- :}
55−
56−class HasAny sel s t a b | s sel -> a where
57− -- |A lens that focuses on a part of a product as identified by some
58− -- selector. Currently supported selectors are field names, positions and
59− -- unique types. Compatible with the lens package's 'Control.Lens.Lens'
60− -- type.
61− --
62− -- >>> human ^. the @Int
63− -- 50
64− --
65− -- >>> human ^. the @"name"
66− -- "Tunyasz"
67− --
68− -- >>> human ^. the @3
69− -- "London"
70− the :: Lens s t a b
71−
72−instance HasPosition i s t a b => HasAny i s t a b where
73− the = position @i
74−
75−instance HasField field s t a b => HasAny field s t a b where
76− the = field @field
77−
78−instance (HasType a s, t ~ s, a ~ b) => HasAny a s t a b where
79− the = typed @a
src/Data/Generics/Product/Constraints.hsdeleted−57
@@ -1,57 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE ConstraintKinds #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE KindSignatures #-}
5−{-# LANGUAGE MultiParamTypeClasses #-}
6−{-# LANGUAGE Rank2Types #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE TypeApplications #-}
9−{-# LANGUAGE UndecidableInstances #-}
10−
11−-----------------------------------------------------------------------------
12−-- |
13−-- Module : Data.Generics.Product.Constraints
14−-- Copyright : (C) 2019 Csongor Kiss
15−-- License : BSD3
16−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17−-- Stability : experimental
18−-- Portability : non-portable
19−--
20−-- Constrained traversals.
21−--
22−-----------------------------------------------------------------------------
23−
24−module Data.Generics.Product.Constraints
25− ( -- *Traversals
26− --
27− -- $example
28− HasConstraints (..)
29− , HasConstraints' (..)
30− ) where
31−
32−import Data.Generics.Product.Internal.Constraints
33−import Data.Kind (Constraint)
34−
35−import GHC.Generics (Generic (Rep), from, to)
36−import Data.Generics.Internal.VL.Traversal
37−
38−class HasConstraints' (c :: * -> Constraint) s where
39− constraints' :: TraversalC' c s
40−
41−instance
42− ( Generic s
43− , GHasConstraints' c (Rep s)
44− ) => HasConstraints' c s where
45− constraints' = confusingC @c (\f s -> to <$> gconstraints' @c f (from s))
46− {-# INLINE constraints' #-}
47−
48−class HasConstraints (c :: * -> * -> Constraint) s t where
49− constraints :: TraversalC c s t
50−
51−instance
52− ( Generic s
53− , Generic t
54− , GHasConstraints c (Rep s) (Rep t)
55− ) => HasConstraints c s t where
56− constraints f s = to <$> gconstraints @c f (from s)
57− {-# INLINE constraints #-}
src/Data/Generics/Product/Fields.hsdeleted−240
@@ -1,240 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE CPP #-}
3−{-# LANGUAGE ConstraintKinds #-}
4−{-# LANGUAGE DataKinds #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE FunctionalDependencies #-}
7−{-# LANGUAGE MultiParamTypeClasses #-}
8−{-# LANGUAGE ScopedTypeVariables #-}
9−{-# LANGUAGE TypeApplications #-}
10−{-# LANGUAGE TypeFamilies #-}
11−{-# LANGUAGE TypeInType #-}
12−{-# LANGUAGE TypeOperators #-}
13−{-# LANGUAGE UndecidableInstances #-}
14−{-# LANGUAGE UndecidableSuperClasses #-}
15−
16−-----------------------------------------------------------------------------
17−-- |
18−-- Module : Data.Generics.Product.Fields
19−-- Copyright : (C) 2019 Csongor Kiss
20−-- License : BSD3
21−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
22−-- Stability : experimental
23−-- Portability : non-portable
24−--
25−-- Derive record field getters and setters generically.
26−--
27−-----------------------------------------------------------------------------
28−
29−module Data.Generics.Product.Fields
30− ( -- *Lenses
31−
32− -- $setup
33− HasField (..)
34− , HasField' (..)
35− , HasField_ (..)
36−
37− , getField
38− , setField
39− ) where
40−
41−import Data.Generics.Internal.Families
42−import Data.Generics.Internal.VL.Lens as VL
43−import Data.Generics.Internal.Void
44−import Data.Generics.Product.Internal.GLens
45−
46−import Data.Kind (Constraint, Type)
47−import GHC.Generics
48−import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError)
49−import Data.Generics.Internal.Profunctor.Lens as P
50−import Data.Generics.Internal.Errors
51−
52−-- $setup
53−-- == /Running example:/
54−--
55−-- >>> :set -XTypeApplications
56−-- >>> :set -XDataKinds
57−-- >>> :set -XDeriveGeneric
58−-- >>> :set -XGADTs
59−-- >>> :set -XFlexibleContexts
60−-- >>> import GHC.Generics
61−-- >>> :m +Data.Generics.Internal.VL.Lens
62−-- >>> :m +Data.Function
63−-- >>> :{
64−-- data Human a
65−-- = Human
66−-- { name :: String
67−-- , age :: Int
68−-- , address :: String
69−-- , other :: a
70−-- }
71−-- | HumanNoAddress
72−-- { name :: String
73−-- , age :: Int
74−-- , other :: a
75−-- }
76−-- deriving (Generic, Show)
77−-- human :: Human Bool
78−-- human = Human { name = "Tunyasz", age = 50, address = "London", other = False }
79−-- :}
80−
81−-- |Records that have a field with a given name.
82−class HasField (field :: Symbol) s t a b | s field -> a, t field -> b, s field b -> t, t field a -> s where
83− -- |A lens that focuses on a field with a given name. Compatible with the
84− -- lens package's 'Control.Lens.Lens' type.
85− --
86− -- >>> human ^. field @"age"
87− -- 50
88− --
89− -- === /Type changing/
90− --
91− -- >>> :t human
92− -- human :: Human Bool
93− --
94− -- >>> :t human & field @"other" .~ (42 :: Int)
95− -- human & field @"other" .~ (42 :: Int) :: Human Int
96− --
97− -- >>> human & field @"other" .~ 42
98− -- Human {name = "Tunyasz", age = 50, address = "London", other = 42}
99− --
100− -- === /Type errors/
101− --
102− -- >>> human & field @"weight" .~ 42
103− -- ...
104− -- ... The type Human Bool does not contain a field named 'weight'.
105− -- ...
106− --
107− -- >>> human & field @"address" .~ ""
108− -- ...
109− -- ... Not all constructors of the type Human Bool
110− -- ... contain a field named 'address'.
111− -- ... The offending constructors are:
112− -- ... HumanNoAddress
113− -- ...
114− field :: VL.Lens s t a b
115−
116−-- |Records that have a field with a given name.
117−--
118−-- This is meant to be more general than 'HasField', but that is not quite the
119−-- case due to the lack of functional dependencies.
120−--
121−-- The types @s@ and @t@ must be applications of the same type constructor.
122−-- In contrast, 'HasField' also requires the parameters of that type constructor
123−-- to have representational roles.
124−--
125−-- One use case of 'HasField_' over 'HasField' is for records defined with
126−-- @data instance@.
127−class HasField_ (field :: Symbol) s t a b where
128− field_ :: VL.Lens s t a b
129−
130−class HasField' (field :: Symbol) s a | s field -> a where
131− field' :: VL.Lens s s a a
132−
133−-- |Records that have a field with a given name.
134−--
135−-- This class gives the minimal constraints needed to define this lens.
136−-- For common uses, see 'HasField'.
137−class HasField0 (field :: Symbol) s t a b where
138− field0 :: VL.Lens s t a b
139−
140−-- |
141−-- >>> getField @"age" human
142−-- 50
143−getField :: forall f a s. HasField' f s a => s -> a
144−getField = VL.view (field' @f)
145−
146−-- |
147−-- >>> setField @"age" 60 human
148−-- Human {name = "Tunyasz", age = 60, address = "London", other = False}
149−setField :: forall f s a. HasField' f s a => a -> s -> s
150−setField = VL.set (field' @f)
151−
152−instance
153− ( Generic s
154− , ErrorUnless field s (CollectField field (Rep s))
155− , GLens' (HasTotalFieldPSym field) (Rep s) a
156− , Defined (Rep s)
157− (NoGeneric s '[ 'Text "arising from a generic lens focusing on the "
158− ':<>: QuoteType field ':<>: 'Text " field of type " ':<>: QuoteType a
159− , 'Text "in " ':<>: QuoteType s])
160− (() :: Constraint)
161− ) => HasField' field s a where
162− field' f s = field0 @field f s
163−
164−class (~~) (a :: k) (b :: k) | a -> b, b -> a
165−instance (a ~ b) => (~~) a b
166−
167−instance -- see Note [Changing type parameters]
168− ( HasTotalFieldP field (Rep s) ~~ 'Just a
169− , HasTotalFieldP field (Rep t) ~~ 'Just b
170− , HasTotalFieldP field (Rep (Indexed s)) ~~ 'Just a'
171− , HasTotalFieldP field (Rep (Indexed t)) ~~ 'Just b'
172− , t ~~ Infer s a' b
173− , s ~~ Infer t b' a
174− , HasField0 field s t a b
175− ) => HasField field s t a b where
176− field f s = field0 @field f s
177−
178−-- | See Note [Uncluttering type signatures]
179−#if __GLASGOW_HASKELL__ < 804
180−-- >>> :t field
181−-- field
182−-- :: (HasField field s t a b, Functor f) => (a -> f b) -> s -> f t
183−#else
184−-- >>> :t field
185−-- field
186−-- :: (Functor f, HasField field s t a b) => (a -> f b) -> s -> f t
187−#endif
188−instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where
189− field = undefined
190−
191−instance
192− ( HasTotalFieldP field (Rep s) ~~ 'Just a
193− , HasTotalFieldP field (Rep t) ~~ 'Just b
194− , UnifyHead s t
195− , UnifyHead t s
196− , HasField0 field s t a b
197− ) => HasField_ field s t a b where
198− field_ f s = field0 @field f s
199−
200−instance {-# OVERLAPPING #-} HasField_ f (Void1 a) (Void1 b) a b where
201− field_ = undefined
202−
203−instance
204− ( Generic s
205− , Generic t
206− , GLens (HasTotalFieldPSym field) (Rep s) (Rep t) a b
207− , ErrorUnless field s (CollectField field (Rep s))
208− , Defined (Rep s)
209− (NoGeneric s '[ 'Text "arising from a generic lens focusing on the "
210− ':<>: QuoteType field ':<>: 'Text " field of type " ':<>: QuoteType a
211− , 'Text "in " ':<>: QuoteType s])
212− (() :: Constraint)
213− ) => HasField0 field s t a b where
214− field0 = VL.ravel (repLens . glens @(HasTotalFieldPSym field))
215− {-# INLINE field0 #-}
216−
217−type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Constraint where
218− ErrorUnless field s ('TypeStat _ _ '[])
219− = TypeError
220− ( 'Text "The type "
221− ':<>: 'ShowType s
222− ':<>: 'Text " does not contain a field named '"
223− ':<>: 'Text field ':<>: 'Text "'."
224− )
225−
226− ErrorUnless field s ('TypeStat (n ': ns) _ _)
227− = TypeError
228− ( 'Text "Not all constructors of the type "
229− ':<>: 'ShowType s
230− ':$$: 'Text " contain a field named '"
231− ':<>: 'Text field ':<>: 'Text "'."
232− ':$$: 'Text "The offending constructors are:"
233− ':$$: ShowSymbols (n ': ns)
234− )
235−
236− ErrorUnless _ _ ('TypeStat '[] '[] _)
237− = ()
238−
239−data HasTotalFieldPSym :: Symbol -> (TyFun (Type -> Type) (Maybe Type))
240−type instance Eval (HasTotalFieldPSym sym) tt = HasTotalFieldP sym tt
src/Data/Generics/Product/HList.hsdeleted−46
@@ -1,46 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE FunctionalDependencies #-}
5−{-# LANGUAGE MonoLocalBinds #-}
6−{-# LANGUAGE ScopedTypeVariables #-}
7−{-# LANGUAGE TypeInType #-}
8−{-# LANGUAGE UndecidableInstances #-}
9−
10−-----------------------------------------------------------------------------
11−-- |
12−-- Module : Data.Generics.Product.HList
13−-- Copyright : (C) 2019 Csongor Kiss
14−-- License : BSD3
15−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16−-- Stability : experimental
17−-- Portability : non-portable
18−--
19−-- Derive an isomorphism between a product type and a flat HList.
20−--
21−-----------------------------------------------------------------------------
22−
23−module Data.Generics.Product.HList
24− ( IsList (..)
25− ) where
26−
27−import Data.Generics.Product.Internal.HList
28−import Data.Kind
29−import GHC.Generics
30−import Data.Generics.Internal.VL.Iso (Iso)
31−import Data.Generics.Internal.Profunctor.Iso (repIso, iso2isovl)
32−
33−class IsList
34− (f :: Type)
35− (g :: Type)
36− (as :: [Type])
37− (bs :: [Type]) | f -> as, g -> bs where
38− list :: Iso f g (HList as) (HList bs)
39−
40−instance
41− ( Generic f
42− , Generic g
43− , GIsList (Rep f) (Rep g) as bs
44− ) => IsList f g as bs where
45− list = iso2isovl (repIso . glist)
46− {-# INLINE list #-}
src/Data/Generics/Product/HasFieldAt.hsnew file+176
@@ -0,0 +1,176 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE PolyKinds #-}
6+{-# LANGUAGE Rank2Types #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeApplications #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeOperators #-}
11+{-# LANGUAGE UndecidableInstances #-}
12+
13+-----------------------------------------------------------------------------
14+-- |
15+-- Module : Data.Generics.Product.HasFieldAt
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 product items lenses generically.
23+--
24+-- @
25+--
26+-- module Example where
27+--
28+-- import GHC.Generics
29+-- import Data.Generics.Product
30+--
31+-- data Human = Human String Int String
32+-- deriving (Generic, Show)
33+--
34+-- human :: Human
35+-- human = Human \"Tunyasz\" 50 \"London\"
36+--
37+-- @
38+--
39+-----------------------------------------------------------------------------
40+
41+module Data.Generics.Product.HasFieldAt
42+ ( HasFieldAt (..)
43+ -- * Getter and setter functions
44+ , getFieldAt
45+ , setFieldAt
46+ ) where
47+
48+import Data.Generics.Internal.Lens
49+
50+import GHC.TypeLits
51+import Data.Kind (Type)
52+import GHC.Generics
53+
54+-- | Get positional field
55+--
56+-- >>> getFieldAt @1 human
57+-- "Tunyasz"
58+getFieldAt :: forall index a s. HasFieldAt index a s => s -> a
59+getFieldAt s = s ^. itemAt @index
60+
61+-- | Set positional field
62+--
63+-- >>> setFieldAt @2 (setField @1 "Tamas" human) 30
64+-- Human "Tamas" 30 "London"
65+setFieldAt :: forall index a s. HasFieldAt index a s => a -> s -> s
66+setFieldAt = set (itemAt @index)
67+
68+-- | Types that have a field at given position.
69+class HasFieldAt (index :: Nat) a s | s index -> a where
70+ -- ^ Lens focusing on a field at a given index.
71+ -- Compatible with the lens package.
72+ --
73+ -- >>> human & itemAt @1 .~ "Tamas"
74+ -- Human "Tamas" 50 "London"
75+ itemAt :: Lens' s a
76+
77+-- | Fields are indexed from BaseIndex upwards.
78+type BaseIndex = 1
79+
80+-- | Instances are generated on the fly for all types that have the required
81+-- positional field.
82+instance
83+ ( Generic s
84+ , ContainsAt BaseIndex index (Rep s) ~ 'True -- this is needed for the fundep
85+ , GHasFieldAt BaseIndex index (Rep s) a
86+ ) => HasFieldAt index a s where
87+ itemAt = repIso . gItemAt @BaseIndex @index
88+
89+data Choice = GoLeft | GoRight
90+
91+class GHasFieldAtProd offset index a b ret (w :: Choice) | offset index a b w -> ret where
92+ prodItemAt :: Lens' ((a :*: b) x) ret
93+
94+instance (GHasFieldAt offset index f ret) => GHasFieldAtProd offset index f g ret 'GoLeft where
95+ prodItemAt = first . gItemAt @offset @index
96+
97+instance (GHasFieldAt offset index g ret) => GHasFieldAtProd offset index f g ret 'GoRight where
98+ prodItemAt = second . gItemAt @offset @index
99+
100+--------------------------------------------------------------------------------
101+
102+type family Search offset index f g :: Choice where
103+ Search offset index f g = Choose (ContainsAt offset index f) (ContainsAt (offset + Size f) index g)
104+
105+type family Choose f g :: Choice where
106+ Choose 'True _ = 'GoLeft
107+ Choose _ 'True = 'GoRight
108+ Choose _ _ = TypeError ('Text "Could not find type")
109+
110+-- | Try find a field by position in the generic representation.
111+type family ContainsAt (offset :: Nat) (index :: Nat) f :: Bool where
112+ ContainsAt offset index (D1 m f)
113+ = ContainsAt offset index f
114+ ContainsAt n n (S1 _ _)
115+ = 'True
116+ ContainsAt _ _ (S1 _ _)
117+ = 'False
118+ ContainsAt offset index (f :*: g)
119+ = ContainsAt offset index f || ContainsAt (Size f + offset) index g
120+ ContainsAt offset index (C1 m f)
121+ = ContainsAt offset index f
122+ ContainsAt offset index (Rec0 _)
123+ = 'False
124+ ContainsAt offset index U1
125+ = 'False
126+ ContainsAt offset index V1
127+ = 'False
128+ ContainsAt offset index t = TypeError ('ShowType offset ':<>: 'Text " " ':<>: 'ShowType index)
129+
130+-- | Returns the count of terminal nodes in the generic representation.
131+type family Size f :: Nat where
132+ Size (D1 m f)
133+ = Size f
134+ Size (f :*: g)
135+ = Size f + Size g
136+ Size (C1 m f)
137+ = Size f
138+ Size t = 1
139+
140+-- | If traversing to the left, offset does not change.
141+-- If traversing to the right, offset is incremented by size of left subtree.
142+type family Offset (offset :: Nat) (choice :: Choice) (size :: Nat) :: Nat where
143+ Offset n 'GoLeft _ = n
144+ Offset n 'GoRight s = n + s
145+
146+-- | Type-level or
147+type family (a :: Bool) || (b :: Bool) :: Bool where
148+ 'True || _ = 'True
149+ _ || b = b
150+
151+--------------------------------------------------------------------------------
152+
153+-- | Like 'HasFieldAt', but on the generic representation
154+class GHasFieldAt (offset :: Nat) (index :: Nat) (s :: Type -> Type) a | offset index s -> a where
155+ gItemAt :: Lens' (s x) a
156+
157+instance
158+ ( choice ~ (Search offset index s s')
159+ , offset' ~ Offset offset choice (Size s)
160+ , GHasFieldAtProd offset' index s s' a choice
161+ )
162+ => GHasFieldAt offset index (s :*: s') a where
163+ gItemAt = prodItemAt @offset' @index @_ @_ @_ @choice
164+
165+instance GHasFieldAt offset index (K1 R a) a where
166+ gItemAt f (K1 x) = fmap K1 (f x)
167+
168+instance GHasFieldAt n n (S1 ('MetaSel m p f b) (Rec0 a)) a where
169+ gItemAt = lensM . gItemAt @n @n
170+
171+instance GHasFieldAt offset index s a => GHasFieldAt offset index (M1 D c s) a where
172+ gItemAt = lensM . gItemAt @offset @index
173+
174+instance GHasFieldAt offset index s a => GHasFieldAt offset index (M1 C c s) a where
175+ gItemAt = lensM . gItemAt @offset @index
176+
src/Data/Generics/Product/Internal/Constraints.hsdeleted−136
@@ -1,136 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE ConstraintKinds #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE FunctionalDependencies #-}
7−{-# LANGUAGE GADTs #-}
8−{-# LANGUAGE Rank2Types #-}
9−{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE TypeApplications #-}
11−{-# LANGUAGE TypeFamilyDependencies #-}
12−{-# LANGUAGE TypeOperators #-}
13−{-# LANGUAGE UndecidableInstances #-}
14−
15−-----------------------------------------------------------------------------
16−-- |
17−-- Module : Data.Generics.Product.Internal.Constraints
18−-- Copyright : (C) 2019 Csongor Kiss
19−-- License : BSD3
20−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21−-- Stability : experimental
22−-- Portability : non-portable
23−--
24−-- Derive constrained traversals
25−--
26−-----------------------------------------------------------------------------
27−
28−-- TODO: use type-changing variant
29−
30−module Data.Generics.Product.Internal.Constraints
31− (
32− GHasConstraints (..)
33− , GHasConstraints' (..)
34− ) where
35−
36−import Data.Kind (Type, Constraint)
37−import GHC.Generics
38−import Data.Generics.Internal.VL.Iso
39−import Data.Generics.Internal.VL.Traversal
40−import Data.Generics.Product.Internal.HList
41−
42−-- | Constrained traversal.
43−class GHasConstraints' (c :: * -> Constraint) (f :: * -> *) where
44− gconstraints' :: forall g x.
45− Applicative g => (forall a. c a => a -> g a) -> f x -> g (f x)
46−
47−instance
48− ( GHasConstraints' c l
49− , GHasConstraints' c r
50− ) => GHasConstraints' c (l :*: r) where
51− gconstraints' f (l :*: r)
52− = (:*:) <$> gconstraints' @c f l <*> gconstraints' @c f r
53−
54−instance
55− ( GHasConstraints' c l
56− , GHasConstraints' c r
57− ) => GHasConstraints' c (l :+: r) where
58− gconstraints' f (L1 l) = L1 <$> gconstraints' @c f l
59− gconstraints' f (R1 r) = R1 <$> gconstraints' @c f r
60−
61−instance c a => GHasConstraints' c (Rec0 a) where
62− gconstraints' = kIso
63−
64−instance GHasConstraints' c f
65− => GHasConstraints' c (M1 m meta f) where
66− gconstraints' f (M1 x) = M1 <$> gconstraints' @c f x
67−
68−instance GHasConstraints' c U1 where
69− gconstraints' _ _ = pure U1
70−
71−--------------------------------------------------------------------------------
72−
73−class GHasConstraints (c :: * -> * -> Constraint) s t where
74− gconstraints :: TraversalC c (s x) (t x)
75−
76−instance
77− ( GHasConstraints c l l'
78− , GHasConstraints c r r'
79− ) => GHasConstraints c (l :*: r) (l' :*: r') where
80− gconstraints f (l :*: r)
81− = (:*:) <$> gconstraints @c f l <*> gconstraints @c f r
82−
83−instance
84− ( GHasConstraints c l l'
85− , GHasConstraints c r r'
86− ) => GHasConstraints c (l :+: r) (l' :+: r') where
87− gconstraints f (L1 l) = L1 <$> gconstraints @c f l
88− gconstraints f (R1 r) = R1 <$> gconstraints @c f r
89−
90−instance GHasConstraints c s t
91− => GHasConstraints c (M1 i m s) (M1 i m t) where
92− gconstraints f (M1 x) = M1 <$> gconstraints @c f x
93−
94−instance GHasConstraints c U1 U1 where
95− gconstraints _ _ = pure U1
96−
97−instance GHasConstraints c V1 V1 where
98− gconstraints _ = pure
99−
100−instance c a b => GHasConstraints c (Rec0 a) (Rec0 b) where
101− gconstraints = kIso
102−
103−--------------------------------------------------------------------------------
104−
105−-- | Multi-traversal
106−--type GHasTypes rep as = GHasConstraints (Contains as) rep
107−
108−-- Try to use a function from the list, or default to 'pure' if not present
109−{-
110−gtypes
111− :: forall as x f g.
112− ( GHasTypes f as
113− , Applicative g
114− ) => HList (Functions as g) -> f x -> g (f x)
115−gtypes hl s = gconstraints @(Contains as) (pick hl) s
116−-}
117−
118−--------------------------------------------------------------------------------
119−
120−-- >>> :kind! Functions '[Int, Char, Bool] Maybe
121−-- '[Int -> Maybe Int, Char -> Maybe Char, Bool -> Maybe Bool]
122−type family Functions (ts :: [Type]) (g :: Type -> Type) = r | r -> ts where
123− Functions '[] _ = '[]
124− Functions (t ': ts) g = ((t -> g t) ': Functions ts g)
125−
126−class Contains as a where
127− pick :: Applicative g => HList (Functions as g) -> a -> g a
128−
129−instance {-# OVERLAPPING #-} Contains (a ': as) a where
130− pick (h :> _) = h
131−
132−instance Contains as a => Contains (b ': as) a where
133− pick (_ :> hs) = pick hs
134−
135−instance Contains '[] a where
136− pick _ = pure
src/Data/Generics/Product/Internal/GLens.hsdeleted−81
@@ -1,81 +0,0 @@
1−{-# LANGUAGE FlexibleContexts #-}
2−{-# LANGUAGE TypeInType #-}
3−{-# LANGUAGE AllowAmbiguousTypes #-}
4−{-# LANGUAGE ConstraintKinds #-}
5−{-# LANGUAGE DataKinds #-}
6−{-# LANGUAGE FlexibleInstances #-}
7−{-# LANGUAGE FunctionalDependencies #-}
8−{-# LANGUAGE KindSignatures #-}
9−{-# LANGUAGE MultiParamTypeClasses #-}
10−{-# LANGUAGE Rank2Types #-}
11−{-# LANGUAGE ScopedTypeVariables #-}
12−{-# LANGUAGE TypeApplications #-}
13−{-# LANGUAGE TypeFamilies #-}
14−{-# LANGUAGE TypeOperators #-}
15−{-# LANGUAGE UndecidableInstances #-}
16−
17−-----------------------------------------------------------------------------
18−-- |
19−-- Module : Data.Generics.Product.Internal.GLens
20−-- Copyright : (C) 2019 Csongor Kiss
21−-- License : BSD3
22−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
23−-- Stability : experimental
24−-- Portability : non-portable
25−--
26−-- Derive record field getters and setters generically.
27−--
28−-----------------------------------------------------------------------------
29−
30−module Data.Generics.Product.Internal.GLens
31− ( GLens (..)
32− , GLens'
33− , TyFun
34− , Eval
35− ) where
36−
37−import Data.Generics.Internal.Profunctor.Lens (Lens, choosing, first, second)
38−import Data.Generics.Internal.Profunctor.Iso (kIso, sumIso, mIso)
39−
40−import Data.Kind (Type)
41−import GHC.Generics
42−
43−type Pred = TyFun (Type -> Type) (Maybe Type)
44−
45−type TyFun a b = a -> b -> Type
46−type family Eval (f :: TyFun a b) (x :: a) :: b
47−
48−-- A generic lens that uses some predicate to determine which field to focus on
49−class GLens (pred :: Pred) (s :: Type -> Type) (t :: Type -> Type) a b | s pred -> a, t pred -> b where
50− glens :: Lens (s x) (t x) a b
51−
52−type GLens' pred s a = GLens pred s s a a
53−
54−instance GProductLens (Eval pred l) pred l r l' r' a b
55− => GLens pred (l :*: r) (l' :*: r') a b where
56−
57− glens = gproductLens @(Eval pred l) @pred
58− {-# INLINE glens #-}
59−
60−instance (GLens pred l l' a b, GLens pred r r' a b) => GLens pred (l :+: r) (l' :+: r') a b where
61− glens = sumIso . choosing (glens @pred) (glens @pred)
62− {-# INLINE glens #-}
63−
64−instance GLens pred (K1 r a) (K1 r b) a b where
65− glens = kIso
66− {-# INLINE glens #-}
67−
68−instance (GLens pred f g a b) => GLens pred (M1 m meta f) (M1 m meta g) a b where
69− glens = mIso . glens @pred
70− {-# INLINE glens #-}
71−
72−class GProductLens (left :: Maybe Type) (pred :: Pred) l r l' r' a b | pred l r -> a, pred l' r' -> b where
73− gproductLens :: Lens ((l :*: r) x) ((l' :*: r') x) a b
74−
75−instance GLens pred l l' a b => GProductLens ('Just x) pred l r l' r a b where
76− gproductLens = first . glens @pred
77− {-# INLINE gproductLens #-}
78−
79−instance GLens pred r r' a b => GProductLens 'Nothing pred l r l r' a b where
80− gproductLens = second . glens @pred
81− {-# INLINE gproductLens #-}
src/Data/Generics/Product/Internal/HList.hsdeleted−329
@@ -1,329 +0,0 @@
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.HList
23−-- Copyright : (C) 2019 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.HList
34− ( GIsList(..)
35− , IndexList (..)
36− , HList (..)
37− , type (++)
38− , Elem
39− , ListTuple (..)
40− , TupleToList
41− ) where
42−
43−#if __GLASGOW_HASKELL__ < 804
44−import Data.Semigroup
45−#endif
46−import GHC.TypeLits
47−
48−import Data.Kind (Type)
49−import GHC.Generics
50−import Data.Profunctor
51−import Data.Generics.Internal.Profunctor.Lens
52−import Data.Generics.Internal.Profunctor.Iso
53−
54−data HList (as :: [Type]) where
55− Nil :: HList '[]
56− (:>) :: a -> HList as -> HList (a ': as)
57−
58−infixr 5 :>
59−
60−type family ((as :: [k]) ++ (bs :: [k])) :: [k] where
61− '[] ++ bs = bs
62− (a ': as) ++ bs = a ': as ++ bs
63−
64−instance Semigroup (HList '[]) where
65− _ <> _ = Nil
66−
67−instance Monoid (HList '[]) where
68− mempty = Nil
69− mappend _ _ = Nil
70−
71−instance (Semigroup a, Semigroup (HList as)) => Semigroup (HList (a ': as)) where
72− (x :> xs) <> (y :> ys) = (x <> y) :> (xs <> ys)
73−
74−instance (Monoid a, Monoid (HList as)) => Monoid (HList (a ': as)) where
75− mempty = mempty :> mempty
76− mappend (x :> xs) (y :> ys) = mappend x y :> mappend xs ys
77−
78−class Elem (as :: [(k, Type)]) (key :: k) (i :: Nat) a | as key -> i a
79−instance {-# OVERLAPPING #-} pos ~ 0 => Elem (a ': xs) key pos a
80−instance (Elem xs key i a, pos ~ (i + 1)) => Elem (x ': xs) key pos a
81−
82−class GIsList
83− (f :: Type -> Type)
84− (g :: Type -> Type)
85− (as :: [Type])
86− (bs :: [Type]) | f -> as, g -> bs, bs f -> g, as g -> f where
87−
88− glist :: Iso (f x) (g x) (HList as) (HList bs)
89−
90− -- We define this reversed version, otherwise uses of `fromIso glist` are not
91− -- properly inlined by GHC 8.0.2.
92− -- This is not actually used.
93− glistR :: Iso (HList bs) (HList as) (g x) (f x)
94− glistR = fromIso glist
95−
96−instance
97− ( GIsList l l' as as'
98− , GIsList r r' bs bs'
99− , Appending as bs cs as' bs' cs'
100− , cs ~ (as ++ bs)
101− , cs' ~ (as' ++ bs')
102− ) => GIsList (l :*: r) (l' :*: r') cs cs' where
103−
104− glist = prodIso . pairing glist glist . appending
105− {-# INLINE glist #-}
106−
107−instance GIsList f g as bs => GIsList (M1 t meta f) (M1 t meta g) as bs where
108− glist = mIso . glist
109− {-# INLINE glist #-}
110−
111−instance GIsList (Rec0 a) (Rec0 b) '[a] '[b] where
112− glist = kIso . singleton
113− {-# INLINE glist #-}
114−
115−instance GIsList U1 U1 '[] '[] where
116− glist = iso (const Nil) (const U1)
117− {-# INLINE glist #-}
118−
119−--------------------------------------------------------------------------------
120−-- | as ++ bs === cs
121−class Appending as bs cs as' bs' cs'
122− | as bs cs cs' -> as' bs'
123− , as' bs' cs cs' -> as bs
124− , as bs -> cs
125− , as' bs' -> cs'
126− where
127− appending :: Iso (HList as, HList bs) (HList as', HList bs') (HList cs) (HList cs')
128−
129−-- | [] ++ bs === bs
130−instance Appending '[] bs bs '[] bs' bs' where
131− appending = iso snd (Nil,)
132−
133−-- | (a : as) ++ bs === (a : cs)
134−instance
135− Appending as bs cs as' bs' cs' -- as ++ bs == cs
136− => Appending (a ': as) bs (a ': cs) (a' ': as') bs' (a' ': cs') where
137− appending
138− = pairing (fromIso consing) id -- ((a, as), bs)
139− . assoc3 -- (a, (as, bs))
140− . pairing id appending -- (a, cs)
141− . consing -- (a : cs)
142−
143−singleton :: Iso a b (HList '[a]) (HList '[ b])
144−singleton = iso (:> Nil) (\(x :> _) -> x)
145−
146−consing :: Iso (a, HList as) (b, HList bs) (HList (a ': as)) (HList (b ': bs))
147−consing = iso (\(x, xs) -> x :> xs) (\(x :> xs) -> (x, xs))
148−
149−--------------------------------------------------------------------------------
150−class IndexList (i :: Nat) as bs a b | i as -> a, i bs -> b, i as b -> bs, i bs a -> as where
151− point :: Lens (HList as) (HList bs) a b
152−
153−instance {-# OVERLAPPING #-}
154− ( as ~ (a ': as')
155− , bs ~ (b ': as')
156− ) => IndexList 0 as bs a b where
157− point = lens (\(x :> xs) -> (xs, x)) (\(xs, x') -> x' :> xs)
158− {-# INLINE point #-}
159−
160−instance
161− ( IndexList (n - 1) as' bs' a b
162− , as ~ (x ': as')
163− , bs ~ (x ': bs')
164− ) => IndexList n as bs a b where
165− point = fromIso consing . alongside id (point @(n-1)) . second'
166− {-# INLINE point #-}
167−
168−--------------------------------------------------------------------------------
169−-- * Convert tuples to/from HLists
170−
171−class ListTuple (tuple :: Type) (as :: [Type]) | as -> tuple where
172− type ListToTuple as :: Type
173− tupled :: Iso' (HList as) tuple
174− tupled = iso listToTuple tupleToList
175−
176− tupleToList :: tuple -> HList as
177− listToTuple :: HList as -> tuple
178−
179−instance ListTuple () '[] where
180− type ListToTuple '[] = ()
181− tupleToList _ = Nil
182− listToTuple _ = ()
183−
184−instance ListTuple a '[a] where
185− type ListToTuple '[a] = a
186− tupleToList a
187− = a :> Nil
188− listToTuple (a :> Nil)
189− = a
190−
191−instance ListTuple (a, b) '[a, b] where
192− type ListToTuple '[a, b] = (a, b)
193− tupleToList (a, b)
194− = a :> b :> Nil
195− listToTuple (a :> b :> Nil)
196− = (a, b)
197−
198−instance ListTuple (a, b, c) '[a, b, c] where
199− type ListToTuple '[a, b, c] = (a, b, c)
200− tupleToList (a, b, c)
201− = a :> b :> c :> Nil
202− listToTuple (a :> b :> c :> Nil)
203− = (a, b, c)
204−
205−instance ListTuple (a, b, c, d) '[a, b, c, d] where
206− type ListToTuple '[a, b, c, d] = (a, b, c, d)
207− tupleToList (a, b, c, d)
208− = a :> b :> c :> d:> Nil
209− listToTuple (a :> b :> c :> d :> Nil)
210− = (a, b, c, d)
211−
212−instance ListTuple (a, b, c, d, e) '[a, b, c, d, e] where
213− type ListToTuple '[a, b, c, d, e] = (a, b, c, d, e)
214− tupleToList (a, b, c, d, e)
215− = a :> b :> c :> d:> e :> Nil
216− listToTuple (a :> b :> c :> d :> e :> Nil)
217− = (a, b, c, d, e)
218−
219−instance ListTuple (a, b, c, d, e, f) '[a, b, c, d, e, f] where
220− type ListToTuple '[a, b, c, d, e, f] = (a, b, c, d, e, f)
221− tupleToList (a, b, c, d, e, f)
222− = a :> b :> c :> d:> e :> f :> Nil
223− listToTuple (a :> b :> c :> d :> e :> f :> Nil)
224− = (a, b, c, d, e, f)
225−
226−instance ListTuple (a, b, c, d, e, f, g) '[a, b, c, d, e, f, g] where
227− type ListToTuple '[a, b, c, d, e, f, g] = (a, b, c, d, e, f, g)
228− tupleToList (a, b, c, d, e, f, g)
229− = a :> b :> c :> d:> e :> f :> g :> Nil
230− listToTuple (a :> b :> c :> d :> e :> f :> g :> Nil)
231− = (a, b, c, d, e, f, g)
232−
233−instance ListTuple (a, b, c, d, e, f, g, h) '[a, b, c, d, e, f, g, h] where
234− type ListToTuple '[a, b, c, d, e, f, g, h] = (a, b, c, d, e, f, g, h)
235− tupleToList (a, b, c, d, e, f, g, h)
236− = a :> b :> c :> d:> e :> f :> g :> h :> Nil
237− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> Nil)
238− = (a, b, c, d, e, f, g, h)
239−
240−instance ListTuple (a, b, c, d, e, f, g, h, j) '[a, b, c, d, e, f, g, h, j] where
241− type ListToTuple '[a, b, c, d, e, f, g, h, j] = (a, b, c, d, e, f, g, h, j)
242− tupleToList (a, b, c, d, e, f, g, h, j)
243− = a :> b :> c :> d:> e :> f :> g :> h :> j :> Nil
244− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> Nil)
245− = (a, b, c, d, e, f, g, h, j)
246−
247−instance ListTuple (a, b, c, d, e, f, g, h, j, k) '[a, b, c, d, e, f, g, h, j, k] where
248− type ListToTuple '[a, b, c, d, e, f, g, h, j, k] = (a, b, c, d, e, f, g, h, j, k)
249− tupleToList (a, b, c, d, e, f, g, h, j, k)
250− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> Nil
251− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> Nil)
252− = (a, b, c, d, e, f, g, h, j, k)
253−
254−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
255− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l] = (a, b, c, d, e, f, g, h, j, k, l)
256− tupleToList (a, b, c, d, e, f, g, h, j, k, l)
257− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> Nil
258− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> Nil)
259− = (a, b, c, d, e, f, g, h, j, k, l)
260−
261−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
262− 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)
263− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m)
264− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> Nil
265− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> Nil)
266− = (a, b, c, d, e, f, g, h, j, k, l, m)
267−
268−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
269− 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)
270− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n)
271− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil
272− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil)
273− = (a, b, c, d, e, f, g, h, j, k, l, m, n)
274−
275−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
276− 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)
277− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
278− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil
279− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil)
280− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
281−
282−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
283− 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)
284− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
285− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil
286− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil)
287− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
288−
289−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
290− 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)
291− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
292− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil
293− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil)
294− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
295−
296−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
297− 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)
298− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
299− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil
300− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil)
301− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
302−
303−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
304− 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)
305− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
306− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil
307− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil)
308− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
309−
310−type family TupleToList a where
311− TupleToList () = '[]
312− TupleToList (a, b) = '[a, b]
313− TupleToList (a, b, c) = '[a, b, c]
314− TupleToList (a, b, c, d) = '[a, b, c, d]
315− TupleToList (a, b, c, d, e) = '[a, b, c, d, e]
316− TupleToList (a, b, c, d, e, f) = '[a, b, c, d, e, f]
317− TupleToList (a, b, c, d, e, f, g) = '[a, b, c, d, e, f, g]
318− TupleToList (a, b, c, d, e, f, g, h) = '[a, b, c, d, e, f, g, h]
319− TupleToList (a, b, c, d, e, f, g, h, j) = '[a, b, c, d, e, f, g, h, j]
320− TupleToList (a, b, c, d, e, f, g, h, j, k) = '[a, b, c, d, e, f, g, h, j, k]
321− TupleToList (a, b, c, d, e, f, g, h, j, k, l) = '[a, b, c, d, e, f, g, h, j, k, l]
322− 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]
323− 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]
324− 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]
325− 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]
326− 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]
327− 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]
328− 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]
329− TupleToList a = '[a]
src/Data/Generics/Product/Internal/Positions.hsdeleted−102
@@ -1,102 +0,0 @@
1−{-# LANGUAGE TypeInType #-}
2−{-# LANGUAGE AllowAmbiguousTypes #-}
3−{-# LANGUAGE ConstraintKinds #-}
4−{-# LANGUAGE DataKinds #-}
5−{-# LANGUAGE FlexibleContexts #-}
6−{-# LANGUAGE FlexibleInstances #-}
7−{-# LANGUAGE FunctionalDependencies #-}
8−{-# LANGUAGE KindSignatures #-}
9−{-# LANGUAGE MultiParamTypeClasses #-}
10−{-# LANGUAGE PolyKinds #-}
11−{-# LANGUAGE ScopedTypeVariables #-}
12−{-# LANGUAGE TypeApplications #-}
13−{-# LANGUAGE TypeFamilies #-}
14−{-# LANGUAGE TypeOperators #-}
15−{-# LANGUAGE UndecidableInstances #-}
16−
17−-----------------------------------------------------------------------------
18−-- |
19−-- Module : Data.Generics.Product.Internal.Positions
20−-- Copyright : (C) 2019 Csongor Kiss
21−-- License : BSD3
22−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
23−-- Stability : experimental
24−-- Portability : non-portable
25−--
26−-- Derive positional product type getters and setters generically.
27−--
28−-----------------------------------------------------------------------------
29−
30−module Data.Generics.Product.Internal.Positions
31− ( type (<?)
32− , Size
33− , CRep
34− ) where
35−
36−import Data.Generics.Internal.Families.Has (Pos)
37−import Data.Kind (Type)
38−import Data.Type.Bool (If, Not)
39−import GHC.Generics
40−import GHC.TypeLits (type (<=?), type (+), Nat)
41−
42−-- | Alias for the kind of the generic rep
43−type G = Type -> Type
44−
45−--------------------------------------------------------------------------------
46−
47−-- | In-order labeling of the generic tree with the field positions
48−--
49−-- We replace the (K1 R a) nodes with (K1 (Pos n) a), where 'n' is the position
50−-- of the field in question in the data type. This is convenient, because we
51−-- can reuse all the existing functions as long as they are polymorphic in the
52−-- first parameter of 'K1'.
53−type family CRep (a :: Type) :: G where
54− CRep rep = Fst (Traverse (Rep rep) 1)
55−
56−-- | The actual traversal.
57−--
58−-- Might be cleaner if the sum and product parts were separated (as there's
59−-- and invariant that 'n' should be zero when we're at a sum node, which holds
60−-- for derived Generic instances (where the sums are strictly above the products))
61−type family Traverse (a :: G) (n :: Nat) :: (G, Nat) where
62− Traverse (M1 mt m s) n
63− = Traverse1 (M1 mt m) (Traverse s n)
64− Traverse (l :+: r) n
65− = '(Fst (Traverse l n) :+: Fst (Traverse r n), n)
66− Traverse (l :*: r) n
67− = TraverseProd (:*:) (Traverse l n) r
68− Traverse (K1 _ p) n
69− = '(K1 (Pos n) p, n + 1)
70− Traverse U1 n
71− = '(U1, n)
72−
73−type family Traverse1 (w :: G -> G) (z :: (G, Nat)) :: (G, Nat) where
74− Traverse1 w '(i, n) = '(w i, n)
75−
76−-- | For products, we first traverse the left-hand side, followed by the second
77−-- using the counter returned by the left traversal.
78−type family TraverseProd (c :: G -> G -> G) (a :: (G, Nat)) (r :: G) :: (G, Nat) where
79− TraverseProd w '(i, n) r = Traverse1 (w i) (Traverse r n)
80−
81−--------------------------------------------------------------------------------
82−-- Utilities
83−
84−type family Fst (p :: (a, b)) :: a where
85− Fst '(a, b) = a
86−
87−type family Size f :: Nat where
88− Size (l :*: r)
89− = Size l + Size r
90− Size (l :+: r)
91− = Min (Size l) (Size r)
92− Size (D1 meta f)
93− = Size f
94− Size (C1 meta f)
95− = Size f
96− Size f
97− = 1
98−
99−type x <? y = Not (y <=? x)
100−infixl 4 <?
101−
102−type Min a b = If (a <? b) a b
src/Data/Generics/Product/Internal/Subtype.hsdeleted−97
@@ -1,97 +0,0 @@
1−{-# LANGUAGE TypeInType #-}
2−{-# LANGUAGE AllowAmbiguousTypes #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE NoMonomorphismRestriction #-}
8−{-# LANGUAGE PolyKinds #-}
9−{-# LANGUAGE Rank2Types #-}
10−{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE TypeApplications #-}
12−{-# LANGUAGE TypeFamilies #-}
13−{-# LANGUAGE TypeOperators #-}
14−{-# LANGUAGE UndecidableInstances #-}
15−
16−-----------------------------------------------------------------------------
17−-- |
18−-- Module : Data.Generics.Product.Internal.Subtype
19−-- Copyright : (C) 2019 Csongor Kiss
20−-- License : BSD3
21−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
22−-- Stability : experimental
23−-- Portability : non-portable
24−--
25−-- Structural subtype relationships between product types.
26−--
27−-----------------------------------------------------------------------------
28−
29−module Data.Generics.Product.Internal.Subtype
30− ( GUpcast (..)
31− , GSmash (..)
32− ) where
33−
34−import Data.Generics.Internal.Families
35−import Data.Generics.Product.Internal.GLens
36−
37−import Data.Kind (Type)
38−import GHC.Generics
39−import GHC.TypeLits (Symbol)
40−import Data.Generics.Internal.Profunctor.Lens (view)
41−
42−--------------------------------------------------------------------------------
43−-- * Generic upcasting
44−
45−class GUpcast (sub :: Type -> Type) (sup :: Type -> Type) where
46− gupcast :: sub p -> sup p
47−
48−instance (GUpcast sub a, GUpcast sub b) => GUpcast sub (a :*: b) where
49− gupcast rep = gupcast rep :*: gupcast rep
50−
51−instance
52− GLens' (HasTotalFieldPSym field) sub t
53− => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
54−
55− gupcast r = M1 (K1 (view (glens @(HasTotalFieldPSym field)) r))
56−
57−instance GUpcast sub sup => GUpcast sub (C1 c sup) where
58− gupcast = M1 . gupcast
59−
60−instance GUpcast sub sup => GUpcast sub (D1 c sup) where
61− gupcast = M1 . gupcast
62−
63−--------------------------------------------------------------------------------
64−-- * Generic smashing
65−
66−class GSmash sub sup where
67− gsmash :: sup p -> sub p -> sub p
68−
69−instance (GSmash a sup, GSmash b sup) => GSmash (a :*: b) sup where
70− gsmash rep (a :*: b) = gsmash rep a :*: gsmash rep b
71−
72−instance
73− ( leaf ~ (S1 ('MetaSel ('Just field) p f b) t)
74− , GSmashLeaf leaf sup (HasTotalFieldP field sup)
75− ) => GSmash (S1 ('MetaSel ('Just field) p f b) t) sup where
76−
77− gsmash = gsmashLeaf @_ @_ @(HasTotalFieldP field sup)
78−
79−instance GSmash sub sup => GSmash (C1 c sub) sup where
80− gsmash sup (M1 sub) = M1 (gsmash sup sub)
81−
82−instance GSmash sub sup => GSmash (D1 c sub) sup where
83− gsmash sup (M1 sub) = M1 (gsmash sup sub)
84−
85−class GSmashLeaf sub sup (w :: Maybe Type) where
86− gsmashLeaf :: sup p -> sub p -> sub p
87−
88−instance
89− GLens' (HasTotalFieldPSym field) sup t
90− => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup ('Just t) where
91− gsmashLeaf sup _ = M1 (K1 (view (glens @(HasTotalFieldPSym field)) sup))
92−
93−instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'Nothing where
94− gsmashLeaf _ = id
95−
96−data HasTotalFieldPSym :: Symbol -> (TyFun (Type -> Type) (Maybe Type))
97−type instance Eval (HasTotalFieldPSym sym) tt = HasTotalFieldP sym tt
src/Data/Generics/Product/Param.hsdeleted−121
@@ -1,121 +0,0 @@
1−{-# LANGUAGE PolyKinds #-}
2−{-# LANGUAGE TypeFamilies #-}
3−{-# LANGUAGE AllowAmbiguousTypes #-}
4−{-# LANGUAGE DataKinds #-}
5−{-# LANGUAGE FlexibleContexts #-}
6−{-# LANGUAGE FlexibleInstances #-}
7−{-# LANGUAGE FunctionalDependencies #-}
8−{-# LANGUAGE GADTs #-}
9−{-# LANGUAGE KindSignatures #-}
10−{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE TypeApplications #-}
12−{-# LANGUAGE TypeOperators #-}
13−{-# LANGUAGE UndecidableInstances #-}
14−
15−--------------------------------------------------------------------------------
16−-- |
17−-- Module : Data.Generics.Product.Param
18−-- Copyright : (C) 2019 Csongor Kiss
19−-- License : BSD3
20−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21−-- Stability : experimental
22−-- Portability : non-portable
23−--
24−-- Derive traversals over type parameters
25−--
26−--------------------------------------------------------------------------------
27−
28−module Data.Generics.Product.Param
29− ( Rec (Rec) -- TODO: this has to be re-exported so the constructor is visible for Coercible... is there a better way?
30− , HasParam (..)
31− ) where
32−
33−import GHC.TypeLits
34−import Data.Generics.Internal.Void
35−import Data.Generics.Internal.Families.Changing
36−import Data.Generics.Internal.VL.Traversal
37−
38−import GHC.Generics
39−import Data.Kind
40−import Data.Generics.Internal.VL.Iso
41−import Data.Generics.Internal.GenericN
42−import Data.Generics.Internal.Errors
43−
44−class HasParam (p :: Nat) s t a b | p t a -> s, p s b -> t, p s -> a, p t -> b where
45− param :: Applicative g => (a -> g b) -> s -> g t
46−
47−instance
48− ( GenericN s
49− , GenericN t
50− -- TODO: merge the old 'Changing' code with 'GenericN'
51− , Defined (Rep s)
52− (NoGeneric s
53− '[ 'Text "arising from a generic traversal of the type parameter at position " ':<>: QuoteType n
54− , 'Text "of type " ':<>: QuoteType a ':<>: 'Text " in " ':<>: QuoteType s
55− ])
56− (() :: Constraint)
57− , s ~ Infer t (P n b 'PTag) a
58− , t ~ Infer s (P n a 'PTag) b
59− , Error ((ArgCount s) <=? n) n (ArgCount s) s
60− , a ~ ArgAt s n
61− , b ~ ArgAt t n
62− , GHasParam n (RepN s) (RepN t) a b
63− ) => HasParam n s t a b where
64−
65− param = confusing (\f s -> toN <$> gparam @n f (fromN s))
66− {-# INLINE param #-}
67−
68−type family Error (b :: Bool) (expected :: Nat) (actual :: Nat) (s :: Type) :: Constraint where
69− Error 'False _ _ _
70− = ()
71−
72− Error 'True expected actual typ
73− = TypeError
74− ( 'Text "Expected a type with at least "
75− ':<>: 'ShowType (expected + 1)
76− ':<>: 'Text " parameters, but "
77− ':$$: 'ShowType typ
78− ':<>: 'Text " only has "
79− ':<>: 'ShowType actual
80− )
81−
82−-- TODO [1.0.0.0]: none of this is needed.
83−
84−instance {-# OVERLAPPING #-} HasParam p (Void1 a) (Void1 b) a b where
85− param = undefined
86−
87−class GHasParam (p :: Nat) s t a b where
88− gparam :: forall g (x :: Type). Applicative g => (a -> g b) -> s x -> g (t x)
89−
90−instance (GHasParam p l l' a b, GHasParam p r r' a b) => GHasParam p (l :*: r) (l' :*: r') a b where
91− gparam f (l :*: r) = (:*:) <$> gparam @p f l <*> gparam @p f r
92−
93−instance (GHasParam p l l' a b, GHasParam p r r' a b) => GHasParam p (l :+: r) (l' :+: r') a b where
94− gparam f (L1 l) = L1 <$> gparam @p f l
95− gparam f (R1 r) = R1 <$> gparam @p f r
96−
97−instance GHasParam p U1 U1 a b where
98− gparam _ _ = pure U1
99−
100−instance GHasParam p s t a b => GHasParam p (M1 m meta s) (M1 m meta t) a b where
101− gparam f (M1 x) = M1 <$> gparam @p f x
102−
103−-- the parameter we're looking for
104−instance GHasParam p (Rec (param p) a) (Rec (param p) b) a b where
105− gparam = recIso
106−
107−-- other recursion
108−instance {-# OVERLAPPABLE #-}
109− ( GHasParamRec (LookupParam si p) s t a b
110− -- TODO: reindex `ti`
111− ) => GHasParam p (Rec si s) (Rec ti t) a b where
112− gparam f (Rec (K1 x)) = Rec . K1 <$> gparamRec @(LookupParam si p) f x
113−
114−class GHasParamRec (param :: Maybe Nat) s t a b | param t a b -> s, param s a b -> t where
115− gparamRec :: forall g. Applicative g => (a -> g b) -> s -> g t
116−
117−instance GHasParamRec 'Nothing a a c d where
118− gparamRec _ = pure
119−
120−instance (HasParam n s t a b) => GHasParamRec ('Just n) s t a b where
121− gparamRec = param @n
src/Data/Generics/Product/Positions.hsdeleted−232
@@ -1,232 +0,0 @@
1−{-# LANGUAGE TypeInType #-}
2−{-# LANGUAGE PartialTypeSignatures #-}
3−{-# LANGUAGE CPP #-}
4−{-# LANGUAGE AllowAmbiguousTypes #-}
5−{-# LANGUAGE ConstraintKinds #-}
6−{-# LANGUAGE DataKinds #-}
7−{-# LANGUAGE FlexibleContexts #-}
8−{-# LANGUAGE FlexibleInstances #-}
9−{-# LANGUAGE FunctionalDependencies #-}
10−{-# LANGUAGE KindSignatures #-}
11−{-# LANGUAGE MultiParamTypeClasses #-}
12−{-# LANGUAGE PolyKinds #-}
13−{-# LANGUAGE ScopedTypeVariables #-}
14−{-# LANGUAGE TypeApplications #-}
15−{-# LANGUAGE TypeFamilies #-}
16−{-# LANGUAGE TypeOperators #-}
17−{-# LANGUAGE UndecidableInstances #-}
18−
19−-----------------------------------------------------------------------------
20−-- |
21−-- Module : Data.Generics.Product.Positions
22−-- Copyright : (C) 2019 Csongor Kiss
23−-- License : BSD3
24−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
25−-- Stability : experimental
26−-- Portability : non-portable
27−--
28−-- Derive positional product type getters and setters generically.
29−--
30−-----------------------------------------------------------------------------
31−
32−module Data.Generics.Product.Positions
33− ( -- *Lenses
34−
35− -- $setup
36− HasPosition (..)
37− , HasPosition' (..)
38− , HasPosition_ (..)
39− , HasPosition0 (..)
40−
41− , getPosition
42− , setPosition
43− ) where
44−
45−import Data.Generics.Internal.VL.Lens as VL
46−import Data.Generics.Internal.Void
47−import Data.Generics.Internal.Families
48−import Data.Generics.Product.Internal.Positions
49−import Data.Generics.Product.Internal.GLens
50−import Data.Generics.Internal.Errors
51−
52−import Data.Kind (Constraint, Type)
53−import Data.Type.Bool (type (&&))
54−import GHC.Generics
55−import GHC.TypeLits (type (<=?), Nat, TypeError, ErrorMessage(..))
56−import Data.Generics.Internal.Profunctor.Lens as P
57−import Data.Coerce
58−
59−-- $setup
60−-- == /Running example:/
61−--
62−-- >>> :set -XTypeApplications
63−-- >>> :set -XDataKinds
64−-- >>> :set -XDeriveGeneric
65−-- >>> :set -XGADTs
66−-- >>> :set -XFlexibleContexts
67−-- >>> import GHC.Generics
68−-- >>> :m +Data.Generics.Internal.VL.Lens
69−-- >>> :m +Data.Function
70−-- >>> :{
71−-- data Human = Human
72−-- { name :: String
73−-- , age :: Int
74−-- , address :: String
75−-- }
76−-- deriving (Generic, Show)
77−-- human :: Human
78−-- human = Human "Tunyasz" 50 "London"
79−-- :}
80−
81−-- |Records that have a field at a given position.
82−class HasPosition (i :: Nat) s t a b | s i -> a, t i -> b, s i b -> t, t i a -> s where
83− -- |A lens that focuses on a field at a given position. Compatible with the
84− -- lens package's 'Control.Lens.Lens' type.
85− --
86− -- >>> human ^. position @1
87− -- "Tunyasz"
88− -- >>> human & position @3 .~ "Berlin"
89− -- Human {name = "Tunyasz", age = 50, address = "Berlin"}
90− --
91− -- === /Type errors/
92− --
93− -- >>> human & position @4 .~ "Berlin"
94− -- ...
95− -- ... The type Human does not contain a field at position 4
96− -- ...
97− position :: VL.Lens s t a b
98−
99−class HasPosition_ (i :: Nat) s t a b where
100− position_ :: VL.Lens s t a b
101−
102−-- |Records that have a field at a given position.
103−--
104−-- The difference between 'HasPosition' and 'HasPosition_' is similar to the
105−-- one between 'Data.Generics.Product.Fields.HasField' and
106−-- 'Data.Generics.Product.Fields.HasField_'.
107−-- See 'Data.Generics.Product.Fields.HasField_'.
108−class HasPosition' (i :: Nat) s a | s i -> a where
109− position' :: VL.Lens s s a a
110−
111−-- |Records that have a field at a given position.
112−--
113−-- This class gives the minimal constraints needed to define this lens.
114−-- For common uses, see 'HasPosition'.
115−class HasPosition0 (i :: Nat) s t a b where
116− position0 :: VL.Lens s t a b
117−
118−-- |
119−-- >>> getPosition @2 human
120−-- 50
121−getPosition :: forall i s a. HasPosition' i s a => s -> a
122−getPosition s = s ^. position' @i
123−
124−-- |
125−-- >>> setPosition @2 60 human
126−-- Human {name = "Tunyasz", age = 60, address = "London"}
127−setPosition :: forall i s a. HasPosition' i s a => a -> s -> s
128−setPosition = VL.set (position' @i)
129−
130−instance
131− ( Generic s
132− , ErrorUnless i s (0 <? i && i <=? Size (Rep s))
133− , cs ~ CRep s
134− , Coercible (Rep s) cs
135− , GLens' (HasTotalPositionPSym i) cs a
136− , Defined (Rep s)
137− (NoGeneric s '[ 'Text "arising from a generic lens focusing on the field at"
138− , 'Text "position " ':<>: QuoteType i ':<>: 'Text " of type " ':<>: QuoteType a
139− ':<>: 'Text " in " ':<>: QuoteType s
140− ])
141− (() :: Constraint)
142− ) => HasPosition' i s a where
143− position' f s = VL.ravel (repLens . coerced @cs @cs . glens @(HasTotalPositionPSym i)) f s
144− {-# INLINE position' #-}
145−
146−-- this is to 'hide' the equality constraints which interfere with inlining
147−-- pre 8.4.3
148−class (~~) (a :: k) (b :: k) | a -> b, b -> a
149−instance (a ~ b) => (~~) a b
150−
151−instance -- see Note [Changing type parameters]
152− ( ErrorUnless i s (0 <? i && i <=? Size (Rep s))
153− , HasTotalPositionP i (CRep s) ~~ 'Just a
154− , HasTotalPositionP i (CRep t) ~~ 'Just b
155− , HasTotalPositionP i (CRep (Indexed s)) ~~ 'Just a'
156− , HasTotalPositionP i (CRep (Indexed t)) ~~ 'Just b'
157− , t ~~ Infer s a' b
158− , s ~~ Infer t b' a
159− , Coercible (CRep s) (Rep s)
160− , Coercible (CRep t) (Rep t)
161− , HasPosition0 i s t a b
162− ) => HasPosition i s t a b where
163−
164− position = position0 @i
165− {-# INLINE position #-}
166−
167−-- We wouldn't need the universal 'x' here if we could express above that
168−-- forall x. Coercible (cs x) (Rep s x), but this requires quantified
169−-- constraints
170−coerced :: forall s t s' t' x a b. (Coercible t t', Coercible s s')
171− => P.ALens a b (s x) (t x) -> P.ALens a b (s' x) (t' x)
172−coerced = coerce
173−{-# INLINE coerced #-}
174−
175−-- | See Note [Uncluttering type signatures]
176−#if __GLASGOW_HASKELL__ < 804
177−-- >>> :t position
178−-- position
179−-- :: (HasPosition i s t a b, Functor f) => (a -> f b) -> s -> f t
180−#else
181−-- >>> :t position
182−-- position
183−-- :: (Functor f, HasPosition i s t a b) => (a -> f b) -> s -> f t
184−#endif
185−instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where
186− position = undefined
187−
188−instance
189− ( ErrorUnless i s (0 <? i && i <=? Size (Rep s))
190− , UnifyHead s t
191− , UnifyHead t s
192− , Coercible (CRep s) (Rep s)
193− , Coercible (CRep t) (Rep t)
194− , HasPosition0 i s t a b
195− ) => HasPosition_ i s t a b where
196−
197− position_ = position0 @i
198− {-# INLINE position_ #-}
199−
200−instance {-# OVERLAPPING #-} HasPosition_ f (Void1 a) (Void1 b) a b where
201− position_ = undefined
202−
203−instance
204− ( Generic s
205− , Generic t
206− , GLens (HasTotalPositionPSym i) (CRep s) (CRep t) a b
207− , Coercible (CRep s) (Rep s)
208− , Coercible (CRep t) (Rep t)
209− , Defined (Rep s)
210− (NoGeneric s '[ 'Text "arising from a generic lens focusing on the field at"
211− , 'Text "position " ':<>: QuoteType i ':<>: 'Text " of type " ':<>: QuoteType a
212− ':<>: 'Text " in " ':<>: QuoteType s
213− ])
214− (() :: Constraint)
215− ) => HasPosition0 i s t a b where
216− position0 = VL.ravel (repLens . coerced @(CRep s) @(CRep t) . glens @(HasTotalPositionPSym i))
217− {-# INLINE position0 #-}
218−
219−type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint where
220− ErrorUnless i s 'False
221− = TypeError
222− ( 'Text "The type "
223− ':<>: 'ShowType s
224− ':<>: 'Text " does not contain a field at position "
225− ':<>: 'ShowType i
226− )
227−
228− ErrorUnless _ _ 'True
229− = ()
230−
231−data HasTotalPositionPSym :: Nat -> (TyFun (Type -> Type) (Maybe Type))
232−type instance Eval (HasTotalPositionPSym t) tt = HasTotalPositionP t tt
src/Data/Generics/Product/Subtype.hsdeleted−180
@@ -1,180 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE AllowAmbiguousTypes #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE NoMonomorphismRestriction #-}
8−{-# LANGUAGE PolyKinds #-}
9−{-# LANGUAGE Rank2Types #-}
10−{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE TypeApplications #-}
12−{-# LANGUAGE TypeFamilies #-}
13−{-# LANGUAGE TypeOperators #-}
14−{-# LANGUAGE UndecidableInstances #-}
15−
16−-----------------------------------------------------------------------------
17−-- |
18−-- Module : Data.Generics.Product.Subtype
19−-- Copyright : (C) 2019 Csongor Kiss
20−-- License : BSD3
21−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
22−-- Stability : experimental
23−-- Portability : non-portable
24−--
25−-- Structural subtype relationships between product types.
26−--
27−-----------------------------------------------------------------------------
28−
29−module Data.Generics.Product.Subtype
30− ( -- *Lenses
31− --
32− -- $setup
33− Subtype (..)
34− ) where
35−
36−import Data.Generics.Internal.Families
37−import Data.Generics.Internal.VL.Lens as VL
38−import Data.Generics.Internal.Void
39−import Data.Generics.Product.Internal.Subtype
40−
41−import GHC.Generics (Generic (Rep, to, from) )
42−import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
43−import Data.Kind (Type, Constraint)
44−import Data.Generics.Internal.Profunctor.Lens hiding (set)
45−import Data.Generics.Internal.Errors
46−
47−-- $setup
48−-- == /Running example:/
49−--
50−-- >>> :set -XTypeApplications
51−-- >>> :set -XDataKinds
52−-- >>> :set -XDeriveGeneric
53−-- >>> :set -XDuplicateRecordFields
54−-- >>> import GHC.Generics
55−-- >>> :m +Data.Generics.Internal.VL.Lens
56−-- >>> :{
57−-- data Human = Human
58−-- { name :: String
59−-- , age :: Int
60−-- , address :: String
61−-- }
62−-- deriving (Generic, Show)
63−-- data Animal = Animal
64−-- { name :: String
65−-- , age :: Int
66−-- }
67−-- deriving (Generic, Show)
68−-- human :: Human
69−-- human = Human "Tunyasz" 50 "London"
70−-- :}
71−
72−-- |Structural subtype relationship
73−--
74−-- @sub@ is a (structural) `subtype' of @sup@, if its fields are a subset of
75−-- those of @sup@.
76−--
77−class Subtype sup sub where
78− -- |Structural subtype lens. Given a subtype relationship @sub :< sup@,
79− -- we can focus on the @sub@ structure of @sup@.
80− --
81− -- >>> human ^. super @Animal
82− -- Animal {name = "Tunyasz", age = 50}
83− --
84− -- >>> set (super @Animal) (Animal "dog" 10) human
85− -- Human {name = "dog", age = 10, address = "London"}
86− super :: VL.Lens sub sub sup sup
87− super
88− = VL.lens upcast (uncurry smash . swap)
89−
90− -- |Cast the more specific subtype to the more general supertype
91− --
92− -- >>> upcast human :: Animal
93− -- Animal {name = "Tunyasz", age = 50}
94− --
95− -- >>> upcast (upcast human :: Animal) :: Human
96− -- ...
97− -- ... The type 'Animal' is not a subtype of 'Human'.
98− -- ... The following fields are missing from 'Animal':
99− -- ... address
100− -- ...
101− upcast :: sub -> sup
102− upcast s = s ^. super @sup
103−
104− -- |Plug a smaller structure into a larger one
105− --
106− -- >>> smash (Animal "dog" 10) human
107− -- Human {name = "dog", age = 10, address = "London"}
108− smash :: sup -> sub -> sub
109− smash = VL.set (super @sup)
110−
111− {-# MINIMAL super | smash, upcast #-}
112−
113−instance
114− ( Generic a
115− , Generic b
116− , GSmash (Rep a) (Rep b)
117− , GUpcast (Rep a) (Rep b)
118− , CustomError a b
119− ) => Subtype b a where
120− smash p b = to $ gsmash (from p) (from b)
121− upcast = to . gupcast . from
122−
123−type family CustomError a b :: Constraint where
124− CustomError a b =
125− ( ErrorUnless b a (CollectFieldsOrdered (Rep b) \\ CollectFieldsOrdered (Rep a))
126− , Defined (Rep a)
127− (NoGeneric a '[ 'Text "arising from a generic lens focusing on " ':<>: QuoteType b
128− , 'Text "as a supertype of " ':<>: QuoteType a
129− ])
130− (() :: Constraint)
131− , Defined (Rep b)
132− (NoGeneric b '[ 'Text "arising from a generic lens focusing on " ':<>: QuoteType b
133− , 'Text "as a supertype of " ':<>: QuoteType a
134− ])
135− (() :: Constraint)
136− )
137−
138−instance {-# OVERLAPPING #-} Subtype a a where
139− super = id
140−
141−-- | See Note [Uncluttering type signatures]
142−#if __GLASGOW_HASKELL__ < 804
143−-- >>> :t super
144−-- super
145−-- :: (Subtype sup sub, Functor f) => (sup -> f sup) -> sub -> f sub
146−#else
147−-- >>> :t super
148−-- super
149−-- :: (Functor f, Subtype sup sub) => (sup -> f sup) -> sub -> f sub
150−#endif
151−instance {-# OVERLAPPING #-} Subtype a Void where
152− super = undefined
153−
154−-- | See Note [Uncluttering type signatures]
155−#if __GLASGOW_HASKELL__ < 804
156−-- >>> :t super @Int
157−-- super @Int
158−-- :: (Subtype Int sub, Functor f) => (Int -> f Int) -> sub -> f sub
159−#else
160−-- >>> :t super @Int
161−-- super @Int
162−-- :: (Functor f, Subtype Int sub) => (Int -> f Int) -> sub -> f sub
163−#endif
164−instance {-# OVERLAPPING #-} Subtype Void a where
165− super = undefined
166−
167−type family ErrorUnless (sup :: Type) (sub :: Type) (diff :: [Symbol]) :: Constraint where
168− ErrorUnless _ _ '[]
169− = ()
170−
171− ErrorUnless sup sub fs
172− = TypeError
173− ( 'Text "The type '"
174− ':<>: 'ShowType sub
175− ':<>: 'Text "' is not a subtype of '"
176− ':<>: 'ShowType sup ':<>: 'Text "'."
177− ':$$: 'Text "The following fields are missing from '"
178− ':<>: 'ShowType sub ':<>: 'Text "':"
179− ':$$: ShowSymbols fs
180− )
src/Data/Generics/Product/Typed.hsdeleted−178
@@ -1,178 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE AllowAmbiguousTypes #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE KindSignatures #-}
7−{-# LANGUAGE MultiParamTypeClasses #-}
8−{-# LANGUAGE ScopedTypeVariables #-}
9−{-# LANGUAGE TypeApplications #-}
10−{-# LANGUAGE TypeFamilies #-}
11−{-# LANGUAGE TypeInType #-}
12−{-# LANGUAGE TypeOperators #-}
13−{-# LANGUAGE UndecidableInstances #-}
14−
15−-----------------------------------------------------------------------------
16−-- |
17−-- Module : Data.Generics.Product.Typed
18−-- Copyright : (C) 2019 Csongor Kiss
19−-- License : BSD3
20−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21−-- Stability : experimental
22−-- Portability : non-portable
23−--
24−-- Derive lenses of a given type in a product.
25−--
26−-----------------------------------------------------------------------------
27−
28−module Data.Generics.Product.Typed
29− ( -- *Lenses
30− --
31− -- $setup
32− HasType (..)
33− ) where
34−
35−import Data.Generics.Internal.Families
36−import Data.Generics.Internal.VL.Lens as VL
37−import Data.Generics.Internal.Void
38−import Data.Generics.Product.Internal.GLens
39−
40−import Data.Kind (Constraint, Type)
41−import GHC.Generics (Generic (Rep))
42−import GHC.TypeLits (TypeError, ErrorMessage (..))
43−import Data.Generics.Internal.Profunctor.Lens
44−import Data.Generics.Internal.Errors
45−
46−-- $setup
47−-- == /Running example:/
48−--
49−-- >>> :set -XTypeApplications
50−-- >>> :set -XDataKinds
51−-- >>> :set -XDeriveGeneric
52−-- >>> import GHC.Generics
53−-- >>> :m +Data.Generics.Internal.VL.Lens
54−-- >>> :{
55−-- data Human
56−-- = Human
57−-- { name :: String
58−-- , age :: Int
59−-- , address :: String
60−-- , tall :: Bool
61−-- }
62−-- | HumanNoTall
63−-- { name :: String
64−-- , age :: Int
65−-- , address :: String
66−-- }
67−-- deriving (Generic, Show)
68−-- human :: Human
69−-- human = Human "Tunyasz" 50 "London" False
70−-- :}
71−
72−-- |Records that have a field with a unique type.
73−class HasType a s where
74− -- |A lens that focuses on a field with a unique type in its parent type.
75− -- Compatible with the lens package's 'Control.Lens.Lens' type.
76− --
77− -- >>> human ^. typed @Int
78− -- 50
79− --
80− -- === /Type errors/
81− --
82− -- >>> human ^. typed @String
83− -- ...
84− -- ...
85− -- ... The type Human contains multiple values of type [Char].
86− -- ... The choice of value is thus ambiguous. The offending constructors are:
87− -- ... Human
88− -- ... HumanNoTall
89− -- ...
90− --
91− -- >>> human ^. typed @Bool
92− -- ...
93− -- ...
94− -- ... Not all constructors of the type Human contain a field of type Bool.
95− -- ... The offending constructors are:
96− -- ... HumanNoTall
97− -- ...
98− typed :: VL.Lens s s a a
99− typed
100− = VL.lens (getTyped @a) (uncurry (setTyped @a) . swap)
101− {-# INLINE typed #-}
102−
103− -- |Get field at type.
104− getTyped :: s -> a
105− getTyped s = s ^. typed @a
106−
107− -- |Set field at type.
108− setTyped :: a -> s -> s
109− setTyped = VL.set (typed @a)
110−
111− {-# MINIMAL typed | setTyped, getTyped #-}
112−
113−instance
114− ( Generic s
115− , ErrorUnlessOne a s (CollectTotalType a (Rep s))
116− , Defined (Rep s)
117− (NoGeneric s '[ 'Text "arising from a generic lens focusing on a field of type " ':<>: QuoteType a])
118− (() :: Constraint)
119− , GLens (HasTotalTypePSym a) (Rep s) (Rep s) a a
120− ) => HasType a s where
121−
122− typed f s = VL.ravel (repLens . glens @(HasTotalTypePSym a)) f s
123−
124−instance {-# OVERLAPPING #-} HasType a a where
125− getTyped = id
126− {-# INLINE getTyped #-}
127−
128− setTyped a _ = a
129− {-# INLINE setTyped #-}
130−
131−-- | See Note [Uncluttering type signatures]
132−#if __GLASGOW_HASKELL__ < 804
133−-- >>> :t typed
134−-- typed :: (HasType a s, Functor f) => (a -> f a) -> s -> f s
135−#else
136−-- >>> :t typed
137−-- typed :: (Functor f, HasType a s) => (a -> f a) -> s -> f s
138−#endif
139−--
140−-- Note that this might not longer be needed given the above 'HasType a a' instance.
141−instance {-# OVERLAPPING #-} HasType a Void where
142− typed = undefined
143−
144−type family ErrorUnlessOne (a :: Type) (s :: Type) (stat :: TypeStat) :: Constraint where
145− ErrorUnlessOne a s ('TypeStat '[_] '[] '[])
146− = TypeError
147− ( 'Text "The type "
148− ':<>: 'ShowType s
149− ':<>: 'Text " does not contain a value of type "
150− ':<>: 'ShowType a
151− )
152−
153− ErrorUnlessOne a s ('TypeStat (n ': ns) _ _)
154− = TypeError
155− ( 'Text "Not all constructors of the type "
156− ':<>: 'ShowType s
157− ':<>: 'Text " contain a field of type "
158− ':<>: 'ShowType a ':<>: 'Text "."
159− ':$$: 'Text "The offending constructors are:"
160− ':$$: ShowSymbols (n ': ns)
161− )
162−
163− ErrorUnlessOne a s ('TypeStat _ (m ': ms) _)
164− = TypeError
165− ( 'Text "The type "
166− ':<>: 'ShowType s
167− ':<>: 'Text " contains multiple values of type "
168− ':<>: 'ShowType a ':<>: 'Text "."
169− ':$$: 'Text "The choice of value is thus ambiguous. The offending constructors are:"
170− ':$$: ShowSymbols (m ': ms)
171− )
172−
173− ErrorUnlessOne _ _ ('TypeStat '[] '[] _)
174− = ()
175−
176−data HasTotalTypePSym :: Type -> (TyFun (Type -> Type) (Maybe Type))
177−type instance Eval (HasTotalTypePSym t) tt = HasTotalTypeP t tt
178−
src/Data/Generics/Product/Types.hsdeleted−367
@@ -1,367 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE ConstraintKinds #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE DefaultSignatures #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE KindSignatures #-}
7−{-# LANGUAGE MultiParamTypeClasses #-}
8−{-# LANGUAGE PolyKinds #-}
9−{-# LANGUAGE Rank2Types #-}
10−{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE TypeApplications #-}
12−{-# LANGUAGE TypeFamilies #-}
13−{-# LANGUAGE TypeOperators #-}
14−{-# LANGUAGE UndecidableInstances #-}
15−
16−-----------------------------------------------------------------------------
17−-- |
18−-- Module : Data.Generics.Product.Types
19−-- Copyright : (C) 2019 Csongor Kiss
20−-- License : BSD3
21−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
22−-- Stability : experimental
23−-- Portability : non-portable
24−--
25−-- Derive traversals of a given type in a product.
26−--
27−-----------------------------------------------------------------------------
28−
29−module Data.Generics.Product.Types
30− ( -- *Traversals
31− --
32− -- $setup
33− HasTypes
34− , types
35−
36− -- * Custom traversal strategies
37− -- $custom
38− , Children
39− , ChGeneric
40−
41− , HasTypesUsing
42− , typesUsing
43−
44− , HasTypesCustom (typesCustom)
45−
46− ) where
47−
48−import Data.Kind
49−import Data.Int (Int8, Int16, Int32, Int64)
50−import Data.Word (Word, Word8, Word16, Word32, Word64)
51−import qualified Data.Text as T
52−
53−import GHC.Generics
54−import GHC.TypeLits
55−import Data.Generics.Internal.VL.Traversal
56−import Data.Generics.Internal.Errors
57−
58−-- $setup
59−-- == /Running example:/
60−--
61−-- >>> :set -XTypeApplications
62−-- >>> :set -XDeriveGeneric
63−-- >>> :set -XScopedTypeVariables
64−-- >>> import GHC.Generics
65−-- >>> :m +Data.Generics.Internal.VL.Traversal
66−-- >>> :m +Data.Generics.Internal.VL.Lens
67−-- >>> :{
68−-- data WTree a w
69−-- = Leaf a
70−-- | Fork (WTree a w) (WTree a w)
71−-- | WithWeight (WTree a w) w
72−-- deriving (Generic, Show)
73−-- :}
74−
75−--------------------------------------------------------------------------------
76−-- HasTypes
77−--------------------------------------------------------------------------------
78−
79−-- TODO [1.0.0.0]: use type-changing variant internally
80−
81−-- | Traverse all types in the given structure.
82−--
83−-- For example, to update all 'String's in a @WTree (Maybe String) String@, we can write
84−--
85−-- >>> myTree = WithWeight (Fork (Leaf (Just "hello")) (Leaf Nothing)) "world"
86−-- >>> over (types @String) (++ "!") myTree
87−-- WithWeight (Fork (Leaf (Just "hello!")) (Leaf Nothing)) "world!"
88−--
89−-- The traversal is /deep/, which means that not just the immediate
90−-- children are visited, but all nested values too.
91−types :: forall a s. HasTypes s a => Traversal' s a
92−types = types_ @s @a
93−{-# INLINE types #-}
94−
95−class HasTypes s a where
96− types_ :: Traversal' s a
97−
98− default types_ :: Traversal' s a
99− types_ _ = pure
100− {-# INLINE types_ #-}
101−
102−instance
103− ( HasTypesUsing ChGeneric s a
104− ) => HasTypes s a where
105− types_ = typesUsing_ @ChGeneric
106− {-# INLINE types_ #-}
107−
108−--------------------------------------------------------------------------------
109−data Void
110−instance {-# OVERLAPPING #-} HasTypes Void a where
111− types_ _ = pure
112−
113−instance {-# OVERLAPPING #-} HasTypes s Void where
114− types_ _ = pure
115−
116−instance {-# OVERLAPPING #-} HasTypesUsing ch Void a where
117− typesUsing_ _ = pure
118−
119−instance {-# OVERLAPPING #-} HasTypesUsing ch s Void where
120− typesUsing_ _ = pure
121−--------------------------------------------------------------------------------
122−
123−--------------------------------------------------------------------------------
124−-- HasTypesUsing
125−--------------------------------------------------------------------------------
126−
127−-- $custom
128−--
129−-- The default traversal strategy 'types' recurses into each node of the type
130−-- using the 'Generic' instance for the nodes. However, in general not all
131−-- nodes will have a 'Generic' instance. For example:
132−--
133−-- >>> data Opaque = Opaque String deriving Show
134−-- >>> myTree = WithWeight (Fork (Leaf (Opaque "foo")) (Leaf (Opaque "bar"))) False
135−-- >>> over (types @String) (++ "!") myTree
136−-- ...
137−-- ... | No instance for ‘Generic Opaque’
138−-- ... | arising from a generic traversal.
139−-- ... | Either derive the instance, or define a custom traversal using ‘HasTypesCustom’
140−-- ...
141−--
142−-- In these cases, we can define a custom traversal strategy to override the
143−-- generic behaviour for certain types.
144−-- For a self-contained example, see the CustomChildren module in the tests directory.
145−
146−-- | The children of a type are the types of its fields.
147−-- The 'Children' type family maps a type @a@ to its set of children.
148−--
149−-- This type family is parameterized by a symbol @ch@ (that can be declared as
150−-- an empty data type).
151−-- The symbol 'ChGeneric' provides a default definition. You can create new
152−-- symbols to override the set of children of abstract, non-generic types.
153−--
154−-- The following example declares a @Custom@ symbol to redefine 'Children'
155−-- for some abstract types from the @time@ library.
156−--
157−-- @
158−-- data Custom
159−-- type instance 'Children' Custom a = ChildrenCustom a
160−--
161−-- type family ChildrenCustom (a :: Type) where
162−-- ChildrenCustom DiffTime = '[]
163−-- ChildrenCustom NominalDiffTime = '[]
164−-- -- Add more custom mappings here.
165−--
166−-- ChildrenCustom a = Children ChGeneric a
167−-- @
168−--
169−-- To use this definition, replace 'types' with @'typesUsing' \@Custom@.
170−type family Children (ch :: Type) (a :: Type) :: [Type]
171−
172−-- | @since 1.2.0.0
173−typesUsing :: forall ch a s. HasTypesUsing ch s a => Traversal' s a
174−typesUsing = typesUsing_ @ch @s @a
175−{-# INLINE typesUsing #-}
176−
177−-- | @since 1.2.0.0
178−class HasTypesUsing (ch :: Type) s a where
179− typesUsing_ :: Traversal' s a
180−
181−instance {-# OVERLAPPABLE #-}
182− ( HasTypesOpt ch (Interesting ch a s) s a
183− ) => HasTypesUsing ch s a where
184− typesUsing_ = typesOpt @ch @(Interesting ch a s)
185− {-# INLINE typesUsing_ #-}
186−
187−-- TODO: should this instance be incoherent?
188−instance {-# OVERLAPPABLE #-} HasTypesUsing ch a a where
189− typesUsing_ = id
190−
191−-- | By adding instances to this class, we can override the default
192−-- behaviour in an ad-hoc manner.
193−-- For example:
194−--
195−-- @
196−-- instance HasTypesCustom Custom Opaque String where
197−-- typesCustom f (Opaque str) = Opaque <$> f str
198−-- @
199−--
200−-- @since 1.2.0.0
201−class HasTypesCustom (ch :: Type) s a where
202− -- | This function should never be used directly, only to override
203− -- the default traversal behaviour. To actually use the custom
204− -- traversal strategy, see 'typesUsing'. This is because 'typesUsing' does
205− -- additional optimisations, like ensuring that nodes with no relevant members will
206− -- not be traversed at runtime.
207− typesCustom :: Traversal' s a
208−
209−instance {-# OVERLAPPABLE #-}
210− ( GHasTypes ch (Rep s) a
211− , Generic s
212− -- if there's no Generic instance here, it means we got through the
213− -- Children check by a user-defined custom strategy.
214− -- Therefore, we can ignore the missing Generic instance, and
215− -- instead report a missing HasTypesCustom instance
216− , Defined (Rep s)
217− (PrettyError '[ 'Text "No instance " ':<>: QuoteType (HasTypesCustom ch s a)])
218− (() :: Constraint)
219− ) => HasTypesCustom ch s a where
220− typesCustom f s = to <$> gtypes_ @ch f (from s)
221− --{-# INLINE types' #-}
222−
223−
224−-- | The default definition of 'Children'.
225−-- Primitive types from core libraries have no children, and other types are
226−-- assumed to be 'Generic'.
227−data ChGeneric
228−type instance Children ChGeneric a = ChildrenDefault a
229−
230−type family ChildrenDefault (a :: Type) :: [Type] where
231− ChildrenDefault Char = '[]
232− ChildrenDefault Double = '[]
233− ChildrenDefault Float = '[]
234− ChildrenDefault Integer = '[]
235− ChildrenDefault Int = '[]
236− ChildrenDefault Int8 = '[]
237− ChildrenDefault Int16 = '[]
238− ChildrenDefault Int32 = '[]
239− ChildrenDefault Int64 = '[]
240− ChildrenDefault Word = '[]
241− ChildrenDefault Word8 = '[]
242− ChildrenDefault Word16 = '[]
243− ChildrenDefault Word32 = '[]
244− ChildrenDefault Word64 = '[]
245− ChildrenDefault T.Text = '[]
246− ChildrenDefault a
247− = Defined (Rep a)
248− (NoGeneric a
249− '[ 'Text "arising from a generic traversal."
250− , 'Text "Either derive the instance, or define a custom traversal using " ':<>: QuoteType HasTypesCustom
251− ])
252− (ChildrenGeneric (Rep a) '[])
253−
254−type family ChildrenGeneric (f :: k -> Type) (cs :: [Type]) :: [Type] where
255− ChildrenGeneric (M1 _ _ f) cs = ChildrenGeneric f cs
256− ChildrenGeneric (l :*: r) cs = ChildrenGeneric l (ChildrenGeneric r cs)
257− ChildrenGeneric (l :+: r) cs = ChildrenGeneric l (ChildrenGeneric r cs)
258− ChildrenGeneric (Rec0 a) cs = a ': cs
259− ChildrenGeneric _ cs = cs
260−
261−--------------------------------------------------------------------------------
262−-- Internals
263−--------------------------------------------------------------------------------
264−-- TODO: these should never leak out in error messages
265−
266−class HasTypesOpt (ch :: Type) (t :: Bool) s a where
267− typesOpt :: Traversal' s a
268−
269−instance HasTypesCustom ch s a => HasTypesOpt ch 'True s a where
270− typesOpt = typesCustom @ch
271−
272−instance HasTypesOpt ch 'False s a where
273− typesOpt _ = pure
274− --{-# INLINE typesOpt #-}
275−
276−--------------------------------------------------------------------------------
277−
278−class GHasTypes ch s a where
279− gtypes_ :: Traversal' (s x) a
280−
281−instance
282− ( GHasTypes ch l a
283− , GHasTypes ch r a
284− ) => GHasTypes ch (l :*: r) a where
285− gtypes_ f (l :*: r) = (:*:) <$> gtypes_ @ch f l <*> gtypes_ @ch f r
286− {-# INLINE gtypes_ #-}
287−
288−instance
289− ( GHasTypes ch l a
290− , GHasTypes ch r a
291− ) => GHasTypes ch (l :+: r) a where
292− gtypes_ f (L1 l) = L1 <$> gtypes_ @ch f l
293− gtypes_ f (R1 r) = R1 <$> gtypes_ @ch f r
294− {-# INLINE gtypes_ #-}
295−
296−instance (GHasTypes ch s a) => GHasTypes ch (M1 m meta s) a where
297− gtypes_ f (M1 s) = M1 <$> gtypes_ @ch f s
298− {-# INLINE gtypes_ #-}
299−
300−-- | In the recursive case, we invoke 'HasTypesUsing' again, using the
301−-- same strategy
302−instance HasTypesUsing ch b a => GHasTypes ch (Rec0 b) a where
303− gtypes_ f (K1 x) = K1 <$> typesUsing_ @ch @b @a f x
304− {-# INLINE gtypes_ #-}
305−
306−-- | The default instance for 'HasTypes' acts as a synonym for
307−-- 'HasTypesUsing ChGeneric', so in most cases this instance should
308−-- behave the same as the one above.
309−-- However, there might be overlapping instances defined for
310−-- 'HasTypes' directly, in which case we want to prefer those
311−-- instances (even though the custom instances should always be added to 'HasTypesCustom')
312−instance {-# OVERLAPPING #-} HasTypes b a => GHasTypes ChGeneric (Rec0 b) a where
313− gtypes_ f (K1 x) = K1 <$> types_ @b @a f x
314− {-# INLINE gtypes_ #-}
315−
316−instance GHasTypes ch U1 a where
317− gtypes_ _ _ = pure U1
318− {-# INLINE gtypes_ #-}
319−
320−instance GHasTypes ch V1 a where
321− gtypes_ _ = pure
322− {-# INLINE gtypes_ #-}
323−
324−type Interesting (ch :: Type) (a :: Type) (t :: Type)
325− = Defined_list (Children ch t) (NoChildren ch t)
326− (IsNothing (Interesting' ch a '[t] (Children ch t)))
327−
328−type family NoChildren (ch :: Type) (a :: Type) :: Constraint where
329− NoChildren ch a = PrettyError
330− '[ 'Text "No type family instance for " ':<>: QuoteType (Children ch a)
331− , 'Text "arising from a traversal over " ':<>: QuoteType a
332− , 'Text "with custom strategy " ':<>: QuoteType ch
333− ]
334−
335−
336−type family Interesting' (ch :: Type) (a :: Type) (seen :: [Type]) (ts :: [Type]) :: Maybe [Type] where
337− Interesting' ch _ seen '[] = 'Just seen
338− Interesting' ch a seen (t ': ts) =
339− InterestingOr ch a (InterestingUnless ch a seen t (Elem t seen)) ts
340−
341−-- Short circuit
342−-- Note: we only insert 't' to the seen list if it's not already there (which is precisely when `s` is 'False)
343−type family InterestingUnless
344− (ch :: Type) (a :: Type) (seen :: [Type]) (t :: Type) (alreadySeen :: Bool) ::
345− Maybe [Type] where
346− InterestingUnless ch a seen a _ = 'Nothing
347− InterestingUnless ch a seen t 'True = 'Just seen
348− InterestingUnless ch a seen t 'False
349− = Defined_list (Children ch t) (NoChildren ch t)
350− (Interesting' ch a (t ': seen) (Children ch t))
351−
352−-- Short circuit
353−type family InterestingOr
354− (ch :: Type) (a :: Type) (seen' :: Maybe [Type]) (ts :: [Type]) ::
355− Maybe [Type] where
356− InterestingOr ch a 'Nothing _ = 'Nothing
357− InterestingOr ch a ('Just seen) ts = Interesting' ch a seen ts
358−
359−type family Elem a as where
360− Elem a (a ': _) = 'True
361− Elem a (_ ': as) = Elem a as
362− Elem a '[] = 'False
363−
364−type family IsNothing a where
365− IsNothing ('Just _) = 'False
366− IsNothing 'Nothing = 'True
367−
src/Data/Generics/Sum.hs → src/Data/Generics/Record.hsrenamed+17−13
@@ -1,29 +1,33 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2-- |
2-- |
3−-- Module : Data.Generics.Sum
3+-- Module : Data.Generics.Record
4−-- Copyright : (C) 2019 Csongor Kiss
4+-- Copyright : (C) 2017 Csongor Kiss
5-- License : BSD3
5-- License : BSD3
6-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
6-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
7-- Stability : experimental
7-- Stability : experimental
8-- Portability : non-portable
8-- Portability : non-portable
9--
9--
10−-- Magic sum operations using Generics
10+-- Magic record operations using Generics
11--
11--
12-- These classes need not be instantiated manually, as GHC can automatically
12-- These classes need not be instantiated manually, as GHC can automatically
13-- prove valid instances via Generics. Only the `Generic` class needs to
13-- prove valid instances via Generics. Only the `Generic` class needs to
14-- be derived (see examples).
14-- be derived (see examples).
15--
15--
16-----------------------------------------------------------------------------
16-----------------------------------------------------------------------------
17+module Data.Generics.Record
18+ (
19+ -- * Subtype relationship
20+ Subtype (..)
21+ , super
22+
23+ -- * Magic lens
24+ , HasField (..)
25+
26+ -- * Getter and setter
27+ , getField
28+ , setField
17
29
18−module Data.Generics.Sum
19− ( -- *Prisms
20− module Data.Generics.Sum.Any
21− , module Data.Generics.Sum.Constructors
22− , module Data.Generics.Sum.Subtype
23− , module Data.Generics.Sum.Typed
24 ) where
30 ) where
25
31
26−import Data.Generics.Sum.Any
32+import Data.Generics.Record.HasField
27−import Data.Generics.Sum.Constructors
33+import Data.Generics.Record.Subtype
28−import Data.Generics.Sum.Subtype
29−import Data.Generics.Sum.Typed
src/Data/Generics/Record/HasField.hsnew file+134
@@ -0,0 +1,134 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE PolyKinds #-}
6+{-# LANGUAGE Rank2Types #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeApplications #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeOperators #-}
11+{-# LANGUAGE UndecidableInstances #-}
12+
13+-----------------------------------------------------------------------------
14+-- |
15+-- Module : Data.Generics.Record.HasField
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.Record.HasField
27+ ( -- * Lens
28+ -- $example
29+ HasField (..)
30+ -- * Getter and setter functions
31+ , getField
32+ , setField
33+ -- * Internals
34+ , GHasField (..)
35+ ) where
36+
37+import Data.Generics.Record.Internal.Contains
38+
39+import Data.Generics.Internal.Lens
40+
41+import GHC.TypeLits (Symbol)
42+import Data.Kind (Type)
43+import GHC.Generics
44+
45+
46+-- $example
47+-- @
48+--
49+-- module Example where
50+--
51+-- import GHC.Generics
52+-- import Data.Generics.Record
53+--
54+-- data Human = Human
55+-- { name :: String
56+-- , age :: Int
57+-- , address :: String
58+-- } deriving (Generic, Show)
59+--
60+-- human :: Human
61+-- human = Human \"Tunyasz\" 50 \"London\"
62+--
63+-- @
64+
65+-- | Get 'field'
66+--
67+-- >>> getField @"name" human
68+-- "Tunyasz"
69+getField :: forall field a s. HasField field a s => s -> a
70+getField s = s ^. label @field
71+
72+-- | Set 'field'
73+--
74+-- >>> setField @"age" (setField @"name" "Tamas" human) 30
75+-- Human {name = "Tamas", age = 30, address = "London"}
76+setField :: forall field a s. HasField field a s => a -> s -> s
77+setField = set (label @field)
78+
79+-- | Records that have a field with a given name.
80+class HasField (field :: Symbol) a s | s field -> a where
81+ -- ^ Lens focusing on a field with a given name.
82+ -- Compatible with the lens package.
83+ --
84+ -- @
85+ -- type Lens' s a
86+ -- = forall f. Functor f => (a -> f a) -> s -> f s
87+ -- @
88+ --
89+ -- >>> human & label @"name" .~ "Tamas"
90+ -- Human {name = "Tamas", age = 50, address = "London"}
91+ label :: Lens' s a
92+
93+-- | Instances are generated on the fly for all records that have the required
94+-- field.
95+instance
96+ ( Generic s
97+ , Contains field (Rep s) ~ 'Just a -- this is needed for the fundep for some reason
98+ , GHasField field (Rep s) a
99+ ) => HasField field a s where
100+ label = repIso . glabel @field
101+
102+
103+class GHasFieldProd field a b ret (w :: Maybe Type) | field a b -> ret where
104+ prodLabel :: Lens' ((a :*: b) x) ret
105+
106+instance (GHasField field f ret) => GHasFieldProd field f g ret ('Just ret) where
107+ prodLabel = first . glabel @field
108+
109+instance (GHasField field g ret) => GHasFieldProd field f g ret 'Nothing where
110+ prodLabel = second . glabel @field
111+
112+--------------------------------------------------------------------------------
113+
114+-- | Like 'HasField', but on the generic representation
115+class GHasField (field :: Symbol) (s :: Type -> Type) a | field s -> a where
116+ glabel :: Lens' (s x) a
117+
118+instance (GHasFieldProd field s s' a (Contains field s)) => GHasField field (s :*: s') a where
119+ glabel = prodLabel @field @_ @_ @_ @(Contains field s)
120+
121+instance (GHasField field s a, GHasField field s' a) => GHasField field (s :+: s') a where
122+ glabel = combine (glabel @field @s) (glabel @field @s')
123+
124+instance GHasField field (S1 ('MetaSel ('Just field) p f b) (Rec0 a)) a where
125+ glabel = lensM . glabel @field
126+
127+instance GHasField field (K1 R a) a where
128+ glabel f (K1 x) = fmap K1 (f x)
129+
130+instance GHasField field s a => GHasField field (M1 D c s) a where
131+ glabel = lensM . glabel @field
132+
133+instance GHasField field s a => GHasField field (M1 C c s) a where
134+ glabel = lensM . glabel @field
src/Data/Generics/Record/Internal/Contains.hsnew file+63
@@ -0,0 +1,63 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE PolyKinds #-}
5+{-# LANGUAGE Rank2Types #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE TypeFamilies #-}
8+{-# LANGUAGE TypeOperators #-}
9+{-# LANGUAGE UndecidableInstances #-}
10+
11+-----------------------------------------------------------------------------
12+-- |
13+-- Module : Data.Generics.Record.Internal.Contains
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+-- Look up fields in the generic representation
21+--
22+-----------------------------------------------------------------------------
23+module Data.Generics.Record.Internal.Contains
24+ ( Contains
25+ ) where
26+
27+import Data.Kind (Type)
28+import GHC.Generics
29+
30+import GHC.TypeLits
31+
32+-- | Look up a record field by name in the generic representation, and return
33+-- its corresponding type, if exists.
34+type family Contains (field :: Symbol) f :: Maybe Type where
35+ Contains field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 t))
36+ = 'Just t
37+ Contains field (f :*: g)
38+ = Contains field f <|> Contains field g
39+ Contains field (f :+: g)
40+ = Contains field f <&> Contains field g
41+ Contains field (S1 _ _)
42+ = 'Nothing
43+ Contains field (C1 m f)
44+ = Contains field f
45+ Contains field (D1 m f)
46+ = Contains field f
47+ Contains field (Rec0 _)
48+ = 'Nothing
49+ Contains field U1
50+ = 'Nothing
51+ Contains field V1
52+ = 'Nothing
53+ Contains x t = TypeError ('ShowType t)
54+
55+-- | Type-level alternative
56+type family (a :: Maybe k) <|> (b :: Maybe k) :: Maybe k where
57+ 'Just x <|> _ = 'Just x
58+ _ <|> b = b
59+
60+type family (a :: Maybe k) <&> (b :: Maybe k) :: Maybe k where
61+ 'Just x <&> 'Just x = 'Just x
62+ _ <&> _ = 'Nothing
63+
src/Data/Generics/Record/Subtype.hsnew file+138
@@ -0,0 +1,138 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE PolyKinds #-}
6+{-# LANGUAGE Rank2Types #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeApplications #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeOperators #-}
11+{-# LANGUAGE UndecidableInstances #-}
12+
13+-----------------------------------------------------------------------------
14+-- |
15+-- Module : Data.Generics.Record.Subtype
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+-- Structural subtype relationship between record types.
23+--
24+-- The running example in this module is the following two types:
25+--
26+-- @
27+--
28+-- module Test where
29+--
30+-- import GHC.Generics
31+-- import Data.Generics.Record
32+--
33+-- data Human = Human
34+-- { name :: String
35+-- , age :: Int
36+-- , address :: String
37+-- } deriving (Generic, Show)
38+--
39+-- data Animal = Animal
40+-- { name :: String
41+-- , age :: Int
42+-- } deriving (Generic, Show)
43+--
44+-- human :: Human
45+-- human = Human \"Tunyasz\" 50 \"London\"
46+--
47+-- @
48+--
49+-----------------------------------------------------------------------------
50+module Data.Generics.Record.Subtype
51+ ( Subtype (..)
52+ , super
53+ ) where
54+
55+import Data.Generics.Record.HasField
56+import Data.Generics.Record.Internal.Contains
57+
58+import Data.Generics.Internal.Lens
59+
60+import Data.Kind (Type)
61+import GHC.Generics
62+
63+-- |Structural subtype relationship
64+--
65+-- @sub@ is a (structural) `subtype' of @sup@, if its fields are a subset of
66+-- those of @sup@.
67+--
68+class Subtype sub sup where
69+ -- | Cast the more specific subtype to the more general supertype
70+ --
71+ -- >>> upcast human :: Animal
72+ -- Animal {name = "Tunyasz", age = 50}
73+ --
74+ upcast :: sub -> sup
75+ -- | Plug a smaller structure into a larger one
76+ --
77+ -- >>> smash (Animal "dog" 10) human
78+ -- Human {name = "dog", age = 10, address = "London"}
79+ smash :: sup -> sub -> sub
80+
81+-- | Instances are created by the compiler
82+instance (GSmash (Rep a) (Rep b), GUpcast (Rep a) (Rep b), Generic a, Generic b) => Subtype a b where
83+ upcast = to . gupcast . from
84+ smash p b = to $ gsmash (from p) (from b)
85+
86+-- | Structural subtype lens. Given a subtype relationship @sub :< sup@,
87+-- we can focus on the @sub@ structure of @sup@.
88+--
89+-- >>> human ^. super @Animal
90+-- Animal {name = "Tunyasz", age = 50}
91+--
92+-- >>> set (super @Animal) (Animal "dog" 10) human
93+-- Human {name = "dog", age = 10, address = "London"}
94+super :: forall sup sub. Subtype sub sup => Lens' sub sup
95+super f sub = fmap (flip smash sub) (f (upcast sub))
96+
97+--------------------------------------------------------------------------------
98+-- * Generic upcasting
99+
100+-- | Upcast 'sub to 'sup' (generic rep)
101+class GUpcast (sub :: Type -> Type) (sup :: Type -> Type) where
102+ gupcast :: sub p -> sup p
103+
104+instance (GUpcast sub a, GUpcast sub b) => GUpcast sub (a :*: b) where
105+ gupcast rep = gupcast rep :*: gupcast rep
106+
107+instance {-# OVERLAPPING #-} GHasField field sub t => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
108+ gupcast r = M1 (K1 (r ^. glabel @field))
109+
110+instance GUpcast sub sup => GUpcast sub (M1 i c sup) where
111+ gupcast = M1 . gupcast
112+
113+--------------------------------------------------------------------------------
114+-- * Generic smashing
115+
116+class GSmash sub sup where
117+ gsmash :: sup p -> sub p -> sub p
118+
119+instance (GSmash a sup, GSmash b sup) => GSmash (a :*: b) sup where
120+ gsmash rep (a :*: b) = gsmash rep a :*: gsmash rep b
121+
122+instance {-# OVERLAPPING #-}
123+ ( leaf ~ (S1 ('MetaSel ('Just field) p f b) t)
124+ , GSmashLeaf leaf sup (Contains field sup)
125+ ) => GSmash (S1 ('MetaSel ('Just field) p f b) t) sup where
126+ gsmash = gsmashLeaf @_ @_ @(Contains field sup)
127+
128+instance GSmash sub sup => GSmash (M1 i c sub) sup where
129+ gsmash sup (M1 sub) = M1 (gsmash sup sub)
130+
131+class GSmashLeaf sub sup (w :: Maybe Type) where
132+ gsmashLeaf :: sup p -> sub p -> sub p
133+
134+instance (GHasField field sup t) => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup ('Just t) where
135+ gsmashLeaf sup (M1 (K1 _)) = M1 (K1 (sup ^. glabel @field))
136+
137+instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'Nothing where
138+ gsmashLeaf _ = id
src/Data/Generics/Sum/Any.hsdeleted−96
@@ -1,96 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE FunctionalDependencies #-}
4−{-# LANGUAGE MonoLocalBinds #-}
5−{-# LANGUAGE MultiParamTypeClasses #-}
6−{-# LANGUAGE PolyKinds #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE TypeApplications #-}
9−{-# LANGUAGE UndecidableInstances #-}
10−
11−-----------------------------------------------------------------------------
12−-- |
13−-- Module : Data.Generics.Sum.Any
14−-- Copyright : (C) 2019 Csongor Kiss
15−-- License : BSD3
16−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17−-- Stability : experimental
18−-- Portability : non-portable
19−--
20−-- Derive a variety of prisms generically.
21−--
22−-----------------------------------------------------------------------------
23−
24−module Data.Generics.Sum.Any
25− ( -- *Prisms
26− --
27− -- $setup
28− AsAny (..)
29− ) where
30−
31−import Data.Generics.Sum.Constructors
32−import Data.Generics.Sum.Typed
33−import Data.Generics.Internal.VL.Prism
34−
35−-- $setup
36−-- == /Running example:/
37−--
38−-- >>> :set -XTypeApplications
39−-- >>> :set -XDataKinds
40−-- >>> :set -XDeriveGeneric
41−-- >>> import GHC.Generics
42−-- >>> :m +Data.Generics.Internal.VL.Prism
43−-- >>> :{
44−-- data Animal
45−-- = Dog Dog
46−-- | Cat Name Age
47−-- | Duck Age
48−-- deriving (Generic, Show)
49−-- data Dog
50−-- = MkDog
51−-- { name :: Name
52−-- , age :: Age
53−-- }
54−-- deriving (Generic, Show)
55−-- type Name = String
56−-- type Age = Int
57−-- dog, cat, duck :: Animal
58−-- dog = Dog (MkDog "Shep" 3)
59−-- cat = Cat "Mog" 5
60−-- duck = Duck 2
61−-- :}
62−
63−-- |Sums that have generic prisms.
64−class AsAny sel a s | s sel -> a where
65− -- |A prism that projects a sum as identified by some selector. Currently
66− -- supported selectors are constructor names and unique types. Compatible
67− -- with the lens package's 'Control.Lens.Prism' type.
68− --
69− -- >>> dog ^? _As @"Dog"
70− -- Just (MkDog {name = "Shep", age = 3})
71− --
72− -- >>> dog ^? _As @Dog
73− -- Just (MkDog {name = "Shep", age = 3})
74− --
75− -- >>> dog ^? _As @"Cat"
76− -- Nothing
77− --
78− -- >>> cat ^? _As @(Name, Age)
79− -- Just ("Mog",5)
80− --
81− -- >>> cat ^? _As @"Cat"
82− -- Just ("Mog",5)
83− --
84− -- >>> _As @"Cat" # ("Garfield", 6) :: Animal
85− -- Cat "Garfield" 6
86− --
87− -- >>> duck ^? _As @Age
88− -- Just 2
89− _As :: Prism s s a a
90−
91−instance AsConstructor ctor s s a a => AsAny ctor a s where
92− _As = _Ctor @ctor
93−
94−instance AsType a s => AsAny a a s where
95− _As = _Typed @a
96−
src/Data/Generics/Sum/Constructors.hsdeleted−212
@@ -1,212 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE CPP #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE FunctionalDependencies #-}
6−{-# LANGUAGE KindSignatures #-}
7−{-# LANGUAGE MultiParamTypeClasses #-}
8−{-# LANGUAGE ScopedTypeVariables #-}
9−{-# LANGUAGE TypeApplications #-}
10−{-# LANGUAGE TypeFamilies #-}
11−{-# LANGUAGE TypeOperators #-}
12−{-# LANGUAGE UndecidableInstances #-}
13−{-# LANGUAGE FlexibleContexts #-}
14−
15−-----------------------------------------------------------------------------
16−-- |
17−-- Module : Data.Generics.Sum.Constructors
18−-- Copyright : (C) 2019 Csongor Kiss
19−-- License : BSD3
20−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21−-- Stability : experimental
22−-- Portability : non-portable
23−--
24−-- Derive constructor-name-based prisms generically.
25−--
26−-----------------------------------------------------------------------------
27−
28−module Data.Generics.Sum.Constructors
29− ( -- *Prisms
30−
31− -- $setup
32− AsConstructor (..)
33− , AsConstructor_ (..)
34− , AsConstructor' (..)
35− , AsConstructor0 (..)
36− ) where
37−
38−import Data.Generics.Internal.Families
39−import Data.Generics.Internal.Void
40−import Data.Generics.Sum.Internal.Constructors
41−
42−import Data.Kind (Constraint, Type)
43−import GHC.Generics (Generic (Rep))
44−import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
45−import Data.Generics.Internal.VL.Prism
46−import Data.Generics.Internal.Profunctor.Iso
47−import Data.Generics.Internal.Profunctor.Prism (prismPRavel)
48−import Data.Generics.Internal.Errors
49−
50−-- $setup
51−-- == /Running example:/
52−--
53−-- >>> :set -XTypeApplications
54−-- >>> :set -XDataKinds
55−-- >>> :set -XDeriveGeneric
56−-- >>> :set -XFlexibleContexts
57−-- >>> :set -XTypeFamilies
58−-- >>> import GHC.Generics
59−-- >>> :m +Data.Generics.Internal.VL.Prism
60−-- >>> :m +Data.Generics.Product.Fields
61−-- >>> :m +Data.Function
62−-- >>> :{
63−-- data Animal a
64−-- = Dog (Dog a)
65−-- | Cat Name Age
66−-- | Duck Age
67−-- deriving (Generic, Show)
68−-- data Dog a
69−-- = MkDog
70−-- { name :: Name
71−-- , age :: Age
72−-- , fieldA :: a
73−-- }
74−-- deriving Show
75−-- type Name = String
76−-- type Age = Int
77−-- dog, cat, duck :: Animal Int
78−-- dog = Dog (MkDog "Shep" 3 30)
79−-- cat = Cat "Mog" 5
80−-- duck = Duck 2
81−-- :}
82−
83−-- |Sums that have a constructor with a given name.
84−class AsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where
85− -- |A prism that projects a named constructor from a sum. Compatible with the
86− -- lens package's 'Control.Lens.Prism' type.
87− --
88− -- >>> dog ^? _Ctor @"Dog"
89− -- Just (MkDog {name = "Shep", age = 3, fieldA = 30})
90− --
91− -- >>> dog ^? _Ctor @"Cat"
92− -- Nothing
93− --
94− -- >>> cat ^? _Ctor @"Cat"
95− -- Just ("Mog",5)
96− --
97− -- >>> _Ctor @"Cat" # ("Garfield", 6) :: Animal Int
98− -- Cat "Garfield" 6
99− --
100− -- === /Type errors/
101− --
102− -- >>> cat ^? _Ctor @"Turtle"
103− -- ...
104− -- ...
105− -- ... The type Animal Int does not contain a constructor named "Turtle"
106− -- ...
107− _Ctor :: Prism s t a b
108−
109−-- |Sums that have a constructor with a given name.
110−--
111−-- The difference between 'HasConstructor' and 'HasConstructor_' is similar to
112−-- the one between 'Data.Generics.Product.Fields.HasField' and
113−-- 'Data.Generics.Product.Fields.HasField_'.
114−-- See 'Data.Generics.Product.Fields.HasField_'.
115−class AsConstructor_ (ctor :: Symbol) s t a b where
116− _Ctor_ :: Prism s t a b
117−
118−class AsConstructor' (ctor :: Symbol) s a | ctor s -> a where
119− _Ctor' :: Prism s s a a
120−
121−-- |Sums that have a constructor with a given name.
122−--
123−-- This class gives the minimal constraints needed to define this prism.
124−-- For common uses, see 'HasConstructor'.
125−class AsConstructor0 (ctor :: Symbol) s t a b where
126− _Ctor0 :: Prism s t a b
127−
128−instance
129− ( Generic s
130− , ErrorUnless ctor s (HasCtorP ctor (Rep s))
131− , GAsConstructor' ctor (Rep s) a
132− , Defined (Rep s)
133− (NoGeneric s '[ 'Text "arising from a generic prism focusing on the "
134− ':<>: QuoteType ctor ':<>: 'Text " constructor of type " ':<>: QuoteType a
135− , 'Text "in " ':<>: QuoteType s])
136− (() :: Constraint)
137− ) => AsConstructor' ctor s a where
138− _Ctor' eta = prismRavel (prismPRavel (repIso . _GCtor @ctor)) eta
139− {-# INLINE[2] _Ctor' #-}
140−
141−instance
142− ( ErrorUnless ctor s (HasCtorP ctor (Rep s))
143− , GAsConstructor' ctor (Rep s) a -- TODO: add a test similar to #62 for prisms
144− , GAsConstructor' ctor (Rep (Indexed s)) a'
145− , GAsConstructor ctor (Rep s) (Rep t) a b
146− , t ~ Infer s a' b
147− , GAsConstructor' ctor (Rep (Indexed t)) b'
148− , s ~ Infer t b' a
149− , AsConstructor0 ctor s t a b
150− ) => AsConstructor ctor s t a b where
151−
152− _Ctor = _Ctor0 @ctor
153− {-# INLINE[2] _Ctor #-}
154−
155−-- | See Note [Uncluttering type signatures]
156−#if __GLASGOW_HASKELL__ < 804
157−-- >>> :t _Ctor
158−-- _Ctor
159−-- :: (Applicative f, Data.Profunctor.Choice.Choice p,
160−-- AsConstructor ctor s t a b) =>
161−-- p a (f b) -> p s (f t)
162−#else
163−-- >>> :t _Ctor
164−-- _Ctor
165−-- :: (AsConstructor ctor s t a b, Data.Profunctor.Choice.Choice p,
166−-- Applicative f) =>
167−-- p a (f b) -> p s (f t)
168−#endif
169−instance {-# OVERLAPPING #-} AsConstructor ctor (Void1 a) (Void1 b) a b where
170− _Ctor = undefined
171−
172−instance
173− ( ErrorUnless ctor s (HasCtorP ctor (Rep s))
174− , GAsConstructor' ctor (Rep s) a -- TODO: add a test similar to #62 for prisms
175− , GAsConstructor' ctor (Rep (Indexed s)) a'
176− , GAsConstructor ctor (Rep s) (Rep t) a b
177− , GAsConstructor' ctor (Rep (Indexed t)) b'
178− , UnifyHead s t
179− , UnifyHead t s
180− , AsConstructor0 ctor s t a b
181− ) => AsConstructor_ ctor s t a b where
182−
183− _Ctor_ = _Ctor0 @ctor
184− {-# INLINE[2] _Ctor_ #-}
185−
186−instance {-# OVERLAPPING #-} AsConstructor_ ctor (Void1 a) (Void1 b) a b where
187− _Ctor_ = undefined
188−
189−instance
190− ( Generic s
191− , Generic t
192− , GAsConstructor ctor (Rep s) (Rep t) a b
193− , Defined (Rep s)
194− (NoGeneric s '[ 'Text "arising from a generic prism focusing on the "
195− ':<>: QuoteType ctor ':<>: 'Text " constructor of type " ':<>: QuoteType a
196− , 'Text "in " ':<>: QuoteType s])
197− (() :: Constraint)
198− ) => AsConstructor0 ctor s t a b where
199− _Ctor0 = prismRavel (prismPRavel (repIso . _GCtor @ctor))
200− {-# INLINE[2] _Ctor0 #-}
201−
202−type family ErrorUnless (ctor :: Symbol) (s :: Type) (contains :: Bool) :: Constraint where
203− ErrorUnless ctor s 'False
204− = TypeError
205− ( 'Text "The type "
206− ':<>: 'ShowType s
207− ':<>: 'Text " does not contain a constructor named "
208− ':<>: 'ShowType ctor
209− )
210−
211− ErrorUnless _ _ 'True
212− = ()
src/Data/Generics/Sum/Internal/Constructors.hsdeleted−76
@@ -1,76 +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 ScopedTypeVariables #-}
9−{-# LANGUAGE TypeApplications #-}
10−{-# LANGUAGE TypeFamilies #-}
11−{-# LANGUAGE TypeOperators #-}
12−{-# LANGUAGE UndecidableInstances #-}
13−
14−-----------------------------------------------------------------------------
15−-- |
16−-- Module : Data.Generics.Sum.Internal.Constructors
17−-- Copyright : (C) 2019 Csongor Kiss
18−-- License : BSD3
19−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20−-- Stability : experimental
21−-- Portability : non-portable
22−--
23−-- Derive constructor-name-based prisms generically.
24−--
25−-----------------------------------------------------------------------------
26−
27−module Data.Generics.Sum.Internal.Constructors
28− ( GAsConstructor (..)
29− , GAsConstructor'
30− ) where
31−
32−import Data.Generics.Internal.Families
33−import Data.Generics.Product.Internal.HList
34−import Data.Profunctor (Profunctor(..))
35−
36−import GHC.Generics
37−import GHC.TypeLits (Symbol)
38−import Data.Generics.Internal.Profunctor.Lens
39−import Data.Generics.Internal.Profunctor.Iso
40−import Data.Generics.Internal.Profunctor.Prism
41−
42−-- |As 'AsConstructor' but over generic representations as defined by
43−-- "GHC.Generics".
44−class GAsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where
45− _GCtor :: Prism (s x) (t x) a b
46−
47−type GAsConstructor' ctor s a = GAsConstructor ctor s s a a
48−
49−instance
50− ( GIsList f f as as
51− , GIsList g g bs bs
52− , ListTuple a as
53− , ListTuple b bs
54− ) => GAsConstructor ctor (M1 C ('MetaCons ctor fixity fields) f) (M1 C ('MetaCons ctor fixity fields) g) a b where
55−
56− _GCtor = dimap (listToTuple . view glist . unM1) (M1 . view (fromIso glist) . tupleToList)
57− {-# INLINE[0] _GCtor #-}
58−
59−instance GSumAsConstructor ctor (HasCtorP ctor l) l r l' r' a b => GAsConstructor ctor (l :+: r) (l' :+: r') a b where
60− _GCtor = _GSumCtor @ctor @(HasCtorP ctor l)
61− {-# INLINE[0] _GCtor #-}
62−
63−instance GAsConstructor ctor f f' a b => GAsConstructor ctor (M1 D meta f) (M1 D meta f') a b where
64− _GCtor = mIso . _GCtor @ctor
65− {-# INLINE[0] _GCtor #-}
66−
67−class GSumAsConstructor (ctor :: Symbol) (contains :: Bool) l r l' r' a b | ctor l r -> a, ctor l' r' -> b where
68− _GSumCtor :: Prism ((l :+: r) x) ((l' :+: r') x) a b
69−
70−instance GAsConstructor ctor l l' a b => GSumAsConstructor ctor 'True l r l' r a b where
71− _GSumCtor = left . _GCtor @ctor
72− {-# INLINE[0] _GSumCtor #-}
73−
74−instance GAsConstructor ctor r r' a b => GSumAsConstructor ctor 'False l r l r' a b where
75− _GSumCtor = right . _GCtor @ctor
76− {-# INLINE[0] _GSumCtor #-}
src/Data/Generics/Sum/Internal/Subtype.hsdeleted−115
@@ -1,115 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE KindSignatures #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE PolyKinds #-}
8−{-# LANGUAGE ScopedTypeVariables #-}
9−{-# LANGUAGE TypeApplications #-}
10−{-# LANGUAGE TypeOperators #-}
11−{-# LANGUAGE TypeSynonymInstances #-}
12−{-# LANGUAGE UndecidableInstances #-}
13−
14−-----------------------------------------------------------------------------
15−-- |
16−-- Module : Data.Generics.Sum.Internal.Subtype
17−-- Copyright : (C) 2019 Csongor Kiss
18−-- License : BSD3
19−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20−-- Stability : experimental
21−-- Portability : non-portable
22−--
23−-- Structural subtype relationships between sum types.
24−--
25−-----------------------------------------------------------------------------
26−
27−module Data.Generics.Sum.Internal.Subtype
28− ( GAsSubtype (..)
29− ) where
30−
31−import Data.Generics.Product.Internal.HList
32−import Data.Generics.Sum.Internal.Typed
33−
34−import Data.Kind
35−import GHC.Generics
36−import Data.Generics.Internal.Profunctor.Iso
37−import Data.Generics.Internal.Profunctor.Prism
38−import Data.Generics.Internal.Families.Has
39−
40−-- |As 'AsSubtype' but over generic representations as defined by
41−-- "GHC.Generics".
42−class GAsSubtype (subf :: Type -> Type) (supf :: Type -> Type) where
43− _GSub :: Prism' (supf x) (subf x)
44−
45−instance
46− ( GSplash sub sup
47− , GDowncast sub sup
48− ) => GAsSubtype sub sup where
49− _GSub f = prism _GSplash _GDowncast f
50− {-# INLINE[0] _GSub #-}
51−
52−--------------------------------------------------------------------------------
53−
54−class GSplash (sub :: Type -> Type) (sup :: Type -> Type) where
55− _GSplash :: sub x -> sup x
56−
57−instance (GSplash a sup, GSplash b sup) => GSplash (a :+: b) sup where
58− _GSplash (L1 rep) = _GSplash rep
59− _GSplash (R1 rep) = _GSplash rep
60− {-# INLINE[0] _GSplash #-}
61−
62−instance
63− ( GIsList subf subf as as
64− , GAsType supf as
65− ) => GSplash (C1 meta subf) supf where
66− _GSplash p = build (_GTyped . fromIso (mIso . glist)) p
67− {-# INLINE[0] _GSplash #-}
68−
69−instance GSplash sub sup => GSplash (D1 c sub) sup where
70− _GSplash (M1 m) = _GSplash m
71− {-# INLINE[0] _GSplash #-}
72−
73−--------------------------------------------------------------------------------
74−
75−class GDowncast sub sup where
76− _GDowncast :: sup x -> Either (sup x) (sub x)
77−
78−instance
79− ( GIsList sup sup as as
80− , GDowncastC (HasPartialTypeP as sub) sub sup
81− ) => GDowncast sub (C1 m sup) where
82− _GDowncast (M1 m) = case _GDowncastC @(HasPartialTypeP as sub) m of
83− Left _ -> Left (M1 m)
84− Right r -> Right r
85− {-# INLINE[0] _GDowncast #-}
86−
87−instance (GDowncast sub l, GDowncast sub r) => GDowncast sub (l :+: r) where
88− _GDowncast (L1 x) = case _GDowncast x of
89− Left _ -> Left (L1 x)
90− Right r -> Right r
91− _GDowncast (R1 x) = case _GDowncast x of
92− Left _ -> Left (R1 x)
93− Right r -> Right r
94− {-# INLINE[0] _GDowncast #-}
95−
96−instance GDowncast sub sup => GDowncast sub (D1 m sup) where
97− _GDowncast (M1 m) = case _GDowncast m of
98− Left _ -> Left (M1 m)
99− Right r -> Right r
100− {-# INLINE[0] _GDowncast #-}
101−
102−class GDowncastC (contains :: Bool) sub sup where
103− _GDowncastC :: sup x -> Either (sup x) (sub x)
104−
105−instance GDowncastC 'False sub sup where
106− _GDowncastC sup = Left sup
107− {-# INLINE[0] _GDowncastC #-}
108−
109−instance
110− ( GAsType sub subl
111− , GIsList sup sup subl subl
112− ) => GDowncastC 'True sub sup where
113− _GDowncastC sup = Right (build (_GTyped . fromIso glist) sup)
114− {-# INLINE[0] _GDowncastC #-}
115−
src/Data/Generics/Sum/Internal/Typed.hsdeleted−72
@@ -1,72 +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.Sum.Internal.Typed
16−-- Copyright : (C) 2019 Csongor Kiss
17−-- License : BSD3
18−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19−-- Stability : experimental
20−-- Portability : non-portable
21−--
22−-- Derive constructor-field-type-based prisms generically.
23−--
24−-----------------------------------------------------------------------------
25−
26−module Data.Generics.Sum.Internal.Typed
27− ( GAsType (..)
28− ) where
29−
30−import Data.Kind
31−import GHC.Generics
32−import Data.Tagged
33−
34−import Data.Generics.Internal.Families
35−import Data.Generics.Product.Internal.HList
36−import Data.Generics.Internal.Profunctor.Iso
37−import Data.Generics.Internal.Profunctor.Prism
38−
39−-- |As 'AsType' but over generic representations as defined by "GHC.Generics".
40−class GAsType (f :: Type -> Type) (as :: [Type]) where
41− _GTyped :: Prism (f x) (f x) (HList as) (HList as)
42−-- We create this specialised version as we use it in the subtype prism
43−-- If we don't create it, the opportunity for specialisation is only
44−-- created after specialisation happens, I think a late specialisation pass
45−-- would pick up this case.
46−{-# SPECIALISE _GTyped :: (Tagged b b -> Tagged t t) #-}
47−
48−
49−instance
50− ( GIsList f f as as
51− ) => GAsType (M1 C meta f) as where
52− _GTyped = mIso . glist
53− {-# INLINE[0] _GTyped #-}
54−
55−instance GSumAsType (HasPartialTypeP a l) l r a => GAsType (l :+: r) a where
56− _GTyped = _GSumTyped @(HasPartialTypeP a l)
57− {-# INLINE[0] _GTyped #-}
58−
59−instance GAsType f a => GAsType (M1 D meta f) a where
60− _GTyped = mIso . _GTyped
61− {-# INLINE[0] _GTyped #-}
62−
63−class GSumAsType (contains :: Bool) l r (a :: [Type]) where
64− _GSumTyped :: Prism ((l :+: r) x) ((l :+: r) x) (HList a) (HList a)
65−
66−instance GAsType l a => GSumAsType 'True l r a where
67− _GSumTyped = left . _GTyped
68− {-# INLINE[0] _GSumTyped #-}
69−
70−instance GAsType r a => GSumAsType 'False l r a where
71− _GSumTyped = right . _GTyped
72− {-# INLINE[0] _GSumTyped #-}
src/Data/Generics/Sum/Subtype.hsdeleted−158
@@ -1,158 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE MonoLocalBinds #-}
5−{-# LANGUAGE MultiParamTypeClasses #-}
6−{-# LANGUAGE ScopedTypeVariables #-}
7−{-# LANGUAGE TypeApplications #-}
8−{-# LANGUAGE TypeOperators #-}
9−{-# LANGUAGE TypeSynonymInstances #-}
10−{-# LANGUAGE UndecidableInstances #-}
11−
12−-----------------------------------------------------------------------------
13−-- |
14−-- Module : Data.Generics.Sum.Subtype
15−-- Copyright : (C) 2019 Csongor Kiss
16−-- License : BSD3
17−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
18−-- Stability : experimental
19−-- Portability : non-portable
20−--
21−-- Structural subtype relationships between sum types.
22−--
23−-----------------------------------------------------------------------------
24−
25−module Data.Generics.Sum.Subtype
26− ( -- *Prisms
27− --
28− -- $setup
29− AsSubtype (..)
30− ) where
31−
32−import Data.Generics.Internal.Void
33−import Data.Generics.Sum.Internal.Subtype
34−
35−import GHC.Generics (Generic (Rep))
36−import Data.Generics.Internal.VL.Prism
37−import Data.Generics.Internal.Profunctor.Iso
38−
39−-- $setup
40−-- == /Running example:/
41−--
42−-- >>> :set -XTypeApplications
43−-- >>> :set -XDataKinds
44−-- >>> :set -XDeriveGeneric
45−-- >>> import GHC.Generics
46−-- >>> :m +Data.Generics.Internal.VL.Prism
47−-- >>> :{
48−-- data Animal
49−-- = Dog Dog
50−-- | Cat Name Age
51−-- | Duck Age
52−-- deriving (Generic, Show)
53−-- data FourLeggedAnimal
54−-- = Dog4 Dog
55−-- | Cat4 Name Age
56−-- deriving (Generic, Show)
57−-- data Dog = MkDog
58−-- { name :: Name
59−-- , age :: Age
60−-- }
61−-- deriving (Generic, Show)
62−-- type Name = String
63−-- type Age = Int
64−-- dog, cat, duck :: Animal
65−-- dog = Dog (MkDog "Shep" 3)
66−-- cat = Cat "Mog" 5
67−-- duck = Duck 2
68−-- dog4, cat4 :: FourLeggedAnimal
69−-- dog4 = Dog4 (MkDog "Snowy" 4)
70−-- cat4 = Cat4 "Garfield" 6
71−-- :}
72−
73−-- |Structural subtyping between sums. A sum 'Sub' is a subtype of another sum
74−-- 'Sup' if a value of 'Sub' can be given (modulo naming of constructors)
75−-- whenever a value of 'Sup' is expected. In the running example for instance,
76−-- 'FourLeggedAnimal` is a subtype of 'Animal' since a value of the former can
77−-- be given as a value of the latter (renaming 'Dog4' to 'Dog' and 'Cat4' to
78−-- 'Cat').
79−class AsSubtype sub sup where
80− -- |A prism that captures structural subtyping. Allows a substructure to be
81− -- injected (upcast) into a superstructure or a superstructure to be downcast
82− -- into a substructure (which may fail).
83− --
84− -- >>> _Sub # dog4 :: Animal
85− -- Dog (MkDog {name = "Snowy", age = 4})
86− --
87− -- >>> cat ^? _Sub :: Maybe FourLeggedAnimal
88− -- Just (Cat4 "Mog" 5)
89− --
90− -- >>> duck ^? _Sub :: Maybe FourLeggedAnimal
91− -- Nothing
92− _Sub :: Prism' sup sub
93− _Sub = prism injectSub (\i -> maybe (Left i) Right (projectSub i))
94− {-# INLINE[2] _Sub #-}
95−
96− -- |Injects a subtype into a supertype (upcast).
97− injectSub :: sub -> sup
98− injectSub
99− = build (_Sub @sub @sup)
100−
101− -- |Projects a subtype from a supertype (downcast).
102− projectSub :: sup -> Maybe sub
103− projectSub
104− = either (const Nothing) Just . match (_Sub @sub @sup)
105−
106− {-# MINIMAL (injectSub, projectSub) | _Sub #-}
107−
108−instance
109− ( Generic sub
110− , Generic sup
111− , GAsSubtype (Rep sub) (Rep sup)
112− ) => AsSubtype sub sup where
113−
114− _Sub f = prismRavel (repIso . _GSub . fromIso repIso) f
115− {-# INLINE[2] _Sub #-}
116−
117−-- | Reflexive case
118−-- >>> _Sub # dog :: Animal
119−-- Dog (MkDog {name = "Shep", age = 3})
120−instance {-# OVERLAPPING #-} AsSubtype a a where
121− _Sub = id
122− {-# INLINE[2] _Sub #-}
123−
124−-- | See Note [Uncluttering type signatures]
125−#if __GLASGOW_HASKELL__ < 804
126−-- >>> :t _Sub
127−--_Sub
128−-- :: (Applicative f, Data.Profunctor.Choice.Choice p,
129−-- AsSubtype sub sup) =>
130−-- p sub (f sub) -> p sup (f sup)
131−-- >>> :t _Sub
132−#else
133−--_Sub
134−-- :: (AsSubtype sub sup, Data.Profunctor.Choice.Choice p,
135−-- Applicative f) =>
136−-- p sub (f sub) -> p sup (f sup)
137−#endif
138−instance {-# OVERLAPPING #-} AsSubtype a Void where
139− injectSub = undefined
140− projectSub = undefined
141−
142−-- | See Note [Uncluttering type signatures]
143−#if __GLASGOW_HASKELL__ < 804
144−-- >>> :t _Sub @Int
145−-- _Sub @Int
146−-- :: (Applicative f, Data.Profunctor.Choice.Choice p,
147−-- AsSubtype Int sup) =>
148−-- p Int (f Int) -> p sup (f sup)
149−#else
150−-- >>> :t _Sub @Int
151−-- _Sub @Int
152−-- :: (AsSubtype Int sup, Data.Profunctor.Choice.Choice p,
153−-- Applicative f) =>
154−-- p Int (f Int) -> p sup (f sup)
155−#endif
156−instance {-# OVERLAPPING #-} AsSubtype Void a where
157− injectSub = undefined
158− projectSub = undefined
src/Data/Generics/Sum/Typed.hsdeleted−178
@@ -1,178 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE TypeApplications #-}
3−{-# LANGUAGE AllowAmbiguousTypes #-}
4−{-# LANGUAGE DataKinds #-}
5−{-# LANGUAGE FlexibleContexts #-}
6−{-# LANGUAGE FlexibleInstances #-}
7−{-# LANGUAGE KindSignatures #-}
8−{-# LANGUAGE MultiParamTypeClasses #-}
9−{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE TypeFamilies #-}
11−{-# LANGUAGE TypeOperators #-}
12−{-# LANGUAGE UndecidableInstances #-}
13−
14−-----------------------------------------------------------------------------
15−-- |
16−-- Module : Data.Generics.Sum.Typed
17−-- Copyright : (C) 2019 Csongor Kiss
18−-- License : BSD3
19−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20−-- Stability : experimental
21−-- Portability : non-portable
22−--
23−-- Derive constructor-field-type-based prisms generically.
24−--
25−-----------------------------------------------------------------------------
26−
27−module Data.Generics.Sum.Typed
28− ( -- *Prisms
29− --
30− -- $setup
31− AsType (..)
32− ) where
33−
34−import Data.Kind
35−import GHC.Generics
36−import GHC.TypeLits (TypeError, ErrorMessage (..), Symbol)
37−import Data.Generics.Sum.Internal.Typed
38−import Data.Generics.Internal.Errors
39−
40−import Data.Generics.Internal.Families
41−import Data.Generics.Internal.Void
42−import Data.Generics.Product.Internal.HList
43−import Data.Generics.Internal.VL.Prism
44−import Data.Generics.Internal.Profunctor.Iso
45−import Data.Generics.Internal.Profunctor.Prism (prismPRavel)
46−
47−-- $setup
48−-- >>> :set -XTypeApplications
49−-- >>> :set -XDataKinds
50−-- >>> :set -XDeriveGeneric
51−-- >>> import GHC.Generics
52−-- >>> :m +Data.Generics.Internal.VL.Prism
53−-- >>> :{
54−-- data Animal
55−-- = Dog Dog
56−-- | Cat Name Age
57−-- | Duck Age
58−-- | Turtle Age
59−-- deriving (Generic, Show)
60−-- data Dog
61−-- = MkDog
62−-- { name :: Name
63−-- , age :: Age
64−-- }
65−-- deriving (Generic, Show)
66−-- type Name = String
67−-- newtype Age = Age Int deriving Show
68−-- dog, cat, duck :: Animal
69−-- dog = Dog (MkDog "Shep" (Age 3))
70−-- cat = Cat "Mog" (Age 5)
71−-- duck = Duck (Age 2)
72−-- :}
73−
74−
75−-- |Sums that have a constructor with a field of the given type.
76−class AsType a s where
77− -- |A prism that projects a constructor uniquely identifiable by the type of
78− -- its field. Compatible with the lens package's 'Control.Lens.Prism' type.
79− --
80− -- >>> dog ^? _Typed @Dog
81− -- Just (MkDog {name = "Shep", age = Age 3})
82− -- >>> cat ^? _Typed @(Name, Age)
83− -- Just ("Mog",Age 5)
84− -- >>> dog ^? _Typed @Age
85− -- ...
86− -- ...
87− -- ... The type Animal contains multiple constructors whose fields are of type Age.
88− -- ... The choice of constructor is thus ambiguous, could be any of:
89− -- ... Duck
90− -- ... Turtle
91− -- ...
92− _Typed :: Prism' s a
93− _Typed = prism injectTyped (\i -> maybe (Left i) Right (projectTyped i))
94− {-# INLINE[2] _Typed #-}
95−
96− -- |Inject by type.
97− injectTyped :: a -> s
98− injectTyped
99− = build _Typed
100−
101− -- |Project by type.
102− projectTyped :: s -> Maybe a
103− projectTyped
104− = either (const Nothing) Just . match _Typed
105−
106− {-# MINIMAL (injectTyped, projectTyped) | _Typed #-}
107−
108−instance
109− ( Generic s
110− , ErrorUnlessOne a s (CollectPartialType as (Rep s))
111− , as ~ TupleToList a
112− , ListTuple a as
113− , GAsType (Rep s) as
114− , Defined (Rep s)
115− (NoGeneric s '[ 'Text "arising from a generic prism focusing on a constructor of type " ':<>: QuoteType a])
116− (() :: Constraint)
117− ) => AsType a s where
118−
119− _Typed eta = prismRavel (prismPRavel (repIso . _GTyped @_ @as . tupled)) eta
120− {-# INLINE[2] _Typed #-}
121−
122−-- | See Note [Uncluttering type signatures]
123−#if __GLASGOW_HASKELL__ < 804
124−-- >>> :t _Typed
125−-- _Typed
126−-- :: (Applicative f, Data.Profunctor.Choice.Choice p, AsType a s) =>
127−-- p a (f a) -> p s (f s)
128−#else
129−-- >>> :t _Typed
130−-- _Typed
131−-- :: (AsType a s, Data.Profunctor.Choice.Choice p, Applicative f) =>
132−-- p a (f a) -> p s (f s)
133−#endif
134−instance {-# OVERLAPPING #-} AsType a Void where
135− _Typed = undefined
136− injectTyped = undefined
137− projectTyped = undefined
138−
139−-- | See Note [Uncluttering type signatures]
140−#if __GLASGOW_HASKELL__ < 804
141−-- >>> :t _Typed @Int
142−-- _Typed @Int
143−-- :: (Applicative f, Data.Profunctor.Choice.Choice p,
144−-- AsType Int s) =>
145−-- p Int (f Int) -> p s (f s)
146−#else
147−-- >>> :t _Typed @Int
148−-- _Typed @Int
149−-- :: (AsType Int s, Data.Profunctor.Choice.Choice p,
150−-- Applicative f) =>
151−-- p Int (f Int) -> p s (f s)
152−#endif
153−instance {-# OVERLAPPING #-} AsType Void a where
154− _Typed = undefined
155− injectTyped = undefined
156− projectTyped = undefined
157−
158−type family ErrorUnlessOne (a :: Type) (s :: Type) (ctors :: [Symbol]) :: Constraint where
159− ErrorUnlessOne _ _ '[_]
160− = ()
161−
162− ErrorUnlessOne a s '[]
163− = TypeError
164− ( 'Text "The type "
165− ':<>: 'ShowType s
166− ':<>: 'Text " does not contain a constructor whose field is of type "
167− ':<>: 'ShowType a
168− )
169−
170− ErrorUnlessOne a s cs
171− = TypeError
172− ( 'Text "The type "
173− ':<>: 'ShowType s
174− ':<>: 'Text " contains multiple constructors whose fields are of type "
175− ':<>: 'ShowType a ':<>: 'Text "."
176− ':$$: 'Text "The choice of constructor is thus ambiguous, could be any of:"
177− ':$$: ShowSymbols cs
178− )
src/Data/Generics/Wrapped.hsdeleted−104
@@ -1,104 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE TypeApplications #-}
3−{-# language ConstraintKinds #-}
4−{-# language DataKinds #-}
5−{-# language FlexibleContexts #-}
6−{-# language FlexibleInstances #-}
7−{-# language FunctionalDependencies #-}
8−{-# language MultiParamTypeClasses #-}
9−{-# language ScopedTypeVariables #-}
10−{-# language TypeFamilies #-}
11−{-# language TypeOperators #-}
12−{-# language UndecidableInstances #-}
13−
14−-----------------------------------------------------------------------------
15−-- |
16−-- Module : Data.Generics.Wrapped
17−-- Copyright : (C) 2019 Csongor Kiss
18−-- License : BSD3
19−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20−-- Stability : experimental
21−-- Portability : non-portable
22−--
23−-- Derive an isomorphism between a newtype and its wrapped type.
24−--
25−-----------------------------------------------------------------------------
26−
27−module Data.Generics.Wrapped
28− ( Wrapped (..)
29− , wrappedTo
30− , wrappedFrom
31− , _Unwrapped
32− , _Wrapped
33− )
34−where
35−
36−import Control.Applicative (Const(..))
37−import Data.Generics.Internal.Profunctor.Iso
38−
39−import qualified Data.Generics.Internal.VL.Iso as VL
40−import Data.Generics.Internal.Families.Changing ( UnifyHead )
41−
42−import Data.Kind (Constraint)
43−import GHC.Generics
44−import GHC.TypeLits
45−
46−type family ErrorUnlessOnlyOne a b :: Constraint where
47− ErrorUnlessOnlyOne t (M1 i k a) = ErrorUnlessOnlyOne t a
48− ErrorUnlessOnlyOne t (K1 i a) = ()
49− ErrorUnlessOnlyOne t a =
50− TypeError ('ShowType t ':<>: 'Text " is not a single-constructor, single-field datatype")
51−
52−-- | @since 1.1.0.0
53−_Unwrapped :: Wrapped s t a b => VL.Iso s t a b
54−_Unwrapped = wrappedIso
55−{-# inline _Unwrapped #-}
56−
57−-- | @since 1.1.0.0
58−_Wrapped :: Wrapped s t a b => VL.Iso b a t s
59−_Wrapped = VL.fromIso wrappedIso
60−{-# inline _Wrapped #-}
61−
62−-- TODO: move this into doctets
63−
64−-- newtype FlippedEither a b = FlippedEither (Either b a)
65−-- deriving Generic
66−
67−-- test :: (a -> c) -> FlippedEither a b -> FlippedEither c b
68−-- test f = over wrappedIso (fmap f)
69−
70−class GWrapped s t a b | s -> a, t -> b, s b -> t, t a -> s where
71− gWrapped :: Iso (s x) (t x) a b
72−
73−instance GWrapped s t a b => GWrapped (M1 i k s) (M1 i k t) a b where
74− gWrapped = mIso . gWrapped
75−
76−instance (a ~ c, b ~ d) => GWrapped (K1 i a) (K1 i b) c d where
77− gWrapped = kIso
78−
79−-- | @since 1.1.0.0
80−class Wrapped s t a b | s -> a, t -> b where
81− -- | @since 1.1.0.0
82− wrappedIso :: VL.Iso s t a b
83−
84−-- | @since 1.1.0.0
85−wrappedTo :: forall s t a b. Wrapped s t a b => s -> a
86−wrappedTo a = view (wrappedIso @s @t @a @b) a
87− where view l s = getConst (l Const s)
88−{-# INLINE wrappedTo #-}
89−
90−-- | @since 1.1.0.0
91−wrappedFrom :: forall s t a b. Wrapped s t a b => b -> t
92−wrappedFrom a = view (VL.fromIso (wrappedIso @s @t @a @b)) a
93− where view l s = getConst (l Const s)
94−{-# INLINE wrappedFrom #-}
95−
96−instance
97− ( Generic s
98− , Generic t
99− , GWrapped (Rep s) (Rep t) a b
100− , UnifyHead s t
101− , UnifyHead t s
102− ) => Wrapped s t a b where
103− wrappedIso = iso2isovl (repIso . gWrapped)
104− {-# INLINE wrappedIso #-}
stack.yaml+4−1
@@ -1,8 +1,11 @@
1+
1−resolver: nightly-2018-08-09
2+resolver: lts-8.17
2
3
3packages:
4packages:
4- '.'
5- '.'
5
6
7+extra-deps: []
8+
6flags: {}
9flags: {}
7
10
8extra-package-dbs: []
11extra-package-dbs: []
test/Bifunctor.hsdeleted−47
@@ -1,47 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DefaultSignatures #-}
3−{-# LANGUAGE DeriveAnyClass #-}
4−{-# LANGUAGE DeriveGeneric #-}
5−{-# LANGUAGE FlexibleContexts #-}
6−{-# LANGUAGE MonoLocalBinds #-}
7−{-# LANGUAGE StandaloneDeriving #-}
8−{-# LANGUAGE TypeApplications #-}
9−
10−module Main (main) where
11−
12−import Control.Lens hiding (Bifunctor(..))
13−import Control.Monad (void)
14−import Data.Generics.Product
15−import GHC.Generics
16−import Test.HUnit
17−
18−main :: IO ()
19−main = void $ runTestTT $
20− bimap (* 2) show mytree ~=? mytreeBimapped
21−
22−data Tree a w = Leaf a
23− | Fork (Tree a w) (Tree a w)
24− | WithWeight (Tree a w) w
25− deriving (Show, Eq, Generic)
26−
27−instance Bifunctor Tree where
28− bimap = gbimap
29−
30−mytree :: Tree Int Int
31−mytree = Fork (WithWeight (Leaf 42) 1)
32− (WithWeight (Fork (Leaf 88) (Leaf 37)) 2)
33−
34−mytreeBimapped :: Tree Int String
35−mytreeBimapped = Fork (WithWeight (Leaf 84) "1")
36− (WithWeight (Fork (Leaf 176) (Leaf 74)) "2")
37−
38−--------------------------------------------------------------------------------
39−
40−class Bifunctor p where
41− bimap :: (a -> c) -> (b -> d) -> p a b -> p c d
42−
43−gbimap ::
44− ( HasParam 0 (p a b) (p a d) b d
45− , HasParam 1 (p a d) (p c d) a c
46− ) => (a -> c) -> (b -> d) -> p a b -> p c d
47−gbimap f g s = s & param @0 %~ g & param @1 %~ f
test/CustomChildren.hsdeleted−63
@@ -1,63 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE KindSignatures #-}
5−{-# LANGUAGE MultiParamTypeClasses #-}
6−{-# LANGUAGE TypeApplications #-}
7−{-# LANGUAGE TypeFamilies #-}
8−{-# LANGUAGE UndecidableInstances #-}
9−
10−module CustomChildren
11− ( customTypesTest
12− ) where
13−
14−import GHC.Generics
15−import Data.Generics.Product
16−import Test.HUnit
17−import Data.Generics.Internal.VL.Lens
18−import Data.Generics.Labels ()
19−import Data.Kind
20−
21−-- Opaque has no Generic instance
22−data Opaque = Opaque String
23− deriving (Show, Eq)
24−
25−-- Hide does have a Generic instance, but we want to hide its contents
26−-- from the traversal
27−data Hide = Hide String
28− deriving (Show, Generic, Eq)
29−
30−-- We first define a symbol for the custom traversal
31−data Custom
32−
33−type instance Children Custom a = ChildrenCustom a
34−
35−type family ChildrenCustom (a :: Type) where
36− ChildrenCustom Opaque = '[String] -- here we state explicitly that Opaque contains a String
37− ChildrenCustom Hide = '[] -- and hide the contents of Hide
38− ChildrenCustom a = Children ChGeneric a -- for the rest, we defer to the generic children
39−
40−-- We define the traversal of Opaque like so:
41−instance HasTypesCustom Custom Opaque String where
42− typesCustom f (Opaque str) = Opaque <$> f str
43−
44−customTypesTest1 :: Test
45−customTypesTest1
46− = TestCase (assertEqual "foo" (over (typesUsing @Custom @String) (++ "!") original) expected)
47− where original = (Opaque "foo", Hide "bar")
48− expected = (Opaque "foo!", Hide "bar") -- only Opaque's String gets modified
49−
50−customTypesTest2 :: Test
51−customTypesTest2
52− = TestCase (assertEqual "foo" (over (typesUsing @Custom @String) (++ "!") original) expected)
53− where original = Opaque "foo"
54− expected = Opaque "foo!"
55−
56−customTypesTest3 :: Test
57−customTypesTest3
58− = TestCase (assertEqual "foo" (over (typesUsing @Custom @String) (++ "!") original) expected)
59− where original = Hide "foo"
60− expected = Hide "foo"
61−
62−customTypesTest :: Test
63−customTypesTest = TestList [customTypesTest1, customTypesTest2, customTypesTest3]
test/Spec.hs+1−276
@@ -1,276 +1 @@
1−{-# OPTIONS_GHC -O -fplugin Test.Inspection.Plugin #-}
1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
2−{-# OPTIONS_GHC -dsuppress-all #-}
3−
4−{-# LANGUAGE AllowAmbiguousTypes #-}
5−{-# LANGUAGE CPP #-}
6−{-# LANGUAGE DataKinds #-}
7−{-# LANGUAGE DeriveGeneric #-}
8−{-# LANGUAGE DuplicateRecordFields #-}
9−{-# LANGUAGE ExistentialQuantification #-}
10−{-# LANGUAGE RankNTypes #-}
11−{-# LANGUAGE ScopedTypeVariables #-}
12−{-# LANGUAGE TypeApplications #-}
13−{-# LANGUAGE TemplateHaskell #-}
14−{-# LANGUAGE OverloadedLabels #-}
15−
16−module Main where
17−
18−import GHC.Generics
19−import Data.Generics.Product
20−import Data.Generics.Sum
21−import Test.Inspection
22−import Test.HUnit
23−import Util
24−import System.Exit
25−import Data.Generics.Internal.VL.Lens
26−import Data.Generics.Internal.VL.Prism
27−import Data.Generics.Internal.VL.Traversal
28−import Control.Lens (_1, (+~))
29−import Data.Function ((&))
30−import Data.Generics.Labels ()
31−
32−-- This is sufficient at we only want to test that they typecheck
33−import Test24 ()
34−import Test25 ()
35−
36−import CustomChildren (customTypesTest)
37−
38−main :: IO ()
39−main = do
40− res <- runTestTT tests
41− case errors res + failures res of
42− 0 -> exitSuccess
43− _ -> exitFailure
44−
45−data Record = MkRecord
46− { fieldA :: Int
47− , fieldB :: Bool
48− } deriving Generic
49−
50−data Record2 = MkRecord2
51− { fieldA :: Int
52− } deriving Generic
53−
54−data Record3 a = MkRecord3
55− { fieldA :: a
56− , fieldB :: Bool
57− } deriving (Generic, Show)
58−
59−data Record4 a = MkRecord4
60− { fieldA :: a
61− , fieldB :: a
62− } deriving (Generic1)
63−
64−data Record5 = MkRecord5
65− { fieldA :: Int
66− , fieldB :: Int
67− , fieldC :: String
68− , fieldD :: Int
69− , fieldE :: Char
70− , fieldF :: Int
71− } deriving Generic
72−
73−typeChangingManual :: Lens (Record3 a) (Record3 b) a b
74−typeChangingManual f (MkRecord3 a b) = (\a' -> MkRecord3 a' b) <$> f a
75−
76−typeChangingManualCompose :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b
77−typeChangingManualCompose = typeChangingManual . typeChangingManual
78−
79−newtype L s a = L (Lens' s a)
80−
81−intTraversalManual :: Traversal' Record5 Int
82−intTraversalManual f (MkRecord5 a b c d e f') =
83− pure (\a1 a2 a3 a4 -> MkRecord5 a1 a2 c a3 e a4) <*> f a <*> f b <*> f d <*> f f'
84−
85−intTraversalDerived :: Traversal' Record5 Int
86−intTraversalDerived = types
87−
88−fieldALensManual :: Lens' Record Int
89−fieldALensManual f (MkRecord a b) = (\a' -> MkRecord a' b) <$> f a
90−
91−subtypeLensManual :: Lens' Record Record2
92−subtypeLensManual f record
93− = fmap (\ds -> case record of
94− MkRecord _ b -> MkRecord (case ds of {MkRecord2 g1 -> g1}) b
95− ) (f (MkRecord2 (case record of {MkRecord a _ -> a})))
96−
97−data Sum1 = A Char | B Int | C () | D () deriving (Generic, Show)
98−data Sum2 = A2 Char | B2 Int deriving (Generic, Show)
99−
100−data Sum3 a b c
101− = A3 a a
102− | B3 String b a a b
103− | C3 c a Int
104− deriving Generic
105−
106−sum3Param0Derived :: Traversal (Sum3 a b xxx) (Sum3 a b yyy) xxx yyy
107−sum3Param0Derived = param @0
108−
109−sum3Param0Manual :: Traversal (Sum3 a b xxx) (Sum3 a b yyy) xxx yyy
110−sum3Param0Manual _ (A3 a1 a2) = pure (A3 a1 a2)
111−sum3Param0Manual _ (B3 s b1 a1 a2 b2) = pure (B3 s b1 a1 a2 b2)
112−sum3Param0Manual f (C3 c a i) = pure (\c' -> C3 c' a i) <*> f c
113−
114−sum3Param1Derived :: Traversal (Sum3 a xxx c) (Sum3 a yyy c) xxx yyy
115−sum3Param1Derived = param @1
116−
117−sum3Param1Manual :: Traversal (Sum3 a xxx c) (Sum3 a yyy c) xxx yyy
118−sum3Param1Manual _ (A3 a1 a2) = pure (A3 a1 a2)
119−sum3Param1Manual f (B3 s b1 a1 a2 b2) = pure (\b1' b2' -> B3 s b1' a1 a2 b2') <*> f b1 <*> f b2
120−sum3Param1Manual _ (C3 c a i) = pure (C3 c a i)
121−
122−sum3Param2Derived :: Traversal (Sum3 xxx b c) (Sum3 yyy b c) xxx yyy
123−sum3Param2Derived = param @2
124−
125−sum3Param2Manual :: Traversal (Sum3 xxx b c) (Sum3 yyy b c) xxx yyy
126−sum3Param2Manual f (A3 a1 a2) = pure (\a1' a2' -> A3 a1' a2') <*> f a1 <*> f a2
127−sum3Param2Manual f (B3 s b1 a1 a2 b2) = pure (\a1' a2' -> B3 s b1 a1' a2' b2) <*> f a1 <*> f a2
128−sum3Param2Manual f (C3 c a i) = pure (\a' -> C3 c a' i) <*> f a
129−
130−sum1PrismManual :: Prism Sum1 Sum1 Int Int
131−sum1PrismManual eta = prism g f eta
132− where
133− f s1 = case s1 of
134− B i -> Right i
135− s -> Left s
136− g = B
137−
138−sum1PrismManualChar :: Prism Sum1 Sum1 Char Char
139−sum1PrismManualChar eta = prism g f eta
140− where
141− f s1 = case s1 of
142− A i -> Right i
143− B _ -> Left s1
144− C _ -> Left s1
145− D _ -> Left s1
146− g = A
147−
148−sum2PrismManual :: Prism Sum2 Sum2 Int Int
149−sum2PrismManual eta = prism g f eta
150− where
151− f s1 = case s1 of
152− B2 i -> Right i
153− s -> Left s
154− g = B2
155−
156−
157−sum2PrismManualChar :: Prism Sum2 Sum2 Char Char
158−sum2PrismManualChar eta = prism g f eta
159− where
160− f s1 = case s1 of
161− A2 i -> Right i
162− s -> Left s
163− g = A2
164−
165−-- Note we don't have a catch-all case because of #14684
166−subtypePrismManual :: Prism Sum1 Sum1 Sum2 Sum2
167−subtypePrismManual eta = prism g f eta
168− where
169− f s1 = case s1 of
170− A c -> Right (A2 c)
171− B i -> Right (B2 i)
172− C _ -> Left s1
173− D _ -> Left s1
174− g (A2 c) = A c
175− g (B2 i) = B i
176−
177−
178−--------------------------------------------------------------------------------
179−-- * Tests
180−-- The inspection-testing plugin checks that the following equalities hold, by
181−-- checking that the LHSs and the RHSs are CSEd. This also means that the
182−-- runtime characteristics of the derived lenses is the same as the manually
183−-- written ones above.
184−
185−fieldALensName :: Lens' Record Int
186−fieldALensName = field @"fieldA"
187−
188−fieldALensName_ :: Lens' Record Int
189−fieldALensName_ = field_ @"fieldA"
190−
191−fieldALensType :: Lens' Record Int
192−fieldALensType = typed @Int
193−
194−fieldALensPos :: Lens' Record Int
195−fieldALensPos = position @1
196−
197−fieldALensPos_ :: Lens' Record Int
198−fieldALensPos_ = position_ @1
199−
200−subtypeLensGeneric :: Lens' Record Record2
201−subtypeLensGeneric = super
202−
203−typeChangingGeneric :: Lens (Record3 a) (Record3 b) a b
204−typeChangingGeneric = #fieldA
205−
206−typeChangingGenericPos :: Lens (Record3 a) (Record3 b) a b
207−typeChangingGenericPos = position @1
208−
209−typeChangingGenericCompose :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b
210−typeChangingGenericCompose = #fieldA . #fieldA
211−
212−typeChangingGenericCompose_ :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b
213−typeChangingGenericCompose_ = field_ @"fieldA" . field_ @"fieldA"
214−
215−sum1PrismB :: Prism Sum1 Sum1 Int Int
216−sum1PrismB = _Ctor @"B"
217−
218−subtypePrismGeneric :: Prism Sum1 Sum1 Sum2 Sum2
219−subtypePrismGeneric = _Sub
220−
221−sum1TypePrism :: Prism Sum1 Sum1 Int Int
222−sum1TypePrism = _Typed @Int
223−
224−sum1TypePrismChar :: Prism Sum1 Sum1 Char Char
225−sum1TypePrismChar = _Typed @Char
226−
227−sum2TypePrism :: Prism Sum2 Sum2 Int Int
228−sum2TypePrism = _Typed @Int
229−
230−sum2TypePrismChar :: Prism Sum2 Sum2 Char Char
231−sum2TypePrismChar = _Typed @Char
232−
233−data SumOfProducts =
234− RecA { _foo :: Int, valA :: String }
235− | RecB { _foo :: Int, valB :: Bool }
236− | RecC { _foo :: Int }
237− deriving (Show, Eq, Generic)
238−
239−tests :: Test
240−tests = TestList $ map mkHUnitTest
241− [ $(inspectTest $ 'fieldALensManual === 'fieldALensName)
242− , $(inspectTest $ 'fieldALensManual === 'fieldALensName_)
243− , $(inspectTest $ 'fieldALensManual === 'fieldALensType)
244− , $(inspectTest $ 'fieldALensManual === 'fieldALensPos)
245− , $(inspectTest $ 'fieldALensManual === 'fieldALensPos_)
246− , $(inspectTest $ 'subtypeLensManual === 'subtypeLensGeneric)
247− , $(inspectTest $ 'typeChangingManual === 'typeChangingGeneric)
248− , $(inspectTest $ 'typeChangingManual === 'typeChangingGenericPos)
249− , $(inspectTest $ 'typeChangingManualCompose === 'typeChangingGenericCompose)
250− , $(inspectTest $ 'typeChangingManualCompose === 'typeChangingGenericCompose_)
251− , $(inspectTest $ 'sum1PrismManual === 'sum1PrismB)
252− , $(inspectTest $ 'subtypePrismManual === 'subtypePrismGeneric)
253− , $(inspectTest $ 'sum2PrismManualChar === 'sum2TypePrismChar)
254− , $(inspectTest $ 'sum2PrismManual === 'sum2TypePrism)
255− , $(inspectTest $ 'sum1PrismManualChar === 'sum1TypePrismChar)
256− , $(inspectTest $ 'sum2PrismManualChar === 'sum2TypePrismChar)
257− , $(inspectTest $ 'sum1PrismManual === 'sum1TypePrism)
258− --, $(inspectTest $ 'intTraversalManual === 'intTraversalDerived)
259− --, $(inspectTest $ 'sum3Param0Manual === 'sum3Param0Derived)
260− -- TODO [1.0.0.0]: these tests pass with the new implementation
261−-- , $(inspectTest $ 'sum3Param1Manual === 'sum3Param1Derived)
262−-- , $(inspectTest $ 'sum3Param2Manual === 'sum3Param2Derived)
263− ] ++
264− -- Tests for overloaded labels
265− [ (valLabel ^. #_foo ) ~=? 3
266− , (valLabel & #_foo +~ 10 ) ~=? RecB 13 True
267−#if __GLASGOW_HASKELL__ >= 802
268− , (valLabel ^? #_RecB ) ~=? Just (3, True)
269− , (valLabel ^? #_RecB . _1 ) ~=? Just 3
270− , (valLabel ^? #_RecC ) ~=? Nothing
271−#endif
272− , customTypesTest
273− ]
274− where valLabel = RecB 3 True
275−
276−-- TODO: add test for traversals over multiple types
test/Test24.hsdeleted−47
@@ -1,47 +0,0 @@
1−{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications #-}
2−
3−module Test24 where
4−
5−-- Test case from #24, comments preserved
6−import Control.Lens
7−import Data.Generics.Product.Fields
8−import Data.Generics.Product.Positions
9−import GHC.Generics
10−
11−data Foo a b = Foo { x1 :: a, x2 :: b } deriving (Generic, Show)
12−
13−data Bar a b = Bar { x3 :: Foo a b, x4 :: Int } deriving (Generic, Show)
14−
15−tup :: ((Int, Char), Int)
16−tup = ((1, 'a'), 2)
17−tup2, tup3, tup4 :: ((Char, Char), Int)
18−tup2 = tup & _1 . _1 %~ toEnum -- Works.
19−tup3 = tup & x %~ toEnum -- Works also with type annotation.
20− where x :: Lens ((Int, Char), Int) ((Char, Char), Int) Int Char
21− x = _1 . _1
22−-- Works.
23−tup4 = tup & position @1 . position @1 %~ toEnum
24−
25−foo :: Foo Int Char
26−foo = Foo 1 'a'
27−foo2, foo3 :: Foo Char Char
28−foo2 = foo & field @"x1" %~ toEnum -- Works when there's just one 'field'.
29−foo3 = foo & position @1 %~ toEnum -- Works when there's just one 'position'.
30−
31−bar :: Bar Int Char
32−bar = Bar (Foo 1 'a') 2
33−bar2, bar3, bar4 :: Bar Char Char
34−-- Doesn't work, error at first 'field' (Couldn't match type ‘Int’ with ‘Char’ arising from a use of ‘field’).
35−bar2 = bar & field @"x3" . field @"x1" %~ toEnum
36−-- Type annotation doesn't help.
37−bar3 = bar & l %~ toEnum
38− where l :: Lens (Bar Int Char) (Bar Char Char) Int Char
39− l = field @"x3" . field @"x1"
40−-- Doesn't work, error at first 'position' (Couldn't match type ‘Int’ with ‘Char’ arising from a use of ‘position’).
41−bar4 = bar & position @1 . position @1 %~ toEnum
42−-- Works if we stick to simple Lens' (modify to the same type).
43−bar5 :: Bar Int Char
44−bar5 = bar & field @"x3" . field @"x1" %~ (+1)
45−
46−main :: IO ()
47−main = print bar5
test/Test25.hsdeleted−33
@@ -1,33 +0,0 @@
1−{-# LANGUAGE DuplicateRecordFields #-}
2−{-# LANGUAGE TypeApplications #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE DeriveGeneric #-}
5−{-# OPTIONS_GHC -Wall #-}
6−
7−module Test25 where
8−
9−import Control.Lens
10−import Data.Generics.Product
11−import GHC.Generics
12−
13−data Record1 = Record1
14− { field1 :: Int
15− , field2 :: Double
16− } deriving (Generic)
17−
18−class Default a where
19− def :: a
20−
21−instance Default Record1 where
22− def = Record1 0 0.0
23−
24−f :: Record1 -> Int
25−f r = r ^. field @"field1"
26−
27−main :: IO ()
28−main = do
29− print $ f def
30− print $ f ( field @"field1" .~ 1 $ (def :: Record1))
31− print $ f ( field @"field1" .~ 2 $ Record1 0 0.0)
32− print $ f ( field @"field1" .~ (1 :: Int) $ def)
33− print $ f ( position @1 .~ (1 :: Int) $ def)
test/Test40.hsdeleted−22
@@ -1,22 +0,0 @@
1−{-# LANGUAGE TypeFamilies #-}
2−{-# LANGUAGE TypeApplications #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE DeriveGeneric #-}
5−{-# OPTIONS_GHC -Wall #-}
6−
7−module Test40 where
8−
9−import Data.Generics.Product
10−import GHC.Generics
11−
12−class MyClass a where
13− data AssocData a
14−
15−instance MyClass Int where
16− data AssocData Int = SomeData
17− { val :: Int
18− } deriving (Generic)
19−
20−main :: IO ()
21−main
22− = print $ getField @"val" (SomeData 3)
test/Test62.hsdeleted−20
@@ -1,20 +0,0 @@
1−{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications #-}
2−module Test62 (example, example_) where
3−import Data.Generics.Product (field, field_, position, position_)
4−import Data.Generics.Internal.VL.Lens (set)
5−import GHC.Generics (Generic)
6−
7−data Foo a = Foo { bar :: Bar a } deriving Generic
8−data Bar a = Bar { x :: a, y :: a } deriving Generic
9−
10−example :: Foo ()
11−example =
12− set (field @"bar" . position @1) ()
13− . set (position @1 . field @"y") ()
14− $ Foo{ bar = Bar{ x = (), y = () } }
15−
16−example_ :: Foo ()
17−example_ =
18− set (field_ @"bar" . position_ @1) ()
19− . set (position_ @1 . field_ @"y") ()
20− $ Foo{ bar = Bar{ x = (), y = () } }
test/Test63.hsdeleted−12
@@ -1,12 +0,0 @@
1−{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications #-}
2−module Test63 (example) where
3−import Data.Generics.Product (types)
4−import Data.Generics.Internal.VL.Lens (over)
5−import Data.Word (Word32)
6−import GHC.Generics (Generic)
7−
8−data Record = Record {field1 :: Word32, field2 :: Int}
9− deriving (Generic, Show)
10−
11−example :: Record
12−example = over (types @Int) (+1) (Record 0 0)
test/Test71.hsdeleted−17
@@ -1,17 +0,0 @@
1−{-# LANGUAGE FlexibleContexts, DeriveGeneric, TypeApplications #-}
2−
3−module Test71 where
4−
5−import GHC.Generics
6−import Control.Lens
7−import Data.Generics.Product
8−
9−data Foobar = Foobar Int Char String
10− deriving Generic
11−
12−foo :: HasType Foobar ctx => ctx -> Char
13−foo ctx = case view (typed @Foobar) ctx of
14− Foobar _ c _ -> c
15−
16−bar :: Char
17−bar = foo (Foobar 3 'a' "Hello")
test/Util.hsdeleted−11
@@ -1,11 +0,0 @@
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−
test/doctest.hsdeleted−8
@@ -1,8 +0,0 @@
1−import Test.DocTest
2−main
3− = doctest
4− [ "-isrc"
5− , "src/Data/Generics/Product.hs"
6− , "src/Data/Generics/Sum.hs"
7− , "src/Data/Generics/Labels.hs"
8− ]
test/syb/Tree.hsdeleted−76
@@ -1,76 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4−{-# LANGUAGE TypeApplications #-}
5−
6−{-
7−Example adapted from SYB
8−========================
9−-}
10−
11−module Main (main) where
12−
13−import Control.Lens
14−import Control.Monad (void)
15−import Data.Generics.Product
16−import GHC.Generics
17−import Test.HUnit
18−
19−main :: IO ()
20−main = void $ runTestTT tests
21−
22−-- A parameterised datatype for binary trees with data at the leafs
23−data Tree a w = Leaf a
24− | Fork (Tree a w) (Tree a w)
25− | WithWeight (Tree a w) w
26− deriving (Show, Generic, Eq)
27−
28−-- A typical tree
29−mytree :: Tree Int Int
30−mytree = Fork (WithWeight (Leaf 42) 1)
31− (WithWeight (Fork (Leaf 88) (Leaf 37)) 2)
32−
33−mytreeShown :: Tree String Int
34−mytreeShown = Fork (WithWeight (Leaf "42") 1)
35− (WithWeight (Fork (Leaf "88") (Leaf "37")) 2)
36−
37−-- A polymorphic-recursive structure
38−data Poly a b
39− = PNil
40− | PCons a (Poly b a)
41− deriving (Show, Generic)
42−
43−poly :: Poly Int String
44−poly = PCons 10 (PCons "hello" (PCons 20 (PCons "world" PNil)))
45−
46−-- Print everything like an Int in mytree
47−-- In fact, we show two attempts:
48−-- 1. print really just everything like an Int
49−-- 2. print everything wrapped with Leaf
50−-- So (1.) confuses leafs and weights whereas (2.) does not.
51−tests :: Test
52−tests = TestList
53− [ toListOf (types @Int) mytree ~=? [42,1,88,37,2]
54− , toListOf (param @1) mytree ~=? [42,88,37]
55−
56− -- Things not (easily) doable in SYB:
57− -- change type of Tree by mapping a function over the second (from the right) param
58− , (mytree & param @1 %~ show) ~=? mytreeShown
59− -- collect values in poly corresponding to the first param
60− , toListOf (param @0) poly ~=? ["hello", "world"]
61− -- collect all Ints inside poly
62− , toListOf (types @Int) poly ~=? [10, 20]
63− -- map length over the Strings, then collect all Ints
64− , toListOf (types @Int) (poly & param @0 %~ length) ~=? [10, 5, 20, 5]
65− -- map length over the Strings, then collect all the resulting Ints
66− , toListOf (param @0) (poly & param @0 %~ length) ~=? [5,5]
67− ]
68−
69−-- original code from SYB:
70−--tests = show ( listify (\(_::Int) -> True) mytree
71−-- , everything (++) ([] `mkQ` fromLeaf) mytree
72−-- ) ~=? output
73−-- where
74−-- fromLeaf :: Tree Int Int -> [Int]
75−-- fromLeaf (Leaf x) = [x]
76−-- fromLeaf _ = []