on 06ea165 help sign in
70 files changed+1586−4110
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−1 examples/Biscuits.hs−150 examples/Examples.hs+1−6 examples/doctest.hs−7 generic-lens.cabal+24−70 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/Lens.hs+515 src/Data/Generics/Internal/Profunctor/Iso.hs−111 src/Data/Generics/Internal/Profunctor/Lens.hs−171 src/Data/Generics/Internal/Profunctor/Prism.hs−117 src/Data/Generics/Internal/VL/Iso.hs−80 src/Data/Generics/Internal/VL/Lens.hs−70 src/Data/Generics/Internal/VL/Prism.hs−74 src/Data/Generics/Internal/VL/Traversal.hs−92 src/Data/Generics/Labels.hs+17−123 src/Data/Generics/Product.hs+3−8 src/Data/Generics/Product/Any.hs+5−5 src/Data/Generics/Product/Constraints.hs−57 src/Data/Generics/Product/Fields.hs+30−96 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+53 src/Data/Generics/Product/Internal/List.hs+344 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+28−124 src/Data/Generics/Product/Subtype.hs+8−49 src/Data/Generics/Product/Typed.hs+10−38 src/Data/Generics/Product/Types.hs+14−333 src/Data/Generics/Sum.hs+1−1 src/Data/Generics/Sum/Any.hs+5−5 src/Data/Generics/Sum/Constructors.hs+20−91 src/Data/Generics/Sum/Internal/Constructors.hs+14−14 src/Data/Generics/Sum/Internal/Subtype.hs+16−73 src/Data/Generics/Sum/Internal/Typed.hs+9−22 src/Data/Generics/Sum/Subtype.hs+12−53 src/Data/Generics/Sum/Typed.hs+18−48 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+47−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
@@ -1,2 +1,2 @@
11packages: generic-lens.cabal
2−write-ghc-environment-files: always
2+optional-packages: inspection-testing/inspection-testing.cabal
examples/Biscuits.hsdeleted−150
@@ -1,150 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE DuplicateRecordFields #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE NoMonomorphismRestriction #-}
6−{-# LANGUAGE TypeApplications #-}
7−
8−module Main where
9−
10−import Control.Lens
11−import Data.Maybe (maybeToList)
12−import Data.Generics.Product
13−import Data.Generics.Sum
14−import GHC.Generics (Generic)
15−
16−-- $setup
17−--
18−-- >>> :set -XTypeApplications
19−-- >>> :set -XDataKinds
20−-- >>> :set -XFlexibleContexts
21−
22−main :: IO ()
23−main = putStrLn "hello"
24−
25−data Item = Item
26− { name :: String
27− , cost :: Cost
28− } deriving (Generic, Show)
29−
30−newtype Cost = Cost Double deriving (Generic, Show)
31−
32−data Invoice p = Invoice
33− { item :: Item
34− , name :: String
35− , number :: Int
36− , priority :: p
37− } deriving (Generic, Show)
38−
39−data Orders = Orders [ Invoice Int ] [ Invoice (Int, Double) ]
40− deriving (Generic, Show)
41−
42−-- |
43−-- >>> view (field @"name") bourbon
44−-- "Bourbon"
45−-- >>> bourbon & field @"cost" .~ Cost 110
46−-- Item {name = "Bourbon", cost = Cost 110.0}
47−--
48−-- >>> bourbon & field @"cost" %~ (\(Cost c) -> (Cost (c + 5)))
49−-- Item {name = "Bourbon", cost = Cost 105.0}
50−--
51−-- >>> Invoice bourbon "Johnny" 2 2 & field @"priority" %~ (\i -> (i, 0))
52−-- Invoice {item = Item {name = "Bourbon", cost = Cost 100.0}, name = "Johnny", number = 2, priority = (2,0)}
53−--
54−-- >>> view (field @"weight") bourbon
55−-- ...
56−-- ... The type Item does not contain a field named 'weight'.
57−-- ...
58−--
59−-- >>> bourbon & typed @Cost .~ Cost 200
60−-- Item {name = "Bourbon", cost = Cost 200.0}
61−--
62−-- >>> bourbon & typed %~ ("Chocolate " ++)
63−-- Item {name = "Chocolate Bourbon", cost = Cost 100.0}
64−--
65−-- >>> view (position @1) (42, "foo")
66−-- 42
67−-- >>> view (position @1) (42, "foo", False)
68−-- 42
69−-- >>> view (position @2) orders
70−-- [Invoice {item = Item {name = "Bourbon", cost = Cost 100.0}, name = "George", number = 2, priority = (0,3.0)}]
71−--
72−-- >>> view (position @2) orders
73−-- [Invoice {item = Item {name = "Bourbon", cost = Cost 100.0}, name = "George", number = 2, priority = (0,3.0)}]
74−--
75−-- >>> view (position @3) orders
76−-- ...
77−-- ... The type Orders does not contain a field at position 3
78−-- ...
79−--
80−-- >>> view (super @Item) (WItem "Bourbon" (Cost 2000) (Weight 0.03))
81−-- Item {name = "Bourbon", cost = Cost 2000.0}
82−--
83−-- >>> (WItem "Bourbon+" (Cost 500) (Weight 0.03)) & super @Item .~ bourbon
84−-- WItem {name = "Bourbon", cost = Cost 100.0, weight = Weight 3.0e-2}
85−--
86−-- >>> DInt 1 ^? _Ctor @"DInt"
87−-- Just 1
88−--
89−-- >>> _Typed # (False, "wurble") :: D
90−-- DPair False "wurble"
91−--
92−-- >>> EChar 'a' ^? _Sub @D
93−-- Nothing
94−--
95−-- >>> _Sub # DInt 10 :: E
96−-- EInt 10
97−bourbon :: Item
98−bourbon = Item "Bourbon" (Cost 100)
99−
100−orders :: Orders
101−orders = Orders [Invoice bourbon "Earl" 1 0 , Invoice bourbon "Johnny" 2 2]
102− [Invoice bourbon "George" 2 (0, 3)]
103−
104−nameOfItem :: Invoice p -> String
105−nameOfItem = view (field @"item" . field @"name")
106−
107−thankYou :: Orders -> Orders
108−thankYou = over (types @Cost) (\(Cost c) -> Cost (c * 0.85))
109−
110−thankYouPriority :: Orders -> Orders
111−thankYouPriority = over (position @2 . types @Cost) (\(Cost c) -> Cost (c * 0.85))
112−
113−upgrade :: Double -> Invoice Int -> Invoice (Int, Double)
114−upgrade bribe invoice = over (param @0) (\i -> (i, bribe)) invoice
115−
116−audit :: Orders -> [Item]
117−audit = toListOf (types @Item)
118−
119−newtype Weight = Weight Double deriving (Generic, Show)
120−data WeighedItem = WItem
121− { name :: String
122− , cost :: Cost
123− , weight :: Weight
124− } deriving (Generic, Show)
125−
126−data D = DInt Int | DPair Bool String
127− deriving (Generic, Show)
128−
129−data E = EInt Int | EPair Bool String | EChar Char
130− deriving (Generic, Show)
131−
132−costInc :: HasTypes t Cost => t -> t
133−costInc = over (types @Cost) (\(Cost c) -> Cost (c + 5))
134−
135−modifyPriority :: (Int -> Int) -> Invoice Int -> Invoice Int
136−modifyPriority = over (types @Int)
137−
138−treeIncParam :: HasParam 0 s s Int Int => s -> s
139−treeIncParam = over (param @0) (+ 1)
140−
141−instance Functor Invoice where
142− fmap = over (param @0)
143−
144−data Numbers = Numbers Int Float Double
145− deriving (Show, Generic)
146−
147−-- |
148−-- >>> constraints' @Num (\x -> pure (x + 20)) numbers
149−-- Numbers 30 40.0 50.0
150−numbers = Numbers 10 20.0 30.0
examples/Examples.hs+1−6
@@ -17,16 +17,11 @@
1717module Examples where
1818
1919import Data.Function ((&))
20−import Data.Generics.Internal.VL.Lens
20+import Data.Generics.Internal.Lens
2121import Data.Generics.Product
2222import Data.Generics.Sum
2323import GHC.Generics
2424import Data.Generics.Labels
25−import Data.Generics.Internal.VL.Iso
26−import Data.Generics.Internal.VL.Prism
27−import Data.Generics.Internal.Profunctor.Lens
28−import Data.Generics.Internal.Profunctor.Iso
29−import Data.Generics.Internal.Profunctor.Prism
3025
3126data Animal = Animal
3227 { name :: String
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+24−70
@@ -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,40 +23,26 @@ 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
4237 , Data.Generics.Sum.Constructors
4338 , Data.Generics.Sum.Typed
4439 , Data.Generics.Sum.Subtype
45− , Data.Generics.Internal.Profunctor.Lens
46− , Data.Generics.Internal.Profunctor.Prism
47− , Data.Generics.Internal.Profunctor.Iso
48− , Data.Generics.Internal.VL.Lens
49− , Data.Generics.Internal.VL.Traversal
50− , Data.Generics.Internal.VL.Prism
51− , Data.Generics.Internal.VL.Iso
52−
53− , Data.GenericLens.Internal
40+ , Data.Generics.Internal.Lens
5441
5542 other-modules: Data.Generics.Internal.Families
5643 , Data.Generics.Internal.Families.Changing
5744 , Data.Generics.Internal.Families.Collect
5845 , Data.Generics.Internal.Families.Has
59− , Data.Generics.Internal.Errors
6046 , Data.Generics.Internal.Void
6147
6248 , Data.Generics.Sum.Internal.Constructors
@@ -64,92 +50,68 @@ library
6450 , Data.Generics.Sum.Internal.Subtype
6551
6652 , Data.Generics.Product.Internal.Positions
67− , Data.Generics.Product.Internal.GLens
6853 , Data.Generics.Product.Internal.Subtype
6954
70− , Data.Generics.Product.Internal.Constraints
71− , Data.Generics.Product.Internal.HList
55+ , Data.Generics.Product.Internal.Types
56+ , Data.Generics.Product.Internal.List
57+ , Data.Generics.Product.Internal.Keyed
7258
73− build-depends: base >= 4.9 && < 5
74− , profunctors >= 5.0 && < 6.0
75− , tagged >= 0.8 && < 1
76− , text >= 1.2 && < 1.3
59+ build-depends: base >= 4.9 && <= 5.0
60+ , profunctors >= 5.0 && <= 6.0
61+ , tagged >= 0.8 && <= 0.9
7762
7863 hs-source-dirs: src
7964 default-language: Haskell2010
8065 ghc-options: -Wall
81−-- if flag(dump-core)
82−-- build-depends: dump-core
83−-- ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
66+ if flag(dump-core)
67+ build-depends: dump-core
68+ ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
8469
8570source-repository head
8671 type: git
8772 location: https://github.com/kcsongor/generic-lens
8873
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−
10274test-suite generic-lens-test
10375 type: exitcode-stdio-1.0
10476 hs-source-dirs: test
10577 main-is: Spec.hs
106− other-modules: Util Test24 Test25 Test40 Test62 Test63 CustomChildren
78+ other-modules: Util
10779
10880 build-depends: base >= 4.9 && <= 5.0
10981 , generic-lens
110− , lens
11182 , profunctors
11283 , inspection-testing >= 0.2
11384 , HUnit
11485
11586 default-language: Haskell2010
116− ghc-options: -Wall
87+ ghc-options: -Wall -O2 -dsuppress-all
11788 if flag(dump-core)
11889 build-depends: dump-core
11990 ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
12091
121−test-suite generic-lens-bifunctor
92+test-suite generic-lens-test-25
12293 type: exitcode-stdio-1.0
12394 hs-source-dirs: test
124− main-is: Bifunctor.hs
95+ main-is: 25.hs
12596
12697 build-depends: base >= 4.9 && <= 5.0
12798 , generic-lens
12899 , lens
129− , HUnit
130100
131101 default-language: Haskell2010
132102 ghc-options: -Wall
133− if flag(dump-core)
134− build-depends: dump-core
135− ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
136103
137−test-suite generic-lens-syb-tree
104+test-suite generic-lens-test-24
138105 type: exitcode-stdio-1.0
139− hs-source-dirs: test/syb
140− main-is: Tree.hs
106+ hs-source-dirs: test
107+ main-is: 24.hs
141108
142109 build-depends: base >= 4.9 && <= 5.0
143110 , generic-lens
144111 , lens
145− , profunctors
146− , HUnit
147112
148113 default-language: Haskell2010
149114 ghc-options: -Wall
150− if flag(dump-core)
151− build-depends: dump-core
152− ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
153115
154116test-suite doctests
155117 default-language: Haskell2010
@@ -159,14 +121,6 @@ test-suite doctests
159121 build-depends: base >4 && <5, doctest
160122 hs-source-dirs: test
161123
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−
170124benchmark generic-lens-bench
171125 type: exitcode-stdio-1.0
172126 hs-source-dirs: benchmarks
@@ -176,7 +130,7 @@ benchmark generic-lens-bench
176130
177131 , base >= 4.9 && <= 5.0
178132 , QuickCheck
179− , criterion >= 1.3.0.0
133+ , criterion
180134 , deepseq
181135 , lens
182136
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/Lens.hsnew file+515
@@ -0,0 +1,515 @@
1+{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE LambdaCase #-}
3+{-# LANGUAGE Rank2Types #-}
4+{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE TypeFamilyDependencies #-}
6+{-# LANGUAGE TypeOperators #-}
7+{-# LANGUAGE TupleSections #-}
8+{-# LANGUAGE NoMonomorphismRestriction #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+
11+-----------------------------------------------------------------------------
12+-- |
13+-- Module : Data.Generics.Internal.Lens
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+-- Internal lens helpers. Only exported for Haddock
21+--
22+-----------------------------------------------------------------------------
23+module Data.Generics.Internal.Lens where
24+
25+import Control.Applicative (Const(..))
26+import Data.Functor.Identity (Identity(..))
27+import Data.Monoid (First (..))
28+import Data.Profunctor (Choice(..), Profunctor(..), Strong(..))
29+import Data.Bifunctor
30+import Data.Profunctor.Unsafe ((#.), (.#))
31+import Data.Tagged
32+import GHC.Generics ((:*:)(..), (:+:)(..), Generic(..), M1(..), K1(..), Rep)
33+import Data.Coerce
34+
35+-- | Type alias for lens
36+type LensVL' s a
37+ = Lens s s a a
38+
39+type LensVL s t a b
40+ = forall f. Functor f => (a -> f b) -> s -> f t
41+
42+type Lens s t a b
43+ = forall p . (Strong p) => p a b -> p s t
44+
45+-- | Type alias for traversal
46+type Traversal' s a
47+ = forall f. Applicative f => (a -> f a) -> s -> f s
48+
49+type Traversal s t a b
50+ = forall f. Applicative f => (a -> f b) -> s -> f t
51+
52+type LensLike p s t a b
53+ = p a b -> p s t
54+
55+-- | Type alias for prism
56+type PrismVL s t a b
57+ = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)
58+
59+type Prism s t a b
60+ = forall p . (Choice p) => p a b -> p s t
61+
62+type Prism' s a = forall p . (Choice p) => p a a -> p s s
63+
64+type PrismVL' s a
65+ = PrismVL s s a a
66+
67+type IsoVL' s a
68+ = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s)
69+
70+type IsoVL s t a b
71+ = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
72+
73+type Iso s t a b
74+ = forall p. (Profunctor p) => p a b -> p s t
75+
76+type Iso' s a = Iso s s a a
77+
78+-- | Getting
79+(^.) :: s -> ((a -> Const a a) -> s -> Const a s) -> a
80+s ^. l = getConst (l Const s)
81+infixl 8 ^.
82+
83+-- | Setting
84+set :: ((a -> b) -> s -> t) -> (s, b) -> t
85+set f (s, b)
86+ = f (const b) s
87+
88+viewVL :: ((a -> Const a a) -> s -> Const a s) -> s -> a
89+viewVL l s = (^.) s l
90+
91+viewVL' :: ((a -> Const a a) -> s -> Const a s) -> s -> a
92+viewVL' l s = (^.) s l
93+
94+setVL :: LensVL s t a b -> b -> s -> t
95+setVL l x = runIdentity . (l (Identity . const x))
96+
97+
98+view :: Lens s s a a -> s -> a
99+view l = withLens l (\get _ -> get)
100+
101+withLens :: Lens s t a b -> ((s -> a) -> ((s, b) -> t) -> r) -> r
102+withLens l k =
103+ case l idLens of
104+ ALens get set -> k get set
105+
106+idLens :: ALens a b a b
107+idLens = ALens id snd
108+
109+infixr 4 .~
110+(.~) :: ((a -> b) -> s -> t) -> b -> s -> t
111+(.~) f b s = set f (s, b)
112+
113+infixl 8 ^?
114+(^?) :: s -> ((a -> Const (First a) a) -> s -> Const (First a) s) -> Maybe a
115+s ^? l = getFirst (fmof l (First #. Just) s)
116+ where fmof l' f = getConst #. l' (Const #. f)
117+
118+buildVL :: (Tagged b (Identity b) -> Tagged t (Identity t)) -> b -> t
119+buildVL p = runIdentity #. unTagged #. p .# Tagged .# Identity
120+
121+matchVL :: PrismVL s t a b -> s -> Either t a
122+matchVL k = withPrismVL k $ \_ match -> match
123+
124+
125+
126+build :: (Tagged b b -> Tagged t t) -> b -> t
127+build p = unTagged . p . Tagged
128+
129+
130+-- | Lens focusing on the first element of a product
131+first :: Lens ((a :*: b) x) ((a' :*: b) x) (a x) (a' x)
132+first
133+ = lens (\(a :*: b) -> a) (\((a :*: b), a') -> a' :*: b)
134+
135+-- | Lens focusing on the second element of a product
136+second :: Lens ((a :*: b) x) ((a :*: b') x) (b x) (b' x)
137+second
138+ = lens (\(a :*: b) -> b) (\((a :*: b), b') -> a :*: b')
139+
140+left :: Prism ((a :+: c) x) ((b :+: c) x) (a x) (b x)
141+left = prism L1 $ gsum Right (Left . R1)
142+
143+right :: Prism ((a :+: b) x) ((a :+: c) x) (b x) (c x)
144+right = prism R1 $ gsum (Left . L1) Right
145+
146+gsum :: (a x -> c) -> (b x -> c) -> ((a :+: b) x) -> c
147+gsum f _ (L1 x) = f x
148+gsum _ g (R1 y) = g y
149+
150+prismVL :: (b -> t) -> (s -> Either t a) -> PrismVL s t a b
151+prismVL bt seta eta = dimap (\x -> plus pure id (seta x)) (either id (\x -> fmap bt x)) (right' eta)
152+{-# INLINE prismVL #-}
153+
154+prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
155+prism bt seta eta = dimap seta (either id bt) (right' eta)
156+
157+plus :: (a -> b) -> (c -> d) -> Either a c -> Either b d
158+plus f _ (Left x) = Left (f x)
159+plus _ g (Right y) = Right (g y)
160+
161+fork :: (a -> b) -> (a -> c) -> a -> (b, c)
162+fork f g a = (f a, g a)
163+
164+swap :: (a, b) -> (b, a)
165+swap (a, b) = (b, a)
166+
167+cross :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
168+cross = bimap
169+
170+-- | A type and its generic representation are isomorphic
171+repIsoVL :: (Generic a, Generic b) => IsoVL a b (Rep a x) (Rep b x)
172+repIsoVL = isoVL from to
173+
174+repLens :: (Generic a, Generic b) => Lens a b (Rep a x) (Rep b x)
175+repLens f = repIso f
176+
177+-- | A type and its generic representation are isomorphic
178+repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
179+repIso = iso from to
180+
181+
182+
183+-- | 'M1' is just a wrapper around `f p`
184+mIsoVL :: IsoVL (M1 i c f p) (M1 i c g p) (f p) (g p)
185+mIsoVL = isoVL unM1 M1
186+
187+-- | 'M1' is just a wrapper around `f p`
188+--mIso :: Iso' (M1 i c f p) (f p)
189+mIso :: Iso (M1 i c f p) (M1 i c g p) (f p) (g p)
190+mIso = iso unM1 M1
191+
192+-- These are specialised versions of the Isos above. On GHC 8.0.2, having
193+-- these functions eta-expanded allows the optimiser to inline these functions.
194+mLens :: Lens (M1 i c f p) (M1 i c g p) (f p) (g p)
195+mLens f = mIso f
196+
197+kIso :: Iso (K1 r a p) (K1 r b p) a b
198+kIso = iso unK1 K1
199+
200+sumIso :: Iso ((a :+: b) x) ((a' :+: b') x) (Either (a x) (b x)) (Either (a' x) (b' x))
201+sumIso = iso back forth
202+ where forth (Left l) = (L1 l)
203+ forth (Right r) = (R1 r)
204+ back (L1 l) = (Left l)
205+ back (R1 r) = (Right r)
206+
207+_Left :: Prism (Either a c) (Either b c) a b
208+_Left = prism Left $ either Right (Left . Right)
209+
210+_Right :: Prism (Either c a) (Either c b) a b
211+_Right = prism Right $ either (Left . Left) Right
212+
213+--------------------------------------------------------------------------------
214+
215+data Coyoneda f b = forall a. Coyoneda (a -> b) (f a)
216+
217+instance Functor (Coyoneda f) where
218+ fmap f (Coyoneda g fa)
219+ = Coyoneda (f . g) fa
220+
221+inj :: Functor f => Coyoneda f a -> f a
222+inj (Coyoneda f a) = fmap f a
223+
224+proj :: Functor f => f a -> Coyoneda f a
225+proj fa = Coyoneda id fa
226+
227+lens2lensvl :: ALens a b s t -> LensVL s t a b
228+lens2lensvl (ALens get set) = lensVL get set
229+
230+ravel :: (ALens a b a b -> ALens a b s t)
231+ -> LensVL s t a b
232+ravel l pab = (lens2lensvl $ l idLens) pab
233+
234+prismPRavel ::
235+ (Market a b a b -> Market a b s t)
236+ -> Prism s t a b
237+prismPRavel l pab = (prism2prismp $ l idPrism) pab
238+
239+prismVLRavel ::
240+ (Market a b a b -> Market a b s t)
241+ -> PrismVL s t a b
242+prismVLRavel l pab = (prism2prismvl $ l idPrism) pab
243+
244+newtype Alongside p s t a b = Alongside { getAlongside :: p (s, a) (t, b) }
245+
246+instance Profunctor p => Profunctor (Alongside p c d) where
247+ dimap f g (Alongside pab) = Alongside $ dimap (fmap f) (fmap g) pab
248+
249+instance Strong p => Strong (Alongside p c d) where
250+ second' (Alongside pab) = Alongside . dimap shuffle shuffle . second' $ pab
251+ where
252+ shuffle (x,(y,z)) = (y,(x,z))
253+
254+(??) :: Functor f => f (a -> b) -> a -> f b
255+fab ?? a = fmap ($ a) fab
256+
257+-- Could implement this using primitives?
258+alongside :: Profunctor p =>
259+ LensLike (Alongside p s' t') s t a b
260+ -> LensLike (Alongside p a b) s' t' a' b'
261+ -> LensLike p (s, s') (t, t') (a, a') (b, b')
262+alongside l1 l2
263+ = dimap swap swap . getAlongside . l1 . Alongside . dimap swap swap . getAlongside . l2 . Alongside
264+
265+prodIsoVL :: IsoVL ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
266+prodIsoVL = isoVL (\(a :*: b) -> (a, b)) (\(a, b) -> (a :*: b))
267+
268+prodIso :: Iso ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
269+prodIso = iso (\(a :*: b) -> (a, b)) (\(a, b) -> (a :*: b))
270+
271+prodL :: Lens ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
272+prodL f = prodIso f
273+
274+prodR :: Lens (a' x, b' x) (a x, b x) ((a' :*: b') x) ((a :*: b) x)
275+prodR f = fromIso prodIso f
276+
277+assoc3 :: Iso ((a, b), c) ((a', b'), c') (a, (b, c)) (a', (b', c'))
278+assoc3 = iso (\((a, b), c) -> (a, (b, c))) (\(a, (b, c)) -> ((a, b), c))
279+
280+assoc3L :: Lens ((a, b), c) ((a', b'), c') (a, (b, c)) (a', (b', c'))
281+assoc3L f = assoc3 f
282+
283+assoc3R :: Lens (a', (b', c')) (a, (b, c)) ((a', b'), c') ((a, b), c)
284+assoc3R f = fromIso assoc3 f
285+
286+stron :: (Either s s', b) -> Either (s, b) (s', b)
287+stron (e, b) = bimap (,b) (, b) e
288+
289+choosing :: forall s t a b s' t' . Lens s t a b -> Lens s' t' a b -> Lens (Either s s') (Either t t') a b
290+choosing l r = withLens l (\getl setl ->
291+ withLens r (\getr setr ->
292+ let g :: Either s s' -> a
293+ g = either getl getr
294+ s = bimap setl setr . stron
295+ in lens g s))
296+
297+lens :: (s -> a) -> ((s,b) -> t) -> Lens s t a b
298+lens get set = dimap (fork id get) set . second'
299+
300+lensVL :: (s -> a) -> ((s, b) -> t) -> LensVL s t a b
301+lensVL get set f x = curry set x <$> f (get x)
302+
303+--------------------------------------------------------------------------------
304+-- Iso stuff
305+
306+data Exchange a b s t = Exchange (s -> a) (b -> t)
307+
308+instance Functor (Exchange a b s) where
309+ fmap f (Exchange sa bt) = Exchange sa (f . bt)
310+ {-# INLINE fmap #-}
311+
312+instance Profunctor (Exchange a b) where
313+ dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt)
314+ {-# INLINE dimap #-}
315+ lmap f (Exchange sa bt) = Exchange (sa . f) bt
316+ {-# INLINE lmap #-}
317+ rmap f (Exchange sa bt) = Exchange sa (f . bt)
318+ {-# INLINE rmap #-}
319+ ( #. ) _ = coerce
320+ {-# INLINE ( #. ) #-}
321+ ( .# ) p _ = coerce p
322+ {-# INLINE ( .# ) #-}
323+
324+fromIso :: Iso s t a b -> Iso b a t s
325+fromIso l = withIso l $ \ sa bt -> iso bt sa
326+{-# INLINE fromIso #-}
327+
328+isoVL :: (s -> a) -> (b -> t) -> IsoVL s t a b
329+isoVL sa bt = dimap sa (fmap bt)
330+{-# INLINE iso #-}
331+
332+iso :: (s -> a) -> (b -> t) -> Iso s t a b
333+iso = dimap
334+
335+withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
336+withIso ai k = case ai (Exchange id id) of
337+ Exchange sa bt -> k sa bt
338+
339+pairing :: Iso s t a b -> Iso s' t' a' b' -> Iso (s, s') (t, t') (a, a') (b, b')
340+pairing f g = withIso f $ \ sa bt -> withIso g $ \s'a' b't' ->
341+ iso (bmap sa s'a') (bmap bt b't')
342+ where bmap f' g' (a, b) = (f' a, g' b)
343+
344+--------------------------------------------------------------------------------
345+-- Prism stuff
346+
347+type APrism s t a b = Market a b a b -> Market a b s t
348+type APrismVL s t a b = Market a b a (Identity b) -> Market a b s (Identity t)
349+
350+-- without :: APrism s t a b
351+-- -> APrism u v c d
352+-- -> Prism (Either s u) (Either t v) (Either a c) (Either b d)
353+-- without k =
354+-- withPrism k $ \bt seta k' ->
355+-- withPrism k' $ \dv uevc ->
356+-- prism (bimapE bt dv) $ \su ->
357+-- case su of
358+-- Left s -> bimapE Left Left (seta s)
359+-- Right u -> bimapE Right Right (uevc u)
360+-- where bimapE :: (a -> b) -> (c -> d) -> Either a c -> Either b d
361+-- bimapE f _ (Left a) = Left (f a)
362+-- bimapE _ g (Right a) = Right (g a)
363+-- {-# INLINE bimapE #-}
364+
365+without' :: Prism s t a b -> Prism s t c d -> Prism s t (Either a c) (Either b d)
366+without' k =
367+ withPrism k $ \bt _ k' ->
368+ withPrism k' $ \dt setc ->
369+ prism (foldEither bt dt) $ \s -> fmap Right (setc s)
370+ where foldEither _ g (Right r) = g r
371+ foldEither f _ (Left l) = f l
372+
373+withPrism :: APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
374+withPrism k f = case k idPrism of
375+ Market bt seta -> f bt seta
376+
377+withPrismVL :: APrismVL s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
378+withPrismVL k f = case coerce (k (Market Identity Right)) of
379+ Market bt seta -> f bt seta
380+
381+--------------------------------------------------------------------------------
382+-- Market
383+
384+data Market a b s t = Market (b -> t) (s -> Either t a)
385+
386+instance Functor (Market a b s) where
387+ fmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)
388+ {-# INLINE fmap #-}
389+
390+instance Profunctor (Market a b) where
391+ dimap f g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta . f)
392+ {-# INLINE dimap #-}
393+ lmap f (Market bt seta) = Market bt (seta . f)
394+ {-# INLINE lmap #-}
395+ rmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)
396+ {-# INLINE rmap #-}
397+ ( #. ) _ = coerce
398+ {-# INLINE ( #. ) #-}
399+ ( .# ) p _ = coerce p
400+ {-# INLINE ( .# ) #-}
401+
402+instance Choice (Market a b) where
403+ left' (Market bt seta) = Market (Left . bt) $ \sc -> case sc of
404+ Left s -> case seta s of
405+ Left t -> Left (Left t)
406+ Right a -> Right a
407+ Right c -> Left (Right c)
408+ {-# INLINE left' #-}
409+
410+prism2prismp :: Market a b s t -> Prism s t a b
411+prism2prismp (Market bt seta) = prism bt seta
412+
413+prism2prismvl :: Market a b s t -> PrismVL s t a b
414+prism2prismvl (Market bt seta) = prismVL bt seta
415+{-# INLINE prism2prismvl #-}
416+
417+idPrism :: Market a b a b
418+idPrism = Market id Right
419+
420+------------------------------------------------------------------------------
421+
422+data ALens a b s t = ALens (s -> a) ((s, b) -> t)
423+
424+instance Functor (ALens a b s) where
425+ fmap f (ALens get set) = ALens get (f . set)
426+
427+instance Profunctor (ALens a b) where
428+ dimap f g (ALens get set) = ALens (get . f) (g . set . cross f id)
429+
430+instance Strong (ALens a b) where
431+ second' (ALens get set) = ALens (get . snd) (bimap id set . assoc)
432+ where
433+ assoc ((a, b), c) = (a, (b, c))
434+
435+newtype Curried f a =
436+ Curried { runCurried :: forall r. f (a -> r) -> f r }
437+
438+instance Functor f => Functor (Curried f) where
439+ fmap f (Curried g) = Curried (g . fmap (.f))
440+ {-# INLINE fmap #-}
441+
442+instance (Functor f) => Applicative (Curried f) where
443+ pure a = Curried (fmap ($ a))
444+ {-# INLINE pure #-}
445+ Curried mf <*> Curried ma = Curried (ma . mf . fmap (.))
446+ {-# INLINE (<*>) #-}
447+
448+-- | The natural isomorphism between @f@ and @Curried f f@.
449+-- @
450+-- 'lowerCurried' '.' 'liftCurried' ≡ 'id'
451+-- 'liftCurried' '.' 'lowerCurried' ≡ 'id'
452+-- @
453+--
454+-- @
455+-- 'lowerCurried' ('liftCurried' x) -- definition
456+-- 'lowerCurried' ('Curried' ('<*>' x)) -- definition
457+-- ('<*>' x) ('pure' 'id') -- beta reduction
458+-- 'pure' 'id' '<*>' x -- Applicative identity law
459+-- x
460+-- @
461+liftCurried :: Applicative f => f a -> Curried f a
462+liftCurried fa = Curried (<*> fa)
463+
464+-- | Lower 'Curried' by applying 'pure' 'id' to the continuation.
465+--
466+-- See 'liftCurried'.
467+lowerCurried :: Applicative f => Curried f a -> f a
468+lowerCurried (Curried f) = f (pure id)
469+
470+confusing :: Applicative f => Traversal s t a b -> (a -> f b) -> s -> f t
471+confusing t = \f -> lowerYoneda . lowerCurried . t (liftCurriedYoneda . f)
472+ where
473+ liftCurriedYoneda :: Applicative f => f a -> Curried (Yoneda f) a
474+ liftCurriedYoneda fa = Curried (`yap` fa)
475+ {-# INLINE liftCurriedYoneda #-}
476+
477+ yap :: Applicative f => Yoneda f (a -> b) -> f a -> Yoneda f b
478+ yap (Yoneda k) fa = Yoneda (\ab_r -> k (ab_r .) <*> fa)
479+ {-# INLINE yap #-}
480+{-# INLINE confusing #-}
481+
482+-- | @Yoneda f a@ can be viewed as the partial application of 'fmap' to its second argument.
483+newtype Yoneda f a = Yoneda { runYoneda :: forall b. (a -> b) -> f b }
484+
485+-- | The natural isomorphism between @f@ and @'Yoneda' f@ given by the Yoneda lemma
486+-- is witnessed by 'liftYoneda' and 'lowerYoneda'
487+--
488+-- @
489+-- 'liftYoneda' . 'lowerYoneda' ≡ 'id'
490+-- 'lowerYoneda' . 'liftYoneda' ≡ 'id'
491+-- @
492+--
493+-- @
494+-- lowerYoneda (liftYoneda fa) = -- definition
495+-- lowerYoneda (Yoneda (\f -> fmap f a)) -- definition
496+-- (\f -> fmap f fa) id -- beta reduction
497+-- fmap id fa -- functor law
498+-- fa
499+-- @
500+--
501+-- @
502+-- 'lift' = 'liftYoneda'
503+-- @
504+liftYoneda :: Functor f => f a -> Yoneda f a
505+liftYoneda a = Yoneda (\f -> fmap f a)
506+
507+lowerYoneda :: Yoneda f a -> f a
508+lowerYoneda (Yoneda f) = f id
509+
510+instance Functor (Yoneda f) where
511+ fmap f m = Yoneda (\k -> runYoneda m (k . f))
512+
513+instance Applicative f => Applicative (Yoneda f) where
514+ pure a = Yoneda (\f -> pure (f a))
515+ Yoneda m <*> Yoneda n = Yoneda (\f -> m (f .) <*> n id)
src/Data/Generics/Internal/Profunctor/Iso.hsdeleted−111
@@ -1,111 +0,0 @@
1−{-# OPTIONS_HADDOCK hide #-}
2−{-# LANGUAGE TupleSections #-}
3−{-# LANGUAGE GADTs #-}
4−{-# LANGUAGE NoMonomorphismRestriction #-}
5−{-# LANGUAGE Rank2Types #-}
6−{-# LANGUAGE ScopedTypeVariables #-}
7−{-# LANGUAGE TypeFamilies #-}
8−{-# LANGUAGE TypeFamilyDependencies #-}
9−{-# LANGUAGE TypeOperators #-}
10−
11−-----------------------------------------------------------------------------
12−-- |
13−-- Module : Data.Generics.Internal.Profunctor.Iso
14−-- Copyright : (C) 2019 Csongor Kiss
15−-- License : BSD3
16−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17−-- Stability : experimental
18−-- Portability : non-portable
19−--
20−-- Internal lens helpers. Only exported for Haddock
21−--
22−-----------------------------------------------------------------------------
23−module Data.Generics.Internal.Profunctor.Iso where
24−
25−import Data.Profunctor (Profunctor(..))
26−import Data.Profunctor.Unsafe ((#.), (.#))
27−import GHC.Generics ((:*:)(..), (:+:)(..), Generic(..), M1(..), K1(..), Rep)
28−import Data.Coerce
29−import Data.Generics.Internal.GenericN (Rec (..))
30−
31−import qualified Data.Generics.Internal.VL.Iso as VL
32−
33−type Iso s t a b
34− = forall p. (Profunctor p) => p a b -> p s t
35−
36−type Iso' s a = Iso s s a a
37−
38−-- | A type and its generic representation are isomorphic
39−repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
40−repIso = iso from to
41−
42−-- | 'M1' is just a wrapper around `f p`
43−--mIso :: Iso' (M1 i c f p) (f p)
44−mIso :: Iso (M1 i c f p) (M1 i c g p) (f p) (g p)
45−mIso = iso unM1 M1
46−{-# INLINE mIso #-}
47−
48−kIso :: Iso (K1 r a p) (K1 r b p) a b
49−kIso = iso unK1 K1
50−{-# INLINE kIso #-}
51−
52−recIso :: Iso (Rec r a p) (Rec r b p) a b
53−recIso = iso (unK1 . unRec) (Rec . K1)
54−{-# INLINE recIso #-}
55−
56−sumIso :: Iso ((a :+: b) x) ((a' :+: b') x) (Either (a x) (b x)) (Either (a' x) (b' x))
57−sumIso = iso back forth
58− where forth (Left l) = L1 l
59− forth (Right r) = R1 r
60− back (L1 l) = Left l
61− back (R1 r) = Right r
62−{-# INLINE sumIso #-}
63−
64−prodIso :: Iso ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
65−prodIso = iso (\(a :*: b) -> (a, b)) (\(a, b) -> (a :*: b))
66−
67−assoc3 :: Iso ((a, b), c) ((a', b'), c') (a, (b, c)) (a', (b', c'))
68−assoc3 = iso (\((a, b), c) -> (a, (b, c))) (\(a, (b, c)) -> ((a, b), c))
69−
70−--------------------------------------------------------------------------------
71−-- Iso stuff
72−
73−fromIso :: Iso s t a b -> Iso b a t s
74−fromIso l = withIso l $ \ sa bt -> iso bt sa
75−{-# INLINE fromIso #-}
76−
77−iso :: (s -> a) -> (b -> t) -> Iso s t a b
78−iso = dimap
79−{-# INLINE iso #-}
80−
81−iso2isovl :: Iso s t a b -> VL.Iso s t a b
82−iso2isovl _iso = withIso _iso VL.iso
83−{-# INLINE iso2isovl #-}
84−
85−withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
86−withIso ai k = case ai (Exchange id id) of
87− Exchange sa bt -> k sa bt
88−
89−pairing :: Iso s t a b -> Iso s' t' a' b' -> Iso (s, s') (t, t') (a, a') (b, b')
90−pairing f g = withIso f $ \ sa bt -> withIso g $ \s'a' b't' ->
91− iso (bmap sa s'a') (bmap bt b't')
92− where bmap f' g' (a, b) = (f' a, g' b)
93−
94−data Exchange a b s t = Exchange (s -> a) (b -> t)
95−
96−instance Functor (Exchange a b s) where
97− fmap f (Exchange sa bt) = Exchange sa (f . bt)
98− {-# INLINE fmap #-}
99−
100−instance Profunctor (Exchange a b) where
101− dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt)
102− {-# INLINE dimap #-}
103− lmap f (Exchange sa bt) = Exchange (sa . f) bt
104− {-# INLINE lmap #-}
105− rmap f (Exchange sa bt) = Exchange sa (f . bt)
106− {-# INLINE rmap #-}
107− ( #. ) _ = coerce
108− {-# INLINE ( #. ) #-}
109− ( .# ) p _ = coerce p
110− {-# INLINE ( .# ) #-}
111−
src/Data/Generics/Internal/Profunctor/Lens.hsdeleted−171
@@ -1,171 +0,0 @@
1−{-# OPTIONS_HADDOCK hide #-}
2−{-# LANGUAGE GADTs #-}
3−{-# LANGUAGE NoMonomorphismRestriction #-}
4−{-# LANGUAGE Rank2Types #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
6−{-# LANGUAGE TupleSections #-}
7−{-# LANGUAGE TypeFamilies #-}
8−{-# LANGUAGE TypeFamilyDependencies #-}
9−{-# LANGUAGE TypeOperators #-}
10−
11−-----------------------------------------------------------------------------
12−-- |
13−-- Module : Data.Generics.Internal.Profunctor.Lens
14−-- Copyright : (C) 2019 Csongor Kiss
15−-- License : BSD3
16−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17−-- Stability : experimental
18−-- Portability : non-portable
19−--
20−-- Internal lens helpers. Only exported for Haddock
21−--
22−-----------------------------------------------------------------------------
23−module Data.Generics.Internal.Profunctor.Lens where
24−
25−import Data.Profunctor (Profunctor(..), Strong(..))
26−import Data.Bifunctor
27−import GHC.Generics
28−import Data.Generics.Internal.Profunctor.Iso
29−
30−type Lens s t a b
31− = forall p . (Strong p) => p a b -> p s t
32−
33−type LensLike p s t a b
34− = p a b -> p s t
35−
36−
37−ravel :: (ALens a b a b -> ALens a b s t) -> Lens s t a b
38−ravel l pab = conv (l idLens) pab
39− where
40− conv :: ALens a b s t -> Lens s t a b
41− conv (ALens _get _set) = lens _get _set
42−
43−-- | Setting
44−set :: ((a -> b) -> s -> t) -> (s, b) -> t
45−set f (s, b)
46− = f (const b) s
47−
48−view :: Lens s s a a -> s -> a
49−view l = withLensPrim l (\get _ -> snd . get)
50−
51−--withLens :: Lens s t a b -> ((s -> a) -> ((s, b) -> t) -> r) -> r
52−--ithLens l k =
53−-- case l idLens of
54−-- ALens _get _set -> k (snd . _get) (\(s, b) -> _set ((fst $ _get s), b))
55−
56−withLensPrim :: Lens s t a b -> (forall c . (s -> (c,a)) -> ((c, b) -> t) -> r) -> r
57−withLensPrim l k =
58− case l idLens of
59− ALens _get _set -> k _get _set
60−
61−idLens :: ALens a b a b
62−idLens = ALens (fork (const ()) id) snd
63−{-# INLINE idLens #-}
64−
65−-- | Lens focusing on the first element of a product
66−first :: Lens ((a :*: b) x) ((a' :*: b) x) (a x) (a' x)
67−first
68− = lens (\(a :*: b) -> (b,a)) (\(b, a') -> a' :*: b)
69−
70−-- | Lens focusing on the second element of a product
71−second :: Lens ((a :*: b) x) ((a :*: b') x) (b x) (b' x)
72−second
73− = lens (\(a :*: b) -> (a,b)) (\(a, b') -> a :*: b')
74−
75−fork :: (a -> b) -> (a -> c) -> a -> (b, c)
76−fork f g a = (f a, g a)
77−
78−swap :: (a, b) -> (b, a)
79−swap (a, b) = (b, a)
80−
81−cross :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
82−cross = bimap
83−
84−--------------------------------------------------------------------------------
85−
86−data Coyoneda f b = forall a. Coyoneda (a -> b) (f a)
87−
88−instance Functor (Coyoneda f) where
89− fmap f (Coyoneda g fa)
90− = Coyoneda (f . g) fa
91−
92−inj :: Functor f => Coyoneda f a -> f a
93−inj (Coyoneda f a) = fmap f a
94−
95−proj :: Functor f => f a -> Coyoneda f a
96−proj fa = Coyoneda id fa
97−
98−newtype Alongside p s t a b = Alongside { getAlongside :: p (s, a) (t, b) }
99−
100−instance Profunctor p => Profunctor (Alongside p c d) where
101− dimap f g (Alongside pab) = Alongside $ dimap (fmap f) (fmap g) pab
102−
103−instance Strong p => Strong (Alongside p c d) where
104− second' (Alongside pab) = Alongside . dimap shuffle shuffle . second' $ pab
105− where
106− shuffle (x,(y,z)) = (y,(x,z))
107−
108−(??) :: Functor f => f (a -> b) -> a -> f b
109−fab ?? a = fmap ($ a) fab
110−
111−-- Could implement this using primitives?
112−alongside :: Profunctor p =>
113− LensLike (Alongside p s' t') s t a b
114− -> LensLike (Alongside p a b) s' t' a' b'
115− -> LensLike p (s, s') (t, t') (a, a') (b, b')
116−alongside l1 l2
117− = dimap swap swap . getAlongside . l1 . Alongside . dimap swap swap . getAlongside . l2 . Alongside
118−
119−assoc3L :: Lens ((a, b), c) ((a', b'), c') (a, (b, c)) (a', (b', c'))
120−assoc3L f = assoc3 f
121−
122−stron :: (Either s s', b) -> Either (s, b) (s', b)
123−stron (e, b) = bimap (,b) (, b) e
124−
125−choosing :: forall s t a b s' t' . Lens s t a b -> Lens s' t' a b -> Lens (Either s s') (Either t t') a b
126−choosing l r = withLensPrim l (\getl setl ->
127− withLensPrim r (\getr setr ->
128− let --g :: Either s s' -> a
129− g e = case e of
130− Left v -> let (c, v') = getl v in (Left c, v')
131− Right v -> let (c, v') = getr v in (Right c, v')
132− s = bimap setl setr . stron
133− in lens g s))
134−
135−lens :: (s -> (c,a)) -> ((c,b) -> t) -> Lens s t a b
136−lens get _set = dimap get _set . second'
137−{-# INLINE lens #-}
138−
139−------------------------------------------------------------------------------
140−
141−data ALens a b s t = forall c . ALens (s -> (c,a)) ((c, b) -> t)
142−
143−instance Functor (ALens a b s) where
144− fmap f (ALens _get _set) = ALens _get (f . _set)
145−
146−instance Profunctor (ALens a b) where
147− dimap f g (ALens get _set) = ALens (get . f) (g . _set)
148−
149−instance Strong (ALens a b) where
150− second' (ALens get _set) = ALens get' set' --(bimap id _set . assoc)
151− where
152− get' (c, a1) = let (c1, a) = get a1 in ((c, c1), a)
153− set' ((c, c1), b) = (c, _set (c1, b))
154− {-# INLINE second' #-}
155−
156−-- These are specialised versions of the Isos. On GHC 8.0.2, having
157−-- these functions eta-expanded allows the optimiser to inline these functions.
158−mLens :: Lens (M1 i c f p) (M1 i c g p) (f p) (g p)
159−mLens f = mIso f
160−
161−repLens :: (Generic a, Generic b) => Lens a b (Rep a x) (Rep b x)
162−repLens f = repIso f
163−
164−prodL :: Lens ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
165−prodL f = prodIso f
166−
167−prodR :: Lens (a' x, b' x) (a x, b x) ((a' :*: b') x) ((a :*: b) x)
168−prodR f = fromIso prodIso f
169−
170−assoc3R :: Lens (a', (b', c')) (a, (b, c)) ((a', b'), c') ((a, b), c)
171−assoc3R f = fromIso assoc3 f
src/Data/Generics/Internal/Profunctor/Prism.hsdeleted−117
@@ -1,117 +0,0 @@
1−{-# OPTIONS_HADDOCK hide #-}
2−{-# LANGUAGE GADTs #-}
3−{-# LANGUAGE LambdaCase #-}
4−{-# LANGUAGE NoMonomorphismRestriction #-}
5−{-# LANGUAGE Rank2Types #-}
6−{-# LANGUAGE ScopedTypeVariables #-}
7−{-# LANGUAGE TypeFamilies #-}
8−{-# LANGUAGE TypeFamilyDependencies #-}
9−{-# LANGUAGE TypeOperators #-}
10−
11−-----------------------------------------------------------------------------
12−-- |
13−-- Module : Data.Generics.Internal.Profunctor.Prism
14−-- Copyright : (C) 2019 Csongor Kiss
15−-- License : BSD3
16−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17−-- Stability : experimental
18−-- Portability : non-portable
19−--
20−-- Internal lens helpers. Only exported for Haddock
21−--
22−-----------------------------------------------------------------------------
23−module Data.Generics.Internal.Profunctor.Prism where
24−
25−import Data.Bifunctor (bimap)
26−import Data.Profunctor (Choice(..), Profunctor(..))
27−import Data.Tagged
28−import Data.Profunctor.Unsafe ((#.), (.#))
29−import GHC.Generics
30−import Data.Coerce
31−
32−type APrism s t a b = Market a b a b -> Market a b s t
33−
34−type Prism s t a b
35− = forall p . (Choice p) => p a b -> p s t
36−
37−type Prism' s a = forall p . (Choice p) => p a a -> p s s
38−
39−left :: Prism ((a :+: c) x) ((b :+: c) x) (a x) (b x)
40−left = prism L1 $ gsum Right (Left . R1)
41−
42−right :: Prism ((a :+: b) x) ((a :+: c) x) (b x) (c x)
43−right = prism R1 $ gsum (Left . L1) Right
44−
45−prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
46−prism bt seta eta = dimap seta (either id bt) (right' eta)
47−
48−_Left :: Prism (Either a c) (Either b c) a b
49−_Left = left'
50−
51−_Right :: Prism (Either c a) (Either c b) a b
52−_Right = right'
53−
54−prismPRavel :: APrism s t a b -> Prism s t a b
55−prismPRavel l pab = (prism2prismp $ l idPrism) pab
56−
57−build :: (Tagged b b -> Tagged t t) -> b -> t
58−build p = unTagged #. p .# Tagged
59−
60−match :: Prism s t a b -> s -> Either t a
61−match k = withPrism k $ \_ _match -> _match
62−
63−--------------------------------------------------------------------------------
64−-- Prism stuff
65−
66−without' :: Prism s t a b -> Prism s t c d -> Prism s t (Either a c) (Either b d)
67−without' k =
68− withPrism k $ \bt _ k' ->
69− withPrism k' $ \dt setc ->
70− prism (either bt dt) $ \s -> fmap Right (setc s)
71−{-# INLINE without' #-}
72−
73−withPrism :: APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
74−withPrism k f = case k idPrism of
75− Market bt seta -> f bt seta
76−
77−prism2prismp :: Market a b s t -> Prism s t a b
78−prism2prismp (Market bt seta) = prism bt seta
79−
80−idPrism :: Market a b a b
81−idPrism = Market id Right
82−
83−gsum :: (a x -> c) -> (b x -> c) -> ((a :+: b) x) -> c
84−gsum f _ (L1 x) = f x
85−gsum _ g (R1 y) = g y
86−
87−plus :: (a -> b) -> (c -> d) -> Either a c -> Either b d
88−plus = bimap
89−
90−--------------------------------------------------------------------------------
91−-- Market
92−
93−data Market a b s t = Market (b -> t) (s -> Either t a)
94−
95−instance Functor (Market a b s) where
96− fmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)
97− {-# INLINE fmap #-}
98−
99−instance Profunctor (Market a b) where
100− dimap f g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta . f)
101− {-# INLINE dimap #-}
102− lmap f (Market bt seta) = Market bt (seta . f)
103− {-# INLINE lmap #-}
104− rmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)
105− {-# INLINE rmap #-}
106− ( #. ) _ = coerce
107− {-# INLINE ( #. ) #-}
108− ( .# ) p _ = coerce p
109− {-# INLINE ( .# ) #-}
110−
111−instance Choice (Market a b) where
112− left' (Market bt seta) = Market (Left . bt) $ \case
113− Left s -> case seta s of
114− Left t -> Left (Left t)
115− Right a -> Right a
116− Right c -> Left (Right c)
117− {-# INLINE left' #-}
src/Data/Generics/Internal/VL/Iso.hsdeleted−80
@@ -1,80 +0,0 @@
1−{-# OPTIONS_HADDOCK hide #-}
2−{-# LANGUAGE GADTs #-}
3−{-# LANGUAGE NoMonomorphismRestriction #-}
4−{-# LANGUAGE Rank2Types #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
6−{-# LANGUAGE TypeFamilies #-}
7−{-# LANGUAGE TypeFamilyDependencies #-}
8−{-# LANGUAGE TypeOperators #-}
9−
10−-----------------------------------------------------------------------------
11−-- |
12−-- Module : Data.Generics.Internal.VL.Iso
13−-- Copyright : (C) 2019 Csongor Kiss
14−-- License : BSD3
15−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16−-- Stability : experimental
17−-- Portability : non-portable
18−--
19−-- Internal lens helpers. Only exported for Haddock
20−--
21−-----------------------------------------------------------------------------
22−module Data.Generics.Internal.VL.Iso where
23−
24−import Data.Coerce (coerce)
25−import Data.Functor.Identity (Identity(..))
26−import Data.Profunctor (Profunctor(..))
27−import GHC.Generics
28−import Data.Generics.Internal.GenericN (Rec (..))
29−
30−data Exchange a b s t = Exchange (s -> a) (b -> t)
31−
32−instance Functor (Exchange a b s) where
33− fmap f (Exchange sa bt) = Exchange sa (f . bt)
34− {-# INLINE fmap #-}
35−
36−instance Profunctor (Exchange a b) where
37− dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt)
38− {-# INLINE dimap #-}
39− lmap f (Exchange sa bt) = Exchange (sa . f) bt
40− {-# INLINE lmap #-}
41− rmap f (Exchange sa bt) = Exchange sa (f . bt)
42− {-# INLINE rmap #-}
43−
44−type Iso' s a
45− = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s)
46−
47−type Iso s t a b
48− = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
49−
50−fromIso :: Iso s t a b -> Iso b a t s
51−fromIso l = withIso l $ \ sa bt -> iso bt sa
52−{-# inline fromIso #-}
53−
54−-- | Extract the two functions, one from @s -> a@ and
55−-- one from @b -> t@ that characterize an 'Iso'.
56−withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
57−withIso ai k = case ai (Exchange id Identity) of
58− Exchange sa bt -> k sa (coerce bt)
59−{-# inline withIso #-}
60−
61−-- | A type and its generic representation are isomorphic
62−repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
63−repIso = iso from to
64−
65−-- | 'M1' is just a wrapper around `f p`
66−mIso :: Iso (M1 i c f p) (M1 i c g p) (f p) (g p)
67−mIso = iso unM1 M1
68−
69−kIso :: Iso (K1 r a p) (K1 r b p) a b
70−kIso = iso unK1 K1
71−
72−recIso :: Iso (Rec r a p) (Rec r b p) a b
73−recIso = iso (unK1 . unRec) (Rec . K1)
74−
75−prodIso :: Iso ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
76−prodIso = iso (\(a :*: b) -> (a, b)) (\(a, b) -> (a :*: b))
77−
78−iso :: (s -> a) -> (b -> t) -> Iso s t a b
79−iso sa bt = dimap sa (fmap bt)
80−{-# INLINE iso #-}
src/Data/Generics/Internal/VL/Lens.hsdeleted−70
@@ -1,70 +0,0 @@
1−{-# OPTIONS_HADDOCK hide #-}
2−{-# LANGUAGE GADTs #-}
3−{-# LANGUAGE NoMonomorphismRestriction #-}
4−{-# LANGUAGE Rank2Types #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
6−{-# LANGUAGE TypeFamilies #-}
7−{-# LANGUAGE TypeFamilyDependencies #-}
8−{-# LANGUAGE TypeOperators #-}
9−{-# LANGUAGE TupleSections #-}
10−
11−-----------------------------------------------------------------------------
12−-- |
13−-- Module : Data.Generics.Internal.VL.Lens
14−-- Copyright : (C) 2019 Csongor Kiss
15−-- License : BSD3
16−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17−-- Stability : experimental
18−-- Portability : non-portable
19−--
20−-- Internal lens helpers. Only exported for Haddock
21−--
22−-----------------------------------------------------------------------------
23−module Data.Generics.Internal.VL.Lens where
24−
25−import Control.Applicative (Const(..))
26−import Data.Coerce (coerce)
27−import Data.Functor.Identity (Identity(..))
28−import Data.Generics.Internal.Profunctor.Lens (ALens (..), idLens)
29−
30−-- | Type alias for lens
31−type Lens' s a
32− = Lens s s a a
33−
34−type Lens s t a b
35− = forall f. Functor f => (a -> f b) -> s -> f t
36−
37−view :: ((a -> Const a a) -> s -> Const a s) -> s -> a
38−view l s = (^.) s l
39−
40−-- | Getting
41−(^.) :: s -> ((a -> Const a a) -> s -> Const a s) -> a
42−s ^. l = getConst (l Const s)
43−infixl 8 ^.
44−
45−infixr 4 .~
46−(.~) :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t
47−(.~) f b = runIdentity . f (Identity . const b)
48−
49−set :: Lens s t a b -> b -> s -> t
50−set l x = l .~ x
51−
52−over :: ((a -> Identity b) -> s -> Identity t) -> (a -> b) -> s -> t
53−over = coerce
54−
55−lens2lensvl :: ALens a b s t -> Lens s t a b
56−lens2lensvl (ALens _get _set) =
57− \f x ->
58− case _get x of
59− (c, a) -> _set . (c, ) <$> f a
60−{-# INLINE lens2lensvl #-}
61−
62−ravel :: (ALens a b a b -> ALens a b s t)
63− -> Lens s t a b
64−ravel l pab = (lens2lensvl $ l idLens) pab
65−
66−
67−lens :: (s -> a) -> ((s, b) -> t) -> Lens s t a b
68−lens get _set = \f x -> curry _set x <$> f (get x)
69−{-# INLINE[0] lens #-}
70−
src/Data/Generics/Internal/VL/Prism.hsdeleted−74
@@ -1,74 +0,0 @@
1−{-# OPTIONS_HADDOCK hide #-}
2−{-# LANGUAGE GADTs #-}
3−{-# LANGUAGE NoMonomorphismRestriction #-}
4−{-# LANGUAGE Rank2Types #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
6−{-# LANGUAGE TypeFamilies #-}
7−{-# LANGUAGE TypeFamilyDependencies #-}
8−{-# LANGUAGE TypeOperators #-}
9−
10−-----------------------------------------------------------------------------
11−-- |
12−-- Module : Data.Generics.Internal.VL.Prism
13−-- Copyright : (C) 2019 Csongor Kiss
14−-- License : BSD3
15−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16−-- Stability : experimental
17−-- Portability : non-portable
18−--
19−-- Internal lens helpers. Only exported for Haddock
20−--
21−-----------------------------------------------------------------------------
22−module Data.Generics.Internal.VL.Prism where
23−
24−import Data.Functor.Identity (Identity(..))
25−import Data.Profunctor (Choice(..), Profunctor(..))
26−import Data.Coerce
27−import Data.Generics.Internal.Profunctor.Prism (Market (..), plus, idPrism)
28−import Data.Tagged
29−import Data.Profunctor.Unsafe ((#.), (.#))
30−import Data.Monoid (First (..))
31−import Control.Applicative (Const(..))
32−
33−-- | Type alias for prism
34−type Prism s t a b
35− = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)
36−
37−type Prism' s a
38− = Prism s s a a
39−
40−infixl 8 ^?
41−(^?) :: s -> ((a -> Const (First a) a) -> s -> Const (First a) s) -> Maybe a
42−s ^? l = getFirst (fmof l (First #. Just) s)
43− where fmof l' f = getConst #. l' (Const #. f)
44−
45−
46−match :: Prism s t a b -> s -> Either t a
47−match k = withPrism k $ \_ _match -> _match
48−{-# INLINE match #-}
49−
50−(#) :: (Tagged b (Identity b) -> Tagged t (Identity t)) -> b -> t
51−(#) = build
52−{-# INLINE (#) #-}
53−
54−prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
55−prism bt seta eta = dimap (\x -> plus pure id (seta x)) (either id (\x -> fmap bt x)) (right' eta)
56−{-# INLINE prism #-}
57−
58−prismRavel :: (Market a b a b -> Market a b s t) -> Prism s t a b
59−prismRavel l pab = (prism2prismvl $ l idPrism) pab
60−{-# INLINE prismRavel #-}
61−
62−type APrismVL s t a b = Market a b a (Identity b) -> Market a b s (Identity t)
63−
64−withPrism :: APrismVL s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
65−withPrism k f = case coerce (k (Market Identity Right)) of
66− Market bt seta -> f bt seta
67−
68−prism2prismvl :: Market a b s t -> Prism s t a b
69−prism2prismvl (Market bt seta) = prism bt seta
70−{-# INLINE prism2prismvl #-}
71−
72−build :: (Tagged b (Identity b) -> Tagged t (Identity t)) -> b -> t
73−build p = runIdentity #. unTagged #. p .# Tagged .# Identity
74−{-# INLINE build #-}
src/Data/Generics/Internal/VL/Traversal.hsdeleted−92
@@ -1,92 +0,0 @@
1−{-# OPTIONS_HADDOCK hide #-}
2−{-# LANGUAGE AllowAmbiguousTypes #-}
3−{-# LANGUAGE ConstraintKinds #-}
4−{-# LANGUAGE GADTs #-}
5−{-# LANGUAGE NoMonomorphismRestriction #-}
6−{-# LANGUAGE Rank2Types #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE TypeFamilies #-}
9−{-# LANGUAGE TypeFamilyDependencies #-}
10−{-# LANGUAGE TypeOperators #-}
11−
12−-----------------------------------------------------------------------------
13−-- |
14−-- Module : Data.Generics.Internal.VL.Traversal
15−-- Copyright : (C) 2019 Csongor Kiss
16−-- License : BSD3
17−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
18−-- Stability : experimental
19−-- Portability : non-portable
20−--
21−-- Internal lens helpers. Only exported for Haddock
22−--
23−-----------------------------------------------------------------------------
24−module Data.Generics.Internal.VL.Traversal where
25−
26−import Data.Kind (Constraint)
27−
28−-- | Type alias for traversal
29−type Traversal' s a
30− = forall f. Applicative f => (a -> f a) -> s -> f s
31−
32−type TraversalC (c :: * -> * -> Constraint) s t
33− = forall f. Applicative f => (forall a b. c a b => a -> f b) -> s -> f t
34−
35−type TraversalC' (c :: * -> Constraint) s
36− = forall f. Applicative f => (forall a. c a => a -> f a) -> s -> f s
37−
38−type Traversal s t a b
39− = forall f. Applicative f => (a -> f b) -> s -> f t
40−
41−type LensLikeC c f s
42− = (forall a. c a => a -> f a) -> s -> f s
43−
44−confusing :: Applicative f => Traversal s t a b -> (a -> f b) -> s -> f t
45−confusing t = \f -> lowerYoneda . lowerCurried . t (liftCurriedYoneda . f)
46−{-# INLINE confusing #-}
47−
48−-- fuse constrained traversals
49−confusingC :: forall c f s. Applicative f => TraversalC' c s -> LensLikeC c f s
50−confusingC t = \f -> lowerYoneda . lowerCurried . t (liftCurriedYoneda . f)
51−{-# INLINE confusingC #-}
52−
53−liftCurriedYoneda :: Applicative f => f a -> Curried (Yoneda f) a
54−liftCurriedYoneda fa = Curried (`yap` fa)
55−{-# INLINE liftCurriedYoneda #-}
56−
57−yap :: Applicative f => Yoneda f (a -> b) -> f a -> Yoneda f b
58−yap (Yoneda k) fa = Yoneda (\ab_r -> k (ab_r .) <*> fa)
59−{-# INLINE yap #-}
60−
61−newtype Curried f a =
62− Curried { runCurried :: forall r. f (a -> r) -> f r }
63−
64−instance Functor f => Functor (Curried f) where
65− fmap f (Curried g) = Curried (g . fmap (.f))
66− {-# INLINE fmap #-}
67−
68−instance (Functor f) => Applicative (Curried f) where
69− pure a = Curried (fmap ($ a))
70− {-# INLINE pure #-}
71− Curried mf <*> Curried ma = Curried (ma . mf . fmap (.))
72− {-# INLINE (<*>) #-}
73−
74−liftCurried :: Applicative f => f a -> Curried f a
75−liftCurried fa = Curried (<*> fa)
76−
77−lowerCurried :: Applicative f => Curried f a -> f a
78−lowerCurried (Curried f) = f (pure id)
79−newtype Yoneda f a = Yoneda { runYoneda :: forall b. (a -> b) -> f b }
80−
81−liftYoneda :: Functor f => f a -> Yoneda f a
82−liftYoneda a = Yoneda (\f -> fmap f a)
83−
84−lowerYoneda :: Yoneda f a -> f a
85−lowerYoneda (Yoneda f) = f id
86−
87−instance Functor (Yoneda f) where
88− fmap f m = Yoneda (\k -> runYoneda m (k . f))
89−
90−instance Applicative f => Applicative (Yoneda f) where
91− pure a = Yoneda (\f -> pure (f a))
92− Yoneda m <*> Yoneda n = Yoneda (\f -> m (f .) <*> n id)
src/Data/Generics/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+5−5
@@ -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
@@ -29,7 +29,7 @@ module Data.Generics.Product.Any
2929 HasAny (..)
3030 ) where
3131
32−import Data.Generics.Internal.VL.Lens
32+import Data.Generics.Internal.Lens
3333import Data.Generics.Product.Fields
3434import Data.Generics.Product.Positions
3535import Data.Generics.Product.Typed
@@ -41,7 +41,7 @@ import Data.Generics.Product.Typed
4141-- >>> :set -XDataKinds
4242-- >>> :set -XDeriveGeneric
4343-- >>> import GHC.Generics
44−-- >>> :m +Data.Generics.Internal.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'
@@ -67,7 +67,7 @@ class HasAny sel s t a b | s sel -> a where
6767 --
6868 -- >>> human ^. the @3
6969 -- "London"
70− the :: Lens s t a b
70+ the :: LensVL s t a b
7171
7272instance HasPosition i s t a b => HasAny i s t a b where
7373 the = position @i
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+30−96
@@ -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,23 +31,20 @@ module Data.Generics.Product.Fields
3131
3232 -- $setup
3333 HasField (..)
34− , HasField' (..)
35− , HasField_ (..)
34+ , HasField'
3635
3736 , getField
3837 , setField
3938 ) where
4039
4140import Data.Generics.Internal.Families
42−import Data.Generics.Internal.VL.Lens as VL
41+import Data.Generics.Internal.Lens
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
5148
5249-- $setup
5350-- == /Running example:/
@@ -58,7 +55,7 @@ import Data.Generics.Internal.Errors
5855-- >>> :set -XGADTs
5956-- >>> :set -XFlexibleContexts
6057-- >>> import GHC.Generics
61−-- >>> :m +Data.Generics.Internal.VL.Lens
58+-- >>> :m +Data.Generics.Internal.Lens
6259-- >>> :m +Data.Function
6360-- >>> :{
6461-- data Human a
@@ -111,108 +108,48 @@ class HasField (field :: Symbol) s t a b | s field -> a, t field -> b, s field b
111108 -- ... The offending constructors are:
112109 -- ... HumanNoAddress
113110 -- ...
114− field :: VL.Lens s t a b
111+ field :: LensVL s t a b
115112
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
113+type HasField' field s a = HasField field s s a a
139114
140115-- |
141116-- >>> getField @"age" human
142117-- 50
143−getField :: forall f a s. HasField' f s a => s -> a
144−getField = VL.view (field' @f)
118+getField :: forall f s t a b . HasField' f s a => s -> a
119+getField = viewVL' (field @f)
145120
146121-- |
147122-- >>> setField @"age" 60 human
148123-- Human {name = "Tunyasz", age = 60, address = "London", other = False}
149124setField :: forall f s a. HasField' f s a => a -> s -> s
150−setField = VL.set (field' @f)
125+setField = setVL (field @f)
151126
152−instance
127+instance -- see Note [Changing type parameters]
153128 ( Generic s
154129 , 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
130+ , Generic t
131+ -- see Note [CPP in instance constraints]
132+#if __GLASGOW_HASKELL__ < 802
133+ , '(s', t') ~ '(Proxied s, Proxied t)
183134#else
184−-- >>> :t field
185−-- field
186−-- :: (Functor f, HasField field s t a b) => (a -> f b) -> s -> f t
135+ , s' ~ Proxied s
136+ , t' ~ Proxied t
187137#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
138+ , Generic s'
139+ , Generic t'
140+ , GHasKey' field (Rep s) a
141+ , GHasKey' field (Rep s') a'
142+ , GHasKey' field (Rep t') b'
143+ , GHasKey field (Rep s) (Rep t) a b
144+ , t ~ Infer s a' b
145+ , s ~ Infer t b' a
146+ ) => HasField field s t a b where
199147
200−instance {-# OVERLAPPING #-} HasField_ f (Void1 a) (Void1 b) a b where
201− field_ = undefined
148+ field f s = ravel (repLens . gkey @field) f s
202149
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 #-}
150+-- -- See Note [Uncluttering type signatures]
151+instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where
152+ field = undefined
216153
217154type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Constraint where
218155 ErrorUnless field s ('TypeStat _ _ '[])
@@ -235,6 +172,3 @@ type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Cons
235172
236173 ErrorUnless _ _ ('TypeStat '[] '[] _)
237174 = ()
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+53
@@ -0,0 +1,53 @@
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.Internal.Lens
31+import Data.Generics.Product.Internal.List
32+import Data.Kind
33+import GHC.Generics
34+
35+class GHasKey (key :: k) (s :: Type -> Type) (t :: Type -> Type) a b | s key -> a, t key -> b where
36+ gkey :: Lens (s x) (t x) a b
37+
38+type GHasKey' key s a = GHasKey key s s a a
39+
40+instance (GHasKey key l l' a b, GHasKey key r r' a b) => GHasKey key (l :+: r) (l' :+: r') a b where
41+ gkey = sumIso . choosing (gkey @key) (gkey @key)
42+
43+instance (GHasKey key f g a b) => GHasKey key (M1 D meta f) (M1 D meta g) a b where
44+ gkey = mLens . gkey @key
45+
46+instance
47+ ( Elem as key i a
48+ , Elem bs key i b
49+ , IndexList i as bs a b
50+ , GIsList k f g as bs
51+ ) => GHasKey (key :: k) (M1 C meta f) (M1 C meta g) a b where
52+ gkey = mIso . (glist @k) . point @i
53+
src/Data/Generics/Product/Internal/List.hsnew file+344
@@ -0,0 +1,344 @@
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+import Data.Generics.Internal.Lens
47+
48+import Data.Kind (Type)
49+import GHC.Generics
50+import Data.Profunctor
51+
52+data List (as :: [(m, Type)]) where
53+ Nil :: List '[]
54+ (:>) :: a -> List as -> List ('(s, a) ': as)
55+
56+infixr 5 :>
57+
58+type family ((as :: [k]) ++ (bs :: [k])) :: [k] where
59+ '[] ++ bs = bs
60+ (a ': as) ++ bs = a ': as ++ bs
61+
62+instance Monoid (List '[]) where
63+ mempty = Nil
64+ mappend _ _ = Nil
65+
66+instance (Monoid a, Monoid (List as)) => Monoid (List ('(k, a) ': as)) where
67+ mempty = mempty :> mempty
68+ mappend (x :> xs) (y :> ys) = mappend x y :> mappend xs ys
69+
70+class Elem (as :: [(k, Type)]) (key :: k) (i :: Nat) a | as key -> i a
71+instance {-# OVERLAPPING #-} pos ~ 0 => Elem ('(key, a) ': xs) key pos a
72+instance (Elem xs key i a, pos ~ (i + 1)) => Elem (x ': xs) key pos a
73+
74+class GIsList
75+ (m :: Type)
76+ (f :: Type -> Type)
77+ (g :: Type -> Type)
78+ (as :: [(m, Type)])
79+ (bs :: [(m, Type)]) | m f -> as, m g -> bs, bs f -> g, as g -> f where
80+
81+ glist :: Iso (f x) (g x) (List as) (List bs)
82+
83+ glistL :: Lens (f x) (g x) (List as) (List bs)
84+ glistL f = glist @m f
85+
86+ glistR :: Lens (List bs) (List as) (g x) (f x)
87+ glistR f = fromIso (glist @m) f
88+
89+instance
90+ ( GIsList m l l' as as'
91+ , GIsList m r r' bs bs'
92+ , Appending List as bs cs as' bs' cs'
93+ , cs ~ (as ++ bs)
94+ , cs' ~ (as' ++ bs')
95+ ) => GIsList m (l :*: r) (l' :*: r') cs cs' where
96+
97+ glist = prodIso . pairing (glist @m) (glist @m) . appending
98+
99+instance GIsList m f g as bs => GIsList m (M1 t meta f) (M1 t meta g) as bs where
100+ glist = mIso . glist @m
101+
102+instance {-# OVERLAPS #-}
103+ GIsList Symbol
104+ (S1 ('MetaSel ('Just field) u s i) (Rec0 a))
105+ (S1 ('MetaSel ('Just field) u s i) (Rec0 b))
106+ '[ '(field, a)] '[ '(field, b)] where
107+ glist = mIso . kIso . singleton
108+
109+instance GIsList Type (Rec0 a) (Rec0 a) '[ '(a, a)] '[ '(a, a)] where
110+ glist = kIso . singleton
111+
112+instance GIsList () (Rec0 a) (Rec0 b) '[ '( '(), a)] '[ '( '(), b)] where
113+ glist = kIso . singleton
114+
115+instance GIsList m U1 U1 '[] '[] where
116+ glist = iso (const Nil) (const U1)
117+
118+--------------------------------------------------------------------------------
119+-- as ++ bs == cs
120+-- as' + == cs'
121+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
122+ appending :: Iso (f as, f bs) (f as', f bs') (f cs) (f cs')
123+
124+instance Appending List '[] bs bs '[] bs' bs' where
125+ appending = iso snd (Nil,)
126+
127+instance Appending List as bs cs as' bs' cs'
128+ => Appending List ('(f, a) ': as) bs ('(f, a) ': cs) ('(f, a') ': as') bs' ('(f, a') ': cs') where
129+ appending = pairing (fromIso consing) id . assoc3 . pairing id appending . consing
130+
131+singleton :: Iso a b (List '[ '(field, a)]) (List '[ '(field, b)])
132+singleton = iso (:> Nil) (\(x :> _) -> x)
133+
134+consing :: Iso (a, List as) (b, List bs) (List ('(f, a) ': as)) (List ('(f, b) ': bs))
135+consing = iso (\(x, xs) -> x :> xs) (\(x :> xs) -> (x, xs))
136+
137+--------------------------------------------------------------------------------
138+
139+-- This ended up not being used now... still cool to have
140+flipping :: Iso' (List (a1 ': a2 ': as)) (List (a2 ': a1 ': as))
141+flipping = iso
142+ (\(a1 :> a2 :> as) -> a2 :> a1 :> as)
143+ (\(a2 :> a1 :> as) -> a1 :> a2 :> as)
144+
145+class Inserting f a as bs | bs a -> as where
146+ inserting :: Iso' (f (a ': as)) (f bs)
147+
148+instance Inserting f a as (a ': as) where
149+ inserting = id
150+
151+instance Inserting List a as bs => Inserting List a ('(fb, b) ': as) ('(fb, b) ': bs) where
152+ inserting = flipping . fromIso consing . pairing id (inserting @_ @a) . consing
153+
154+class Permuting f as bs where
155+ permuting :: Iso' (f as) (f bs)
156+
157+instance Permuting List '[] '[] where
158+ permuting = id
159+
160+instance (Permuting List as as', Inserting List '(fa, a) as' bs')
161+ => Permuting List ('(fa, a) ': as) bs' where
162+ permuting = fromIso consing . pairing id permuting . consing . (inserting @_ @'(fa, _))
163+
164+--------------------------------------------------------------------------------
165+class IndexList (i :: Nat) as bs a b | i as -> a, i bs -> b, i as b -> bs, i bs a -> as where
166+ point :: Lens (List as) (List bs) a b
167+
168+instance {-# OVERLAPPING #-}
169+ ( as ~ ('(f, a) ': as')
170+ , bs ~ ('(f, b) ': as')
171+ ) => IndexList 0 as bs a b where
172+ point = lens (\(x :> xs) -> x) (\((x :> xs), x') -> x' :> xs)
173+ {-# INLINE point #-}
174+
175+instance
176+ ( IndexList (n - 1) as' bs' a b
177+ , as ~ ('(f, x) ': as')
178+ , bs ~ ('(f, x) ': bs')
179+ ) => IndexList n as bs a b where
180+ point = fromIso consing . alongside id (point @(n-1)) . second'
181+ {-# INLINE point #-}
182+
183+--------------------------------------------------------------------------------
184+-- * Convert tuples to/from HLists
185+
186+class ListTuple (tuple :: Type) (as :: [(k, Type)]) | as -> tuple where
187+ type ListToTuple as :: Type
188+ tupled :: Iso' (List as) tuple
189+ tupled = iso listToTuple tupleToList
190+
191+ tupleToList :: tuple -> List as
192+ listToTuple :: List as -> tuple
193+
194+instance ListTuple () '[] where
195+ type ListToTuple '[] = ()
196+ tupleToList _ = Nil
197+ listToTuple _ = ()
198+
199+instance ListTuple a '[ '(fa, a)] where
200+ type ListToTuple '[ '(fa, a)] = a
201+ tupleToList a
202+ = a :> Nil
203+ listToTuple (a :> Nil)
204+ = a
205+
206+instance ListTuple (a, b) '[ '(fa, a), '(fb, b)] where
207+ type ListToTuple '[ '(fa, a), '(fb, b)] = (a, b)
208+ tupleToList (a, b)
209+ = a :> b :> Nil
210+ listToTuple (a :> b :> Nil)
211+ = (a, b)
212+
213+instance ListTuple (a, b, c) '[ '(fa, a), '(fb, b), '(fc, c)] where
214+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c)] = (a, b, c)
215+ tupleToList (a, b, c)
216+ = a :> b :> c :> Nil
217+ listToTuple (a :> b :> c :> Nil)
218+ = (a, b, c)
219+
220+instance ListTuple (a, b, c, d) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d)] where
221+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d)] = (a, b, c, d)
222+ tupleToList (a, b, c, d)
223+ = a :> b :> c :> d:> Nil
224+ listToTuple (a :> b :> c :> d :> Nil)
225+ = (a, b, c, d)
226+
227+instance ListTuple (a, b, c, d, e) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e)] where
228+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e)] = (a, b, c, d, e)
229+ tupleToList (a, b, c, d, e)
230+ = a :> b :> c :> d:> e :> Nil
231+ listToTuple (a :> b :> c :> d :> e :> Nil)
232+ = (a, b, c, d, e)
233+
234+instance ListTuple (a, b, c, d, e, f) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f)] where
235+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f)] = (a, b, c, d, e, f)
236+ tupleToList (a, b, c, d, e, f)
237+ = a :> b :> c :> d:> e :> f :> Nil
238+ listToTuple (a :> b :> c :> d :> e :> f :> Nil)
239+ = (a, b, c, d, e, f)
240+
241+instance ListTuple (a, b, c, d, e, f, g) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g)] where
242+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g)] = (a, b, c, d, e, f, g)
243+ tupleToList (a, b, c, d, e, f, g)
244+ = a :> b :> c :> d:> e :> f :> g :> Nil
245+ listToTuple (a :> b :> c :> d :> e :> f :> g :> Nil)
246+ = (a, b, c, d, e, f, g)
247+
248+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
249+ 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)
250+ tupleToList (a, b, c, d, e, f, g, h)
251+ = a :> b :> c :> d:> e :> f :> g :> h :> Nil
252+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> Nil)
253+ = (a, b, c, d, e, f, g, h)
254+
255+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
256+ 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)
257+ tupleToList (a, b, c, d, e, f, g, h, j)
258+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> Nil
259+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> Nil)
260+ = (a, b, c, d, e, f, g, h, j)
261+
262+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
263+ 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)
264+ tupleToList (a, b, c, d, e, f, g, h, j, k)
265+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> Nil
266+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> Nil)
267+ = (a, b, c, d, e, f, g, h, j, k)
268+
269+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
270+ 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)
271+ tupleToList (a, b, c, d, e, f, g, h, j, k, l)
272+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> Nil
273+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> Nil)
274+ = (a, b, c, d, e, f, g, h, j, k, l)
275+
276+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
277+ 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)
278+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m)
279+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> Nil
280+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> Nil)
281+ = (a, b, c, d, e, f, g, h, j, k, l, m)
282+
283+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
284+ 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)
285+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n)
286+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil
287+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil)
288+ = (a, b, c, d, e, f, g, h, j, k, l, m, n)
289+
290+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
291+ 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)
292+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
293+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil
294+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil)
295+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
296+
297+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
298+ 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)
299+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
300+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil
301+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil)
302+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
303+
304+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
305+ 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)
306+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
307+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil
308+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil)
309+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
310+
311+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
312+ 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)
313+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
314+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil
315+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil)
316+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
317+
318+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
319+ 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)
320+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
321+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil
322+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil)
323+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
324+
325+type family TupleToList a where
326+ TupleToList () = '[]
327+ TupleToList (a, b) = '[ '( '(), a), '( '(), b)]
328+ TupleToList (a, b, c) = '[ '( '(), a), '( '(), b), '( '(), c)]
329+ TupleToList (a, b, c, d) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d)]
330+ TupleToList (a, b, c, d, e) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e)]
331+ TupleToList (a, b, c, d, e, f) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f)]
332+ TupleToList (a, b, c, d, e, f, g) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g)]
333+ TupleToList (a, b, c, d, e, f, g, h) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h)]
334+ TupleToList (a, b, c, d, e, f, g, h, j) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j)]
335+ TupleToList (a, b, c, d, e, f, g, h, j, k) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k)]
336+ TupleToList (a, b, c, d, e, f, g, h, j, k, l) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l)]
337+ 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)]
338+ 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)]
339+ 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)]
340+ 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)]
341+ 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)]
342+ 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)]
343+ 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)]
344+ 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.Internal.Lens
37+
38+import Data.Generics.Product.Internal.List
3739import Data.Kind (Type)
3840import Data.Type.Bool (If, Not)
3941import GHC.Generics
40−import GHC.TypeLits (type (<=?), type (+), Nat)
41−
42−-- | Alias for the kind of the generic rep
43−type G = Type -> Type
44−
45−--------------------------------------------------------------------------------
46−
47−-- | In-order labeling of the generic tree with the field positions
48−--
49−-- We replace the (K1 R a) nodes with (K1 (Pos n) a), where 'n' is the position
50−-- of the field in question in the data type. This is convenient, because we
51−-- can reuse all the existing functions as long as they are polymorphic in the
52−-- first parameter of 'K1'.
53−type family CRep (a :: Type) :: G where
54− CRep rep = Fst (Traverse (Rep rep) 1)
42+import GHC.TypeLits (type (<=?), type (+), type (-), Nat)
5543
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)
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
7248
73−type family Traverse1 (w :: G -> G) (z :: (G, Nat)) :: (G, Nat) where
74− Traverse1 w '(i, n) = '(w i, n)
49+type GHasPosition' i s a = GHasPosition i s s a a
7550
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)
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)
8053
81−--------------------------------------------------------------------------------
82−-- Utilities
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
8356
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.Internal.Lens
35+import Data.Generics.Product.Internal.Keyed
3636
3737import Data.Kind (Type)
3838import GHC.Generics
39−import GHC.TypeLits (Symbol)
40−import Data.Generics.Internal.Profunctor.Lens (view)
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.Internal.Lens
31+import Data.Generics.Product.Internal.List
32+import Data.Kind
33+import GHC.Generics
34+import GHC.TypeLits
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+28−124
@@ -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,27 +32,21 @@ module Data.Generics.Product.Positions
3432
3533 -- $setup
3634 HasPosition (..)
37− , HasPosition' (..)
38− , HasPosition_ (..)
39− , HasPosition0 (..)
35+ , HasPosition'
4036
4137 , getPosition
4238 , setPosition
4339 ) where
4440
45−import Data.Generics.Internal.VL.Lens as VL
41+import Data.Generics.Internal.Lens
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
5850
5951-- $setup
6052-- == /Running example:/
@@ -65,7 +57,7 @@ import Data.Coerce
6557-- >>> :set -XGADTs
6658-- >>> :set -XFlexibleContexts
6759-- >>> import GHC.Generics
68−-- >>> :m +Data.Generics.Internal.VL.Lens
60+-- >>> :m +Data.Generics.Internal.Lens
6961-- >>> :m +Data.Function
7062-- >>> :{
7163-- data Human = Human
@@ -94,127 +86,42 @@ class HasPosition (i :: Nat) s t a b | s i -> a, t i -> b, s i b -> t, t i a ->
9486 -- ...
9587 -- ... The type Human does not contain a field at position 4
9688 -- ...
97− position :: VL.Lens s t a b
89+ position :: LensVL s t a b
9890
99−class HasPosition_ (i :: Nat) s t a b where
100− position_ :: VL.Lens s t a b
91+type HasPosition' i s a = HasPosition i s s a a
10192
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
12193getPosition :: forall i s a. HasPosition' i s a => s -> a
122−getPosition s = s ^. position' @i
94+getPosition s = s ^. position @i
12395
124−-- |
125−-- >>> setPosition @2 60 human
126−-- Human {name = "Tunyasz", age = 60, address = "London"}
12796setPosition :: forall i s a. HasPosition' i s a => a -> s -> s
128−setPosition = VL.set (position' @i)
97+setPosition = setVL (position @i)
12998
130−instance
99+instance -- see Note [Changing type parameters]
131100 ( Generic s
132101 , 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
102+ , Generic t
103+ -- see Note [CPP in instance constraints]
104+#if __GLASGOW_HASKELL__ < 802
105+ , '(s', t') ~ '(Proxied s, Proxied t)
180106#else
181−-- >>> :t position
182−-- position
183−-- :: (Functor f, HasPosition i s t a b) => (a -> f b) -> s -> f t
107+ , s' ~ Proxied s
108+ , t' ~ Proxied t
184109#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_ #-}
110+ , Generic s'
111+ , Generic t'
112+ , GHasPosition' i (Rep s) a
113+ , GHasPosition' i (Rep s') a'
114+ , GHasPosition i (Rep s) (Rep t) a b
115+ , t ~ Infer s a' b
116+ , GHasPosition' i (Rep t') b'
117+ , s ~ Infer t b' a
118+ ) => HasPosition i s t a b where
199119
200−instance {-# OVERLAPPING #-} HasPosition_ f (Void1 a) (Void1 b) a b where
201− position_ = undefined
120+ position f s = ravel (repLens . gposition @i) f s
202121
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 #-}
122+-- See Note [Uncluttering type signatures]
123+instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where
124+ position = undefined
218125
219126type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint where
220127 ErrorUnless i s 'False
@@ -227,6 +134,3 @@ type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint wher
227134
228135 ErrorUnless _ _ 'True
229136 = ()
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+8−49
@@ -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
@@ -34,15 +33,13 @@ module Data.Generics.Product.Subtype
3433 ) where
3534
3635import Data.Generics.Internal.Families
37−import Data.Generics.Internal.VL.Lens as VL
36+import Data.Generics.Internal.Lens
3837import Data.Generics.Internal.Void
3938import Data.Generics.Product.Internal.Subtype
4039
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
4643
4744-- $setup
4845-- == /Running example:/
@@ -52,7 +49,7 @@ import Data.Generics.Internal.Errors
5249-- >>> :set -XDeriveGeneric
5350-- >>> :set -XDuplicateRecordFields
5451-- >>> import GHC.Generics
55−-- >>> :m +Data.Generics.Internal.VL.Lens
52+-- >>> :m +Data.Generics.Internal.Lens
5653-- >>> :{
5754-- data Human = Human
5855-- { name :: String
@@ -83,9 +80,9 @@ class Subtype sup sub where
8380 --
8481 -- >>> set (super @Animal) (Animal "dog" 10) human
8582 -- Human {name = "dog", age = 10, address = "London"}
86− super :: VL.Lens sub sub sup sup
83+ super :: LensVL sub sub sup sup
8784 super
88− = VL.lens upcast (uncurry smash . swap)
85+ = lensVL upcast (uncurry smash . swap)
8986
9087 -- |Cast the more specific subtype to the more general supertype
9188 --
@@ -106,7 +103,7 @@ class Subtype sup sub where
106103 -- >>> smash (Animal "dog" 10) human
107104 -- Human {name = "dog", age = 10, address = "London"}
108105 smash :: sup -> sub -> sub
109− smash = VL.set (super @sup)
106+ smash = setVL (super @sup)
110107
111108 {-# MINIMAL super | smash, upcast #-}
112109
@@ -115,52 +112,14 @@ instance
115112 , Generic b
116113 , GSmash (Rep a) (Rep b)
117114 , GUpcast (Rep a) (Rep b)
118− , CustomError a b
115+ , ErrorUnless b a (CollectFieldsOrdered (Rep b) \\ CollectFieldsOrdered (Rep a))
119116 ) => Subtype b a where
120117 smash p b = to $ gsmash (from p) (from b)
121118 upcast = to . gupcast . from
122119
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
120+-- See Note [Uncluttering type signatures]
151121instance {-# OVERLAPPING #-} Subtype a Void where
152122 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
164123instance {-# OVERLAPPING #-} Subtype Void a where
165124 super = undefined
166125
src/Data/Generics/Product/Typed.hs+10−38
@@ -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
@@ -33,15 +31,13 @@ module Data.Generics.Product.Typed
3331 ) where
3432
3533import Data.Generics.Internal.Families
36−import Data.Generics.Internal.VL.Lens as VL
34+import Data.Generics.Internal.Lens
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 (..))
43−import Data.Generics.Internal.Profunctor.Lens
44−import Data.Generics.Internal.Errors
4541
4642-- $setup
4743-- == /Running example:/
@@ -50,7 +46,7 @@ import Data.Generics.Internal.Errors
5046-- >>> :set -XDataKinds
5147-- >>> :set -XDeriveGeneric
5248-- >>> import GHC.Generics
53−-- >>> :m +Data.Generics.Internal.VL.Lens
49+-- >>> :m +Data.Generics.Internal.Lens
5450-- >>> :{
5551-- data Human
5652-- = Human
@@ -95,10 +91,9 @@ class HasType a s where
9591 -- ... The offending constructors are:
9692 -- ... HumanNoTall
9793 -- ...
98− typed :: VL.Lens s s a a
94+ typed :: LensVL s s a a
9995 typed
100− = VL.lens (getTyped @a) (uncurry (setTyped @a) . swap)
101− {-# INLINE typed #-}
96+ = lensVL (getTyped @a) (uncurry (setTyped @a) . swap)
10297
10398 -- |Get field at type.
10499 getTyped :: s -> a
@@ -106,38 +101,19 @@ class HasType a s where
106101
107102 -- |Set field at type.
108103 setTyped :: a -> s -> s
109− setTyped = VL.set (typed @a)
104+ setTyped = setVL (typed @a)
110105
111106 {-# MINIMAL typed | setTyped, getTyped #-}
112107
113108instance
114109 ( Generic s
115110 , 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
111+ , GHasKey a (Rep s) (Rep s) a a
120112 ) => HasType a s where
121113
122− typed f s = VL.ravel (repLens . glens @(HasTotalTypePSym a)) f s
114+ typed = ravel (repLens . gkey @a)
123115
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.
116+-- See Note [Uncluttering type signatures]
141117instance {-# OVERLAPPING #-} HasType a Void where
142118 typed = undefined
143119
@@ -172,7 +148,3 @@ type family ErrorUnlessOne (a :: Type) (s :: Type) (stat :: TypeStat) :: Constra
172148
173149 ErrorUnlessOne _ _ ('TypeStat '[] '[] _)
174150 = ()
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+14−333
@@ -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
52−
53−import GHC.Generics
54−import GHC.TypeLits
55−import Data.Generics.Internal.VL.Traversal
56−import Data.Generics.Internal.Errors
57−
58−-- $setup
59−-- == /Running example:/
60−--
61−-- >>> :set -XTypeApplications
62−-- >>> :set -XDeriveGeneric
63−-- >>> :set -XScopedTypeVariables
64−-- >>> import GHC.Generics
65−-- >>> :m +Data.Generics.Internal.VL.Traversal
66−-- >>> :m +Data.Generics.Internal.VL.Lens
67−-- >>> :{
68−-- data WTree a w
69−-- = Leaf a
70−-- | Fork (WTree a w) (WTree a w)
71−-- | WithWeight (WTree a w) w
72−-- deriving (Generic, Show)
73−-- :}
74−
75−--------------------------------------------------------------------------------
76−-- HasTypes
77−--------------------------------------------------------------------------------
33+import Data.Generics.Internal.Lens
34+import Data.Generics.Product.Internal.Types
7835
79−-- TODO [1.0.0.0]: use type-changing variant internally
36+import GHC.Generics (Generic (Rep), from, to)
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+5−5
@@ -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
@@ -28,9 +28,9 @@ module Data.Generics.Sum.Any
2828 AsAny (..)
2929 ) where
3030
31+import Data.Generics.Internal.Lens
3132import Data.Generics.Sum.Constructors
3233import Data.Generics.Sum.Typed
33−import Data.Generics.Internal.VL.Prism
3434
3535-- $setup
3636-- == /Running example:/
@@ -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.
@@ -86,7 +86,7 @@ class AsAny sel a s | s sel -> a where
8686 --
8787 -- >>> duck ^? _As @Age
8888 -- Just 2
89− _As :: Prism s s a a
89+ _As :: PrismVL s s a a
9090
9191instance AsConstructor ctor s s a a => AsAny ctor a s where
9292 _As = _Ctor @ctor
src/Data/Generics/Sum/Constructors.hs+20−91
@@ -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,22 +30,16 @@ module Data.Generics.Sum.Constructors
3030
3131 -- $setup
3232 AsConstructor (..)
33− , AsConstructor_ (..)
34− , AsConstructor' (..)
35− , AsConstructor0 (..)
3633 ) where
3734
3835import Data.Generics.Internal.Families
36+import Data.Generics.Internal.Lens
3937import Data.Generics.Internal.Void
4038import Data.Generics.Sum.Internal.Constructors
4139
4240import Data.Kind (Constraint, Type)
4341import GHC.Generics (Generic (Rep))
4442import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
45−import Data.Generics.Internal.VL.Prism
46−import Data.Generics.Internal.Profunctor.Iso
47−import Data.Generics.Internal.Profunctor.Prism (prismPRavel)
48−import Data.Generics.Internal.Errors
4943
5044-- $setup
5145-- == /Running example:/
@@ -56,7 +50,7 @@ import Data.Generics.Internal.Errors
5650-- >>> :set -XFlexibleContexts
5751-- >>> :set -XTypeFamilies
5852-- >>> import GHC.Generics
59−-- >>> :m +Data.Generics.Internal.VL.Prism
53+-- >>> :m +Data.Generics.Internal.Lens
6054-- >>> :m +Data.Generics.Product.Fields
6155-- >>> :m +Data.Function
6256-- >>> :{
@@ -71,7 +65,7 @@ import Data.Generics.Internal.Errors
7165-- , age :: Age
7266-- , fieldA :: a
7367-- }
74−-- deriving Show
68+-- deriving (Generic, Show)
7569-- type Name = String
7670-- type Age = Int
7771-- dog, cat, duck :: Animal Int
@@ -104,101 +98,36 @@ class AsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where
10498 -- ...
10599 -- ... The type Animal Int does not contain a constructor named "Turtle"
106100 -- ...
107− _Ctor :: Prism s t a b
108−
109−-- |Sums that have a constructor with a given name.
110−--
111−-- The difference between 'HasConstructor' and 'HasConstructor_' is similar to
112−-- the one between 'Data.Generics.Product.Fields.HasField' and
113−-- 'Data.Generics.Product.Fields.HasField_'.
114−-- See 'Data.Generics.Product.Fields.HasField_'.
115−class AsConstructor_ (ctor :: Symbol) s t a b where
116− _Ctor_ :: Prism s t a b
117−
118−class AsConstructor' (ctor :: Symbol) s a | ctor s -> a where
119− _Ctor' :: Prism s s a a
120−
121−-- |Sums that have a constructor with a given name.
122−--
123−-- This class gives the minimal constraints needed to define this prism.
124−-- For common uses, see 'HasConstructor'.
125−class AsConstructor0 (ctor :: Symbol) s t a b where
126− _Ctor0 :: Prism s t a b
101+ _Ctor :: PrismVL s t a b
127102
128103instance
129104 ( Generic s
130105 , ErrorUnless ctor s (HasCtorP ctor (Rep s))
106+ , Generic t
107+ -- see Note [CPP in instance constraints]
108+#if __GLASGOW_HASKELL__ < 802
109+ , '(s', t') ~ '(Proxied s, Proxied t)
110+#else
111+ , s' ~ Proxied s
112+ , t' ~ Proxied t
113+#endif
114+ , Generic s'
115+ , Generic t'
131116 , 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'
117+ , GAsConstructor' ctor (Rep s') a'
145118 , GAsConstructor ctor (Rep s) (Rep t) a b
146119 , t ~ Infer s a' b
147− , GAsConstructor' ctor (Rep (Indexed t)) b'
120+ , GAsConstructor' ctor (Rep t') b'
148121 , s ~ Infer t b' a
149− , AsConstructor0 ctor s t a b
150122 ) => AsConstructor ctor s t a b where
151123
152− _Ctor = _Ctor0 @ctor
153− {-# INLINE[2] _Ctor #-}
124+ _Ctor eta = prismVLRavel (repIso . _GCtor @ctor) eta
125+ {-# INLINE _Ctor #-}
154126
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
127+-- See Note [Uncluttering type signatures]
169128instance {-# OVERLAPPING #-} AsConstructor ctor (Void1 a) (Void1 b) a b where
170129 _Ctor = undefined
171130
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−
202131type family ErrorUnless (ctor :: Symbol) (s :: Type) (contains :: Bool) :: Constraint where
203132 ErrorUnless ctor s 'False
204133 = TypeError
src/Data/Generics/Sum/Internal/Constructors.hs+14−14
@@ -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,14 +30,12 @@ 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
34+import Data.Generics.Internal.Lens
3535
3636import GHC.Generics
3737import GHC.TypeLits (Symbol)
38−import Data.Generics.Internal.Profunctor.Lens
39−import Data.Generics.Internal.Profunctor.Iso
40−import Data.Generics.Internal.Profunctor.Prism
38+import Data.Kind
4139
4240-- |As 'AsConstructor' but over generic representations as defined by
4341-- "GHC.Generics".
@@ -47,30 +45,32 @@ class GAsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where
4745type GAsConstructor' ctor s a = GAsConstructor ctor s s a a
4846
4947instance
50− ( GIsList f f as as
51− , GIsList g g bs bs
48+ ( GIsList Type f f as as
49+ , GIsList Type g g bs bs
5250 , ListTuple a as
5351 , ListTuple b bs
5452 ) => GAsConstructor ctor (M1 C ('MetaCons ctor fixity fields) f) (M1 C ('MetaCons ctor fixity fields) g) a b where
5553
56− _GCtor = dimap (listToTuple . view glist . unM1) (M1 . view (fromIso glist) . tupleToList)
57− {-# INLINE[0] _GCtor #-}
54+-- _GCtor = prismP (M1 . gfromCollection . tupleToList) (Right . listToTuple . gtoCollection . unM1)
55+-- {-# INLINE _GCtor #-}
56+ _GCtor = prism (M1 . (view (fromIso (glist @Type))) . tupleToList) (Right . listToTuple . (view (glist @Type)) . unM1)
57+
5858
5959instance GSumAsConstructor ctor (HasCtorP ctor l) l r l' r' a b => GAsConstructor ctor (l :+: r) (l' :+: r') a b where
6060 _GCtor = _GSumCtor @ctor @(HasCtorP ctor l)
61− {-# INLINE[0] _GCtor #-}
61+ {-# INLINE _GCtor #-}
6262
6363instance GAsConstructor ctor f f' a b => GAsConstructor ctor (M1 D meta f) (M1 D meta f') a b where
6464 _GCtor = mIso . _GCtor @ctor
65− {-# INLINE[0] _GCtor #-}
65+ {-# INLINE _GCtor #-}
6666
6767class GSumAsConstructor (ctor :: Symbol) (contains :: Bool) l r l' r' a b | ctor l r -> a, ctor l' r' -> b where
6868 _GSumCtor :: Prism ((l :+: r) x) ((l' :+: r') x) a b
6969
7070instance GAsConstructor ctor l l' a b => GSumAsConstructor ctor 'True l r l' r a b where
7171 _GSumCtor = left . _GCtor @ctor
72− {-# INLINE[0] _GSumCtor #-}
72+ {-# INLINE _GSumCtor #-}
7373
7474instance GAsConstructor ctor r r' a b => GSumAsConstructor ctor 'False l r l r' a b where
7575 _GSumCtor = right . _GCtor @ctor
76− {-# INLINE[0] _GSumCtor #-}
76+ {-# INLINE _GSumCtor #-}
src/Data/Generics/Sum/Internal/Subtype.hs+16−73
@@ -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,12 @@ module Data.Generics.Sum.Internal.Subtype
2827 ( GAsSubtype (..)
2928 ) where
3029
31−import Data.Generics.Product.Internal.HList
30+import Data.Generics.Internal.Lens
31+import Data.Generics.Product.Internal.List
3232import Data.Generics.Sum.Internal.Typed
3333
3434import Data.Kind
3535import GHC.Generics
36−import Data.Generics.Internal.Profunctor.Iso
37−import Data.Generics.Internal.Profunctor.Prism
38−import Data.Generics.Internal.Families.Has
3936
4037-- |As 'AsSubtype' but over generic representations as defined by
4138-- "GHC.Generics".
@@ -43,73 +40,19 @@ class GAsSubtype (subf :: Type -> Type) (supf :: Type -> Type) where
4340 _GSub :: Prism' (supf x) (subf x)
4441
4542instance
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 #-}
43+ ( GAsSubtype l supf
44+ , GAsSubtype r supf
45+ ) => GAsSubtype (l :+: r) supf where
46+ _GSub = without' _GSub _GSub . fromIso sumIso
6147
6248instance
63− ( GIsList subf subf as as
49+ ( GIsList () subf subf as as
6450 , 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 #-}
51+ ) => GAsSubtype (C1 meta subf) supf where
52+ _GSub = _GTyped . fromIso (glist @()) . fromIso mIso
7253
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 #-}
54+-- instance GAsType supf a => GAsSubtype (S1 meta (Rec0 a)) supf where
55+-- _GSub = _GTyped . fromIso (mIso . kIso)
11556
57+instance GAsSubtype subf supf => GAsSubtype (D1 meta subf) supf where
58+ _GSub = _GSub . fromIso mIso
src/Data/Generics/Sum/Internal/Typed.hs+9−22
@@ -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,31 @@ 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
36−import Data.Generics.Internal.Profunctor.Iso
37−import Data.Generics.Internal.Profunctor.Prism
34+import Data.Generics.Product.Internal.List
35+import Data.Generics.Internal.Lens
3836
3937-- |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−
38+class GAsType (f :: Type -> Type) (as :: [((), Type)]) where
39+ _GTyped :: Prism (f x) (f x) (List as) (List as)
4840
4941instance
50− ( GIsList f f as as
42+ ( GIsList () f f as as
5143 ) => GAsType (M1 C meta f) as where
52− _GTyped = mIso . glist
53− {-# INLINE[0] _GTyped #-}
44+ _GTyped = mIso . glist @()
5445
5546instance GSumAsType (HasPartialTypeP a l) l r a => GAsType (l :+: r) a where
5647 _GTyped = _GSumTyped @(HasPartialTypeP a l)
57− {-# INLINE[0] _GTyped #-}
5848
5949instance GAsType f a => GAsType (M1 D meta f) a where
6050 _GTyped = mIso . _GTyped
61− {-# INLINE[0] _GTyped #-}
6251
63−class GSumAsType (contains :: Bool) l r (a :: [Type]) where
64− _GSumTyped :: Prism ((l :+: r) x) ((l :+: r) x) (HList a) (HList a)
52+class GSumAsType (contains :: Bool) l r (a :: [((), Type)]) where
53+ _GSumTyped :: Prism ((l :+: r) x) ((l :+: r) x) (List a) (List a)
6554
6655instance GAsType l a => GSumAsType 'True l r a where
6756 _GSumTyped = left . _GTyped
68− {-# INLINE[0] _GSumTyped #-}
6957
7058instance GAsType r a => GSumAsType 'False l r a where
7159 _GSumTyped = right . _GTyped
72− {-# INLINE[0] _GSumTyped #-}
src/Data/Generics/Sum/Subtype.hs+12−53
@@ -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
@@ -29,12 +27,11 @@ module Data.Generics.Sum.Subtype
2927 AsSubtype (..)
3028 ) where
3129
30+import Data.Generics.Internal.Lens
3231import Data.Generics.Internal.Void
3332import Data.Generics.Sum.Internal.Subtype
3433
3534import GHC.Generics (Generic (Rep))
36−import Data.Generics.Internal.VL.Prism
37−import Data.Generics.Internal.Profunctor.Iso
3835
3936-- $setup
4037-- == /Running example:/
@@ -43,7 +40,7 @@ import Data.Generics.Internal.Profunctor.Iso
4340-- >>> :set -XDataKinds
4441-- >>> :set -XDeriveGeneric
4542-- >>> import GHC.Generics
46−-- >>> :m +Data.Generics.Internal.VL.Prism
43+-- >>> :m +Data.Generics.Internal.Lens
4744-- >>> :{
4845-- data Animal
4946-- = Dog Dog
@@ -89,19 +86,17 @@ class AsSubtype sub sup where
8986 --
9087 -- >>> duck ^? _Sub :: Maybe FourLeggedAnimal
9188 -- Nothing
92− _Sub :: Prism' sup sub
93− _Sub = prism injectSub (\i -> maybe (Left i) Right (projectSub i))
94− {-# INLINE[2] _Sub #-}
89+ _Sub :: PrismVL' sup sub
90+ _Sub eta = prismVL injectSub projectSub eta
91+ {-# INLINE _Sub #-}
9592
9693 -- |Injects a subtype into a supertype (upcast).
9794 injectSub :: sub -> sup
98− injectSub
99− = build (_Sub @sub @sup)
95+ injectSub = buildVL (_Sub @sub @sup)
10096
10197 -- |Projects a subtype from a supertype (downcast).
102− projectSub :: sup -> Maybe sub
103− projectSub
104− = either (const Nothing) Just . match (_Sub @sub @sup)
98+ projectSub :: sup -> Either sup sub
99+ projectSub = matchVL (_Sub @sub @sup)
105100
106101 {-# MINIMAL (injectSub, projectSub) | _Sub #-}
107102
@@ -111,48 +106,12 @@ instance
111106 , GAsSubtype (Rep sub) (Rep sup)
112107 ) => AsSubtype sub sup where
113108
114− _Sub f = prismRavel (repIso . _GSub . fromIso repIso) f
115− {-# INLINE[2] _Sub #-}
109+ _Sub = prismVLRavel (repIso . _GSub . fromIso repIso)
116110
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
111+-- See Note [Uncluttering type signatures]
138112instance {-# OVERLAPPING #-} AsSubtype a Void where
139113 injectSub = undefined
140114 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
156115instance {-# OVERLAPPING #-} AsSubtype Void a where
157116 injectSub = undefined
158117 projectSub = undefined
src/Data/Generics/Sum/Typed.hs+18−48
@@ -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,18 @@ 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
39+import Data.Generics.Internal.Lens
4140import Data.Generics.Internal.Void
42−import Data.Generics.Product.Internal.HList
43−import Data.Generics.Internal.VL.Prism
44−import Data.Generics.Internal.Profunctor.Iso
45−import Data.Generics.Internal.Profunctor.Prism (prismPRavel)
41+import Data.Generics.Product.Internal.List
4642
4743-- $setup
4844-- >>> :set -XTypeApplications
4945-- >>> :set -XDataKinds
5046-- >>> :set -XDeriveGeneric
5147-- >>> import GHC.Generics
52−-- >>> :m +Data.Generics.Internal.VL.Prism
48+-- >>> :m +Data.Generics.Internal.Lens
5349-- >>> :{
5450-- data Animal
5551-- = Dog Dog
@@ -89,21 +85,17 @@ class AsType a s where
8985 -- ... Duck
9086 -- ... Turtle
9187 -- ...
92− _Typed :: Prism' s a
93− _Typed = prism injectTyped (\i -> maybe (Left i) Right (projectTyped i))
94− {-# INLINE[2] _Typed #-}
88+ _Typed :: PrismVL' s a
9589
9690 -- |Inject by type.
9791 injectTyped :: a -> s
9892 injectTyped
99− = build _Typed
93+ = buildVL _Typed
10094
10195 -- |Project by type.
10296 projectTyped :: s -> Maybe a
10397 projectTyped
104− = either (const Nothing) Just . match _Typed
105−
106− {-# MINIMAL (injectTyped, projectTyped) | _Typed #-}
98+ = either (const Nothing) Just . (matchVL _Typed)
10799
108100instance
109101 ( Generic s
@@ -111,45 +103,23 @@ instance
111103 , as ~ TupleToList a
112104 , ListTuple a as
113105 , 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)
117106 ) => AsType a s where
118107
119− _Typed eta = prismRavel (prismPRavel (repIso . _GTyped @_ @as . tupled)) eta
120− {-# INLINE[2] _Typed #-}
121−
122−-- | See Note [Uncluttering type signatures]
123−#if __GLASGOW_HASKELL__ < 804
124−-- >>> :t _Typed
125−-- _Typed
126−-- :: (Applicative f, Data.Profunctor.Choice.Choice p, AsType a s) =>
127−-- p a (f a) -> p s (f s)
128−#else
129−-- >>> :t _Typed
130−-- _Typed
131−-- :: (AsType a s, Data.Profunctor.Choice.Choice p, Applicative f) =>
132−-- p a (f a) -> p s (f s)
133−#endif
108+-- _Typed
109+-- = prism injectTyped (either (Left . to) Right . gprojectTyped . from)
110+-- {-# INLINE _Typed #-}
111+-- injectTyped
112+-- = to . ginjectTyped
113+-- projectTyped
114+-- = either (const Nothing) Just . gprojectTyped . from
115+ _Typed = prismVLRavel (repIso . _GTyped @_ @as . tupled)
116+ {-# INLINE _Typed #-}
117+
118+-- See Note [Uncluttering type signatures]
134119instance {-# OVERLAPPING #-} AsType a Void where
135120 _Typed = undefined
136121 injectTyped = undefined
137122 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
153123instance {-# OVERLAPPING #-} AsType Void a where
154124 _Typed = undefined
155125 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-9.2
22
33packages:
44- '.'
55
6+extra-deps:
7+- 'inspection-testing-0.1.1.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+47−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,29 +10,19 @@
1110{-# LANGUAGE ScopedTypeVariables #-}
1211{-# LANGUAGE TypeApplications #-}
1312{-# LANGUAGE TemplateHaskell #-}
14−{-# LANGUAGE OverloadedLabels #-}
13+-- For the VL prism test
1514
1615module Main where
1716
1817import GHC.Generics
18+import Data.Profunctor
1919import Data.Generics.Product
20+import Data.Generics.Internal.Lens (prismPRavel, plus)
2021import Data.Generics.Sum
2122import Test.Inspection
2223import Test.HUnit
2324import Util
2425import System.Exit
25−import Data.Generics.Internal.VL.Lens
26−import Data.Generics.Internal.VL.Prism
27−import Data.Generics.Internal.VL.Traversal
28−import Control.Lens (_1, (+~))
29−import Data.Function ((&))
30−import Data.Generics.Labels ()
31−
32−-- This is sufficient at we only want to test that they typecheck
33−import Test24 ()
34−import Test25 ()
35−
36−import CustomChildren (customTypesTest)
3726
3827main :: IO ()
3928main = do
@@ -56,6 +45,24 @@ data Record3 a = MkRecord3
5645 , fieldB :: Bool
5746 } deriving (Generic, Show)
5847
48+type Lens' s a = Lens s s a a
49+type Prism' s a = Prism s s a a
50+type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t
51+type Prism s t a b =
52+ forall p f . (Choice p, Applicative f) => p a (f b) -> p s (f t)
53+
54+type PrismP s t a b =
55+ forall p . (Choice p) => p a b -> p s t
56+type Traversal' s a = forall f. Applicative f => (a -> f a) -> s -> f s
57+
58+prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
59+prism bt seta eta = dimap (\x -> plus pure id (seta x)) (either id (\x -> fmap bt x)) (right' eta)
60+{-# INLINE prism #-}
61+
62+prismP :: (b -> t) -> (s -> Either t a) -> PrismP s t a b
63+prismP bt seta eta = dimap seta (either id bt) (right' eta)
64+{-# INLINE prismP #-}
65+
5966data Record4 a = MkRecord4
6067 { fieldA :: a
6168 , fieldB :: a
@@ -70,6 +77,8 @@ data Record5 = MkRecord5
7077 , fieldF :: Int
7178 } deriving Generic
7279
80+
81+
7382typeChangingManual :: Lens (Record3 a) (Record3 b) a b
7483typeChangingManual f (MkRecord3 a b) = (\a' -> MkRecord3 a' b) <$> f a
7584
@@ -97,36 +106,6 @@ subtypeLensManual f record
97106data Sum1 = A Char | B Int | C () | D () deriving (Generic, Show)
98107data Sum2 = A2 Char | B2 Int deriving (Generic, Show)
99108
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−
130109sum1PrismManual :: Prism Sum1 Sum1 Int Int
131110sum1PrismManual eta = prism g f eta
132111 where
@@ -135,42 +114,22 @@ sum1PrismManual eta = prism g f eta
135114 s -> Left s
136115 g = B
137116
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
117+sum1PrismPManual :: PrismP Sum1 Sum1 Int Int
118+sum1PrismPManual eta = prismP g f eta
159119 where
160120 f s1 = case s1 of
161− A2 i -> Right i
162− s -> Left s
163− g = A2
121+ B i -> Right i
122+ s -> Left s
123+ g = B
164124
165−-- Note we don't have a catch-all case because of #14684
166125subtypePrismManual :: Prism Sum1 Sum1 Sum2 Sum2
167126subtypePrismManual eta = prism g f eta
168127 where
169128 f s1 = case s1 of
170129 A c -> Right (A2 c)
171130 B i -> Right (B2 i)
172− C _ -> Left s1
173− D _ -> Left s1
131+ C _ -> Left s1
132+ D _ -> Left s1
174133 g (A2 c) = A c
175134 g (B2 i) = B i
176135
@@ -185,92 +144,47 @@ subtypePrismManual eta = prism g f eta
185144fieldALensName :: Lens' Record Int
186145fieldALensName = field @"fieldA"
187146
188−fieldALensName_ :: Lens' Record Int
189−fieldALensName_ = field_ @"fieldA"
190−
191147fieldALensType :: Lens' Record Int
192148fieldALensType = typed @Int
193149
194150fieldALensPos :: Lens' Record Int
195151fieldALensPos = position @1
196152
197−fieldALensPos_ :: Lens' Record Int
198−fieldALensPos_ = position_ @1
199−
200153subtypeLensGeneric :: Lens' Record Record2
201154subtypeLensGeneric = super
202155
203156typeChangingGeneric :: Lens (Record3 a) (Record3 b) a b
204−typeChangingGeneric = #fieldA
157+typeChangingGeneric = field @"fieldA"
205158
206159typeChangingGenericPos :: Lens (Record3 a) (Record3 b) a b
207160typeChangingGenericPos = position @1
208161
209162typeChangingGenericCompose :: 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"
163+typeChangingGenericCompose = field @"fieldA" . field @"fieldA"
214164
215165sum1PrismB :: Prism Sum1 Sum1 Int Int
216166sum1PrismB = _Ctor @"B"
217167
168+--sum1PrismBP :: PrismP Sum1 Sum1 Int Int
169+--sum1PrismBP = prismPRavel (_CtorRaw @"B")
170+
218171subtypePrismGeneric :: Prism Sum1 Sum1 Sum2 Sum2
219172subtypePrismGeneric = _Sub
220173
221174sum1TypePrism :: Prism Sum1 Sum1 Int Int
222175sum1TypePrism = _Typed @Int
223176
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−
239177tests :: Test
240178tests = 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)
179+ [ $(inspectTest $ 'fieldALensManual === 'fieldALensName)
180+ , $(inspectTest $ 'fieldALensManual === 'fieldALensType)
181+ , $(inspectTest $ 'fieldALensManual === 'fieldALensPos)
182+ , $(inspectTest $ 'subtypeLensManual === 'subtypeLensGeneric)
183+ , $(inspectTest $ 'typeChangingManual === 'typeChangingGeneric)
184+ , $(inspectTest $ 'typeChangingManual === 'typeChangingGenericPos)
249185 , $(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
186+ , $(inspectTest $ 'intTraversalManual === 'intTraversalDerived)
187+ , $(inspectTest $ 'sum1PrismManual === 'sum1PrismB)
188+ -- , $(inspectTest $ 'sum1PrismPManual === 'sum1PrismBP)
189+ , $(inspectTest $ 'subtypePrismManual === 'subtypePrismGeneric)
190+ , $(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 _ = []