on master help sign in
.github/FUNDING.ymlnew file+12
since splitsnapshots
unifiedsplit
@@ -0,0 +1,12 @@
1+# These are supported funding model platforms
2+
3+github: [kcsongor] # Replace with up to 4 GitHub Sponsors-enabled usernames e.g., [user1, user2]
4+patreon: # Replace with a single Patreon username
5+open_collective: # Replace with a single Open Collective username
6+ko_fi: # Replace with a single Ko-fi username
7+tidelift: # Replace with a single Tidelift platform-name/package-name e.g., npm/babel
8+community_bridge: # Replace with a single Community Bridge project-name e.g., cloud-foundry
9+liberapay: # Replace with a single Liberapay username
10+issuehunt: # Replace with a single IssueHunt username
11+otechie: # Replace with a single Otechie username
12+custom: # Replace with up to 4 custom sponsorship URLs e.g., ['link1', 'link2']
.gitignore+3
@@ -7,3 +7,6 @@ cabal.sandbox.config
7*.hi
7*.hi
8*.o
8*.o
9core-html
9core-html
10+*~
11+*.org
12+cabal.project.local
.travis.yml+132−71
@@ -1,94 +1,155 @@
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−# make_travis_yml_2.hs 'generic-lens.cabal'
3+# haskell-ci '--config=cabal.haskell-ci' 'cabal.project'
4#
4#
5−# For more information, see https://github.com/hvr/multi-ghc-travis
5+# For more information, see https://github.com/haskell-CI/haskell-ci
6+#
7+# version: 0.5.20190908
6#
8#
7language: c
9language: c
8−sudo: false
10+dist: xenial
9−
10git:
11git:
11− submodules: false # whether to recursively clone submodules
12+ # whether to recursively clone submodules
12−
13+ submodules: false
13cache:
14cache:
14 directories:
15 directories:
15 - $HOME/.cabal/packages
16 - $HOME/.cabal/packages
16 - $HOME/.cabal/store
17 - $HOME/.cabal/store
17−
18before_cache:
18before_cache:
19− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
19+ - rm -fv $CABALHOME/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 $HOME/.cabal/packages/hackage.haskell.org/00-index.*
21+ - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*
22− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json
22+ - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json
23− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache
23+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache
24− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar
24+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar
25− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx
25+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx
26−
26+ - rm -rfv $CABALHOME/packages/head.hackage
27matrix:
27matrix:
28 include:
28 include:
29− - compiler: "ghc-8.0.2"
29+ - compiler: ghc-8.8.1
30− # env: TEST=--disable-tests BENCH=--disable-benchmarks
31− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.2], sources: [hvr-ghc]}}
30+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}}
31+ - compiler: ghc-8.6.5
32+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-3.0"]}}
32− - compiler: "ghc-8.2.1"
33+ - compiler: ghc-8.4.4
33− # env: TEST=--disable-tests BENCH=--disable-benchmarks
34− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.1], sources: [hvr-ghc]}}
34+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-3.0"]}}
35+ - compiler: ghc-8.4.1
36+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.1","cabal-install-3.0"]}}
35− - compiler: "ghc-8.2.2"
37+ - compiler: ghc-8.2.2
36− # env: TEST=--disable-tests BENCH=--disable-benchmarks
38+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-3.0"]}}
37− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.2], sources: [hvr-ghc]}}
38− - compiler: "ghc-8.4.1"
39+ - compiler: ghc-8.0.2
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]}}
40+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-3.0"]}}
41−
42before_install:
41before_install:
43− - HC=${CC}
42+ - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')
43+ - WITHCOMPILER="-w $HC"
44+ - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//')
44− - HCPKG=${HC/ghc/ghc-pkg}
45+ - HCPKG="$HC-pkg"
45 - unset CC
46 - unset CC
46− - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH
47+ - CABAL=/opt/ghc/bin/cabal
47−
48+ - CABALHOME=$HOME/.cabal
49+ - export PATH="$CABALHOME/bin:$PATH"
50+ - TOP=$(pwd)
51+ - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')"
52+ - echo $HCNUMVER
53+ - CABAL="$CABAL -vnormal+nowrap+markoutput"
54+ - set -o pipefail
55+ - |
56+ echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk
57+ echo 'BEGIN { state = "output"; }' >> .colorful.awk
58+ echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk
59+ echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk
60+ echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk
61+ echo ' if (state == "cabal") {' >> .colorful.awk
62+ echo ' print blue($0)' >> .colorful.awk
63+ echo ' } else {' >> .colorful.awk
64+ echo ' print $0' >> .colorful.awk
65+ echo ' }' >> .colorful.awk
66+ echo '}' >> .colorful.awk
67+ - cat .colorful.awk
68+ - |
69+ color_cabal_output () {
70+ awk -f $TOP/.colorful.awk
71+ }
72+ - echo text | color_cabal_output
48install:
73install:
49− - cabal --version
74+ - ${CABAL} --version
50 - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
75 - 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
51− - BENCH=${BENCH---enable-benchmarks}
78+ - BENCH=--enable-benchmarks
52− - TEST=${TEST---enable-tests}
79+ - if [ $HCNUMVER -ge 80800 ] ; then BENCH=--disable-benchmarks ; fi
53− - HADDOCK=${HADDOCK-true}
80+ - HEADHACKAGE=false
54− - INSTALLED=${INSTALLED-true}
81+ - rm -f $CABALHOME/config
82+ - |
83+ echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config
84+ echo "remote-build-reporting: anonymous" >> $CABALHOME/config
85+ echo "write-ghc-environment-files: always" >> $CABALHOME/config
86+ echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config
87+ echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config
88+ echo "world-file: $CABALHOME/world" >> $CABALHOME/config
89+ echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config
90+ echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config
91+ echo "installdir: $CABALHOME/bin" >> $CABALHOME/config
92+ echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config
93+ echo "store-dir: $CABALHOME/store" >> $CABALHOME/config
94+ echo "install-dirs user" >> $CABALHOME/config
95+ echo " prefix: $CABALHOME" >> $CABALHOME/config
96+ echo "repository hackage.haskell.org" >> $CABALHOME/config
97+ echo " url: http://hackage.haskell.org/" >> $CABALHOME/config
98+ - |
99+ echo "program-default-options" >> $CABALHOME/config
100+ echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config
101+ - cat $CABALHOME/config
102+ - rm -fv cabal.project cabal.project.local cabal.project.freeze
55− - travis_retry cabal update -v
103+ - travis_retry ${CABAL} v2-update -v
56− - sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
104+ # Generate cabal.project
105+ - rm -rf cabal.project cabal.project.local cabal.project.freeze
106+ - touch cabal.project
107+ - |
57− - rm -fv cabal.project.local
108+ echo "packages: ." >> cabal.project
58− - "echo 'packages: .' > cabal.project"
109+ - |
110+ - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(generic-lens)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
111+ - cat cabal.project || true
112+ - cat cabal.project.local || true
59− - if [ -f "./configure.ac" ]; then
113+ - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi
60− (cd "."; autoreconf -i);
114+ - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output
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
64− - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all
118+ - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all | color_cabal_output
65− - rm -rf "."/.ghc.environment.* "."/dist
66− - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
67−
68−# Here starts the actual work to be performed for the package under test;
69−# any command which exits with a non-zero exit code causes the build to fail.
70script:
119script:
71− # test that source-distributions can be generated
120+ - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
72− - (cd "."; cabal sdist)
121+ # Packaging...
122+ - ${CABAL} v2-sdist all | color_cabal_output
123+ # Unpacking...
73− - mv "."/dist/generic-lens-*.tar.gz ${DISTDIR}/
124+ - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
74− - cd ${DISTDIR}
125+ - cd ${DISTDIR} || false
75− - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;
126+ - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \;
76− - "printf 'packages: generic-lens-*/*.cabal' > cabal.project"
127+ - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \;
128+ - PKGDIR_generic_lens="$(find . -maxdepth 1 -type d -regex '.*/generic-lens-[0-9.]*')"
129+ # Generate cabal.project
130+ - rm -rf cabal.project cabal.project.local cabal.project.freeze
131+ - touch cabal.project
132+ - |
133+ echo "packages: ${PKGDIR_generic_lens}" >> cabal.project
134+ - |
135+ - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(generic-lens)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
136+ - cat cabal.project || true
137+ - cat cabal.project.local || true
138+ # Building...
77 # this builds all libraries and executables (without tests/benchmarks)
139 # this builds all libraries and executables (without tests/benchmarks)
78− - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all
140+ - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output
79−
141+ # Building with tests and benchmarks...
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−
85 # build & run tests, build benchmarks
142 # build & run tests, build benchmarks
86− - cabal new-build -w ${HC} ${TEST} ${BENCH} all
143+ - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output
87− - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} all; fi
144+ # Testing...
88−
145+ - if [ $HCNUMVER -lt 80600 ] ; then ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi
89− # haddock
146+ # cabal check...
90− - rm -rf ./dist-newstyle
147+ - (cd ${PKGDIR_generic_lens} && ${CABAL} -vnormal check)
91− - if $HADDOCK; then cabal new-haddock -w ${HC} --disable-tests --disable-benchmarks all; else echo "Skipping haddock generation";fi
148+ # haddock...
149+ - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all | color_cabal_output
150+ # Building without installed constraints for packages in global-db...
151+ - rm -f cabal.project.local
152+ - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output
92
153
93−# REGENDATA ["generic-lens.cabal"]
154+# REGENDATA ["--config=cabal.haskell-ci","cabal.project"]
94# EOF
155# EOF
ChangeLog.md+20
@@ -1,3 +1,23 @@
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+
1## 1.0.0.2
21## 1.0.0.2
2- Fix compile-time performance regression
22- Fix compile-time performance regression
3
23
LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2017, Csongor Kiss
1+Copyright (c) 2019, Csongor Kiss
2
2
3All rights reserved.
3All rights reserved.
4
4
README.md+4−1
@@ -16,6 +16,9 @@ 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+
19Table of contents
22Table of contents
20=================
23=================
21
24
@@ -407,7 +410,7 @@ The
407library is used to ensure (see [here](test/Spec.hs)) that everything gets
410library is used to ensure (see [here](test/Spec.hs)) that everything gets
408inlined away.
411inlined away.
409
412
410−TODO push benchmarks too
413+There is also a [benchmark suite](https://github.com/mpickering/generic-lens-benchmarks) with larger, real-world examples.
411# Contributors
414# Contributors
412
415
413+ [Matthew Pickering](https://github.com/mpickering)
416+ [Matthew Pickering](https://github.com/mpickering)
cabal.haskell-cinew file+5
@@ -0,0 +1,5 @@
1+-- inspection tests fail
2+tests: <8.6
3+
4+-- blocked on vector-th-unbox
5+benchmarks: <8.8
cabal.project+1
@@ -1 +1,2 @@
1packages: generic-lens.cabal
1packages: generic-lens.cabal
2+write-ghc-environment-files: always
examples/doctest.hs+1
@@ -2,5 +2,6 @@ import Test.DocTest
2main
2main
3 = doctest
3 = doctest
4 [ "-iexamples"
4 [ "-iexamples"
5+ , "-isrc"
5 , "examples/Biscuits.hs"
6 , "examples/Biscuits.hs"
6 ]
7 ]
generic-lens.cabal+14−9
@@ -1,5 +1,5 @@
1name: generic-lens
1name: generic-lens
2−version: 1.0.0.2
2+version: 1.2.0.1
3synopsis: Generically derive traversals, lenses and prisms.
3synopsis: Generically derive traversals, lenses and prisms.
4description: This library uses GHC.Generics to derive efficient optics (traversals, lenses and prisms) for algebraic data types in a type-directed way, with a focus on good type inference and error messages when possible.
4description: This library uses GHC.Generics to derive efficient optics (traversals, lenses and prisms) for algebraic data types in a type-directed way, with a focus on good type inference and error messages when possible.
5
5
@@ -11,7 +11,7 @@ maintainer: kiss.csongor.kiss@gmail.com
11category: Generics, Records, Lens
11category: Generics, Records, Lens
12build-type: Simple
12build-type: Simple
13cabal-version: >= 1.10
13cabal-version: >= 1.10
14−Tested-With: GHC == 8.0.2, GHC == 8.2.1
14+Tested-With: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.1
15
15
16extra-source-files: ChangeLog.md
16extra-source-files: ChangeLog.md
17 , examples/StarWars.hs
17 , examples/StarWars.hs
@@ -23,7 +23,7 @@ flag dump-core
23 default: False
23 default: False
24
24
25library
25library
26− exposed-modules: Data.Generics.Iso
26+ exposed-modules: Data.Generics.Wrapped
27 , Data.Generics.Product
27 , Data.Generics.Product
28 , Data.Generics.Product.Any
28 , Data.Generics.Product.Any
29 , Data.Generics.Product.Fields
29 , Data.Generics.Product.Fields
@@ -33,7 +33,8 @@ library
33 , Data.Generics.Product.Typed
33 , Data.Generics.Product.Typed
34 , Data.Generics.Product.Types
34 , Data.Generics.Product.Types
35 , Data.Generics.Product.Constraints
35 , Data.Generics.Product.Constraints
36− , Data.Generics.Product.List
36+ , Data.Generics.Product.HList
37+ , Data.Generics.Labels
37 , Data.Generics.Internal.GenericN
38 , Data.Generics.Internal.GenericN
38
39
39 , Data.Generics.Sum
40 , Data.Generics.Sum
@@ -49,10 +50,13 @@ library
49 , Data.Generics.Internal.VL.Prism
50 , Data.Generics.Internal.VL.Prism
50 , Data.Generics.Internal.VL.Iso
51 , Data.Generics.Internal.VL.Iso
51
52
53+ , Data.GenericLens.Internal
54+
52 other-modules: Data.Generics.Internal.Families
55 other-modules: Data.Generics.Internal.Families
53 , Data.Generics.Internal.Families.Changing
56 , Data.Generics.Internal.Families.Changing
54 , Data.Generics.Internal.Families.Collect
57 , Data.Generics.Internal.Families.Collect
55 , Data.Generics.Internal.Families.Has
58 , Data.Generics.Internal.Families.Has
59+ , Data.Generics.Internal.Errors
56 , Data.Generics.Internal.Void
60 , Data.Generics.Internal.Void
57
61
58 , Data.Generics.Sum.Internal.Constructors
62 , Data.Generics.Sum.Internal.Constructors
@@ -64,11 +68,12 @@ library
64 , Data.Generics.Product.Internal.Subtype
68 , Data.Generics.Product.Internal.Subtype
65
69
66 , Data.Generics.Product.Internal.Constraints
70 , Data.Generics.Product.Internal.Constraints
67− , Data.Generics.Product.Internal.List
71+ , Data.Generics.Product.Internal.HList
68
72
69− build-depends: base >= 4.9 && <= 5.0
73+ build-depends: base >= 4.9 && < 5
70− , profunctors >= 5.0 && <= 6.0
74+ , profunctors >= 5.0 && < 6.0
71− , tagged >= 0.8 && <= 0.9
75+ , tagged >= 0.8 && < 1
76+ , text >= 1.2 && < 1.3
72
77
73 hs-source-dirs: src
78 hs-source-dirs: src
74 default-language: Haskell2010
79 default-language: Haskell2010
@@ -98,7 +103,7 @@ test-suite generic-lens-test
98 type: exitcode-stdio-1.0
103 type: exitcode-stdio-1.0
99 hs-source-dirs: test
104 hs-source-dirs: test
100 main-is: Spec.hs
105 main-is: Spec.hs
101− other-modules: Util Test24 Test25 Test40
106+ other-modules: Util Test24 Test25 Test40 Test62 Test63 CustomChildren
102
107
103 build-depends: base >= 4.9 && <= 5.0
108 build-depends: base >= 4.9 && <= 5.0
104 , generic-lens
109 , generic-lens
src/Data/GenericLens/Internal.hsnew file+64
@@ -0,0 +1,64 @@
1+-----------------------------------------------------------------------------
2+-- |
3+-- Module : Data.GenericLens.Internal
4+-- Copyright : (C) 2019 Csongor Kiss
5+-- License : BSD3
6+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
7+-- Stability : experimental
8+-- Portability : non-portable
9+--
10+-- The library internals are exposed through this module. Please keep
11+-- in mind that everything here is subject to change irrespective of
12+-- the the version numbers.
13+-----------------------------------------------------------------------------
14+
15+module Data.GenericLens.Internal
16+ ( module Data.Generics.Internal.Families
17+ , module Data.Generics.Internal.Families.Changing
18+ , module Data.Generics.Internal.Families.Collect
19+ , module Data.Generics.Internal.Families.Has
20+ , module Data.Generics.Internal.Void
21+ , module Data.Generics.Internal.Errors
22+
23+ , module Data.Generics.Sum.Internal.Constructors
24+ , module Data.Generics.Sum.Internal.Typed
25+ , module Data.Generics.Sum.Internal.Subtype
26+
27+ , module Data.Generics.Product.Internal.Positions
28+ , module Data.Generics.Product.Internal.GLens
29+ , module Data.Generics.Product.Internal.Subtype
30+ , module Data.Generics.Product.Internal.Constraints
31+ , module Data.Generics.Product.Internal.HList
32+
33+ , module Data.Generics.Internal.GenericN
34+
35+ -- * van Laarhoven optics
36+ , module Data.Generics.Internal.VL.Iso
37+ , module Data.Generics.Internal.VL.Lens
38+ , module Data.Generics.Internal.VL.Prism
39+ , module Data.Generics.Internal.VL.Traversal
40+ ) where
41+
42+import Data.Generics.Internal.Families
43+import Data.Generics.Internal.Families.Changing
44+import Data.Generics.Internal.Families.Collect
45+import Data.Generics.Internal.Families.Has
46+import Data.Generics.Internal.Void
47+import Data.Generics.Internal.Errors
48+
49+import Data.Generics.Sum.Internal.Constructors
50+import Data.Generics.Sum.Internal.Typed
51+import Data.Generics.Sum.Internal.Subtype
52+
53+import Data.Generics.Product.Internal.Positions
54+import Data.Generics.Product.Internal.GLens
55+import Data.Generics.Product.Internal.Subtype
56+import Data.Generics.Product.Internal.Constraints
57+import Data.Generics.Product.Internal.HList
58+
59+import Data.Generics.Internal.GenericN
60+
61+import Data.Generics.Internal.VL.Iso
62+import Data.Generics.Internal.VL.Lens
63+import Data.Generics.Internal.VL.Prism
64+import Data.Generics.Internal.VL.Traversal
src/Data/GenericLens/Internal.hs~new file

No changes to the content.

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