on 882b766 help sign in
68 files changed+1091−3522
since splitsnapshots
unifiedsplit
.github/FUNDING.yml−12 .gitignore−4 .gitmodules+4 .travis.yml+69−132 ChangeLog.md−35 LICENSE+1−1 README.md+78−238 cabal.haskell-ci−5 cabal.project−1 examples/Biscuits.hs−150 examples/doctest.hs−7 generic-lens.cabal+23−63 src/Data/GenericLens/Internal.hs−64 src/Data/GenericLens/Internal.hs~ src/Data/Generics/Internal/Errors.hs−59 src/Data/Generics/Internal/Families.hs+2−1 src/Data/Generics/Internal/Families/Changing.hs+16−49 src/Data/Generics/Internal/Families/Collect.hs+2−2 src/Data/Generics/Internal/Families/Has.hs+46−72 src/Data/Generics/Internal/GenericN.hs−75 src/Data/Generics/Internal/Profunctor/Iso.hs+7−19 src/Data/Generics/Internal/Profunctor/Lens.hs+39−35 src/Data/Generics/Internal/Profunctor/Prism.hs+13−16 src/Data/Generics/Internal/VL/Iso.hs+4−37 src/Data/Generics/Internal/VL/Lens.hs+7−26 src/Data/Generics/Internal/VL/Prism.hs+4−16 src/Data/Generics/Internal/VL/Traversal.hs+10−28 src/Data/Generics/Labels.hs+17−123 src/Data/Generics/Product.hs+3−8 src/Data/Generics/Product/Any.hs+3−3 src/Data/Generics/Product/Constraints.hs−57 src/Data/Generics/Product/Fields.hs+28−93 src/Data/Generics/Product/HList.hs−46 src/Data/Generics/Product/Internal/Constraints.hs−136 src/Data/Generics/Product/Internal/GLens.hs−81 src/Data/Generics/Product/Internal/HList.hs−329 src/Data/Generics/Product/Internal/Keyed.hs+54 src/Data/Generics/Product/Internal/List.hs+345 src/Data/Generics/Product/Internal/Positions.hs+24−46 src/Data/Generics/Product/Internal/Subtype.hs+10−15 src/Data/Generics/Product/Internal/Types.hs+56 src/Data/Generics/Product/List.hs+77 src/Data/Generics/Product/Param.hs−121 src/Data/Generics/Product/Positions.hs+27−122 src/Data/Generics/Product/Subtype.hs+5−45 src/Data/Generics/Product/Typed.hs+6−33 src/Data/Generics/Product/Types.hs+13−332 src/Data/Generics/Sum.hs+1−1 src/Data/Generics/Sum/Any.hs+3−3 src/Data/Generics/Sum/Constructors.hs+18−88 src/Data/Generics/Sum/Internal/Constructors.hs+13−11 src/Data/Generics/Sum/Internal/Subtype.hs+15−71 src/Data/Generics/Sum/Internal/Typed.hs+8−20 src/Data/Generics/Sum/Subtype.hs+10−50 src/Data/Generics/Sum/Typed.hs+7−43 src/Data/Generics/Wrapped.hs−104 stack.yaml+4−1 test/Test24.hs → test/24.hs+1−1 test/Test25.hs → test/25.hs+1−1 test/Bifunctor.hs−47 test/CustomChildren.hs−63 test/Spec.hs+17−133 test/Test40.hs−22 test/Test62.hs−20 test/Test63.hs−12 test/Test71.hs−17 test/doctest.hs−1 test/syb/Tree.hs−76
.github/FUNDING.ymldeleted−12
@@ -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−4
@@ -6,7 +6,3 @@ cabal.sandbox.config
66.ghc*
77*.hi
88*.o
9−core-html
10−*~
11−*.org
12−cabal.project.local
.gitmodulesnew file+4
@@ -0,0 +1,4 @@
1+[submodule "inspection-testing"]
2+ path = inspection-testing
3+ url = https://github.com/nomeata/inspection-testing.git
4+ branch = master
.travis.yml+69−132
@@ -1,155 +1,92 @@
11# This Travis job script has been generated by a script via
22#
3−# haskell-ci '--config=cabal.haskell-ci' 'cabal.project'
3+# make_travis_yml_2.hs 'generic-lens.cabal'
44#
5−# For more information, see https://github.com/haskell-CI/haskell-ci
6−#
7−# version: 0.5.20190908
5+# For more information, see https://github.com/hvr/multi-ghc-travis
86#
97language: c
10−dist: xenial
8+sudo: false
9+
1110git:
12− # whether to recursively clone submodules
13− submodules: false
11+ submodules: true # whether to recursively clone submodules
12+
1413cache:
1514 directories:
1615 - $HOME/.cabal/packages
1716 - $HOME/.cabal/store
17+
1818before_cache:
19− - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log
19+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
2020 # 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
21+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*
22+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json
23+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache
24+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar
25+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx
26+
2727matrix:
2828 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"]}}
29+ - compiler: "ghc-8.0.2"
30+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
31+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.2], sources: [hvr-ghc]}}
32+ - compiler: "ghc-8.2.1"
33+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
34+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.1], sources: [hvr-ghc]}}
35+ - compiler: "ghc-8.2.2"
36+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
37+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.2], sources: [hvr-ghc]}}
38+
4139before_install:
42− - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')
43− - WITHCOMPILER="-w $HC"
44− - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//')
45− - HCPKG="$HC-pkg"
40+ - HC=${CC}
41+ - HCPKG=${HC/ghc/ghc-pkg}
4642 - unset CC
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
43+ - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH
44+
7345install:
74− - ${CABAL} --version
46+ - cabal --version
7547 - 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:
48+ - BENCH=${BENCH---enable-benchmarks}
49+ - TEST=${TEST---enable-tests}
50+ - HADDOCK=${HADDOCK-true}
51+ - INSTALLED=${INSTALLED-true}
52+ - travis_retry cabal update -v
53+ - sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
54+ - rm -fv cabal.project.local
55+ - "echo 'packages: .' > cabal.project"
56+ - if [ -f "./configure.ac" ]; then
57+ (cd "."; autoreconf -i);
58+ fi
59+ - rm -f cabal.project.freeze
60+ - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all
61+ - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all
62+ - rm -rf "."/.ghc.environment.* "."/dist
12063 - 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...
64+
65+# Here starts the actual work to be performed for the package under test;
66+# any command which exits with a non-zero exit code causes the build to fail.
67+script:
68+ # test that source-distributions can be generated
69+ - (cd "."; cabal sdist)
70+ - mv "."/dist/generic-lens-*.tar.gz ${DISTDIR}/
71+ - mv "."/inspection-testing ${DISTDIR}/inspection-testing
72+ - cd ${DISTDIR}
73+ - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;
74+ - "printf 'packages: generic-lens-*/*.cabal\noptional-packages: inspection-testing/*.cabal\n' > cabal.project"
13975 # 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...
76+ - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all
77+
78+ # Build with installed constraints for packages in global-db
79+ - if $INSTALLED; then
80+ echo cabal new-build -w ${HC} --disable-tests --disable-benchmarks $(${HCPKG} list --global --simple-output --names-only | sed 's/\([a-zA-Z0-9-]\{1,\}\) */--constraint="\1 installed" /g') all | sh;
81+ else echo "Not building with installed constraints"; fi
82+
14283 # 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
84+ - cabal new-build -w ${HC} ${TEST} ${BENCH} all
85+ - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} all; fi
86+
87+ # haddock
88+ - rm -rf ./dist-newstyle
89+ - if $HADDOCK; then cabal new-haddock -w ${HC} --disable-tests --disable-benchmarks all; else echo "Skipping haddock generation";fi
15390
154−# REGENDATA ["--config=cabal.haskell-ci","cabal.project"]
91+# REGENDATA ["generic-lens.cabal"]
15592# EOF
ChangeLog.md−35
@@ -1,38 +1,3 @@
1−## 1.2.0.1
2−- Give HasAny/AsAny the same VTA behavior on 8.6 and 8.8 (Ryan Scott)
3−
4−## 1.2.0.0
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−
9−### Breaking API changes
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−
361## 0.5.1.0
372- Infer input type from result type (#25)
383- Allow changing of multiple type parameters (#24)
LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2019, Csongor Kiss
1+Copyright (c) 2017, Csongor Kiss
22
33All rights reserved.
44
README.md+78−238
@@ -3,69 +3,26 @@
33[![Build Status](https://travis-ci.org/kcsongor/generic-lens.svg?branch=master)](https://travis-ci.org/kcsongor/generic-lens)
44[![Hackage](https://img.shields.io/hackage/v/generic-lens.svg)](https://hackage.haskell.org/package/generic-lens)
55
6−Generically derive traversals, lenses and prisms.
6+Generically derive lenses and prisms for data types.
77
88Available on [Hackage](https://hackage.haskell.org/package/generic-lens)
99
10−This library uses `GHC.Generics` to derive efficient optics (traversals, lenses
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 #-}
10+This package uses the GHC 8 `Generic` representation to derive various operations
11+on data structures with lens interfaces, including structural subtype
12+relationships between records and positional indexing into arbitrary product
13+types.
5514
56−```
15+This is made possible by GHC 8's new Generics API, which provides metadata
16+at the type-level (previously only value-level metadata was available).
5717
58−# Taxonomy of optics
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.
18+Examples can be found in the `examples` folder. This library makes heavy use of
19+[Visible Type Applications](https://ghc.haskell.org/trac/ghc/wiki/TypeApplication).
6220
6321## Lenses
6422
65−A lens identifies exactly one part of a product type, and allows querying and
66−updating it.
23+### Record fields
6724
68−### By name
25+Record fields can be accessed by their label:
6926
7027```haskell
7128data Person = Person { name :: String, age :: Int } deriving (Generic, Show)
@@ -74,83 +31,42 @@ sally :: Person
7431sally = Person "Sally" 25
7532```
7633
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.
9234```haskell
9335>>> getField @"age" sally
943625
9537
9638>>> setField @"age" 26 sally
9739Person {name = "Sally", age = 26}
98−```
9940
100−When a non-existent field is requested, the library generates a helpful type error:
101−```haskell
41+>>> sally ^. field @"name"
42+"Sally"
43+
44+>>> sally & field @"name" .~ "Tamas"
45+Person {name = "Tamas", age = 25}
46+
10247>>> sally ^. field @"pet"
10348error:
104− • The type Person does not contain a field named 'pet'
49+ • The type Person does not contain a field named "pet"
10550```
10651
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.
52+If the accessed field is a type parameter that appears uniquely in the type,
53+then its type can be changed:
13054
13155```haskell
132−data Foo f a = Foo
133− { foo :: f a
134− } deriving (Generic, Show)
135−
136−foo1 :: Foo Maybe Int
137−foo1 = Foo (Just 10)
56+data T a b c d = T
57+ { paramA :: a
58+ , paramB :: b
59+ , paramC :: c
60+ , paramD :: d
61+ }
62+ deriving (Generic, Show)
13863
139−-- |
140−-- >>> foo2
141−-- Foo {foo = ["10"]}
142−foo2 :: Foo [] String
143−foo2 = foo1 & field @"foo" %~ (maybeToList . fmap show)
64+>>> t = T "a" (10 :: Int) 'c' False
65+>>> t & field @"paramA" .~ 'a' & field @"paramB" .~ False
66+T {paramA = 'a', paramB = False, paramC = 'c', paramD = False}
14467```
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−
149−With `DuplicateRecordFields`, multiple data types can share the same field
150−name, and the `field` lens works in this case too. No more field name
151−prefixing!
15268
153−### By position
69+### Positional fields
15470
15571Fields can be accessed by their position in the data structure (index starting at 1):
15672
@@ -163,6 +79,12 @@ polygon = Polygon (Point 1 5 3) (Point 2 4 2) (Point 5 7 (-2))
16379```
16480
16581```haskell
82+>>> getPosition @2 polygon
83+Point 2 4 2
84+
85+>>> setPosition @1 (Point 26 5 3) polygon
86+Polygon (Point 26 5 3) (Point 2 4 2) (Point 5 7 (-2))
87+
16688>>> polygon ^. position @1 . position @2
167895
16890
@@ -174,34 +96,49 @@ error:
17496 • The type Polygon does not contain a field at position 10
17597```
17698
177−Since tuples are an instance of `Generic`, the positional lens readily works:
99+Since tuples are an instance of `Generic`, they also have positional lenses:
178100
179101```haskell
180102>>> (("hello", True), 5) ^. position @1 . position @2
181103True
182−>>> (("hello", True, "or"), 5, "even", "longer") ^. position @1 . position @2
183−True
184104```
185105
186−### By type
106+### Typed fields
187107
188108Fields can be accessed by their type in the data structure, assuming that this
189109type is unique:
190110
191111```haskell
192−>>> sally ^. typed @String
112+data Person = Person { name :: String, age :: Int } deriving (Generic, Show)
113+data Point = Point Int Int Int deriving (Generic, Show)
114+
115+sally :: Person
116+sally = Person "Sally" 25
117+
118+point :: Point
119+point = Point 1 2 3
120+```
121+
122+```haskell
123+>>> getTyped @String sally
193124"Sally"
194125
195126>>> setTyped @Int sally 26
196127Person {name = "Sally", age = 26}
128+
129+>>> point ^. typed @Int
130+error:
131+ • The type Point contains multiple values of type Int; the choice of value is thus ambiguous
132+
133+>>> point & typed @String .~ "Point"
134+error:
135+ • The type Point does not contain a value of type [Char]
197136```
198137
199−### By structure
138+### Structural subtyping
200139
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
204−are a superset of those of the other.
140+A record is a (structural) `subtype' of another, if its fields are a superset of
141+those of the other.
205142
206143```haskell
207144data Human = Human
@@ -220,11 +157,17 @@ human = Human {name = "Tunyasz", age = 50, address = "London"}
220157```
221158
222159```haskell
223−>>> human ^. super @Animal
224−Animal {name = "Tunyasz", age = 50}
225160
226161>>> upcast human :: Animal
227162Animal {name = "Tunyasz", age = 50}
163+
164+-- 'smash' plug the smaller structure into the larger one
165+>>> smash (Animal "dog" 10) human
166+Human {name = "dog", age = 10, address = "London"}
167+
168+-- 'super' is a lens that focuses on a subrecord of a larger record:
169+>>> human ^. super @Animal
170+Animal {name = "Tunyasz", age = 50}
228171```
229172
230173We can apply a function that operates on a supertype to the larger (subtype)
@@ -238,96 +181,9 @@ growUp (Animal name age) = Animal name (age + 50)
238181Human {name = "Tunyasz", age = 60, address = "London"}
239182```
240183
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−
324184## Prisms
325185
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
186+### Named constructors
331187
332188Constructor components can be accessed using the constructor's name:
333189
@@ -349,20 +205,19 @@ Just (MkDog {name = "Shep", age = 4})
349205
350206>>> shep ^? _Ctor @"Cat"
351207Nothing
352−```
353−
354−Constructors with multiple fields can be focused as a tuple
355208
356−```
357209>>> mog ^? _Ctor @"Cat"
358210Just ("Mog",5)
359211
360212>>> _Ctor @"Cat" # ("Garfield", 6) :: Animal
361213Cat "Garfield" 6
362214
215+>>> donald ^? _Ctor @"Giraffe"
216+error:
217+ • The type Animal does not contain a constructor named "Giraffe"
363218```
364219
365−### By type
220+### Typed constructors
366221
367222Constructor components can be accessed using the component's type, assuming
368223that this type is unique:
@@ -372,10 +227,10 @@ type Name = String
372227type Age = Int
373228
374229data Dog = MkDog { name :: Name, age :: Age } deriving (Generic, Show)
375−data Animal = Dog Dog | Cat Name Age | Duck Age deriving (Generic, Show)
230+data Animal = Dog Dog | Cat (Name, Age) | Duck Age deriving (Generic, Show)
376231
377232shep = Dog (MkDog "Shep" 4)
378−mog = Cat "Mog" 5
233+mog = Cat ("Mog", 5)
379234donald = Duck 4
380235```
381236
@@ -389,9 +244,6 @@ Just (MkDog {name = "Shep", age = 4})
389244>>> donald ^? _Typed @Age
390245Just 4
391246
392−>>> mog ^? _Typed @(Name, Age)
393−("Mog", 5)
394−
395247>>> donald ^? _Typed @Float
396248error:
397249 • The type Animal does not contain a constructor whose field is of type Float
@@ -400,19 +252,7 @@ error:
400252Duck 6
401253```
402254
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
255+## Contributors
415256
416−+ [Matthew Pickering](https://github.com/mpickering)
417257+ [Toby Shaw](https://github.com/TobyShaw)
418258+ [Will Jones](https://github.com/lunaris)
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.project−1
@@ -1,2 +1 @@
11packages: 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/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+23−63
@@ -1,7 +1,7 @@
11name: 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.
2+version: 0.5.1.0
3+synopsis: Generic data-structure operations exposed as lenses.
4+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.
55
66homepage: https://github.com/kcsongor/generic-lens
77license: BSD3
@@ -11,7 +11,7 @@ maintainer: kiss.csongor.kiss@gmail.com
1111category: Generics, Records, Lens
1212build-type: Simple
1313cabal-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
14+Tested-With: GHC == 8.0.2, GHC == 8.2.1
1515
1616extra-source-files: ChangeLog.md
1717 , examples/StarWars.hs
@@ -23,19 +23,14 @@ flag dump-core
2323 default: False
2424
2525library
26− exposed-modules: Data.Generics.Wrapped
27− , Data.Generics.Product
26+ exposed-modules: Data.Generics.Product
2827 , Data.Generics.Product.Any
2928 , Data.Generics.Product.Fields
30− , Data.Generics.Product.Param
3129 , Data.Generics.Product.Positions
3230 , Data.Generics.Product.Subtype
3331 , Data.Generics.Product.Typed
3432 , Data.Generics.Product.Types
35− , Data.Generics.Product.Constraints
36− , Data.Generics.Product.HList
37− , Data.Generics.Labels
38− , Data.Generics.Internal.GenericN
33+ , Data.Generics.Product.List
3934
4035 , Data.Generics.Sum
4136 , Data.Generics.Sum.Any
@@ -50,13 +45,10 @@ library
5045 , Data.Generics.Internal.VL.Prism
5146 , Data.Generics.Internal.VL.Iso
5247
53− , Data.GenericLens.Internal
54−
5548 other-modules: Data.Generics.Internal.Families
5649 , Data.Generics.Internal.Families.Changing
5750 , Data.Generics.Internal.Families.Collect
5851 , Data.Generics.Internal.Families.Has
59− , Data.Generics.Internal.Errors
6052 , Data.Generics.Internal.Void
6153
6254 , Data.Generics.Sum.Internal.Constructors
@@ -64,92 +56,68 @@ library
6456 , Data.Generics.Sum.Internal.Subtype
6557
6658 , Data.Generics.Product.Internal.Positions
67− , Data.Generics.Product.Internal.GLens
6859 , Data.Generics.Product.Internal.Subtype
6960
70− , Data.Generics.Product.Internal.Constraints
71− , Data.Generics.Product.Internal.HList
61+ , Data.Generics.Product.Internal.Types
62+ , Data.Generics.Product.Internal.List
63+ , Data.Generics.Product.Internal.Keyed
7264
73− build-depends: base >= 4.9 && < 5
74− , profunctors >= 5.0 && < 6.0
75− , tagged >= 0.8 && < 1
76− , text >= 1.2 && < 1.3
65+ build-depends: base >= 4.9 && <= 5.0
66+ , profunctors >= 5.0 && <= 6.0
67+ , tagged >= 0.8 && <= 0.9
7768
7869 hs-source-dirs: src
7970 default-language: Haskell2010
8071 ghc-options: -Wall
81−-- if flag(dump-core)
82−-- build-depends: dump-core
83−-- ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
72+ if flag(dump-core)
73+ build-depends: dump-core
74+ ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
8475
8576source-repository head
8677 type: git
8778 location: https://github.com/kcsongor/generic-lens
8879
89−test-suite generic-lens-examples
90− type: exitcode-stdio-1.0
91− hs-source-dirs: examples
92− main-is: Biscuits.hs
93−
94− build-depends: base >= 4.9 && <= 5.0
95− , generic-lens
96− , lens
97− , profunctors
98− , HUnit
99−
100− default-language: Haskell2010
101−
10280test-suite generic-lens-test
10381 type: exitcode-stdio-1.0
10482 hs-source-dirs: test
10583 main-is: Spec.hs
106− other-modules: Util Test24 Test25 Test40 Test62 Test63 CustomChildren
84+ other-modules: Util
10785
10886 build-depends: base >= 4.9 && <= 5.0
10987 , generic-lens
110− , lens
11188 , profunctors
11289 , inspection-testing >= 0.2
11390 , HUnit
11491
11592 default-language: Haskell2010
116− ghc-options: -Wall
93+ ghc-options: -Wall -O2 -dsuppress-all
11794 if flag(dump-core)
11895 build-depends: dump-core
11996 ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
12097
121−test-suite generic-lens-bifunctor
98+test-suite generic-lens-test-25
12299 type: exitcode-stdio-1.0
123100 hs-source-dirs: test
124− main-is: Bifunctor.hs
101+ main-is: 25.hs
125102
126103 build-depends: base >= 4.9 && <= 5.0
127104 , generic-lens
128105 , lens
129− , HUnit
130106
131107 default-language: Haskell2010
132108 ghc-options: -Wall
133− if flag(dump-core)
134− build-depends: dump-core
135− ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
136109
137−test-suite generic-lens-syb-tree
110+test-suite generic-lens-test-24
138111 type: exitcode-stdio-1.0
139− hs-source-dirs: test/syb
140− main-is: Tree.hs
112+ hs-source-dirs: test
113+ main-is: 24.hs
141114
142115 build-depends: base >= 4.9 && <= 5.0
143116 , generic-lens
144117 , lens
145− , profunctors
146− , HUnit
147118
148119 default-language: Haskell2010
149120 ghc-options: -Wall
150− if flag(dump-core)
151− build-depends: dump-core
152− ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
153121
154122test-suite doctests
155123 default-language: Haskell2010
@@ -159,14 +127,6 @@ test-suite doctests
159127 build-depends: base >4 && <5, doctest
160128 hs-source-dirs: test
161129
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−
170130benchmark generic-lens-bench
171131 type: exitcode-stdio-1.0
172132 hs-source-dirs: benchmarks
@@ -176,7 +136,7 @@ benchmark generic-lens-bench
176136
177137 , base >= 4.9 && <= 5.0
178138 , QuickCheck
179− , criterion >= 1.3.0.0
139+ , criterion
180140 , deepseq
181141 , lens
182142
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.hs+2−1
@@ -3,13 +3,14 @@
33{-# LANGUAGE FlexibleInstances #-}
44{-# LANGUAGE KindSignatures #-}
55{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE TypeApplications #-}
67{-# LANGUAGE TypeFamilies #-}
78{-# LANGUAGE TypeOperators #-}
89
910-----------------------------------------------------------------------------
1011-- |
1112-- Module : Data.Generics.Internal.Families
12−-- Copyright : (C) 2019 Csongor Kiss
13+-- Copyright : (C) 2017 Csongor Kiss
1314-- License : BSD3
1415-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1516-- Stability : experimental
src/Data/Generics/Internal/Families/Changing.hs+16−49
@@ -9,17 +9,11 @@
99{-# LANGUAGE UndecidableInstances #-}
1010
1111module Data.Generics.Internal.Families.Changing
12− ( Indexed
12+ ( Proxied
1313 , Infer
14− , PTag (..)
15− , P
16− , LookupParam
17− , ArgAt
18− , ArgCount
19− , UnifyHead
2014 ) where
2115
22−import GHC.TypeLits (Nat, type (-), type (+), TypeError, ErrorMessage (..))
16+import GHC.TypeLits (TypeError, ErrorMessage (..))
2317
2418{-
2519 Note [Changing type parameters]
@@ -54,19 +48,19 @@ import GHC.TypeLits (Nat, type (-), type (+), TypeError, ErrorMessage (..))
5448-- application form. In order to distinguish between applications of P and other type constructors, we use a tag, `PTag`
5549-- to fake a type constructor.
5650data PTag = PTag
57−type family P :: Nat -> k -> PTag -> k
51+type family P :: Peano -> k -> PTag -> k
5852
59−type Indexed t = Indexed' t 0
53+type Proxied t = Proxied' t 'Z
6054
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
55+type family Proxied' (t :: k) (next :: Peano) :: k where
56+ Proxied' (t (a :: j) :: k) next = (Proxied' t ('S next)) (P next a 'PTag)
57+ Proxied' t _ = t
6458
6559data Sub where
66− Sub :: Nat -> k -> Sub
60+ Sub :: Peano -> k -> Sub
6761
6862type family Unify (a :: k) (b :: k) :: [Sub] where
69− Unify (p n _ 'PTag) a' = '[ 'Sub n a']
63+ Unify (a n _ 'PTag) a' = '[ 'Sub n a']
7064 Unify (a x) (b y) = Unify x y ++ Unify a b
7165 Unify a a = '[]
7266 Unify a b = TypeError
@@ -87,49 +81,28 @@ type family Infer (s :: *) (a' :: *) (b :: *) :: * where
8781
8882--------------------------------------------------------------------------------
8983
84+data Peano = Z | S Peano
85+
9086-- [TODO]: work this out
9187--
92−--type family ArgKind (t :: k) (pos :: Nat) :: * where
88+--type family ArgKind (t :: k) (pos :: Peano) :: * where
9389-- ArgKind (t (a :: k)) 'Z = k
9490-- ArgKind (t _) ('S pos) = ArgKind t pos
9591--
96−--type family ReplaceArg (t :: k) (pos :: Nat) (to :: ArgKind t pos) :: k where
92+--type family ReplaceArg (t :: k) (pos :: Peano) (to :: ArgKind t pos) :: k where
9793-- ReplaceArg (t a) 'Z to = t to
9894-- ReplaceArg (t a) ('S pos) to = ReplaceArg t pos to a
9995-- ReplaceArg t _ _ = t
10096
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
97+type family ReplaceArg (t :: k) (pos :: Peano) (to :: j) :: k where
98+ ReplaceArg (t a) 'Z to = t to
99+ ReplaceArg (t a) ('S pos) to = ReplaceArg t pos to a
104100 ReplaceArg t _ _ = t
105101
106102type family ReplaceArgs (t :: k) (subs :: [Sub]) :: k where
107103 ReplaceArgs t '[] = t
108104 ReplaceArgs t ('Sub n arg ': ss) = ReplaceArgs (ReplaceArg t n arg) ss
109105
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−
133106-- Note [CPP in instance constraints]
134107-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
135108--
@@ -153,9 +126,3 @@ type family ArgAt (t :: k) (n :: Nat) :: j where
153126-- However, for some reason, this violates the functional dependencies on 8.2.2.
154127-- Therefore, when using a newer version of the compiler, the original constraints
155128-- 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.hs+2−2
@@ -7,7 +7,7 @@
77-----------------------------------------------------------------------------
88-- |
99-- Module : Data.Generics.Internal.Families.Collect
10−-- Copyright : (C) 2019 Csongor Kiss
10+-- Copyright : (C) 2017 Csongor Kiss
1111-- License : BSD3
1212-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1313-- Stability : experimental
@@ -28,7 +28,7 @@ import Data.Type.Equality (type (==))
2828import GHC.Generics
2929import GHC.TypeLits (Symbol, CmpSymbol)
3030
31−import Data.Generics.Product.Internal.HList (type (++))
31+import Data.Generics.Product.Internal.List (type (++))
3232import Data.Generics.Internal.Families.Has (GTypes)
3333
3434data TypeStat
src/Data/Generics/Internal/Families/Has.hs+46−72
@@ -7,7 +7,7 @@
77-----------------------------------------------------------------------------
88-- |
99-- Module : Data.Generics.Internal.Families.Has
10−-- Copyright : (C) 2019 Csongor Kiss
10+-- Copyright : (C) 2017 Csongor Kiss
1111-- License : BSD3
1212-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1313-- Stability : experimental
@@ -17,99 +17,73 @@
1717module Data.Generics.Internal.Families.Has
1818 ( HasTotalFieldP
1919 , HasTotalTypeP
20− , HasTotalPositionP
21− , Pos
2220 , HasPartialTypeP
2321 , HasCtorP
2422 , GTypes
2523 ) where
2624
27−import Data.Type.Bool (type (||))
25+import Data.Type.Bool (type (||), type (&&))
2826import Data.Type.Equality (type (==))
2927import GHC.Generics
30−import GHC.TypeLits (Symbol, Nat)
31−import Data.Kind (Type)
28+import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
3229
33−import Data.Generics.Product.Internal.HList
30+import Data.Generics.Product.Internal.List
3431
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
32+type family HasTotalFieldP (field :: Symbol) f :: Bool where
33+ HasTotalFieldP field (S1 ('MetaSel ('Just field) _ _ _) _)
34+ = 'True
4735 HasTotalFieldP field (l :*: r)
48− = Alt (HasTotalFieldP field l) (HasTotalFieldP field r)
36+ = HasTotalFieldP field l || HasTotalFieldP field r
4937 HasTotalFieldP field (l :+: r)
50− = Both (HasTotalFieldP field l) (HasTotalFieldP field r)
38+ = HasTotalFieldP field l && HasTotalFieldP field r
5139 HasTotalFieldP field (S1 _ _)
52− = 'Nothing
40+ = 'False
5341 HasTotalFieldP field (C1 _ f)
5442 = HasTotalFieldP field f
5543 HasTotalFieldP field (D1 _ f)
5644 = HasTotalFieldP field f
57− HasTotalFieldP field (K1 _ _)
58− = 'Nothing
45+ HasTotalFieldP field (Rec0 _)
46+ = 'False
5947 HasTotalFieldP field U1
60− = 'Nothing
48+ = 'False
6149 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)
50+ = 'False
51+ HasTotalFieldP field f
52+ = TypeError
53+ ( 'ShowType f
54+ ':<>: 'Text " is not a valid GHC.Generics representation type"
55+ )
8556
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
57+type family HasTotalTypeP a f :: Bool where
58+ HasTotalTypeP t (S1 meta (Rec0 t))
59+ = 'True
60+ HasTotalTypeP t (l :*: r)
61+ = HasTotalTypeP t l || HasTotalTypeP t r
62+ HasTotalTypeP t (l :+: r)
63+ = HasTotalTypeP t l && HasTotalTypeP t r
64+ HasTotalTypeP t (S1 _ _)
65+ = 'False
66+ HasTotalTypeP t (C1 m f)
67+ = HasTotalTypeP t f
68+ HasTotalTypeP t (D1 m f)
69+ = HasTotalTypeP t f
70+ HasTotalTypeP t (Rec0 _)
71+ = 'False
72+ HasTotalTypeP t U1
73+ = 'False
74+ HasTotalTypeP t V1
75+ = 'False
76+ HasTotalTypeP t f
77+ = TypeError
78+ ( 'ShowType f
79+ ':<>: 'Text " is not a valid GHC.Generics representation type"
80+ )
10581
10682type family HasPartialTypeP a f :: Bool where
10783 HasPartialTypeP t (l :+: r)
10884 = HasPartialTypeP t l || HasPartialTypeP t r
10985 HasPartialTypeP t (C1 m f)
11086 = t == GTypes f
111− HasPartialTypeP t (M1 _ _ f)
112− = HasPartialTypeP t f
11387 HasPartialTypeP t _
11488 = 'False
11589
@@ -123,11 +97,11 @@ type family HasCtorP (ctor :: Symbol) f :: Bool where
12397 HasCtorP ctor _
12498 = 'False
12599
126−type family GTypes (rep :: Type -> Type) :: [Type] where
100+type family GTypes (rep :: * -> *) :: [((), *)] where
127101 GTypes (l :*: r)
128102 = GTypes l ++ GTypes r
129− GTypes (K1 _ a)
130− = '[ a]
103+ GTypes (Rec0 a)
104+ = '[ '( '(), a)]
131105 GTypes (M1 _ m a)
132106 = GTypes a
133107 GTypes U1 = '[]
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/Profunctor/Iso.hs+7−19
@@ -1,9 +1,9 @@
1−{-# OPTIONS_HADDOCK hide #-}
2−{-# LANGUAGE TupleSections #-}
31{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE LambdaCase #-}
43{-# LANGUAGE NoMonomorphismRestriction #-}
54{-# LANGUAGE Rank2Types #-}
65{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TupleSections #-}
77{-# LANGUAGE TypeFamilies #-}
88{-# LANGUAGE TypeFamilyDependencies #-}
99{-# LANGUAGE TypeOperators #-}
@@ -11,7 +11,7 @@
1111-----------------------------------------------------------------------------
1212-- |
1313-- Module : Data.Generics.Internal.Profunctor.Iso
14−-- Copyright : (C) 2019 Csongor Kiss
14+-- Copyright : (C) 2017 Csongor Kiss
1515-- License : BSD3
1616-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1717-- Stability : experimental
@@ -26,9 +26,6 @@ import Data.Profunctor (Profunctor(..))
2626import Data.Profunctor.Unsafe ((#.), (.#))
2727import GHC.Generics ((:*:)(..), (:+:)(..), Generic(..), M1(..), K1(..), Rep)
2828import Data.Coerce
29−import Data.Generics.Internal.GenericN (Rec (..))
30−
31−import qualified Data.Generics.Internal.VL.Iso as VL
3229
3330type Iso s t a b
3431 = forall p. (Profunctor p) => p a b -> p s t
@@ -49,17 +46,12 @@ kIso :: Iso (K1 r a p) (K1 r b p) a b
4946kIso = iso unK1 K1
5047{-# INLINE kIso #-}
5148
52−recIso :: Iso (Rec r a p) (Rec r b p) a b
53−recIso = iso (unK1 . unRec) (Rec . K1)
54−{-# INLINE recIso #-}
55−
5649sumIso :: Iso ((a :+: b) x) ((a' :+: b') x) (Either (a x) (b x)) (Either (a' x) (b' x))
5750sumIso = 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 #-}
51+ where forth (Left l) = (L1 l)
52+ forth (Right r) = (R1 r)
53+ back (L1 l) = (Left l)
54+ back (R1 r) = (Right r)
6355
6456prodIso :: Iso ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
6557prodIso = iso (\(a :*: b) -> (a, b)) (\(a, b) -> (a :*: b))
@@ -78,10 +70,6 @@ iso :: (s -> a) -> (b -> t) -> Iso s t a b
7870iso = dimap
7971{-# INLINE iso #-}
8072
81−iso2isovl :: Iso s t a b -> VL.Iso s t a b
82−iso2isovl _iso = withIso _iso VL.iso
83−{-# INLINE iso2isovl #-}
84−
8573withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
8674withIso ai k = case ai (Exchange id id) of
8775 Exchange sa bt -> k sa bt
src/Data/Generics/Internal/Profunctor/Lens.hs+39−35
@@ -1,5 +1,5 @@
1−{-# OPTIONS_HADDOCK hide #-}
21{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE LambdaCase #-}
33{-# LANGUAGE NoMonomorphismRestriction #-}
44{-# LANGUAGE Rank2Types #-}
55{-# LANGUAGE ScopedTypeVariables #-}
@@ -11,7 +11,7 @@
1111-----------------------------------------------------------------------------
1212-- |
1313-- Module : Data.Generics.Internal.Profunctor.Lens
14−-- Copyright : (C) 2019 Csongor Kiss
14+-- Copyright : (C) 2017 Csongor Kiss
1515-- License : BSD3
1616-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1717-- Stability : experimental
@@ -22,8 +22,12 @@
2222-----------------------------------------------------------------------------
2323module Data.Generics.Internal.Profunctor.Lens where
2424
25+import Control.Applicative (Const(..))
26+import Data.Monoid (First (..))
2527import Data.Profunctor (Profunctor(..), Strong(..))
2628import Data.Bifunctor
29+import Data.Profunctor.Unsafe ((#.))
30+import Data.Tagged
2731import GHC.Generics
2832import Data.Generics.Internal.Profunctor.Iso
2933
@@ -33,12 +37,10 @@ type Lens s t a b
3337type LensLike p s t a b
3438 = p a b -> p s t
3539
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
40+-- | Getting
41+(^.) :: s -> ((a -> Const a a) -> s -> Const a s) -> a
42+s ^. l = getConst (l Const s)
43+infixl 8 ^.
4244
4345-- | Setting
4446set :: ((a -> b) -> s -> t) -> (s, b) -> t
@@ -46,31 +48,38 @@ set f (s, b)
4648 = f (const b) s
4749
4850view :: 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))
51+view l = withLens l (\get _ -> get)
5552
56−withLensPrim :: Lens s t a b -> (forall c . (s -> (c,a)) -> ((c, b) -> t) -> r) -> r
57−withLensPrim l k =
53+withLens :: Lens s t a b -> ((s -> a) -> ((s, b) -> t) -> r) -> r
54+withLens l k =
5855 case l idLens of
5956 ALens _get _set -> k _get _set
6057
6158idLens :: ALens a b a b
62−idLens = ALens (fork (const ()) id) snd
63−{-# INLINE idLens #-}
59+idLens = ALens id snd
60+
61+infixr 4 .~
62+(.~) :: ((a -> b) -> s -> t) -> b -> s -> t
63+(.~) f b s = set f (s, b)
64+
65+infixl 8 ^?
66+(^?) :: s -> ((a -> Const (First a) a) -> s -> Const (First a) s) -> Maybe a
67+s ^? l = getFirst (fmof l (First #. Just) s)
68+ where fmof l' f = getConst #. l' (Const #. f)
69+
70+build :: (Tagged b b -> Tagged t t) -> b -> t
71+build p = unTagged . p . Tagged
72+
6473
6574-- | Lens focusing on the first element of a product
6675first :: Lens ((a :*: b) x) ((a' :*: b) x) (a x) (a' x)
6776first
68− = lens (\(a :*: b) -> (b,a)) (\(b, a') -> a' :*: b)
77+ = lens (\(a :*: _) -> a) (\((_ :*: b), a') -> a' :*: b)
6978
7079-- | Lens focusing on the second element of a product
7180second :: Lens ((a :*: b) x) ((a :*: b') x) (b x) (b' x)
7281second
73− = lens (\(a :*: b) -> (a,b)) (\(a, b') -> a :*: b')
82+ = lens (\(_ :*: b) -> b) (\((a :*: _), b') -> a :*: b')
7483
7584fork :: (a -> b) -> (a -> c) -> a -> (b, c)
7685fork f g a = (f a, g a)
@@ -123,35 +132,30 @@ stron :: (Either s s', b) -> Either (s, b) (s', b)
123132stron (e, b) = bimap (,b) (, b) e
124133
125134choosing :: 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')
135+choosing l r = withLens l (\getl setl ->
136+ withLens r (\getr setr ->
137+ let g :: Either s s' -> a
138+ g = either getl getr
132139 s = bimap setl setr . stron
133140 in lens g s))
134141
135−lens :: (s -> (c,a)) -> ((c,b) -> t) -> Lens s t a b
136−lens get _set = dimap get _set . second'
137−{-# INLINE lens #-}
142+lens :: (s -> a) -> ((s,b) -> t) -> Lens s t a b
143+lens get _set = dimap (fork id get) _set . second'
138144
139145------------------------------------------------------------------------------
140146
141−data ALens a b s t = forall c . ALens (s -> (c,a)) ((c, b) -> t)
147+data ALens a b s t = ALens (s -> a) ((s, b) -> t)
142148
143149instance Functor (ALens a b s) where
144150 fmap f (ALens _get _set) = ALens _get (f . _set)
145151
146152instance Profunctor (ALens a b) where
147− dimap f g (ALens get _set) = ALens (get . f) (g . _set)
153+ dimap f g (ALens get _set) = ALens (get . f) (g . _set . cross f id)
148154
149155instance Strong (ALens a b) where
150− second' (ALens get _set) = ALens get' set' --(bimap id _set . assoc)
156+ second' (ALens get _set) = ALens (get . snd) (bimap id _set . assoc)
151157 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' #-}
158+ assoc ((a, b), c) = (a, (b, c))
155159
156160-- These are specialised versions of the Isos. On GHC 8.0.2, having
157161-- these functions eta-expanded allows the optimiser to inline these functions.
src/Data/Generics/Internal/Profunctor/Prism.hs+13−16
@@ -1,9 +1,9 @@
1−{-# OPTIONS_HADDOCK hide #-}
21{-# LANGUAGE GADTs #-}
32{-# LANGUAGE LambdaCase #-}
43{-# LANGUAGE NoMonomorphismRestriction #-}
54{-# LANGUAGE Rank2Types #-}
65{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TupleSections #-}
77{-# LANGUAGE TypeFamilies #-}
88{-# LANGUAGE TypeFamilyDependencies #-}
99{-# LANGUAGE TypeOperators #-}
@@ -11,7 +11,7 @@
1111-----------------------------------------------------------------------------
1212-- |
1313-- Module : Data.Generics.Internal.Profunctor.Prism
14−-- Copyright : (C) 2019 Csongor Kiss
14+-- Copyright : (C) 2017 Csongor Kiss
1515-- License : BSD3
1616-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1717-- Stability : experimental
@@ -22,9 +22,7 @@
2222-----------------------------------------------------------------------------
2323module Data.Generics.Internal.Profunctor.Prism where
2424
25−import Data.Bifunctor (bimap)
2625import Data.Profunctor (Choice(..), Profunctor(..))
27−import Data.Tagged
2826import Data.Profunctor.Unsafe ((#.), (.#))
2927import GHC.Generics
3028import Data.Coerce
@@ -46,20 +44,16 @@ prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
4644prism bt seta eta = dimap seta (either id bt) (right' eta)
4745
4846_Left :: Prism (Either a c) (Either b c) a b
49−_Left = left'
47+_Left = prism Left $ either Right (Left . Right)
5048
5149_Right :: Prism (Either c a) (Either c b) a b
52−_Right = right'
50+_Right = prism Right $ either (Left . Left) Right
5351
54−prismPRavel :: APrism s t a b -> Prism s t a b
52+prismPRavel ::
53+ (Market a b a b -> Market a b s t)
54+ -> Prism s t a b
5555prismPRavel l pab = (prism2prismp $ l idPrism) pab
5656
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−
6357--------------------------------------------------------------------------------
6458-- Prism stuff
6559
@@ -67,7 +61,9 @@ without' :: Prism s t a b -> Prism s t c d -> Prism s t (Either a c) (Either b d
6761without' k =
6862 withPrism k $ \bt _ k' ->
6963 withPrism k' $ \dt setc ->
70− prism (either bt dt) $ \s -> fmap Right (setc s)
64+ prism (foldEither bt dt) $ \s -> fmap Right (setc s)
65+ where foldEither _ g (Right r) = g r
66+ foldEither f _ (Left l) = f l
7167{-# INLINE without' #-}
7268
7369withPrism :: APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
@@ -85,7 +81,8 @@ gsum f _ (L1 x) = f x
8581gsum _ g (R1 y) = g y
8682
8783plus :: (a -> b) -> (c -> d) -> Either a c -> Either b d
88−plus = bimap
84+plus f _ (Left x) = Left (f x)
85+plus _ g (Right y) = Right (g y)
8986
9087--------------------------------------------------------------------------------
9188-- Market
@@ -109,7 +106,7 @@ instance Profunctor (Market a b) where
109106 {-# INLINE ( .# ) #-}
110107
111108instance Choice (Market a b) where
112− left' (Market bt seta) = Market (Left . bt) $ \case
109+ left' (Market bt seta) = Market (Left . bt) $ \sc -> case sc of
113110 Left s -> case seta s of
114111 Left t -> Left (Left t)
115112 Right a -> Right a
src/Data/Generics/Internal/VL/Iso.hs+4−37
@@ -1,8 +1,9 @@
1−{-# OPTIONS_HADDOCK hide #-}
21{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE LambdaCase #-}
33{-# LANGUAGE NoMonomorphismRestriction #-}
44{-# LANGUAGE Rank2Types #-}
55{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TupleSections #-}
67{-# LANGUAGE TypeFamilies #-}
78{-# LANGUAGE TypeFamilyDependencies #-}
89{-# LANGUAGE TypeOperators #-}
@@ -10,7 +11,7 @@
1011-----------------------------------------------------------------------------
1112-- |
1213-- Module : Data.Generics.Internal.VL.Iso
13−-- Copyright : (C) 2019 Csongor Kiss
14+-- Copyright : (C) 2017 Csongor Kiss
1415-- License : BSD3
1516-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1617-- Stability : experimental
@@ -21,25 +22,8 @@
2122-----------------------------------------------------------------------------
2223module Data.Generics.Internal.VL.Iso where
2324
24−import Data.Coerce (coerce)
25−import Data.Functor.Identity (Identity(..))
26−import Data.Profunctor (Profunctor(..))
25+import Data.Profunctor (Profunctor(..))
2726import 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 #-}
4327
4428type Iso' s a
4529 = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s)
@@ -47,17 +31,6 @@ type Iso' s a
4731type Iso s t a b
4832 = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
4933
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−
6134-- | A type and its generic representation are isomorphic
6235repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
6336repIso = iso from to
@@ -66,12 +39,6 @@ repIso = iso from to
6639mIso :: Iso (M1 i c f p) (M1 i c g p) (f p) (g p)
6740mIso = iso unM1 M1
6841
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−
7542prodIso :: Iso ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
7643prodIso = iso (\(a :*: b) -> (a, b)) (\(a, b) -> (a :*: b))
7744
src/Data/Generics/Internal/VL/Lens.hs+7−26
@@ -1,17 +1,17 @@
1−{-# OPTIONS_HADDOCK hide #-}
21{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE LambdaCase #-}
33{-# LANGUAGE NoMonomorphismRestriction #-}
44{-# LANGUAGE Rank2Types #-}
55{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TupleSections #-}
67{-# LANGUAGE TypeFamilies #-}
78{-# LANGUAGE TypeFamilyDependencies #-}
89{-# LANGUAGE TypeOperators #-}
9−{-# LANGUAGE TupleSections #-}
1010
1111-----------------------------------------------------------------------------
1212-- |
1313-- Module : Data.Generics.Internal.VL.Lens
14−-- Copyright : (C) 2019 Csongor Kiss
14+-- Copyright : (C) 2017 Csongor Kiss
1515-- License : BSD3
1616-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1717-- Stability : experimental
@@ -23,9 +23,8 @@
2323module Data.Generics.Internal.VL.Lens where
2424
2525import Control.Applicative (Const(..))
26−import Data.Coerce (coerce)
2726import Data.Functor.Identity (Identity(..))
28−import Data.Generics.Internal.Profunctor.Lens (ALens (..), idLens)
27+import Data.Generics.Internal.Profunctor.Lens (ALens (..), (^.), idLens)
2928
3029-- | Type alias for lens
3130type Lens' s a
@@ -37,34 +36,16 @@ type Lens s t a b
3736view :: ((a -> Const a a) -> s -> Const a s) -> s -> a
3837view l s = (^.) s l
3938
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−
4939set :: 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
40+set l x = runIdentity . (l (Identity . const x))
5441
5542lens2lensvl :: 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 #-}
43+lens2lensvl (ALens _get _set) = lens _get _set
6144
6245ravel :: (ALens a b a b -> ALens a b s t)
6346 -> Lens s t a b
6447ravel l pab = (lens2lensvl $ l idLens) pab
6548
66−
6749lens :: (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 #-}
50+lens get _set f x = curry _set x <$> f (get x)
7051
src/Data/Generics/Internal/VL/Prism.hs+4−16
@@ -1,8 +1,9 @@
1−{-# OPTIONS_HADDOCK hide #-}
21{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE LambdaCase #-}
33{-# LANGUAGE NoMonomorphismRestriction #-}
44{-# LANGUAGE Rank2Types #-}
55{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TupleSections #-}
67{-# LANGUAGE TypeFamilies #-}
78{-# LANGUAGE TypeFamilyDependencies #-}
89{-# LANGUAGE TypeOperators #-}
@@ -10,7 +11,7 @@
1011-----------------------------------------------------------------------------
1112-- |
1213-- Module : Data.Generics.Internal.VL.Prism
13−-- Copyright : (C) 2019 Csongor Kiss
14+-- Copyright : (C) 2017 Csongor Kiss
1415-- License : BSD3
1516-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1617-- Stability : experimental
@@ -27,8 +28,6 @@ import Data.Coerce
2728import Data.Generics.Internal.Profunctor.Prism (Market (..), plus, idPrism)
2829import Data.Tagged
2930import Data.Profunctor.Unsafe ((#.), (.#))
30−import Data.Monoid (First (..))
31−import Control.Applicative (Const(..))
3231
3332-- | Type alias for prism
3433type Prism s t a b
@@ -37,19 +36,8 @@ type Prism s t a b
3736type Prism' s a
3837 = Prism s s a a
3938
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−
4639match :: Prism s t a b -> s -> Either t a
4740match k = withPrism k $ \_ _match -> _match
48−{-# INLINE match #-}
49−
50−(#) :: (Tagged b (Identity b) -> Tagged t (Identity t)) -> b -> t
51−(#) = build
52−{-# INLINE (#) #-}
5341
5442prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
5543prism bt seta eta = dimap (\x -> plus pure id (seta x)) (either id (\x -> fmap bt x)) (right' eta)
@@ -71,4 +59,4 @@ prism2prismvl (Market bt seta) = prism bt seta
7159
7260build :: (Tagged b (Identity b) -> Tagged t (Identity t)) -> b -> t
7361build p = runIdentity #. unTagged #. p .# Tagged .# Identity
74−{-# INLINE build #-}
62+
src/Data/Generics/Internal/VL/Traversal.hs+10−28
@@ -1,10 +1,9 @@
1−{-# OPTIONS_HADDOCK hide #-}
2−{-# LANGUAGE AllowAmbiguousTypes #-}
3−{-# LANGUAGE ConstraintKinds #-}
41{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE LambdaCase #-}
53{-# LANGUAGE NoMonomorphismRestriction #-}
64{-# LANGUAGE Rank2Types #-}
75{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TupleSections #-}
87{-# LANGUAGE TypeFamilies #-}
98{-# LANGUAGE TypeFamilyDependencies #-}
109{-# LANGUAGE TypeOperators #-}
@@ -12,7 +11,7 @@
1211-----------------------------------------------------------------------------
1312-- |
1413-- Module : Data.Generics.Internal.VL.Traversal
15−-- Copyright : (C) 2019 Csongor Kiss
14+-- Copyright : (C) 2017 Csongor Kiss
1615-- License : BSD3
1716-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1817-- Stability : experimental
@@ -23,41 +22,24 @@
2322-----------------------------------------------------------------------------
2423module Data.Generics.Internal.VL.Traversal where
2524
26−import Data.Kind (Constraint)
27−
2825-- | Type alias for traversal
2926type Traversal' s a
3027 = forall f. Applicative f => (a -> f a) -> s -> f s
3128
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−
3829type Traversal s t a b
3930 = forall f. Applicative f => (a -> f b) -> s -> f t
4031
41−type LensLikeC c f s
42− = (forall a. c a => a -> f a) -> s -> f s
43−
4432confusing :: Applicative f => Traversal s t a b -> (a -> f b) -> s -> f t
4533confusing t = \f -> lowerYoneda . lowerCurried . t (liftCurriedYoneda . f)
34+ where
35+ liftCurriedYoneda :: Applicative f => f a -> Curried (Yoneda f) a
36+ liftCurriedYoneda fa = Curried (`yap` fa)
37+ {-# INLINE liftCurriedYoneda #-}
38+ yap :: Applicative f => Yoneda f (a -> b) -> f a -> Yoneda f b
39+ yap (Yoneda k) fa = Yoneda (\ab_r -> k (ab_r .) <*> fa)
40+ {-# INLINE yap #-}
4641{-# INLINE confusing #-}
4742
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−
6143newtype Curried f a =
6244 Curried { runCurried :: forall r. f (a -> r) -> f r }
6345
src/Data/Generics/Labels.hs+17−123
@@ -1,142 +1,36 @@
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 #-}
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE MultiParamTypeClasses #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE TypeApplications #-}
6+{-# LANGUAGE TypeFamilies #-}
7+{-# LANGUAGE UndecidableInstances #-}
8+{-# OPTIONS_GHC -Wno-orphans #-}
9+
1510
1611--------------------------------------------------------------------------------
1712-- |
1813-- Module : Data.Generics.Labels
19−-- Copyright : (C) 2019 Csongor Kiss
20−-- License : BSD3
14+-- Copyright : (C) 2017 Csongor Kiss
2115-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16+-- License : BSD3
2217-- Stability : experimental
2318-- Portability : non-portable
2419--
25−-- Provides an (orphan) IsLabel instance for field lenses and constructor prisms.
20+-- Provides an (orphan) IsLabel instance for field lenses.
2621-- Use at your own risk.
2722--------------------------------------------------------------------------------
2823
29−module Data.Generics.Labels
30− ( -- * Orphan IsLabel Instance
31− -- $sec1
32− Field(..)
33− , Field'
34− , Constructor(..)
35− , Constructor'
36− ) where
24+module Data.Generics.Labels () where
3725
3826import 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−
4727import 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)
13128
132−instance (Functor f, Field name s t a b) => IsLabelHelper 'False name (->) f s t a b where
133− labelOutput = fieldLens @name
13429
30+instance (HasField field s t a b, Functor f, sft ~ (s -> f t)) =>
31+ IsLabel field ((a -> f b) -> sft) where
13532#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
33+ fromLabel = field @field
13934#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
35+ fromLabel _ = field @field
14236#endif
src/Data/Generics/Product.hs+3−8
@@ -1,7 +1,7 @@
11-----------------------------------------------------------------------------
22-- |
33-- Module : Data.Generics.Product
4−-- Copyright : (C) 2019 Csongor Kiss
4+-- Copyright : (C) 2017 Csongor Kiss
55-- License : BSD3
66-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
77-- Stability : experimental
@@ -22,11 +22,8 @@ module Data.Generics.Product
2222 , module Data.Generics.Product.Positions
2323 , module Data.Generics.Product.Subtype
2424 , module Data.Generics.Product.Typed
25− , module Data.Generics.Product.HList
26− -- *Traversals
2725 , module Data.Generics.Product.Types
28− , module Data.Generics.Product.Param
29− , module Data.Generics.Product.Constraints
26+ , module Data.Generics.Product.List
3027 ) where
3128
3229import Data.Generics.Product.Any
@@ -35,6 +32,4 @@ import Data.Generics.Product.Positions
3532import Data.Generics.Product.Subtype
3633import Data.Generics.Product.Typed
3734import Data.Generics.Product.Types
38−import Data.Generics.Product.Constraints
39−import Data.Generics.Product.Param
40−import Data.Generics.Product.HList
35+import Data.Generics.Product.List
src/Data/Generics/Product/Any.hs+3−3
@@ -12,7 +12,7 @@
1212-----------------------------------------------------------------------------
1313-- |
1414-- Module : Data.Generics.Product.Any
15−-- Copyright : (C) 2019 Csongor Kiss
15+-- Copyright : (C) 2017 Csongor Kiss
1616-- License : BSD3
1717-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1818-- Stability : experimental
@@ -41,7 +41,7 @@ import Data.Generics.Product.Typed
4141-- >>> :set -XDataKinds
4242-- >>> :set -XDeriveGeneric
4343-- >>> import GHC.Generics
44−-- >>> :m +Data.Generics.Internal.VL.Lens
44+-- >>> :m +Data.Generics.Internal.Lens
4545-- >>> :{
4646-- data Human = Human
4747-- { name :: String
@@ -53,7 +53,7 @@ import Data.Generics.Product.Typed
5353-- human = Human "Tunyasz" 50 "London"
5454-- :}
5555
56−class HasAny sel s t a b | s sel -> a where
56+class HasAny (sel :: k) s t a b | s sel k -> a where
5757 -- |A lens that focuses on a part of a product as identified by some
5858 -- selector. Currently supported selectors are field names, positions and
5959 -- unique types. Compatible with the lens package's 'Control.Lens.Lens'
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.hs+28−93
@@ -16,7 +16,7 @@
1616-----------------------------------------------------------------------------
1717-- |
1818-- Module : Data.Generics.Product.Fields
19−-- Copyright : (C) 2019 Csongor Kiss
19+-- Copyright : (C) 2017 Csongor Kiss
2020-- License : BSD3
2121-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
2222-- Stability : experimental
@@ -31,8 +31,7 @@ module Data.Generics.Product.Fields
3131
3232 -- $setup
3333 HasField (..)
34− , HasField' (..)
35− , HasField_ (..)
34+ , HasField'
3635
3736 , getField
3837 , setField
@@ -41,13 +40,12 @@ module Data.Generics.Product.Fields
4140import Data.Generics.Internal.Families
4241import Data.Generics.Internal.VL.Lens as VL
4342import Data.Generics.Internal.Void
44−import Data.Generics.Product.Internal.GLens
43+import Data.Generics.Product.Internal.Keyed
4544
4645import Data.Kind (Constraint, Type)
4746import GHC.Generics
4847import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError)
49−import Data.Generics.Internal.Profunctor.Lens as P
50−import Data.Generics.Internal.Errors
48+import Data.Generics.Internal.Profunctor.Lens
5149
5250-- $setup
5351-- == /Running example:/
@@ -58,7 +56,7 @@ import Data.Generics.Internal.Errors
5856-- >>> :set -XGADTs
5957-- >>> :set -XFlexibleContexts
6058-- >>> import GHC.Generics
61−-- >>> :m +Data.Generics.Internal.VL.Lens
59+-- >>> :m +Data.Generics.Internal.Lens
6260-- >>> :m +Data.Function
6361-- >>> :{
6462-- data Human a
@@ -113,106 +111,46 @@ class HasField (field :: Symbol) s t a b | s field -> a, t field -> b, s field b
113111 -- ...
114112 field :: VL.Lens s t a b
115113
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
114+type HasField' field s a = HasField field s s a a
139115
140116-- |
141117-- >>> getField @"age" human
142118-- 50
143119getField :: forall f a s. HasField' f s a => s -> a
144−getField = VL.view (field' @f)
120+getField = VL.view (field @f)
145121
146122-- |
147123-- >>> setField @"age" 60 human
148124-- Human {name = "Tunyasz", age = 60, address = "London", other = False}
149125setField :: forall f s a. HasField' f s a => a -> s -> s
150−setField = VL.set (field' @f)
126+setField = VL.set (field @f)
151127
152−instance
128+instance -- see Note [Changing type parameters]
153129 ( Generic s
154130 , 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
131+ , Generic t
132+ -- see Note [CPP in instance constraints]
133+#if __GLASGOW_HASKELL__ < 802
134+ , '(s', t') ~ '(Proxied s, Proxied t)
183135#else
184−-- >>> :t field
185−-- field
186−-- :: (Functor f, HasField field s t a b) => (a -> f b) -> s -> f t
136+ , s' ~ Proxied s
137+ , t' ~ Proxied t
187138#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
139+ , Generic s'
140+ , Generic t'
141+ , GHasKey' field (Rep s) a
142+ , GHasKey' field (Rep s') a'
143+ , GHasKey' field (Rep t') b'
144+ , GHasKey field (Rep s) (Rep t) a b
145+ , t ~ Infer s a' b
146+ , s ~ Infer t b' a
147+ ) => HasField field s t a b where
199148
200−instance {-# OVERLAPPING #-} HasField_ f (Void1 a) (Void1 b) a b where
201− field_ = undefined
149+ field f s = ravel (repLens . gkey @field) f s
202150
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 #-}
151+-- -- See Note [Uncluttering type signatures]
152+instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where
153+ field = undefined
216154
217155type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Constraint where
218156 ErrorUnless field s ('TypeStat _ _ '[])
@@ -235,6 +173,3 @@ type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Cons
235173
236174 ErrorUnless _ _ ('TypeStat '[] '[] _)
237175 = ()
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/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/Keyed.hsnew file+54
@@ -0,0 +1,54 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE GADTs #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE TupleSections #-}
8+{-# LANGUAGE TypeApplications #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeInType #-}
11+{-# LANGUAGE TypeOperators #-}
12+{-# LANGUAGE UndecidableInstances #-}
13+
14+--------------------------------------------------------------------------------
15+-- |
16+-- Module : Data.Generics.Product.Internal.Keyed
17+-- Copyright : (C) 2018 Csongor Kiss
18+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19+-- License : BSD3
20+-- Stability : experimental
21+-- Portability : non-portable
22+--
23+--------------------------------------------------------------------------------
24+
25+module Data.Generics.Product.Internal.Keyed
26+ ( GHasKey (..)
27+ , GHasKey'
28+ ) where
29+
30+import Data.Generics.Product.Internal.List
31+import Data.Kind
32+import GHC.Generics
33+import Data.Generics.Internal.Profunctor.Lens
34+import Data.Generics.Internal.Profunctor.Iso
35+
36+class GHasKey (key :: k) (s :: Type -> Type) (t :: Type -> Type) a b | s key -> a, t key -> b where
37+ gkey :: Lens (s x) (t x) a b
38+
39+type GHasKey' key s a = GHasKey key s s a a
40+
41+instance (GHasKey key l l' a b, GHasKey key r r' a b) => GHasKey key (l :+: r) (l' :+: r') a b where
42+ gkey = sumIso . choosing (gkey @key) (gkey @key)
43+
44+instance (GHasKey key f g a b) => GHasKey key (M1 D meta f) (M1 D meta g) a b where
45+ gkey = mLens . gkey @key
46+
47+instance
48+ ( Elem as key i a
49+ , Elem bs key i b
50+ , IndexList i as bs a b
51+ , GIsList k f g as bs
52+ ) => GHasKey (key :: k) (M1 C meta f) (M1 C meta g) a b where
53+ gkey = mIso . (glist @k) . point @i
54+
src/Data/Generics/Product/Internal/List.hsnew file+345
@@ -0,0 +1,345 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE ConstraintKinds #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE FunctionalDependencies #-}
6+{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TupleSections #-}
9+{-# LANGUAGE TypeApplications #-}
10+{-# LANGUAGE TypeFamilies #-}
11+{-# LANGUAGE TypeInType #-}
12+{-# LANGUAGE TypeOperators #-}
13+{-# LANGUAGE UndecidableInstances #-}
14+
15+#if __GLASGOW_HASKELL__ == 802
16+{-# OPTIONS_GHC -fno-solve-constant-dicts #-}
17+#endif
18+
19+
20+-----------------------------------------------------------------------------
21+-- |
22+-- Module : Data.Generics.Product.Internal.List
23+-- Copyright : (C) 2017 Csongor Kiss
24+-- License : BSD3
25+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
26+-- Stability : experimental
27+-- Portability : non-portable
28+--
29+-- Derive an isomorphism between a product type and a flat HList.
30+--
31+-----------------------------------------------------------------------------
32+
33+module Data.Generics.Product.Internal.List
34+ ( GIsList (..)
35+ , IndexList (..)
36+ , List (..)
37+ , type (++)
38+ , Elem
39+ , ListTuple (..)
40+ , TupleToList
41+ , Permuting (..)
42+ , Appending (..)
43+ ) where
44+
45+import GHC.TypeLits
46+
47+import Data.Kind (Type)
48+import GHC.Generics
49+import Data.Profunctor
50+import Data.Generics.Internal.Profunctor.Lens
51+import Data.Generics.Internal.Profunctor.Iso
52+
53+data List (as :: [(m, Type)]) where
54+ Nil :: List '[]
55+ (:>) :: a -> List as -> List ('(s, a) ': as)
56+
57+infixr 5 :>
58+
59+type family ((as :: [k]) ++ (bs :: [k])) :: [k] where
60+ '[] ++ bs = bs
61+ (a ': as) ++ bs = a ': as ++ bs
62+
63+instance Monoid (List '[]) where
64+ mempty = Nil
65+ mappend _ _ = Nil
66+
67+instance (Monoid a, Monoid (List as)) => Monoid (List ('(k, a) ': as)) where
68+ mempty = mempty :> mempty
69+ mappend (x :> xs) (y :> ys) = mappend x y :> mappend xs ys
70+
71+class Elem (as :: [(k, Type)]) (key :: k) (i :: Nat) a | as key -> i a
72+instance {-# OVERLAPPING #-} pos ~ 0 => Elem ('(key, a) ': xs) key pos a
73+instance (Elem xs key i a, pos ~ (i + 1)) => Elem (x ': xs) key pos a
74+
75+class GIsList
76+ (m :: Type)
77+ (f :: Type -> Type)
78+ (g :: Type -> Type)
79+ (as :: [(m, Type)])
80+ (bs :: [(m, Type)]) | m f -> as, m g -> bs, bs f -> g, as g -> f where
81+
82+ glist :: Iso (f x) (g x) (List as) (List bs)
83+
84+ glistL :: Lens (f x) (g x) (List as) (List bs)
85+ glistL f = glist @m f
86+
87+ glistR :: Lens (List bs) (List as) (g x) (f x)
88+ glistR f = fromIso (glist @m) f
89+
90+instance
91+ ( GIsList m l l' as as'
92+ , GIsList m r r' bs bs'
93+ , Appending List as bs cs as' bs' cs'
94+ , cs ~ (as ++ bs)
95+ , cs' ~ (as' ++ bs')
96+ ) => GIsList m (l :*: r) (l' :*: r') cs cs' where
97+
98+ glist = prodIso . pairing (glist @m) (glist @m) . appending
99+
100+instance GIsList m f g as bs => GIsList m (M1 t meta f) (M1 t meta g) as bs where
101+ glist = mIso . glist @m
102+
103+instance {-# OVERLAPS #-}
104+ GIsList Symbol
105+ (S1 ('MetaSel ('Just field) u s i) (Rec0 a))
106+ (S1 ('MetaSel ('Just field) u s i) (Rec0 b))
107+ '[ '(field, a)] '[ '(field, b)] where
108+ glist = mIso . kIso . singleton
109+
110+instance GIsList Type (Rec0 a) (Rec0 a) '[ '(a, a)] '[ '(a, a)] where
111+ glist = kIso . singleton
112+
113+instance GIsList () (Rec0 a) (Rec0 b) '[ '( '(), a)] '[ '( '(), b)] where
114+ glist = kIso . singleton
115+
116+instance GIsList m U1 U1 '[] '[] where
117+ glist = iso (const Nil) (const U1)
118+
119+--------------------------------------------------------------------------------
120+-- as ++ bs == cs
121+-- as' + == cs'
122+class Appending f (as :: [k]) bs cs (as' :: [k]) bs' cs' | as bs cs cs' -> as' bs', as' bs' cs cs' -> as bs, as bs -> cs, as' bs' -> cs' where
123+ appending :: Iso (f as, f bs) (f as', f bs') (f cs) (f cs')
124+
125+instance Appending List '[] bs bs '[] bs' bs' where
126+ appending = iso snd (Nil,)
127+
128+instance Appending List as bs cs as' bs' cs'
129+ => Appending List ('(f, a) ': as) bs ('(f, a) ': cs) ('(f, a') ': as') bs' ('(f, a') ': cs') where
130+ appending = pairing (fromIso consing) id . assoc3 . pairing id appending . consing
131+
132+singleton :: Iso a b (List '[ '(field, a)]) (List '[ '(field, b)])
133+singleton = iso (:> Nil) (\(x :> _) -> x)
134+
135+consing :: Iso (a, List as) (b, List bs) (List ('(f, a) ': as)) (List ('(f, b) ': bs))
136+consing = iso (\(x, xs) -> x :> xs) (\(x :> xs) -> (x, xs))
137+
138+--------------------------------------------------------------------------------
139+
140+-- This ended up not being used now... still cool to have
141+flipping :: Iso' (List (a1 ': a2 ': as)) (List (a2 ': a1 ': as))
142+flipping = iso
143+ (\(a1 :> a2 :> as) -> a2 :> a1 :> as)
144+ (\(a2 :> a1 :> as) -> a1 :> a2 :> as)
145+
146+class Inserting f a as bs | bs a -> as where
147+ inserting :: Iso' (f (a ': as)) (f bs)
148+
149+instance Inserting f a as (a ': as) where
150+ inserting = id
151+
152+instance Inserting List a as bs => Inserting List a ('(fb, b) ': as) ('(fb, b) ': bs) where
153+ inserting = flipping . fromIso consing . pairing id (inserting @_ @a) . consing
154+
155+class Permuting f as bs where
156+ permuting :: Iso' (f as) (f bs)
157+
158+instance Permuting List '[] '[] where
159+ permuting = id
160+
161+instance (Permuting List as as', Inserting List '(fa, a) as' bs')
162+ => Permuting List ('(fa, a) ': as) bs' where
163+ permuting = fromIso consing . pairing id permuting . consing . (inserting @_ @'(fa, _))
164+
165+--------------------------------------------------------------------------------
166+class IndexList (i :: Nat) as bs a b | i as -> a, i bs -> b, i as b -> bs, i bs a -> as where
167+ point :: Lens (List as) (List bs) a b
168+
169+instance {-# OVERLAPPING #-}
170+ ( as ~ ('(f, a) ': as')
171+ , bs ~ ('(f, b) ': as')
172+ ) => IndexList 0 as bs a b where
173+ point = lens (\(x :> _) -> x) (\((_ :> xs), x') -> x' :> xs)
174+ {-# INLINE point #-}
175+
176+instance
177+ ( IndexList (n - 1) as' bs' a b
178+ , as ~ ('(f, x) ': as')
179+ , bs ~ ('(f, x) ': bs')
180+ ) => IndexList n as bs a b where
181+ point = fromIso consing . alongside id (point @(n-1)) . second'
182+ {-# INLINE point #-}
183+
184+--------------------------------------------------------------------------------
185+-- * Convert tuples to/from HLists
186+
187+class ListTuple (tuple :: Type) (as :: [(k, Type)]) | as -> tuple where
188+ type ListToTuple as :: Type
189+ tupled :: Iso' (List as) tuple
190+ tupled = iso listToTuple tupleToList
191+
192+ tupleToList :: tuple -> List as
193+ listToTuple :: List as -> tuple
194+
195+instance ListTuple () '[] where
196+ type ListToTuple '[] = ()
197+ tupleToList _ = Nil
198+ listToTuple _ = ()
199+
200+instance ListTuple a '[ '(fa, a)] where
201+ type ListToTuple '[ '(fa, a)] = a
202+ tupleToList a
203+ = a :> Nil
204+ listToTuple (a :> Nil)
205+ = a
206+
207+instance ListTuple (a, b) '[ '(fa, a), '(fb, b)] where
208+ type ListToTuple '[ '(fa, a), '(fb, b)] = (a, b)
209+ tupleToList (a, b)
210+ = a :> b :> Nil
211+ listToTuple (a :> b :> Nil)
212+ = (a, b)
213+
214+instance ListTuple (a, b, c) '[ '(fa, a), '(fb, b), '(fc, c)] where
215+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c)] = (a, b, c)
216+ tupleToList (a, b, c)
217+ = a :> b :> c :> Nil
218+ listToTuple (a :> b :> c :> Nil)
219+ = (a, b, c)
220+
221+instance ListTuple (a, b, c, d) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d)] where
222+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d)] = (a, b, c, d)
223+ tupleToList (a, b, c, d)
224+ = a :> b :> c :> d:> Nil
225+ listToTuple (a :> b :> c :> d :> Nil)
226+ = (a, b, c, d)
227+
228+instance ListTuple (a, b, c, d, e) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e)] where
229+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e)] = (a, b, c, d, e)
230+ tupleToList (a, b, c, d, e)
231+ = a :> b :> c :> d:> e :> Nil
232+ listToTuple (a :> b :> c :> d :> e :> Nil)
233+ = (a, b, c, d, e)
234+
235+instance ListTuple (a, b, c, d, e, f) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f)] where
236+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f)] = (a, b, c, d, e, f)
237+ tupleToList (a, b, c, d, e, f)
238+ = a :> b :> c :> d:> e :> f :> Nil
239+ listToTuple (a :> b :> c :> d :> e :> f :> Nil)
240+ = (a, b, c, d, e, f)
241+
242+instance ListTuple (a, b, c, d, e, f, g) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g)] where
243+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g)] = (a, b, c, d, e, f, g)
244+ tupleToList (a, b, c, d, e, f, g)
245+ = a :> b :> c :> d:> e :> f :> g :> Nil
246+ listToTuple (a :> b :> c :> d :> e :> f :> g :> Nil)
247+ = (a, b, c, d, e, f, g)
248+
249+instance ListTuple (a, b, c, d, e, f, g, h) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h)] where
250+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h)] = (a, b, c, d, e, f, g, h)
251+ tupleToList (a, b, c, d, e, f, g, h)
252+ = a :> b :> c :> d:> e :> f :> g :> h :> Nil
253+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> Nil)
254+ = (a, b, c, d, e, f, g, h)
255+
256+instance ListTuple (a, b, c, d, e, f, g, h, j) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j)] where
257+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j)] = (a, b, c, d, e, f, g, h, j)
258+ tupleToList (a, b, c, d, e, f, g, h, j)
259+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> Nil
260+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> Nil)
261+ = (a, b, c, d, e, f, g, h, j)
262+
263+instance ListTuple (a, b, c, d, e, f, g, h, j, k) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k)] where
264+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k)] = (a, b, c, d, e, f, g, h, j, k)
265+ tupleToList (a, b, c, d, e, f, g, h, j, k)
266+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> Nil
267+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> Nil)
268+ = (a, b, c, d, e, f, g, h, j, k)
269+
270+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l)] where
271+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l)] = (a, b, c, d, e, f, g, h, j, k, l)
272+ tupleToList (a, b, c, d, e, f, g, h, j, k, l)
273+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> Nil
274+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> Nil)
275+ = (a, b, c, d, e, f, g, h, j, k, l)
276+
277+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m)] where
278+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m)] = (a, b, c, d, e, f, g, h, j, k, l, m)
279+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m)
280+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> Nil
281+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> Nil)
282+ = (a, b, c, d, e, f, g, h, j, k, l, m)
283+
284+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n)] where
285+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n)] = (a, b, c, d, e, f, g, h, j, k, l, m, n)
286+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n)
287+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil
288+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil)
289+ = (a, b, c, d, e, f, g, h, j, k, l, m, n)
290+
291+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o)] where
292+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
293+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
294+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil
295+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil)
296+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
297+
298+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p)] where
299+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
300+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
301+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil
302+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil)
303+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
304+
305+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q)] where
306+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
307+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
308+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil
309+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil)
310+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
311+
312+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r)] where
313+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
314+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
315+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil
316+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil)
317+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
318+
319+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r), '(fs, s)] where
320+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r), '(fs, s)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
321+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
322+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil
323+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil)
324+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
325+
326+type family TupleToList a where
327+ TupleToList () = '[]
328+ TupleToList (a, b) = '[ '( '(), a), '( '(), b)]
329+ TupleToList (a, b, c) = '[ '( '(), a), '( '(), b), '( '(), c)]
330+ TupleToList (a, b, c, d) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d)]
331+ TupleToList (a, b, c, d, e) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e)]
332+ TupleToList (a, b, c, d, e, f) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f)]
333+ TupleToList (a, b, c, d, e, f, g) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g)]
334+ TupleToList (a, b, c, d, e, f, g, h) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h)]
335+ TupleToList (a, b, c, d, e, f, g, h, j) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j)]
336+ TupleToList (a, b, c, d, e, f, g, h, j, k) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k)]
337+ TupleToList (a, b, c, d, e, f, g, h, j, k, l) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l)]
338+ 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)]
339+ 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)]
340+ 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)]
341+ 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)]
342+ 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)]
343+ 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)]
344+ 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)]
345+ TupleToList a = '[ '( '(), a)]
src/Data/Generics/Product/Internal/Positions.hs+24−46
@@ -1,4 +1,3 @@
1−{-# LANGUAGE TypeInType #-}
21{-# LANGUAGE AllowAmbiguousTypes #-}
32{-# LANGUAGE ConstraintKinds #-}
43{-# LANGUAGE DataKinds #-}
@@ -17,7 +16,7 @@
1716-----------------------------------------------------------------------------
1817-- |
1918-- Module : Data.Generics.Product.Internal.Positions
20−-- Copyright : (C) 2019 Csongor Kiss
19+-- Copyright : (C) 2017 Csongor Kiss
2120-- License : BSD3
2221-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
2322-- Stability : experimental
@@ -28,61 +27,38 @@
2827-----------------------------------------------------------------------------
2928
3029module Data.Generics.Product.Internal.Positions
31− ( type (<?)
30+ ( GHasPosition (..)
31+ , GHasPosition'
32+ , type (<?)
3233 , Size
33− , CRep
3434 ) where
3535
36−import Data.Generics.Internal.Families.Has (Pos)
36+import Data.Generics.Product.Internal.List
3737import Data.Kind (Type)
3838import Data.Type.Bool (If, Not)
3939import GHC.Generics
40−import GHC.TypeLits (type (<=?), type (+), Nat)
40+import GHC.TypeLits (type (<=?), type (+), type (-), Nat)
41+import Data.Generics.Internal.Profunctor.Lens
42+import Data.Generics.Internal.Profunctor.Iso
4143
42−-- | Alias for the kind of the generic rep
43−type G = Type -> Type
44+-- |As 'HasPosition' but over generic representations as defined by
45+-- "GHC.Generics".
46+class GHasPosition (i :: Nat) (s :: Type -> Type) (t :: Type -> Type) a b | s i -> a, t i -> b, s t i -> b where
47+ gposition :: Lens (s x) (t x) a b
4448
45−--------------------------------------------------------------------------------
49+type GHasPosition' i s a = GHasPosition i s s a a
4650
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)
51+instance (GHasPosition i l l' a b, GHasPosition i r r' a b) => GHasPosition i (l :+: r) (l' :+: r') a b where
52+ gposition = sumIso . choosing (gposition @i) (gposition @i)
5553
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)
54+instance GHasPosition i s t a b => GHasPosition i (M1 D meta s) (M1 D meta t) a b where
55+ gposition = mLens . gposition @i
7256
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
57+instance
58+ ( IndexList (i - 1) as bs a b
59+ , GIsList () f g as bs
60+ ) => GHasPosition i (M1 C meta f) (M1 C meta g) a b where
61+ gposition = mIso . (glist @()) . point @(i - 1)
8662
8763type family Size f :: Nat where
8864 Size (l :*: r)
@@ -96,6 +72,8 @@ type family Size f :: Nat where
9672 Size f
9773 = 1
9874
75+--------------------------------------------------------------------------------
76+
9977type x <? y = Not (y <=? x)
10078infixl 4 <?
10179
src/Data/Generics/Product/Internal/Subtype.hs+10−15
@@ -1,4 +1,3 @@
1−{-# LANGUAGE TypeInType #-}
21{-# LANGUAGE AllowAmbiguousTypes #-}
32{-# LANGUAGE DataKinds #-}
43{-# LANGUAGE FlexibleContexts #-}
@@ -16,7 +15,7 @@
1615-----------------------------------------------------------------------------
1716-- |
1817-- Module : Data.Generics.Product.Internal.Subtype
19−-- Copyright : (C) 2019 Csongor Kiss
18+-- Copyright : (C) 2017 Csongor Kiss
2019-- License : BSD3
2120-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
2221-- Stability : experimental
@@ -32,12 +31,11 @@ module Data.Generics.Product.Internal.Subtype
3231 ) where
3332
3433import Data.Generics.Internal.Families
35−import Data.Generics.Product.Internal.GLens
34+import Data.Generics.Product.Internal.Keyed
3635
3736import Data.Kind (Type)
3837import GHC.Generics
39−import GHC.TypeLits (Symbol)
40−import Data.Generics.Internal.Profunctor.Lens (view)
38+import Data.Generics.Internal.Profunctor.Lens
4139
4240--------------------------------------------------------------------------------
4341-- * Generic upcasting
@@ -49,10 +47,10 @@ instance (GUpcast sub a, GUpcast sub b) => GUpcast sub (a :*: b) where
4947 gupcast rep = gupcast rep :*: gupcast rep
5048
5149instance
52− GLens' (HasTotalFieldPSym field) sub t
50+ GHasKey field sub sub t t
5351 => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
5452
55− gupcast r = M1 (K1 (view (glens @(HasTotalFieldPSym field)) r))
53+ gupcast r = M1 (K1 (view (gkey @field) r))
5654
5755instance GUpcast sub sup => GUpcast sub (C1 c sup) where
5856 gupcast = M1 . gupcast
@@ -82,16 +80,13 @@ instance GSmash sub sup => GSmash (C1 c sub) sup where
8280instance GSmash sub sup => GSmash (D1 c sub) sup where
8381 gsmash sup (M1 sub) = M1 (gsmash sup sub)
8482
85−class GSmashLeaf sub sup (w :: Maybe Type) where
83+class GSmashLeaf sub sup (w :: Bool) where
8684 gsmashLeaf :: sup p -> sub p -> sub p
8785
8886instance
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))
87+ GHasKey field sup sup t t
88+ => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'True where
89+ gsmashLeaf sup _ = M1 (K1 (view (gkey @field) sup))
9290
93−instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'Nothing where
91+instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'False where
9492 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/Internal/Types.hsnew file+56
@@ -0,0 +1,56 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE KindSignatures #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeApplications #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeOperators #-}
11+{-# LANGUAGE UndecidableInstances #-}
12+
13+-----------------------------------------------------------------------------
14+-- |
15+-- Module : Data.Generics.Product.Internal.Types
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 traversals of a given type in a product.
23+--
24+-----------------------------------------------------------------------------
25+
26+module Data.Generics.Product.Internal.Types
27+ ( GHasTypes (..)
28+ ) where
29+
30+import Data.Kind (Type)
31+import GHC.Generics
32+
33+-- |As 'HasTypes' but over generic representations as defined by
34+-- "GHC.Generics".
35+class GHasTypes (f :: Type -> Type) a where
36+ gtypes :: forall g . Applicative g => (a -> g a) -> f a -> g (f a)
37+
38+instance (GHasTypes l a, GHasTypes r a) => GHasTypes (l :*: r) a where
39+ gtypes f (l :*: r) = (:*:) <$> gtypes f l <*> gtypes f r
40+ {-# INLINE gtypes #-}
41+
42+-- TODO:
43+-- instance (GHasTypes l a, GHasTypes r a) => GHasTypes (l :+: r) a where
44+
45+instance GHasTypes (K1 R a) a where
46+ gtypes f (K1 x) = fmap K1 (f x)
47+ {-# INLINE gtypes #-}
48+
49+
50+instance {-# OVERLAPS #-} GHasTypes (K1 R a) b where
51+ gtypes _ k = pure k
52+ {-# INLINE gtypes #-}
53+
54+instance GHasTypes f a => GHasTypes (M1 m meta f) a where
55+ gtypes f (M1 x) = M1 <$> gtypes f x
56+ {-# INLINE gtypes #-}
src/Data/Generics/Product/List.hsnew file+77
@@ -0,0 +1,77 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE MonoLocalBinds #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE TypeApplications #-}
8+{-# LANGUAGE TypeInType #-}
9+{-# LANGUAGE UndecidableInstances #-}
10+
11+-----------------------------------------------------------------------------
12+-- |
13+-- Module : Data.Generics.Product.List
14+-- Copyright : (C) 2017 Csongor Kiss
15+-- License : BSD3
16+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17+-- Stability : experimental
18+-- Portability : non-portable
19+--
20+-- Derive an isomorphism between a product type and a flat HList.
21+--
22+-----------------------------------------------------------------------------
23+
24+module Data.Generics.Product.List
25+ ( IsList (..)
26+ , IsRecord
27+ , IsRecord'
28+ ) where
29+
30+import Data.Generics.Product.Internal.List
31+import Data.Kind
32+import GHC.Generics
33+import GHC.TypeLits
34+import Data.Generics.Internal.Profunctor.Iso
35+
36+class IsList
37+ (m :: Type)
38+ (f :: Type)
39+ (g :: Type)
40+ (as :: [(m, Type)])
41+ (bs :: [(m, Type)]) | m f -> as, m g -> bs where
42+ list :: Iso f g (List as) (List bs)
43+
44+instance
45+ ( Generic f
46+ , Generic g
47+ , GIsList m (Rep f) (Rep g) as bs
48+ ) => IsList m f g as bs where
49+ list = repIso . (glist @m)
50+
51+class IsList Symbol f g as bs => IsRecord f g (as :: [(Symbol, Type)]) (bs :: [(Symbol, Type)]) | f -> as, g -> bs
52+instance IsList Symbol f g as bs => IsRecord f g as bs
53+
54+class IsRecord f f as as => IsRecord' f (as :: [(Symbol, Type)]) | f -> as
55+instance IsRecord f f as as => IsRecord' f as
56+
57+-- example (TODO: move elsewhere)
58+--class PrintRecord (rl :: [(Symbol, Type)]) where
59+-- printRecord' :: List rl -> String
60+--
61+--instance PrintRecord '[] where
62+-- printRecord' _ = ""
63+--
64+--instance (KnownSymbol field, Show a, PrintRecord xs) => PrintRecord ('(field, a) ': xs) where
65+-- printRecord' (x :> xs) = show x ++ ", " ++ printRecord' xs
66+--
67+--printRecord :: (IsRecord' rec rl, PrintRecord rl) => rec -> String
68+--printRecord rec = printRecord' (rec ^. list)
69+--
70+--data MyRecord = MyRecord
71+-- { field1 :: Int
72+-- , field2 :: String
73+-- , field3 :: Bool
74+-- } deriving Generic
75+--
76+-- >>> printRecord (MyRecord 10 "hello" False)
77+-- "10, \"hello\", False, "
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.hs+27−122
@@ -1,5 +1,3 @@
1−{-# LANGUAGE TypeInType #-}
2−{-# LANGUAGE PartialTypeSignatures #-}
31{-# LANGUAGE CPP #-}
42{-# LANGUAGE AllowAmbiguousTypes #-}
53{-# LANGUAGE ConstraintKinds #-}
@@ -19,7 +17,7 @@
1917-----------------------------------------------------------------------------
2018-- |
2119-- Module : Data.Generics.Product.Positions
22−-- Copyright : (C) 2019 Csongor Kiss
20+-- Copyright : (C) 2017 Csongor Kiss
2321-- License : BSD3
2422-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
2523-- Stability : experimental
@@ -34,9 +32,7 @@ module Data.Generics.Product.Positions
3432
3533 -- $setup
3634 HasPosition (..)
37− , HasPosition' (..)
38− , HasPosition_ (..)
39− , HasPosition0 (..)
35+ , HasPosition'
4036
4137 , getPosition
4238 , setPosition
@@ -46,15 +42,12 @@ import Data.Generics.Internal.VL.Lens as VL
4642import Data.Generics.Internal.Void
4743import Data.Generics.Internal.Families
4844import Data.Generics.Product.Internal.Positions
49−import Data.Generics.Product.Internal.GLens
50−import Data.Generics.Internal.Errors
5145
5246import Data.Kind (Constraint, Type)
5347import Data.Type.Bool (type (&&))
5448import GHC.Generics
5549import GHC.TypeLits (type (<=?), Nat, TypeError, ErrorMessage(..))
56−import Data.Generics.Internal.Profunctor.Lens as P
57−import Data.Coerce
50+import Data.Generics.Internal.Profunctor.Lens
5851
5952-- $setup
6053-- == /Running example:/
@@ -65,7 +58,7 @@ import Data.Coerce
6558-- >>> :set -XGADTs
6659-- >>> :set -XFlexibleContexts
6760-- >>> import GHC.Generics
68−-- >>> :m +Data.Generics.Internal.VL.Lens
61+-- >>> :m +Data.Generics.Internal.Lens
6962-- >>> :m +Data.Function
7063-- >>> :{
7164-- data Human = Human
@@ -96,125 +89,40 @@ class HasPosition (i :: Nat) s t a b | s i -> a, t i -> b, s i b -> t, t i a ->
9689 -- ...
9790 position :: VL.Lens s t a b
9891
99−class HasPosition_ (i :: Nat) s t a b where
100− position_ :: VL.Lens s t a b
92+type HasPosition' i s a = HasPosition i s s a a
10193
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
12194getPosition :: forall i s a. HasPosition' i s a => s -> a
122−getPosition s = s ^. position' @i
95+getPosition s = s ^. position @i
12396
124−-- |
125−-- >>> setPosition @2 60 human
126−-- Human {name = "Tunyasz", age = 60, address = "London"}
12797setPosition :: forall i s a. HasPosition' i s a => a -> s -> s
128−setPosition = VL.set (position' @i)
98+setPosition = VL.set (position @i)
12999
130−instance
100+instance -- see Note [Changing type parameters]
131101 ( Generic s
132102 , 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
103+ , Generic t
104+ -- see Note [CPP in instance constraints]
105+#if __GLASGOW_HASKELL__ < 802
106+ , '(s', t') ~ '(Proxied s, Proxied t)
180107#else
181−-- >>> :t position
182−-- position
183−-- :: (Functor f, HasPosition i s t a b) => (a -> f b) -> s -> f t
108+ , s' ~ Proxied s
109+ , t' ~ Proxied t
184110#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_ #-}
111+ , Generic s'
112+ , Generic t'
113+ , GHasPosition' i (Rep s) a
114+ , GHasPosition' i (Rep s') a'
115+ , GHasPosition i (Rep s) (Rep t) a b
116+ , t ~ Infer s a' b
117+ , GHasPosition' i (Rep t') b'
118+ , s ~ Infer t b' a
119+ ) => HasPosition i s t a b where
199120
200−instance {-# OVERLAPPING #-} HasPosition_ f (Void1 a) (Void1 b) a b where
201− position_ = undefined
121+ position f s = ravel (repLens . gposition @i) f s
202122
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 #-}
123+-- See Note [Uncluttering type signatures]
124+instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where
125+ position = undefined
218126
219127type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint where
220128 ErrorUnless i s 'False
@@ -227,6 +135,3 @@ type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint wher
227135
228136 ErrorUnless _ _ 'True
229137 = ()
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.hs+5−45
@@ -1,4 +1,3 @@
1−{-# LANGUAGE CPP #-}
21{-# LANGUAGE AllowAmbiguousTypes #-}
32{-# LANGUAGE DataKinds #-}
43{-# LANGUAGE FlexibleContexts #-}
@@ -16,7 +15,7 @@
1615-----------------------------------------------------------------------------
1716-- |
1817-- Module : Data.Generics.Product.Subtype
19−-- Copyright : (C) 2019 Csongor Kiss
18+-- Copyright : (C) 2017 Csongor Kiss
2019-- License : BSD3
2120-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
2221-- Stability : experimental
@@ -41,8 +40,7 @@ import Data.Generics.Product.Internal.Subtype
4140import GHC.Generics (Generic (Rep, to, from) )
4241import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
4342import Data.Kind (Type, Constraint)
44−import Data.Generics.Internal.Profunctor.Lens hiding (set)
45−import Data.Generics.Internal.Errors
43+import Data.Generics.Internal.Profunctor.Lens
4644
4745-- $setup
4846-- == /Running example:/
@@ -52,7 +50,7 @@ import Data.Generics.Internal.Errors
5250-- >>> :set -XDeriveGeneric
5351-- >>> :set -XDuplicateRecordFields
5452-- >>> import GHC.Generics
55−-- >>> :m +Data.Generics.Internal.VL.Lens
53+-- >>> :m +Data.Generics.Internal.Lens
5654-- >>> :{
5755-- data Human = Human
5856-- { name :: String
@@ -115,52 +113,14 @@ instance
115113 , Generic b
116114 , GSmash (Rep a) (Rep b)
117115 , GUpcast (Rep a) (Rep b)
118− , CustomError a b
116+ , ErrorUnless b a (CollectFieldsOrdered (Rep b) \\ CollectFieldsOrdered (Rep a))
119117 ) => Subtype b a where
120118 smash p b = to $ gsmash (from p) (from b)
121119 upcast = to . gupcast . from
122120
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
121+-- See Note [Uncluttering type signatures]
151122instance {-# OVERLAPPING #-} Subtype a Void where
152123 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
164124instance {-# OVERLAPPING #-} Subtype Void a where
165125 super = undefined
166126
src/Data/Generics/Product/Typed.hs+6−33
@@ -1,4 +1,3 @@
1−{-# LANGUAGE CPP #-}
21{-# LANGUAGE AllowAmbiguousTypes #-}
32{-# LANGUAGE DataKinds #-}
43{-# LANGUAGE FlexibleContexts #-}
@@ -8,14 +7,13 @@
87{-# LANGUAGE ScopedTypeVariables #-}
98{-# LANGUAGE TypeApplications #-}
109{-# LANGUAGE TypeFamilies #-}
11−{-# LANGUAGE TypeInType #-}
1210{-# LANGUAGE TypeOperators #-}
1311{-# LANGUAGE UndecidableInstances #-}
1412
1513-----------------------------------------------------------------------------
1614-- |
1715-- Module : Data.Generics.Product.Typed
18−-- Copyright : (C) 2019 Csongor Kiss
16+-- Copyright : (C) 2017 Csongor Kiss
1917-- License : BSD3
2018-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
2119-- Stability : experimental
@@ -35,13 +33,12 @@ module Data.Generics.Product.Typed
3533import Data.Generics.Internal.Families
3634import Data.Generics.Internal.VL.Lens as VL
3735import Data.Generics.Internal.Void
38−import Data.Generics.Product.Internal.GLens
36+import Data.Generics.Product.Internal.Keyed
3937
4038import Data.Kind (Constraint, Type)
4139import GHC.Generics (Generic (Rep))
4240import GHC.TypeLits (TypeError, ErrorMessage (..))
4341import Data.Generics.Internal.Profunctor.Lens
44−import Data.Generics.Internal.Errors
4542
4643-- $setup
4744-- == /Running example:/
@@ -50,7 +47,7 @@ import Data.Generics.Internal.Errors
5047-- >>> :set -XDataKinds
5148-- >>> :set -XDeriveGeneric
5249-- >>> import GHC.Generics
53−-- >>> :m +Data.Generics.Internal.VL.Lens
50+-- >>> :m +Data.Generics.Internal.Lens
5451-- >>> :{
5552-- data Human
5653-- = Human
@@ -98,7 +95,6 @@ class HasType a s where
9895 typed :: VL.Lens s s a a
9996 typed
10097 = VL.lens (getTyped @a) (uncurry (setTyped @a) . swap)
101− {-# INLINE typed #-}
10298
10399 -- |Get field at type.
104100 getTyped :: s -> a
@@ -113,31 +109,12 @@ class HasType a s where
113109instance
114110 ( Generic s
115111 , 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
112+ , GHasKey a (Rep s) (Rep s) a a
120113 ) => HasType a s where
121114
122− typed f s = VL.ravel (repLens . glens @(HasTotalTypePSym a)) f s
115+ typed = ravel (repLens . gkey @a)
123116
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.
117+-- See Note [Uncluttering type signatures]
141118instance {-# OVERLAPPING #-} HasType a Void where
142119 typed = undefined
143120
@@ -172,7 +149,3 @@ type family ErrorUnlessOne (a :: Type) (s :: Type) (stat :: TypeStat) :: Constra
172149
173150 ErrorUnlessOne _ _ ('TypeStat '[] '[] _)
174151 = ()
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.hs+13−332
@@ -1,12 +1,9 @@
11{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE ConstraintKinds #-}
32{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE DefaultSignatures #-}
3+{-# LANGUAGE FlexibleContexts #-}
54{-# LANGUAGE FlexibleInstances #-}
65{-# LANGUAGE KindSignatures #-}
76{-# LANGUAGE MultiParamTypeClasses #-}
8−{-# LANGUAGE PolyKinds #-}
9−{-# LANGUAGE Rank2Types #-}
107{-# LANGUAGE ScopedTypeVariables #-}
118{-# LANGUAGE TypeApplications #-}
129{-# LANGUAGE TypeFamilies #-}
@@ -16,7 +13,7 @@
1613-----------------------------------------------------------------------------
1714-- |
1815-- Module : Data.Generics.Product.Types
19−-- Copyright : (C) 2019 Csongor Kiss
16+-- Copyright : (C) 2017 Csongor Kiss
2017-- License : BSD3
2118-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
2219-- Stability : experimental
@@ -29,339 +26,23 @@
2926module Data.Generics.Product.Types
3027 ( -- *Traversals
3128 --
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−
29+ -- $example
30+ HasTypes (..)
4631 ) where
4732
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
33+import Data.Generics.Product.Internal.Types
5234
53−import GHC.Generics
54−import GHC.TypeLits
35+import GHC.Generics (Generic (Rep), from, to)
5536import 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
8037
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_ #-}
38+class HasTypes a s where
39+ types :: Traversal' s a
10140
10241instance
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
42+ ( Generic s
43+ , GHasTypes (Rep s) a
44+ ) => HasTypes a s where
36345
364−type family IsNothing a where
365− IsNothing ('Just _) = 'False
366− IsNothing 'Nothing = 'True
46+ types = confusing (\f s -> to <$> gtypes f (from s))
47+ {-# INLINE types #-}
36748
src/Data/Generics/Sum.hs+1−1
@@ -1,7 +1,7 @@
11-----------------------------------------------------------------------------
22-- |
33-- Module : Data.Generics.Sum
4−-- Copyright : (C) 2019 Csongor Kiss
4+-- Copyright : (C) 2017 Csongor Kiss
55-- License : BSD3
66-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
77-- Stability : experimental
src/Data/Generics/Sum/Any.hs+3−3
@@ -11,7 +11,7 @@
1111-----------------------------------------------------------------------------
1212-- |
1313-- Module : Data.Generics.Sum.Any
14−-- Copyright : (C) 2019 Csongor Kiss
14+-- Copyright : (C) 2017 Csongor Kiss
1515-- License : BSD3
1616-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1717-- Stability : experimental
@@ -39,7 +39,7 @@ import Data.Generics.Internal.VL.Prism
3939-- >>> :set -XDataKinds
4040-- >>> :set -XDeriveGeneric
4141-- >>> import GHC.Generics
42−-- >>> :m +Data.Generics.Internal.VL.Prism
42+-- >>> :m +Data.Generics.Internal.Lens
4343-- >>> :{
4444-- data Animal
4545-- = Dog Dog
@@ -61,7 +61,7 @@ import Data.Generics.Internal.VL.Prism
6161-- :}
6262
6363-- |Sums that have generic prisms.
64−class AsAny sel a s | s sel -> a where
64+class AsAny (sel :: k) a s | s sel k -> a where
6565 -- |A prism that projects a sum as identified by some selector. Currently
6666 -- supported selectors are constructor names and unique types. Compatible
6767 -- with the lens package's 'Control.Lens.Prism' type.
src/Data/Generics/Sum/Constructors.hs+18−88
@@ -15,7 +15,7 @@
1515-----------------------------------------------------------------------------
1616-- |
1717-- Module : Data.Generics.Sum.Constructors
18−-- Copyright : (C) 2019 Csongor Kiss
18+-- Copyright : (C) 2017 Csongor Kiss
1919-- License : BSD3
2020-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
2121-- Stability : experimental
@@ -30,9 +30,6 @@ module Data.Generics.Sum.Constructors
3030
3131 -- $setup
3232 AsConstructor (..)
33− , AsConstructor_ (..)
34− , AsConstructor' (..)
35− , AsConstructor0 (..)
3633 ) where
3734
3835import Data.Generics.Internal.Families
@@ -44,8 +41,6 @@ import GHC.Generics (Generic (Rep))
4441import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
4542import Data.Generics.Internal.VL.Prism
4643import Data.Generics.Internal.Profunctor.Iso
47−import Data.Generics.Internal.Profunctor.Prism (prismPRavel)
48−import Data.Generics.Internal.Errors
4944
5045-- $setup
5146-- == /Running example:/
@@ -56,7 +51,7 @@ import Data.Generics.Internal.Errors
5651-- >>> :set -XFlexibleContexts
5752-- >>> :set -XTypeFamilies
5853-- >>> import GHC.Generics
59−-- >>> :m +Data.Generics.Internal.VL.Prism
54+-- >>> :m +Data.Generics.Internal.Lens
6055-- >>> :m +Data.Generics.Product.Fields
6156-- >>> :m +Data.Function
6257-- >>> :{
@@ -71,7 +66,7 @@ import Data.Generics.Internal.Errors
7166-- , age :: Age
7267-- , fieldA :: a
7368-- }
74−-- deriving Show
69+-- deriving (Generic, Show)
7570-- type Name = String
7671-- type Age = Int
7772-- dog, cat, duck :: Animal Int
@@ -106,99 +101,34 @@ class AsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where
106101 -- ...
107102 _Ctor :: Prism s t a b
108103
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−
128104instance
129105 ( Generic s
130106 , ErrorUnless ctor s (HasCtorP ctor (Rep s))
107+ , Generic t
108+ -- see Note [CPP in instance constraints]
109+#if __GLASGOW_HASKELL__ < 802
110+ , '(s', t') ~ '(Proxied s, Proxied t)
111+#else
112+ , s' ~ Proxied s
113+ , t' ~ Proxied t
114+#endif
115+ , Generic s'
116+ , Generic t'
131117 , 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'
118+ , GAsConstructor' ctor (Rep s') a'
145119 , GAsConstructor ctor (Rep s) (Rep t) a b
146120 , t ~ Infer s a' b
147− , GAsConstructor' ctor (Rep (Indexed t)) b'
121+ , GAsConstructor' ctor (Rep t') b'
148122 , s ~ Infer t b' a
149− , AsConstructor0 ctor s t a b
150123 ) => AsConstructor ctor s t a b where
151124
152− _Ctor = _Ctor0 @ctor
153− {-# INLINE[2] _Ctor #-}
125+ _Ctor eta = prismRavel (repIso . _GCtor @ctor) eta
126+ {-# INLINE _Ctor #-}
154127
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
128+-- See Note [Uncluttering type signatures]
169129instance {-# OVERLAPPING #-} AsConstructor ctor (Void1 a) (Void1 b) a b where
170130 _Ctor = undefined
171131
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−
202132type family ErrorUnless (ctor :: Symbol) (s :: Type) (contains :: Bool) :: Constraint where
203133 ErrorUnless ctor s 'False
204134 = TypeError
src/Data/Generics/Sum/Internal/Constructors.hs+13−11
@@ -14,7 +14,7 @@
1414-----------------------------------------------------------------------------
1515-- |
1616-- Module : Data.Generics.Sum.Internal.Constructors
17−-- Copyright : (C) 2019 Csongor Kiss
17+-- Copyright : (C) 2017 Csongor Kiss
1818-- License : BSD3
1919-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
2020-- Stability : experimental
@@ -30,11 +30,11 @@ module Data.Generics.Sum.Internal.Constructors
3030 ) where
3131
3232import Data.Generics.Internal.Families
33−import Data.Generics.Product.Internal.HList
34−import Data.Profunctor (Profunctor(..))
33+import Data.Generics.Product.Internal.List
3534
3635import GHC.Generics
3736import GHC.TypeLits (Symbol)
37+import Data.Kind
3838import Data.Generics.Internal.Profunctor.Lens
3939import Data.Generics.Internal.Profunctor.Iso
4040import Data.Generics.Internal.Profunctor.Prism
@@ -47,30 +47,32 @@ class GAsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where
4747type GAsConstructor' ctor s a = GAsConstructor ctor s s a a
4848
4949instance
50− ( GIsList f f as as
51− , GIsList g g bs bs
50+ ( GIsList Type f f as as
51+ , GIsList Type g g bs bs
5252 , ListTuple a as
5353 , ListTuple b bs
5454 ) => GAsConstructor ctor (M1 C ('MetaCons ctor fixity fields) f) (M1 C ('MetaCons ctor fixity fields) g) a b where
5555
56− _GCtor = dimap (listToTuple . view glist . unM1) (M1 . view (fromIso glist) . tupleToList)
57− {-# INLINE[0] _GCtor #-}
56+-- _GCtor = prismP (M1 . gfromCollection . tupleToList) (Right . listToTuple . gtoCollection . unM1)
57+-- {-# INLINE _GCtor #-}
58+ _GCtor = prism (M1 . (view (fromIso (glist @Type))) . tupleToList) (Right . listToTuple . (view (glist @Type)) . unM1)
59+
5860
5961instance GSumAsConstructor ctor (HasCtorP ctor l) l r l' r' a b => GAsConstructor ctor (l :+: r) (l' :+: r') a b where
6062 _GCtor = _GSumCtor @ctor @(HasCtorP ctor l)
61− {-# INLINE[0] _GCtor #-}
63+ {-# INLINE _GCtor #-}
6264
6365instance GAsConstructor ctor f f' a b => GAsConstructor ctor (M1 D meta f) (M1 D meta f') a b where
6466 _GCtor = mIso . _GCtor @ctor
65− {-# INLINE[0] _GCtor #-}
67+ {-# INLINE _GCtor #-}
6668
6769class GSumAsConstructor (ctor :: Symbol) (contains :: Bool) l r l' r' a b | ctor l r -> a, ctor l' r' -> b where
6870 _GSumCtor :: Prism ((l :+: r) x) ((l' :+: r') x) a b
6971
7072instance GAsConstructor ctor l l' a b => GSumAsConstructor ctor 'True l r l' r a b where
7173 _GSumCtor = left . _GCtor @ctor
72− {-# INLINE[0] _GSumCtor #-}
74+ {-# INLINE _GSumCtor #-}
7375
7476instance GAsConstructor ctor r r' a b => GSumAsConstructor ctor 'False l r l r' a b where
7577 _GSumCtor = right . _GCtor @ctor
76− {-# INLINE[0] _GSumCtor #-}
78+ {-# INLINE _GSumCtor #-}
src/Data/Generics/Sum/Internal/Subtype.hs+15−71
@@ -1,10 +1,9 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DataKinds #-}
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE PolyKinds #-}
33{-# LANGUAGE FlexibleContexts #-}
44{-# LANGUAGE FlexibleInstances #-}
55{-# LANGUAGE KindSignatures #-}
66{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE PolyKinds #-}
87{-# LANGUAGE ScopedTypeVariables #-}
98{-# LANGUAGE TypeApplications #-}
109{-# LANGUAGE TypeOperators #-}
@@ -14,7 +13,7 @@
1413-----------------------------------------------------------------------------
1514-- |
1615-- Module : Data.Generics.Sum.Internal.Subtype
17−-- Copyright : (C) 2019 Csongor Kiss
16+-- Copyright : (C) 2017 Csongor Kiss
1817-- License : BSD3
1918-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
2019-- Stability : experimental
@@ -28,14 +27,13 @@ module Data.Generics.Sum.Internal.Subtype
2827 ( GAsSubtype (..)
2928 ) where
3029
31−import Data.Generics.Product.Internal.HList
30+import Data.Generics.Product.Internal.List
3231import Data.Generics.Sum.Internal.Typed
3332
3433import Data.Kind
3534import GHC.Generics
3635import Data.Generics.Internal.Profunctor.Iso
3736import Data.Generics.Internal.Profunctor.Prism
38−import Data.Generics.Internal.Families.Has
3937
4038-- |As 'AsSubtype' but over generic representations as defined by
4139-- "GHC.Generics".
@@ -43,73 +41,19 @@ class GAsSubtype (subf :: Type -> Type) (supf :: Type -> Type) where
4341 _GSub :: Prism' (supf x) (subf x)
4442
4543instance
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 #-}
44+ ( GAsSubtype l supf
45+ , GAsSubtype r supf
46+ ) => GAsSubtype (l :+: r) supf where
47+ _GSub = without' _GSub _GSub . fromIso sumIso
6148
6249instance
63− ( GIsList subf subf as as
50+ ( GIsList () subf subf as as
6451 , 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 #-}
52+ ) => GAsSubtype (C1 meta subf) supf where
53+ _GSub = _GTyped . fromIso (glist @()) . fromIso mIso
7254
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 #-}
55+-- instance GAsType supf a => GAsSubtype (S1 meta (Rec0 a)) supf where
56+-- _GSub = _GTyped . fromIso (mIso . kIso)
11557
58+instance GAsSubtype subf supf => GAsSubtype (D1 meta subf) supf where
59+ _GSub = _GSub . fromIso mIso
src/Data/Generics/Sum/Internal/Typed.hs+8−20
@@ -13,7 +13,7 @@
1313-----------------------------------------------------------------------------
1414-- |
1515-- Module : Data.Generics.Sum.Internal.Typed
16−-- Copyright : (C) 2019 Csongor Kiss
16+-- Copyright : (C) 2017 Csongor Kiss
1717-- License : BSD3
1818-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1919-- Stability : experimental
@@ -29,44 +29,32 @@ module Data.Generics.Sum.Internal.Typed
2929
3030import Data.Kind
3131import GHC.Generics
32−import Data.Tagged
3332
3433import Data.Generics.Internal.Families
35−import Data.Generics.Product.Internal.HList
34+import Data.Generics.Product.Internal.List
3635import Data.Generics.Internal.Profunctor.Iso
3736import Data.Generics.Internal.Profunctor.Prism
3837
3938-- |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−
39+class GAsType (f :: Type -> Type) (as :: [((), Type)]) where
40+ _GTyped :: Prism (f x) (f x) (List as) (List as)
4841
4942instance
50− ( GIsList f f as as
43+ ( GIsList () f f as as
5144 ) => GAsType (M1 C meta f) as where
52− _GTyped = mIso . glist
53− {-# INLINE[0] _GTyped #-}
45+ _GTyped = mIso . glist @()
5446
5547instance GSumAsType (HasPartialTypeP a l) l r a => GAsType (l :+: r) a where
5648 _GTyped = _GSumTyped @(HasPartialTypeP a l)
57− {-# INLINE[0] _GTyped #-}
5849
5950instance GAsType f a => GAsType (M1 D meta f) a where
6051 _GTyped = mIso . _GTyped
61− {-# INLINE[0] _GTyped #-}
6252
63−class GSumAsType (contains :: Bool) l r (a :: [Type]) where
64− _GSumTyped :: Prism ((l :+: r) x) ((l :+: r) x) (HList a) (HList a)
53+class GSumAsType (contains :: Bool) l r (a :: [((), Type)]) where
54+ _GSumTyped :: Prism ((l :+: r) x) ((l :+: r) x) (List a) (List a)
6555
6656instance GAsType l a => GSumAsType 'True l r a where
6757 _GSumTyped = left . _GTyped
68− {-# INLINE[0] _GSumTyped #-}
6958
7059instance GAsType r a => GSumAsType 'False l r a where
7160 _GSumTyped = right . _GTyped
72− {-# INLINE[0] _GSumTyped #-}
src/Data/Generics/Sum/Subtype.hs+10−50
@@ -1,10 +1,8 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE TypeApplications #-}
22{-# LANGUAGE FlexibleContexts #-}
33{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE MonoLocalBinds #-}
54{-# LANGUAGE MultiParamTypeClasses #-}
65{-# LANGUAGE ScopedTypeVariables #-}
7−{-# LANGUAGE TypeApplications #-}
86{-# LANGUAGE TypeOperators #-}
97{-# LANGUAGE TypeSynonymInstances #-}
108{-# LANGUAGE UndecidableInstances #-}
@@ -12,7 +10,7 @@
1210-----------------------------------------------------------------------------
1311-- |
1412-- Module : Data.Generics.Sum.Subtype
15−-- Copyright : (C) 2019 Csongor Kiss
13+-- Copyright : (C) 2017 Csongor Kiss
1614-- License : BSD3
1715-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1816-- Stability : experimental
@@ -43,7 +41,7 @@ import Data.Generics.Internal.Profunctor.Iso
4341-- >>> :set -XDataKinds
4442-- >>> :set -XDeriveGeneric
4543-- >>> import GHC.Generics
46−-- >>> :m +Data.Generics.Internal.VL.Prism
44+-- >>> :m +Data.Generics.Internal.Lens
4745-- >>> :{
4846-- data Animal
4947-- = Dog Dog
@@ -90,18 +88,16 @@ class AsSubtype sub sup where
9088 -- >>> duck ^? _Sub :: Maybe FourLeggedAnimal
9189 -- Nothing
9290 _Sub :: Prism' sup sub
93− _Sub = prism injectSub (\i -> maybe (Left i) Right (projectSub i))
94− {-# INLINE[2] _Sub #-}
91+ _Sub eta = prism injectSub projectSub eta
92+ {-# INLINE _Sub #-}
9593
9694 -- |Injects a subtype into a supertype (upcast).
9795 injectSub :: sub -> sup
98− injectSub
99− = build (_Sub @sub @sup)
96+ injectSub = build (_Sub @sub @sup)
10097
10198 -- |Projects a subtype from a supertype (downcast).
102− projectSub :: sup -> Maybe sub
103− projectSub
104− = either (const Nothing) Just . match (_Sub @sub @sup)
99+ projectSub :: sup -> Either sup sub
100+ projectSub = match (_Sub @sub @sup)
105101
106102 {-# MINIMAL (injectSub, projectSub) | _Sub #-}
107103
@@ -111,48 +107,12 @@ instance
111107 , GAsSubtype (Rep sub) (Rep sup)
112108 ) => AsSubtype sub sup where
113109
114− _Sub f = prismRavel (repIso . _GSub . fromIso repIso) f
115− {-# INLINE[2] _Sub #-}
110+ _Sub = prismRavel (repIso . _GSub . fromIso repIso)
116111
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
112+-- See Note [Uncluttering type signatures]
138113instance {-# OVERLAPPING #-} AsSubtype a Void where
139114 injectSub = undefined
140115 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
156116instance {-# OVERLAPPING #-} AsSubtype Void a where
157117 injectSub = undefined
158118 projectSub = undefined
src/Data/Generics/Sum/Typed.hs+7−43
@@ -1,4 +1,3 @@
1−{-# LANGUAGE CPP #-}
21{-# LANGUAGE TypeApplications #-}
32{-# LANGUAGE AllowAmbiguousTypes #-}
43{-# LANGUAGE DataKinds #-}
@@ -14,7 +13,7 @@
1413-----------------------------------------------------------------------------
1514-- |
1615-- Module : Data.Generics.Sum.Typed
17−-- Copyright : (C) 2019 Csongor Kiss
16+-- Copyright : (C) 2017 Csongor Kiss
1817-- License : BSD3
1918-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
2019-- Stability : experimental
@@ -35,21 +34,19 @@ import Data.Kind
3534import GHC.Generics
3635import GHC.TypeLits (TypeError, ErrorMessage (..), Symbol)
3736import Data.Generics.Sum.Internal.Typed
38−import Data.Generics.Internal.Errors
3937
4038import Data.Generics.Internal.Families
4139import Data.Generics.Internal.Void
42−import Data.Generics.Product.Internal.HList
40+import Data.Generics.Product.Internal.List
4341import Data.Generics.Internal.VL.Prism
4442import Data.Generics.Internal.Profunctor.Iso
45−import Data.Generics.Internal.Profunctor.Prism (prismPRavel)
4643
4744-- $setup
4845-- >>> :set -XTypeApplications
4946-- >>> :set -XDataKinds
5047-- >>> :set -XDeriveGeneric
5148-- >>> import GHC.Generics
52−-- >>> :m +Data.Generics.Internal.VL.Prism
49+-- >>> :m +Data.Generics.Internal.Lens
5350-- >>> :{
5451-- data Animal
5552-- = Dog Dog
@@ -90,8 +87,6 @@ class AsType a s where
9087 -- ... Turtle
9188 -- ...
9289 _Typed :: Prism' s a
93− _Typed = prism injectTyped (\i -> maybe (Left i) Right (projectTyped i))
94− {-# INLINE[2] _Typed #-}
9590
9691 -- |Inject by type.
9792 injectTyped :: a -> s
@@ -101,9 +96,7 @@ class AsType a s where
10196 -- |Project by type.
10297 projectTyped :: s -> Maybe a
10398 projectTyped
104− = either (const Nothing) Just . match _Typed
105−
106− {-# MINIMAL (injectTyped, projectTyped) | _Typed #-}
99+ = either (const Nothing) Just . (match _Typed)
107100
108101instance
109102 ( Generic s
@@ -111,45 +104,16 @@ instance
111104 , as ~ TupleToList a
112105 , ListTuple a as
113106 , 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)
117107 ) => AsType a s where
118108
119− _Typed eta = prismRavel (prismPRavel (repIso . _GTyped @_ @as . tupled)) eta
120− {-# INLINE[2] _Typed #-}
109+ _Typed = prismRavel (repIso . _GTyped @_ @as . tupled)
110+ {-# INLINE _Typed #-}
121111
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
112+-- See Note [Uncluttering type signatures]
134113instance {-# OVERLAPPING #-} AsType a Void where
135114 _Typed = undefined
136115 injectTyped = undefined
137116 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
153117instance {-# OVERLAPPING #-} AsType Void a where
154118 _Typed = undefined
155119 injectTyped = undefined
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−resolver: nightly-2018-08-09
1+resolver: lts-10.3
22
33packages:
44- '.'
55
6+extra-deps:
7+- 'inspection-testing-0.2'
8+
69flags: {}
710
811extra-package-dbs: []
test/Test24.hs → test/24.hsrenamed+1−1
@@ -1,6 +1,6 @@
11{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications #-}
22
3−module Test24 where
3+module Main where
44
55-- Test case from #24, comments preserved
66import Control.Lens
test/Test25.hs → test/25.hsrenamed+1−1
@@ -4,7 +4,7 @@
44{-# LANGUAGE DeriveGeneric #-}
55{-# OPTIONS_GHC -Wall #-}
66
7−module Test25 where
7+module Main where
88
99import Control.Lens
1010import Data.Generics.Product
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+17−133
@@ -1,8 +1,7 @@
11{-# OPTIONS_GHC -O -fplugin Test.Inspection.Plugin #-}
2−{-# OPTIONS_GHC -dsuppress-all #-}
2+{-# OPTIONS_GHC -dsuppress-all #-}
33
44{-# LANGUAGE AllowAmbiguousTypes #-}
5−{-# LANGUAGE CPP #-}
65{-# LANGUAGE DataKinds #-}
76{-# LANGUAGE DeriveGeneric #-}
87{-# LANGUAGE DuplicateRecordFields #-}
@@ -11,7 +10,6 @@
1110{-# LANGUAGE ScopedTypeVariables #-}
1211{-# LANGUAGE TypeApplications #-}
1312{-# LANGUAGE TemplateHaskell #-}
14−{-# LANGUAGE OverloadedLabels #-}
1513
1614module Main where
1715
@@ -25,15 +23,6 @@ import System.Exit
2523import Data.Generics.Internal.VL.Lens
2624import Data.Generics.Internal.VL.Prism
2725import 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)
3726
3827main :: IO ()
3928main = do
@@ -70,6 +59,8 @@ data Record5 = MkRecord5
7059 , fieldF :: Int
7160 } deriving Generic
7261
62+
63+
7364typeChangingManual :: Lens (Record3 a) (Record3 b) a b
7465typeChangingManual f (MkRecord3 a b) = (\a' -> MkRecord3 a' b) <$> f a
7566
@@ -97,36 +88,6 @@ subtypeLensManual f record
9788data Sum1 = A Char | B Int | C () | D () deriving (Generic, Show)
9889data Sum2 = A2 Char | B2 Int deriving (Generic, Show)
9990
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−
13091sum1PrismManual :: Prism Sum1 Sum1 Int Int
13192sum1PrismManual eta = prism g f eta
13293 where
@@ -135,42 +96,14 @@ sum1PrismManual eta = prism g f eta
13596 s -> Left s
13697 g = B
13798
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
16699subtypePrismManual :: Prism Sum1 Sum1 Sum2 Sum2
167100subtypePrismManual eta = prism g f eta
168101 where
169102 f s1 = case s1 of
170103 A c -> Right (A2 c)
171104 B i -> Right (B2 i)
172− C _ -> Left s1
173− D _ -> Left s1
105+ C _ -> Left s1
106+ D _ -> Left s1
174107 g (A2 c) = A c
175108 g (B2 i) = B i
176109
@@ -185,32 +118,23 @@ subtypePrismManual eta = prism g f eta
185118fieldALensName :: Lens' Record Int
186119fieldALensName = field @"fieldA"
187120
188−fieldALensName_ :: Lens' Record Int
189−fieldALensName_ = field_ @"fieldA"
190−
191121fieldALensType :: Lens' Record Int
192122fieldALensType = typed @Int
193123
194124fieldALensPos :: Lens' Record Int
195125fieldALensPos = position @1
196126
197−fieldALensPos_ :: Lens' Record Int
198−fieldALensPos_ = position_ @1
199−
200127subtypeLensGeneric :: Lens' Record Record2
201128subtypeLensGeneric = super
202129
203130typeChangingGeneric :: Lens (Record3 a) (Record3 b) a b
204−typeChangingGeneric = #fieldA
131+typeChangingGeneric = field @"fieldA"
205132
206133typeChangingGenericPos :: Lens (Record3 a) (Record3 b) a b
207134typeChangingGenericPos = position @1
208135
209136typeChangingGenericCompose :: 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"
137+typeChangingGenericCompose = field @"fieldA" . field @"fieldA"
214138
215139sum1PrismB :: Prism Sum1 Sum1 Int Int
216140sum1PrismB = _Ctor @"B"
@@ -221,56 +145,16 @@ subtypePrismGeneric = _Sub
221145sum1TypePrism :: Prism Sum1 Sum1 Int Int
222146sum1TypePrism = _Typed @Int
223147
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−
239148tests :: Test
240149tests = 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)
150+ [ $(inspectTest $ 'fieldALensManual === 'fieldALensName)
151+ , $(inspectTest $ 'fieldALensManual === 'fieldALensType)
152+ , $(inspectTest $ 'fieldALensManual === 'fieldALensPos)
153+ , $(inspectTest $ 'subtypeLensManual === 'subtypeLensGeneric)
154+ , $(inspectTest $ 'typeChangingManual === 'typeChangingGeneric)
155+ , $(inspectTest $ 'typeChangingManual === 'typeChangingGenericPos)
249156 , $(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
157+ , $(inspectTest $ 'intTraversalManual === 'intTraversalDerived)
158+ , $(inspectTest $ 'sum1PrismManual === 'sum1PrismB)
159+ , $(inspectTest $ 'subtypePrismManual === 'subtypePrismGeneric)
160+ , $(inspectTest $ 'sum1PrismManual === 'sum1TypePrism) ]
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/doctest.hs−1
@@ -4,5 +4,4 @@ main
44 [ "-isrc"
55 , "src/Data/Generics/Product.hs"
66 , "src/Data/Generics/Sum.hs"
7− , "src/Data/Generics/Labels.hs"
87 ]
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 _ = []