on master help sign in
70 files changed+4110−1585
since splitsnapshots
unifiedsplit
.github/FUNDING.yml+12 .gitignore+4 .gitmodules−4 .travis.yml+132−69 ChangeLog.md+35 LICENSE+1−1 README.md+238−78 cabal.haskell-ci+5 cabal.project+1 examples/Biscuits.hs+150 examples/Examples.hs+6−1 examples/doctest.hs+7 generic-lens.cabal+70−24 src/Data/GenericLens/Internal.hs+64 src/Data/GenericLens/Internal.hs~ src/Data/Generics/Internal/Errors.hs+59 src/Data/Generics/Internal/Families.hs+1−2 src/Data/Generics/Internal/Families/Changing.hs+49−16 src/Data/Generics/Internal/Families/Collect.hs+2−2 src/Data/Generics/Internal/Families/Has.hs+72−46 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+123−17 src/Data/Generics/Product.hs+8−3 src/Data/Generics/Product/Any.hs+5−5 src/Data/Generics/Product/Constraints.hs+57 src/Data/Generics/Product/Fields.hs+96−30 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+46−24 src/Data/Generics/Product/Internal/Subtype.hs+15−10 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+124−28 src/Data/Generics/Product/Subtype.hs+49−8 src/Data/Generics/Product/Typed.hs+38−10 src/Data/Generics/Product/Types.hs+333−14 src/Data/Generics/Sum.hs+1−1 src/Data/Generics/Sum/Any.hs+5−5 src/Data/Generics/Sum/Constructors.hs+91−20 src/Data/Generics/Sum/Internal/Constructors.hs+14−14 src/Data/Generics/Sum/Internal/Subtype.hs+73−16 src/Data/Generics/Sum/Internal/Typed.hs+22−9 src/Data/Generics/Sum/Subtype.hs+53−12 src/Data/Generics/Sum/Typed.hs+48−18 src/Data/Generics/Wrapped.hs+104 stack.yaml+1−4 test/Bifunctor.hs+47 test/CustomChildren.hs+63 test/Spec.hs+133−47 test/24.hs → test/Test24.hs+1−1 test/25.hs → test/Test25.hs+1−1 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.ymlnew file+12
@@ -0,0 +1,12 @@
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,3 +6,7 @@ cabal.sandbox.config
66.ghc*
77*.hi
88*.o
9+core-html
10+*~
11+*.org
12+cabal.project.local
.gitmodulesdeleted−4
@@ -1,4 +0,0 @@
1−[submodule "inspection-testing"]
2− path = inspection-testing
3− url = https://github.com/nomeata/inspection-testing.git
4− branch = master
.travis.yml+132−69
@@ -1,92 +1,155 @@
11# This Travis job script has been generated by a script via
22#
3−# make_travis_yml_2.hs 'generic-lens.cabal'
3+# haskell-ci '--config=cabal.haskell-ci' 'cabal.project'
44#
5−# For more information, see https://github.com/hvr/multi-ghc-travis
5+# For more information, see https://github.com/haskell-CI/haskell-ci
6+#
7+# version: 0.5.20190908
68#
79language: c
8−sudo: false
9−
10+dist: xenial
1011git:
11− submodules: true # whether to recursively clone submodules
12−
12+ # whether to recursively clone submodules
13+ submodules: false
1314cache:
1415 directories:
1516 - $HOME/.cabal/packages
1617 - $HOME/.cabal/store
17−
1818before_cache:
19− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
19+ - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log
2020 # remove files that are regenerated by 'cabal update'
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−
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
2727matrix:
2828 include:
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−
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"]}}
3941before_install:
40− - HC=${CC}
41− - HCPKG=${HC/ghc/ghc-pkg}
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"
4246 - unset CC
43− - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH
44−
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
4573install:
46− - cabal --version
74+ - ${CABAL} --version
4775 - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
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
63− - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
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.
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
67119script:
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"
120+ - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
121+ # Packaging...
122+ - ${CABAL} v2-sdist all | color_cabal_output
123+ # Unpacking...
124+ - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
125+ - cd ${DISTDIR} || false
126+ - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \;
127+ - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \;
128+ - PKGDIR_generic_lens="$(find . -maxdepth 1 -type d -regex '.*/generic-lens-[0-9.]*')"
129+ # Generate cabal.project
130+ - rm -rf cabal.project cabal.project.local cabal.project.freeze
131+ - touch cabal.project
132+ - |
133+ echo "packages: ${PKGDIR_generic_lens}" >> cabal.project
134+ - |
135+ - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(generic-lens)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
136+ - cat cabal.project || true
137+ - cat cabal.project.local || true
138+ # Building...
75139 # this builds all libraries and executables (without tests/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−
140+ - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output
141+ # Building with tests and benchmarks...
83142 # build & run tests, build benchmarks
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
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
90153
91−# REGENDATA ["generic-lens.cabal"]
154+# REGENDATA ["--config=cabal.haskell-ci","cabal.project"]
92155# EOF
ChangeLog.md+35
@@ -1,3 +1,38 @@
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+
136## 0.5.1.0
237- Infer input type from result type (#25)
338- Allow changing of multiple type parameters (#24)
LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2017, Csongor Kiss
1+Copyright (c) 2019, Csongor Kiss
22
33All rights reserved.
44
README.md+238−78
@@ -3,26 +3,69 @@
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 lenses and prisms for data types.
6+Generically derive traversals, lenses and prisms.
77
88Available on [Hackage](https://hackage.haskell.org/package/generic-lens)
99
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.
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 #-}
1455
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).
56+```
1757
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).
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.
2062
2163## Lenses
2264
23−### Record fields
65+A lens identifies exactly one part of a product type, and allows querying and
66+updating it.
2467
25−Record fields can be accessed by their label:
68+### By name
2669
2770```haskell
2871data Person = Person { name :: String, age :: Int } deriving (Generic, Show)
@@ -31,42 +74,83 @@ sally :: Person
3174sally = Person "Sally" 25
3275```
3376
34−```haskell
35−>>> getField @"age" sally
36−25
37−
38−>>> setField @"age" 26 sally
39−Person {name = "Sally", age = 26}
77+Record fields can be accessed by their label using the `field` lens.
4078
79+```haskell
4180>>> sally ^. field @"name"
4281"Sally"
4382
4483>>> sally & field @"name" .~ "Tamas"
4584Person {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.
4690
91+Or for standalone use, the `getField` and `setField` functions can be used instead.
92+```haskell
93+>>> getField @"age" sally
94+25
95+
96+>>> setField @"age" 26 sally
97+Person {name = "Sally", age = 26}
98+```
99+
100+When a non-existent field is requested, the library generates a helpful type error:
101+```haskell
47102>>> sally ^. field @"pet"
48103error:
49− • The type Person does not contain a field named "pet"
104+ • The type Person does not contain a field named 'pet'
50105```
51106
52−If the accessed field is a type parameter that appears uniquely in the type,
53−then its type can be changed:
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+```
54124
125+The type of `field` is
55126```haskell
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)
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.
63130
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}
131+```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)
138+
139+-- |
140+-- >>> foo2
141+-- Foo {foo = ["10"]}
142+foo2 :: Foo [] String
143+foo2 = foo1 & field @"foo" %~ (maybeToList . fmap show)
67144```
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!
68152
69−### Positional fields
153+### By position
70154
71155Fields can be accessed by their position in the data structure (index starting at 1):
72156
@@ -79,12 +163,6 @@ polygon = Polygon (Point 1 5 3) (Point 2 4 2) (Point 5 7 (-2))
79163```
80164
81165```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−
88166>>> polygon ^. position @1 . position @2
891675
90168
@@ -96,49 +174,34 @@ error:
96174 • The type Polygon does not contain a field at position 10
97175```
98176
99−Since tuples are an instance of `Generic`, they also have positional lenses:
177+Since tuples are an instance of `Generic`, the positional lens readily works:
100178
101179```haskell
102180>>> (("hello", True), 5) ^. position @1 . position @2
103181True
182+>>> (("hello", True, "or"), 5, "even", "longer") ^. position @1 . position @2
183+True
104184```
105185
106−### Typed fields
186+### By type
107187
108188Fields can be accessed by their type in the data structure, assuming that this
109189type is unique:
110190
111191```haskell
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
192+>>> sally ^. typed @String
124193"Sally"
125194
126195>>> setTyped @Int sally 26
127196Person {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]
136197```
137198
138−### Structural subtyping
199+### By structure
139200
140−A record is a (structural) `subtype' of another, if its fields are a superset of
141−those of the other.
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.
142205
143206```haskell
144207data Human = Human
@@ -157,16 +220,10 @@ human = Human {name = "Tunyasz", age = 50, address = "London"}
157220```
158221
159222```haskell
160−
161−>>> upcast human :: Animal
223+>>> human ^. super @Animal
162224Animal {name = "Tunyasz", age = 50}
163225
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
226+>>> upcast human :: Animal
170227Animal {name = "Tunyasz", age = 50}
171228```
172229
@@ -181,9 +238,96 @@ growUp (Animal name age) = Animal name (age + 50)
181238Human {name = "Tunyasz", age = 60, address = "London"}
182239```
183240
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+
184324## Prisms
185325
186−### Named constructors
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
187331
188332Constructor components can be accessed using the constructor's name:
189333
@@ -205,19 +349,20 @@ Just (MkDog {name = "Shep", age = 4})
205349
206350>>> shep ^? _Ctor @"Cat"
207351Nothing
352+```
353+
354+Constructors with multiple fields can be focused as a tuple
208355
356+```
209357>>> mog ^? _Ctor @"Cat"
210358Just ("Mog",5)
211359
212360>>> _Ctor @"Cat" # ("Garfield", 6) :: Animal
213361Cat "Garfield" 6
214362
215−>>> donald ^? _Ctor @"Giraffe"
216−error:
217− • The type Animal does not contain a constructor named "Giraffe"
218363```
219364
220−### Typed constructors
365+### By type
221366
222367Constructor components can be accessed using the component's type, assuming
223368that this type is unique:
@@ -227,10 +372,10 @@ type Name = String
227372type Age = Int
228373
229374data Dog = MkDog { name :: Name, age :: Age } deriving (Generic, Show)
230−data Animal = Dog Dog | Cat (Name, Age) | Duck Age deriving (Generic, Show)
375+data Animal = Dog Dog | Cat Name Age | Duck Age deriving (Generic, Show)
231376
232377shep = Dog (MkDog "Shep" 4)
233−mog = Cat ("Mog", 5)
378+mog = Cat "Mog" 5
234379donald = Duck 4
235380```
236381
@@ -244,6 +389,9 @@ Just (MkDog {name = "Shep", age = 4})
244389>>> donald ^? _Typed @Age
245390Just 4
246391
392+>>> mog ^? _Typed @(Name, Age)
393+("Mog", 5)
394+
247395>>> donald ^? _Typed @Float
248396error:
249397 • The type Animal does not contain a constructor whose field is of type Float
@@ -252,7 +400,19 @@ error:
252400Duck 6
253401```
254402
255−## Contributors
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
256415
416++ [Matthew Pickering](https://github.com/mpickering)
257417+ [Toby Shaw](https://github.com/TobyShaw)
258418+ [Will Jones](https://github.com/lunaris)
cabal.haskell-cinew file+5
@@ -0,0 +1,5 @@
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 @@
11packages: generic-lens.cabal
2+write-ghc-environment-files: always
examples/Biscuits.hsnew file+150
@@ -0,0 +1,150 @@
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+6−1
@@ -17,11 +17,16 @@
1717module Examples where
1818
1919import Data.Function ((&))
20−import Data.Generics.Internal.Lens
20+import Data.Generics.Internal.VL.Lens
2121import Data.Generics.Product
2222import Data.Generics.Sum
2323import GHC.Generics
2424import Data.Generics.Labels
25+import Data.Generics.Internal.VL.Iso
26+import Data.Generics.Internal.VL.Prism
27+import Data.Generics.Internal.Profunctor.Lens
28+import Data.Generics.Internal.Profunctor.Iso
29+import Data.Generics.Internal.Profunctor.Prism
2530
2631data Animal = Animal
2732 { name :: String
examples/doctest.hsnew file+7
@@ -0,0 +1,7 @@
1+import Test.DocTest
2+main
3+ = doctest
4+ [ "-iexamples"
5+ , "-isrc"
6+ , "examples/Biscuits.hs"
7+ ]
generic-lens.cabal+70−24
@@ -1,7 +1,7 @@
11name: generic-lens
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.
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.
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.1
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
1515
1616extra-source-files: ChangeLog.md
1717 , examples/StarWars.hs
@@ -23,26 +23,40 @@ flag dump-core
2323 default: False
2424
2525library
26− exposed-modules: Data.Generics.Product
26+ exposed-modules: Data.Generics.Wrapped
27+ , Data.Generics.Product
2728 , Data.Generics.Product.Any
2829 , Data.Generics.Product.Fields
30+ , Data.Generics.Product.Param
2931 , Data.Generics.Product.Positions
3032 , Data.Generics.Product.Subtype
3133 , Data.Generics.Product.Typed
3234 , Data.Generics.Product.Types
33− , Data.Generics.Product.List
35+ , Data.Generics.Product.Constraints
36+ , Data.Generics.Product.HList
37+ , Data.Generics.Labels
38+ , Data.Generics.Internal.GenericN
3439
3540 , Data.Generics.Sum
3641 , Data.Generics.Sum.Any
3742 , Data.Generics.Sum.Constructors
3843 , Data.Generics.Sum.Typed
3944 , Data.Generics.Sum.Subtype
40− , Data.Generics.Internal.Lens
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
4154
4255 other-modules: Data.Generics.Internal.Families
4356 , Data.Generics.Internal.Families.Changing
4457 , Data.Generics.Internal.Families.Collect
4558 , Data.Generics.Internal.Families.Has
59+ , Data.Generics.Internal.Errors
4660 , Data.Generics.Internal.Void
4761
4862 , Data.Generics.Sum.Internal.Constructors
@@ -50,68 +64,92 @@ library
5064 , Data.Generics.Sum.Internal.Subtype
5165
5266 , Data.Generics.Product.Internal.Positions
67+ , Data.Generics.Product.Internal.GLens
5368 , Data.Generics.Product.Internal.Subtype
5469
55− , Data.Generics.Product.Internal.Types
56− , Data.Generics.Product.Internal.List
57− , Data.Generics.Product.Internal.Keyed
70+ , Data.Generics.Product.Internal.Constraints
71+ , Data.Generics.Product.Internal.HList
5872
59− build-depends: base >= 4.9 && <= 5.0
60− , profunctors >= 5.0 && <= 6.0
61− , tagged >= 0.8 && <= 0.9
73+ build-depends: base >= 4.9 && < 5
74+ , profunctors >= 5.0 && < 6.0
75+ , tagged >= 0.8 && < 1
76+ , text >= 1.2 && < 1.3
6277
6378 hs-source-dirs: src
6479 default-language: Haskell2010
6580 ghc-options: -Wall
66− if flag(dump-core)
67− build-depends: dump-core
68− ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
81+-- if flag(dump-core)
82+-- build-depends: dump-core
83+-- ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
6984
7085source-repository head
7186 type: git
7287 location: https://github.com/kcsongor/generic-lens
7388
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+
74102test-suite generic-lens-test
75103 type: exitcode-stdio-1.0
76104 hs-source-dirs: test
77105 main-is: Spec.hs
78− other-modules: Util
106+ other-modules: Util Test24 Test25 Test40 Test62 Test63 CustomChildren
79107
80108 build-depends: base >= 4.9 && <= 5.0
81109 , generic-lens
110+ , lens
82111 , profunctors
83112 , inspection-testing >= 0.2
84113 , HUnit
85114
86115 default-language: Haskell2010
87− ghc-options: -Wall -O2 -dsuppress-all
116+ ghc-options: -Wall
88117 if flag(dump-core)
89118 build-depends: dump-core
90119 ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
91120
92−test-suite generic-lens-test-25
121+test-suite generic-lens-bifunctor
93122 type: exitcode-stdio-1.0
94123 hs-source-dirs: test
95− main-is: 25.hs
124+ main-is: Bifunctor.hs
96125
97126 build-depends: base >= 4.9 && <= 5.0
98127 , generic-lens
99128 , lens
129+ , HUnit
100130
101131 default-language: Haskell2010
102132 ghc-options: -Wall
133+ if flag(dump-core)
134+ build-depends: dump-core
135+ ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
103136
104−test-suite generic-lens-test-24
137+test-suite generic-lens-syb-tree
105138 type: exitcode-stdio-1.0
106− hs-source-dirs: test
107− main-is: 24.hs
139+ hs-source-dirs: test/syb
140+ main-is: Tree.hs
108141
109142 build-depends: base >= 4.9 && <= 5.0
110143 , generic-lens
111144 , lens
145+ , profunctors
146+ , HUnit
112147
113148 default-language: Haskell2010
114149 ghc-options: -Wall
150+ if flag(dump-core)
151+ build-depends: dump-core
152+ ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
115153
116154test-suite doctests
117155 default-language: Haskell2010
@@ -121,6 +159,14 @@ test-suite doctests
121159 build-depends: base >4 && <5, doctest
122160 hs-source-dirs: test
123161
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+
124170benchmark generic-lens-bench
125171 type: exitcode-stdio-1.0
126172 hs-source-dirs: benchmarks
@@ -130,7 +176,7 @@ benchmark generic-lens-bench
130176
131177 , base >= 4.9 && <= 5.0
132178 , QuickCheck
133− , criterion
179+ , criterion >= 1.3.0.0
134180 , deepseq
135181 , lens
136182
src/Data/GenericLens/Internal.hsnew file+64
@@ -0,0 +1,64 @@
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~new file

No changes to the content.

src/Data/Generics/Internal/Errors.hsnew file+59
@@ -0,0 +1,59 @@
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+1−2
@@ -3,14 +3,13 @@
33{-# LANGUAGE FlexibleInstances #-}
44{-# LANGUAGE KindSignatures #-}
55{-# LANGUAGE MultiParamTypeClasses #-}
6−{-# LANGUAGE TypeApplications #-}
76{-# LANGUAGE TypeFamilies #-}
87{-# LANGUAGE TypeOperators #-}
98
109-----------------------------------------------------------------------------
1110-- |
1211-- Module : Data.Generics.Internal.Families
13−-- Copyright : (C) 2017 Csongor Kiss
12+-- Copyright : (C) 2019 Csongor Kiss
1413-- License : BSD3
1514-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1615-- Stability : experimental
src/Data/Generics/Internal/Families/Changing.hs+49−16
@@ -9,11 +9,17 @@
99{-# LANGUAGE UndecidableInstances #-}
1010
1111module Data.Generics.Internal.Families.Changing
12− ( Proxied
12+ ( Indexed
1313 , Infer
14+ , PTag (..)
15+ , P
16+ , LookupParam
17+ , ArgAt
18+ , ArgCount
19+ , UnifyHead
1420 ) where
1521
16−import GHC.TypeLits (TypeError, ErrorMessage (..))
22+import GHC.TypeLits (Nat, type (-), type (+), TypeError, ErrorMessage (..))
1723
1824{-
1925 Note [Changing type parameters]
@@ -48,19 +54,19 @@ import GHC.TypeLits (TypeError, ErrorMessage (..))
4854-- application form. In order to distinguish between applications of P and other type constructors, we use a tag, `PTag`
4955-- to fake a type constructor.
5056data PTag = PTag
51−type family P :: Peano -> k -> PTag -> k
57+type family P :: Nat -> k -> PTag -> k
5258
53−type Proxied t = Proxied' t 'Z
59+type Indexed t = Indexed' t 0
5460
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
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
5864
5965data Sub where
60− Sub :: Peano -> k -> Sub
66+ Sub :: Nat -> k -> Sub
6167
6268type family Unify (a :: k) (b :: k) :: [Sub] where
63− Unify (a n _ 'PTag) a' = '[ 'Sub n a']
69+ Unify (p n _ 'PTag) a' = '[ 'Sub n a']
6470 Unify (a x) (b y) = Unify x y ++ Unify a b
6571 Unify a a = '[]
6672 Unify a b = TypeError
@@ -81,28 +87,49 @@ type family Infer (s :: *) (a' :: *) (b :: *) :: * where
8187
8288--------------------------------------------------------------------------------
8389
84−data Peano = Z | S Peano
85−
8690-- [TODO]: work this out
8791--
88−--type family ArgKind (t :: k) (pos :: Peano) :: * where
92+--type family ArgKind (t :: k) (pos :: Nat) :: * where
8993-- ArgKind (t (a :: k)) 'Z = k
9094-- ArgKind (t _) ('S pos) = ArgKind t pos
9195--
92−--type family ReplaceArg (t :: k) (pos :: Peano) (to :: ArgKind t pos) :: k where
96+--type family ReplaceArg (t :: k) (pos :: Nat) (to :: ArgKind t pos) :: k where
9397-- ReplaceArg (t a) 'Z to = t to
9498-- ReplaceArg (t a) ('S pos) to = ReplaceArg t pos to a
9599-- ReplaceArg t _ _ = t
96100
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
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
100104 ReplaceArg t _ _ = t
101105
102106type family ReplaceArgs (t :: k) (subs :: [Sub]) :: k where
103107 ReplaceArgs t '[] = t
104108 ReplaceArgs t ('Sub n arg ': ss) = ReplaceArgs (ReplaceArg t n arg) ss
105109
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+
106133-- Note [CPP in instance constraints]
107134-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
108135--
@@ -126,3 +153,9 @@ type family ReplaceArgs (t :: k) (subs :: [Sub]) :: k where
126153-- However, for some reason, this violates the functional dependencies on 8.2.2.
127154-- Therefore, when using a newer version of the compiler, the original constraints
128155-- 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) 2017 Csongor Kiss
10+-- Copyright : (C) 2019 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.List (type (++))
31+import Data.Generics.Product.Internal.HList (type (++))
3232import Data.Generics.Internal.Families.Has (GTypes)
3333
3434data TypeStat
src/Data/Generics/Internal/Families/Has.hs+72−46
@@ -7,7 +7,7 @@
77-----------------------------------------------------------------------------
88-- |
99-- Module : Data.Generics.Internal.Families.Has
10−-- Copyright : (C) 2017 Csongor Kiss
10+-- Copyright : (C) 2019 Csongor Kiss
1111-- License : BSD3
1212-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1313-- Stability : experimental
@@ -17,73 +17,99 @@
1717module Data.Generics.Internal.Families.Has
1818 ( HasTotalFieldP
1919 , HasTotalTypeP
20+ , HasTotalPositionP
21+ , Pos
2022 , HasPartialTypeP
2123 , HasCtorP
2224 , GTypes
2325 ) where
2426
25−import Data.Type.Bool (type (||), type (&&))
27+import Data.Type.Bool (type (||))
2628import Data.Type.Equality (type (==))
2729import GHC.Generics
28−import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
30+import GHC.TypeLits (Symbol, Nat)
31+import Data.Kind (Type)
2932
30−import Data.Generics.Product.Internal.List
33+import Data.Generics.Product.Internal.HList
3134
32−type family HasTotalFieldP (field :: Symbol) f :: Bool where
33− HasTotalFieldP field (S1 ('MetaSel ('Just field) _ _ _) _)
34− = 'True
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
3547 HasTotalFieldP field (l :*: r)
36− = HasTotalFieldP field l || HasTotalFieldP field r
48+ = Alt (HasTotalFieldP field l) (HasTotalFieldP field r)
3749 HasTotalFieldP field (l :+: r)
38− = HasTotalFieldP field l && HasTotalFieldP field r
50+ = Both (HasTotalFieldP field l) (HasTotalFieldP field r)
3951 HasTotalFieldP field (S1 _ _)
40− = 'False
52+ = 'Nothing
4153 HasTotalFieldP field (C1 _ f)
4254 = HasTotalFieldP field f
4355 HasTotalFieldP field (D1 _ f)
4456 = HasTotalFieldP field f
45− HasTotalFieldP field (Rec0 _)
46− = 'False
57+ HasTotalFieldP field (K1 _ _)
58+ = 'Nothing
4759 HasTotalFieldP field U1
48− = 'False
60+ = 'Nothing
4961 HasTotalFieldP field V1
50− = 'False
51− HasTotalFieldP field f
52− = TypeError
53− ( 'ShowType f
54− ':<>: 'Text " is not a valid GHC.Generics representation type"
55− )
62+ = 'Nothing
5663
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− )
64+type family HasTotalTypeP (typ :: Type) f :: Maybe Type where
65+ HasTotalTypeP typ (S1 _ (K1 _ typ))
66+ = 'Just typ
67+ HasTotalTypeP typ (l :*: r)
68+ = Alt (HasTotalTypeP typ l) (HasTotalTypeP typ r)
69+ HasTotalTypeP typ (l :+: r)
70+ = Both (HasTotalTypeP typ l) (HasTotalTypeP typ r)
71+ HasTotalTypeP typ (S1 _ _)
72+ = 'Nothing
73+ HasTotalTypeP typ (C1 _ f)
74+ = HasTotalTypeP typ f
75+ HasTotalTypeP typ (D1 _ f)
76+ = HasTotalTypeP typ f
77+ HasTotalTypeP typ (K1 _ _)
78+ = 'Nothing
79+ HasTotalTypeP typ U1
80+ = 'Nothing
81+ HasTotalTypeP typ V1
82+ = 'Nothing
83+
84+data Pos (p :: Nat)
85+
86+type family HasTotalPositionP (pos :: Nat) f :: Maybe Type where
87+ HasTotalPositionP pos (S1 _ (K1 (Pos pos) t))
88+ = 'Just t
89+ HasTotalPositionP pos (l :*: r)
90+ = Alt (HasTotalPositionP pos l) (HasTotalPositionP pos r)
91+ HasTotalPositionP pos (l :+: r)
92+ = Both (HasTotalPositionP pos l) (HasTotalPositionP pos r)
93+ HasTotalPositionP pos (S1 _ _)
94+ = 'Nothing
95+ HasTotalPositionP pos (C1 _ f)
96+ = HasTotalPositionP pos f
97+ HasTotalPositionP pos (D1 _ f)
98+ = HasTotalPositionP pos f
99+ HasTotalPositionP pos (K1 _ _)
100+ = 'Nothing
101+ HasTotalPositionP pos U1
102+ = 'Nothing
103+ HasTotalPositionP pos V1
104+ = 'Nothing
81105
82106type family HasPartialTypeP a f :: Bool where
83107 HasPartialTypeP t (l :+: r)
84108 = HasPartialTypeP t l || HasPartialTypeP t r
85109 HasPartialTypeP t (C1 m f)
86110 = t == GTypes f
111+ HasPartialTypeP t (M1 _ _ f)
112+ = HasPartialTypeP t f
87113 HasPartialTypeP t _
88114 = 'False
89115
@@ -97,11 +123,11 @@ type family HasCtorP (ctor :: Symbol) f :: Bool where
97123 HasCtorP ctor _
98124 = 'False
99125
100−type family GTypes (rep :: * -> *) :: [((), *)] where
126+type family GTypes (rep :: Type -> Type) :: [Type] where
101127 GTypes (l :*: r)
102128 = GTypes l ++ GTypes r
103− GTypes (Rec0 a)
104− = '[ '( '(), a)]
129+ GTypes (K1 _ a)
130+ = '[ a]
105131 GTypes (M1 _ m a)
106132 = GTypes a
107133 GTypes U1 = '[]
src/Data/Generics/Internal/GenericN.hsnew file+75
@@ -0,0 +1,75 @@
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.hsdeleted−515
@@ -1,515 +0,0 @@
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.hsnew file+111
@@ -0,0 +1,111 @@
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.hsnew file+171
@@ -0,0 +1,171 @@
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.hsnew file+117
@@ -0,0 +1,117 @@
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.hsnew file+80
@@ -0,0 +1,80 @@
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.hsnew file+70
@@ -0,0 +1,70 @@
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.hsnew file+74
@@ -0,0 +1,74 @@
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.hsnew file+92
@@ -0,0 +1,92 @@
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+123−17
@@ -1,36 +1,142 @@
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−
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 #-}
1015
1116--------------------------------------------------------------------------------
1217-- |
1318-- Module : Data.Generics.Labels
14−-- Copyright : (C) 2017 Csongor Kiss
15−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19+-- Copyright : (C) 2019 Csongor Kiss
1620-- License : BSD3
21+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1722-- Stability : experimental
1823-- Portability : non-portable
1924--
20−-- Provides an (orphan) IsLabel instance for field lenses.
25+-- Provides an (orphan) IsLabel instance for field lenses and constructor prisms.
2126-- Use at your own risk.
2227--------------------------------------------------------------------------------
2328
24−module Data.Generics.Labels () where
29+module Data.Generics.Labels
30+ ( -- * Orphan IsLabel Instance
31+ -- $sec1
32+ Field(..)
33+ , Field'
34+ , Constructor(..)
35+ , Constructor'
36+ ) where
2537
2638import 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+
2747import 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)
28131
132+instance (Functor f, Field name s t a b) => IsLabelHelper 'False name (->) f s t a b where
133+ labelOutput = fieldLens @name
29134
30−instance (HasField field s t a b, Functor f, sft ~ (s -> f t)) =>
31− IsLabel field ((a -> f b) -> sft) where
32135#if __GLASGOW_HASKELL__ >= 802
33− fromLabel = field @field
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
34139#else
35− fromLabel _ = field @field
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
36142#endif
src/Data/Generics/Product.hs+8−3
@@ -1,7 +1,7 @@
11-----------------------------------------------------------------------------
22-- |
33-- Module : Data.Generics.Product
4−-- Copyright : (C) 2017 Csongor Kiss
4+-- Copyright : (C) 2019 Csongor Kiss
55-- License : BSD3
66-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
77-- Stability : experimental
@@ -22,8 +22,11 @@ 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
2527 , module Data.Generics.Product.Types
26− , module Data.Generics.Product.List
28+ , module Data.Generics.Product.Param
29+ , module Data.Generics.Product.Constraints
2730 ) where
2831
2932import Data.Generics.Product.Any
@@ -32,4 +35,6 @@ import Data.Generics.Product.Positions
3235import Data.Generics.Product.Subtype
3336import Data.Generics.Product.Typed
3437import Data.Generics.Product.Types
35−import Data.Generics.Product.List
38+import Data.Generics.Product.Constraints
39+import Data.Generics.Product.Param
40+import Data.Generics.Product.HList
src/Data/Generics/Product/Any.hs+5−5
@@ -12,7 +12,7 @@
1212-----------------------------------------------------------------------------
1313-- |
1414-- Module : Data.Generics.Product.Any
15−-- Copyright : (C) 2017 Csongor Kiss
15+-- Copyright : (C) 2019 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.Lens
32+import Data.Generics.Internal.VL.Lens
3333import Data.Generics.Product.Fields
3434import Data.Generics.Product.Positions
3535import Data.Generics.Product.Typed
@@ -41,7 +41,7 @@ import Data.Generics.Product.Typed
4141-- >>> :set -XDataKinds
4242-- >>> :set -XDeriveGeneric
4343-- >>> import GHC.Generics
44−-- >>> :m +Data.Generics.Internal.Lens
44+-- >>> :m +Data.Generics.Internal.VL.Lens
4545-- >>> :{
4646-- data Human = Human
4747-- { name :: String
@@ -53,7 +53,7 @@ import Data.Generics.Product.Typed
5353-- human = Human "Tunyasz" 50 "London"
5454-- :}
5555
56−class HasAny (sel :: k) s t a b | s sel k -> a where
56+class HasAny sel s t a b | s sel -> 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 :: k) s t a b | s sel k -> a where
6767 --
6868 -- >>> human ^. the @3
6969 -- "London"
70− the :: LensVL s t a b
70+ the :: Lens 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.hsnew file+57
@@ -0,0 +1,57 @@
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+96−30
@@ -16,7 +16,7 @@
1616-----------------------------------------------------------------------------
1717-- |
1818-- Module : Data.Generics.Product.Fields
19−-- Copyright : (C) 2017 Csongor Kiss
19+-- Copyright : (C) 2019 Csongor Kiss
2020-- License : BSD3
2121-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
2222-- Stability : experimental
@@ -31,20 +31,23 @@ module Data.Generics.Product.Fields
3131
3232 -- $setup
3333 HasField (..)
34− , HasField'
34+ , HasField' (..)
35+ , HasField_ (..)
3536
3637 , getField
3738 , setField
3839 ) where
3940
4041import Data.Generics.Internal.Families
41−import Data.Generics.Internal.Lens
42+import Data.Generics.Internal.VL.Lens as VL
4243import Data.Generics.Internal.Void
43−import Data.Generics.Product.Internal.Keyed
44+import Data.Generics.Product.Internal.GLens
4445
4546import Data.Kind (Constraint, Type)
4647import GHC.Generics
4748import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError)
49+import Data.Generics.Internal.Profunctor.Lens as P
50+import Data.Generics.Internal.Errors
4851
4952-- $setup
5053-- == /Running example:/
@@ -55,7 +58,7 @@ import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError)
5558-- >>> :set -XGADTs
5659-- >>> :set -XFlexibleContexts
5760-- >>> import GHC.Generics
58−-- >>> :m +Data.Generics.Internal.Lens
61+-- >>> :m +Data.Generics.Internal.VL.Lens
5962-- >>> :m +Data.Function
6063-- >>> :{
6164-- data Human a
@@ -108,49 +111,109 @@ class HasField (field :: Symbol) s t a b | s field -> a, t field -> b, s field b
108111 -- ... The offending constructors are:
109112 -- ... HumanNoAddress
110113 -- ...
111− field :: LensVL s t a b
114+ field :: VL.Lens s t a b
112115
113−type HasField' field s a = HasField field s s a a
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
114139
115140-- |
116141-- >>> getField @"age" human
117142-- 50
118−getField :: forall f s t a b . HasField' f s a => s -> a
119−getField = viewVL' (field @f)
143+getField :: forall f a s. HasField' f s a => s -> a
144+getField = VL.view (field' @f)
120145
121146-- |
122147-- >>> setField @"age" 60 human
123148-- Human {name = "Tunyasz", age = 60, address = "London", other = False}
124149setField :: forall f s a. HasField' f s a => a -> s -> s
125−setField = setVL (field @f)
150+setField = VL.set (field' @f)
126151
127−instance -- see Note [Changing type parameters]
152+instance
128153 ( Generic s
129154 , ErrorUnless field s (CollectField field (Rep s))
130− , Generic t
131− -- see Note [CPP in instance constraints]
132−#if __GLASGOW_HASKELL__ < 802
133− , '(s', t') ~ '(Proxied s, Proxied t)
134−#else
135− , s' ~ Proxied s
136− , t' ~ Proxied t
137−#endif
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
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
147166
148− field f s = ravel (repLens . gkey @field) f s
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
149177
150−-- -- See Note [Uncluttering type signatures]
178+-- | See Note [Uncluttering type signatures]
179+#if __GLASGOW_HASKELL__ < 804
180+-- >>> :t field
181+-- field
182+-- :: (HasField field s t a b, Functor f) => (a -> f b) -> s -> f t
183+#else
184+-- >>> :t field
185+-- field
186+-- :: (Functor f, HasField field s t a b) => (a -> f b) -> s -> f t
187+#endif
151188instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where
152189 field = undefined
153190
191+instance
192+ ( HasTotalFieldP field (Rep s) ~~ 'Just a
193+ , HasTotalFieldP field (Rep t) ~~ 'Just b
194+ , UnifyHead s t
195+ , UnifyHead t s
196+ , HasField0 field s t a b
197+ ) => HasField_ field s t a b where
198+ field_ f s = field0 @field f s
199+
200+instance {-# OVERLAPPING #-} HasField_ f (Void1 a) (Void1 b) a b where
201+ field_ = undefined
202+
203+instance
204+ ( Generic s
205+ , Generic t
206+ , GLens (HasTotalFieldPSym field) (Rep s) (Rep t) a b
207+ , ErrorUnless field s (CollectField field (Rep s))
208+ , Defined (Rep s)
209+ (NoGeneric s '[ 'Text "arising from a generic lens focusing on the "
210+ ':<>: QuoteType field ':<>: 'Text " field of type " ':<>: QuoteType a
211+ , 'Text "in " ':<>: QuoteType s])
212+ (() :: Constraint)
213+ ) => HasField0 field s t a b where
214+ field0 = VL.ravel (repLens . glens @(HasTotalFieldPSym field))
215+ {-# INLINE field0 #-}
216+
154217type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Constraint where
155218 ErrorUnless field s ('TypeStat _ _ '[])
156219 = TypeError
@@ -172,3 +235,6 @@ type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Cons
172235
173236 ErrorUnless _ _ ('TypeStat '[] '[] _)
174237 = ()
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.hsnew file+46
@@ -0,0 +1,46 @@
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.hsnew file+136
@@ -0,0 +1,136 @@
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.hsnew file+81
@@ -0,0 +1,81 @@
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.hsnew file+329
@@ -0,0 +1,329 @@
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.hsdeleted−53
@@ -1,53 +0,0 @@
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.hsdeleted−344
@@ -1,344 +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.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+46−24
@@ -1,3 +1,4 @@
1+{-# LANGUAGE TypeInType #-}
12{-# LANGUAGE AllowAmbiguousTypes #-}
23{-# LANGUAGE ConstraintKinds #-}
34{-# LANGUAGE DataKinds #-}
@@ -16,7 +17,7 @@
1617-----------------------------------------------------------------------------
1718-- |
1819-- Module : Data.Generics.Product.Internal.Positions
19−-- Copyright : (C) 2017 Csongor Kiss
20+-- Copyright : (C) 2019 Csongor Kiss
2021-- License : BSD3
2122-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
2223-- Stability : experimental
@@ -27,38 +28,61 @@
2728-----------------------------------------------------------------------------
2829
2930module Data.Generics.Product.Internal.Positions
30− ( GHasPosition (..)
31− , GHasPosition'
32− , type (<?)
31+ ( type (<?)
3332 , Size
33+ , CRep
3434 ) where
3535
36−import Data.Generics.Internal.Lens
37−
38−import Data.Generics.Product.Internal.List
36+import Data.Generics.Internal.Families.Has (Pos)
3937import Data.Kind (Type)
4038import Data.Type.Bool (If, Not)
4139import GHC.Generics
42−import GHC.TypeLits (type (<=?), type (+), type (-), Nat)
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)
4355
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
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)
4872
49−type GHasPosition' i s a = GHasPosition i s s a a
73+type family Traverse1 (w :: G -> G) (z :: (G, Nat)) :: (G, Nat) where
74+ Traverse1 w '(i, n) = '(w i, n)
5075
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)
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)
5380
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
81+--------------------------------------------------------------------------------
82+-- Utilities
5683
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)
84+type family Fst (p :: (a, b)) :: a where
85+ Fst '(a, b) = a
6286
6387type family Size f :: Nat where
6488 Size (l :*: r)
@@ -72,8 +96,6 @@ type family Size f :: Nat where
7296 Size f
7397 = 1
7498
75−--------------------------------------------------------------------------------
76−
7799type x <? y = Not (y <=? x)
78100infixl 4 <?
79101
src/Data/Generics/Product/Internal/Subtype.hs+15−10
@@ -1,3 +1,4 @@
1+{-# LANGUAGE TypeInType #-}
12{-# LANGUAGE AllowAmbiguousTypes #-}
23{-# LANGUAGE DataKinds #-}
34{-# LANGUAGE FlexibleContexts #-}
@@ -15,7 +16,7 @@
1516-----------------------------------------------------------------------------
1617-- |
1718-- Module : Data.Generics.Product.Internal.Subtype
18−-- Copyright : (C) 2017 Csongor Kiss
19+-- Copyright : (C) 2019 Csongor Kiss
1920-- License : BSD3
2021-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
2122-- Stability : experimental
@@ -31,11 +32,12 @@ module Data.Generics.Product.Internal.Subtype
3132 ) where
3233
3334import Data.Generics.Internal.Families
34−import Data.Generics.Internal.Lens
35−import Data.Generics.Product.Internal.Keyed
35+import Data.Generics.Product.Internal.GLens
3636
3737import Data.Kind (Type)
3838import GHC.Generics
39+import GHC.TypeLits (Symbol)
40+import Data.Generics.Internal.Profunctor.Lens (view)
3941
4042--------------------------------------------------------------------------------
4143-- * Generic upcasting
@@ -47,10 +49,10 @@ instance (GUpcast sub a, GUpcast sub b) => GUpcast sub (a :*: b) where
4749 gupcast rep = gupcast rep :*: gupcast rep
4850
4951instance
50− GHasKey field sub sub t t
52+ GLens' (HasTotalFieldPSym field) sub t
5153 => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
5254
53− gupcast r = M1 (K1 (view (gkey @field) r))
55+ gupcast r = M1 (K1 (view (glens @(HasTotalFieldPSym field)) r))
5456
5557instance GUpcast sub sup => GUpcast sub (C1 c sup) where
5658 gupcast = M1 . gupcast
@@ -80,13 +82,16 @@ instance GSmash sub sup => GSmash (C1 c sub) sup where
8082instance GSmash sub sup => GSmash (D1 c sub) sup where
8183 gsmash sup (M1 sub) = M1 (gsmash sup sub)
8284
83−class GSmashLeaf sub sup (w :: Bool) where
85+class GSmashLeaf sub sup (w :: Maybe Type) where
8486 gsmashLeaf :: sup p -> sub p -> sub p
8587
8688instance
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))
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))
9092
91−instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'False where
93+instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'Nothing where
9294 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.hsdeleted−56
@@ -1,56 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE KindSignatures #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE TypeApplications #-}
9−{-# LANGUAGE TypeFamilies #-}
10−{-# LANGUAGE TypeOperators #-}
11−{-# LANGUAGE UndecidableInstances #-}
12−
13−-----------------------------------------------------------------------------
14−-- |
15−-- Module : Data.Generics.Product.Internal.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.hsdeleted−77
@@ -1,77 +0,0 @@
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.hsnew file+121
@@ -0,0 +1,121 @@
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+124−28
@@ -1,3 +1,5 @@
1+{-# LANGUAGE TypeInType #-}
2+{-# LANGUAGE PartialTypeSignatures #-}
13{-# LANGUAGE CPP #-}
24{-# LANGUAGE AllowAmbiguousTypes #-}
35{-# LANGUAGE ConstraintKinds #-}
@@ -17,7 +19,7 @@
1719-----------------------------------------------------------------------------
1820-- |
1921-- Module : Data.Generics.Product.Positions
20−-- Copyright : (C) 2017 Csongor Kiss
22+-- Copyright : (C) 2019 Csongor Kiss
2123-- License : BSD3
2224-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
2325-- Stability : experimental
@@ -32,21 +34,27 @@ module Data.Generics.Product.Positions
3234
3335 -- $setup
3436 HasPosition (..)
35− , HasPosition'
37+ , HasPosition' (..)
38+ , HasPosition_ (..)
39+ , HasPosition0 (..)
3640
3741 , getPosition
3842 , setPosition
3943 ) where
4044
41−import Data.Generics.Internal.Lens
45+import Data.Generics.Internal.VL.Lens as VL
4246import Data.Generics.Internal.Void
4347import Data.Generics.Internal.Families
4448import Data.Generics.Product.Internal.Positions
49+import Data.Generics.Product.Internal.GLens
50+import Data.Generics.Internal.Errors
4551
4652import Data.Kind (Constraint, Type)
4753import Data.Type.Bool (type (&&))
4854import GHC.Generics
4955import GHC.TypeLits (type (<=?), Nat, TypeError, ErrorMessage(..))
56+import Data.Generics.Internal.Profunctor.Lens as P
57+import Data.Coerce
5058
5159-- $setup
5260-- == /Running example:/
@@ -57,7 +65,7 @@ import GHC.TypeLits (type (<=?), Nat, TypeError, ErrorMessage(..))
5765-- >>> :set -XGADTs
5866-- >>> :set -XFlexibleContexts
5967-- >>> import GHC.Generics
60−-- >>> :m +Data.Generics.Internal.Lens
68+-- >>> :m +Data.Generics.Internal.VL.Lens
6169-- >>> :m +Data.Function
6270-- >>> :{
6371-- data Human = Human
@@ -86,43 +94,128 @@ class HasPosition (i :: Nat) s t a b | s i -> a, t i -> b, s i b -> t, t i a ->
8694 -- ...
8795 -- ... The type Human does not contain a field at position 4
8896 -- ...
89− position :: LensVL s t a b
97+ position :: VL.Lens s t a b
9098
91−type HasPosition' i s a = HasPosition i s s a a
99+class HasPosition_ (i :: Nat) s t a b where
100+ position_ :: VL.Lens s t a b
92101
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
93121getPosition :: forall i s a. HasPosition' i s a => s -> a
94−getPosition s = s ^. position @i
122+getPosition s = s ^. position' @i
95123
124+-- |
125+-- >>> setPosition @2 60 human
126+-- Human {name = "Tunyasz", age = 60, address = "London"}
96127setPosition :: forall i s a. HasPosition' i s a => a -> s -> s
97−setPosition = setVL (position @i)
128+setPosition = VL.set (position' @i)
98129
99−instance -- see Note [Changing type parameters]
130+instance
100131 ( Generic s
101132 , ErrorUnless i s (0 <? i && i <=? Size (Rep s))
102− , Generic t
103− -- see Note [CPP in instance constraints]
104−#if __GLASGOW_HASKELL__ < 802
105− , '(s', t') ~ '(Proxied s, Proxied t)
106−#else
107− , s' ~ Proxied s
108− , t' ~ Proxied t
109−#endif
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
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
119150
120− position f s = ravel (repLens . gposition @i) f s
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
121163
122−-- See Note [Uncluttering type signatures]
164+ position = position0 @i
165+ {-# INLINE position #-}
166+
167+-- We wouldn't need the universal 'x' here if we could express above that
168+-- forall x. Coercible (cs x) (Rep s x), but this requires quantified
169+-- constraints
170+coerced :: forall s t s' t' x a b. (Coercible t t', Coercible s s')
171+ => P.ALens a b (s x) (t x) -> P.ALens a b (s' x) (t' x)
172+coerced = coerce
173+{-# INLINE coerced #-}
174+
175+-- | See Note [Uncluttering type signatures]
176+#if __GLASGOW_HASKELL__ < 804
177+-- >>> :t position
178+-- position
179+-- :: (HasPosition i s t a b, Functor f) => (a -> f b) -> s -> f t
180+#else
181+-- >>> :t position
182+-- position
183+-- :: (Functor f, HasPosition i s t a b) => (a -> f b) -> s -> f t
184+#endif
123185instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where
124186 position = undefined
125187
188+instance
189+ ( ErrorUnless i s (0 <? i && i <=? Size (Rep s))
190+ , UnifyHead s t
191+ , UnifyHead t s
192+ , Coercible (CRep s) (Rep s)
193+ , Coercible (CRep t) (Rep t)
194+ , HasPosition0 i s t a b
195+ ) => HasPosition_ i s t a b where
196+
197+ position_ = position0 @i
198+ {-# INLINE position_ #-}
199+
200+instance {-# OVERLAPPING #-} HasPosition_ f (Void1 a) (Void1 b) a b where
201+ position_ = undefined
202+
203+instance
204+ ( Generic s
205+ , Generic t
206+ , GLens (HasTotalPositionPSym i) (CRep s) (CRep t) a b
207+ , Coercible (CRep s) (Rep s)
208+ , Coercible (CRep t) (Rep t)
209+ , Defined (Rep s)
210+ (NoGeneric s '[ 'Text "arising from a generic lens focusing on the field at"
211+ , 'Text "position " ':<>: QuoteType i ':<>: 'Text " of type " ':<>: QuoteType a
212+ ':<>: 'Text " in " ':<>: QuoteType s
213+ ])
214+ (() :: Constraint)
215+ ) => HasPosition0 i s t a b where
216+ position0 = VL.ravel (repLens . coerced @(CRep s) @(CRep t) . glens @(HasTotalPositionPSym i))
217+ {-# INLINE position0 #-}
218+
126219type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint where
127220 ErrorUnless i s 'False
128221 = TypeError
@@ -134,3 +227,6 @@ type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint wher
134227
135228 ErrorUnless _ _ 'True
136229 = ()
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+49−8
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE AllowAmbiguousTypes #-}
23{-# LANGUAGE DataKinds #-}
34{-# LANGUAGE FlexibleContexts #-}
@@ -15,7 +16,7 @@
1516-----------------------------------------------------------------------------
1617-- |
1718-- Module : Data.Generics.Product.Subtype
18−-- Copyright : (C) 2017 Csongor Kiss
19+-- Copyright : (C) 2019 Csongor Kiss
1920-- License : BSD3
2021-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
2122-- Stability : experimental
@@ -33,13 +34,15 @@ module Data.Generics.Product.Subtype
3334 ) where
3435
3536import Data.Generics.Internal.Families
36−import Data.Generics.Internal.Lens
37+import Data.Generics.Internal.VL.Lens as VL
3738import Data.Generics.Internal.Void
3839import Data.Generics.Product.Internal.Subtype
3940
4041import GHC.Generics (Generic (Rep, to, from) )
4142import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
4243import Data.Kind (Type, Constraint)
44+import Data.Generics.Internal.Profunctor.Lens hiding (set)
45+import Data.Generics.Internal.Errors
4346
4447-- $setup
4548-- == /Running example:/
@@ -49,7 +52,7 @@ import Data.Kind (Type, Constraint)
4952-- >>> :set -XDeriveGeneric
5053-- >>> :set -XDuplicateRecordFields
5154-- >>> import GHC.Generics
52−-- >>> :m +Data.Generics.Internal.Lens
55+-- >>> :m +Data.Generics.Internal.VL.Lens
5356-- >>> :{
5457-- data Human = Human
5558-- { name :: String
@@ -80,9 +83,9 @@ class Subtype sup sub where
8083 --
8184 -- >>> set (super @Animal) (Animal "dog" 10) human
8285 -- Human {name = "dog", age = 10, address = "London"}
83− super :: LensVL sub sub sup sup
86+ super :: VL.Lens sub sub sup sup
8487 super
85− = lensVL upcast (uncurry smash . swap)
88+ = VL.lens upcast (uncurry smash . swap)
8689
8790 -- |Cast the more specific subtype to the more general supertype
8891 --
@@ -103,7 +106,7 @@ class Subtype sup sub where
103106 -- >>> smash (Animal "dog" 10) human
104107 -- Human {name = "dog", age = 10, address = "London"}
105108 smash :: sup -> sub -> sub
106− smash = setVL (super @sup)
109+ smash = VL.set (super @sup)
107110
108111 {-# MINIMAL super | smash, upcast #-}
109112
@@ -112,14 +115,52 @@ instance
112115 , Generic b
113116 , GSmash (Rep a) (Rep b)
114117 , GUpcast (Rep a) (Rep b)
115− , ErrorUnless b a (CollectFieldsOrdered (Rep b) \\ CollectFieldsOrdered (Rep a))
118+ , CustomError a b
116119 ) => Subtype b a where
117120 smash p b = to $ gsmash (from p) (from b)
118121 upcast = to . gupcast . from
119122
120−-- See Note [Uncluttering type signatures]
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
121151instance {-# OVERLAPPING #-} Subtype a Void where
122152 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
123164instance {-# OVERLAPPING #-} Subtype Void a where
124165 super = undefined
125166
src/Data/Generics/Product/Typed.hs+38−10
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE AllowAmbiguousTypes #-}
23{-# LANGUAGE DataKinds #-}
34{-# LANGUAGE FlexibleContexts #-}
@@ -7,13 +8,14 @@
78{-# LANGUAGE ScopedTypeVariables #-}
89{-# LANGUAGE TypeApplications #-}
910{-# LANGUAGE TypeFamilies #-}
11+{-# LANGUAGE TypeInType #-}
1012{-# LANGUAGE TypeOperators #-}
1113{-# LANGUAGE UndecidableInstances #-}
1214
1315-----------------------------------------------------------------------------
1416-- |
1517-- Module : Data.Generics.Product.Typed
16−-- Copyright : (C) 2017 Csongor Kiss
18+-- Copyright : (C) 2019 Csongor Kiss
1719-- License : BSD3
1820-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1921-- Stability : experimental
@@ -31,13 +33,15 @@ module Data.Generics.Product.Typed
3133 ) where
3234
3335import Data.Generics.Internal.Families
34−import Data.Generics.Internal.Lens
36+import Data.Generics.Internal.VL.Lens as VL
3537import Data.Generics.Internal.Void
36−import Data.Generics.Product.Internal.Keyed
38+import Data.Generics.Product.Internal.GLens
3739
3840import Data.Kind (Constraint, Type)
3941import GHC.Generics (Generic (Rep))
4042import GHC.TypeLits (TypeError, ErrorMessage (..))
43+import Data.Generics.Internal.Profunctor.Lens
44+import Data.Generics.Internal.Errors
4145
4246-- $setup
4347-- == /Running example:/
@@ -46,7 +50,7 @@ import GHC.TypeLits (TypeError, ErrorMessage (..))
4650-- >>> :set -XDataKinds
4751-- >>> :set -XDeriveGeneric
4852-- >>> import GHC.Generics
49−-- >>> :m +Data.Generics.Internal.Lens
53+-- >>> :m +Data.Generics.Internal.VL.Lens
5054-- >>> :{
5155-- data Human
5256-- = Human
@@ -91,9 +95,10 @@ class HasType a s where
9195 -- ... The offending constructors are:
9296 -- ... HumanNoTall
9397 -- ...
94− typed :: LensVL s s a a
98+ typed :: VL.Lens s s a a
9599 typed
96− = lensVL (getTyped @a) (uncurry (setTyped @a) . swap)
100+ = VL.lens (getTyped @a) (uncurry (setTyped @a) . swap)
101+ {-# INLINE typed #-}
97102
98103 -- |Get field at type.
99104 getTyped :: s -> a
@@ -101,19 +106,38 @@ class HasType a s where
101106
102107 -- |Set field at type.
103108 setTyped :: a -> s -> s
104− setTyped = setVL (typed @a)
109+ setTyped = VL.set (typed @a)
105110
106111 {-# MINIMAL typed | setTyped, getTyped #-}
107112
108113instance
109114 ( Generic s
110115 , ErrorUnlessOne a s (CollectTotalType a (Rep s))
111− , GHasKey a (Rep s) (Rep s) a a
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
112120 ) => HasType a s where
113121
114− typed = ravel (repLens . gkey @a)
122+ typed f s = VL.ravel (repLens . glens @(HasTotalTypePSym a)) f s
115123
116−-- See Note [Uncluttering type signatures]
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.
117141instance {-# OVERLAPPING #-} HasType a Void where
118142 typed = undefined
119143
@@ -148,3 +172,7 @@ type family ErrorUnlessOne (a :: Type) (s :: Type) (stat :: TypeStat) :: Constra
148172
149173 ErrorUnlessOne _ _ ('TypeStat '[] '[] _)
150174 = ()
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+333−14
@@ -1,9 +1,12 @@
11{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE ConstraintKinds #-}
23{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE DefaultSignatures #-}
45{-# LANGUAGE FlexibleInstances #-}
56{-# LANGUAGE KindSignatures #-}
67{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE PolyKinds #-}
9+{-# LANGUAGE Rank2Types #-}
710{-# LANGUAGE ScopedTypeVariables #-}
811{-# LANGUAGE TypeApplications #-}
912{-# LANGUAGE TypeFamilies #-}
@@ -13,7 +16,7 @@
1316-----------------------------------------------------------------------------
1417-- |
1518-- Module : Data.Generics.Product.Types
16−-- Copyright : (C) 2017 Csongor Kiss
19+-- Copyright : (C) 2019 Csongor Kiss
1720-- License : BSD3
1821-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1922-- Stability : experimental
@@ -26,23 +29,339 @@
2629module Data.Generics.Product.Types
2730 ( -- *Traversals
2831 --
29− -- $example
30− HasTypes (..)
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+
3146 ) where
3247
33−import Data.Generics.Internal.Lens
34−import Data.Generics.Product.Internal.Types
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+--------------------------------------------------------------------------------
3578
36−import GHC.Generics (Generic (Rep), from, to)
79+-- TODO [1.0.0.0]: use type-changing variant internally
3780
38−class HasTypes a s where
39− types :: Traversal' s a
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_ #-}
40101
41102instance
42− ( Generic s
43− , GHasTypes (Rep s) a
44− ) => HasTypes a s where
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
45363
46− types = confusing (\f s -> to <$> gtypes f (from s))
47− {-# INLINE types #-}
364+type family IsNothing a where
365+ IsNothing ('Just _) = 'False
366+ IsNothing 'Nothing = 'True
48367
src/Data/Generics/Sum.hs+1−1
@@ -1,7 +1,7 @@
11-----------------------------------------------------------------------------
22-- |
33-- Module : Data.Generics.Sum
4−-- Copyright : (C) 2017 Csongor Kiss
4+-- Copyright : (C) 2019 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) 2017 Csongor Kiss
14+-- Copyright : (C) 2019 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
3231import Data.Generics.Sum.Constructors
3332import Data.Generics.Sum.Typed
33+import Data.Generics.Internal.VL.Prism
3434
3535-- $setup
3636-- == /Running example:/
@@ -39,7 +39,7 @@ import Data.Generics.Sum.Typed
3939-- >>> :set -XDataKinds
4040-- >>> :set -XDeriveGeneric
4141-- >>> import GHC.Generics
42−-- >>> :m +Data.Generics.Internal.Lens
42+-- >>> :m +Data.Generics.Internal.VL.Prism
4343-- >>> :{
4444-- data Animal
4545-- = Dog Dog
@@ -61,7 +61,7 @@ import Data.Generics.Sum.Typed
6161-- :}
6262
6363-- |Sums that have generic prisms.
64−class AsAny (sel :: k) a s | s sel k -> a where
64+class AsAny sel a s | s sel -> 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 :: k) a s | s sel k -> a where
8686 --
8787 -- >>> duck ^? _As @Age
8888 -- Just 2
89− _As :: PrismVL s s a a
89+ _As :: Prism s s a a
9090
9191instance AsConstructor ctor s s a a => AsAny ctor a s where
9292 _As = _Ctor @ctor
src/Data/Generics/Sum/Constructors.hs+91−20
@@ -15,7 +15,7 @@
1515-----------------------------------------------------------------------------
1616-- |
1717-- Module : Data.Generics.Sum.Constructors
18−-- Copyright : (C) 2017 Csongor Kiss
18+-- Copyright : (C) 2019 Csongor Kiss
1919-- License : BSD3
2020-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
2121-- Stability : experimental
@@ -30,16 +30,22 @@ module Data.Generics.Sum.Constructors
3030
3131 -- $setup
3232 AsConstructor (..)
33+ , AsConstructor_ (..)
34+ , AsConstructor' (..)
35+ , AsConstructor0 (..)
3336 ) where
3437
3538import Data.Generics.Internal.Families
36−import Data.Generics.Internal.Lens
3739import Data.Generics.Internal.Void
3840import Data.Generics.Sum.Internal.Constructors
3941
4042import Data.Kind (Constraint, Type)
4143import GHC.Generics (Generic (Rep))
4244import 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
4349
4450-- $setup
4551-- == /Running example:/
@@ -50,7 +56,7 @@ import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
5056-- >>> :set -XFlexibleContexts
5157-- >>> :set -XTypeFamilies
5258-- >>> import GHC.Generics
53−-- >>> :m +Data.Generics.Internal.Lens
59+-- >>> :m +Data.Generics.Internal.VL.Prism
5460-- >>> :m +Data.Generics.Product.Fields
5561-- >>> :m +Data.Function
5662-- >>> :{
@@ -65,7 +71,7 @@ import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
6571-- , age :: Age
6672-- , fieldA :: a
6773-- }
68−-- deriving (Generic, Show)
74+-- deriving Show
6975-- type Name = String
7076-- type Age = Int
7177-- dog, cat, duck :: Animal Int
@@ -98,36 +104,101 @@ class AsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where
98104 -- ...
99105 -- ... The type Animal Int does not contain a constructor named "Turtle"
100106 -- ...
101− _Ctor :: PrismVL s t a b
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
102127
103128instance
104129 ( Generic s
105130 , 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'
116131 , GAsConstructor' ctor (Rep s) a
117− , 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'
118145 , GAsConstructor ctor (Rep s) (Rep t) a b
119146 , t ~ Infer s a' b
120− , GAsConstructor' ctor (Rep t') b'
147+ , GAsConstructor' ctor (Rep (Indexed t)) b'
121148 , s ~ Infer t b' a
149+ , AsConstructor0 ctor s t a b
122150 ) => AsConstructor ctor s t a b where
123151
124− _Ctor eta = prismVLRavel (repIso . _GCtor @ctor) eta
125− {-# INLINE _Ctor #-}
152+ _Ctor = _Ctor0 @ctor
153+ {-# INLINE[2] _Ctor #-}
126154
127−-- See Note [Uncluttering type signatures]
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
128169instance {-# OVERLAPPING #-} AsConstructor ctor (Void1 a) (Void1 b) a b where
129170 _Ctor = undefined
130171
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+
131202type family ErrorUnless (ctor :: Symbol) (s :: Type) (contains :: Bool) :: Constraint where
132203 ErrorUnless ctor s 'False
133204 = 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) 2017 Csongor Kiss
17+-- Copyright : (C) 2019 Csongor Kiss
1818-- License : BSD3
1919-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
2020-- Stability : experimental
@@ -30,12 +30,14 @@ module Data.Generics.Sum.Internal.Constructors
3030 ) where
3131
3232import Data.Generics.Internal.Families
33−import Data.Generics.Product.Internal.List
34−import Data.Generics.Internal.Lens
33+import Data.Generics.Product.Internal.HList
34+import Data.Profunctor (Profunctor(..))
3535
3636import GHC.Generics
3737import GHC.TypeLits (Symbol)
38−import Data.Kind
38+import Data.Generics.Internal.Profunctor.Lens
39+import Data.Generics.Internal.Profunctor.Iso
40+import Data.Generics.Internal.Profunctor.Prism
3941
4042-- |As 'AsConstructor' but over generic representations as defined by
4143-- "GHC.Generics".
@@ -45,32 +47,30 @@ class GAsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where
4547type GAsConstructor' ctor s a = GAsConstructor ctor s s a a
4648
4749instance
48− ( GIsList Type f f as as
49− , GIsList Type g g bs bs
50+ ( GIsList f f as as
51+ , GIsList g g bs bs
5052 , ListTuple a as
5153 , ListTuple b bs
5254 ) => GAsConstructor ctor (M1 C ('MetaCons ctor fixity fields) f) (M1 C ('MetaCons ctor fixity fields) g) a b where
5355
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−
56+ _GCtor = dimap (listToTuple . view glist . unM1) (M1 . view (fromIso glist) . tupleToList)
57+ {-# INLINE[0] _GCtor #-}
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 _GCtor #-}
61+ {-# INLINE[0] _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 _GCtor #-}
65+ {-# INLINE[0] _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 _GSumCtor #-}
72+ {-# INLINE[0] _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 _GSumCtor #-}
76+ {-# INLINE[0] _GSumCtor #-}
src/Data/Generics/Sum/Internal/Subtype.hs+73−16
@@ -1,9 +1,10 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE PolyKinds #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE DataKinds #-}
33{-# LANGUAGE FlexibleContexts #-}
44{-# LANGUAGE FlexibleInstances #-}
55{-# LANGUAGE KindSignatures #-}
66{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE PolyKinds #-}
78{-# LANGUAGE ScopedTypeVariables #-}
89{-# LANGUAGE TypeApplications #-}
910{-# LANGUAGE TypeOperators #-}
@@ -13,7 +14,7 @@
1314-----------------------------------------------------------------------------
1415-- |
1516-- Module : Data.Generics.Sum.Internal.Subtype
16−-- Copyright : (C) 2017 Csongor Kiss
17+-- Copyright : (C) 2019 Csongor Kiss
1718-- License : BSD3
1819-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1920-- Stability : experimental
@@ -27,12 +28,14 @@ module Data.Generics.Sum.Internal.Subtype
2728 ( GAsSubtype (..)
2829 ) where
2930
30−import Data.Generics.Internal.Lens
31−import Data.Generics.Product.Internal.List
31+import Data.Generics.Product.Internal.HList
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
3639
3740-- |As 'AsSubtype' but over generic representations as defined by
3841-- "GHC.Generics".
@@ -40,19 +43,73 @@ class GAsSubtype (subf :: Type -> Type) (supf :: Type -> Type) where
4043 _GSub :: Prism' (supf x) (subf x)
4144
4245instance
43− ( GAsSubtype l supf
44− , GAsSubtype r supf
45− ) => GAsSubtype (l :+: r) supf where
46− _GSub = without' _GSub _GSub . fromIso sumIso
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 #-}
4761
4862instance
49− ( GIsList () subf subf as as
63+ ( GIsList subf subf as as
5064 , GAsType supf as
51− ) => GAsSubtype (C1 meta subf) supf where
52− _GSub = _GTyped . fromIso (glist @()) . fromIso mIso
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 #-}
5372
54−-- instance GAsType supf a => GAsSubtype (S1 meta (Rec0 a)) supf where
55−-- _GSub = _GTyped . fromIso (mIso . kIso)
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 #-}
56115
57−instance GAsSubtype subf supf => GAsSubtype (D1 meta subf) supf where
58− _GSub = _GSub . fromIso mIso
src/Data/Generics/Sum/Internal/Typed.hs+22−9
@@ -13,7 +13,7 @@
1313-----------------------------------------------------------------------------
1414-- |
1515-- Module : Data.Generics.Sum.Internal.Typed
16−-- Copyright : (C) 2017 Csongor Kiss
16+-- Copyright : (C) 2019 Csongor Kiss
1717-- License : BSD3
1818-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1919-- Stability : experimental
@@ -29,31 +29,44 @@ module Data.Generics.Sum.Internal.Typed
2929
3030import Data.Kind
3131import GHC.Generics
32+import Data.Tagged
3233
3334import Data.Generics.Internal.Families
34−import Data.Generics.Product.Internal.List
35−import Data.Generics.Internal.Lens
35+import Data.Generics.Product.Internal.HList
36+import Data.Generics.Internal.Profunctor.Iso
37+import Data.Generics.Internal.Profunctor.Prism
3638
3739-- |As 'AsType' but over generic representations as defined by "GHC.Generics".
38−class GAsType (f :: Type -> Type) (as :: [((), Type)]) where
39− _GTyped :: Prism (f x) (f x) (List as) (List as)
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+
4048
4149instance
42− ( GIsList () f f as as
50+ ( GIsList f f as as
4351 ) => GAsType (M1 C meta f) as where
44− _GTyped = mIso . glist @()
52+ _GTyped = mIso . glist
53+ {-# INLINE[0] _GTyped #-}
4554
4655instance GSumAsType (HasPartialTypeP a l) l r a => GAsType (l :+: r) a where
4756 _GTyped = _GSumTyped @(HasPartialTypeP a l)
57+ {-# INLINE[0] _GTyped #-}
4858
4959instance GAsType f a => GAsType (M1 D meta f) a where
5060 _GTyped = mIso . _GTyped
61+ {-# INLINE[0] _GTyped #-}
5162
52−class GSumAsType (contains :: Bool) l r (a :: [((), Type)]) where
53− _GSumTyped :: Prism ((l :+: r) x) ((l :+: r) x) (List a) (List a)
63+class GSumAsType (contains :: Bool) l r (a :: [Type]) where
64+ _GSumTyped :: Prism ((l :+: r) x) ((l :+: r) x) (HList a) (HList a)
5465
5566instance GAsType l a => GSumAsType 'True l r a where
5667 _GSumTyped = left . _GTyped
68+ {-# INLINE[0] _GSumTyped #-}
5769
5870instance GAsType r a => GSumAsType 'False l r a where
5971 _GSumTyped = right . _GTyped
72+ {-# INLINE[0] _GSumTyped #-}
src/Data/Generics/Sum/Subtype.hs+53−12
@@ -1,8 +1,10 @@
1−{-# LANGUAGE TypeApplications #-}
1+{-# LANGUAGE CPP #-}
22{-# LANGUAGE FlexibleContexts #-}
33{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE MonoLocalBinds #-}
45{-# LANGUAGE MultiParamTypeClasses #-}
56{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE TypeApplications #-}
68{-# LANGUAGE TypeOperators #-}
79{-# LANGUAGE TypeSynonymInstances #-}
810{-# LANGUAGE UndecidableInstances #-}
@@ -10,7 +12,7 @@
1012-----------------------------------------------------------------------------
1113-- |
1214-- Module : Data.Generics.Sum.Subtype
13−-- Copyright : (C) 2017 Csongor Kiss
15+-- Copyright : (C) 2019 Csongor Kiss
1416-- License : BSD3
1517-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1618-- Stability : experimental
@@ -27,11 +29,12 @@ module Data.Generics.Sum.Subtype
2729 AsSubtype (..)
2830 ) where
2931
30−import Data.Generics.Internal.Lens
3132import Data.Generics.Internal.Void
3233import Data.Generics.Sum.Internal.Subtype
3334
3435import GHC.Generics (Generic (Rep))
36+import Data.Generics.Internal.VL.Prism
37+import Data.Generics.Internal.Profunctor.Iso
3538
3639-- $setup
3740-- == /Running example:/
@@ -40,7 +43,7 @@ import GHC.Generics (Generic (Rep))
4043-- >>> :set -XDataKinds
4144-- >>> :set -XDeriveGeneric
4245-- >>> import GHC.Generics
43−-- >>> :m +Data.Generics.Internal.Lens
46+-- >>> :m +Data.Generics.Internal.VL.Prism
4447-- >>> :{
4548-- data Animal
4649-- = Dog Dog
@@ -86,17 +89,19 @@ class AsSubtype sub sup where
8689 --
8790 -- >>> duck ^? _Sub :: Maybe FourLeggedAnimal
8891 -- Nothing
89− _Sub :: PrismVL' sup sub
90− _Sub eta = prismVL injectSub projectSub eta
91− {-# INLINE _Sub #-}
92+ _Sub :: Prism' sup sub
93+ _Sub = prism injectSub (\i -> maybe (Left i) Right (projectSub i))
94+ {-# INLINE[2] _Sub #-}
9295
9396 -- |Injects a subtype into a supertype (upcast).
9497 injectSub :: sub -> sup
95− injectSub = buildVL (_Sub @sub @sup)
98+ injectSub
99+ = build (_Sub @sub @sup)
96100
97101 -- |Projects a subtype from a supertype (downcast).
98− projectSub :: sup -> Either sup sub
99− projectSub = matchVL (_Sub @sub @sup)
102+ projectSub :: sup -> Maybe sub
103+ projectSub
104+ = either (const Nothing) Just . match (_Sub @sub @sup)
100105
101106 {-# MINIMAL (injectSub, projectSub) | _Sub #-}
102107
@@ -106,12 +111,48 @@ instance
106111 , GAsSubtype (Rep sub) (Rep sup)
107112 ) => AsSubtype sub sup where
108113
109− _Sub = prismVLRavel (repIso . _GSub . fromIso repIso)
114+ _Sub f = prismRavel (repIso . _GSub . fromIso repIso) f
115+ {-# INLINE[2] _Sub #-}
110116
111−-- See Note [Uncluttering type signatures]
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
112138instance {-# OVERLAPPING #-} AsSubtype a Void where
113139 injectSub = undefined
114140 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
115156instance {-# OVERLAPPING #-} AsSubtype Void a where
116157 injectSub = undefined
117158 projectSub = undefined
src/Data/Generics/Sum/Typed.hs+48−18
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE TypeApplications #-}
23{-# LANGUAGE AllowAmbiguousTypes #-}
34{-# LANGUAGE DataKinds #-}
@@ -13,7 +14,7 @@
1314-----------------------------------------------------------------------------
1415-- |
1516-- Module : Data.Generics.Sum.Typed
16−-- Copyright : (C) 2017 Csongor Kiss
17+-- Copyright : (C) 2019 Csongor Kiss
1718-- License : BSD3
1819-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1920-- Stability : experimental
@@ -34,18 +35,21 @@ import Data.Kind
3435import GHC.Generics
3536import GHC.TypeLits (TypeError, ErrorMessage (..), Symbol)
3637import Data.Generics.Sum.Internal.Typed
38+import Data.Generics.Internal.Errors
3739
3840import Data.Generics.Internal.Families
39−import Data.Generics.Internal.Lens
4041import Data.Generics.Internal.Void
41−import Data.Generics.Product.Internal.List
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)
4246
4347-- $setup
4448-- >>> :set -XTypeApplications
4549-- >>> :set -XDataKinds
4650-- >>> :set -XDeriveGeneric
4751-- >>> import GHC.Generics
48−-- >>> :m +Data.Generics.Internal.Lens
52+-- >>> :m +Data.Generics.Internal.VL.Prism
4953-- >>> :{
5054-- data Animal
5155-- = Dog Dog
@@ -85,17 +89,21 @@ class AsType a s where
8589 -- ... Duck
8690 -- ... Turtle
8791 -- ...
88− _Typed :: PrismVL' s a
92+ _Typed :: Prism' s a
93+ _Typed = prism injectTyped (\i -> maybe (Left i) Right (projectTyped i))
94+ {-# INLINE[2] _Typed #-}
8995
9096 -- |Inject by type.
9197 injectTyped :: a -> s
9298 injectTyped
93− = buildVL _Typed
99+ = build _Typed
94100
95101 -- |Project by type.
96102 projectTyped :: s -> Maybe a
97103 projectTyped
98− = either (const Nothing) Just . (matchVL _Typed)
104+ = either (const Nothing) Just . match _Typed
105+
106+ {-# MINIMAL (injectTyped, projectTyped) | _Typed #-}
99107
100108instance
101109 ( Generic s
@@ -103,23 +111,45 @@ instance
103111 , as ~ TupleToList a
104112 , ListTuple a as
105113 , 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)
106117 ) => AsType a s where
107118
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]
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
119134instance {-# OVERLAPPING #-} AsType a Void where
120135 _Typed = undefined
121136 injectTyped = undefined
122137 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
123153instance {-# OVERLAPPING #-} AsType Void a where
124154 _Typed = undefined
125155 injectTyped = undefined
src/Data/Generics/Wrapped.hsnew file+104
@@ -0,0 +1,104 @@
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+1−4
@@ -1,11 +1,8 @@
1−resolver: lts-9.2
1+resolver: nightly-2018-08-09
22
33packages:
44- '.'
55
6−extra-deps:
7−- 'inspection-testing-0.1.1.2'
8−
96flags: {}
107
118extra-package-dbs: []
test/Bifunctor.hsnew file+47
@@ -0,0 +1,47 @@
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.hsnew file+63
@@ -0,0 +1,63 @@
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+133−47
@@ -1,7 +1,8 @@
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 #-}
56{-# LANGUAGE DataKinds #-}
67{-# LANGUAGE DeriveGeneric #-}
78{-# LANGUAGE DuplicateRecordFields #-}
@@ -10,19 +11,29 @@
1011{-# LANGUAGE ScopedTypeVariables #-}
1112{-# LANGUAGE TypeApplications #-}
1213{-# LANGUAGE TemplateHaskell #-}
13−-- For the VL prism test
14+{-# LANGUAGE OverloadedLabels #-}
1415
1516module Main where
1617
1718import GHC.Generics
18−import Data.Profunctor
1919import Data.Generics.Product
20−import Data.Generics.Internal.Lens (prismPRavel, plus)
2120import Data.Generics.Sum
2221import Test.Inspection
2322import Test.HUnit
2423import Util
2524import 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)
2637
2738main :: IO ()
2839main = do
@@ -45,24 +56,6 @@ data Record3 a = MkRecord3
4556 , fieldB :: Bool
4657 } deriving (Generic, Show)
4758
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−
6659data Record4 a = MkRecord4
6760 { fieldA :: a
6861 , fieldB :: a
@@ -77,8 +70,6 @@ data Record5 = MkRecord5
7770 , fieldF :: Int
7871 } deriving Generic
7972
80−
81−
8273typeChangingManual :: Lens (Record3 a) (Record3 b) a b
8374typeChangingManual f (MkRecord3 a b) = (\a' -> MkRecord3 a' b) <$> f a
8475
@@ -106,6 +97,36 @@ subtypeLensManual f record
10697data Sum1 = A Char | B Int | C () | D () deriving (Generic, Show)
10798data Sum2 = A2 Char | B2 Int deriving (Generic, Show)
10899
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+
109130sum1PrismManual :: Prism Sum1 Sum1 Int Int
110131sum1PrismManual eta = prism g f eta
111132 where
@@ -114,22 +135,42 @@ sum1PrismManual eta = prism g f eta
114135 s -> Left s
115136 g = B
116137
117−sum1PrismPManual :: PrismP Sum1 Sum1 Int Int
118−sum1PrismPManual eta = prismP g f eta
138+sum1PrismManualChar :: Prism Sum1 Sum1 Char Char
139+sum1PrismManualChar eta = prism g f eta
119140 where
120141 f s1 = case s1 of
121− B i -> Right i
122− s -> Left s
123− g = B
142+ A i -> Right i
143+ B _ -> Left s1
144+ C _ -> Left s1
145+ D _ -> Left s1
146+ g = A
147+
148+sum2PrismManual :: Prism Sum2 Sum2 Int Int
149+sum2PrismManual eta = prism g f eta
150+ where
151+ f s1 = case s1 of
152+ B2 i -> Right i
153+ s -> Left s
154+ g = B2
155+
156+
157+sum2PrismManualChar :: Prism Sum2 Sum2 Char Char
158+sum2PrismManualChar eta = prism g f eta
159+ where
160+ f s1 = case s1 of
161+ A2 i -> Right i
162+ s -> Left s
163+ g = A2
124164
165+-- Note we don't have a catch-all case because of #14684
125166subtypePrismManual :: Prism Sum1 Sum1 Sum2 Sum2
126167subtypePrismManual eta = prism g f eta
127168 where
128169 f s1 = case s1 of
129170 A c -> Right (A2 c)
130171 B i -> Right (B2 i)
131− C _ -> Left s1
132− D _ -> Left s1
172+ C _ -> Left s1
173+ D _ -> Left s1
133174 g (A2 c) = A c
134175 g (B2 i) = B i
135176
@@ -144,47 +185,92 @@ subtypePrismManual eta = prism g f eta
144185fieldALensName :: Lens' Record Int
145186fieldALensName = field @"fieldA"
146187
188+fieldALensName_ :: Lens' Record Int
189+fieldALensName_ = field_ @"fieldA"
190+
147191fieldALensType :: Lens' Record Int
148192fieldALensType = typed @Int
149193
150194fieldALensPos :: Lens' Record Int
151195fieldALensPos = position @1
152196
197+fieldALensPos_ :: Lens' Record Int
198+fieldALensPos_ = position_ @1
199+
153200subtypeLensGeneric :: Lens' Record Record2
154201subtypeLensGeneric = super
155202
156203typeChangingGeneric :: Lens (Record3 a) (Record3 b) a b
157−typeChangingGeneric = field @"fieldA"
204+typeChangingGeneric = #fieldA
158205
159206typeChangingGenericPos :: Lens (Record3 a) (Record3 b) a b
160207typeChangingGenericPos = position @1
161208
162209typeChangingGenericCompose :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b
163−typeChangingGenericCompose = field @"fieldA" . field @"fieldA"
210+typeChangingGenericCompose = #fieldA . #fieldA
211+
212+typeChangingGenericCompose_ :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b
213+typeChangingGenericCompose_ = field_ @"fieldA" . field_ @"fieldA"
164214
165215sum1PrismB :: Prism Sum1 Sum1 Int Int
166216sum1PrismB = _Ctor @"B"
167217
168−--sum1PrismBP :: PrismP Sum1 Sum1 Int Int
169−--sum1PrismBP = prismPRavel (_CtorRaw @"B")
170−
171218subtypePrismGeneric :: Prism Sum1 Sum1 Sum2 Sum2
172219subtypePrismGeneric = _Sub
173220
174221sum1TypePrism :: Prism Sum1 Sum1 Int Int
175222sum1TypePrism = _Typed @Int
176223
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+
177239tests :: Test
178240tests = TestList $ map mkHUnitTest
179− [ $(inspectTest $ 'fieldALensManual === 'fieldALensName)
180− , $(inspectTest $ 'fieldALensManual === 'fieldALensType)
181− , $(inspectTest $ 'fieldALensManual === 'fieldALensPos)
182− , $(inspectTest $ 'subtypeLensManual === 'subtypeLensGeneric)
183− , $(inspectTest $ 'typeChangingManual === 'typeChangingGeneric)
184− , $(inspectTest $ 'typeChangingManual === 'typeChangingGenericPos)
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)
185249 , $(inspectTest $ 'typeChangingManualCompose === 'typeChangingGenericCompose)
186− , $(inspectTest $ 'intTraversalManual === 'intTraversalDerived)
187− , $(inspectTest $ 'sum1PrismManual === 'sum1PrismB)
188− -- , $(inspectTest $ 'sum1PrismPManual === 'sum1PrismBP)
189− , $(inspectTest $ 'subtypePrismManual === 'subtypePrismGeneric)
190− , $(inspectTest $ 'sum1PrismManual === 'sum1TypePrism) ]
250+ , $(inspectTest $ 'typeChangingManualCompose === 'typeChangingGenericCompose_)
251+ , $(inspectTest $ 'sum1PrismManual === 'sum1PrismB)
252+ , $(inspectTest $ 'subtypePrismManual === 'subtypePrismGeneric)
253+ , $(inspectTest $ 'sum2PrismManualChar === 'sum2TypePrismChar)
254+ , $(inspectTest $ 'sum2PrismManual === 'sum2TypePrism)
255+ , $(inspectTest $ 'sum1PrismManualChar === 'sum1TypePrismChar)
256+ , $(inspectTest $ 'sum2PrismManualChar === 'sum2TypePrismChar)
257+ , $(inspectTest $ 'sum1PrismManual === 'sum1TypePrism)
258+ --, $(inspectTest $ 'intTraversalManual === 'intTraversalDerived)
259+ --, $(inspectTest $ 'sum3Param0Manual === 'sum3Param0Derived)
260+ -- TODO [1.0.0.0]: these tests pass with the new implementation
261+-- , $(inspectTest $ 'sum3Param1Manual === 'sum3Param1Derived)
262+-- , $(inspectTest $ 'sum3Param2Manual === 'sum3Param2Derived)
263+ ] ++
264+ -- Tests for overloaded labels
265+ [ (valLabel ^. #_foo ) ~=? 3
266+ , (valLabel & #_foo +~ 10 ) ~=? RecB 13 True
267+#if __GLASGOW_HASKELL__ >= 802
268+ , (valLabel ^? #_RecB ) ~=? Just (3, True)
269+ , (valLabel ^? #_RecB . _1 ) ~=? Just 3
270+ , (valLabel ^? #_RecC ) ~=? Nothing
271+#endif
272+ , customTypesTest
273+ ]
274+ where valLabel = RecB 3 True
275+
276+-- TODO: add test for traversals over multiple types
test/24.hs → test/Test24.hsrenamed+1−1
@@ -1,6 +1,6 @@
11{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications #-}
22
3−module Main where
3+module Test24 where
44
55-- Test case from #24, comments preserved
66import Control.Lens
test/25.hs → test/Test25.hsrenamed+1−1
@@ -4,7 +4,7 @@
44{-# LANGUAGE DeriveGeneric #-}
55{-# OPTIONS_GHC -Wall #-}
66
7−module Main where
7+module Test25 where
88
99import Control.Lens
1010import Data.Generics.Product
test/Test40.hsnew file+22
@@ -0,0 +1,22 @@
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.hsnew file+20
@@ -0,0 +1,20 @@
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.hsnew file+12
@@ -0,0 +1,12 @@
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.hsnew file+17
@@ -0,0 +1,17 @@
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,4 +4,5 @@ main
44 [ "-isrc"
55 , "src/Data/Generics/Product.hs"
66 , "src/Data/Generics/Sum.hs"
7+ , "src/Data/Generics/Labels.hs"
78 ]
test/syb/Tree.hsnew file+76
@@ -0,0 +1,76 @@
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 _ = []