on 6787a4e help sign in
.github/FUNDING.ymldeleted−12
since splitsnapshots
unifiedsplit
@@ -1,12 +0,0 @@
1−# These are supported funding model platforms
2−
3−github: [kcsongor] # Replace with up to 4 GitHub Sponsors-enabled usernames e.g., [user1, user2]
4−patreon: # Replace with a single Patreon username
5−open_collective: # Replace with a single Open Collective username
6−ko_fi: # Replace with a single Ko-fi username
7−tidelift: # Replace with a single Tidelift platform-name/package-name e.g., npm/babel
8−community_bridge: # Replace with a single Community Bridge project-name e.g., cloud-foundry
9−liberapay: # Replace with a single Liberapay username
10−issuehunt: # Replace with a single IssueHunt username
11−otechie: # Replace with a single Otechie username
12−custom: # Replace with up to 4 custom sponsorship URLs e.g., ['link1', 'link2']
.gitignore−3
@@ -7,6 +7,3 @@ cabal.sandbox.config
7*.hi
7*.hi
8*.o
8*.o
9core-html
9core-html
10−*~
11−*.org
12−cabal.project.local
.travis.yml+71−132
@@ -1,155 +1,94 @@
1# This Travis job script has been generated by a script via
1# This Travis job script has been generated by a script via
2#
2#
3−# haskell-ci '--config=cabal.haskell-ci' 'cabal.project'
3+# make_travis_yml_2.hs 'generic-lens.cabal'
4#
4#
5−# For more information, see https://github.com/haskell-CI/haskell-ci
5+# For more information, see https://github.com/hvr/multi-ghc-travis
6−#
7−# version: 0.5.20190908
8#
6#
9language: c
7language: c
10−dist: xenial
8+sudo: false
9+
11git:
10git:
12− # whether to recursively clone submodules
11+ submodules: false # whether to recursively clone submodules
13− submodules: false
12+
14cache:
13cache:
15 directories:
14 directories:
16 - $HOME/.cabal/packages
15 - $HOME/.cabal/packages
17 - $HOME/.cabal/store
16 - $HOME/.cabal/store
17+
18before_cache:
18before_cache:
19− - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log
19+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
20 # remove files that are regenerated by 'cabal update'
20 # remove files that are regenerated by 'cabal update'
21− - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*
21+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*
22− - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json
22+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json
23− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache
23+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache
24− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar
24+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar
25− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx
25+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx
26− - rm -rfv $CABALHOME/packages/head.hackage
26+
27matrix:
27matrix:
28 include:
28 include:
29− - compiler: ghc-8.8.1
29+ - compiler: "ghc-8.0.2"
30+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
30− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}}
31+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.2], sources: [hvr-ghc]}}
31− - compiler: ghc-8.6.5
32+ - compiler: "ghc-8.2.1"
32− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-3.0"]}}
33+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
33− - compiler: ghc-8.4.4
34− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-3.0"]}}
34+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.1], sources: [hvr-ghc]}}
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
35+ - compiler: "ghc-8.2.2"
38− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-3.0"]}}
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]}}
39− - compiler: ghc-8.0.2
38+ - compiler: "ghc-8.4.1"
40− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-3.0"]}}
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+
41before_install:
42before_install:
42− - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')
43+ - HC=${CC}
43− - WITHCOMPILER="-w $HC"
44− - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//')
45− - HCPKG="$HC-pkg"
44+ - HCPKG=${HC/ghc/ghc-pkg}
46 - unset CC
45 - unset CC
47− - CABAL=/opt/ghc/bin/cabal
46+ - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH
48− - CABALHOME=$HOME/.cabal
47+
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
73install:
48install:
74− - ${CABAL} --version
49+ - cabal --version
75 - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
50 - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
76− - TEST=--enable-tests
77− - if [ $HCNUMVER -ge 80600 ] ; then TEST=--disable-tests ; fi
78− - BENCH=--enable-benchmarks
51+ - BENCH=${BENCH---enable-benchmarks}
79− - if [ $HCNUMVER -ge 80800 ] ; then BENCH=--disable-benchmarks ; fi
52+ - TEST=${TEST---enable-tests}
80− - HEADHACKAGE=false
53+ - HADDOCK=${HADDOCK-true}
81− - rm -f $CABALHOME/config
54+ - INSTALLED=${INSTALLED-true}
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
55+ - travis_retry cabal update -v
104− # Generate cabal.project
56+ - sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
105− - rm -rf cabal.project cabal.project.local cabal.project.freeze
106− - touch cabal.project
107− - |
108− echo "packages: ." >> cabal.project
57+ - rm -fv cabal.project.local
109− - |
58+ - "echo 'packages: .' > cabal.project"
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
59+ - if [ -f "./configure.ac" ]; then
114− - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output
60+ (cd "."; autoreconf -i);
61+ fi
115− - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"
62+ - rm -f cabal.project.freeze
116− - rm cabal.project.freeze
63+ - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all
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
64+ - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all
119−script:
65+ - rm -rf "."/.ghc.environment.* "."/dist
120 - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
66 - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
121− # Packaging...
67+
122− - ${CABAL} v2-sdist all | color_cabal_output
68+# Here starts the actual work to be performed for the package under test;
123− # Unpacking...
69+# any command which exits with a non-zero exit code causes the build to fail.
70+script:
71+ # test that source-distributions can be generated
72+ - (cd "."; cabal sdist)
124− - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
73+ - mv "."/dist/generic-lens-*.tar.gz ${DISTDIR}/
125− - cd ${DISTDIR} || false
74+ - cd ${DISTDIR}
126− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \;
75+ - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;
127− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \;
76+ - "printf 'packages: generic-lens-*/*.cabal' > cabal.project"
128− - PKGDIR_generic_lens="$(find . -maxdepth 1 -type d -regex '.*/generic-lens-[0-9.]*')"
129− # Generate cabal.project
130− - rm -rf cabal.project cabal.project.local cabal.project.freeze
131− - touch cabal.project
132− - |
133− echo "packages: ${PKGDIR_generic_lens}" >> cabal.project
134− - |
135− - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(generic-lens)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
136− - cat cabal.project || true
137− - cat cabal.project.local || true
138− # Building...
139 # this builds all libraries and executables (without tests/benchmarks)
77 # this builds all libraries and executables (without tests/benchmarks)
140− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output
78+ - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all
141− # Building with tests and benchmarks...
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+
142 # build & run tests, build benchmarks
85 # build & run tests, build benchmarks
143− - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output
86+ - cabal new-build -w ${HC} ${TEST} ${BENCH} all
144− # Testing...
87+ - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} all; fi
145− - if [ $HCNUMVER -lt 80600 ] ; then ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi
88+
146− # cabal check...
147− - (cd ${PKGDIR_generic_lens} && ${CABAL} -vnormal check)
148− # haddock...
89+ # haddock
149− - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all | color_cabal_output
90+ - rm -rf ./dist-newstyle
150− # Building without installed constraints for packages in global-db...
91+ - if $HADDOCK; then cabal new-haddock -w ${HC} --disable-tests --disable-benchmarks all; else echo "Skipping haddock generation";fi
151− - rm -f cabal.project.local
152− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output
153
92
154−# REGENDATA ["--config=cabal.haskell-ci","cabal.project"]
93+# REGENDATA ["generic-lens.cabal"]
155# EOF
94# EOF
ChangeLog.md−23
@@ -1,26 +1,3 @@
1−## 1.2.0.1
2−- Give HasAny/AsAny the same VTA behavior on 8.6 and 8.8 (Ryan Scott)
3−
4−## 1.2.0.0
5−- Add `HasTypesUsing` and `HasTypesCustom` for custom traversals (Lysxia)
6−- Improve type errors when no Generic instance is defined
7−- `types` now supports Text by default
8−
9−### Breaking API changes
10−- `HasType` now includes a reflexive case so that every type 'contains' itself (Matt Parsons)
11−- `AsSubtype` and `Subtype` now include a reflexive case so that every type is a subtype of itself
12−
13−## 1.1.0.0
14−- Fix regression in type inference for polymorphic optics
15−- Add `HasField0`, `HasPosition0`, `AsConstructor0`, `HasField_`, `HasPositon_`, and `AsConstructor_` (Lysxia)
16−- `types` now supports Data.Word and Data.Int (Lysxia)
17−- Add `Wrapped` iso for newtypes (Isaac Elliott)
18−- Expose internals through Data.GenericLens.Internal
19−- Add labels for prisms (Daniel Winograd-Cort)
20−
21−## 1.0.0.2
22−- Fix compile-time performance regression
23−
24## 1.0.0.1
1## 1.0.0.1
25- Remove dump-core dependency
2- Remove dump-core dependency
26- Relax upper bound on criterion (#42)
3- Relax upper bound on criterion (#42)
LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2019, Csongor Kiss
1+Copyright (c) 2017, Csongor Kiss
2
2
3All rights reserved.
3All rights reserved.
4
4
README.md+1−4
@@ -16,9 +16,6 @@ fully interoperable with the combinators found in mainstream lens libraries.
16
16
17Examples can be found in the `examples` and `tests` folders.
17Examples can be found in the `examples` and `tests` folders.
18
18
19−The library is described in the paper:
20−> Csongor Kiss, Matthew Pickering, and Nicolas Wu. 2018. Generic deriving of generic traversals. Proc. ACM Program. Lang. 2, ICFP, Article 85 (July 2018), 30 pages. DOI: https://doi.org/10.1145/3236780
21−
22Table of contents
19Table of contents
23=================
20=================
24
21
@@ -410,7 +407,7 @@ The
410library is used to ensure (see [here](test/Spec.hs)) that everything gets
407library is used to ensure (see [here](test/Spec.hs)) that everything gets
411inlined away.
408inlined away.
412
409
413−There is also a [benchmark suite](https://github.com/mpickering/generic-lens-benchmarks) with larger, real-world examples.
410+TODO push benchmarks too
414# Contributors
411# Contributors
415
412
416+ [Matthew Pickering](https://github.com/mpickering)
413+ [Matthew Pickering](https://github.com/mpickering)
cabal.haskell-cideleted−5
@@ -1,5 +0,0 @@
1−-- inspection tests fail
2−tests: <8.6
3−
4−-- blocked on vector-th-unbox
5−benchmarks: <8.8
cabal.project−1
@@ -1,2 +1 @@
1packages: generic-lens.cabal
1packages: generic-lens.cabal
2−write-ghc-environment-files: always
examples/doctest.hs−1
@@ -2,6 +2,5 @@ import Test.DocTest
2main
2main
3 = doctest
3 = doctest
4 [ "-iexamples"
4 [ "-iexamples"
5− , "-isrc"
6 , "examples/Biscuits.hs"
5 , "examples/Biscuits.hs"
7 ]
6 ]
generic-lens.cabal+10−16
@@ -1,5 +1,5 @@
1name: generic-lens
1name: generic-lens
2−version: 1.2.0.1
2+version: 1.0.0.1
3synopsis: Generically derive traversals, lenses and prisms.
3synopsis: Generically derive traversals, lenses and prisms.
4description: 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.
4description: This library uses GHC.Generics to derive efficient optics (traversals, lenses and prisms) for algebraic data types in a type-directed way, with a focus on good type inference and error messages when possible.
5
5
@@ -11,7 +11,7 @@ maintainer: kiss.csongor.kiss@gmail.com
11category: Generics, Records, Lens
11category: Generics, Records, Lens
12build-type: Simple
12build-type: Simple
13cabal-version: >= 1.10
13cabal-version: >= 1.10
14−Tested-With: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.1
14+Tested-With: GHC == 8.0.2, GHC == 8.2.1
15
15
16extra-source-files: ChangeLog.md
16extra-source-files: ChangeLog.md
17 , examples/StarWars.hs
17 , examples/StarWars.hs
@@ -23,8 +23,7 @@ flag dump-core
23 default: False
23 default: False
24
24
25library
25library
26− exposed-modules: Data.Generics.Wrapped
26+ exposed-modules: Data.Generics.Product
27− , Data.Generics.Product
28 , Data.Generics.Product.Any
27 , Data.Generics.Product.Any
29 , Data.Generics.Product.Fields
28 , Data.Generics.Product.Fields
30 , Data.Generics.Product.Param
29 , Data.Generics.Product.Param
@@ -33,8 +32,7 @@ library
33 , Data.Generics.Product.Typed
32 , Data.Generics.Product.Typed
34 , Data.Generics.Product.Types
33 , Data.Generics.Product.Types
35 , Data.Generics.Product.Constraints
34 , Data.Generics.Product.Constraints
36− , Data.Generics.Product.HList
35+ , Data.Generics.Product.List
37− , Data.Generics.Labels
38 , Data.Generics.Internal.GenericN
36 , Data.Generics.Internal.GenericN
39
37
40 , Data.Generics.Sum
38 , Data.Generics.Sum
@@ -50,13 +48,10 @@ library
50 , Data.Generics.Internal.VL.Prism
48 , Data.Generics.Internal.VL.Prism
51 , Data.Generics.Internal.VL.Iso
49 , Data.Generics.Internal.VL.Iso
52
50
53− , Data.GenericLens.Internal
54−
55 other-modules: Data.Generics.Internal.Families
51 other-modules: Data.Generics.Internal.Families
56 , Data.Generics.Internal.Families.Changing
52 , Data.Generics.Internal.Families.Changing
57 , Data.Generics.Internal.Families.Collect
53 , Data.Generics.Internal.Families.Collect
58 , Data.Generics.Internal.Families.Has
54 , Data.Generics.Internal.Families.Has
59− , Data.Generics.Internal.Errors
60 , Data.Generics.Internal.Void
55 , Data.Generics.Internal.Void
61
56
62 , Data.Generics.Sum.Internal.Constructors
57 , Data.Generics.Sum.Internal.Constructors
@@ -64,16 +59,15 @@ library
64 , Data.Generics.Sum.Internal.Subtype
59 , Data.Generics.Sum.Internal.Subtype
65
60
66 , Data.Generics.Product.Internal.Positions
61 , Data.Generics.Product.Internal.Positions
67− , Data.Generics.Product.Internal.GLens
68 , Data.Generics.Product.Internal.Subtype
62 , Data.Generics.Product.Internal.Subtype
69
63
70 , Data.Generics.Product.Internal.Constraints
64 , Data.Generics.Product.Internal.Constraints
71− , Data.Generics.Product.Internal.HList
65+ , Data.Generics.Product.Internal.List
66+ , Data.Generics.Product.Internal.Keyed
72
67
73− build-depends: base >= 4.9 && < 5
68+ build-depends: base >= 4.9 && <= 5.0
74− , profunctors >= 5.0 && < 6.0
69+ , profunctors >= 5.0 && <= 6.0
75− , tagged >= 0.8 && < 1
70+ , tagged >= 0.8 && <= 0.9
76− , text >= 1.2 && < 1.3
77
71
78 hs-source-dirs: src
72 hs-source-dirs: src
79 default-language: Haskell2010
73 default-language: Haskell2010
@@ -103,7 +97,7 @@ test-suite generic-lens-test
103 type: exitcode-stdio-1.0
97 type: exitcode-stdio-1.0
104 hs-source-dirs: test
98 hs-source-dirs: test
105 main-is: Spec.hs
99 main-is: Spec.hs
106− other-modules: Util Test24 Test25 Test40 Test62 Test63 CustomChildren
100+ other-modules: Util Test24 Test25 Test40
107
101
108 build-depends: base >= 4.9 && <= 5.0
102 build-depends: base >= 4.9 && <= 5.0
109 , generic-lens
103 , generic-lens
src/Data/GenericLens/Internal.hsdeleted−64
@@ -1,64 +0,0 @@
1−-----------------------------------------------------------------------------
2−-- |
3−-- Module : Data.GenericLens.Internal
4−-- Copyright : (C) 2019 Csongor Kiss
5−-- License : BSD3
6−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
7−-- Stability : experimental
8−-- Portability : non-portable
9−--
10−-- The library internals are exposed through this module. Please keep
11−-- in mind that everything here is subject to change irrespective of
12−-- the the version numbers.
13−-----------------------------------------------------------------------------
14−
15−module Data.GenericLens.Internal
16− ( module Data.Generics.Internal.Families
17− , module Data.Generics.Internal.Families.Changing
18− , module Data.Generics.Internal.Families.Collect
19− , module Data.Generics.Internal.Families.Has
20− , module Data.Generics.Internal.Void
21− , module Data.Generics.Internal.Errors
22−
23− , module Data.Generics.Sum.Internal.Constructors
24− , module Data.Generics.Sum.Internal.Typed
25− , module Data.Generics.Sum.Internal.Subtype
26−
27− , module Data.Generics.Product.Internal.Positions
28− , module Data.Generics.Product.Internal.GLens
29− , module Data.Generics.Product.Internal.Subtype
30− , module Data.Generics.Product.Internal.Constraints
31− , module Data.Generics.Product.Internal.HList
32−
33− , module Data.Generics.Internal.GenericN
34−
35− -- * van Laarhoven optics
36− , module Data.Generics.Internal.VL.Iso
37− , module Data.Generics.Internal.VL.Lens
38− , module Data.Generics.Internal.VL.Prism
39− , module Data.Generics.Internal.VL.Traversal
40− ) where
41−
42−import Data.Generics.Internal.Families
43−import Data.Generics.Internal.Families.Changing
44−import Data.Generics.Internal.Families.Collect
45−import Data.Generics.Internal.Families.Has
46−import Data.Generics.Internal.Void
47−import Data.Generics.Internal.Errors
48−
49−import Data.Generics.Sum.Internal.Constructors
50−import Data.Generics.Sum.Internal.Typed
51−import Data.Generics.Sum.Internal.Subtype
52−
53−import Data.Generics.Product.Internal.Positions
54−import Data.Generics.Product.Internal.GLens
55−import Data.Generics.Product.Internal.Subtype
56−import Data.Generics.Product.Internal.Constraints
57−import Data.Generics.Product.Internal.HList
58−
59−import Data.Generics.Internal.GenericN
60−
61−import Data.Generics.Internal.VL.Iso
62−import Data.Generics.Internal.VL.Lens
63−import Data.Generics.Internal.VL.Prism
64−import Data.Generics.Internal.VL.Traversal
src/Data/GenericLens/Internal.hs~deleted

No changes to the content.

src/Data/Generics/Internal/Errors.hsdeleted−59
@@ -1,59 +0,0 @@
1−{-# LANGUAGE UndecidableInstances #-}
2−{-# LANGUAGE TypeFamilies #-}
3−{-# LANGUAGE KindSignatures #-}
4−{-# LANGUAGE PolyKinds #-}
5−{-# LANGUAGE DataKinds #-}
6−{-# LANGUAGE TypeOperators #-}
7−{-# LANGUAGE KindSignatures #-}
8−
9−-------------------------------------------------------------------------------
10−---- |
11−---- Module : Data.Generics.Internal.Errors
12−---- Copyright : (C) 2019 Csongor Kiss
13−---- License : BSD3
14−---- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
15−---- Stability : experimental
16−---- Portability : non-portable
17−----
18−---- Provide more legible type errors as described in
19−---- (https://kcsongor.github.io/report-stuck-families/)[this blog post].
20−-------------------------------------------------------------------------------
21−
22−module Data.Generics.Internal.Errors
23− ( NoGeneric
24− , Defined
25− , Defined_list
26−
27− , QuoteType
28− , PrettyError
29− ) where
30−
31−import GHC.Generics
32−import GHC.TypeLits
33−import Data.Kind
34−
35−type family NoGeneric (a :: Type) (ctxt :: [ErrorMessage]) :: Constraint where
36− NoGeneric a ctxt = PrettyError ('Text "No instance for " ':<>: QuoteType (Generic a)
37− ': ctxt)
38−type family PrettyError (ctxt :: [ErrorMessage]) :: k where
39− PrettyError '[] = TypeError ('Text "")
40− PrettyError (c ': cs) = TypeError ('Text "| " ':<>: c ':$$: PrettyLines cs)
41−
42−type family PrettyLines (ctxt :: [ErrorMessage]) :: ErrorMessage where
43− PrettyLines '[] = 'Text ""
44− PrettyLines (c ': cs) = 'Text "| " ':<>: c ':$$: PrettyLines cs
45−
46−type family Defined (break :: Type -> Type) (err :: Constraint) (a :: k) :: k where
47− Defined Void1 _ _ = Any
48− Defined _ _ k = k
49−
50−type family Defined_list (break :: [*]) (err :: Constraint) (a :: k) :: k where
51− Defined_list '[Void] _ _ = Any
52− Defined_list _ _ k = k
53−
54−data Void1 a
55−data Void
56−type family Any :: k
57−
58−type family QuoteType (typ :: k) :: ErrorMessage where
59− QuoteType typ = 'Text "‘" ':<>: 'ShowType typ ':<>: 'Text "’"
src/Data/Generics/Internal/Families.hs+2−1
@@ -9,7 +9,7 @@
9-----------------------------------------------------------------------------
9-----------------------------------------------------------------------------
10-- |
10-- |
11-- Module : Data.Generics.Internal.Families
11-- Module : Data.Generics.Internal.Families
12−-- Copyright : (C) 2019 Csongor Kiss
12+-- Copyright : (C) 2017 Csongor Kiss
13-- License : BSD3
13-- License : BSD3
14-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
14-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
15-- Stability : experimental
15-- Stability : experimental
@@ -27,6 +27,7 @@ import Data.Generics.Internal.Families.Changing as Families
27
27
28import GHC.TypeLits (ErrorMessage (..), Symbol)
28import GHC.TypeLits (ErrorMessage (..), Symbol)
29
29
30+-- * Stuff
30type family ShowSymbols (ctors :: [Symbol]) :: ErrorMessage where
31type family ShowSymbols (ctors :: [Symbol]) :: ErrorMessage where
31 ShowSymbols '[]
32 ShowSymbols '[]
32 = 'Text ""
33 = 'Text ""
src/Data/Generics/Internal/Families/Changing.hs+5−12
@@ -9,14 +9,13 @@
9{-# LANGUAGE UndecidableInstances #-}
9{-# LANGUAGE UndecidableInstances #-}
10
10
11module Data.Generics.Internal.Families.Changing
11module Data.Generics.Internal.Families.Changing
12− ( Indexed
12+ ( Proxied
13 , Infer
13 , Infer
14 , PTag (..)
14 , PTag (..)
15 , P
15 , P
16 , LookupParam
16 , LookupParam
17 , ArgAt
17 , ArgAt
18 , ArgCount
18 , ArgCount
19− , UnifyHead
20 ) where
19 ) where
21
20
22import GHC.TypeLits (Nat, type (-), type (+), TypeError, ErrorMessage (..))
21import GHC.TypeLits (Nat, type (-), type (+), TypeError, ErrorMessage (..))
@@ -56,11 +55,11 @@ import GHC.TypeLits (Nat, type (-), type (+), TypeError, ErrorMessage (..))
56data PTag = PTag
55data PTag = PTag
57type family P :: Nat -> k -> PTag -> k
56type family P :: Nat -> k -> PTag -> k
58
57
59−type Indexed t = Indexed' t 0
58+type Proxied t = Proxied' t 0
60
59
61−type family Indexed' (t :: k) (next :: Nat) :: k where
60+type family Proxied' (t :: k) (next :: Nat) :: k where
62− Indexed' (t (a :: j) :: k) next = (Indexed' t (next + 1)) (P next a 'PTag)
61+ Proxied' (t (a :: j) :: k) next = (Proxied' t (next + 1)) (P next a 'PTag)
63− Indexed' t _ = t
62+ Proxied' t _ = t
64
63
65data Sub where
64data Sub where
66 Sub :: Nat -> k -> Sub
65 Sub :: Nat -> k -> Sub
@@ -153,9 +152,3 @@ type family ArgAt (t :: k) (n :: Nat) :: j where
153-- However, for some reason, this violates the functional dependencies on 8.2.2.
152-- However, for some reason, this violates the functional dependencies on 8.2.2.
154-- Therefore, when using a newer version of the compiler, the original constraints
153-- Therefore, when using a newer version of the compiler, the original constraints
155-- are used, as the expression size is smaller under 8.2.2.
154-- 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 @@
7-----------------------------------------------------------------------------
7-----------------------------------------------------------------------------
8-- |
8-- |
9-- Module : Data.Generics.Internal.Families.Collect
9-- Module : Data.Generics.Internal.Families.Collect
10−-- Copyright : (C) 2019 Csongor Kiss
10+-- Copyright : (C) 2017 Csongor Kiss
11-- License : BSD3
11-- License : BSD3
12-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
12-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
13-- Stability : experimental
13-- Stability : experimental
@@ -28,7 +28,7 @@ import Data.Type.Equality (type (==))
28import GHC.Generics
28import GHC.Generics
29import GHC.TypeLits (Symbol, CmpSymbol)
29import GHC.TypeLits (Symbol, CmpSymbol)
30
30
31−import Data.Generics.Product.Internal.HList (type (++))
31+import Data.Generics.Product.Internal.List (type (++))
32import Data.Generics.Internal.Families.Has (GTypes)
32import Data.Generics.Internal.Families.Has (GTypes)
33
33
34data TypeStat
34data TypeStat
src/Data/Generics/Internal/Families/Has.hs+22−72
@@ -7,7 +7,7 @@
7-----------------------------------------------------------------------------
7-----------------------------------------------------------------------------
8-- |
8-- |
9-- Module : Data.Generics.Internal.Families.Has
9-- Module : Data.Generics.Internal.Families.Has
10−-- Copyright : (C) 2019 Csongor Kiss
10+-- Copyright : (C) 2017 Csongor Kiss
11-- License : BSD3
11-- License : BSD3
12-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
12-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
13-- Stability : experimental
13-- Stability : experimental
@@ -16,92 +16,42 @@
16-----------------------------------------------------------------------------
16-----------------------------------------------------------------------------
17module Data.Generics.Internal.Families.Has
17module Data.Generics.Internal.Families.Has
18 ( HasTotalFieldP
18 ( HasTotalFieldP
19− , HasTotalTypeP
20− , HasTotalPositionP
21− , Pos
22 , HasPartialTypeP
19 , HasPartialTypeP
23 , HasCtorP
20 , HasCtorP
24 , GTypes
21 , GTypes
25 ) where
22 ) where
26
23
27−import Data.Type.Bool (type (||))
24+import Data.Type.Bool (type (||), type (&&))
28import Data.Type.Equality (type (==))
25import Data.Type.Equality (type (==))
29import GHC.Generics
26import GHC.Generics
30−import GHC.TypeLits (Symbol, Nat)
27+import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
31−import Data.Kind (Type)
32
28
33−import Data.Generics.Product.Internal.HList
29+import Data.Generics.Product.Internal.List
34
30
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
31+type family HasTotalFieldP (field :: Symbol) f :: Bool where
45− HasTotalFieldP field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 t))
32+ HasTotalFieldP field (S1 ('MetaSel ('Just field) _ _ _) _)
46− = 'Just t
33+ = 'True
47 HasTotalFieldP field (l :*: r)
34 HasTotalFieldP field (l :*: r)
48− = Alt (HasTotalFieldP field l) (HasTotalFieldP field r)
35+ = HasTotalFieldP field l || HasTotalFieldP field r
49 HasTotalFieldP field (l :+: r)
36 HasTotalFieldP field (l :+: r)
50− = Both (HasTotalFieldP field l) (HasTotalFieldP field r)
37+ = HasTotalFieldP field l && HasTotalFieldP field r
51 HasTotalFieldP field (S1 _ _)
38 HasTotalFieldP field (S1 _ _)
52− = 'Nothing
39+ = 'False
53 HasTotalFieldP field (C1 _ f)
40 HasTotalFieldP field (C1 _ f)
54 = HasTotalFieldP field f
41 = HasTotalFieldP field f
55 HasTotalFieldP field (D1 _ f)
42 HasTotalFieldP field (D1 _ f)
56 = HasTotalFieldP field f
43 = HasTotalFieldP field f
57− HasTotalFieldP field (K1 _ _)
44+ HasTotalFieldP field (Rec0 _)
58− = 'Nothing
45+ = 'False
59 HasTotalFieldP field U1
46 HasTotalFieldP field U1
60− = 'Nothing
47+ = 'False
61 HasTotalFieldP field V1
48 HasTotalFieldP field V1
62− = 'Nothing
49+ = 'False
63−
50+ HasTotalFieldP field f
64−type family HasTotalTypeP (typ :: Type) f :: Maybe Type where
51+ = TypeError
65− HasTotalTypeP typ (S1 _ (K1 _ typ))
52+ ( 'ShowType f
66− = 'Just typ
53+ ':<>: 'Text " is not a valid GHC.Generics representation type"
67− HasTotalTypeP typ (l :*: r)
54+ )
68− = Alt (HasTotalTypeP typ l) (HasTotalTypeP typ r)
69− HasTotalTypeP typ (l :+: r)
70− = Both (HasTotalTypeP typ l) (HasTotalTypeP typ r)
71− HasTotalTypeP typ (S1 _ _)
72− = 'Nothing
73− HasTotalTypeP typ (C1 _ f)
74− = HasTotalTypeP typ f
75− HasTotalTypeP typ (D1 _ f)
76− = HasTotalTypeP typ f
77− HasTotalTypeP typ (K1 _ _)
78− = 'Nothing
79− HasTotalTypeP typ U1
80− = 'Nothing
81− HasTotalTypeP typ V1
82− = 'Nothing
83−
84−data Pos (p :: Nat)
85−
86−type family HasTotalPositionP (pos :: Nat) f :: Maybe Type where
87− HasTotalPositionP pos (S1 _ (K1 (Pos pos) t))
88− = 'Just t
89− HasTotalPositionP pos (l :*: r)
90− = Alt (HasTotalPositionP pos l) (HasTotalPositionP pos r)
91− HasTotalPositionP pos (l :+: r)
92− = Both (HasTotalPositionP pos l) (HasTotalPositionP pos r)
93− HasTotalPositionP pos (S1 _ _)
94− = 'Nothing
95− HasTotalPositionP pos (C1 _ f)
96− = HasTotalPositionP pos f
97− HasTotalPositionP pos (D1 _ f)
98− = HasTotalPositionP pos f
99− HasTotalPositionP pos (K1 _ _)
100− = 'Nothing
101− HasTotalPositionP pos U1
102− = 'Nothing
103− HasTotalPositionP pos V1
104− = 'Nothing
105
55
106type family HasPartialTypeP a f :: Bool where
56type family HasPartialTypeP a f :: Bool where
107 HasPartialTypeP t (l :+: r)
57 HasPartialTypeP t (l :+: r)
@@ -123,11 +73,11 @@ type family HasCtorP (ctor :: Symbol) f :: Bool where
123 HasCtorP ctor _
73 HasCtorP ctor _
124 = 'False
74 = 'False
125
75
126−type family GTypes (rep :: Type -> Type) :: [Type] where
76+type family GTypes (rep :: * -> *) :: [((), *)] where
127 GTypes (l :*: r)
77 GTypes (l :*: r)
128 = GTypes l ++ GTypes r
78 = GTypes l ++ GTypes r
129− GTypes (K1 _ a)
79+ GTypes (Rec0 a)
130− = '[ a]
80+ = '[ '( '(), a)]
131 GTypes (M1 _ m a)
81 GTypes (M1 _ m a)
132 = GTypes a
82 = GTypes a
133 GTypes U1 = '[]
83 GTypes U1 = '[]
src/Data/Generics/Internal/GenericN.hs+2−3
@@ -1,4 +1,3 @@
1−{-# OPTIONS_HADDOCK hide #-}
2{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
@@ -12,9 +11,9 @@
12--------------------------------------------------------------------------------
11--------------------------------------------------------------------------------
13-- |
12-- |
14-- Module : Data.Generics.Internal.GenericN
13-- Module : Data.Generics.Internal.GenericN
15−-- Copyright : (C) 2019 Csongor Kiss
14+-- Copyright : (C) 2018 Csongor Kiss
16−-- License : BSD3
17-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
15-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16+-- License : BSD3
18-- Stability : experimental
17-- Stability : experimental
19-- Portability : non-portable
18-- Portability : non-portable
20--
19--
src/Data/Generics/Internal/Profunctor/Iso.hs+1−9
@@ -1,5 +1,3 @@
1−{-# OPTIONS_HADDOCK hide #-}
2−{-# LANGUAGE TupleSections #-}
3{-# LANGUAGE GADTs #-}
1{-# LANGUAGE GADTs #-}
4{-# LANGUAGE NoMonomorphismRestriction #-}
2{-# LANGUAGE NoMonomorphismRestriction #-}
5{-# LANGUAGE Rank2Types #-}
3{-# LANGUAGE Rank2Types #-}
@@ -11,7 +9,7 @@
11-----------------------------------------------------------------------------
9-----------------------------------------------------------------------------
12-- |
10-- |
13-- Module : Data.Generics.Internal.Profunctor.Iso
11-- Module : Data.Generics.Internal.Profunctor.Iso
14−-- Copyright : (C) 2019 Csongor Kiss
12+-- Copyright : (C) 2017 Csongor Kiss
15-- License : BSD3
13-- License : BSD3
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
14-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17-- Stability : experimental
15-- Stability : experimental
@@ -28,8 +26,6 @@ import GHC.Generics ((:*:)(..), (:+:)(..), Generic(..), M1(..), K1(..)
28import Data.Coerce
26import Data.Coerce
29import Data.Generics.Internal.GenericN (Rec (..))
27import Data.Generics.Internal.GenericN (Rec (..))
30
28
31−import qualified Data.Generics.Internal.VL.Iso as VL
32−
33type Iso s t a b
29type Iso s t a b
34 = forall p. (Profunctor p) => p a b -> p s t
30 = forall p. (Profunctor p) => p a b -> p s t
35
31
@@ -78,10 +74,6 @@ iso :: (s -> a) -> (b -> t) -> Iso s t a b
78iso = dimap
74iso = dimap
79{-# INLINE iso #-}
75{-# INLINE iso #-}
80
76
81−iso2isovl :: Iso s t a b -> VL.Iso s t a b
82−iso2isovl _iso = withIso _iso VL.iso
83−{-# INLINE iso2isovl #-}
84−
85withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
77withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
86withIso ai k = case ai (Exchange id id) of
78withIso ai k = case ai (Exchange id id) of
87 Exchange sa bt -> k sa bt
79 Exchange sa bt -> k sa bt
src/Data/Generics/Internal/Profunctor/Lens.hs+1−2
@@ -1,4 +1,3 @@
1−{-# OPTIONS_HADDOCK hide #-}
2{-# LANGUAGE GADTs #-}
1{-# LANGUAGE GADTs #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
2{-# LANGUAGE NoMonomorphismRestriction #-}
4{-# LANGUAGE Rank2Types #-}
3{-# LANGUAGE Rank2Types #-}
@@ -11,7 +10,7 @@
11-----------------------------------------------------------------------------
10-----------------------------------------------------------------------------
12-- |
11-- |
13-- Module : Data.Generics.Internal.Profunctor.Lens
12-- Module : Data.Generics.Internal.Profunctor.Lens
14−-- Copyright : (C) 2019 Csongor Kiss
13+-- Copyright : (C) 2017 Csongor Kiss
15-- License : BSD3
14-- License : BSD3
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
15-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17-- Stability : experimental
16-- Stability : experimental
src/Data/Generics/Internal/Profunctor/Prism.hs+9−8
@@ -1,4 +1,3 @@
1−{-# OPTIONS_HADDOCK hide #-}
2{-# LANGUAGE GADTs #-}
1{-# LANGUAGE GADTs #-}
3{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE NoMonomorphismRestriction #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
@@ -11,7 +10,7 @@
11-----------------------------------------------------------------------------
10-----------------------------------------------------------------------------
12-- |
11-- |
13-- Module : Data.Generics.Internal.Profunctor.Prism
12-- Module : Data.Generics.Internal.Profunctor.Prism
14−-- Copyright : (C) 2019 Csongor Kiss
13+-- Copyright : (C) 2017 Csongor Kiss
15-- License : BSD3
14-- License : BSD3
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
15-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17-- Stability : experimental
16-- Stability : experimental
@@ -22,7 +21,6 @@
22-----------------------------------------------------------------------------
21-----------------------------------------------------------------------------
23module Data.Generics.Internal.Profunctor.Prism where
22module Data.Generics.Internal.Profunctor.Prism where
24
23
25−import Data.Bifunctor (bimap)
26import Data.Profunctor (Choice(..), Profunctor(..))
24import Data.Profunctor (Choice(..), Profunctor(..))
27import Data.Tagged
25import Data.Tagged
28import Data.Profunctor.Unsafe ((#.), (.#))
26import Data.Profunctor.Unsafe ((#.), (.#))
@@ -46,12 +44,12 @@ prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
46prism bt seta eta = dimap seta (either id bt) (right' eta)
44prism bt seta eta = dimap seta (either id bt) (right' eta)
47
45
48_Left :: Prism (Either a c) (Either b c) a b
46_Left :: Prism (Either a c) (Either b c) a b
49−_Left = left'
47+_Left = prism Left $ either Right (Left . Right)
50
48
51_Right :: Prism (Either c a) (Either c b) a b
49_Right :: Prism (Either c a) (Either c b) a b
52−_Right = right'
50+_Right = prism Right $ either (Left . Left) Right
53
51
54−prismPRavel :: APrism s t a b -> Prism s t a b
52+prismPRavel :: (Market a b a b -> Market a b s t) -> Prism s t a b
55prismPRavel l pab = (prism2prismp $ l idPrism) pab
53prismPRavel l pab = (prism2prismp $ l idPrism) pab
56
54
57build :: (Tagged b b -> Tagged t t) -> b -> t
55build :: (Tagged b b -> Tagged t t) -> b -> t
@@ -67,7 +65,9 @@ without' :: Prism s t a b -> Prism s t c d -> Prism s t (Either a c) (Either b d
67without' k =
65without' k =
68 withPrism k $ \bt _ k' ->
66 withPrism k $ \bt _ k' ->
69 withPrism k' $ \dt setc ->
67 withPrism k' $ \dt setc ->
70− prism (either bt dt) $ \s -> fmap Right (setc s)
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
71{-# INLINE without' #-}
71{-# INLINE without' #-}
72
72
73withPrism :: APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
73withPrism :: APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
@@ -85,7 +85,8 @@ gsum f _ (L1 x) = f x
85gsum _ g (R1 y) = g y
85gsum _ g (R1 y) = g y
86
86
87plus :: (a -> b) -> (c -> d) -> Either a c -> Either b d
87plus :: (a -> b) -> (c -> d) -> Either a c -> Either b d
88−plus = bimap
88+plus f _ (Left x) = Left (f x)
89+plus _ g (Right y) = Right (g y)
89
90
90--------------------------------------------------------------------------------
91--------------------------------------------------------------------------------
91-- Market
92-- Market
src/Data/Generics/Internal/VL/Iso.hs+2−30
@@ -1,4 +1,3 @@
1−{-# OPTIONS_HADDOCK hide #-}
2{-# LANGUAGE GADTs #-}
1{-# LANGUAGE GADTs #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
2{-# LANGUAGE NoMonomorphismRestriction #-}
4{-# LANGUAGE Rank2Types #-}
3{-# LANGUAGE Rank2Types #-}
@@ -10,7 +9,7 @@
10-----------------------------------------------------------------------------
9-----------------------------------------------------------------------------
11-- |
10-- |
12-- Module : Data.Generics.Internal.VL.Iso
11-- Module : Data.Generics.Internal.VL.Iso
13−-- Copyright : (C) 2019 Csongor Kiss
12+-- Copyright : (C) 2017 Csongor Kiss
14-- License : BSD3
13-- License : BSD3
15-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
14-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16-- Stability : experimental
15-- Stability : experimental
@@ -21,43 +20,16 @@
21-----------------------------------------------------------------------------
20-----------------------------------------------------------------------------
22module Data.Generics.Internal.VL.Iso where
21module Data.Generics.Internal.VL.Iso where
23
22
24−import Data.Coerce (coerce)
25−import Data.Functor.Identity (Identity(..))
26−import Data.Profunctor (Profunctor(..))
23+import Data.Profunctor (Profunctor(..))
27import GHC.Generics
24import GHC.Generics
28import Data.Generics.Internal.GenericN (Rec (..))
25import Data.Generics.Internal.GenericN (Rec (..))
29
26
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−
44type Iso' s a
27type Iso' s a
45 = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s)
28 = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s)
46
29
47type Iso s t a b
30type Iso s t a b
48 = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
31 = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
49
32
50−fromIso :: Iso s t a b -> Iso b a t s
51−fromIso l = withIso l $ \ sa bt -> iso bt sa
52−{-# inline fromIso #-}
53−
54−-- | Extract the two functions, one from @s -> a@ and
55−-- one from @b -> t@ that characterize an 'Iso'.
56−withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
57−withIso ai k = case ai (Exchange id Identity) of
58− Exchange sa bt -> k sa (coerce bt)
59−{-# inline withIso #-}
60−
61-- | A type and its generic representation are isomorphic
33-- | A type and its generic representation are isomorphic
62repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
34repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
63repIso = iso from to
35repIso = iso from to
src/Data/Generics/Internal/VL/Lens.hs+1−6
@@ -1,4 +1,3 @@
1−{-# OPTIONS_HADDOCK hide #-}
2{-# LANGUAGE GADTs #-}
1{-# LANGUAGE GADTs #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
2{-# LANGUAGE NoMonomorphismRestriction #-}
4{-# LANGUAGE Rank2Types #-}
3{-# LANGUAGE Rank2Types #-}
@@ -11,7 +10,7 @@
11-----------------------------------------------------------------------------
10-----------------------------------------------------------------------------
12-- |
11-- |
13-- Module : Data.Generics.Internal.VL.Lens
12-- Module : Data.Generics.Internal.VL.Lens
14−-- Copyright : (C) 2019 Csongor Kiss
13+-- Copyright : (C) 2017 Csongor Kiss
15-- License : BSD3
14-- License : BSD3
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
15-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17-- Stability : experimental
16-- Stability : experimental
@@ -23,7 +22,6 @@
23module Data.Generics.Internal.VL.Lens where
22module Data.Generics.Internal.VL.Lens where
24
23
25import Control.Applicative (Const(..))
24import Control.Applicative (Const(..))
26−import Data.Coerce (coerce)
27import Data.Functor.Identity (Identity(..))
25import Data.Functor.Identity (Identity(..))
28import Data.Generics.Internal.Profunctor.Lens (ALens (..), idLens)
26import Data.Generics.Internal.Profunctor.Lens (ALens (..), idLens)
29
27
@@ -49,9 +47,6 @@ infixr 4 .~
49set :: Lens s t a b -> b -> s -> t
47set :: Lens s t a b -> b -> s -> t
50set l x = l .~ x
48set l x = l .~ x
51
49
52−over :: ((a -> Identity b) -> s -> Identity t) -> (a -> b) -> s -> t
53−over = coerce
54−
55lens2lensvl :: ALens a b s t -> Lens s t a b
50lens2lensvl :: ALens a b s t -> Lens s t a b
56lens2lensvl (ALens _get _set) =
51lens2lensvl (ALens _get _set) =
57 \f x ->
52 \f x ->
src/Data/Generics/Internal/VL/Prism.hs+1−2
@@ -1,4 +1,3 @@
1−{-# OPTIONS_HADDOCK hide #-}
2{-# LANGUAGE GADTs #-}
1{-# LANGUAGE GADTs #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
2{-# LANGUAGE NoMonomorphismRestriction #-}
4{-# LANGUAGE Rank2Types #-}
3{-# LANGUAGE Rank2Types #-}
@@ -10,7 +9,7 @@
10-----------------------------------------------------------------------------
9-----------------------------------------------------------------------------
11-- |
10-- |
12-- Module : Data.Generics.Internal.VL.Prism
11-- Module : Data.Generics.Internal.VL.Prism
13−-- Copyright : (C) 2019 Csongor Kiss
12+-- Copyright : (C) 2017 Csongor Kiss
14-- License : BSD3
13-- License : BSD3
15-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
14-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16-- Stability : experimental
15-- Stability : experimental
src/Data/Generics/Internal/VL/Traversal.hs+1−2
@@ -1,4 +1,3 @@
1−{-# OPTIONS_HADDOCK hide #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
3{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ConstraintKinds #-}
4{-# LANGUAGE GADTs #-}
3{-# LANGUAGE GADTs #-}
@@ -12,7 +11,7 @@
12-----------------------------------------------------------------------------
11-----------------------------------------------------------------------------
13-- |
12-- |
14-- Module : Data.Generics.Internal.VL.Traversal
13-- Module : Data.Generics.Internal.VL.Traversal
15−-- Copyright : (C) 2019 Csongor Kiss
14+-- Copyright : (C) 2017 Csongor Kiss
16-- License : BSD3
15-- License : BSD3
17-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
18-- Stability : experimental
17-- Stability : experimental
src/Data/Generics/Labels.hs+17−123
@@ -1,142 +1,36 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
1+{-# LANGUAGE CPP #-}
2−{-# LANGUAGE CPP #-}
3−{-# LANGUAGE ConstraintKinds #-}
4−{-# LANGUAGE DataKinds #-}
5−{-# LANGUAGE FlexibleInstances #-}
2+{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE FunctionalDependencies #-}
7−{-# LANGUAGE MultiParamTypeClasses #-}
3+{-# LANGUAGE MultiParamTypeClasses #-}
8−{-# LANGUAGE PolyKinds #-}
9−{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE TypeApplications #-}
5+{-# LANGUAGE TypeApplications #-}
11−{-# LANGUAGE TypeOperators #-}
6+{-# LANGUAGE TypeFamilies #-}
12−{-# LANGUAGE TypeFamilies #-}
13−{-# LANGUAGE UndecidableInstances #-}
7+{-# LANGUAGE UndecidableInstances #-}
14−{-# OPTIONS_GHC -Wno-orphans #-}
8+{-# OPTIONS_GHC -Wno-orphans #-}
9+
15
10
16--------------------------------------------------------------------------------
11--------------------------------------------------------------------------------
17-- |
12-- |
18-- Module : Data.Generics.Labels
13-- Module : Data.Generics.Labels
19−-- Copyright : (C) 2019 Csongor Kiss
14+-- Copyright : (C) 2017 Csongor Kiss
20−-- License : BSD3
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
15-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16+-- License : BSD3
22-- Stability : experimental
17-- Stability : experimental
23-- Portability : non-portable
18-- Portability : non-portable
24--
19--
25−-- Provides an (orphan) IsLabel instance for field lenses and constructor prisms.
20+-- Provides an (orphan) IsLabel instance for field lenses.
26-- Use at your own risk.
21-- Use at your own risk.
27--------------------------------------------------------------------------------
22--------------------------------------------------------------------------------
28
23
29−module Data.Generics.Labels
24+module Data.Generics.Labels () where
30− ( -- * Orphan IsLabel Instance
31− -- $sec1
32− Field(..)
33− , Field'
34− , Constructor(..)
35− , Constructor'
36− ) where
37
25
38import Data.Generics.Product
26import 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−
47import GHC.OverloadedLabels
27import GHC.OverloadedLabels
48−import GHC.TypeLits
49−
50−-- $sec1
51−-- An instance for creating lenses and prisms with @#identifiers@ from the
52−-- @OverloadedLabels@ extension. Note that since overloaded labels do not
53−-- support symbols starting with capital letters, all prisms (which come from
54−-- constructor names, which are capitalized) must be prefixed with an underscore
55−-- (e.g. @#_ConstructorName@).
56−--
57−-- Morally:
58−--
59−-- @
60−-- instance (HasField name s t a b) => IsLabel name (Lens s t a b) where ...
61−-- @
62−-- and
63−--
64−-- @
65−-- instance (AsConstructor name s t a b) => IsLabel name (Prism s t a b) where ...
66−-- @
67−--
68−-- Remember:
69−--
70−-- @
71−-- type Lens = forall f. Functor f => (a -> f b) -> s -> f t
72−--
73−-- type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)
74−-- @
75−--
76−-- The orphan instance is unavoidable if we want to work with
77−-- lenses-as-functions (as opposed to a 'ReifiedLens'-like newtype).
78−
79−-- | 'Field' is morally the same as 'HasField', but it is constructed from an
80−-- incoherent combination of 'HasField' and 'HasField''. In this way, it can be
81−-- seamlessly used in the 'IsLabel' instance even when dealing with data types
82−-- that don't have 'Field' instances (like data instances).
83−class Field name s t a b | s name -> a, t name -> b, s name b -> t, t name a -> s where
84− fieldLens :: Lens s t a b
85−
86−type Field' name s a = Field name s s a a
87−
88−instance {-# INCOHERENT #-} HasField name s t a b => Field name s t a b where
89− fieldLens = field @name
90−
91−instance {-# INCOHERENT #-} HasField' name s a => Field name s s a a where
92− fieldLens = field' @name
93−
94−-- | 'Constructor' is morally the same as 'AsConstructor', but it is constructed from an
95−-- incoherent combination of 'AsConstructor' and 'AsConstructor''. In this way, it can be
96−-- seamlessly used in the 'IsLabel' instance even when dealing with data types
97−-- that don't have 'Constructor' instances (like data instances).
98−class Constructor name s t a b | name s -> a, name t -> b where
99− constructorPrism :: Prism s t a b
100−
101−type Constructor' name s a = Constructor name s s a a
102−
103−instance {-# INCOHERENT #-} AsConstructor name s t a b => Constructor name s t a b where
104− constructorPrism = _Ctor @name
105−
106−instance {-# INCOHERENT #-} AsConstructor' name s a => Constructor name s s a a where
107− constructorPrism = _Ctor' @name
108−
109−type family BeginsWithCapital (name :: Symbol) :: Bool where
110− BeginsWithCapital name = CmpSymbol "_@" name == 'LT && CmpSymbol "_[" name == 'GT
111−
112−instance ( capital ~ BeginsWithCapital name
113− , IsLabelHelper capital name p f s t a b
114− , pafb ~ p a (f b), psft ~ p s (f t)) => IsLabel name (pafb -> psft) where
115−#if __GLASGOW_HASKELL__ >= 802
116− fromLabel = labelOutput @capital @name @p @f
117−#else
118− fromLabel _ = labelOutput @capital @name @p @f
119−#endif
120−
121−-- | This helper class allows us to customize the output type of the lens to be
122−-- either 'Prism' or 'Lens' (by choosing appropriate @p@ and @f@) as well as to
123−-- choose between whether we're dealing with a lens or a prism. The choice is
124−-- made by whether the @capital@ argument is true or false, which is determined by
125−-- whether the symbol starts with an underscore followed by a capital letter
126−-- (a check done in the 'IsLabel' instance above). If so, then we're dealing
127−-- with a constructor name, which should be a prism, and otherwise, it's a field
128−-- name, so we have a lens.
129−class IsLabelHelper capital name p f s t a b where
130− labelOutput :: p a (f b) -> p s (f t)
131
28
132−instance (Functor f, Field name s t a b) => IsLabelHelper 'False name (->) f s t a b where
133− labelOutput = fieldLens @name
134
29
30+instance (HasField field s t a b, Functor f, sft ~ (s -> f t)) =>
31+ IsLabel field ((a -> f b) -> sft) where
135#if __GLASGOW_HASKELL__ >= 802
32#if __GLASGOW_HASKELL__ >= 802
136−instance ( Applicative f, Choice p, Constructor name s t a b
33+ fromLabel = field @field
137− , name' ~ AppendSymbol "_" name) => IsLabelHelper 'True name' p f s t a b where
138− labelOutput = constructorPrism @name
139#else
34#else
140−instance (TypeError ('Text "Labels for Prisms require at least GHC 8.2"), Choice p) => IsLabelHelper 'True name' p f s t a b where
35+ fromLabel _ = field @field
141− labelOutput = undefined
142#endif
36#endif
src/Data/Generics/Product.hs+3−3
@@ -1,7 +1,7 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2-- |
2-- |
3-- Module : Data.Generics.Product
3-- Module : Data.Generics.Product
4−-- Copyright : (C) 2019 Csongor Kiss
4+-- Copyright : (C) 2017 Csongor Kiss
5-- License : BSD3
5-- License : BSD3
6-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
6-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
7-- Stability : experimental
7-- Stability : experimental
@@ -22,7 +22,7 @@ module Data.Generics.Product
22 , module Data.Generics.Product.Positions
22 , module Data.Generics.Product.Positions
23 , module Data.Generics.Product.Subtype
23 , module Data.Generics.Product.Subtype
24 , module Data.Generics.Product.Typed
24 , module Data.Generics.Product.Typed
25− , module Data.Generics.Product.HList
25+ , module Data.Generics.Product.List
26 -- *Traversals
26 -- *Traversals
27 , module Data.Generics.Product.Types
27 , module Data.Generics.Product.Types
28 , module Data.Generics.Product.Param
28 , module Data.Generics.Product.Param
@@ -37,4 +37,4 @@ import Data.Generics.Product.Typed
37import Data.Generics.Product.Types
37import Data.Generics.Product.Types
38import Data.Generics.Product.Constraints
38import Data.Generics.Product.Constraints
39import Data.Generics.Product.Param
39import Data.Generics.Product.Param
40−import Data.Generics.Product.HList
40+import Data.Generics.Product.List
src/Data/Generics/Product/Any.hs+2−2
@@ -12,7 +12,7 @@
12-----------------------------------------------------------------------------
12-----------------------------------------------------------------------------
13-- |
13-- |
14-- Module : Data.Generics.Product.Any
14-- Module : Data.Generics.Product.Any
15−-- Copyright : (C) 2019 Csongor Kiss
15+-- Copyright : (C) 2017 Csongor Kiss
16-- License : BSD3
16-- License : BSD3
17-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
18-- Stability : experimental
18-- Stability : experimental
@@ -53,7 +53,7 @@ import Data.Generics.Product.Typed
53-- human = Human "Tunyasz" 50 "London"
53-- human = Human "Tunyasz" 50 "London"
54-- :}
54-- :}
55
55
56−class HasAny sel s t a b | s sel -> a where
56+class HasAny (sel :: k) s t a b | s sel k -> a where
57 -- |A lens that focuses on a part of a product as identified by some
57 -- |A lens that focuses on a part of a product as identified by some
58 -- selector. Currently supported selectors are field names, positions and
58 -- selector. Currently supported selectors are field names, positions and
59 -- unique types. Compatible with the lens package's 'Control.Lens.Lens'
59 -- unique types. Compatible with the lens package's 'Control.Lens.Lens'
src/Data/Generics/Product/Constraints.hs+1−1
@@ -11,7 +11,7 @@
11-----------------------------------------------------------------------------
11-----------------------------------------------------------------------------
12-- |
12-- |
13-- Module : Data.Generics.Product.Constraints
13-- Module : Data.Generics.Product.Constraints
14−-- Copyright : (C) 2019 Csongor Kiss
14+-- Copyright : (C) 2018 Csongor Kiss
15-- License : BSD3
15-- License : BSD3
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17-- Stability : experimental
17-- Stability : experimental
src/Data/Generics/Product/Fields.hs+24−82
@@ -16,7 +16,7 @@
16-----------------------------------------------------------------------------
16-----------------------------------------------------------------------------
17-- |
17-- |
18-- Module : Data.Generics.Product.Fields
18-- Module : Data.Generics.Product.Fields
19−-- Copyright : (C) 2019 Csongor Kiss
19+-- Copyright : (C) 2017 Csongor Kiss
20-- License : BSD3
20-- License : BSD3
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
22-- Stability : experimental
22-- Stability : experimental
@@ -32,7 +32,6 @@ module Data.Generics.Product.Fields
32 -- $setup
32 -- $setup
33 HasField (..)
33 HasField (..)
34 , HasField' (..)
34 , HasField' (..)
35− , HasField_ (..)
36
35
37 , getField
36 , getField
38 , setField
37 , setField
@@ -41,13 +40,12 @@ module Data.Generics.Product.Fields
41import Data.Generics.Internal.Families
40import Data.Generics.Internal.Families
42import Data.Generics.Internal.VL.Lens as VL
41import Data.Generics.Internal.VL.Lens as VL
43import Data.Generics.Internal.Void
42import Data.Generics.Internal.Void
44−import Data.Generics.Product.Internal.GLens
43+import Data.Generics.Product.Internal.Keyed
45
44
46import Data.Kind (Constraint, Type)
45import Data.Kind (Constraint, Type)
47import GHC.Generics
46import GHC.Generics
48import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError)
47import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError)
49import Data.Generics.Internal.Profunctor.Lens as P
48import Data.Generics.Internal.Profunctor.Lens as P
50−import Data.Generics.Internal.Errors
51
49
52-- $setup
50-- $setup
53-- == /Running example:/
51-- == /Running example:/
@@ -113,30 +111,9 @@ class HasField (field :: Symbol) s t a b | s field -> a, t field -> b, s field b
113 -- ...
111 -- ...
114 field :: VL.Lens s t a b
112 field :: VL.Lens s t a b
115
113
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−
130class HasField' (field :: Symbol) s a | s field -> a where
114class HasField' (field :: Symbol) s a | s field -> a where
131 field' :: VL.Lens s s a a
115 field' :: VL.Lens s s a a
132
116
133−-- |Records that have a field with a given name.
134−--
135−-- This class gives the minimal constraints needed to define this lens.
136−-- For common uses, see 'HasField'.
137−class HasField0 (field :: Symbol) s t a b where
138− field0 :: VL.Lens s t a b
139−
140-- |
117-- |
141-- >>> getField @"age" human
118-- >>> getField @"age" human
142-- 50
119-- 50
@@ -152,68 +129,36 @@ setField = VL.set (field' @f)
152instance
129instance
153 ( Generic s
130 ( Generic s
154 , ErrorUnless field s (CollectField field (Rep s))
131 , ErrorUnless field s (CollectField field (Rep s))
155− , GLens' (HasTotalFieldPSym field) (Rep s) a
132+ , GHasKey' field (Rep s) a
156− , Defined (Rep s)
157− (NoGeneric s '[ 'Text "arising from a generic lens focusing on the "
158− ':<>: QuoteType field ':<>: 'Text " field of type " ':<>: QuoteType a
159− , 'Text "in " ':<>: QuoteType s])
160− (() :: Constraint)
161 ) => HasField' field s a where
133 ) => HasField' field s a where
162− field' f s = field0 @field f s
134+ field' f s = VL.ravel (repLens . gkey @field) f s
163−
164−class (~~) (a :: k) (b :: k) | a -> b, b -> a
165−instance (a ~ b) => (~~) a b
166
135
167instance -- see Note [Changing type parameters]
136instance -- see Note [Changing type parameters]
168− ( HasTotalFieldP field (Rep s) ~~ 'Just a
137+ ( Generic s
169− , HasTotalFieldP field (Rep t) ~~ 'Just b
138+ , ErrorUnless field s (CollectField field (Rep s))
170− , HasTotalFieldP field (Rep (Indexed s)) ~~ 'Just a'
139+ , Generic t
171− , HasTotalFieldP field (Rep (Indexed t)) ~~ 'Just b'
140+ -- see Note [CPP in instance constraints]
172− , t ~~ Infer s a' b
173− , s ~~ Infer t b' a
174− , HasField0 field s t a b
175− ) => HasField field s t a b where
176− field f s = field0 @field f s
177−
178−-- | See Note [Uncluttering type signatures]
179−#if __GLASGOW_HASKELL__ < 804
141+#if __GLASGOW_HASKELL__ < 802
180−-- >>> :t field
142+ , '(s', t') ~ '(Proxied s, Proxied t)
181−-- field
182−-- :: (HasField field s t a b, Functor f) => (a -> f b) -> s -> f t
183#else
143#else
184−-- >>> :t field
144+ , s' ~ Proxied s
185−-- field
145+ , t' ~ Proxied t
186−-- :: (Functor f, HasField field s t a b) => (a -> f b) -> s -> f t
187#endif
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
155+ ) => HasField field s t a b where
156+ field f s = VL.ravel (repLens . gkey @field) f s
157+
158+-- -- See Note [Uncluttering type signatures]
188instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where
159instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where
189 field = undefined
160 field = undefined
190
161
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−
217type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Constraint where
162type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Constraint where
218 ErrorUnless field s ('TypeStat _ _ '[])
163 ErrorUnless field s ('TypeStat _ _ '[])
219 = TypeError
164 = TypeError
@@ -235,6 +180,3 @@ type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Cons
235
180
236 ErrorUnless _ _ ('TypeStat '[] '[] _)
181 ErrorUnless _ _ ('TypeStat '[] '[] _)
237 = ()
182 = ()
238−
239−data HasTotalFieldPSym :: Symbol -> (TyFun (Type -> Type) (Maybe Type))
240−type instance Eval (HasTotalFieldPSym sym) tt = HasTotalFieldP sym tt
src/Data/Generics/Product/HList.hsdeleted−46
@@ -1,46 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE FunctionalDependencies #-}
5−{-# LANGUAGE MonoLocalBinds #-}
6−{-# LANGUAGE ScopedTypeVariables #-}
7−{-# LANGUAGE TypeInType #-}
8−{-# LANGUAGE UndecidableInstances #-}
9−
10−-----------------------------------------------------------------------------
11−-- |
12−-- Module : Data.Generics.Product.HList
13−-- Copyright : (C) 2019 Csongor Kiss
14−-- License : BSD3
15−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16−-- Stability : experimental
17−-- Portability : non-portable
18−--
19−-- Derive an isomorphism between a product type and a flat HList.
20−--
21−-----------------------------------------------------------------------------
22−
23−module Data.Generics.Product.HList
24− ( IsList (..)
25− ) where
26−
27−import Data.Generics.Product.Internal.HList
28−import Data.Kind
29−import GHC.Generics
30−import Data.Generics.Internal.VL.Iso (Iso)
31−import Data.Generics.Internal.Profunctor.Iso (repIso, iso2isovl)
32−
33−class IsList
34− (f :: Type)
35− (g :: Type)
36− (as :: [Type])
37− (bs :: [Type]) | f -> as, g -> bs where
38− list :: Iso f g (HList as) (HList bs)
39−
40−instance
41− ( Generic f
42− , Generic g
43− , GIsList (Rep f) (Rep g) as bs
44− ) => IsList f g as bs where
45− list = iso2isovl (repIso . glist)
46− {-# INLINE list #-}
src/Data/Generics/Product/Internal/Constraints.hs+7−2
@@ -15,7 +15,7 @@
15-----------------------------------------------------------------------------
15-----------------------------------------------------------------------------
16-- |
16-- |
17-- Module : Data.Generics.Product.Internal.Constraints
17-- Module : Data.Generics.Product.Internal.Constraints
18−-- Copyright : (C) 2019 Csongor Kiss
18+-- Copyright : (C) 2017 Csongor Kiss
19-- License : BSD3
19-- License : BSD3
20-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21-- Stability : experimental
21-- Stability : experimental
@@ -31,13 +31,13 @@ module Data.Generics.Product.Internal.Constraints
31 (
31 (
32 GHasConstraints (..)
32 GHasConstraints (..)
33 , GHasConstraints' (..)
33 , GHasConstraints' (..)
34+ , HList (..)
34 ) where
35 ) where
35
36
36import Data.Kind (Type, Constraint)
37import Data.Kind (Type, Constraint)
37import GHC.Generics
38import GHC.Generics
38import Data.Generics.Internal.VL.Iso
39import Data.Generics.Internal.VL.Iso
39import Data.Generics.Internal.VL.Traversal
40import Data.Generics.Internal.VL.Traversal
40−import Data.Generics.Product.Internal.HList
41
41
42-- | Constrained traversal.
42-- | Constrained traversal.
43class GHasConstraints' (c :: * -> Constraint) (f :: * -> *) where
43class GHasConstraints' (c :: * -> Constraint) (f :: * -> *) where
@@ -117,6 +117,11 @@ gtypes hl s = gconstraints @(Contains as) (pick hl) s
117
117
118--------------------------------------------------------------------------------
118--------------------------------------------------------------------------------
119
119
120+data HList (ts :: [Type]) where
121+ HNil :: HList '[]
122+ (:>) :: a -> HList as -> HList (a ': as)
123+infixr 5 :>
124+
120-- >>> :kind! Functions '[Int, Char, Bool] Maybe
125-- >>> :kind! Functions '[Int, Char, Bool] Maybe
121-- '[Int -> Maybe Int, Char -> Maybe Char, Bool -> Maybe Bool]
126-- '[Int -> Maybe Int, Char -> Maybe Char, Bool -> Maybe Bool]
122type family Functions (ts :: [Type]) (g :: Type -> Type) = r | r -> ts where
127type family Functions (ts :: [Type]) (g :: Type -> Type) = r | r -> ts where
src/Data/Generics/Product/Internal/GLens.hsdeleted−81
@@ -1,81 +0,0 @@
1−{-# LANGUAGE FlexibleContexts #-}
2−{-# LANGUAGE TypeInType #-}
3−{-# LANGUAGE AllowAmbiguousTypes #-}
4−{-# LANGUAGE ConstraintKinds #-}
5−{-# LANGUAGE DataKinds #-}
6−{-# LANGUAGE FlexibleInstances #-}
7−{-# LANGUAGE FunctionalDependencies #-}
8−{-# LANGUAGE KindSignatures #-}
9−{-# LANGUAGE MultiParamTypeClasses #-}
10−{-# LANGUAGE Rank2Types #-}
11−{-# LANGUAGE ScopedTypeVariables #-}
12−{-# LANGUAGE TypeApplications #-}
13−{-# LANGUAGE TypeFamilies #-}
14−{-# LANGUAGE TypeOperators #-}
15−{-# LANGUAGE UndecidableInstances #-}
16−
17−-----------------------------------------------------------------------------
18−-- |
19−-- Module : Data.Generics.Product.Internal.GLens
20−-- Copyright : (C) 2019 Csongor Kiss
21−-- License : BSD3
22−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
23−-- Stability : experimental
24−-- Portability : non-portable
25−--
26−-- Derive record field getters and setters generically.
27−--
28−-----------------------------------------------------------------------------
29−
30−module Data.Generics.Product.Internal.GLens
31− ( GLens (..)
32− , GLens'
33− , TyFun
34− , Eval
35− ) where
36−
37−import Data.Generics.Internal.Profunctor.Lens (Lens, choosing, first, second)
38−import Data.Generics.Internal.Profunctor.Iso (kIso, sumIso, mIso)
39−
40−import Data.Kind (Type)
41−import GHC.Generics
42−
43−type Pred = TyFun (Type -> Type) (Maybe Type)
44−
45−type TyFun a b = a -> b -> Type
46−type family Eval (f :: TyFun a b) (x :: a) :: b
47−
48−-- A generic lens that uses some predicate to determine which field to focus on
49−class GLens (pred :: Pred) (s :: Type -> Type) (t :: Type -> Type) a b | s pred -> a, t pred -> b where
50− glens :: Lens (s x) (t x) a b
51−
52−type GLens' pred s a = GLens pred s s a a
53−
54−instance GProductLens (Eval pred l) pred l r l' r' a b
55− => GLens pred (l :*: r) (l' :*: r') a b where
56−
57− glens = gproductLens @(Eval pred l) @pred
58− {-# INLINE glens #-}
59−
60−instance (GLens pred l l' a b, GLens pred r r' a b) => GLens pred (l :+: r) (l' :+: r') a b where
61− glens = sumIso . choosing (glens @pred) (glens @pred)
62− {-# INLINE glens #-}
63−
64−instance GLens pred (K1 r a) (K1 r b) a b where
65− glens = kIso
66− {-# INLINE glens #-}
67−
68−instance (GLens pred f g a b) => GLens pred (M1 m meta f) (M1 m meta g) a b where
69− glens = mIso . glens @pred
70− {-# INLINE glens #-}
71−
72−class GProductLens (left :: Maybe Type) (pred :: Pred) l r l' r' a b | pred l r -> a, pred l' r' -> b where
73− gproductLens :: Lens ((l :*: r) x) ((l' :*: r') x) a b
74−
75−instance GLens pred l l' a b => GProductLens ('Just x) pred l r l' r a b where
76− gproductLens = first . glens @pred
77− {-# INLINE gproductLens #-}
78−
79−instance GLens pred r r' a b => GProductLens 'Nothing pred l r l r' a b where
80− gproductLens = second . glens @pred
81− {-# INLINE gproductLens #-}
src/Data/Generics/Product/Internal/HList.hsdeleted−329
@@ -1,329 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE CPP #-}
3−{-# LANGUAGE ConstraintKinds #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE FunctionalDependencies #-}
6−{-# LANGUAGE GADTs #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE TupleSections #-}
9−{-# LANGUAGE TypeApplications #-}
10−{-# LANGUAGE TypeFamilies #-}
11−{-# LANGUAGE TypeInType #-}
12−{-# LANGUAGE TypeOperators #-}
13−{-# LANGUAGE UndecidableInstances #-}
14−
15−#if __GLASGOW_HASKELL__ == 802
16−{-# OPTIONS_GHC -fno-solve-constant-dicts #-}
17−#endif
18−
19−
20−-----------------------------------------------------------------------------
21−-- |
22−-- Module : Data.Generics.Product.Internal.HList
23−-- Copyright : (C) 2019 Csongor Kiss
24−-- License : BSD3
25−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
26−-- Stability : experimental
27−-- Portability : non-portable
28−--
29−-- Derive an isomorphism between a product type and a flat HList.
30−--
31−-----------------------------------------------------------------------------
32−
33−module Data.Generics.Product.Internal.HList
34− ( GIsList(..)
35− , IndexList (..)
36− , HList (..)
37− , type (++)
38− , Elem
39− , ListTuple (..)
40− , TupleToList
41− ) where
42−
43−#if __GLASGOW_HASKELL__ < 804
44−import Data.Semigroup
45−#endif
46−import GHC.TypeLits
47−
48−import Data.Kind (Type)
49−import GHC.Generics
50−import Data.Profunctor
51−import Data.Generics.Internal.Profunctor.Lens
52−import Data.Generics.Internal.Profunctor.Iso
53−
54−data HList (as :: [Type]) where
55− Nil :: HList '[]
56− (:>) :: a -> HList as -> HList (a ': as)
57−
58−infixr 5 :>
59−
60−type family ((as :: [k]) ++ (bs :: [k])) :: [k] where
61− '[] ++ bs = bs
62− (a ': as) ++ bs = a ': as ++ bs
63−
64−instance Semigroup (HList '[]) where
65− _ <> _ = Nil
66−
67−instance Monoid (HList '[]) where
68− mempty = Nil
69− mappend _ _ = Nil
70−
71−instance (Semigroup a, Semigroup (HList as)) => Semigroup (HList (a ': as)) where
72− (x :> xs) <> (y :> ys) = (x <> y) :> (xs <> ys)
73−
74−instance (Monoid a, Monoid (HList as)) => Monoid (HList (a ': as)) where
75− mempty = mempty :> mempty
76− mappend (x :> xs) (y :> ys) = mappend x y :> mappend xs ys
77−
78−class Elem (as :: [(k, Type)]) (key :: k) (i :: Nat) a | as key -> i a
79−instance {-# OVERLAPPING #-} pos ~ 0 => Elem (a ': xs) key pos a
80−instance (Elem xs key i a, pos ~ (i + 1)) => Elem (x ': xs) key pos a
81−
82−class GIsList
83− (f :: Type -> Type)
84− (g :: Type -> Type)
85− (as :: [Type])
86− (bs :: [Type]) | f -> as, g -> bs, bs f -> g, as g -> f where
87−
88− glist :: Iso (f x) (g x) (HList as) (HList bs)
89−
90− -- We define this reversed version, otherwise uses of `fromIso glist` are not
91− -- properly inlined by GHC 8.0.2.
92− -- This is not actually used.
93− glistR :: Iso (HList bs) (HList as) (g x) (f x)
94− glistR = fromIso glist
95−
96−instance
97− ( GIsList l l' as as'
98− , GIsList r r' bs bs'
99− , Appending as bs cs as' bs' cs'
100− , cs ~ (as ++ bs)
101− , cs' ~ (as' ++ bs')
102− ) => GIsList (l :*: r) (l' :*: r') cs cs' where
103−
104− glist = prodIso . pairing glist glist . appending
105− {-# INLINE glist #-}
106−
107−instance GIsList f g as bs => GIsList (M1 t meta f) (M1 t meta g) as bs where
108− glist = mIso . glist
109− {-# INLINE glist #-}
110−
111−instance GIsList (Rec0 a) (Rec0 b) '[a] '[b] where
112− glist = kIso . singleton
113− {-# INLINE glist #-}
114−
115−instance GIsList U1 U1 '[] '[] where
116− glist = iso (const Nil) (const U1)
117− {-# INLINE glist #-}
118−
119−--------------------------------------------------------------------------------
120−-- | as ++ bs === cs
121−class Appending as bs cs as' bs' cs'
122− | as bs cs cs' -> as' bs'
123− , as' bs' cs cs' -> as bs
124− , as bs -> cs
125− , as' bs' -> cs'
126− where
127− appending :: Iso (HList as, HList bs) (HList as', HList bs') (HList cs) (HList cs')
128−
129−-- | [] ++ bs === bs
130−instance Appending '[] bs bs '[] bs' bs' where
131− appending = iso snd (Nil,)
132−
133−-- | (a : as) ++ bs === (a : cs)
134−instance
135− Appending as bs cs as' bs' cs' -- as ++ bs == cs
136− => Appending (a ': as) bs (a ': cs) (a' ': as') bs' (a' ': cs') where
137− appending
138− = pairing (fromIso consing) id -- ((a, as), bs)
139− . assoc3 -- (a, (as, bs))
140− . pairing id appending -- (a, cs)
141− . consing -- (a : cs)
142−
143−singleton :: Iso a b (HList '[a]) (HList '[ b])
144−singleton = iso (:> Nil) (\(x :> _) -> x)
145−
146−consing :: Iso (a, HList as) (b, HList bs) (HList (a ': as)) (HList (b ': bs))
147−consing = iso (\(x, xs) -> x :> xs) (\(x :> xs) -> (x, xs))
148−
149−--------------------------------------------------------------------------------
150−class IndexList (i :: Nat) as bs a b | i as -> a, i bs -> b, i as b -> bs, i bs a -> as where
151− point :: Lens (HList as) (HList bs) a b
152−
153−instance {-# OVERLAPPING #-}
154− ( as ~ (a ': as')
155− , bs ~ (b ': as')
156− ) => IndexList 0 as bs a b where
157− point = lens (\(x :> xs) -> (xs, x)) (\(xs, x') -> x' :> xs)
158− {-# INLINE point #-}
159−
160−instance
161− ( IndexList (n - 1) as' bs' a b
162− , as ~ (x ': as')
163− , bs ~ (x ': bs')
164− ) => IndexList n as bs a b where
165− point = fromIso consing . alongside id (point @(n-1)) . second'
166− {-# INLINE point #-}
167−
168−--------------------------------------------------------------------------------
169−-- * Convert tuples to/from HLists
170−
171−class ListTuple (tuple :: Type) (as :: [Type]) | as -> tuple where
172− type ListToTuple as :: Type
173− tupled :: Iso' (HList as) tuple
174− tupled = iso listToTuple tupleToList
175−
176− tupleToList :: tuple -> HList as
177− listToTuple :: HList as -> tuple
178−
179−instance ListTuple () '[] where
180− type ListToTuple '[] = ()
181− tupleToList _ = Nil
182− listToTuple _ = ()
183−
184−instance ListTuple a '[a] where
185− type ListToTuple '[a] = a
186− tupleToList a
187− = a :> Nil
188− listToTuple (a :> Nil)
189− = a
190−
191−instance ListTuple (a, b) '[a, b] where
192− type ListToTuple '[a, b] = (a, b)
193− tupleToList (a, b)
194− = a :> b :> Nil
195− listToTuple (a :> b :> Nil)
196− = (a, b)
197−
198−instance ListTuple (a, b, c) '[a, b, c] where
199− type ListToTuple '[a, b, c] = (a, b, c)
200− tupleToList (a, b, c)
201− = a :> b :> c :> Nil
202− listToTuple (a :> b :> c :> Nil)
203− = (a, b, c)
204−
205−instance ListTuple (a, b, c, d) '[a, b, c, d] where
206− type ListToTuple '[a, b, c, d] = (a, b, c, d)
207− tupleToList (a, b, c, d)
208− = a :> b :> c :> d:> Nil
209− listToTuple (a :> b :> c :> d :> Nil)
210− = (a, b, c, d)
211−
212−instance ListTuple (a, b, c, d, e) '[a, b, c, d, e] where
213− type ListToTuple '[a, b, c, d, e] = (a, b, c, d, e)
214− tupleToList (a, b, c, d, e)
215− = a :> b :> c :> d:> e :> Nil
216− listToTuple (a :> b :> c :> d :> e :> Nil)
217− = (a, b, c, d, e)
218−
219−instance ListTuple (a, b, c, d, e, f) '[a, b, c, d, e, f] where
220− type ListToTuple '[a, b, c, d, e, f] = (a, b, c, d, e, f)
221− tupleToList (a, b, c, d, e, f)
222− = a :> b :> c :> d:> e :> f :> Nil
223− listToTuple (a :> b :> c :> d :> e :> f :> Nil)
224− = (a, b, c, d, e, f)
225−
226−instance ListTuple (a, b, c, d, e, f, g) '[a, b, c, d, e, f, g] where
227− type ListToTuple '[a, b, c, d, e, f, g] = (a, b, c, d, e, f, g)
228− tupleToList (a, b, c, d, e, f, g)
229− = a :> b :> c :> d:> e :> f :> g :> Nil
230− listToTuple (a :> b :> c :> d :> e :> f :> g :> Nil)
231− = (a, b, c, d, e, f, g)
232−
233−instance ListTuple (a, b, c, d, e, f, g, h) '[a, b, c, d, e, f, g, h] where
234− type ListToTuple '[a, b, c, d, e, f, g, h] = (a, b, c, d, e, f, g, h)
235− tupleToList (a, b, c, d, e, f, g, h)
236− = a :> b :> c :> d:> e :> f :> g :> h :> Nil
237− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> Nil)
238− = (a, b, c, d, e, f, g, h)
239−
240−instance ListTuple (a, b, c, d, e, f, g, h, j) '[a, b, c, d, e, f, g, h, j] where
241− type ListToTuple '[a, b, c, d, e, f, g, h, j] = (a, b, c, d, e, f, g, h, j)
242− tupleToList (a, b, c, d, e, f, g, h, j)
243− = a :> b :> c :> d:> e :> f :> g :> h :> j :> Nil
244− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> Nil)
245− = (a, b, c, d, e, f, g, h, j)
246−
247−instance ListTuple (a, b, c, d, e, f, g, h, j, k) '[a, b, c, d, e, f, g, h, j, k] where
248− type ListToTuple '[a, b, c, d, e, f, g, h, j, k] = (a, b, c, d, e, f, g, h, j, k)
249− tupleToList (a, b, c, d, e, f, g, h, j, k)
250− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> Nil
251− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> Nil)
252− = (a, b, c, d, e, f, g, h, j, k)
253−
254−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l) '[a, b, c, d, e, f, g, h, j, k, l] where
255− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l] = (a, b, c, d, e, f, g, h, j, k, l)
256− tupleToList (a, b, c, d, e, f, g, h, j, k, l)
257− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> Nil
258− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> Nil)
259− = (a, b, c, d, e, f, g, h, j, k, l)
260−
261−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m) '[a, b, c, d, e, f, g, h, j, k, l, m] where
262− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m] = (a, b, c, d, e, f, g, h, j, k, l, m)
263− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m)
264− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> Nil
265− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> Nil)
266− = (a, b, c, d, e, f, g, h, j, k, l, m)
267−
268−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n) '[a, b, c, d, e, f, g, h, j, k, l, m, n] where
269− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n] = (a, b, c, d, e, f, g, h, j, k, l, m, n)
270− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n)
271− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil
272− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil)
273− = (a, b, c, d, e, f, g, h, j, k, l, m, n)
274−
275−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o] where
276− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
277− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
278− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil
279− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil)
280− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
281−
282−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p] where
283− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
284− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
285− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil
286− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil)
287− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
288−
289−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q] where
290− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
291− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
292− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil
293− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil)
294− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
295−
296−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r] where
297− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
298− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
299− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil
300− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil)
301− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
302−
303−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s] where
304− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
305− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
306− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil
307− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil)
308− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
309−
310−type family TupleToList a where
311− TupleToList () = '[]
312− TupleToList (a, b) = '[a, b]
313− TupleToList (a, b, c) = '[a, b, c]
314− TupleToList (a, b, c, d) = '[a, b, c, d]
315− TupleToList (a, b, c, d, e) = '[a, b, c, d, e]
316− TupleToList (a, b, c, d, e, f) = '[a, b, c, d, e, f]
317− TupleToList (a, b, c, d, e, f, g) = '[a, b, c, d, e, f, g]
318− TupleToList (a, b, c, d, e, f, g, h) = '[a, b, c, d, e, f, g, h]
319− TupleToList (a, b, c, d, e, f, g, h, j) = '[a, b, c, d, e, f, g, h, j]
320− TupleToList (a, b, c, d, e, f, g, h, j, k) = '[a, b, c, d, e, f, g, h, j, k]
321− TupleToList (a, b, c, d, e, f, g, h, j, k, l) = '[a, b, c, d, e, f, g, h, j, k, l]
322− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m) = '[a, b, c, d, e, f, g, h, j, k, l, m]
323− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n) = '[a, b, c, d, e, f, g, h, j, k, l, m, n]
324− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o) = '[a, b, c, d, e, f, g, h, j, k, l, m, n, o]
325− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p) = '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p]
326− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q) = '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q]
327− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r) = '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r]
328− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) = '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s]
329− TupleToList a = '[a]
src/Data/Generics/Product/Internal/Keyed.hsnew file+60
@@ -0,0 +1,60 @@
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.hsnew file+335
@@ -0,0 +1,335 @@
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+27−46
@@ -1,4 +1,3 @@
1−{-# LANGUAGE TypeInType #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
3{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ConstraintKinds #-}
4{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
@@ -17,7 +16,7 @@
17-----------------------------------------------------------------------------
16-----------------------------------------------------------------------------
18-- |
17-- |
19-- Module : Data.Generics.Product.Internal.Positions
18-- Module : Data.Generics.Product.Internal.Positions
20−-- Copyright : (C) 2019 Csongor Kiss
19+-- Copyright : (C) 2017 Csongor Kiss
21-- License : BSD3
20-- License : BSD3
22-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
23-- Stability : experimental
22-- Stability : experimental
@@ -28,61 +27,41 @@
28-----------------------------------------------------------------------------
27-----------------------------------------------------------------------------
29
28
30module Data.Generics.Product.Internal.Positions
29module Data.Generics.Product.Internal.Positions
30+ ( GHasPosition (..)
31+ , GHasPosition'
31− ( type (<?)
32+ , type (<?)
32 , Size
33 , Size
33− , CRep
34 ) where
34 ) where
35
35
36−import Data.Generics.Internal.Families.Has (Pos)
36+import Data.Generics.Product.Internal.List
37import Data.Kind (Type)
37import Data.Kind (Type)
38import Data.Type.Bool (If, Not)
38import Data.Type.Bool (If, Not)
39import GHC.Generics
39import GHC.Generics
40−import GHC.TypeLits (type (<=?), type (+), Nat)
40+import GHC.TypeLits (type (<=?), type (+), type (-), Nat)
41+import Data.Generics.Internal.Profunctor.Lens
42+import Data.Generics.Internal.Profunctor.Iso
41
43
42−-- | Alias for the kind of the generic rep
44+-- |As 'HasPosition' but over generic representations as defined by
43−type G = Type -> Type
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
44
48
45−--------------------------------------------------------------------------------
49+type GHasPosition' i s a = GHasPosition i s s a a
46
50
47−-- | In-order labeling of the generic tree with the field positions
51+instance (GHasPosition i l l' a b, GHasPosition i r r' a b) => GHasPosition i (l :+: r) (l' :+: r') a b where
48−--
52+ gposition = \x -> sumIso (choosing (gposition @i) (gposition @i) x)
49−-- We replace the (K1 R a) nodes with (K1 (Pos n) a), where 'n' is the position
53+ {-# INLINE gposition #-}
50−-- of the field in question in the data type. This is convenient, because we
51−-- can reuse all the existing functions as long as they are polymorphic in the
52−-- first parameter of 'K1'.
53−type family CRep (a :: Type) :: G where
54− CRep rep = Fst (Traverse (Rep rep) 1)
55
54
56−-- | The actual traversal.
55+instance GHasPosition i s t a b => GHasPosition i (M1 D meta s) (M1 D meta t) a b where
57−--
56+ gposition x = mLens (gposition @i x)
58−-- Might be cleaner if the sum and product parts were separated (as there's
57+ {-# INLINE gposition #-}
59−-- and invariant that 'n' should be zero when we're at a sum node, which holds
60−-- for derived Generic instances (where the sums are strictly above the products))
61−type family Traverse (a :: G) (n :: Nat) :: (G, Nat) where
62− Traverse (M1 mt m s) n
63− = Traverse1 (M1 mt m) (Traverse s n)
64− Traverse (l :+: r) n
65− = '(Fst (Traverse l n) :+: Fst (Traverse r n), n)
66− Traverse (l :*: r) n
67− = TraverseProd (:*:) (Traverse l n) r
68− Traverse (K1 _ p) n
69− = '(K1 (Pos n) p, n + 1)
70− Traverse U1 n
71− = '(U1, n)
72
58
73−type family Traverse1 (w :: G -> G) (z :: (G, Nat)) :: (G, Nat) where
59+instance
74− Traverse1 w '(i, n) = '(w i, n)
60+ ( IndexList (i - 1) as bs a b
75−
61+ , GIsList () f g as bs
76−-- | For products, we first traverse the left-hand side, followed by the second
62+ ) => GHasPosition i (M1 C meta f) (M1 C meta g) a b where
77−-- using the counter returned by the left traversal.
63+ gposition x = mIso (glist @() (point @(i - 1) x))
78−type family TraverseProd (c :: G -> G -> G) (a :: (G, Nat)) (r :: G) :: (G, Nat) where
64+ {-# INLINE gposition #-}
79− TraverseProd w '(i, n) r = Traverse1 (w i) (Traverse r n)
80−
81−--------------------------------------------------------------------------------
82−-- Utilities
83−
84−type family Fst (p :: (a, b)) :: a where
85− Fst '(a, b) = a
86
65
87type family Size f :: Nat where
66type family Size f :: Nat where
88 Size (l :*: r)
67 Size (l :*: r)
@@ -96,6 +75,8 @@ type family Size f :: Nat where
96 Size f
75 Size f
97 = 1
76 = 1
98
77
78+--------------------------------------------------------------------------------
79+
99type x <? y = Not (y <=? x)
80type x <? y = Not (y <=? x)
100infixl 4 <?
81infixl 4 <?
101
82
src/Data/Generics/Product/Internal/Subtype.hs+10−15
@@ -1,4 +1,3 @@
1−{-# LANGUAGE TypeInType #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
3{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
@@ -16,7 +15,7 @@
16-----------------------------------------------------------------------------
15-----------------------------------------------------------------------------
17-- |
16-- |
18-- Module : Data.Generics.Product.Internal.Subtype
17-- Module : Data.Generics.Product.Internal.Subtype
19−-- Copyright : (C) 2019 Csongor Kiss
18+-- Copyright : (C) 2017 Csongor Kiss
20-- License : BSD3
19-- License : BSD3
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
22-- Stability : experimental
21-- Stability : experimental
@@ -32,12 +31,11 @@ module Data.Generics.Product.Internal.Subtype
32 ) where
31 ) where
33
32
34import Data.Generics.Internal.Families
33import Data.Generics.Internal.Families
35−import Data.Generics.Product.Internal.GLens
34+import Data.Generics.Product.Internal.Keyed
36
35
37import Data.Kind (Type)
36import Data.Kind (Type)
38import GHC.Generics
37import GHC.Generics
39−import GHC.TypeLits (Symbol)
40−import Data.Generics.Internal.Profunctor.Lens (view)
38+import Data.Generics.Internal.Profunctor.Lens
41
39
42--------------------------------------------------------------------------------
40--------------------------------------------------------------------------------
43-- * Generic upcasting
41-- * Generic upcasting
@@ -49,10 +47,10 @@ instance (GUpcast sub a, GUpcast sub b) => GUpcast sub (a :*: b) where
49 gupcast rep = gupcast rep :*: gupcast rep
47 gupcast rep = gupcast rep :*: gupcast rep
50
48
51instance
49instance
52− GLens' (HasTotalFieldPSym field) sub t
50+ GHasKey field sub sub t t
53 => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
51 => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
54
52
55− gupcast r = M1 (K1 (view (glens @(HasTotalFieldPSym field)) r))
53+ gupcast r = M1 (K1 (view (gkey @field) r))
56
54
57instance GUpcast sub sup => GUpcast sub (C1 c sup) where
55instance GUpcast sub sup => GUpcast sub (C1 c sup) where
58 gupcast = M1 . gupcast
56 gupcast = M1 . gupcast
@@ -82,16 +80,13 @@ instance GSmash sub sup => GSmash (C1 c sub) sup where
82instance GSmash sub sup => GSmash (D1 c sub) sup where
80instance GSmash sub sup => GSmash (D1 c sub) sup where
83 gsmash sup (M1 sub) = M1 (gsmash sup sub)
81 gsmash sup (M1 sub) = M1 (gsmash sup sub)
84
82
85−class GSmashLeaf sub sup (w :: Maybe Type) where
83+class GSmashLeaf sub sup (w :: Bool) where
86 gsmashLeaf :: sup p -> sub p -> sub p
84 gsmashLeaf :: sup p -> sub p -> sub p
87
85
88instance
86instance
89− GLens' (HasTotalFieldPSym field) sup t
87+ GHasKey field sup sup t t
90− => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup ('Just t) where
88+ => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'True where
91− gsmashLeaf sup _ = M1 (K1 (view (glens @(HasTotalFieldPSym field)) sup))
89+ gsmashLeaf sup _ = M1 (K1 (view (gkey @field) sup))
92
90
93−instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'Nothing where
91+instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'False where
94 gsmashLeaf _ = id
92 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.hsnew file+78
@@ -0,0 +1,78 @@
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+3−10
@@ -15,13 +15,13 @@
15--------------------------------------------------------------------------------
15--------------------------------------------------------------------------------
16-- |
16-- |
17-- Module : Data.Generics.Product.Param
17-- Module : Data.Generics.Product.Param
18−-- Copyright : (C) 2019 Csongor Kiss
18+-- Copyright : (C) 2018 Csongor Kiss
19−-- License : BSD3
20-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20+-- License : BSD3
21-- Stability : experimental
21-- Stability : experimental
22-- Portability : non-portable
22-- Portability : non-portable
23--
23--
24−-- Derive traversals over type parameters
24+-- Derive traversal over type parameters
25--
25--
26--------------------------------------------------------------------------------
26--------------------------------------------------------------------------------
27
27
@@ -39,7 +39,6 @@ import GHC.Generics
39import Data.Kind
39import Data.Kind
40import Data.Generics.Internal.VL.Iso
40import Data.Generics.Internal.VL.Iso
41import Data.Generics.Internal.GenericN
41import Data.Generics.Internal.GenericN
42−import Data.Generics.Internal.Errors
43
42
44class HasParam (p :: Nat) s t a b | p t a -> s, p s b -> t, p s -> a, p t -> b where
43class HasParam (p :: Nat) s t a b | p t a -> s, p s b -> t, p s -> a, p t -> b where
45 param :: Applicative g => (a -> g b) -> s -> g t
44 param :: Applicative g => (a -> g b) -> s -> g t
@@ -48,12 +47,6 @@ instance
48 ( GenericN s
47 ( GenericN s
49 , GenericN t
48 , GenericN t
50 -- TODO: merge the old 'Changing' code with 'GenericN'
49 -- TODO: merge the old 'Changing' code with 'GenericN'
51− , Defined (Rep s)
52− (NoGeneric s
53− '[ 'Text "arising from a generic traversal of the type parameter at position " ':<>: QuoteType n
54− , 'Text "of type " ':<>: QuoteType a ':<>: 'Text " in " ':<>: QuoteType s
55− ])
56− (() :: Constraint)
57 , s ~ Infer t (P n b 'PTag) a
50 , s ~ Infer t (P n b 'PTag) a
58 , t ~ Infer s (P n a 'PTag) b
51 , t ~ Infer s (P n a 'PTag) b
59 , Error ((ArgCount s) <=? n) n (ArgCount s) s
52 , Error ((ArgCount s) <=? n) n (ArgCount s) s
src/Data/Generics/Product/Positions.hs+24−109
@@ -1,5 +1,3 @@
1−{-# LANGUAGE TypeInType #-}
2−{-# LANGUAGE PartialTypeSignatures #-}
3{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
4{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
5{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE ConstraintKinds #-}
@@ -19,7 +17,7 @@
19-----------------------------------------------------------------------------
17-----------------------------------------------------------------------------
20-- |
18-- |
21-- Module : Data.Generics.Product.Positions
19-- Module : Data.Generics.Product.Positions
22−-- Copyright : (C) 2019 Csongor Kiss
20+-- Copyright : (C) 2017 Csongor Kiss
23-- License : BSD3
21-- License : BSD3
24-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
22-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
25-- Stability : experimental
23-- Stability : experimental
@@ -35,8 +33,6 @@ module Data.Generics.Product.Positions
35 -- $setup
33 -- $setup
36 HasPosition (..)
34 HasPosition (..)
37 , HasPosition' (..)
35 , HasPosition' (..)
38− , HasPosition_ (..)
39− , HasPosition0 (..)
40
36
41 , getPosition
37 , getPosition
42 , setPosition
38 , setPosition
@@ -46,15 +42,12 @@ import Data.Generics.Internal.VL.Lens as VL
46import Data.Generics.Internal.Void
42import Data.Generics.Internal.Void
47import Data.Generics.Internal.Families
43import Data.Generics.Internal.Families
48import Data.Generics.Product.Internal.Positions
44import Data.Generics.Product.Internal.Positions
49−import Data.Generics.Product.Internal.GLens
50−import Data.Generics.Internal.Errors
51
45
52import Data.Kind (Constraint, Type)
46import Data.Kind (Constraint, Type)
53import Data.Type.Bool (type (&&))
47import Data.Type.Bool (type (&&))
54import GHC.Generics
48import GHC.Generics
55import GHC.TypeLits (type (<=?), Nat, TypeError, ErrorMessage(..))
49import GHC.TypeLits (type (<=?), Nat, TypeError, ErrorMessage(..))
56−import Data.Generics.Internal.Profunctor.Lens as P
50+import Data.Generics.Internal.Profunctor.Lens
57−import Data.Coerce
58
51
59-- $setup
52-- $setup
60-- == /Running example:/
53-- == /Running example:/
@@ -96,126 +89,51 @@ class HasPosition (i :: Nat) s t a b | s i -> a, t i -> b, s i b -> t, t i a ->
96 -- ...
89 -- ...
97 position :: VL.Lens s t a b
90 position :: VL.Lens s t a b
98
91
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_'.
108class HasPosition' (i :: Nat) s a | s i -> a where
92class HasPosition' (i :: Nat) s a | s i -> a where
109 position' :: VL.Lens s s a a
93 position' :: VL.Lens s s a a
110
94
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
121getPosition :: forall i s a. HasPosition' i s a => s -> a
95getPosition :: forall i s a. HasPosition' i s a => s -> a
122getPosition s = s ^. position' @i
96getPosition s = s ^. position' @i
123
97
124−-- |
125−-- >>> setPosition @2 60 human
126−-- Human {name = "Tunyasz", age = 60, address = "London"}
127setPosition :: forall i s a. HasPosition' i s a => a -> s -> s
98setPosition :: forall i s a. HasPosition' i s a => a -> s -> s
128setPosition = VL.set (position' @i)
99setPosition = VL.set (position' @i)
129
100
130instance
101instance
131 ( Generic s
102 ( Generic s
132 , ErrorUnless i s (0 <? i && i <=? Size (Rep s))
103 , ErrorUnless i s (0 <? i && i <=? Size (Rep s))
133− , cs ~ CRep s
104+ , GHasPosition' i (Rep s) a
134− , Coercible (Rep s) cs
135− , GLens' (HasTotalPositionPSym i) cs a
136− , Defined (Rep s)
137− (NoGeneric s '[ 'Text "arising from a generic lens focusing on the field at"
138− , 'Text "position " ':<>: QuoteType i ':<>: 'Text " of type " ':<>: QuoteType a
139− ':<>: 'Text " in " ':<>: QuoteType s
140− ])
141− (() :: Constraint)
142 ) => HasPosition' i s a where
105 ) => HasPosition' i s a where
143− position' f s = VL.ravel (repLens . coerced @cs @cs . glens @(HasTotalPositionPSym i)) f s
106+ position' f s = VL.ravel (repLens . gposition @i) f s
144 {-# INLINE position' #-}
107 {-# INLINE position' #-}
145
108
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−
151instance -- see Note [Changing type parameters]
109instance -- see Note [Changing type parameters]
110+ ( Generic s
152− ( ErrorUnless i s (0 <? i && i <=? Size (Rep s))
111+ , ErrorUnless i s (0 <? i && i <=? Size (Rep s))
153− , HasTotalPositionP i (CRep s) ~~ 'Just a
112+ , Generic t
154− , HasTotalPositionP i (CRep t) ~~ 'Just b
113+ -- see Note [CPP in instance constraints]
155− , HasTotalPositionP i (CRep (Indexed s)) ~~ 'Just a'
114+#if __GLASGOW_HASKELL__ < 802
156− , HasTotalPositionP i (CRep (Indexed t)) ~~ 'Just b'
115+ , '(s', t') ~ '(Proxied s, Proxied t)
157− , t ~~ Infer s a' b
116+#else
158− , s ~~ Infer t b' a
117+ , s' ~ Proxied s
159− , Coercible (CRep s) (Rep s)
118+ , t' ~ Proxied t
160− , Coercible (CRep t) (Rep t)
119+#endif
161− , HasPosition0 i s t a b
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
162 ) => HasPosition i s t a b where
128 ) => HasPosition i s t a b where
163
129
164− position = position0 @i
130+ position = VL.ravel (repLens . gposition @i)
165 {-# INLINE position #-}
131 {-# INLINE position #-}
166
132
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]
133+-- 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
185instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where
134instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where
186 position = undefined
135 position = undefined
187
136
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−
219type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint where
137type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint where
220 ErrorUnless i s 'False
138 ErrorUnless i s 'False
221 = TypeError
139 = TypeError
@@ -227,6 +145,3 @@ type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint wher
227
145
228 ErrorUnless _ _ 'True
146 ErrorUnless _ _ 'True
229 = ()
147 = ()
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+3−43
@@ -1,4 +1,3 @@
1−{-# LANGUAGE CPP #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
3{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
@@ -16,7 +15,7 @@
16-----------------------------------------------------------------------------
15-----------------------------------------------------------------------------
17-- |
16-- |
18-- Module : Data.Generics.Product.Subtype
17-- Module : Data.Generics.Product.Subtype
19−-- Copyright : (C) 2019 Csongor Kiss
18+-- Copyright : (C) 2017 Csongor Kiss
20-- License : BSD3
19-- License : BSD3
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
22-- Stability : experimental
21-- Stability : experimental
@@ -42,7 +41,6 @@ import GHC.Generics (Generic (Rep, to, from) )
42import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
41import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
43import Data.Kind (Type, Constraint)
42import Data.Kind (Type, Constraint)
44import Data.Generics.Internal.Profunctor.Lens hiding (set)
43import Data.Generics.Internal.Profunctor.Lens hiding (set)
45−import Data.Generics.Internal.Errors
46
44
47-- $setup
45-- $setup
48-- == /Running example:/
46-- == /Running example:/
@@ -115,52 +113,14 @@ instance
115 , Generic b
113 , Generic b
116 , GSmash (Rep a) (Rep b)
114 , GSmash (Rep a) (Rep b)
117 , GUpcast (Rep a) (Rep b)
115 , GUpcast (Rep a) (Rep b)
118− , CustomError a b
116+ , ErrorUnless b a (CollectFieldsOrdered (Rep b) \\ CollectFieldsOrdered (Rep a))
119 ) => Subtype b a where
117 ) => Subtype b a where
120 smash p b = to $ gsmash (from p) (from b)
118 smash p b = to $ gsmash (from p) (from b)
121 upcast = to . gupcast . from
119 upcast = to . gupcast . from
122
120
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]
121+-- 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
151instance {-# OVERLAPPING #-} Subtype a Void where
122instance {-# OVERLAPPING #-} Subtype a Void where
152 super = undefined
123 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
164instance {-# OVERLAPPING #-} Subtype Void a where
124instance {-# OVERLAPPING #-} Subtype Void a where
165 super = undefined
125 super = undefined
166
126
src/Data/Generics/Product/Typed.hs+5−31
@@ -1,4 +1,3 @@
1−{-# LANGUAGE CPP #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
3{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
@@ -8,14 +7,13 @@
8{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE TypeApplications #-}
8{-# LANGUAGE TypeApplications #-}
10{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE TypeFamilies #-}
11−{-# LANGUAGE TypeInType #-}
12{-# LANGUAGE TypeOperators #-}
10{-# LANGUAGE TypeOperators #-}
13{-# LANGUAGE UndecidableInstances #-}
11{-# LANGUAGE UndecidableInstances #-}
14
12
15-----------------------------------------------------------------------------
13-----------------------------------------------------------------------------
16-- |
14-- |
17-- Module : Data.Generics.Product.Typed
15-- Module : Data.Generics.Product.Typed
18−-- Copyright : (C) 2019 Csongor Kiss
16+-- Copyright : (C) 2017 Csongor Kiss
19-- License : BSD3
17-- License : BSD3
20-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
18-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21-- Stability : experimental
19-- Stability : experimental
@@ -35,13 +33,12 @@ module Data.Generics.Product.Typed
35import Data.Generics.Internal.Families
33import Data.Generics.Internal.Families
36import Data.Generics.Internal.VL.Lens as VL
34import Data.Generics.Internal.VL.Lens as VL
37import Data.Generics.Internal.Void
35import Data.Generics.Internal.Void
38−import Data.Generics.Product.Internal.GLens
36+import Data.Generics.Product.Internal.Keyed
39
37
40import Data.Kind (Constraint, Type)
38import Data.Kind (Constraint, Type)
41import GHC.Generics (Generic (Rep))
39import GHC.Generics (Generic (Rep))
42import GHC.TypeLits (TypeError, ErrorMessage (..))
40import GHC.TypeLits (TypeError, ErrorMessage (..))
43import Data.Generics.Internal.Profunctor.Lens
41import Data.Generics.Internal.Profunctor.Lens
44−import Data.Generics.Internal.Errors
45
42
46-- $setup
43-- $setup
47-- == /Running example:/
44-- == /Running example:/
@@ -113,31 +110,12 @@ class HasType a s where
113instance
110instance
114 ( Generic s
111 ( Generic s
115 , ErrorUnlessOne a s (CollectTotalType a (Rep s))
112 , ErrorUnlessOne a s (CollectTotalType a (Rep s))
116− , Defined (Rep s)
117− (NoGeneric s '[ 'Text "arising from a generic lens focusing on a field of type " ':<>: QuoteType a])
118− (() :: Constraint)
119− , GLens (HasTotalTypePSym a) (Rep s) (Rep s) a a
113+ , GHasKey a (Rep s) (Rep s) a a
120 ) => HasType a s where
114 ) => HasType a s where
121
115
122− typed f s = VL.ravel (repLens . glens @(HasTotalTypePSym a)) f s
116+ typed f s = VL.ravel (repLens . gkey @a) f s
123
117
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]
118+-- 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.
141instance {-# OVERLAPPING #-} HasType a Void where
119instance {-# OVERLAPPING #-} HasType a Void where
142 typed = undefined
120 typed = undefined
143
121
@@ -172,7 +150,3 @@ type family ErrorUnlessOne (a :: Type) (s :: Type) (stat :: TypeStat) :: Constra
172
150
173 ErrorUnlessOne _ _ ('TypeStat '[] '[] _)
151 ErrorUnlessOne _ _ ('TypeStat '[] '[] _)
174 = ()
152 = ()
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+68−272
@@ -16,7 +16,7 @@
16-----------------------------------------------------------------------------
16-----------------------------------------------------------------------------
17-- |
17-- |
18-- Module : Data.Generics.Product.Types
18-- Module : Data.Generics.Product.Types
19−-- Copyright : (C) 2019 Csongor Kiss
19+-- Copyright : (C) 2017 Csongor Kiss
20-- License : BSD3
20-- License : BSD3
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
22-- Stability : experimental
22-- Stability : experimental
@@ -29,65 +29,18 @@
29module Data.Generics.Product.Types
29module Data.Generics.Product.Types
30 ( -- *Traversals
30 ( -- *Traversals
31 --
31 --
32− -- $setup
32+ -- $example
33 HasTypes
33 HasTypes
34 , types
34 , types
35−
36− -- * Custom traversal strategies
37− -- $custom
38− , Children
39− , ChGeneric
40−
41− , HasTypesUsing
42− , typesUsing
43−
44− , HasTypesCustom (typesCustom)
45−
46 ) where
35 ) where
47
36
48import Data.Kind
37import Data.Kind
49−import Data.Int (Int8, Int16, Int32, Int64)
50−import Data.Word (Word, Word8, Word16, Word32, Word64)
51−import qualified Data.Text as T
52
38
53import GHC.Generics
39import GHC.Generics
54−import GHC.TypeLits
55import Data.Generics.Internal.VL.Traversal
40import Data.Generics.Internal.VL.Traversal
56−import Data.Generics.Internal.Errors
57−
58−-- $setup
59−-- == /Running example:/
60−--
61−-- >>> :set -XTypeApplications
62−-- >>> :set -XDeriveGeneric
63−-- >>> :set -XScopedTypeVariables
64−-- >>> import GHC.Generics
65−-- >>> :m +Data.Generics.Internal.VL.Traversal
66−-- >>> :m +Data.Generics.Internal.VL.Lens
67−-- >>> :{
68−-- data WTree a w
69−-- = Leaf a
70−-- | Fork (WTree a w) (WTree a w)
71−-- | WithWeight (WTree a w) w
72−-- deriving (Generic, Show)
73−-- :}
74−
75−--------------------------------------------------------------------------------
76−-- HasTypes
77−--------------------------------------------------------------------------------
78
41
79-- TODO [1.0.0.0]: use type-changing variant internally
42-- TODO [1.0.0.0]: use type-changing variant internally
80
43
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.
91types :: forall a s. HasTypes s a => Traversal' s a
44types :: forall a s. HasTypes s a => Traversal' s a
92types = types_ @s @a
45types = types_ @s @a
93{-# INLINE types #-}
46{-# INLINE types #-}
@@ -100,268 +53,111 @@ class HasTypes s a where
100 {-# INLINE types_ #-}
53 {-# INLINE types_ #-}
101
54
102instance
55instance
103− ( HasTypesUsing ChGeneric s a
56+ ( HasTypes' (Interesting s a) s a
104 ) => HasTypes s a where
57 ) => HasTypes s a where
105− types_ = typesUsing_ @ChGeneric
58+ types_ = types' @(Interesting s a)
106 {-# INLINE types_ #-}
59 {-# INLINE types_ #-}
107
60
108−--------------------------------------------------------------------------------
61+class HasTypes' (t :: Bool) s a where
109−data Void
62+ types' :: Traversal' s a
110−instance {-# OVERLAPPING #-} HasTypes Void a where
111− types_ _ = pure
112−
113−instance {-# OVERLAPPING #-} HasTypes s Void where
114− types_ _ = pure
115−
116−instance {-# OVERLAPPING #-} HasTypesUsing ch Void a where
117− typesUsing_ _ = pure
118
63
119−instance {-# OVERLAPPING #-} HasTypesUsing ch s Void where
64+instance
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
65+ ( GHasTypes (Rep s) a
211 , Generic s
66 , Generic s
212− -- if there's no Generic instance here, it means we got through the
67+ ) => HasTypes' 'True s a where
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)
68+ types' f s = to <$> gtypes_ f (from s)
221 --{-# INLINE types' #-}
69 --{-# INLINE types' #-}
222
70
71+instance HasTypes' 'False s a where
72+ types' _ = pure
73+ --{-# INLINE types' #-}
223
74
224−-- | The default definition of 'Children'.
75+instance {-# OVERLAPPING #-} HasTypes Bool a
225−-- Primitive types from core libraries have no children, and other types are
76+instance {-# OVERLAPPING #-} HasTypes Char a
226−-- assumed to be 'Generic'.
77+instance {-# OVERLAPPING #-} HasTypes Double a
227−data ChGeneric
78+instance {-# OVERLAPPING #-} HasTypes Float a
228−type instance Children ChGeneric a = ChildrenDefault a
79+instance {-# OVERLAPPING #-} HasTypes Int a
229−
80+instance {-# OVERLAPPING #-} HasTypes Integer a
230−type family ChildrenDefault (a :: Type) :: [Type] where
81+instance {-# OVERLAPPING #-} HasTypes Ordering a
231− ChildrenDefault Char = '[]
232− ChildrenDefault Double = '[]
233− ChildrenDefault Float = '[]
234− ChildrenDefault Integer = '[]
235− ChildrenDefault Int = '[]
236− ChildrenDefault Int8 = '[]
237− ChildrenDefault Int16 = '[]
238− ChildrenDefault Int32 = '[]
239− ChildrenDefault Int64 = '[]
240− ChildrenDefault Word = '[]
241− ChildrenDefault Word8 = '[]
242− ChildrenDefault Word16 = '[]
243− ChildrenDefault Word32 = '[]
244− ChildrenDefault Word64 = '[]
245− ChildrenDefault T.Text = '[]
246− ChildrenDefault a
247− = Defined (Rep a)
248− (NoGeneric a
249− '[ 'Text "arising from a generic traversal."
250− , 'Text "Either derive the instance, or define a custom traversal using " ':<>: QuoteType HasTypesCustom
251− ])
252− (ChildrenGeneric (Rep a) '[])
253−
254−type family ChildrenGeneric (f :: k -> Type) (cs :: [Type]) :: [Type] where
255− ChildrenGeneric (M1 _ _ f) cs = ChildrenGeneric f cs
256− ChildrenGeneric (l :*: r) cs = ChildrenGeneric l (ChildrenGeneric r cs)
257− ChildrenGeneric (l :+: r) cs = ChildrenGeneric l (ChildrenGeneric r cs)
258− ChildrenGeneric (Rec0 a) cs = a ': cs
259− ChildrenGeneric _ cs = cs
260−
261−--------------------------------------------------------------------------------
262−-- Internals
263−--------------------------------------------------------------------------------
264−-- TODO: these should never leak out in error messages
265−
266−class HasTypesOpt (ch :: Type) (t :: Bool) s a where
267− typesOpt :: Traversal' s a
268−
269−instance HasTypesCustom ch s a => HasTypesOpt ch 'True s a where
270− typesOpt = typesCustom @ch
271−
272−instance HasTypesOpt ch 'False s a where
273− typesOpt _ = pure
274− --{-# INLINE typesOpt #-}
275
82
276--------------------------------------------------------------------------------
83--------------------------------------------------------------------------------
277
84
278−class GHasTypes ch s a where
85+class GHasTypes s a where
279 gtypes_ :: Traversal' (s x) a
86 gtypes_ :: Traversal' (s x) a
280
87
281instance
88instance
282− ( GHasTypes ch l a
89+ ( GHasTypes l a
283− , GHasTypes ch r a
90+ , GHasTypes r a
284− ) => GHasTypes ch (l :*: r) a where
91+ ) => GHasTypes (l :*: r) a where
285− gtypes_ f (l :*: r) = (:*:) <$> gtypes_ @ch f l <*> gtypes_ @ch f r
92+ gtypes_ f (l :*: r) = (:*:) <$> gtypes_ f l <*> gtypes_ f r
286 {-# INLINE gtypes_ #-}
93 {-# INLINE gtypes_ #-}
287
94
288instance
95instance
289− ( GHasTypes ch l a
96+ ( GHasTypes l a
290− , GHasTypes ch r a
97+ , GHasTypes r a
291− ) => GHasTypes ch (l :+: r) a where
98+ ) => GHasTypes (l :+: r) a where
292− gtypes_ f (L1 l) = L1 <$> gtypes_ @ch f l
99+ gtypes_ f (L1 l) = L1 <$> gtypes_ f l
293− gtypes_ f (R1 r) = R1 <$> gtypes_ @ch f r
100+ gtypes_ f (R1 r) = R1 <$> gtypes_ f r
294 {-# INLINE gtypes_ #-}
101 {-# INLINE gtypes_ #-}
295
102
296−instance (GHasTypes ch s a) => GHasTypes ch (M1 m meta s) a where
103+instance (GHasTypes s a) => GHasTypes (M1 m meta s) a where
297− gtypes_ f (M1 s) = M1 <$> gtypes_ @ch f s
104+ gtypes_ f (M1 s) = M1 <$> gtypes_ f s
298 {-# INLINE gtypes_ #-}
105 {-# INLINE gtypes_ #-}
299
106
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
107+instance {-# OVERLAPPING #-} GHasTypes (Rec0 a) a where
303− gtypes_ f (K1 x) = K1 <$> typesUsing_ @ch @b @a f x
108+ gtypes_ f (K1 x) = K1 <$> f x
304 {-# INLINE gtypes_ #-}
109 {-# INLINE gtypes_ #-}
305
110
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
111+instance HasTypes b a => GHasTypes (Rec0 b) a where
313− gtypes_ f (K1 x) = K1 <$> types_ @b @a f x
112+ gtypes_ f (K1 x) = K1 <$> types_ @_ @a f x
314 {-# INLINE gtypes_ #-}
113 {-# INLINE gtypes_ #-}
315
114
316−instance GHasTypes ch U1 a where
115+instance GHasTypes U1 a where
317 gtypes_ _ _ = pure U1
116 gtypes_ _ _ = pure U1
318 {-# INLINE gtypes_ #-}
117 {-# INLINE gtypes_ #-}
319
118
320−instance GHasTypes ch V1 a where
119+instance GHasTypes V1 a where
321 gtypes_ _ = pure
120 gtypes_ _ = pure
322 {-# INLINE gtypes_ #-}
121 {-# INLINE gtypes_ #-}
323
122
324−type Interesting (ch :: Type) (a :: Type) (t :: Type)
123+type Interesting f a = Snd (Interesting' (Rep f) a '[f])
325− = Defined_list (Children ch t) (NoChildren ch t)
124+
125+type family Interesting' f (a :: Type) (seen :: [Type]) :: ([Type], Bool) where
126+ Interesting' (M1 _ m f) t seen
326− (IsNothing (Interesting' ch a '[t] (Children ch t)))
127+ = Interesting' f t seen
327−
128+ -- The result of the left branch is passed on to the right branch in order to avoid duplicate work
328−type family NoChildren (ch :: Type) (a :: Type) :: Constraint where
129+ Interesting' (l :*: r) t seen
329− NoChildren ch a = PrettyError
130+ = InterestingOr (Interesting' l t seen) r t
330− '[ 'Text "No type family instance for " ':<>: QuoteType (Children ch a)
131+ Interesting' (l :+: r) t seen
331− , 'Text "arising from a traversal over " ':<>: QuoteType a
132+ = InterestingOr (Interesting' l t seen) r t
332− , 'Text "with custom strategy " ':<>: QuoteType ch
133+ Interesting' (Rec0 t) t seen
333− ]
134+ = '(seen, 'True)
334−
135+ Interesting' (Rec0 Char) _ seen = '(seen ,'False)
335−
136+ Interesting' (Rec0 Double) _ seen = '(seen ,'False)
336−type family Interesting' (ch :: Type) (a :: Type) (seen :: [Type]) (ts :: [Type]) :: Maybe [Type] where
137+ Interesting' (Rec0 Float) _ seen = '(seen ,'False)
337− Interesting' ch _ seen '[] = 'Just seen
138+ Interesting' (Rec0 Int) _ seen = '(seen ,'False)
338− Interesting' ch a seen (t ': ts) =
139+ Interesting' (Rec0 Integer) _ seen = '(seen ,'False)
140+ Interesting' (Rec0 r) t seen
339− InterestingOr ch a (InterestingUnless ch a seen t (Elem t seen)) ts
141+ = InterestingUnless (Elem r seen) (Rep r) t r seen
142+ Interesting' _ _ seen
143+ = '(seen, 'False)
340
144
341-- Short circuit
145-- Short circuit
342−-- Note: we only insert 't' to the seen list if it's not already there (which is precisely when `s` is 'False)
146+-- Note: we only insert 'r' to the seen list if it's not already there (which is precisely when `s` is 'False)
343−type family InterestingUnless
147+type family InterestingUnless (s :: Bool) f (a :: Type) (r :: Type) (seen :: [Type]) :: ([Type], Bool) where
344− (ch :: Type) (a :: Type) (seen :: [Type]) (t :: Type) (alreadySeen :: Bool) ::
345− Maybe [Type] where
346− InterestingUnless ch a seen a _ = 'Nothing
148+ InterestingUnless 'True _ _ _ seen = '(seen, 'False)
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))
149+ InterestingUnless 'False f a r seen = Interesting' f a (r ': seen)
351
150
352-- Short circuit
151-- Short circuit
353−type family InterestingOr
152+type family InterestingOr (b :: ([Type], Bool)) r t :: ([Type], Bool) where
354− (ch :: Type) (a :: Type) (seen' :: Maybe [Type]) (ts :: [Type]) ::
355− Maybe [Type] where
356− InterestingOr ch a 'Nothing _ = 'Nothing
153+ InterestingOr '(seen, 'True) _ _ = '(seen, 'True)
357− InterestingOr ch a ('Just seen) ts = Interesting' ch a seen ts
154+ InterestingOr '(seen, 'False) r t = Interesting' r t seen
358
155
359type family Elem a as where
156type family Elem a as where
360 Elem a (a ': _) = 'True
157 Elem a (a ': _) = 'True
361 Elem a (_ ': as) = Elem a as
158 Elem a (_ ': as) = Elem a as
362 Elem a '[] = 'False
159 Elem a '[] = 'False
363
160
364−type family IsNothing a where
161+type family Snd a where
365− IsNothing ('Just _) = 'False
162+ Snd '(_, b) = b
366− IsNothing 'Nothing = 'True
367
163
src/Data/Generics/Sum.hs+1−1
@@ -1,7 +1,7 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2-- |
2-- |
3-- Module : Data.Generics.Sum
3-- Module : Data.Generics.Sum
4−-- Copyright : (C) 2019 Csongor Kiss
4+-- Copyright : (C) 2017 Csongor Kiss
5-- License : BSD3
5-- License : BSD3
6-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
6-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
7-- Stability : experimental
7-- Stability : experimental
src/Data/Generics/Sum/Any.hs+2−2
@@ -11,7 +11,7 @@
11-----------------------------------------------------------------------------
11-----------------------------------------------------------------------------
12-- |
12-- |
13-- Module : Data.Generics.Sum.Any
13-- Module : Data.Generics.Sum.Any
14−-- Copyright : (C) 2019 Csongor Kiss
14+-- Copyright : (C) 2017 Csongor Kiss
15-- License : BSD3
15-- License : BSD3
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17-- Stability : experimental
17-- Stability : experimental
@@ -61,7 +61,7 @@ import Data.Generics.Internal.VL.Prism
61-- :}
61-- :}
62
62
63-- |Sums that have generic prisms.
63-- |Sums that have generic prisms.
64−class AsAny sel a s | s sel -> a where
64+class AsAny (sel :: k) a s | s sel k -> a where
65 -- |A prism that projects a sum as identified by some selector. Currently
65 -- |A prism that projects a sum as identified by some selector. Currently
66 -- supported selectors are constructor names and unique types. Compatible
66 -- supported selectors are constructor names and unique types. Compatible
67 -- with the lens package's 'Control.Lens.Prism' type.
67 -- with the lens package's 'Control.Lens.Prism' type.
src/Data/Generics/Sum/Constructors.hs+19−76
@@ -15,7 +15,7 @@
15-----------------------------------------------------------------------------
15-----------------------------------------------------------------------------
16-- |
16-- |
17-- Module : Data.Generics.Sum.Constructors
17-- Module : Data.Generics.Sum.Constructors
18−-- Copyright : (C) 2019 Csongor Kiss
18+-- Copyright : (C) 2017 Csongor Kiss
19-- License : BSD3
19-- License : BSD3
20-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21-- Stability : experimental
21-- Stability : experimental
@@ -30,9 +30,7 @@ module Data.Generics.Sum.Constructors
30
30
31 -- $setup
31 -- $setup
32 AsConstructor (..)
32 AsConstructor (..)
33− , AsConstructor_ (..)
34 , AsConstructor' (..)
33 , AsConstructor' (..)
35− , AsConstructor0 (..)
36 ) where
34 ) where
37
35
38import Data.Generics.Internal.Families
36import Data.Generics.Internal.Families
@@ -45,7 +43,6 @@ import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
45import Data.Generics.Internal.VL.Prism
43import Data.Generics.Internal.VL.Prism
46import Data.Generics.Internal.Profunctor.Iso
44import Data.Generics.Internal.Profunctor.Iso
47import Data.Generics.Internal.Profunctor.Prism (prismPRavel)
45import Data.Generics.Internal.Profunctor.Prism (prismPRavel)
48−import Data.Generics.Internal.Errors
49
46
50-- $setup
47-- $setup
51-- == /Running example:/
48-- == /Running example:/
@@ -71,7 +68,7 @@ import Data.Generics.Internal.Errors
71-- , age :: Age
68-- , age :: Age
72-- , fieldA :: a
69-- , fieldA :: a
73-- }
70-- }
74−-- deriving Show
71+-- deriving (Generic, Show)
75-- type Name = String
72-- type Name = String
76-- type Age = Int
73-- type Age = Int
77-- dog, cat, duck :: Animal Int
74-- dog, cat, duck :: Animal Int
@@ -106,99 +103,45 @@ class AsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where
106 -- ...
103 -- ...
107 _Ctor :: Prism s t a b
104 _Ctor :: Prism s t a b
108
105
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−
118class AsConstructor' (ctor :: Symbol) s a | ctor s -> a where
106class AsConstructor' (ctor :: Symbol) s a | ctor s -> a where
119 _Ctor' :: Prism s s a a
107 _Ctor' :: Prism s s a a
120
108
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−
128instance
109instance
129 ( Generic s
110 ( Generic s
130 , ErrorUnless ctor s (HasCtorP ctor (Rep s))
111 , ErrorUnless ctor s (HasCtorP ctor (Rep s))
131 , GAsConstructor' ctor (Rep s) a
112 , GAsConstructor' ctor (Rep s) a
132− , Defined (Rep s)
133− (NoGeneric s '[ 'Text "arising from a generic prism focusing on the "
134− ':<>: QuoteType ctor ':<>: 'Text " constructor of type " ':<>: QuoteType a
135− , 'Text "in " ':<>: QuoteType s])
136− (() :: Constraint)
137 ) => AsConstructor' ctor s a where
113 ) => AsConstructor' ctor s a where
138 _Ctor' eta = prismRavel (prismPRavel (repIso . _GCtor @ctor)) eta
114 _Ctor' eta = prismRavel (prismPRavel (repIso . _GCtor @ctor)) eta
139 {-# INLINE[2] _Ctor' #-}
115 {-# INLINE[2] _Ctor' #-}
140
116
141instance
117instance
118+ ( Generic s
142− ( ErrorUnless ctor s (HasCtorP ctor (Rep s))
119+ , ErrorUnless ctor s (HasCtorP ctor (Rep s))
143− , GAsConstructor' ctor (Rep s) a -- TODO: add a test similar to #62 for prisms
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'
144− , GAsConstructor' ctor (Rep (Indexed s)) a'
130+ , GAsConstructor' ctor (Rep s) a
131+ , GAsConstructor' ctor (Rep s') a'
145 , GAsConstructor ctor (Rep s) (Rep t) a b
132 , GAsConstructor ctor (Rep s) (Rep t) a b
146 , t ~ Infer s a' b
133 , t ~ Infer s a' b
147− , GAsConstructor' ctor (Rep (Indexed t)) b'
134+ , GAsConstructor' ctor (Rep t') b'
148 , s ~ Infer t b' a
135 , s ~ Infer t b' a
149− , AsConstructor0 ctor s t a b
150 ) => AsConstructor ctor s t a b where
136 ) => AsConstructor ctor s t a b where
151
137
152− _Ctor = _Ctor0 @ctor
138+ _Ctor eta = prismRavel (prismPRavel (repIso . _GCtor @ctor)) eta
153 {-# INLINE[2] _Ctor #-}
139 {-# INLINE[2] _Ctor #-}
154
140
155−-- | See Note [Uncluttering type signatures]
141+-- 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
169instance {-# OVERLAPPING #-} AsConstructor ctor (Void1 a) (Void1 b) a b where
142instance {-# OVERLAPPING #-} AsConstructor ctor (Void1 a) (Void1 b) a b where
170 _Ctor = undefined
143 _Ctor = undefined
171
144
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−
202type family ErrorUnless (ctor :: Symbol) (s :: Type) (contains :: Bool) :: Constraint where
145type family ErrorUnless (ctor :: Symbol) (s :: Type) (contains :: Bool) :: Constraint where
203 ErrorUnless ctor s 'False
146 ErrorUnless ctor s 'False
204 = TypeError
147 = TypeError
src/Data/Generics/Sum/Internal/Constructors.hs+7−6
@@ -14,7 +14,7 @@
14-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
15-- |
15-- |
16-- Module : Data.Generics.Sum.Internal.Constructors
16-- Module : Data.Generics.Sum.Internal.Constructors
17−-- Copyright : (C) 2019 Csongor Kiss
17+-- Copyright : (C) 2017 Csongor Kiss
18-- License : BSD3
18-- License : BSD3
19-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20-- Stability : experimental
20-- Stability : experimental
@@ -30,11 +30,11 @@ module Data.Generics.Sum.Internal.Constructors
30 ) where
30 ) where
31
31
32import Data.Generics.Internal.Families
32import Data.Generics.Internal.Families
33−import Data.Generics.Product.Internal.HList
33+import Data.Generics.Product.Internal.List
34−import Data.Profunctor (Profunctor(..))
35
34
36import GHC.Generics
35import GHC.Generics
37import GHC.TypeLits (Symbol)
36import GHC.TypeLits (Symbol)
37+import Data.Kind
38import Data.Generics.Internal.Profunctor.Lens
38import Data.Generics.Internal.Profunctor.Lens
39import Data.Generics.Internal.Profunctor.Iso
39import Data.Generics.Internal.Profunctor.Iso
40import Data.Generics.Internal.Profunctor.Prism
40import Data.Generics.Internal.Profunctor.Prism
@@ -47,15 +47,16 @@ class GAsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where
47type GAsConstructor' ctor s a = GAsConstructor ctor s s a a
47type GAsConstructor' ctor s a = GAsConstructor ctor s s a a
48
48
49instance
49instance
50− ( GIsList f f as as
50+ ( GIsList Type f f as as
51− , GIsList g g bs bs
51+ , GIsList Type g g bs bs
52 , ListTuple a as
52 , ListTuple a as
53 , ListTuple b bs
53 , ListTuple b bs
54 ) => GAsConstructor ctor (M1 C ('MetaCons ctor fixity fields) f) (M1 C ('MetaCons ctor fixity fields) g) a b where
54 ) => GAsConstructor ctor (M1 C ('MetaCons ctor fixity fields) f) (M1 C ('MetaCons ctor fixity fields) g) a b where
55
55
56− _GCtor = dimap (listToTuple . view glist . unM1) (M1 . view (fromIso glist) . tupleToList)
56+ _GCtor = prism (M1 . view (fromIso (glist @Type)) . tupleToList) (Right . listToTuple . view (glist @Type) . unM1)
57 {-# INLINE[0] _GCtor #-}
57 {-# INLINE[0] _GCtor #-}
58
58
59+
59instance GSumAsConstructor ctor (HasCtorP ctor l) l r l' r' a b => GAsConstructor ctor (l :+: r) (l' :+: r') a b where
60instance GSumAsConstructor ctor (HasCtorP ctor l) l r l' r' a b => GAsConstructor ctor (l :+: r) (l' :+: r') a b where
60 _GCtor = _GSumCtor @ctor @(HasCtorP ctor l)
61 _GCtor = _GSumCtor @ctor @(HasCtorP ctor l)
61 {-# INLINE[0] _GCtor #-}
62 {-# INLINE[0] _GCtor #-}
src/Data/Generics/Sum/Internal/Subtype.hs+8−8
@@ -14,7 +14,7 @@
14-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
15-- |
15-- |
16-- Module : Data.Generics.Sum.Internal.Subtype
16-- Module : Data.Generics.Sum.Internal.Subtype
17−-- Copyright : (C) 2019 Csongor Kiss
17+-- Copyright : (C) 2017 Csongor Kiss
18-- License : BSD3
18-- License : BSD3
19-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20-- Stability : experimental
20-- Stability : experimental
@@ -28,7 +28,7 @@ module Data.Generics.Sum.Internal.Subtype
28 ( GAsSubtype (..)
28 ( GAsSubtype (..)
29 ) where
29 ) where
30
30
31−import Data.Generics.Product.Internal.HList
31+import Data.Generics.Product.Internal.List
32import Data.Generics.Sum.Internal.Typed
32import Data.Generics.Sum.Internal.Typed
33
33
34import Data.Kind
34import Data.Kind
@@ -46,7 +46,7 @@ instance
46 ( GSplash sub sup
46 ( GSplash sub sup
47 , GDowncast sub sup
47 , GDowncast sub sup
48 ) => GAsSubtype sub sup where
48 ) => GAsSubtype sub sup where
49− _GSub f = prism _GSplash _GDowncast f
49+ _GSub f = (prism _GSplash _GDowncast) f
50 {-# INLINE[0] _GSub #-}
50 {-# INLINE[0] _GSub #-}
51
51
52--------------------------------------------------------------------------------
52--------------------------------------------------------------------------------
@@ -60,10 +60,10 @@ instance (GSplash a sup, GSplash b sup) => GSplash (a :+: b) sup where
60 {-# INLINE[0] _GSplash #-}
60 {-# INLINE[0] _GSplash #-}
61
61
62instance
62instance
63− ( GIsList subf subf as as
63+ ( GIsList () subf subf as as
64 , GAsType supf as
64 , GAsType supf as
65 ) => GSplash (C1 meta subf) supf where
65 ) => GSplash (C1 meta subf) supf where
66− _GSplash p = build (_GTyped . fromIso (mIso . glist)) p
66+ _GSplash p = build ((_GTyped . fromIso (glist @()) . fromIso mIso)) p
67 {-# INLINE[0] _GSplash #-}
67 {-# INLINE[0] _GSplash #-}
68
68
69instance GSplash sub sup => GSplash (D1 c sub) sup where
69instance GSplash sub sup => GSplash (D1 c sub) sup where
@@ -76,7 +76,7 @@ class GDowncast sub sup where
76 _GDowncast :: sup x -> Either (sup x) (sub x)
76 _GDowncast :: sup x -> Either (sup x) (sub x)
77
77
78instance
78instance
79− ( GIsList sup sup as as
79+ ( GIsList () sup sup as as
80 , GDowncastC (HasPartialTypeP as sub) sub sup
80 , GDowncastC (HasPartialTypeP as sub) sub sup
81 ) => GDowncast sub (C1 m sup) where
81 ) => GDowncast sub (C1 m sup) where
82 _GDowncast (M1 m) = case _GDowncastC @(HasPartialTypeP as sub) m of
82 _GDowncast (M1 m) = case _GDowncastC @(HasPartialTypeP as sub) m of
@@ -108,8 +108,8 @@ instance GDowncastC 'False sub sup where
108
108
109instance
109instance
110 ( GAsType sub subl
110 ( GAsType sub subl
111− , GIsList sup sup subl subl
111+ , GIsList () sup sup subl subl
112 ) => GDowncastC 'True sub sup where
112 ) => GDowncastC 'True sub sup where
113− _GDowncastC sup = Right (build (_GTyped . fromIso glist) sup)
113+ _GDowncastC sup = Right (build (_GTyped . fromIso (glist @())) sup)
114 {-# INLINE[0] _GDowncastC #-}
114 {-# INLINE[0] _GDowncastC #-}
115
115
src/Data/Generics/Sum/Internal/Typed.hs+8−8
@@ -13,7 +13,7 @@
13-----------------------------------------------------------------------------
13-----------------------------------------------------------------------------
14-- |
14-- |
15-- Module : Data.Generics.Sum.Internal.Typed
15-- Module : Data.Generics.Sum.Internal.Typed
16−-- Copyright : (C) 2019 Csongor Kiss
16+-- Copyright : (C) 2017 Csongor Kiss
17-- License : BSD3
17-- License : BSD3
18-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
18-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19-- Stability : experimental
19-- Stability : experimental
@@ -32,13 +32,13 @@ import GHC.Generics
32import Data.Tagged
32import Data.Tagged
33
33
34import Data.Generics.Internal.Families
34import Data.Generics.Internal.Families
35−import Data.Generics.Product.Internal.HList
35+import Data.Generics.Product.Internal.List
36import Data.Generics.Internal.Profunctor.Iso
36import Data.Generics.Internal.Profunctor.Iso
37import Data.Generics.Internal.Profunctor.Prism
37import Data.Generics.Internal.Profunctor.Prism
38
38
39-- |As 'AsType' but over generic representations as defined by "GHC.Generics".
39-- |As 'AsType' but over generic representations as defined by "GHC.Generics".
40−class GAsType (f :: Type -> Type) (as :: [Type]) where
40+class GAsType (f :: Type -> Type) (as :: [((), Type)]) where
41− _GTyped :: Prism (f x) (f x) (HList as) (HList as)
41+ _GTyped :: Prism (f x) (f x) (List as) (List as)
42-- We create this specialised version as we use it in the subtype prism
42-- We create this specialised version as we use it in the subtype prism
43-- If we don't create it, the opportunity for specialisation is only
43-- If we don't create it, the opportunity for specialisation is only
44-- created after specialisation happens, I think a late specialisation pass
44-- created after specialisation happens, I think a late specialisation pass
@@ -47,9 +47,9 @@ class GAsType (f :: Type -> Type) (as :: [Type]) where
47
47
48
48
49instance
49instance
50− ( GIsList f f as as
50+ ( GIsList () f f as as
51 ) => GAsType (M1 C meta f) as where
51 ) => GAsType (M1 C meta f) as where
52− _GTyped = mIso . glist
52+ _GTyped = mIso . glist @()
53 {-# INLINE[0] _GTyped #-}
53 {-# INLINE[0] _GTyped #-}
54
54
55instance GSumAsType (HasPartialTypeP a l) l r a => GAsType (l :+: r) a where
55instance 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
60 _GTyped = mIso . _GTyped
60 _GTyped = mIso . _GTyped
61 {-# INLINE[0] _GTyped #-}
61 {-# INLINE[0] _GTyped #-}
62
62
63−class GSumAsType (contains :: Bool) l r (a :: [Type]) where
63+class GSumAsType (contains :: Bool) l r (a :: [((), Type)]) where
64− _GSumTyped :: Prism ((l :+: r) x) ((l :+: r) x) (HList a) (HList a)
64+ _GSumTyped :: Prism ((l :+: r) x) ((l :+: r) x) (List a) (List a)
65
65
66instance GAsType l a => GSumAsType 'True l r a where
66instance GAsType l a => GSumAsType 'True l r a where
67 _GSumTyped = left . _GTyped
67 _GSumTyped = left . _GTyped
src/Data/Generics/Sum/Subtype.hs+2−38
@@ -1,4 +1,3 @@
1−{-# LANGUAGE CPP #-}
2{-# LANGUAGE FlexibleContexts #-}
1{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE MonoLocalBinds #-}
3{-# LANGUAGE MonoLocalBinds #-}
@@ -12,7 +11,7 @@
12-----------------------------------------------------------------------------
11-----------------------------------------------------------------------------
13-- |
12-- |
14-- Module : Data.Generics.Sum.Subtype
13-- Module : Data.Generics.Sum.Subtype
15−-- Copyright : (C) 2019 Csongor Kiss
14+-- Copyright : (C) 2017 Csongor Kiss
16-- License : BSD3
15-- License : BSD3
17-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
18-- Stability : experimental
17-- Stability : experimental
@@ -114,45 +113,10 @@ instance
114 _Sub f = prismRavel (repIso . _GSub . fromIso repIso) f
113 _Sub f = prismRavel (repIso . _GSub . fromIso repIso) f
115 {-# INLINE[2] _Sub #-}
114 {-# INLINE[2] _Sub #-}
116
115
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]
116+-- 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
138instance {-# OVERLAPPING #-} AsSubtype a Void where
117instance {-# OVERLAPPING #-} AsSubtype a Void where
139 injectSub = undefined
118 injectSub = undefined
140 projectSub = undefined
119 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
156instance {-# OVERLAPPING #-} AsSubtype Void a where
120instance {-# OVERLAPPING #-} AsSubtype Void a where
157 injectSub = undefined
121 injectSub = undefined
158 projectSub = undefined
122 projectSub = undefined
src/Data/Generics/Sum/Typed.hs+3−34
@@ -1,4 +1,3 @@
1−{-# LANGUAGE CPP #-}
2{-# LANGUAGE TypeApplications #-}
1{-# LANGUAGE TypeApplications #-}
3{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
4{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
@@ -14,7 +13,7 @@
14-----------------------------------------------------------------------------
13-----------------------------------------------------------------------------
15-- |
14-- |
16-- Module : Data.Generics.Sum.Typed
15-- Module : Data.Generics.Sum.Typed
17−-- Copyright : (C) 2019 Csongor Kiss
16+-- Copyright : (C) 2017 Csongor Kiss
18-- License : BSD3
17-- License : BSD3
19-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
18-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20-- Stability : experimental
19-- Stability : experimental
@@ -35,11 +34,10 @@ import Data.Kind
35import GHC.Generics
34import GHC.Generics
36import GHC.TypeLits (TypeError, ErrorMessage (..), Symbol)
35import GHC.TypeLits (TypeError, ErrorMessage (..), Symbol)
37import Data.Generics.Sum.Internal.Typed
36import Data.Generics.Sum.Internal.Typed
38−import Data.Generics.Internal.Errors
39
37
40import Data.Generics.Internal.Families
38import Data.Generics.Internal.Families
41import Data.Generics.Internal.Void
39import Data.Generics.Internal.Void
42−import Data.Generics.Product.Internal.HList
40+import Data.Generics.Product.Internal.List
43import Data.Generics.Internal.VL.Prism
41import Data.Generics.Internal.VL.Prism
44import Data.Generics.Internal.Profunctor.Iso
42import Data.Generics.Internal.Profunctor.Iso
45import Data.Generics.Internal.Profunctor.Prism (prismPRavel)
43import Data.Generics.Internal.Profunctor.Prism (prismPRavel)
@@ -111,45 +109,16 @@ instance
111 , as ~ TupleToList a
109 , as ~ TupleToList a
112 , ListTuple a as
110 , ListTuple a as
113 , GAsType (Rep s) as
111 , GAsType (Rep s) as
114− , Defined (Rep s)
115− (NoGeneric s '[ 'Text "arising from a generic prism focusing on a constructor of type " ':<>: QuoteType a])
116− (() :: Constraint)
117 ) => AsType a s where
112 ) => AsType a s where
118
113
119 _Typed eta = prismRavel (prismPRavel (repIso . _GTyped @_ @as . tupled)) eta
114 _Typed eta = prismRavel (prismPRavel (repIso . _GTyped @_ @as . tupled)) eta
120 {-# INLINE[2] _Typed #-}
115 {-# INLINE[2] _Typed #-}
121
116
122−-- | See Note [Uncluttering type signatures]
117+-- 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
134instance {-# OVERLAPPING #-} AsType a Void where
118instance {-# OVERLAPPING #-} AsType a Void where
135 _Typed = undefined
119 _Typed = undefined
136 injectTyped = undefined
120 injectTyped = undefined
137 projectTyped = undefined
121 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
153instance {-# OVERLAPPING #-} AsType Void a where
122instance {-# OVERLAPPING #-} AsType Void a where
154 _Typed = undefined
123 _Typed = undefined
155 injectTyped = undefined
124 injectTyped = undefined
src/Data/Generics/Wrapped.hsdeleted−104
@@ -1,104 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE TypeApplications #-}
3−{-# language ConstraintKinds #-}
4−{-# language DataKinds #-}
5−{-# language FlexibleContexts #-}
6−{-# language FlexibleInstances #-}
7−{-# language FunctionalDependencies #-}
8−{-# language MultiParamTypeClasses #-}
9−{-# language ScopedTypeVariables #-}
10−{-# language TypeFamilies #-}
11−{-# language TypeOperators #-}
12−{-# language UndecidableInstances #-}
13−
14−-----------------------------------------------------------------------------
15−-- |
16−-- Module : Data.Generics.Wrapped
17−-- Copyright : (C) 2019 Csongor Kiss
18−-- License : BSD3
19−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20−-- Stability : experimental
21−-- Portability : non-portable
22−--
23−-- Derive an isomorphism between a newtype and its wrapped type.
24−--
25−-----------------------------------------------------------------------------
26−
27−module Data.Generics.Wrapped
28− ( Wrapped (..)
29− , wrappedTo
30− , wrappedFrom
31− , _Unwrapped
32− , _Wrapped
33− )
34−where
35−
36−import Control.Applicative (Const(..))
37−import Data.Generics.Internal.Profunctor.Iso
38−
39−import qualified Data.Generics.Internal.VL.Iso as VL
40−import Data.Generics.Internal.Families.Changing ( UnifyHead )
41−
42−import Data.Kind (Constraint)
43−import GHC.Generics
44−import GHC.TypeLits
45−
46−type family ErrorUnlessOnlyOne a b :: Constraint where
47− ErrorUnlessOnlyOne t (M1 i k a) = ErrorUnlessOnlyOne t a
48− ErrorUnlessOnlyOne t (K1 i a) = ()
49− ErrorUnlessOnlyOne t a =
50− TypeError ('ShowType t ':<>: 'Text " is not a single-constructor, single-field datatype")
51−
52−-- | @since 1.1.0.0
53−_Unwrapped :: Wrapped s t a b => VL.Iso s t a b
54−_Unwrapped = wrappedIso
55−{-# inline _Unwrapped #-}
56−
57−-- | @since 1.1.0.0
58−_Wrapped :: Wrapped s t a b => VL.Iso b a t s
59−_Wrapped = VL.fromIso wrappedIso
60−{-# inline _Wrapped #-}
61−
62−-- TODO: move this into doctets
63−
64−-- newtype FlippedEither a b = FlippedEither (Either b a)
65−-- deriving Generic
66−
67−-- test :: (a -> c) -> FlippedEither a b -> FlippedEither c b
68−-- test f = over wrappedIso (fmap f)
69−
70−class GWrapped s t a b | s -> a, t -> b, s b -> t, t a -> s where
71− gWrapped :: Iso (s x) (t x) a b
72−
73−instance GWrapped s t a b => GWrapped (M1 i k s) (M1 i k t) a b where
74− gWrapped = mIso . gWrapped
75−
76−instance (a ~ c, b ~ d) => GWrapped (K1 i a) (K1 i b) c d where
77− gWrapped = kIso
78−
79−-- | @since 1.1.0.0
80−class Wrapped s t a b | s -> a, t -> b where
81− -- | @since 1.1.0.0
82− wrappedIso :: VL.Iso s t a b
83−
84−-- | @since 1.1.0.0
85−wrappedTo :: forall s t a b. Wrapped s t a b => s -> a
86−wrappedTo a = view (wrappedIso @s @t @a @b) a
87− where view l s = getConst (l Const s)
88−{-# INLINE wrappedTo #-}
89−
90−-- | @since 1.1.0.0
91−wrappedFrom :: forall s t a b. Wrapped s t a b => b -> t
92−wrappedFrom a = view (VL.fromIso (wrappedIso @s @t @a @b)) a
93− where view l s = getConst (l Const s)
94−{-# INLINE wrappedFrom #-}
95−
96−instance
97− ( Generic s
98− , Generic t
99− , GWrapped (Rep s) (Rep t) a b
100− , UnifyHead s t
101− , UnifyHead t s
102− ) => Wrapped s t a b where
103− wrappedIso = iso2isovl (repIso . gWrapped)
104− {-# INLINE wrappedIso #-}
stack.yaml+1−1
@@ -1,4 +1,4 @@
1−resolver: nightly-2018-08-09
1+resolver: nightly-2018-04-05
2
2
3packages:
3packages:
4- '.'
4- '.'
test/CustomChildren.hsdeleted−63
@@ -1,63 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE KindSignatures #-}
5−{-# LANGUAGE MultiParamTypeClasses #-}
6−{-# LANGUAGE TypeApplications #-}
7−{-# LANGUAGE TypeFamilies #-}
8−{-# LANGUAGE UndecidableInstances #-}
9−
10−module CustomChildren
11− ( customTypesTest
12− ) where
13−
14−import GHC.Generics
15−import Data.Generics.Product
16−import Test.HUnit
17−import Data.Generics.Internal.VL.Lens
18−import Data.Generics.Labels ()
19−import Data.Kind
20−
21−-- Opaque has no Generic instance
22−data Opaque = Opaque String
23− deriving (Show, Eq)
24−
25−-- Hide does have a Generic instance, but we want to hide its contents
26−-- from the traversal
27−data Hide = Hide String
28− deriving (Show, Generic, Eq)
29−
30−-- We first define a symbol for the custom traversal
31−data Custom
32−
33−type instance Children Custom a = ChildrenCustom a
34−
35−type family ChildrenCustom (a :: Type) where
36− ChildrenCustom Opaque = '[String] -- here we state explicitly that Opaque contains a String
37− ChildrenCustom Hide = '[] -- and hide the contents of Hide
38− ChildrenCustom a = Children ChGeneric a -- for the rest, we defer to the generic children
39−
40−-- We define the traversal of Opaque like so:
41−instance HasTypesCustom Custom Opaque String where
42− typesCustom f (Opaque str) = Opaque <$> f str
43−
44−customTypesTest1 :: Test
45−customTypesTest1
46− = TestCase (assertEqual "foo" (over (typesUsing @Custom @String) (++ "!") original) expected)
47− where original = (Opaque "foo", Hide "bar")
48− expected = (Opaque "foo!", Hide "bar") -- only Opaque's String gets modified
49−
50−customTypesTest2 :: Test
51−customTypesTest2
52− = TestCase (assertEqual "foo" (over (typesUsing @Custom @String) (++ "!") original) expected)
53− where original = Opaque "foo"
54− expected = Opaque "foo!"
55−
56−customTypesTest3 :: Test
57−customTypesTest3
58− = TestCase (assertEqual "foo" (over (typesUsing @Custom @String) (++ "!") original) expected)
59− where original = Hide "foo"
60− expected = Hide "foo"
61−
62−customTypesTest :: Test
63−customTypesTest = TestList [customTypesTest1, customTypesTest2, customTypesTest3]
test/Spec.hs+2−38
@@ -2,7 +2,6 @@
2{-# OPTIONS_GHC -dsuppress-all #-}
2{-# OPTIONS_GHC -dsuppress-all #-}
3
3
4{-# LANGUAGE AllowAmbiguousTypes #-}
4{-# LANGUAGE AllowAmbiguousTypes #-}
5−{-# LANGUAGE CPP #-}
6{-# LANGUAGE DataKinds #-}
5{-# LANGUAGE DataKinds #-}
7{-# LANGUAGE DeriveGeneric #-}
6{-# LANGUAGE DeriveGeneric #-}
8{-# LANGUAGE DuplicateRecordFields #-}
7{-# LANGUAGE DuplicateRecordFields #-}
@@ -11,7 +10,6 @@
11{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE TypeApplications #-}
11{-# LANGUAGE TypeApplications #-}
13{-# LANGUAGE TemplateHaskell #-}
12{-# LANGUAGE TemplateHaskell #-}
14−{-# LANGUAGE OverloadedLabels #-}
15
13
16module Main where
14module Main where
17
15
@@ -25,16 +23,11 @@ import System.Exit
25import Data.Generics.Internal.VL.Lens
23import Data.Generics.Internal.VL.Lens
26import Data.Generics.Internal.VL.Prism
24import Data.Generics.Internal.VL.Prism
27import Data.Generics.Internal.VL.Traversal
25import Data.Generics.Internal.VL.Traversal
28−import Control.Lens (_1, (+~))
29−import Data.Function ((&))
30−import Data.Generics.Labels ()
31
26
32-- This is sufficient at we only want to test that they typecheck
27-- This is sufficient at we only want to test that they typecheck
33import Test24 ()
28import Test24 ()
34import Test25 ()
29import Test25 ()
35
30
36−import CustomChildren (customTypesTest)
37−
38main :: IO ()
31main :: IO ()
39main = do
32main = do
40 res <- runTestTT tests
33 res <- runTestTT tests
@@ -185,32 +178,23 @@ subtypePrismManual eta = prism g f eta
185fieldALensName :: Lens' Record Int
178fieldALensName :: Lens' Record Int
186fieldALensName = field @"fieldA"
179fieldALensName = field @"fieldA"
187
180
188−fieldALensName_ :: Lens' Record Int
189−fieldALensName_ = field_ @"fieldA"
190−
191fieldALensType :: Lens' Record Int
181fieldALensType :: Lens' Record Int
192fieldALensType = typed @Int
182fieldALensType = typed @Int
193
183
194fieldALensPos :: Lens' Record Int
184fieldALensPos :: Lens' Record Int
195fieldALensPos = position @1
185fieldALensPos = position @1
196
186
197−fieldALensPos_ :: Lens' Record Int
198−fieldALensPos_ = position_ @1
199−
200subtypeLensGeneric :: Lens' Record Record2
187subtypeLensGeneric :: Lens' Record Record2
201subtypeLensGeneric = super
188subtypeLensGeneric = super
202
189
203typeChangingGeneric :: Lens (Record3 a) (Record3 b) a b
190typeChangingGeneric :: Lens (Record3 a) (Record3 b) a b
204−typeChangingGeneric = #fieldA
191+typeChangingGeneric = field @"fieldA"
205
192
206typeChangingGenericPos :: Lens (Record3 a) (Record3 b) a b
193typeChangingGenericPos :: Lens (Record3 a) (Record3 b) a b
207typeChangingGenericPos = position @1
194typeChangingGenericPos = position @1
208
195
209typeChangingGenericCompose :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b
196typeChangingGenericCompose :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b
210−typeChangingGenericCompose = #fieldA . #fieldA
197+typeChangingGenericCompose = field @"fieldA" . field @"fieldA"
211−
212−typeChangingGenericCompose_ :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b
213−typeChangingGenericCompose_ = field_ @"fieldA" . field_ @"fieldA"
214
198
215sum1PrismB :: Prism Sum1 Sum1 Int Int
199sum1PrismB :: Prism Sum1 Sum1 Int Int
216sum1PrismB = _Ctor @"B"
200sum1PrismB = _Ctor @"B"
@@ -230,24 +214,15 @@ sum2TypePrism = _Typed @Int
230sum2TypePrismChar :: Prism Sum2 Sum2 Char Char
214sum2TypePrismChar :: Prism Sum2 Sum2 Char Char
231sum2TypePrismChar = _Typed @Char
215sum2TypePrismChar = _Typed @Char
232
216
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−
239tests :: Test
217tests :: Test
240tests = TestList $ map mkHUnitTest
218tests = TestList $ map mkHUnitTest
241 [ $(inspectTest $ 'fieldALensManual === 'fieldALensName)
219 [ $(inspectTest $ 'fieldALensManual === 'fieldALensName)
242− , $(inspectTest $ 'fieldALensManual === 'fieldALensName_)
243 , $(inspectTest $ 'fieldALensManual === 'fieldALensType)
220 , $(inspectTest $ 'fieldALensManual === 'fieldALensType)
244 , $(inspectTest $ 'fieldALensManual === 'fieldALensPos)
221 , $(inspectTest $ 'fieldALensManual === 'fieldALensPos)
245− , $(inspectTest $ 'fieldALensManual === 'fieldALensPos_)
246 , $(inspectTest $ 'subtypeLensManual === 'subtypeLensGeneric)
222 , $(inspectTest $ 'subtypeLensManual === 'subtypeLensGeneric)
247 , $(inspectTest $ 'typeChangingManual === 'typeChangingGeneric)
223 , $(inspectTest $ 'typeChangingManual === 'typeChangingGeneric)
248 , $(inspectTest $ 'typeChangingManual === 'typeChangingGenericPos)
224 , $(inspectTest $ 'typeChangingManual === 'typeChangingGenericPos)
249 , $(inspectTest $ 'typeChangingManualCompose === 'typeChangingGenericCompose)
225 , $(inspectTest $ 'typeChangingManualCompose === 'typeChangingGenericCompose)
250− , $(inspectTest $ 'typeChangingManualCompose === 'typeChangingGenericCompose_)
251 , $(inspectTest $ 'sum1PrismManual === 'sum1PrismB)
226 , $(inspectTest $ 'sum1PrismManual === 'sum1PrismB)
252 , $(inspectTest $ 'subtypePrismManual === 'subtypePrismGeneric)
227 , $(inspectTest $ 'subtypePrismManual === 'subtypePrismGeneric)
253 , $(inspectTest $ 'sum2PrismManualChar === 'sum2TypePrismChar)
228 , $(inspectTest $ 'sum2PrismManualChar === 'sum2TypePrismChar)
@@ -260,17 +235,6 @@ tests = TestList $ map mkHUnitTest
260 -- TODO [1.0.0.0]: these tests pass with the new implementation
235 -- TODO [1.0.0.0]: these tests pass with the new implementation
261-- , $(inspectTest $ 'sum3Param1Manual === 'sum3Param1Derived)
236-- , $(inspectTest $ 'sum3Param1Manual === 'sum3Param1Derived)
262-- , $(inspectTest $ 'sum3Param2Manual === 'sum3Param2Derived)
237-- , $(inspectTest $ 'sum3Param2Manual === 'sum3Param2Derived)
263− ] ++
264− -- Tests for overloaded labels
265− [ (valLabel ^. #_foo ) ~=? 3
266− , (valLabel & #_foo +~ 10 ) ~=? RecB 13 True
267−#if __GLASGOW_HASKELL__ >= 802
268− , (valLabel ^? #_RecB ) ~=? Just (3, True)
269− , (valLabel ^? #_RecB . _1 ) ~=? Just 3
270− , (valLabel ^? #_RecC ) ~=? Nothing
271−#endif
272− , customTypesTest
273 ]
238 ]
274− where valLabel = RecB 3 True
275
239
276-- TODO: add test for traversals over multiple types
240-- TODO: add test for traversals over multiple types
test/Test62.hsdeleted−20
@@ -1,20 +0,0 @@
1−{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications #-}
2−module Test62 (example, example_) where
3−import Data.Generics.Product (field, field_, position, position_)
4−import Data.Generics.Internal.VL.Lens (set)
5−import GHC.Generics (Generic)
6−
7−data Foo a = Foo { bar :: Bar a } deriving Generic
8−data Bar a = Bar { x :: a, y :: a } deriving Generic
9−
10−example :: Foo ()
11−example =
12− set (field @"bar" . position @1) ()
13− . set (position @1 . field @"y") ()
14− $ Foo{ bar = Bar{ x = (), y = () } }
15−
16−example_ :: Foo ()
17−example_ =
18− set (field_ @"bar" . position_ @1) ()
19− . set (position_ @1 . field_ @"y") ()
20− $ Foo{ bar = Bar{ x = (), y = () } }
test/Test63.hsdeleted−12
@@ -1,12 +0,0 @@
1−{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications #-}
2−module Test63 (example) where
3−import Data.Generics.Product (types)
4−import Data.Generics.Internal.VL.Lens (over)
5−import Data.Word (Word32)
6−import GHC.Generics (Generic)
7−
8−data Record = Record {field1 :: Word32, field2 :: Int}
9− deriving (Generic, Show)
10−
11−example :: Record
12−example = over (types @Int) (+1) (Record 0 0)
test/Test71.hsdeleted−17
@@ -1,17 +0,0 @@
1−{-# LANGUAGE FlexibleContexts, DeriveGeneric, TypeApplications #-}
2−
3−module Test71 where
4−
5−import GHC.Generics
6−import Control.Lens
7−import Data.Generics.Product
8−
9−data Foobar = Foobar Int Char String
10− deriving Generic
11−
12−foo :: HasType Foobar ctx => ctx -> Char
13−foo ctx = case view (typed @Foobar) ctx of
14− Foobar _ c _ -> c
15−
16−bar :: Char
17−bar = foo (Foobar 3 'a' "Hello")
test/doctest.hs−1
@@ -4,5 +4,4 @@ main
4 [ "-isrc"
4 [ "-isrc"
5 , "src/Data/Generics/Product.hs"
5 , "src/Data/Generics/Product.hs"
6 , "src/Data/Generics/Sum.hs"
6 , "src/Data/Generics/Sum.hs"
7− , "src/Data/Generics/Labels.hs"
8 ]
7 ]