on master help sign in
60 files changed+2094−852
since splitsnapshots
unifiedsplit
.github/FUNDING.yml+12 .gitignore+3 .travis.yml+132−71 ChangeLog.md+23 LICENSE+1−1 README.md+4−1 cabal.haskell-ci+5 cabal.project+1 examples/doctest.hs+1 generic-lens.cabal+16−10 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+12−5 src/Data/Generics/Internal/Families/Collect.hs+2−2 src/Data/Generics/Internal/Families/Has.hs+72−22 src/Data/Generics/Internal/GenericN.hs+3−2 src/Data/Generics/Internal/Profunctor/Iso.hs+9−1 src/Data/Generics/Internal/Profunctor/Lens.hs+2−1 src/Data/Generics/Internal/Profunctor/Prism.hs+8−9 src/Data/Generics/Internal/VL/Iso.hs+30−2 src/Data/Generics/Internal/VL/Lens.hs+6−1 src/Data/Generics/Internal/VL/Prism.hs+2−1 src/Data/Generics/Internal/VL/Traversal.hs+2−1 src/Data/Generics/Labels.hs+123−17 src/Data/Generics/Product.hs+3−3 src/Data/Generics/Product/Any.hs+2−2 src/Data/Generics/Product/Constraints.hs+1−1 src/Data/Generics/Product/Fields.hs+82−24 src/Data/Generics/Product/HList.hs+46 src/Data/Generics/Product/Internal/Constraints.hs+2−7 src/Data/Generics/Product/Internal/GLens.hs+81 src/Data/Generics/Product/Internal/HList.hs+329 src/Data/Generics/Product/Internal/Keyed.hs−60 src/Data/Generics/Product/Internal/List.hs−335 src/Data/Generics/Product/Internal/Positions.hs+46−27 src/Data/Generics/Product/Internal/Subtype.hs+15−10 src/Data/Generics/Product/List.hs−78 src/Data/Generics/Product/Param.hs+10−3 src/Data/Generics/Product/Positions.hs+109−24 src/Data/Generics/Product/Subtype.hs+43−3 src/Data/Generics/Product/Typed.hs+31−5 src/Data/Generics/Product/Types.hs+272−68 src/Data/Generics/Sum.hs+1−1 src/Data/Generics/Sum/Any.hs+2−2 src/Data/Generics/Sum/Constructors.hs+76−19 src/Data/Generics/Sum/Internal/Constructors.hs+6−7 src/Data/Generics/Sum/Internal/Subtype.hs+8−8 src/Data/Generics/Sum/Internal/Typed.hs+8−8 src/Data/Generics/Sum/Subtype.hs+38−2 src/Data/Generics/Sum/Typed.hs+34−3 src/Data/Generics/Wrapped.hs+104 stack.yaml+1−1 test/CustomChildren.hs+63 test/Spec.hs+38−2 test/Test62.hs+20 test/Test63.hs+12 test/Test71.hs+17 test/doctest.hs+1
.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+3
@@ -7,3 +7,6 @@ cabal.sandbox.config
77*.hi
88*.o
99core-html
10+*~
11+*.org
12+cabal.project.local
.travis.yml+132−71
@@ -1,94 +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: false # 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− - compiler: "ghc-8.4.1"
39− # env: TEST=--disable-tests BENCH=--disable-benchmarks
40− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.4.1], sources: [hvr-ghc]}}
41−
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"]}}
4241before_install:
43− - HC=${CC}
44− - 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"
4546 - unset CC
46− - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH
47−
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
4873install:
49− - cabal --version
74+ - ${CABAL} --version
5075 - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
51− - BENCH=${BENCH---enable-benchmarks}
52− - TEST=${TEST---enable-tests}
53− - HADDOCK=${HADDOCK-true}
54− - INSTALLED=${INSTALLED-true}
55− - travis_retry cabal update -v
56− - sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
57− - rm -fv cabal.project.local
58− - "echo 'packages: .' > cabal.project"
59− - if [ -f "./configure.ac" ]; then
60− (cd "."; autoreconf -i);
61− fi
62− - rm -f cabal.project.freeze
63− - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all
64− - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all
65− - rm -rf "."/.ghc.environment.* "."/dist
66− - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
67−
68−# Here starts the actual work to be performed for the package under test;
69−# 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
70119script:
71− # test that source-distributions can be generated
72− - (cd "."; cabal sdist)
73− - mv "."/dist/generic-lens-*.tar.gz ${DISTDIR}/
74− - cd ${DISTDIR}
75− - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;
76− - "printf 'packages: generic-lens-*/*.cabal' > 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...
77139 # this builds all libraries and executables (without tests/benchmarks)
78− - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all
79−
80− # Build with installed constraints for packages in global-db
81− - if $INSTALLED; then
82− 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;
83− else echo "Not building with installed constraints"; fi
84−
140+ - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output
141+ # Building with tests and benchmarks...
85142 # build & run tests, build benchmarks
86− - cabal new-build -w ${HC} ${TEST} ${BENCH} all
87− - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} all; fi
88−
89− # haddock
90− - rm -rf ./dist-newstyle
91− - 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
92153
93−# REGENDATA ["generic-lens.cabal"]
154+# REGENDATA ["--config=cabal.haskell-ci","cabal.project"]
94155# EOF
ChangeLog.md+23
@@ -1,3 +1,26 @@
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+
124## 1.0.0.1
225- Remove dump-core dependency
326- Relax upper bound on criterion (#42)
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+4−1
@@ -16,6 +16,9 @@ fully interoperable with the combinators found in mainstream lens libraries.
1616
1717Examples can be found in the `examples` and `tests` folders.
1818
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+
1922Table of contents
2023=================
2124
@@ -407,7 +410,7 @@ The
407410library is used to ensure (see [here](test/Spec.hs)) that everything gets
408411inlined away.
409412
410−TODO push benchmarks too
413+There is also a [benchmark suite](https://github.com/mpickering/generic-lens-benchmarks) with larger, real-world examples.
411414# Contributors
412415
413416+ [Matthew Pickering](https://github.com/mpickering)
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/doctest.hs+1
@@ -2,5 +2,6 @@ import Test.DocTest
22main
33 = doctest
44 [ "-iexamples"
5+ , "-isrc"
56 , "examples/Biscuits.hs"
67 ]
generic-lens.cabal+16−10
@@ -1,5 +1,5 @@
11name: generic-lens
2−version: 1.0.0.1
2+version: 1.2.0.1
33synopsis: Generically derive traversals, lenses and prisms.
44description: 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
@@ -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,7 +23,8 @@ 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
2930 , Data.Generics.Product.Param
@@ -32,7 +33,8 @@ library
3233 , Data.Generics.Product.Typed
3334 , Data.Generics.Product.Types
3435 , Data.Generics.Product.Constraints
35− , Data.Generics.Product.List
36+ , Data.Generics.Product.HList
37+ , Data.Generics.Labels
3638 , Data.Generics.Internal.GenericN
3739
3840 , Data.Generics.Sum
@@ -48,10 +50,13 @@ library
4850 , Data.Generics.Internal.VL.Prism
4951 , Data.Generics.Internal.VL.Iso
5052
53+ , Data.GenericLens.Internal
54+
5155 other-modules: Data.Generics.Internal.Families
5256 , Data.Generics.Internal.Families.Changing
5357 , Data.Generics.Internal.Families.Collect
5458 , Data.Generics.Internal.Families.Has
59+ , Data.Generics.Internal.Errors
5560 , Data.Generics.Internal.Void
5661
5762 , Data.Generics.Sum.Internal.Constructors
@@ -59,15 +64,16 @@ library
5964 , Data.Generics.Sum.Internal.Subtype
6065
6166 , Data.Generics.Product.Internal.Positions
67+ , Data.Generics.Product.Internal.GLens
6268 , Data.Generics.Product.Internal.Subtype
6369
6470 , Data.Generics.Product.Internal.Constraints
65− , Data.Generics.Product.Internal.List
66− , Data.Generics.Product.Internal.Keyed
71+ , Data.Generics.Product.Internal.HList
6772
68− build-depends: base >= 4.9 && <= 5.0
69− , profunctors >= 5.0 && <= 6.0
70− , 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
7177
7278 hs-source-dirs: src
7379 default-language: Haskell2010
@@ -97,7 +103,7 @@ test-suite generic-lens-test
97103 type: exitcode-stdio-1.0
98104 hs-source-dirs: test
99105 main-is: Spec.hs
100− other-modules: Util Test24 Test25 Test40
106+ other-modules: Util Test24 Test25 Test40 Test62 Test63 CustomChildren
101107
102108 build-depends: base >= 4.9 && <= 5.0
103109 , generic-lens
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
@@ -9,7 +9,7 @@
99-----------------------------------------------------------------------------
1010-- |
1111-- Module : Data.Generics.Internal.Families
12−-- Copyright : (C) 2017 Csongor Kiss
12+-- Copyright : (C) 2019 Csongor Kiss
1313-- License : BSD3
1414-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1515-- Stability : experimental
@@ -27,7 +27,6 @@ import Data.Generics.Internal.Families.Changing as Families
2727
2828import GHC.TypeLits (ErrorMessage (..), Symbol)
2929
30−-- * Stuff
3130type family ShowSymbols (ctors :: [Symbol]) :: ErrorMessage where
3231 ShowSymbols '[]
3332 = 'Text ""
src/Data/Generics/Internal/Families/Changing.hs+12−5
@@ -9,13 +9,14 @@
99{-# LANGUAGE UndecidableInstances #-}
1010
1111module Data.Generics.Internal.Families.Changing
12− ( Proxied
12+ ( Indexed
1313 , Infer
1414 , PTag (..)
1515 , P
1616 , LookupParam
1717 , ArgAt
1818 , ArgCount
19+ , UnifyHead
1920 ) where
2021
2122import GHC.TypeLits (Nat, type (-), type (+), TypeError, ErrorMessage (..))
@@ -55,11 +56,11 @@ import GHC.TypeLits (Nat, type (-), type (+), TypeError, ErrorMessage (..))
5556data PTag = PTag
5657type family P :: Nat -> k -> PTag -> k
5758
58−type Proxied t = Proxied' t 0
59+type Indexed t = Indexed' t 0
5960
60−type family Proxied' (t :: k) (next :: Nat) :: k where
61− Proxied' (t (a :: j) :: k) next = (Proxied' t (next + 1)) (P next a 'PTag)
62− 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
6364
6465data Sub where
6566 Sub :: Nat -> k -> Sub
@@ -152,3 +153,9 @@ type family ArgAt (t :: k) (n :: Nat) :: j where
152153-- However, for some reason, this violates the functional dependencies on 8.2.2.
153154-- Therefore, when using a newer version of the compiler, the original constraints
154155-- 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−22
@@ -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
@@ -16,42 +16,92 @@
1616-----------------------------------------------------------------------------
1717module Data.Generics.Internal.Families.Has
1818 ( HasTotalFieldP
19+ , HasTotalTypeP
20+ , HasTotalPositionP
21+ , Pos
1922 , HasPartialTypeP
2023 , HasCtorP
2124 , GTypes
2225 ) where
2326
24−import Data.Type.Bool (type (||), type (&&))
27+import Data.Type.Bool (type (||))
2528import Data.Type.Equality (type (==))
2629import GHC.Generics
27−import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
30+import GHC.TypeLits (Symbol, Nat)
31+import Data.Kind (Type)
2832
29−import Data.Generics.Product.Internal.List
33+import Data.Generics.Product.Internal.HList
3034
31−type family HasTotalFieldP (field :: Symbol) f :: Bool where
32− HasTotalFieldP field (S1 ('MetaSel ('Just field) _ _ _) _)
33− = '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
3447 HasTotalFieldP field (l :*: r)
35− = HasTotalFieldP field l || HasTotalFieldP field r
48+ = Alt (HasTotalFieldP field l) (HasTotalFieldP field r)
3649 HasTotalFieldP field (l :+: r)
37− = HasTotalFieldP field l && HasTotalFieldP field r
50+ = Both (HasTotalFieldP field l) (HasTotalFieldP field r)
3851 HasTotalFieldP field (S1 _ _)
39− = 'False
52+ = 'Nothing
4053 HasTotalFieldP field (C1 _ f)
4154 = HasTotalFieldP field f
4255 HasTotalFieldP field (D1 _ f)
4356 = HasTotalFieldP field f
44− HasTotalFieldP field (Rec0 _)
45− = 'False
57+ HasTotalFieldP field (K1 _ _)
58+ = 'Nothing
4659 HasTotalFieldP field U1
47− = 'False
60+ = 'Nothing
4861 HasTotalFieldP field V1
49− = 'False
50− HasTotalFieldP field f
51− = TypeError
52− ( 'ShowType f
53− ':<>: 'Text " is not a valid GHC.Generics representation type"
54− )
62+ = 'Nothing
63+
64+type family HasTotalTypeP (typ :: Type) f :: Maybe Type where
65+ HasTotalTypeP typ (S1 _ (K1 _ typ))
66+ = 'Just typ
67+ HasTotalTypeP typ (l :*: r)
68+ = Alt (HasTotalTypeP typ l) (HasTotalTypeP typ r)
69+ HasTotalTypeP typ (l :+: r)
70+ = Both (HasTotalTypeP typ l) (HasTotalTypeP typ r)
71+ HasTotalTypeP typ (S1 _ _)
72+ = 'Nothing
73+ HasTotalTypeP typ (C1 _ f)
74+ = HasTotalTypeP typ f
75+ HasTotalTypeP typ (D1 _ f)
76+ = HasTotalTypeP typ f
77+ HasTotalTypeP typ (K1 _ _)
78+ = 'Nothing
79+ HasTotalTypeP typ U1
80+ = 'Nothing
81+ HasTotalTypeP typ V1
82+ = 'Nothing
83+
84+data Pos (p :: Nat)
85+
86+type family HasTotalPositionP (pos :: Nat) f :: Maybe Type where
87+ HasTotalPositionP pos (S1 _ (K1 (Pos pos) t))
88+ = 'Just t
89+ HasTotalPositionP pos (l :*: r)
90+ = Alt (HasTotalPositionP pos l) (HasTotalPositionP pos r)
91+ HasTotalPositionP pos (l :+: r)
92+ = Both (HasTotalPositionP pos l) (HasTotalPositionP pos r)
93+ HasTotalPositionP pos (S1 _ _)
94+ = 'Nothing
95+ HasTotalPositionP pos (C1 _ f)
96+ = HasTotalPositionP pos f
97+ HasTotalPositionP pos (D1 _ f)
98+ = HasTotalPositionP pos f
99+ HasTotalPositionP pos (K1 _ _)
100+ = 'Nothing
101+ HasTotalPositionP pos U1
102+ = 'Nothing
103+ HasTotalPositionP pos V1
104+ = 'Nothing
55105
56106type family HasPartialTypeP a f :: Bool where
57107 HasPartialTypeP t (l :+: r)
@@ -73,11 +123,11 @@ type family HasCtorP (ctor :: Symbol) f :: Bool where
73123 HasCtorP ctor _
74124 = 'False
75125
76−type family GTypes (rep :: * -> *) :: [((), *)] where
126+type family GTypes (rep :: Type -> Type) :: [Type] where
77127 GTypes (l :*: r)
78128 = GTypes l ++ GTypes r
79− GTypes (Rec0 a)
80− = '[ '( '(), a)]
129+ GTypes (K1 _ a)
130+ = '[ a]
81131 GTypes (M1 _ m a)
82132 = GTypes a
83133 GTypes U1 = '[]
src/Data/Generics/Internal/GenericN.hs+3−2
@@ -1,3 +1,4 @@
1+{-# OPTIONS_HADDOCK hide #-}
12{-# LANGUAGE DataKinds #-}
23{-# LANGUAGE FlexibleContexts #-}
34{-# LANGUAGE FlexibleInstances #-}
@@ -11,9 +12,9 @@
1112--------------------------------------------------------------------------------
1213-- |
1314-- Module : Data.Generics.Internal.GenericN
14−-- Copyright : (C) 2018 Csongor Kiss
15−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
15+-- Copyright : (C) 2019 Csongor Kiss
1616-- License : BSD3
17+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1718-- Stability : experimental
1819-- Portability : non-portable
1920--
src/Data/Generics/Internal/Profunctor/Iso.hs+9−1
@@ -1,3 +1,5 @@
1+{-# OPTIONS_HADDOCK hide #-}
2+{-# LANGUAGE TupleSections #-}
13{-# LANGUAGE GADTs #-}
24{-# LANGUAGE NoMonomorphismRestriction #-}
35{-# LANGUAGE Rank2Types #-}
@@ -9,7 +11,7 @@
911-----------------------------------------------------------------------------
1012-- |
1113-- Module : Data.Generics.Internal.Profunctor.Iso
12−-- Copyright : (C) 2017 Csongor Kiss
14+-- Copyright : (C) 2019 Csongor Kiss
1315-- License : BSD3
1416-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1517-- Stability : experimental
@@ -26,6 +28,8 @@ import GHC.Generics ((:*:)(..), (:+:)(..), Generic(..), M1(..), K1(..)
2628import Data.Coerce
2729import Data.Generics.Internal.GenericN (Rec (..))
2830
31+import qualified Data.Generics.Internal.VL.Iso as VL
32+
2933type Iso s t a b
3034 = forall p. (Profunctor p) => p a b -> p s t
3135
@@ -74,6 +78,10 @@ iso :: (s -> a) -> (b -> t) -> Iso s t a b
7478iso = dimap
7579{-# INLINE iso #-}
7680
81+iso2isovl :: Iso s t a b -> VL.Iso s t a b
82+iso2isovl _iso = withIso _iso VL.iso
83+{-# INLINE iso2isovl #-}
84+
7785withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
7886withIso ai k = case ai (Exchange id id) of
7987 Exchange sa bt -> k sa bt
src/Data/Generics/Internal/Profunctor/Lens.hs+2−1
@@ -1,3 +1,4 @@
1+{-# OPTIONS_HADDOCK hide #-}
12{-# LANGUAGE GADTs #-}
23{-# LANGUAGE NoMonomorphismRestriction #-}
34{-# LANGUAGE Rank2Types #-}
@@ -10,7 +11,7 @@
1011-----------------------------------------------------------------------------
1112-- |
1213-- Module : Data.Generics.Internal.Profunctor.Lens
13−-- Copyright : (C) 2017 Csongor Kiss
14+-- Copyright : (C) 2019 Csongor Kiss
1415-- License : BSD3
1516-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1617-- Stability : experimental
src/Data/Generics/Internal/Profunctor/Prism.hs+8−9
@@ -1,3 +1,4 @@
1+{-# OPTIONS_HADDOCK hide #-}
12{-# LANGUAGE GADTs #-}
23{-# LANGUAGE LambdaCase #-}
34{-# LANGUAGE NoMonomorphismRestriction #-}
@@ -10,7 +11,7 @@
1011-----------------------------------------------------------------------------
1112-- |
1213-- Module : Data.Generics.Internal.Profunctor.Prism
13−-- Copyright : (C) 2017 Csongor Kiss
14+-- Copyright : (C) 2019 Csongor Kiss
1415-- License : BSD3
1516-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1617-- Stability : experimental
@@ -21,6 +22,7 @@
2122-----------------------------------------------------------------------------
2223module Data.Generics.Internal.Profunctor.Prism where
2324
25+import Data.Bifunctor (bimap)
2426import Data.Profunctor (Choice(..), Profunctor(..))
2527import Data.Tagged
2628import Data.Profunctor.Unsafe ((#.), (.#))
@@ -44,12 +46,12 @@ prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
4446prism bt seta eta = dimap seta (either id bt) (right' eta)
4547
4648_Left :: Prism (Either a c) (Either b c) a b
47−_Left = prism Left $ either Right (Left . Right)
49+_Left = left'
4850
4951_Right :: Prism (Either c a) (Either c b) a b
50−_Right = prism Right $ either (Left . Left) Right
52+_Right = right'
5153
52−prismPRavel :: (Market a b a b -> Market a b s t) -> Prism s t a b
54+prismPRavel :: APrism s t a b -> Prism s t a b
5355prismPRavel l pab = (prism2prismp $ l idPrism) pab
5456
5557build :: (Tagged b b -> Tagged t t) -> b -> t
@@ -65,9 +67,7 @@ without' :: Prism s t a b -> Prism s t c d -> Prism s t (Either a c) (Either b d
6567without' k =
6668 withPrism k $ \bt _ k' ->
6769 withPrism k' $ \dt setc ->
68− prism (foldEither bt dt) $ \s -> fmap Right (setc s)
69− where foldEither _ g (Right r) = g r
70− foldEither f _ (Left l) = f l
70+ prism (either bt dt) $ \s -> fmap Right (setc s)
7171{-# INLINE without' #-}
7272
7373withPrism :: APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
@@ -85,8 +85,7 @@ gsum f _ (L1 x) = f x
8585gsum _ g (R1 y) = g y
8686
8787plus :: (a -> b) -> (c -> d) -> Either a c -> Either b d
88−plus f _ (Left x) = Left (f x)
89−plus _ g (Right y) = Right (g y)
88+plus = bimap
9089
9190--------------------------------------------------------------------------------
9291-- Market
src/Data/Generics/Internal/VL/Iso.hs+30−2
@@ -1,3 +1,4 @@
1+{-# OPTIONS_HADDOCK hide #-}
12{-# LANGUAGE GADTs #-}
23{-# LANGUAGE NoMonomorphismRestriction #-}
34{-# LANGUAGE Rank2Types #-}
@@ -9,7 +10,7 @@
910-----------------------------------------------------------------------------
1011-- |
1112-- Module : Data.Generics.Internal.VL.Iso
12−-- Copyright : (C) 2017 Csongor Kiss
13+-- Copyright : (C) 2019 Csongor Kiss
1314-- License : BSD3
1415-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1516-- Stability : experimental
@@ -20,16 +21,43 @@
2021-----------------------------------------------------------------------------
2122module Data.Generics.Internal.VL.Iso where
2223
23−import Data.Profunctor (Profunctor(..))
24+import Data.Coerce (coerce)
25+import Data.Functor.Identity (Identity(..))
26+import Data.Profunctor (Profunctor(..))
2427import GHC.Generics
2528import Data.Generics.Internal.GenericN (Rec (..))
2629
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+
2744type Iso' s a
2845 = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s)
2946
3047type Iso s t a b
3148 = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
3249
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+
3361-- | A type and its generic representation are isomorphic
3462repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
3563repIso = iso from to
src/Data/Generics/Internal/VL/Lens.hs+6−1
@@ -1,3 +1,4 @@
1+{-# OPTIONS_HADDOCK hide #-}
12{-# LANGUAGE GADTs #-}
23{-# LANGUAGE NoMonomorphismRestriction #-}
34{-# LANGUAGE Rank2Types #-}
@@ -10,7 +11,7 @@
1011-----------------------------------------------------------------------------
1112-- |
1213-- Module : Data.Generics.Internal.VL.Lens
13−-- Copyright : (C) 2017 Csongor Kiss
14+-- Copyright : (C) 2019 Csongor Kiss
1415-- License : BSD3
1516-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1617-- Stability : experimental
@@ -22,6 +23,7 @@
2223module Data.Generics.Internal.VL.Lens where
2324
2425import Control.Applicative (Const(..))
26+import Data.Coerce (coerce)
2527import Data.Functor.Identity (Identity(..))
2628import Data.Generics.Internal.Profunctor.Lens (ALens (..), idLens)
2729
@@ -47,6 +49,9 @@ infixr 4 .~
4749set :: Lens s t a b -> b -> s -> t
4850set l x = l .~ x
4951
52+over :: ((a -> Identity b) -> s -> Identity t) -> (a -> b) -> s -> t
53+over = coerce
54+
5055lens2lensvl :: ALens a b s t -> Lens s t a b
5156lens2lensvl (ALens _get _set) =
5257 \f x ->
src/Data/Generics/Internal/VL/Prism.hs+2−1
@@ -1,3 +1,4 @@
1+{-# OPTIONS_HADDOCK hide #-}
12{-# LANGUAGE GADTs #-}
23{-# LANGUAGE NoMonomorphismRestriction #-}
34{-# LANGUAGE Rank2Types #-}
@@ -9,7 +10,7 @@
910-----------------------------------------------------------------------------
1011-- |
1112-- Module : Data.Generics.Internal.VL.Prism
12−-- Copyright : (C) 2017 Csongor Kiss
13+-- Copyright : (C) 2019 Csongor Kiss
1314-- License : BSD3
1415-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1516-- Stability : experimental
src/Data/Generics/Internal/VL/Traversal.hs+2−1
@@ -1,3 +1,4 @@
1+{-# OPTIONS_HADDOCK hide #-}
12{-# LANGUAGE AllowAmbiguousTypes #-}
23{-# LANGUAGE ConstraintKinds #-}
34{-# LANGUAGE GADTs #-}
@@ -11,7 +12,7 @@
1112-----------------------------------------------------------------------------
1213-- |
1314-- Module : Data.Generics.Internal.VL.Traversal
14−-- Copyright : (C) 2017 Csongor Kiss
15+-- Copyright : (C) 2019 Csongor Kiss
1516-- License : BSD3
1617-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1718-- Stability : experimental
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+3−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,7 +22,7 @@ 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.List
25+ , module Data.Generics.Product.HList
2626 -- *Traversals
2727 , module Data.Generics.Product.Types
2828 , module Data.Generics.Product.Param
@@ -37,4 +37,4 @@ import Data.Generics.Product.Typed
3737import Data.Generics.Product.Types
3838import Data.Generics.Product.Constraints
3939import Data.Generics.Product.Param
40−import Data.Generics.Product.List
40+import Data.Generics.Product.HList
src/Data/Generics/Product/Any.hs+2−2
@@ -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
@@ -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'
src/Data/Generics/Product/Constraints.hs+1−1
@@ -11,7 +11,7 @@
1111-----------------------------------------------------------------------------
1212-- |
1313-- Module : Data.Generics.Product.Constraints
14−-- Copyright : (C) 2018 Csongor Kiss
14+-- Copyright : (C) 2019 Csongor Kiss
1515-- License : BSD3
1616-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1717-- Stability : experimental
src/Data/Generics/Product/Fields.hs+82−24
@@ -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
@@ -32,6 +32,7 @@ module Data.Generics.Product.Fields
3232 -- $setup
3333 HasField (..)
3434 , HasField' (..)
35+ , HasField_ (..)
3536
3637 , getField
3738 , setField
@@ -40,12 +41,13 @@ module Data.Generics.Product.Fields
4041import Data.Generics.Internal.Families
4142import 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)
4849import Data.Generics.Internal.Profunctor.Lens as P
50+import Data.Generics.Internal.Errors
4951
5052-- $setup
5153-- == /Running example:/
@@ -111,9 +113,30 @@ class HasField (field :: Symbol) s t a b | s field -> a, t field -> b, s field b
111113 -- ...
112114 field :: VL.Lens s t a b
113115
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+
114130class HasField' (field :: Symbol) s a | s field -> a where
115131 field' :: VL.Lens s s a a
116132
133+-- |Records that have a field with a given name.
134+--
135+-- This class gives the minimal constraints needed to define this lens.
136+-- For common uses, see 'HasField'.
137+class HasField0 (field :: Symbol) s t a b where
138+ field0 :: VL.Lens s t a b
139+
117140-- |
118141-- >>> getField @"age" human
119142-- 50
@@ -129,36 +152,68 @@ setField = VL.set (field' @f)
129152instance
130153 ( Generic s
131154 , ErrorUnless field s (CollectField field (Rep s))
132− , GHasKey' field (Rep s) a
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)
133161 ) => HasField' field s a where
134− field' f s = VL.ravel (repLens . gkey @field) f s
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
135166
136167instance -- see Note [Changing type parameters]
137− ( Generic s
138− , ErrorUnless field s (CollectField field (Rep s))
139− , Generic t
140− -- see Note [CPP in instance constraints]
141−#if __GLASGOW_HASKELL__ < 802
142− , '(s', t') ~ '(Proxied s, Proxied t)
143−#else
144− , s' ~ Proxied s
145− , t' ~ Proxied t
146−#endif
147− , Generic s'
148− , Generic t'
149− , GHasKey' field (Rep s) a
150− , GHasKey' field (Rep s') a'
151− , GHasKey' field (Rep t') b'
152− , GHasKey field (Rep s) (Rep t) a b
153− , t ~ Infer s a' b
154− , s ~ Infer t b' a
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
155175 ) => HasField field s t a b where
156− field f s = VL.ravel (repLens . gkey @field) f s
176+ field f s = field0 @field f s
157177
158−-- -- 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
159188instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where
160189 field = undefined
161190
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+
162217type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Constraint where
163218 ErrorUnless field s ('TypeStat _ _ '[])
164219 = TypeError
@@ -180,3 +235,6 @@ type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Cons
180235
181236 ErrorUnless _ _ ('TypeStat '[] '[] _)
182237 = ()
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.hs+2−7
@@ -15,7 +15,7 @@
1515-----------------------------------------------------------------------------
1616-- |
1717-- Module : Data.Generics.Product.Internal.Constraints
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
@@ -31,13 +31,13 @@ module Data.Generics.Product.Internal.Constraints
3131 (
3232 GHasConstraints (..)
3333 , GHasConstraints' (..)
34− , HList (..)
3534 ) where
3635
3736import Data.Kind (Type, Constraint)
3837import GHC.Generics
3938import Data.Generics.Internal.VL.Iso
4039import Data.Generics.Internal.VL.Traversal
40+import Data.Generics.Product.Internal.HList
4141
4242-- | Constrained traversal.
4343class GHasConstraints' (c :: * -> Constraint) (f :: * -> *) where
@@ -117,11 +117,6 @@ gtypes hl s = gconstraints @(Contains as) (pick hl) s
117117
118118--------------------------------------------------------------------------------
119119
120−data HList (ts :: [Type]) where
121− HNil :: HList '[]
122− (:>) :: a -> HList as -> HList (a ': as)
123−infixr 5 :>
124−
125120-- >>> :kind! Functions '[Int, Char, Bool] Maybe
126121-- '[Int -> Maybe Int, Char -> Maybe Char, Bool -> Maybe Bool]
127122type family Functions (ts :: [Type]) (g :: Type -> Type) = r | r -> ts where
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−60
@@ -1,60 +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 TypeApplications #-}
9−{-# LANGUAGE TypeFamilies #-}
10−{-# LANGUAGE TypeInType #-}
11−{-# LANGUAGE TypeOperators #-}
12−{-# LANGUAGE UndecidableInstances #-}
13−
14−#if __GLASGOW_HASKELL__ == 802
15−{-# OPTIONS_GHC -fno-solve-constant-dicts #-}
16−#endif
17−
18−--------------------------------------------------------------------------------
19−-- |
20−-- Module : Data.Generics.Product.Internal.Keyed
21−-- Copyright : (C) 2018 Csongor Kiss
22−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
23−-- License : BSD3
24−-- Stability : experimental
25−-- Portability : non-portable
26−--
27−--------------------------------------------------------------------------------
28−
29−module Data.Generics.Product.Internal.Keyed
30− ( GHasKey (..)
31− , GHasKey'
32− ) where
33−
34−import Data.Generics.Product.Internal.List
35−import Data.Kind
36−import GHC.Generics
37−import Data.Generics.Internal.Profunctor.Lens
38−import Data.Generics.Internal.Profunctor.Iso
39−
40−class GHasKey (key :: k) (s :: Type -> Type) (t :: Type -> Type) a b | s key -> a, t key -> b where
41− gkey :: Lens (s x) (t x) a b
42−
43−type GHasKey' key s a = GHasKey key s s a a
44−
45−instance (GHasKey key l l' a b, GHasKey key r r' a b) => GHasKey key (l :+: r) (l' :+: r') a b where
46− gkey = sumIso . choosing (gkey @key) (gkey @key)
47− {-# INLINE gkey #-}
48−
49−instance (GHasKey key f g a b) => GHasKey key (M1 D meta f) (M1 D meta g) a b where
50− gkey = ravel (mLens . gkey @key)
51− {-# INLINE gkey #-}
52−
53−instance
54− ( Elem as key i a
55− , Elem bs key i b
56− , IndexList i as bs a b
57− , GIsList k f g as bs
58− ) => GHasKey (key :: k) (M1 C meta f) (M1 C meta g) a b where
59− gkey = mLens . glist @k . point @i
60− {-# INLINE gkey #-}
src/Data/Generics/Product/Internal/List.hsdeleted−335
@@ -1,335 +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− ) where
42−
43−import GHC.TypeLits
44−import Data.Semigroup
45−
46−import Data.Kind (Type)
47−import GHC.Generics
48−import Data.Profunctor
49−import Data.Generics.Internal.Profunctor.Lens
50−import Data.Generics.Internal.Profunctor.Iso
51−
52−data List (as :: [(m, Type)]) where
53− Nil :: List '[]
54− (:>) :: a -> List as -> List ('(s, a) ': as)
55−
56−infixr 5 :>
57−
58−type family ((as :: [k]) ++ (bs :: [k])) :: [k] where
59− '[] ++ bs = bs
60− (a ': as) ++ bs = a ': as ++ bs
61−
62−instance Semigroup (List '[]) where
63− _ <> _ = Nil
64−
65−instance Monoid (List '[]) where
66− mempty = Nil
67− mappend _ _ = Nil
68−
69−instance (Semigroup a, Semigroup (List as)) => Semigroup (List ('(k, a) ': as)) where
70− (x :> xs) <> (y :> ys) = (x <> y) :> (xs <> ys)
71−
72−instance (Monoid a, Monoid (List as)) => Monoid (List ('(k, a) ': as)) where
73− mempty = mempty :> mempty
74− mappend (x :> xs) (y :> ys) = mappend x y :> mappend xs ys
75−
76−class Elem (as :: [(k, Type)]) (key :: k) (i :: Nat) a | as key -> i a
77−instance {-# OVERLAPPING #-} pos ~ 0 => Elem ('(key, a) ': xs) key pos a
78−instance (Elem xs key i a, pos ~ (i + 1)) => Elem (x ': xs) key pos a
79−
80−class GIsList
81− (m :: Type)
82− (f :: Type -> Type)
83− (g :: Type -> Type)
84− (as :: [(m, Type)])
85− (bs :: [(m, Type)]) | m f -> as, m g -> bs, bs f -> g, as g -> f where
86−
87− glist :: Iso (f x) (g x) (List as) (List bs)
88−
89− -- We define this reversed version, otherwise uses of `fromIso glist` are not
90− -- properly inlined by GHC 8.0.2.
91− -- This is not actually used.
92− glistR :: Iso (List bs) (List as) (g x) (f x)
93− glistR = fromIso (glist @m)
94−
95−instance
96− ( GIsList m l l' as as'
97− , GIsList m r r' bs bs'
98− , Appending List as bs cs as' bs' cs'
99− , cs ~ (as ++ bs)
100− , cs' ~ (as' ++ bs')
101− ) => GIsList m (l :*: r) (l' :*: r') cs cs' where
102−
103− glist = prodIso . pairing (glist @m) (glist @m) . appending
104− {-# INLINE glist #-}
105−
106−instance GIsList m f g as bs => GIsList m (M1 t meta f) (M1 t meta g) as bs where
107− glist = mIso . glist @m
108− {-# INLINE glist #-}
109−
110−instance {-# OVERLAPS #-}
111− GIsList Symbol
112− (S1 ('MetaSel ('Just field) u s i) (Rec0 a))
113− (S1 ('MetaSel ('Just field) u s i) (Rec0 b))
114− '[ '(field, a)] '[ '(field, b)] where
115− glist = mIso . kIso . singleton
116− {-# INLINE glist #-}
117−
118−instance GIsList Type (Rec0 a) (Rec0 a) '[ '(a, a)] '[ '(a, a)] where
119− glist = kIso . singleton
120− {-# INLINE glist #-}
121−
122−instance GIsList () (Rec0 a) (Rec0 b) '[ '( '(), a)] '[ '( '(), b)] where
123− glist = kIso . singleton
124− {-# INLINE glist #-}
125−
126−instance GIsList m U1 U1 '[] '[] where
127− glist = iso (const Nil) (const U1)
128− {-# INLINE glist #-}
129−
130−--------------------------------------------------------------------------------
131−-- | as ++ bs === cs
132−class Appending f (as :: [k]) bs cs (as' :: [k]) bs' cs' | as bs cs cs' -> as' bs', as' bs' cs cs' -> as bs, as bs -> cs, as' bs' -> cs' where
133− appending :: Iso (f as, f bs) (f as', f bs') (f cs) (f cs')
134−
135−-- | [] ++ bs === bs
136−instance Appending List '[] bs bs '[] bs' bs' where
137− appending = iso (\(_, b) -> b) (Nil,)
138−
139−-- | (a : as) ++ bs === (a : cs)
140−instance
141− Appending List as bs cs as' bs' cs' -- as ++ bs == cs
142− => Appending List ('(f, a) ': as) bs ('(f, a) ': cs) ('(f, a') ': as') bs' ('(f, a') ': cs') where
143− appending
144− = pairing (fromIso consing) id -- ((a, as), bs)
145− . assoc3 -- (a, (as, bs))
146− . pairing id appending -- (a, cs)
147− . consing -- (a : cs)
148−
149−singleton :: Iso a b (List '[ '(field, a)]) (List '[ '(field, b)])
150−singleton = iso (:> Nil) (\(x :> _) -> x)
151−
152−consing :: Iso (a, List as) (b, List bs) (List ('(f, a) ': as)) (List ('(f, b) ': bs))
153−consing = iso (\(x, xs) -> x :> xs) (\(x :> xs) -> (x, xs))
154−
155−--------------------------------------------------------------------------------
156−class IndexList (i :: Nat) as bs a b | i as -> a, i bs -> b, i as b -> bs, i bs a -> as where
157− point :: Lens (List as) (List bs) a b
158−
159−instance {-# OVERLAPPING #-}
160− ( as ~ ('(f, a) ': as')
161− , bs ~ ('(f, b) ': as')
162− ) => IndexList 0 as bs a b where
163− point = lens (\(x :> xs) -> (xs, x)) (\(xs, x') -> x' :> xs)
164− {-# INLINE point #-}
165−
166−instance
167− ( IndexList (n - 1) as' bs' a b
168− , as ~ ('(f, x) ': as')
169− , bs ~ ('(f, x) ': bs')
170− ) => IndexList n as bs a b where
171− point = fromIso consing . alongside id (point @(n-1)) . second'
172− {-# INLINE point #-}
173−
174−--------------------------------------------------------------------------------
175−-- * Convert tuples to/from HLists
176−
177−class ListTuple (tuple :: Type) (as :: [(k, Type)]) | as -> tuple where
178− type ListToTuple as :: Type
179− tupled :: Iso' (List as) tuple
180− tupled = iso listToTuple tupleToList
181−
182− tupleToList :: tuple -> List as
183− listToTuple :: List as -> tuple
184−
185−instance ListTuple () '[] where
186− type ListToTuple '[] = ()
187− tupleToList _ = Nil
188− listToTuple _ = ()
189−
190−instance ListTuple a '[ '(fa, a)] where
191− type ListToTuple '[ '(fa, a)] = a
192− tupleToList a
193− = a :> Nil
194− listToTuple (a :> Nil)
195− = a
196−
197−instance ListTuple (a, b) '[ '(fa, a), '(fb, b)] where
198− type ListToTuple '[ '(fa, a), '(fb, b)] = (a, b)
199− tupleToList (a, b)
200− = a :> b :> Nil
201− listToTuple (a :> b :> Nil)
202− = (a, b)
203−
204−instance ListTuple (a, b, c) '[ '(fa, a), '(fb, b), '(fc, c)] where
205− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c)] = (a, b, c)
206− tupleToList (a, b, c)
207− = a :> b :> c :> Nil
208− listToTuple (a :> b :> c :> Nil)
209− = (a, b, c)
210−
211−instance ListTuple (a, b, c, d) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d)] where
212− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d)] = (a, b, c, d)
213− tupleToList (a, b, c, d)
214− = a :> b :> c :> d:> Nil
215− listToTuple (a :> b :> c :> d :> Nil)
216− = (a, b, c, d)
217−
218−instance ListTuple (a, b, c, d, e) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e)] where
219− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e)] = (a, b, c, d, e)
220− tupleToList (a, b, c, d, e)
221− = a :> b :> c :> d:> e :> Nil
222− listToTuple (a :> b :> c :> d :> e :> Nil)
223− = (a, b, c, d, e)
224−
225−instance ListTuple (a, b, c, d, e, f) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f)] where
226− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f)] = (a, b, c, d, e, f)
227− tupleToList (a, b, c, d, e, f)
228− = a :> b :> c :> d:> e :> f :> Nil
229− listToTuple (a :> b :> c :> d :> e :> f :> Nil)
230− = (a, b, c, d, e, f)
231−
232−instance ListTuple (a, b, c, d, e, f, g) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g)] where
233− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g)] = (a, b, c, d, e, f, g)
234− tupleToList (a, b, c, d, e, f, g)
235− = a :> b :> c :> d:> e :> f :> g :> Nil
236− listToTuple (a :> b :> c :> d :> e :> f :> g :> Nil)
237− = (a, b, c, d, e, f, g)
238−
239−instance ListTuple (a, b, c, d, e, f, g, h) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h)] where
240− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h)] = (a, b, c, d, e, f, g, h)
241− tupleToList (a, b, c, d, e, f, g, h)
242− = a :> b :> c :> d:> e :> f :> g :> h :> Nil
243− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> Nil)
244− = (a, b, c, d, e, f, g, h)
245−
246−instance ListTuple (a, b, c, d, e, f, g, h, j) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j)] where
247− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j)] = (a, b, c, d, e, f, g, h, j)
248− tupleToList (a, b, c, d, e, f, g, h, j)
249− = a :> b :> c :> d:> e :> f :> g :> h :> j :> Nil
250− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> Nil)
251− = (a, b, c, d, e, f, g, h, j)
252−
253−instance ListTuple (a, b, c, d, e, f, g, h, j, k) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k)] where
254− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k)] = (a, b, c, d, e, f, g, h, j, k)
255− tupleToList (a, b, c, d, e, f, g, h, j, k)
256− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> Nil
257− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> Nil)
258− = (a, b, c, d, e, f, g, h, j, k)
259−
260−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l)] where
261− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l)] = (a, b, c, d, e, f, g, h, j, k, l)
262− tupleToList (a, b, c, d, e, f, g, h, j, k, l)
263− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> Nil
264− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> Nil)
265− = (a, b, c, d, e, f, g, h, j, k, l)
266−
267−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m)] where
268− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m)] = (a, b, c, d, e, f, g, h, j, k, l, m)
269− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m)
270− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> Nil
271− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> Nil)
272− = (a, b, c, d, e, f, g, h, j, k, l, m)
273−
274−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n)] where
275− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n)] = (a, b, c, d, e, f, g, h, j, k, l, m, n)
276− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n)
277− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil
278− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil)
279− = (a, b, c, d, e, f, g, h, j, k, l, m, n)
280−
281−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o)] where
282− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
283− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
284− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil
285− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil)
286− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
287−
288−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p)] where
289− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
290− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
291− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil
292− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil)
293− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
294−
295−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q)] where
296− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
297− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
298− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil
299− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil)
300− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
301−
302−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r)] where
303− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
304− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
305− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil
306− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil)
307− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
308−
309−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r), '(fs, s)] where
310− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r), '(fs, s)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
311− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
312− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil
313− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil)
314− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
315−
316−type family TupleToList a where
317− TupleToList () = '[]
318− TupleToList (a, b) = '[ '( '(), a), '( '(), b)]
319− TupleToList (a, b, c) = '[ '( '(), a), '( '(), b), '( '(), c)]
320− TupleToList (a, b, c, d) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d)]
321− TupleToList (a, b, c, d, e) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e)]
322− TupleToList (a, b, c, d, e, f) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f)]
323− TupleToList (a, b, c, d, e, f, g) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g)]
324− TupleToList (a, b, c, d, e, f, g, h) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h)]
325− TupleToList (a, b, c, d, e, f, g, h, j) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j)]
326− TupleToList (a, b, c, d, e, f, g, h, j, k) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k)]
327− TupleToList (a, b, c, d, e, f, g, h, j, k, l) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l)]
328− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m)]
329− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n)]
330− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o)]
331− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o), '( '(), p)]
332− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o), '( '(), p), '( '(), q)]
333− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o), '( '(), p), '( '(), q), '( '(), r)]
334− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o), '( '(), p), '( '(), q), '( '(), r), '( '(), s)]
335− TupleToList a = '[ '( '(), a)]
src/Data/Generics/Product/Internal/Positions.hs+46−27
@@ -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,41 +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.Product.Internal.List
36+import Data.Generics.Internal.Families.Has (Pos)
3737import Data.Kind (Type)
3838import Data.Type.Bool (If, Not)
3939import GHC.Generics
40−import GHC.TypeLits (type (<=?), type (+), type (-), Nat)
41−import Data.Generics.Internal.Profunctor.Lens
42−import Data.Generics.Internal.Profunctor.Iso
40+import GHC.TypeLits (type (<=?), type (+), Nat)
4341
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
42+-- | Alias for the kind of the generic rep
43+type G = Type -> Type
4844
49−type GHasPosition' i s a = GHasPosition i s s a a
45+--------------------------------------------------------------------------------
5046
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 = \x -> sumIso (choosing (gposition @i) (gposition @i) x)
53− {-# INLINE gposition #-}
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)
5455
55−instance GHasPosition i s t a b => GHasPosition i (M1 D meta s) (M1 D meta t) a b where
56− gposition x = mLens (gposition @i x)
57− {-# INLINE gposition #-}
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)
5872
59−instance
60− ( IndexList (i - 1) as bs a b
61− , GIsList () f g as bs
62− ) => GHasPosition i (M1 C meta f) (M1 C meta g) a b where
63− gposition x = mIso (glist @() (point @(i - 1) x))
64− {-# INLINE gposition #-}
73+type family Traverse1 (w :: G -> G) (z :: (G, Nat)) :: (G, Nat) where
74+ Traverse1 w '(i, n) = '(w i, n)
75+
76+-- | For products, we first traverse the left-hand side, followed by the second
77+-- using the counter returned by the left traversal.
78+type family TraverseProd (c :: G -> G -> G) (a :: (G, Nat)) (r :: G) :: (G, Nat) where
79+ TraverseProd w '(i, n) r = Traverse1 (w i) (Traverse r n)
80+
81+--------------------------------------------------------------------------------
82+-- Utilities
83+
84+type family Fst (p :: (a, b)) :: a where
85+ Fst '(a, b) = a
6586
6687type family Size f :: Nat where
6788 Size (l :*: r)
@@ -75,8 +96,6 @@ type family Size f :: Nat where
7596 Size f
7697 = 1
7798
78−--------------------------------------------------------------------------------
79−
8099type x <? y = Not (y <=? x)
81100infixl 4 <?
82101
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.Product.Internal.Keyed
35+import Data.Generics.Product.Internal.GLens
3536
3637import Data.Kind (Type)
3738import GHC.Generics
38−import Data.Generics.Internal.Profunctor.Lens
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/List.hsdeleted−78
@@ -1,78 +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.Product.Internal.List
31−import Data.Kind
32−import GHC.Generics
33−import GHC.TypeLits
34−import Data.Generics.Internal.Profunctor.Iso
35−
36−class IsList
37− (m :: Type)
38− (f :: Type)
39− (g :: Type)
40− (as :: [(m, Type)])
41− (bs :: [(m, Type)]) | m f -> as, m g -> bs where
42− list :: Iso f g (List as) (List bs)
43−
44−instance
45− ( Generic f
46− , Generic g
47− , GIsList m (Rep f) (Rep g) as bs
48− ) => IsList m f g as bs where
49− list = repIso . glist @m
50− {-# INLINE list #-}
51−
52−class IsList Symbol f g as bs => IsRecord f g (as :: [(Symbol, Type)]) (bs :: [(Symbol, Type)]) | f -> as, g -> bs
53−instance IsList Symbol f g as bs => IsRecord f g as bs
54−
55−class IsRecord f f as as => IsRecord' f (as :: [(Symbol, Type)]) | f -> as
56−instance IsRecord f f as as => IsRecord' f as
57−
58−-- example (TODO: move elsewhere)
59−--class PrintRecord (rl :: [(Symbol, Type)]) where
60−-- printRecord' :: List rl -> String
61−--
62−--instance PrintRecord '[] where
63−-- printRecord' _ = ""
64−--
65−--instance (KnownSymbol field, Show a, PrintRecord xs) => PrintRecord ('(field, a) ': xs) where
66−-- printRecord' (x :> xs) = show x ++ ", " ++ printRecord' xs
67−--
68−--printRecord :: (IsRecord' rec rl, PrintRecord rl) => rec -> String
69−--printRecord rec = printRecord' (rec ^. list)
70−--
71−--data MyRecord = MyRecord
72−-- { field1 :: Int
73−-- , field2 :: String
74−-- , field3 :: Bool
75−-- } deriving Generic
76−--
77−-- >>> printRecord (MyRecord 10 "hello" False)
78−-- "10, \"hello\", False, "
src/Data/Generics/Product/Param.hs+10−3
@@ -15,13 +15,13 @@
1515--------------------------------------------------------------------------------
1616-- |
1717-- Module : Data.Generics.Product.Param
18−-- Copyright : (C) 2018 Csongor Kiss
19−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
18+-- Copyright : (C) 2019 Csongor Kiss
2019-- License : BSD3
20+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
2121-- Stability : experimental
2222-- Portability : non-portable
2323--
24−-- Derive traversal over type parameters
24+-- Derive traversals over type parameters
2525--
2626--------------------------------------------------------------------------------
2727
@@ -39,6 +39,7 @@ import GHC.Generics
3939import Data.Kind
4040import Data.Generics.Internal.VL.Iso
4141import Data.Generics.Internal.GenericN
42+import Data.Generics.Internal.Errors
4243
4344class HasParam (p :: Nat) s t a b | p t a -> s, p s b -> t, p s -> a, p t -> b where
4445 param :: Applicative g => (a -> g b) -> s -> g t
@@ -47,6 +48,12 @@ instance
4748 ( GenericN s
4849 , GenericN t
4950 -- 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)
5057 , s ~ Infer t (P n b 'PTag) a
5158 , t ~ Infer s (P n a 'PTag) b
5259 , Error ((ArgCount s) <=? n) n (ArgCount s) s
src/Data/Generics/Product/Positions.hs+109−24
@@ -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
@@ -33,6 +35,8 @@ module Data.Generics.Product.Positions
3335 -- $setup
3436 HasPosition (..)
3537 , HasPosition' (..)
38+ , HasPosition_ (..)
39+ , HasPosition0 (..)
3640
3741 , getPosition
3842 , setPosition
@@ -42,12 +46,15 @@ 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(..))
50−import Data.Generics.Internal.Profunctor.Lens
56+import Data.Generics.Internal.Profunctor.Lens as P
57+import Data.Coerce
5158
5259-- $setup
5360-- == /Running example:/
@@ -89,51 +96,126 @@ class HasPosition (i :: Nat) s t a b | s i -> a, t i -> b, s i b -> t, t i a ->
8996 -- ...
9097 position :: VL.Lens s t a b
9198
99+class HasPosition_ (i :: Nat) s t a b where
100+ position_ :: VL.Lens s t a b
101+
102+-- |Records that have a field at a given position.
103+--
104+-- The difference between 'HasPosition' and 'HasPosition_' is similar to the
105+-- one between 'Data.Generics.Product.Fields.HasField' and
106+-- 'Data.Generics.Product.Fields.HasField_'.
107+-- See 'Data.Generics.Product.Fields.HasField_'.
92108class HasPosition' (i :: Nat) s a | s i -> a where
93109 position' :: VL.Lens s s a a
94110
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
95121getPosition :: forall i s a. HasPosition' i s a => s -> a
96122getPosition s = s ^. position' @i
97123
124+-- |
125+-- >>> setPosition @2 60 human
126+-- Human {name = "Tunyasz", age = 60, address = "London"}
98127setPosition :: forall i s a. HasPosition' i s a => a -> s -> s
99128setPosition = VL.set (position' @i)
100129
101130instance
102131 ( Generic s
103132 , ErrorUnless i s (0 <? i && i <=? Size (Rep s))
104− , GHasPosition' i (Rep s) a
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)
105142 ) => HasPosition' i s a where
106− position' f s = VL.ravel (repLens . gposition @i) f s
143+ position' f s = VL.ravel (repLens . coerced @cs @cs . glens @(HasTotalPositionPSym i)) f s
107144 {-# INLINE position' #-}
108145
146+-- this is to 'hide' the equality constraints which interfere with inlining
147+-- pre 8.4.3
148+class (~~) (a :: k) (b :: k) | a -> b, b -> a
149+instance (a ~ b) => (~~) a b
150+
109151instance -- see Note [Changing type parameters]
110− ( Generic s
111− , ErrorUnless i s (0 <? i && i <=? Size (Rep s))
112− , Generic t
113− -- see Note [CPP in instance constraints]
114−#if __GLASGOW_HASKELL__ < 802
115− , '(s', t') ~ '(Proxied s, Proxied t)
116−#else
117− , s' ~ Proxied s
118− , t' ~ Proxied t
119−#endif
120− , Generic s'
121− , Generic t'
122− , GHasPosition' i (Rep s) a
123− , GHasPosition' i (Rep s') a'
124− , GHasPosition i (Rep s) (Rep t) a b
125− , t ~ Infer s a' b
126− , GHasPosition' i (Rep t') b'
127− , s ~ Infer t b' a
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
128162 ) => HasPosition i s t a b where
129163
130− position = VL.ravel (repLens . gposition @i)
164+ position = position0 @i
131165 {-# INLINE position #-}
132166
133−-- See Note [Uncluttering type signatures]
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
134185instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where
135186 position = undefined
136187
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+
137219type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint where
138220 ErrorUnless i s 'False
139221 = TypeError
@@ -145,3 +227,6 @@ type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint wher
145227
146228 ErrorUnless _ _ 'True
147229 = ()
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+43−3
@@ -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
@@ -41,6 +42,7 @@ import GHC.Generics (Generic (Rep, to, from) )
4142import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
4243import Data.Kind (Type, Constraint)
4344import Data.Generics.Internal.Profunctor.Lens hiding (set)
45+import Data.Generics.Internal.Errors
4446
4547-- $setup
4648-- == /Running example:/
@@ -113,14 +115,52 @@ instance
113115 , Generic b
114116 , GSmash (Rep a) (Rep b)
115117 , GUpcast (Rep a) (Rep b)
116− , ErrorUnless b a (CollectFieldsOrdered (Rep b) \\ CollectFieldsOrdered (Rep a))
118+ , CustomError a b
117119 ) => Subtype b a where
118120 smash p b = to $ gsmash (from p) (from b)
119121 upcast = to . gupcast . from
120122
121−-- 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
122151instance {-# OVERLAPPING #-} Subtype a Void where
123152 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
124164instance {-# OVERLAPPING #-} Subtype Void a where
125165 super = undefined
126166
src/Data/Generics/Product/Typed.hs+31−5
@@ -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
@@ -33,12 +35,13 @@ module Data.Generics.Product.Typed
3335import Data.Generics.Internal.Families
3436import 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 (..))
4143import Data.Generics.Internal.Profunctor.Lens
44+import Data.Generics.Internal.Errors
4245
4346-- $setup
4447-- == /Running example:/
@@ -110,12 +113,31 @@ class HasType a s where
110113instance
111114 ( Generic s
112115 , ErrorUnlessOne a s (CollectTotalType a (Rep s))
113− , 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
114120 ) => HasType a s where
115121
116− typed f s = VL.ravel (repLens . gkey @a) f s
122+ typed f s = VL.ravel (repLens . glens @(HasTotalTypePSym a)) f s
117123
118−-- 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.
119141instance {-# OVERLAPPING #-} HasType a Void where
120142 typed = undefined
121143
@@ -150,3 +172,7 @@ type family ErrorUnlessOne (a :: Type) (s :: Type) (stat :: TypeStat) :: Constra
150172
151173 ErrorUnlessOne _ _ ('TypeStat '[] '[] _)
152174 = ()
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+272−68
@@ -16,7 +16,7 @@
1616-----------------------------------------------------------------------------
1717-- |
1818-- Module : Data.Generics.Product.Types
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
@@ -29,18 +29,65 @@
2929module Data.Generics.Product.Types
3030 ( -- *Traversals
3131 --
32− -- $example
32+ -- $setup
3333 HasTypes
3434 , types
35+
36+ -- * Custom traversal strategies
37+ -- $custom
38+ , Children
39+ , ChGeneric
40+
41+ , HasTypesUsing
42+ , typesUsing
43+
44+ , HasTypesCustom (typesCustom)
45+
3546 ) where
3647
3748import 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
3852
3953import GHC.Generics
54+import GHC.TypeLits
4055import 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+--------------------------------------------------------------------------------
4178
4279-- TODO [1.0.0.0]: use type-changing variant internally
4380
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.
4491types :: forall a s. HasTypes s a => Traversal' s a
4592types = types_ @s @a
4693{-# INLINE types #-}
@@ -53,111 +100,268 @@ class HasTypes s a where
53100 {-# INLINE types_ #-}
54101
55102instance
56− ( HasTypes' (Interesting s a) s a
103+ ( HasTypesUsing ChGeneric s a
57104 ) => HasTypes s a where
58− types_ = types' @(Interesting s a)
105+ types_ = typesUsing_ @ChGeneric
59106 {-# INLINE types_ #-}
60107
61−class HasTypes' (t :: Bool) s a where
62− types' :: Traversal' s a
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
63118
64−instance
65− ( GHasTypes (Rep s) a
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
66211 , Generic s
67− ) => HasTypes' 'True s a where
68− types' f s = to <$> gtypes_ f (from 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)
69221 --{-# INLINE types' #-}
70222
71−instance HasTypes' 'False s a where
72− types' _ = pure
73− --{-# INLINE types' #-}
74223
75−instance {-# OVERLAPPING #-} HasTypes Bool a
76−instance {-# OVERLAPPING #-} HasTypes Char a
77−instance {-# OVERLAPPING #-} HasTypes Double a
78−instance {-# OVERLAPPING #-} HasTypes Float a
79−instance {-# OVERLAPPING #-} HasTypes Int a
80−instance {-# OVERLAPPING #-} HasTypes Integer a
81−instance {-# OVERLAPPING #-} HasTypes Ordering a
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 #-}
82275
83276--------------------------------------------------------------------------------
84277
85−class GHasTypes s a where
278+class GHasTypes ch s a where
86279 gtypes_ :: Traversal' (s x) a
87280
88281instance
89− ( GHasTypes l a
90− , GHasTypes r a
91− ) => GHasTypes (l :*: r) a where
92− gtypes_ f (l :*: r) = (:*:) <$> gtypes_ f l <*> gtypes_ f r
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
93286 {-# INLINE gtypes_ #-}
94287
95288instance
96− ( GHasTypes l a
97− , GHasTypes r a
98− ) => GHasTypes (l :+: r) a where
99− gtypes_ f (L1 l) = L1 <$> gtypes_ f l
100− gtypes_ f (R1 r) = R1 <$> gtypes_ f r
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
101294 {-# INLINE gtypes_ #-}
102295
103−instance (GHasTypes s a) => GHasTypes (M1 m meta s) a where
104− gtypes_ f (M1 s) = M1 <$> gtypes_ f s
296+instance (GHasTypes ch s a) => GHasTypes ch (M1 m meta s) a where
297+ gtypes_ f (M1 s) = M1 <$> gtypes_ @ch f s
105298 {-# INLINE gtypes_ #-}
106299
107−instance {-# OVERLAPPING #-} GHasTypes (Rec0 a) a where
108− gtypes_ f (K1 x) = K1 <$> f x
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
109304 {-# INLINE gtypes_ #-}
110305
111−instance HasTypes b a => GHasTypes (Rec0 b) a where
112− gtypes_ f (K1 x) = K1 <$> types_ @_ @a f x
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
113314 {-# INLINE gtypes_ #-}
114315
115−instance GHasTypes U1 a where
316+instance GHasTypes ch U1 a where
116317 gtypes_ _ _ = pure U1
117318 {-# INLINE gtypes_ #-}
118319
119−instance GHasTypes V1 a where
320+instance GHasTypes ch V1 a where
120321 gtypes_ _ = pure
121322 {-# INLINE gtypes_ #-}
122323
123−type Interesting f a = Snd (Interesting' (Rep f) a '[f])
124−
125−type family Interesting' f (a :: Type) (seen :: [Type]) :: ([Type], Bool) where
126− Interesting' (M1 _ m f) t seen
127− = Interesting' f t seen
128− -- The result of the left branch is passed on to the right branch in order to avoid duplicate work
129− Interesting' (l :*: r) t seen
130− = InterestingOr (Interesting' l t seen) r t
131− Interesting' (l :+: r) t seen
132− = InterestingOr (Interesting' l t seen) r t
133− Interesting' (Rec0 t) t seen
134− = '(seen, 'True)
135− Interesting' (Rec0 Char) _ seen = '(seen ,'False)
136− Interesting' (Rec0 Double) _ seen = '(seen ,'False)
137− Interesting' (Rec0 Float) _ seen = '(seen ,'False)
138− Interesting' (Rec0 Int) _ seen = '(seen ,'False)
139− Interesting' (Rec0 Integer) _ seen = '(seen ,'False)
140− Interesting' (Rec0 r) t seen
141− = InterestingUnless (Elem r seen) (Rep r) t r seen
142− Interesting' _ _ seen
143− = '(seen, 'False)
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
144340
145341-- Short circuit
146−-- Note: we only insert 'r' to the seen list if it's not already there (which is precisely when `s` is 'False)
147−type family InterestingUnless (s :: Bool) f (a :: Type) (r :: Type) (seen :: [Type]) :: ([Type], Bool) where
148− InterestingUnless 'True _ _ _ seen = '(seen, 'False)
149− InterestingUnless 'False f a r seen = Interesting' f a (r ': seen)
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))
150351
151352-- Short circuit
152−type family InterestingOr (b :: ([Type], Bool)) r t :: ([Type], Bool) where
153− InterestingOr '(seen, 'True) _ _ = '(seen, 'True)
154− InterestingOr '(seen, 'False) r t = Interesting' r t seen
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
155358
156359type family Elem a as where
157360 Elem a (a ': _) = 'True
158361 Elem a (_ ': as) = Elem a as
159362 Elem a '[] = 'False
160363
161−type family Snd a where
162− Snd '(_, b) = b
364+type family IsNothing a where
365+ IsNothing ('Just _) = 'False
366+ IsNothing 'Nothing = 'True
163367
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+2−2
@@ -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
@@ -61,7 +61,7 @@ import Data.Generics.Internal.VL.Prism
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.
src/Data/Generics/Sum/Constructors.hs+76−19
@@ -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,7 +30,9 @@ module Data.Generics.Sum.Constructors
3030
3131 -- $setup
3232 AsConstructor (..)
33+ , AsConstructor_ (..)
3334 , AsConstructor' (..)
35+ , AsConstructor0 (..)
3436 ) where
3537
3638import Data.Generics.Internal.Families
@@ -43,6 +45,7 @@ import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
4345import Data.Generics.Internal.VL.Prism
4446import Data.Generics.Internal.Profunctor.Iso
4547import Data.Generics.Internal.Profunctor.Prism (prismPRavel)
48+import Data.Generics.Internal.Errors
4649
4750-- $setup
4851-- == /Running example:/
@@ -68,7 +71,7 @@ import Data.Generics.Internal.Profunctor.Prism (prismPRavel)
6871-- , age :: Age
6972-- , fieldA :: a
7073-- }
71−-- deriving (Generic, Show)
74+-- deriving Show
7275-- type Name = String
7376-- type Age = Int
7477-- dog, cat, duck :: Animal Int
@@ -103,45 +106,99 @@ class AsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where
103106 -- ...
104107 _Ctor :: Prism s t a b
105108
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+
106118class AsConstructor' (ctor :: Symbol) s a | ctor s -> a where
107119 _Ctor' :: Prism s s a a
108120
121+-- |Sums that have a constructor with a given name.
122+--
123+-- This class gives the minimal constraints needed to define this prism.
124+-- For common uses, see 'HasConstructor'.
125+class AsConstructor0 (ctor :: Symbol) s t a b where
126+ _Ctor0 :: Prism s t a b
127+
109128instance
110129 ( Generic s
111130 , ErrorUnless ctor s (HasCtorP ctor (Rep s))
112131 , 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)
113137 ) => AsConstructor' ctor s a where
114138 _Ctor' eta = prismRavel (prismPRavel (repIso . _GCtor @ctor)) eta
115139 {-# INLINE[2] _Ctor' #-}
116140
117141instance
118− ( Generic s
119− , ErrorUnless ctor s (HasCtorP ctor (Rep s))
120− , Generic t
121− -- see Note [CPP in instance constraints]
122−#if __GLASGOW_HASKELL__ < 802
123− , '(s', t') ~ '(Proxied s, Proxied t)
124−#else
125− , s' ~ Proxied s
126− , t' ~ Proxied t
127−#endif
128− , Generic s'
129− , Generic t'
130− , GAsConstructor' ctor (Rep s) a
131− , GAsConstructor' ctor (Rep s') a'
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'
132145 , GAsConstructor ctor (Rep s) (Rep t) a b
133146 , t ~ Infer s a' b
134− , GAsConstructor' ctor (Rep t') b'
147+ , GAsConstructor' ctor (Rep (Indexed t)) b'
135148 , s ~ Infer t b' a
149+ , AsConstructor0 ctor s t a b
136150 ) => AsConstructor ctor s t a b where
137151
138− _Ctor eta = prismRavel (prismPRavel (repIso . _GCtor @ctor)) eta
152+ _Ctor = _Ctor0 @ctor
139153 {-# INLINE[2] _Ctor #-}
140154
141−-- 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
142169instance {-# OVERLAPPING #-} AsConstructor ctor (Void1 a) (Void1 b) a b where
143170 _Ctor = undefined
144171
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+
145202type family ErrorUnless (ctor :: Symbol) (s :: Type) (contains :: Bool) :: Constraint where
146203 ErrorUnless ctor s 'False
147204 = TypeError
src/Data/Generics/Sum/Internal/Constructors.hs+6−7
@@ -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,11 +30,11 @@ module Data.Generics.Sum.Internal.Constructors
3030 ) where
3131
3232import Data.Generics.Internal.Families
33−import Data.Generics.Product.Internal.List
33+import Data.Generics.Product.Internal.HList
34+import Data.Profunctor (Profunctor(..))
3435
3536import GHC.Generics
3637import GHC.TypeLits (Symbol)
37−import Data.Kind
3838import Data.Generics.Internal.Profunctor.Lens
3939import Data.Generics.Internal.Profunctor.Iso
4040import Data.Generics.Internal.Profunctor.Prism
@@ -47,16 +47,15 @@ class GAsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where
4747type GAsConstructor' ctor s a = GAsConstructor ctor s s a a
4848
4949instance
50− ( GIsList Type f f as as
51− , GIsList Type g g bs bs
50+ ( GIsList f f as as
51+ , GIsList g g bs bs
5252 , ListTuple a as
5353 , ListTuple b bs
5454 ) => GAsConstructor ctor (M1 C ('MetaCons ctor fixity fields) f) (M1 C ('MetaCons ctor fixity fields) g) a b where
5555
56− _GCtor = prism (M1 . view (fromIso (glist @Type)) . tupleToList) (Right . listToTuple . view (glist @Type) . unM1)
56+ _GCtor = dimap (listToTuple . view glist . unM1) (M1 . view (fromIso glist) . tupleToList)
5757 {-# INLINE[0] _GCtor #-}
5858
59−
6059instance GSumAsConstructor ctor (HasCtorP ctor l) l r l' r' a b => GAsConstructor ctor (l :+: r) (l' :+: r') a b where
6160 _GCtor = _GSumCtor @ctor @(HasCtorP ctor l)
6261 {-# INLINE[0] _GCtor #-}
src/Data/Generics/Sum/Internal/Subtype.hs+8−8
@@ -14,7 +14,7 @@
1414-----------------------------------------------------------------------------
1515-- |
1616-- Module : Data.Generics.Sum.Internal.Subtype
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
@@ -28,7 +28,7 @@ module Data.Generics.Sum.Internal.Subtype
2828 ( GAsSubtype (..)
2929 ) where
3030
31−import Data.Generics.Product.Internal.List
31+import Data.Generics.Product.Internal.HList
3232import Data.Generics.Sum.Internal.Typed
3333
3434import Data.Kind
@@ -46,7 +46,7 @@ instance
4646 ( GSplash sub sup
4747 , GDowncast sub sup
4848 ) => GAsSubtype sub sup where
49− _GSub f = (prism _GSplash _GDowncast) f
49+ _GSub f = prism _GSplash _GDowncast f
5050 {-# INLINE[0] _GSub #-}
5151
5252--------------------------------------------------------------------------------
@@ -60,10 +60,10 @@ instance (GSplash a sup, GSplash b sup) => GSplash (a :+: b) sup where
6060 {-# INLINE[0] _GSplash #-}
6161
6262instance
63− ( GIsList () subf subf as as
63+ ( GIsList subf subf as as
6464 , GAsType supf as
6565 ) => GSplash (C1 meta subf) supf where
66− _GSplash p = build ((_GTyped . fromIso (glist @()) . fromIso mIso)) p
66+ _GSplash p = build (_GTyped . fromIso (mIso . glist)) p
6767 {-# INLINE[0] _GSplash #-}
6868
6969instance GSplash sub sup => GSplash (D1 c sub) sup where
@@ -76,7 +76,7 @@ class GDowncast sub sup where
7676 _GDowncast :: sup x -> Either (sup x) (sub x)
7777
7878instance
79− ( GIsList () sup sup as as
79+ ( GIsList sup sup as as
8080 , GDowncastC (HasPartialTypeP as sub) sub sup
8181 ) => GDowncast sub (C1 m sup) where
8282 _GDowncast (M1 m) = case _GDowncastC @(HasPartialTypeP as sub) m of
@@ -108,8 +108,8 @@ instance GDowncastC 'False sub sup where
108108
109109instance
110110 ( GAsType sub subl
111− , GIsList () sup sup subl subl
111+ , GIsList sup sup subl subl
112112 ) => GDowncastC 'True sub sup where
113− _GDowncastC sup = Right (build (_GTyped . fromIso (glist @())) sup)
113+ _GDowncastC sup = Right (build (_GTyped . fromIso glist) sup)
114114 {-# INLINE[0] _GDowncastC #-}
115115
src/Data/Generics/Sum/Internal/Typed.hs+8−8
@@ -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
@@ -32,13 +32,13 @@ import GHC.Generics
3232import Data.Tagged
3333
3434import Data.Generics.Internal.Families
35−import Data.Generics.Product.Internal.List
35+import Data.Generics.Product.Internal.HList
3636import Data.Generics.Internal.Profunctor.Iso
3737import Data.Generics.Internal.Profunctor.Prism
3838
3939-- |As 'AsType' but over generic representations as defined by "GHC.Generics".
40−class GAsType (f :: Type -> Type) (as :: [((), Type)]) where
41− _GTyped :: Prism (f x) (f x) (List as) (List as)
40+class GAsType (f :: Type -> Type) (as :: [Type]) where
41+ _GTyped :: Prism (f x) (f x) (HList as) (HList as)
4242-- We create this specialised version as we use it in the subtype prism
4343-- If we don't create it, the opportunity for specialisation is only
4444-- created after specialisation happens, I think a late specialisation pass
@@ -47,9 +47,9 @@ class GAsType (f :: Type -> Type) (as :: [((), Type)]) where
4747
4848
4949instance
50− ( GIsList () f f as as
50+ ( GIsList f f as as
5151 ) => GAsType (M1 C meta f) as where
52− _GTyped = mIso . glist @()
52+ _GTyped = mIso . glist
5353 {-# INLINE[0] _GTyped #-}
5454
5555instance GSumAsType (HasPartialTypeP a l) l r a => GAsType (l :+: r) a where
@@ -60,8 +60,8 @@ instance GAsType f a => GAsType (M1 D meta f) a where
6060 _GTyped = mIso . _GTyped
6161 {-# INLINE[0] _GTyped #-}
6262
63−class GSumAsType (contains :: Bool) l r (a :: [((), Type)]) where
64− _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)
6565
6666instance GAsType l a => GSumAsType 'True l r a where
6767 _GSumTyped = left . _GTyped
src/Data/Generics/Sum/Subtype.hs+38−2
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE FlexibleContexts #-}
23{-# LANGUAGE FlexibleInstances #-}
34{-# LANGUAGE MonoLocalBinds #-}
@@ -11,7 +12,7 @@
1112-----------------------------------------------------------------------------
1213-- |
1314-- Module : Data.Generics.Sum.Subtype
14−-- Copyright : (C) 2017 Csongor Kiss
15+-- Copyright : (C) 2019 Csongor Kiss
1516-- License : BSD3
1617-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
1718-- Stability : experimental
@@ -113,10 +114,45 @@ instance
113114 _Sub f = prismRavel (repIso . _GSub . fromIso repIso) f
114115 {-# INLINE[2] _Sub #-}
115116
116−-- 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
117138instance {-# OVERLAPPING #-} AsSubtype a Void where
118139 injectSub = undefined
119140 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
120156instance {-# OVERLAPPING #-} AsSubtype Void a where
121157 injectSub = undefined
122158 projectSub = undefined
src/Data/Generics/Sum/Typed.hs+34−3
@@ -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,10 +35,11 @@ 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
3941import Data.Generics.Internal.Void
40−import Data.Generics.Product.Internal.List
42+import Data.Generics.Product.Internal.HList
4143import Data.Generics.Internal.VL.Prism
4244import Data.Generics.Internal.Profunctor.Iso
4345import Data.Generics.Internal.Profunctor.Prism (prismPRavel)
@@ -109,16 +111,45 @@ instance
109111 , as ~ TupleToList a
110112 , ListTuple a as
111113 , 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)
112117 ) => AsType a s where
113118
114119 _Typed eta = prismRavel (prismPRavel (repIso . _GTyped @_ @as . tupled)) eta
115120 {-# INLINE[2] _Typed #-}
116121
117−-- See Note [Uncluttering type signatures]
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
118134instance {-# OVERLAPPING #-} AsType a Void where
119135 _Typed = undefined
120136 injectTyped = undefined
121137 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
122153instance {-# OVERLAPPING #-} AsType Void a where
123154 _Typed = undefined
124155 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−1
@@ -1,4 +1,4 @@
1−resolver: nightly-2018-04-05
1+resolver: nightly-2018-08-09
22
33packages:
44- '.'
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+38−2
@@ -2,6 +2,7 @@
22{-# OPTIONS_GHC -dsuppress-all #-}
33
44{-# LANGUAGE AllowAmbiguousTypes #-}
5+{-# LANGUAGE CPP #-}
56{-# LANGUAGE DataKinds #-}
67{-# LANGUAGE DeriveGeneric #-}
78{-# LANGUAGE DuplicateRecordFields #-}
@@ -10,6 +11,7 @@
1011{-# LANGUAGE ScopedTypeVariables #-}
1112{-# LANGUAGE TypeApplications #-}
1213{-# LANGUAGE TemplateHaskell #-}
14+{-# LANGUAGE OverloadedLabels #-}
1315
1416module Main where
1517
@@ -23,11 +25,16 @@ import System.Exit
2325import Data.Generics.Internal.VL.Lens
2426import Data.Generics.Internal.VL.Prism
2527import Data.Generics.Internal.VL.Traversal
28+import Control.Lens (_1, (+~))
29+import Data.Function ((&))
30+import Data.Generics.Labels ()
2631
2732-- This is sufficient at we only want to test that they typecheck
2833import Test24 ()
2934import Test25 ()
3035
36+import CustomChildren (customTypesTest)
37+
3138main :: IO ()
3239main = do
3340 res <- runTestTT tests
@@ -178,23 +185,32 @@ subtypePrismManual eta = prism g f eta
178185fieldALensName :: Lens' Record Int
179186fieldALensName = field @"fieldA"
180187
188+fieldALensName_ :: Lens' Record Int
189+fieldALensName_ = field_ @"fieldA"
190+
181191fieldALensType :: Lens' Record Int
182192fieldALensType = typed @Int
183193
184194fieldALensPos :: Lens' Record Int
185195fieldALensPos = position @1
186196
197+fieldALensPos_ :: Lens' Record Int
198+fieldALensPos_ = position_ @1
199+
187200subtypeLensGeneric :: Lens' Record Record2
188201subtypeLensGeneric = super
189202
190203typeChangingGeneric :: Lens (Record3 a) (Record3 b) a b
191−typeChangingGeneric = field @"fieldA"
204+typeChangingGeneric = #fieldA
192205
193206typeChangingGenericPos :: Lens (Record3 a) (Record3 b) a b
194207typeChangingGenericPos = position @1
195208
196209typeChangingGenericCompose :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b
197−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"
198214
199215sum1PrismB :: Prism Sum1 Sum1 Int Int
200216sum1PrismB = _Ctor @"B"
@@ -214,15 +230,24 @@ sum2TypePrism = _Typed @Int
214230sum2TypePrismChar :: Prism Sum2 Sum2 Char Char
215231sum2TypePrismChar = _Typed @Char
216232
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+
217239tests :: Test
218240tests = TestList $ map mkHUnitTest
219241 [ $(inspectTest $ 'fieldALensManual === 'fieldALensName)
242+ , $(inspectTest $ 'fieldALensManual === 'fieldALensName_)
220243 , $(inspectTest $ 'fieldALensManual === 'fieldALensType)
221244 , $(inspectTest $ 'fieldALensManual === 'fieldALensPos)
245+ , $(inspectTest $ 'fieldALensManual === 'fieldALensPos_)
222246 , $(inspectTest $ 'subtypeLensManual === 'subtypeLensGeneric)
223247 , $(inspectTest $ 'typeChangingManual === 'typeChangingGeneric)
224248 , $(inspectTest $ 'typeChangingManual === 'typeChangingGenericPos)
225249 , $(inspectTest $ 'typeChangingManualCompose === 'typeChangingGenericCompose)
250+ , $(inspectTest $ 'typeChangingManualCompose === 'typeChangingGenericCompose_)
226251 , $(inspectTest $ 'sum1PrismManual === 'sum1PrismB)
227252 , $(inspectTest $ 'subtypePrismManual === 'subtypePrismGeneric)
228253 , $(inspectTest $ 'sum2PrismManualChar === 'sum2TypePrismChar)
@@ -235,6 +260,17 @@ tests = TestList $ map mkHUnitTest
235260 -- TODO [1.0.0.0]: these tests pass with the new implementation
236261-- , $(inspectTest $ 'sum3Param1Manual === 'sum3Param1Derived)
237262-- , $(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
238273 ]
274+ where valLabel = RecB 3 True
239275
240276-- TODO: add test for traversals over multiple types
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 ]