on 571b430 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−20
@@ -1,23 +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
1## 1.0.0.2
22- Fix compile-time performance regression
2- Fix compile-time performance regression
23
3
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+9−15
@@ -1,5 +1,5 @@
1name: generic-lens
1name: generic-lens
2−version: 1.2.0.1
2+version: 1.0.0.2
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, GHC == 8.4.1, GHC == 8.4.3
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
@@ -68,12 +63,11 @@ library
68 , Data.Generics.Product.Internal.Subtype
63 , Data.Generics.Product.Internal.Subtype
69
64
70 , Data.Generics.Product.Internal.Constraints
65 , Data.Generics.Product.Internal.Constraints
71− , Data.Generics.Product.Internal.HList
66+ , Data.Generics.Product.Internal.List
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+31−38
@@ -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
@@ -24,84 +24,77 @@ module Data.Generics.Internal.Families.Has
24 , GTypes
24 , GTypes
25 ) where
25 ) where
26
26
27−import Data.Type.Bool (type (||))
27+import Data.Type.Bool (type (||), type (&&))
28import Data.Type.Equality (type (==))
28import Data.Type.Equality (type (==))
29import GHC.Generics
29import GHC.Generics
30import GHC.TypeLits (Symbol, Nat)
30import GHC.TypeLits (Symbol, Nat)
31import Data.Kind (Type)
31import Data.Kind (Type)
32
32
33−import Data.Generics.Product.Internal.HList
33+import Data.Generics.Product.Internal.List
34
34
35-- Note: these could be factored out into a single traversal
35-- Note: these could be factored out into a single traversal
36
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
37+type family HasTotalFieldP (field :: Symbol) f :: Bool where
45− HasTotalFieldP field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 t))
38+ HasTotalFieldP field (S1 ('MetaSel ('Just field) _ _ _) _)
46− = 'Just t
39+ = 'True
47 HasTotalFieldP field (l :*: r)
40 HasTotalFieldP field (l :*: r)
48− = Alt (HasTotalFieldP field l) (HasTotalFieldP field r)
41+ = HasTotalFieldP field l || HasTotalFieldP field r
49 HasTotalFieldP field (l :+: r)
42 HasTotalFieldP field (l :+: r)
50− = Both (HasTotalFieldP field l) (HasTotalFieldP field r)
43+ = HasTotalFieldP field l && HasTotalFieldP field r
51 HasTotalFieldP field (S1 _ _)
44 HasTotalFieldP field (S1 _ _)
52− = 'Nothing
45+ = 'False
53 HasTotalFieldP field (C1 _ f)
46 HasTotalFieldP field (C1 _ f)
54 = HasTotalFieldP field f
47 = HasTotalFieldP field f
55 HasTotalFieldP field (D1 _ f)
48 HasTotalFieldP field (D1 _ f)
56 = HasTotalFieldP field f
49 = HasTotalFieldP field f
57 HasTotalFieldP field (K1 _ _)
50 HasTotalFieldP field (K1 _ _)
58− = 'Nothing
51+ = 'False
59 HasTotalFieldP field U1
52 HasTotalFieldP field U1
60− = 'Nothing
53+ = 'False
61 HasTotalFieldP field V1
54 HasTotalFieldP field V1
62− = 'Nothing
55+ = 'False
63
56
64−type family HasTotalTypeP (typ :: Type) f :: Maybe Type where
57+type family HasTotalTypeP (typ :: Type) f :: Bool where
65 HasTotalTypeP typ (S1 _ (K1 _ typ))
58 HasTotalTypeP typ (S1 _ (K1 _ typ))
66− = 'Just typ
59+ = 'True
67 HasTotalTypeP typ (l :*: r)
60 HasTotalTypeP typ (l :*: r)
68− = Alt (HasTotalTypeP typ l) (HasTotalTypeP typ r)
61+ = HasTotalTypeP typ l || HasTotalTypeP typ r
69 HasTotalTypeP typ (l :+: r)
62 HasTotalTypeP typ (l :+: r)
70− = Both (HasTotalTypeP typ l) (HasTotalTypeP typ r)
63+ = HasTotalTypeP typ l && HasTotalTypeP typ r
71 HasTotalTypeP typ (S1 _ _)
64 HasTotalTypeP typ (S1 _ _)
72− = 'Nothing
65+ = 'False
73 HasTotalTypeP typ (C1 _ f)
66 HasTotalTypeP typ (C1 _ f)
74 = HasTotalTypeP typ f
67 = HasTotalTypeP typ f
75 HasTotalTypeP typ (D1 _ f)
68 HasTotalTypeP typ (D1 _ f)
76 = HasTotalTypeP typ f
69 = HasTotalTypeP typ f
77 HasTotalTypeP typ (K1 _ _)
70 HasTotalTypeP typ (K1 _ _)
78− = 'Nothing
71+ = 'False
79 HasTotalTypeP typ U1
72 HasTotalTypeP typ U1
80− = 'Nothing
73+ = 'False
81 HasTotalTypeP typ V1
74 HasTotalTypeP typ V1
82− = 'Nothing
75+ = 'False
83
76
84data Pos (p :: Nat)
77data Pos (p :: Nat)
85
78
86−type family HasTotalPositionP (pos :: Nat) f :: Maybe Type where
79+type family HasTotalPositionP (pos :: Nat) f :: Bool where
87− HasTotalPositionP pos (S1 _ (K1 (Pos pos) t))
80+ HasTotalPositionP pos (S1 _ (K1 (Pos pos) _))
88− = 'Just t
81+ = 'True
89 HasTotalPositionP pos (l :*: r)
82 HasTotalPositionP pos (l :*: r)
90− = Alt (HasTotalPositionP pos l) (HasTotalPositionP pos r)
83+ = HasTotalPositionP pos l || HasTotalPositionP pos r
91 HasTotalPositionP pos (l :+: r)
84 HasTotalPositionP pos (l :+: r)
92− = Both (HasTotalPositionP pos l) (HasTotalPositionP pos r)
85+ = HasTotalPositionP pos l && HasTotalPositionP pos r
93 HasTotalPositionP pos (S1 _ _)
86 HasTotalPositionP pos (S1 _ _)
94− = 'Nothing
87+ = 'False
95 HasTotalPositionP pos (C1 _ f)
88 HasTotalPositionP pos (C1 _ f)
96 = HasTotalPositionP pos f
89 = HasTotalPositionP pos f
97 HasTotalPositionP pos (D1 _ f)
90 HasTotalPositionP pos (D1 _ f)
98 = HasTotalPositionP pos f
91 = HasTotalPositionP pos f
99 HasTotalPositionP pos (K1 _ _)
92 HasTotalPositionP pos (K1 _ _)
100− = 'Nothing
93+ = 'False
101 HasTotalPositionP pos U1
94 HasTotalPositionP pos U1
102− = 'Nothing
95+ = 'False
103 HasTotalPositionP pos V1
96 HasTotalPositionP pos V1
104− = 'Nothing
97+ = 'False
105
98
106type family HasPartialTypeP a f :: Bool where
99type family HasPartialTypeP a f :: Bool where
107 HasPartialTypeP t (l :+: r)
100 HasPartialTypeP t (l :+: r)
@@ -123,11 +116,11 @@ type family HasCtorP (ctor :: Symbol) f :: Bool where
123 HasCtorP ctor _
116 HasCtorP ctor _
124 = 'False
117 = 'False
125
118
126−type family GTypes (rep :: Type -> Type) :: [Type] where
119+type family GTypes (rep :: Type -> Type) :: [((), Type)] where
127 GTypes (l :*: r)
120 GTypes (l :*: r)
128 = GTypes l ++ GTypes r
121 = GTypes l ++ GTypes r
129 GTypes (K1 _ a)
122 GTypes (K1 _ a)
130− = '[ a]
123+ = '[ '( '(), a)]
131 GTypes (M1 _ m a)
124 GTypes (M1 _ m a)
132 = GTypes a
125 = GTypes a
133 GTypes U1 = '[]
126 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+22−78
@@ -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
@@ -47,7 +46,6 @@ import 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
@@ -153,67 +130,34 @@ instance
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 , GLens' (HasTotalFieldPSym field) (Rep s) a
156− , Defined (Rep s)
157− (NoGeneric s '[ 'Text "arising from a generic lens focusing on the "
158− ':<>: QuoteType field ':<>: 'Text " field of type " ':<>: QuoteType a
159− , 'Text "in " ':<>: QuoteType s])
160− (() :: Constraint)
161 ) => HasField' field s a where
133 ) => HasField' field s a where
162− field' f s = field0 @field f s
134+ field' f s = VL.ravel (repLens . glens @(HasTotalFieldPSym 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+ , GLens' (HasTotalFieldPSym field) (Rep s') a'
150+ , GLens' (HasTotalFieldPSym field) (Rep t') b'
151+ , GLens (HasTotalFieldPSym field) (Rep s) (Rep t) a b
152+ , t ~ Infer s a' b
153+ , s ~ Infer t b' a
154+ ) => HasField field s t a b where
155+ field f s = VL.ravel (repLens . glens @(HasTotalFieldPSym field)) f s
156+
157+-- -- See Note [Uncluttering type signatures]
188instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where
158instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where
189 field = undefined
159 field = undefined
190
160
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
161type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Constraint where
218 ErrorUnless field s ('TypeStat _ _ '[])
162 ErrorUnless field s ('TypeStat _ _ '[])
219 = TypeError
163 = TypeError
@@ -236,5 +180,5 @@ type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Cons
236 ErrorUnless _ _ ('TypeStat '[] '[] _)
180 ErrorUnless _ _ ('TypeStat '[] '[] _)
237 = ()
181 = ()
238
182
239−data HasTotalFieldPSym :: Symbol -> (TyFun (Type -> Type) (Maybe Type))
183+data HasTotalFieldPSym :: Symbol -> (TyFun (Type -> Type) Bool)
240type instance Eval (HasTotalFieldPSym sym) tt = HasTotalFieldP sym tt
184type 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.hs+12−14
@@ -17,7 +17,7 @@
17-----------------------------------------------------------------------------
17-----------------------------------------------------------------------------
18-- |
18-- |
19-- Module : Data.Generics.Product.Internal.GLens
19-- Module : Data.Generics.Product.Internal.GLens
20−-- Copyright : (C) 2019 Csongor Kiss
20+-- Copyright : (C) 2017 Csongor Kiss
21-- License : BSD3
21-- License : BSD3
22-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
22-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
23-- Stability : experimental
23-- Stability : experimental
@@ -40,13 +40,11 @@ import Data.Generics.Internal.Profunctor.Iso (kIso, sumIso, mIso)
40import Data.Kind (Type)
40import Data.Kind (Type)
41import GHC.Generics
41import GHC.Generics
42
42
43−type Pred = TyFun (Type -> Type) (Maybe Type)
44−
45type TyFun a b = a -> b -> Type
43type TyFun a b = a -> b -> Type
46type family Eval (f :: TyFun a b) (x :: a) :: b
44type family Eval (f :: TyFun a b) (x :: a) :: b
47
45
48-- A generic lens that uses some predicate to determine which field to focus on
46-- 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
47+class GLens (pred :: TyFun (Type -> Type) Bool) (s :: Type -> Type) (t :: Type -> Type) a b | s pred -> a, t pred -> b where
50 glens :: Lens (s x) (t x) a b
48 glens :: Lens (s x) (t x) a b
51
49
52type GLens' pred s a = GLens pred s s a a
50type GLens' pred s a = GLens pred s s a a
@@ -54,7 +52,7 @@ type GLens' pred s a = GLens pred s s a a
54instance GProductLens (Eval pred l) pred l r l' r' a b
52instance GProductLens (Eval pred l) pred l r l' r' a b
55 => GLens pred (l :*: r) (l' :*: r') a b where
53 => GLens pred (l :*: r) (l' :*: r') a b where
56
54
57− glens = gproductLens @(Eval pred l) @pred
55+ glens = gproductField @(Eval pred l) @pred
58 {-# INLINE glens #-}
56 {-# INLINE glens #-}
59
57
60instance (GLens pred l l' a b, GLens pred r r' a b) => GLens pred (l :+: r) (l' :+: r') a b where
58instance (GLens pred l l' a b, GLens pred r r' a b) => GLens pred (l :+: r) (l' :+: r') a b where
@@ -65,17 +63,17 @@ instance GLens pred (K1 r a) (K1 r b) a b where
65 glens = kIso
63 glens = kIso
66 {-# INLINE glens #-}
64 {-# INLINE glens #-}
67
65
68−instance (GLens pred f g a b) => GLens pred (M1 m meta f) (M1 m meta g) a b where
66+instance (Functor g, GLens pred f g a b) => GLens pred (M1 m meta f) (M1 m meta g) a b where
69 glens = mIso . glens @pred
67 glens = mIso . glens @pred
70 {-# INLINE glens #-}
68 {-# INLINE glens #-}
71
69
72−class GProductLens (left :: Maybe Type) (pred :: Pred) l r l' r' a b | pred l r -> a, pred l' r' -> b where
70+class GProductLens (left :: Bool) (pred :: TyFun (Type -> Type) Bool) 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
71+ gproductField :: Lens ((l :*: r) x) ((l' :*: r') x) a b
74
72
75−instance GLens pred l l' a b => GProductLens ('Just x) pred l r l' r a b where
73+instance GLens pred l l' a b => GProductLens 'True pred l r l' r a b where
76− gproductLens = first . glens @pred
74+ gproductField = first . glens @pred
77− {-# INLINE gproductLens #-}
75+ {-# INLINE gproductField #-}
78
76
79−instance GLens pred r r' a b => GProductLens 'Nothing pred l r l r' a b where
77+instance GLens pred r r' a b => GProductLens 'False pred l r l r' a b where
80− gproductLens = second . glens @pred
78+ gproductField = second . glens @pred
81− {-# INLINE gproductLens #-}
79+ {-# INLINE gproductField #-}
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/List.hsnew file+337
@@ -0,0 +1,337 @@
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+#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 List (as :: [(m, Type)]) where
55+ Nil :: List '[]
56+ (:>) :: a -> List as -> List ('(s, 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 (List '[]) where
65+ _ <> _ = Nil
66+
67+instance Monoid (List '[]) where
68+ mempty = Nil
69+ mappend _ _ = Nil
70+
71+instance (Semigroup a, Semigroup (List as)) => Semigroup (List ('(k, a) ': as)) where
72+ (x :> xs) <> (y :> ys) = (x <> y) :> (xs <> ys)
73+
74+instance (Monoid a, Monoid (List as)) => Monoid (List ('(k, 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 ('(key, 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+ (m :: Type)
84+ (f :: Type -> Type)
85+ (g :: Type -> Type)
86+ (as :: [(m, Type)])
87+ (bs :: [(m, Type)]) | m f -> as, m g -> bs, bs f -> g, as g -> f where
88+
89+ glist :: Iso (f x) (g x) (List as) (List bs)
90+
91+ -- We define this reversed version, otherwise uses of `fromIso glist` are not
92+ -- properly inlined by GHC 8.0.2.
93+ -- This is not actually used.
94+ glistR :: Iso (List bs) (List as) (g x) (f x)
95+ glistR = fromIso (glist @m)
96+
97+instance
98+ ( GIsList m l l' as as'
99+ , GIsList m r r' bs bs'
100+ , Appending List as bs cs as' bs' cs'
101+ , cs ~ (as ++ bs)
102+ , cs' ~ (as' ++ bs')
103+ ) => GIsList m (l :*: r) (l' :*: r') cs cs' where
104+
105+ glist = prodIso . pairing (glist @m) (glist @m) . appending
106+ {-# INLINE glist #-}
107+
108+instance GIsList m f g as bs => GIsList m (M1 t meta f) (M1 t meta g) as bs where
109+ glist = mIso . glist @m
110+ {-# INLINE glist #-}
111+
112+instance {-# OVERLAPS #-}
113+ GIsList Symbol
114+ (S1 ('MetaSel ('Just field) u s i) (Rec0 a))
115+ (S1 ('MetaSel ('Just field) u s i) (Rec0 b))
116+ '[ '(field, a)] '[ '(field, b)] where
117+ glist = mIso . kIso . singleton
118+ {-# INLINE glist #-}
119+
120+instance GIsList Type (Rec0 a) (Rec0 a) '[ '(a, a)] '[ '(a, a)] where
121+ glist = kIso . singleton
122+ {-# INLINE glist #-}
123+
124+instance GIsList () (Rec0 a) (Rec0 b) '[ '( '(), a)] '[ '( '(), b)] where
125+ glist = kIso . singleton
126+ {-# INLINE glist #-}
127+
128+instance GIsList m U1 U1 '[] '[] where
129+ glist = iso (const Nil) (const U1)
130+ {-# INLINE glist #-}
131+
132+--------------------------------------------------------------------------------
133+-- | as ++ bs === cs
134+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
135+ appending :: Iso (f as, f bs) (f as', f bs') (f cs) (f cs')
136+
137+-- | [] ++ bs === bs
138+instance Appending List '[] bs bs '[] bs' bs' where
139+ appending = iso (\(_, b) -> b) (Nil,)
140+
141+-- | (a : as) ++ bs === (a : cs)
142+instance
143+ Appending List as bs cs as' bs' cs' -- as ++ bs == cs
144+ => Appending List ('(f, a) ': as) bs ('(f, a) ': cs) ('(f, a') ': as') bs' ('(f, a') ': cs') where
145+ appending
146+ = pairing (fromIso consing) id -- ((a, as), bs)
147+ . assoc3 -- (a, (as, bs))
148+ . pairing id appending -- (a, cs)
149+ . consing -- (a : cs)
150+
151+singleton :: Iso a b (List '[ '(field, a)]) (List '[ '(field, b)])
152+singleton = iso (:> Nil) (\(x :> _) -> x)
153+
154+consing :: Iso (a, List as) (b, List bs) (List ('(f, a) ': as)) (List ('(f, b) ': bs))
155+consing = iso (\(x, xs) -> x :> xs) (\(x :> xs) -> (x, xs))
156+
157+--------------------------------------------------------------------------------
158+class IndexList (i :: Nat) as bs a b | i as -> a, i bs -> b, i as b -> bs, i bs a -> as where
159+ point :: Lens (List as) (List bs) a b
160+
161+instance {-# OVERLAPPING #-}
162+ ( as ~ ('(f, a) ': as')
163+ , bs ~ ('(f, b) ': as')
164+ ) => IndexList 0 as bs a b where
165+ point = lens (\(x :> xs) -> (xs, x)) (\(xs, x') -> x' :> xs)
166+ {-# INLINE point #-}
167+
168+instance
169+ ( IndexList (n - 1) as' bs' a b
170+ , as ~ ('(f, x) ': as')
171+ , bs ~ ('(f, x) ': bs')
172+ ) => IndexList n as bs a b where
173+ point = fromIso consing . alongside id (point @(n-1)) . second'
174+ {-# INLINE point #-}
175+
176+--------------------------------------------------------------------------------
177+-- * Convert tuples to/from HLists
178+
179+class ListTuple (tuple :: Type) (as :: [(k, Type)]) | as -> tuple where
180+ type ListToTuple as :: Type
181+ tupled :: Iso' (List as) tuple
182+ tupled = iso listToTuple tupleToList
183+
184+ tupleToList :: tuple -> List as
185+ listToTuple :: List as -> tuple
186+
187+instance ListTuple () '[] where
188+ type ListToTuple '[] = ()
189+ tupleToList _ = Nil
190+ listToTuple _ = ()
191+
192+instance ListTuple a '[ '(fa, a)] where
193+ type ListToTuple '[ '(fa, a)] = a
194+ tupleToList a
195+ = a :> Nil
196+ listToTuple (a :> Nil)
197+ = a
198+
199+instance ListTuple (a, b) '[ '(fa, a), '(fb, b)] where
200+ type ListToTuple '[ '(fa, a), '(fb, b)] = (a, b)
201+ tupleToList (a, b)
202+ = a :> b :> Nil
203+ listToTuple (a :> b :> Nil)
204+ = (a, b)
205+
206+instance ListTuple (a, b, c) '[ '(fa, a), '(fb, b), '(fc, c)] where
207+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c)] = (a, b, c)
208+ tupleToList (a, b, c)
209+ = a :> b :> c :> Nil
210+ listToTuple (a :> b :> c :> Nil)
211+ = (a, b, c)
212+
213+instance ListTuple (a, b, c, d) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d)] where
214+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d)] = (a, b, c, d)
215+ tupleToList (a, b, c, d)
216+ = a :> b :> c :> d:> Nil
217+ listToTuple (a :> b :> c :> d :> Nil)
218+ = (a, b, c, d)
219+
220+instance ListTuple (a, b, c, d, e) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e)] where
221+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e)] = (a, b, c, d, e)
222+ tupleToList (a, b, c, d, e)
223+ = a :> b :> c :> d:> e :> Nil
224+ listToTuple (a :> b :> c :> d :> e :> Nil)
225+ = (a, b, c, d, e)
226+
227+instance ListTuple (a, b, c, d, e, f) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f)] where
228+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f)] = (a, b, c, d, e, f)
229+ tupleToList (a, b, c, d, e, f)
230+ = a :> b :> c :> d:> e :> f :> Nil
231+ listToTuple (a :> b :> c :> d :> e :> f :> Nil)
232+ = (a, b, c, d, e, f)
233+
234+instance ListTuple (a, b, c, d, e, f, g) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g)] where
235+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g)] = (a, b, c, d, e, f, g)
236+ tupleToList (a, b, c, d, e, f, g)
237+ = a :> b :> c :> d:> e :> f :> g :> Nil
238+ listToTuple (a :> b :> c :> d :> e :> f :> g :> Nil)
239+ = (a, b, c, d, e, f, g)
240+
241+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
242+ 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)
243+ tupleToList (a, b, c, d, e, f, g, h)
244+ = a :> b :> c :> d:> e :> f :> g :> h :> Nil
245+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> Nil)
246+ = (a, b, c, d, e, f, g, h)
247+
248+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
249+ 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)
250+ tupleToList (a, b, c, d, e, f, g, h, j)
251+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> Nil
252+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> Nil)
253+ = (a, b, c, d, e, f, g, h, j)
254+
255+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
256+ 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)
257+ tupleToList (a, b, c, d, e, f, g, h, j, k)
258+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> Nil
259+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> Nil)
260+ = (a, b, c, d, e, f, g, h, j, k)
261+
262+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
263+ 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)
264+ tupleToList (a, b, c, d, e, f, g, h, j, k, l)
265+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> Nil
266+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> Nil)
267+ = (a, b, c, d, e, f, g, h, j, k, l)
268+
269+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
270+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m)] = (a, b, c, d, e, f, g, h, j, k, l, m)
271+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m)
272+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> Nil
273+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> Nil)
274+ = (a, b, c, d, e, f, g, h, j, k, l, m)
275+
276+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
277+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n)] = (a, b, c, d, e, f, g, h, j, k, l, m, n)
278+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n)
279+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil
280+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil)
281+ = (a, b, c, d, e, f, g, h, j, k, l, m, n)
282+
283+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
284+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
285+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
286+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil
287+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil)
288+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
289+
290+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
291+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
292+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
293+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil
294+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil)
295+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
296+
297+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
298+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
299+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
300+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil
301+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil)
302+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
303+
304+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
305+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
306+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
307+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil
308+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil)
309+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
310+
311+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
312+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r), '(fs, s)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
313+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
314+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil
315+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil)
316+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
317+
318+type family TupleToList a where
319+ TupleToList () = '[]
320+ TupleToList (a, b) = '[ '( '(), a), '( '(), b)]
321+ TupleToList (a, b, c) = '[ '( '(), a), '( '(), b), '( '(), c)]
322+ TupleToList (a, b, c, d) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d)]
323+ TupleToList (a, b, c, d, e) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e)]
324+ TupleToList (a, b, c, d, e, f) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f)]
325+ TupleToList (a, b, c, d, e, f, g) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g)]
326+ TupleToList (a, b, c, d, e, f, g, h) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h)]
327+ TupleToList (a, b, c, d, e, f, g, h, j) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j)]
328+ TupleToList (a, b, c, d, e, f, g, h, j, k) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k)]
329+ TupleToList (a, b, c, d, e, f, g, h, j, k, l) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l)]
330+ 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)]
331+ 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)]
332+ 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)]
333+ 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)]
334+ 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)]
335+ 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)]
336+ 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)]
337+ TupleToList a = '[ '( '(), a)]
src/Data/Generics/Product/Internal/Positions.hs+6−6
@@ -17,7 +17,7 @@
17-----------------------------------------------------------------------------
17-----------------------------------------------------------------------------
18-- |
18-- |
19-- Module : Data.Generics.Product.Internal.Positions
19-- Module : Data.Generics.Product.Internal.Positions
20−-- Copyright : (C) 2019 Csongor Kiss
20+-- Copyright : (C) 2017 Csongor Kiss
21-- License : BSD3
21-- License : BSD3
22-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
22-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
23-- Stability : experimental
23-- Stability : experimental
@@ -40,7 +40,7 @@ import GHC.Generics
40import GHC.TypeLits (type (<=?), type (+), Nat)
40import GHC.TypeLits (type (<=?), type (+), Nat)
41
41
42-- | Alias for the kind of the generic rep
42-- | Alias for the kind of the generic rep
43−type G = Type -> Type
43+type G k = k -> Type
44
44
45--------------------------------------------------------------------------------
45--------------------------------------------------------------------------------
46
46
@@ -50,7 +50,7 @@ type G = Type -> Type
50-- of the field in question in the data type. This is convenient, because we
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
51-- can reuse all the existing functions as long as they are polymorphic in the
52-- first parameter of 'K1'.
52-- first parameter of 'K1'.
53−type family CRep (a :: Type) :: G where
53+type family CRep (a :: Type) :: G k where
54 CRep rep = Fst (Traverse (Rep rep) 1)
54 CRep rep = Fst (Traverse (Rep rep) 1)
55
55
56-- | The actual traversal.
56-- | The actual traversal.
@@ -58,7 +58,7 @@ type family CRep (a :: Type) :: G where
58-- Might be cleaner if the sum and product parts were separated (as there's
58-- Might be cleaner if the sum and product parts were separated (as there's
59-- and invariant that 'n' should be zero when we're at a sum node, which holds
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))
60-- for derived Generic instances (where the sums are strictly above the products))
61−type family Traverse (a :: G) (n :: Nat) :: (G, Nat) where
61+type family Traverse (a :: G k) (n :: Nat) :: (G k, Nat) where
62 Traverse (M1 mt m s) n
62 Traverse (M1 mt m s) n
63 = Traverse1 (M1 mt m) (Traverse s n)
63 = Traverse1 (M1 mt m) (Traverse s n)
64 Traverse (l :+: r) n
64 Traverse (l :+: r) n
@@ -70,12 +70,12 @@ type family Traverse (a :: G) (n :: Nat) :: (G, Nat) where
70 Traverse U1 n
70 Traverse U1 n
71 = '(U1, n)
71 = '(U1, n)
72
72
73−type family Traverse1 (w :: G -> G) (z :: (G, Nat)) :: (G, Nat) where
73+type family Traverse1 (w :: G k -> G k) (z :: (G k, Nat)) :: (G k, Nat) where
74 Traverse1 w '(i, n) = '(w i, n)
74 Traverse1 w '(i, n) = '(w i, n)
75
75
76-- | For products, we first traverse the left-hand side, followed by the second
76-- | For products, we first traverse the left-hand side, followed by the second
77-- using the counter returned by the left traversal.
77-- using the counter returned by the left traversal.
78−type family TraverseProd (c :: G -> G -> G) (a :: (G, Nat)) (r :: G) :: (G, Nat) where
78+type family TraverseProd (c :: G k -> G k -> G k) (a :: (G k, Nat)) (r :: G k) :: (G k, Nat) where
79 TraverseProd w '(i, n) r = Traverse1 (w i) (Traverse r n)
79 TraverseProd w '(i, n) r = Traverse1 (w i) (Traverse r n)
80
80
81--------------------------------------------------------------------------------
81--------------------------------------------------------------------------------
src/Data/Generics/Product/Internal/Subtype.hs+5−5
@@ -16,7 +16,7 @@
16-----------------------------------------------------------------------------
16-----------------------------------------------------------------------------
17-- |
17-- |
18-- Module : Data.Generics.Product.Internal.Subtype
18-- Module : Data.Generics.Product.Internal.Subtype
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
@@ -82,16 +82,16 @@ instance GSmash sub sup => GSmash (C1 c sub) sup where
82instance GSmash sub sup => GSmash (D1 c sub) sup where
82instance GSmash sub sup => GSmash (D1 c sub) sup where
83 gsmash sup (M1 sub) = M1 (gsmash sup sub)
83 gsmash sup (M1 sub) = M1 (gsmash sup sub)
84
84
85−class GSmashLeaf sub sup (w :: Maybe Type) where
85+class GSmashLeaf sub sup (w :: Bool) where
86 gsmashLeaf :: sup p -> sub p -> sub p
86 gsmashLeaf :: sup p -> sub p -> sub p
87
87
88instance
88instance
89 GLens' (HasTotalFieldPSym field) sup t
89 GLens' (HasTotalFieldPSym field) sup t
90− => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup ('Just t) where
90+ => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'True where
91 gsmashLeaf sup _ = M1 (K1 (view (glens @(HasTotalFieldPSym field)) sup))
91 gsmashLeaf sup _ = M1 (K1 (view (glens @(HasTotalFieldPSym field)) sup))
92
92
93−instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'Nothing where
93+instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'False where
94 gsmashLeaf _ = id
94 gsmashLeaf _ = id
95
95
96−data HasTotalFieldPSym :: Symbol -> (TyFun (Type -> Type) (Maybe Type))
96+data HasTotalFieldPSym :: Symbol -> (TyFun (Type -> Type) Bool)
97type instance Eval (HasTotalFieldPSym sym) tt = HasTotalFieldP sym tt
97type 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+25−90
@@ -19,7 +19,7 @@
19-----------------------------------------------------------------------------
19-----------------------------------------------------------------------------
20-- |
20-- |
21-- Module : Data.Generics.Product.Positions
21-- Module : Data.Generics.Product.Positions
22−-- Copyright : (C) 2019 Csongor Kiss
22+-- Copyright : (C) 2017 Csongor Kiss
23-- License : BSD3
23-- License : BSD3
24-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
24-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
25-- Stability : experimental
25-- Stability : experimental
@@ -35,8 +35,6 @@ module Data.Generics.Product.Positions
35 -- $setup
35 -- $setup
36 HasPosition (..)
36 HasPosition (..)
37 , HasPosition' (..)
37 , HasPosition' (..)
38− , HasPosition_ (..)
39− , HasPosition0 (..)
40
38
41 , getPosition
39 , getPosition
42 , setPosition
40 , setPosition
@@ -47,7 +45,6 @@ import Data.Generics.Internal.Void
47import Data.Generics.Internal.Families
45import Data.Generics.Internal.Families
48import Data.Generics.Product.Internal.Positions
46import Data.Generics.Product.Internal.Positions
49import Data.Generics.Product.Internal.GLens
47import Data.Generics.Product.Internal.GLens
50−import Data.Generics.Internal.Errors
51
48
52import Data.Kind (Constraint, Type)
49import Data.Kind (Constraint, Type)
53import Data.Type.Bool (type (&&))
50import Data.Type.Bool (type (&&))
@@ -96,34 +93,12 @@ class HasPosition (i :: Nat) s t a b | s i -> a, t i -> b, s i b -> t, t i a ->
96 -- ...
93 -- ...
97 position :: VL.Lens s t a b
94 position :: VL.Lens s t a b
98
95
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
96class HasPosition' (i :: Nat) s a | s i -> a where
109 position' :: VL.Lens s s a a
97 position' :: VL.Lens s s a a
110
98
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
99getPosition :: forall i s a. HasPosition' i s a => s -> a
122getPosition s = s ^. position' @i
100getPosition s = s ^. position' @i
123
101
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
102setPosition :: forall i s a. HasPosition' i s a => a -> s -> s
128setPosition = VL.set (position' @i)
103setPosition = VL.set (position' @i)
129
104
@@ -133,35 +108,35 @@ instance
133 , cs ~ CRep s
108 , cs ~ CRep s
134 , Coercible (Rep s) cs
109 , Coercible (Rep s) cs
135 , GLens' (HasTotalPositionPSym i) cs a
110 , 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
111 ) => HasPosition' i s a where
143 position' f s = VL.ravel (repLens . coerced @cs @cs . glens @(HasTotalPositionPSym i)) f s
112 position' f s = VL.ravel (repLens . coerced @cs @cs . glens @(HasTotalPositionPSym i)) f s
144 {-# INLINE position' #-}
113 {-# INLINE position' #-}
145
114
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]
115instance -- see Note [Changing type parameters]
116+ ( Generic s
152− ( ErrorUnless i s (0 <? i && i <=? Size (Rep s))
117+ , ErrorUnless i s (0 <? i && i <=? Size (Rep s))
153− , HasTotalPositionP i (CRep s) ~~ 'Just a
118+ , Generic t
154− , HasTotalPositionP i (CRep t) ~~ 'Just b
119+ -- see Note [CPP in instance constraints]
155− , HasTotalPositionP i (CRep (Indexed s)) ~~ 'Just a'
120+#if __GLASGOW_HASKELL__ < 802
156− , HasTotalPositionP i (CRep (Indexed t)) ~~ 'Just b'
121+ , '(s', t') ~ '(Proxied s, Proxied t)
122+#else
123+ , s' ~ Proxied s
124+ , t' ~ Proxied t
125+#endif
126+ , Generic s'
127+ , Generic t'
128+ , GLens (HasTotalPositionPSym i) cs ct a b
129+ , cs ~ CRep s
130+ , ct ~ CRep t
131+ , GLens' (HasTotalPositionPSym i) (CRep s') a'
132+ , GLens' (HasTotalPositionPSym i) (CRep t') b'
157− , t ~~ Infer s a' b
133+ , t ~ Infer s a' b
158− , s ~~ Infer t b' a
134+ , s ~ Infer t b' a
159− , Coercible (CRep s) (Rep s)
135+ , Coercible cs (Rep s)
160− , Coercible (CRep t) (Rep t)
136+ , Coercible ct (Rep t)
161− , HasPosition0 i s t a b
162 ) => HasPosition i s t a b where
137 ) => HasPosition i s t a b where
163
138
164− position = position0 @i
139+ position = VL.ravel (repLens . coerced @cs @ct . glens @(HasTotalPositionPSym i))
165 {-# INLINE position #-}
140 {-# INLINE position #-}
166
141
167-- We wouldn't need the universal 'x' here if we could express above that
142-- We wouldn't need the universal 'x' here if we could express above that
@@ -172,50 +147,10 @@ coerced :: forall s t s' t' x a b. (Coercible t t', Coercible s s')
172coerced = coerce
147coerced = coerce
173{-# INLINE coerced #-}
148{-# INLINE coerced #-}
174
149
175−-- | See Note [Uncluttering type signatures]
150+-- 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
151instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where
186 position = undefined
152 position = undefined
187
153
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
154type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint where
220 ErrorUnless i s 'False
155 ErrorUnless i s 'False
221 = TypeError
156 = TypeError
@@ -228,5 +163,5 @@ type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint wher
228 ErrorUnless _ _ 'True
163 ErrorUnless _ _ 'True
229 = ()
164 = ()
230
165
231−data HasTotalPositionPSym :: Nat -> (TyFun (Type -> Type) (Maybe Type))
166+data HasTotalPositionPSym :: Nat -> (TyFun (Type -> Type) Bool)
232type instance Eval (HasTotalPositionPSym t) tt = HasTotalPositionP t tt
167type 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+3−24
@@ -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 #-}
@@ -15,7 +14,7 @@
15-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
16-- |
15-- |
17-- Module : Data.Generics.Product.Typed
16-- Module : Data.Generics.Product.Typed
18−-- Copyright : (C) 2019 Csongor Kiss
17+-- Copyright : (C) 2017 Csongor Kiss
19-- License : BSD3
18-- License : BSD3
20-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21-- Stability : experimental
20-- Stability : experimental
@@ -41,7 +40,6 @@ import Data.Kind (Constraint, Type)
41import GHC.Generics (Generic (Rep))
40import GHC.Generics (Generic (Rep))
42import GHC.TypeLits (TypeError, ErrorMessage (..))
41import GHC.TypeLits (TypeError, ErrorMessage (..))
43import Data.Generics.Internal.Profunctor.Lens
42import Data.Generics.Internal.Profunctor.Lens
44−import Data.Generics.Internal.Errors
45
43
46-- $setup
44-- $setup
47-- == /Running example:/
45-- == /Running example:/
@@ -113,31 +111,12 @@ class HasType a s where
113instance
111instance
114 ( Generic s
112 ( Generic s
115 , ErrorUnlessOne a s (CollectTotalType a (Rep s))
113 , 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
114 , GLens (HasTotalTypePSym a) (Rep s) (Rep s) a a
120 ) => HasType a s where
115 ) => HasType a s where
121
116
122 typed f s = VL.ravel (repLens . glens @(HasTotalTypePSym a)) f s
117 typed f s = VL.ravel (repLens . glens @(HasTotalTypePSym a)) f s
123
118
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]
119+-- 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
120instance {-# OVERLAPPING #-} HasType a Void where
142 typed = undefined
121 typed = undefined
143
122
@@ -173,6 +152,6 @@ type family ErrorUnlessOne (a :: Type) (s :: Type) (stat :: TypeStat) :: Constra
173 ErrorUnlessOne _ _ ('TypeStat '[] '[] _)
152 ErrorUnlessOne _ _ ('TypeStat '[] '[] _)
174 = ()
153 = ()
175
154
176−data HasTotalTypePSym :: Type -> (TyFun (Type -> Type) (Maybe Type))
155+data HasTotalTypePSym :: Type -> (TyFun (Type -> Type) Bool)
177type instance Eval (HasTotalTypePSym t) tt = HasTotalTypeP t tt
156type instance Eval (HasTotalTypePSym t) tt = HasTotalTypeP t tt
178
157
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 #-}
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 ]