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+23
@@ -1,3 +1,26 @@
1+## 1.2.0.1
2+- Give HasAny/AsAny the same VTA behavior on 8.6 and 8.8 (Ryan Scott)
3+
4+## 1.2.0.0
5+- Add `HasTypesUsing` and `HasTypesCustom` for custom traversals (Lysxia)
6+- Improve type errors when no Generic instance is defined
7+- `types` now supports Text by default
8+
9+### Breaking API changes
10+- `HasType` now includes a reflexive case so that every type 'contains' itself (Matt Parsons)
11+- `AsSubtype` and `Subtype` now include a reflexive case so that every type is a subtype of itself
12+
13+## 1.1.0.0
14+- Fix regression in type inference for polymorphic optics
15+- Add `HasField0`, `HasPosition0`, `AsConstructor0`, `HasField_`, `HasPositon_`, and `AsConstructor_` (Lysxia)
16+- `types` now supports Data.Word and Data.Int (Lysxia)
17+- Add `Wrapped` iso for newtypes (Isaac Elliott)
18+- Expose internals through Data.GenericLens.Internal
19+- Add labels for prisms (Daniel Winograd-Cort)
20+
21+## 1.0.0.2
22+- Fix compile-time performance regression
23+
1## 1.0.0.1
24## 1.0.0.1
2- Remove dump-core dependency
25- Remove dump-core dependency
3- Relax upper bound on criterion (#42)
26- Relax upper bound on criterion (#42)
LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2017, Csongor Kiss
1+Copyright (c) 2019, Csongor Kiss
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+16−10
@@ -1,5 +1,5 @@
1name: generic-lens
1name: generic-lens
2−version: 1.0.0.1
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,8 @@ flag dump-core
23 default: False
23 default: False
24
24
25library
25library
26− exposed-modules: Data.Generics.Product
26+ exposed-modules: Data.Generics.Wrapped
27+ , Data.Generics.Product
27 , Data.Generics.Product.Any
28 , Data.Generics.Product.Any
28 , Data.Generics.Product.Fields
29 , Data.Generics.Product.Fields
29 , Data.Generics.Product.Param
30 , Data.Generics.Product.Param
@@ -32,7 +33,8 @@ library
32 , Data.Generics.Product.Typed
33 , Data.Generics.Product.Typed
33 , Data.Generics.Product.Types
34 , Data.Generics.Product.Types
34 , Data.Generics.Product.Constraints
35 , Data.Generics.Product.Constraints
35− , Data.Generics.Product.List
36+ , Data.Generics.Product.HList
37+ , Data.Generics.Labels
36 , Data.Generics.Internal.GenericN
38 , Data.Generics.Internal.GenericN
37
39
38 , Data.Generics.Sum
40 , Data.Generics.Sum
@@ -48,10 +50,13 @@ library
48 , Data.Generics.Internal.VL.Prism
50 , Data.Generics.Internal.VL.Prism
49 , Data.Generics.Internal.VL.Iso
51 , Data.Generics.Internal.VL.Iso
50
52
53+ , Data.GenericLens.Internal
54+
51 other-modules: Data.Generics.Internal.Families
55 other-modules: Data.Generics.Internal.Families
52 , Data.Generics.Internal.Families.Changing
56 , Data.Generics.Internal.Families.Changing
53 , Data.Generics.Internal.Families.Collect
57 , Data.Generics.Internal.Families.Collect
54 , Data.Generics.Internal.Families.Has
58 , Data.Generics.Internal.Families.Has
59+ , Data.Generics.Internal.Errors
55 , Data.Generics.Internal.Void
60 , Data.Generics.Internal.Void
56
61
57 , Data.Generics.Sum.Internal.Constructors
62 , Data.Generics.Sum.Internal.Constructors
@@ -59,15 +64,16 @@ library
59 , Data.Generics.Sum.Internal.Subtype
64 , Data.Generics.Sum.Internal.Subtype
60
65
61 , Data.Generics.Product.Internal.Positions
66 , Data.Generics.Product.Internal.Positions
67+ , Data.Generics.Product.Internal.GLens
62 , Data.Generics.Product.Internal.Subtype
68 , Data.Generics.Product.Internal.Subtype
63
69
64 , Data.Generics.Product.Internal.Constraints
70 , Data.Generics.Product.Internal.Constraints
65− , Data.Generics.Product.Internal.List
71+ , Data.Generics.Product.Internal.HList
66− , Data.Generics.Product.Internal.Keyed
67
72
68− build-depends: base >= 4.9 && <= 5.0
73+ build-depends: base >= 4.9 && < 5
69− , profunctors >= 5.0 && <= 6.0
74+ , profunctors >= 5.0 && < 6.0
70− , tagged >= 0.8 && <= 0.9
75+ , tagged >= 0.8 && < 1
76+ , text >= 1.2 && < 1.3
71
77
72 hs-source-dirs: src
78 hs-source-dirs: src
73 default-language: Haskell2010
79 default-language: Haskell2010
@@ -97,7 +103,7 @@ test-suite generic-lens-test
97 type: exitcode-stdio-1.0
103 type: exitcode-stdio-1.0
98 hs-source-dirs: test
104 hs-source-dirs: test
99 main-is: Spec.hs
105 main-is: Spec.hs
100− other-modules: Util Test24 Test25 Test40
106+ other-modules: Util Test24 Test25 Test40 Test62 Test63 CustomChildren
101
107
102 build-depends: base >= 4.9 && <= 5.0
108 build-depends: base >= 4.9 && <= 5.0
103 , 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+72−22
@@ -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
@@ -16,42 +16,92 @@
16-----------------------------------------------------------------------------
16-----------------------------------------------------------------------------
17module Data.Generics.Internal.Families.Has
17module Data.Generics.Internal.Families.Has
18 ( HasTotalFieldP
18 ( HasTotalFieldP
19+ , HasTotalTypeP
20+ , HasTotalPositionP
21+ , Pos
19 , HasPartialTypeP
22 , HasPartialTypeP
20 , HasCtorP
23 , HasCtorP
21 , GTypes
24 , GTypes
22 ) where
25 ) where
23
26
24−import Data.Type.Bool (type (||), type (&&))
27+import Data.Type.Bool (type (||))
25import Data.Type.Equality (type (==))
28import Data.Type.Equality (type (==))
26import GHC.Generics
29import GHC.Generics
27−import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
30+import GHC.TypeLits (Symbol, Nat)
31+import Data.Kind (Type)
28
32
29−import Data.Generics.Product.Internal.List
33+import Data.Generics.Product.Internal.HList
30
34
35+-- Note: these could be factored out into a single traversal
36+
37+type family Both (m1 :: Maybe a) (m2 :: Maybe a) :: Maybe a where
38+ Both ('Just a) ('Just a) = 'Just a
39+
40+type family Alt (m1 :: Maybe a) (m2 :: Maybe a) :: Maybe a where
41+ Alt ('Just a) _ = 'Just a
42+ Alt _ b = b
43+
31−type family HasTotalFieldP (field :: Symbol) f :: Bool where
44+type family HasTotalFieldP (field :: Symbol) f :: Maybe Type where
32− HasTotalFieldP field (S1 ('MetaSel ('Just field) _ _ _) _)
45+ HasTotalFieldP field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 t))
33− = 'True
46+ = 'Just t
34 HasTotalFieldP field (l :*: r)
47 HasTotalFieldP field (l :*: r)
35− = HasTotalFieldP field l || HasTotalFieldP field r
48+ = Alt (HasTotalFieldP field l) (HasTotalFieldP field r)
36 HasTotalFieldP field (l :+: r)
49 HasTotalFieldP field (l :+: r)
37− = HasTotalFieldP field l && HasTotalFieldP field r
50+ = Both (HasTotalFieldP field l) (HasTotalFieldP field r)
38 HasTotalFieldP field (S1 _ _)
51 HasTotalFieldP field (S1 _ _)
39− = 'False
52+ = 'Nothing
40 HasTotalFieldP field (C1 _ f)
53 HasTotalFieldP field (C1 _ f)
41 = HasTotalFieldP field f
54 = HasTotalFieldP field f
42 HasTotalFieldP field (D1 _ f)
55 HasTotalFieldP field (D1 _ f)
43 = HasTotalFieldP field f
56 = HasTotalFieldP field f
44− HasTotalFieldP field (Rec0 _)
57+ HasTotalFieldP field (K1 _ _)
45− = 'False
58+ = 'Nothing
46 HasTotalFieldP field U1
59 HasTotalFieldP field U1
47− = 'False
60+ = 'Nothing
48 HasTotalFieldP field V1
61 HasTotalFieldP field V1
49− = 'False
62+ = 'Nothing
50− HasTotalFieldP field f
63+
51− = TypeError
64+type family HasTotalTypeP (typ :: Type) f :: Maybe Type where
52− ( 'ShowType f
65+ HasTotalTypeP typ (S1 _ (K1 _ typ))
53− ':<>: 'Text " is not a valid GHC.Generics representation type"
66+ = 'Just typ
54− )
67+ HasTotalTypeP typ (l :*: r)
68+ = Alt (HasTotalTypeP typ l) (HasTotalTypeP typ r)
69+ HasTotalTypeP typ (l :+: r)
70+ = Both (HasTotalTypeP typ l) (HasTotalTypeP typ r)
71+ HasTotalTypeP typ (S1 _ _)
72+ = 'Nothing
73+ HasTotalTypeP typ (C1 _ f)
74+ = HasTotalTypeP typ f
75+ HasTotalTypeP typ (D1 _ f)
76+ = HasTotalTypeP typ f
77+ HasTotalTypeP typ (K1 _ _)
78+ = 'Nothing
79+ HasTotalTypeP typ U1
80+ = 'Nothing
81+ HasTotalTypeP typ V1
82+ = 'Nothing
83+
84+data Pos (p :: Nat)
85+
86+type family HasTotalPositionP (pos :: Nat) f :: Maybe Type where
87+ HasTotalPositionP pos (S1 _ (K1 (Pos pos) t))
88+ = 'Just t
89+ HasTotalPositionP pos (l :*: r)
90+ = Alt (HasTotalPositionP pos l) (HasTotalPositionP pos r)
91+ HasTotalPositionP pos (l :+: r)
92+ = Both (HasTotalPositionP pos l) (HasTotalPositionP pos r)
93+ HasTotalPositionP pos (S1 _ _)
94+ = 'Nothing
95+ HasTotalPositionP pos (C1 _ f)
96+ = HasTotalPositionP pos f
97+ HasTotalPositionP pos (D1 _ f)
98+ = HasTotalPositionP pos f
99+ HasTotalPositionP pos (K1 _ _)
100+ = 'Nothing
101+ HasTotalPositionP pos U1
102+ = 'Nothing
103+ HasTotalPositionP pos V1
104+ = 'Nothing
55
105
56type family HasPartialTypeP a f :: Bool where
106type family HasPartialTypeP a f :: Bool where
57 HasPartialTypeP t (l :+: r)
107 HasPartialTypeP t (l :+: r)
@@ -73,11 +123,11 @@ type family HasCtorP (ctor :: Symbol) f :: Bool where
73 HasCtorP ctor _
123 HasCtorP ctor _
74 = 'False
124 = 'False
75
125
76−type family GTypes (rep :: * -> *) :: [((), *)] where
126+type family GTypes (rep :: Type -> Type) :: [Type] where
77 GTypes (l :*: r)
127 GTypes (l :*: r)
78 = GTypes l ++ GTypes r
128 = GTypes l ++ GTypes r
79− GTypes (Rec0 a)
129+ GTypes (K1 _ a)
80− = '[ '( '(), a)]
130+ = '[ a]
81 GTypes (M1 _ m a)
131 GTypes (M1 _ m a)
82 = GTypes a
132 = GTypes a
83 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+30−2
@@ -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
@@ -20,16 +21,43 @@
20-----------------------------------------------------------------------------
21-----------------------------------------------------------------------------
21module Data.Generics.Internal.VL.Iso where
22module Data.Generics.Internal.VL.Iso where
22
23
24+import Data.Coerce (coerce)
25+import Data.Functor.Identity (Identity(..))
23−import Data.Profunctor (Profunctor(..))
26+import Data.Profunctor (Profunctor(..))
24import GHC.Generics
27import GHC.Generics
25import Data.Generics.Internal.GenericN (Rec (..))
28import Data.Generics.Internal.GenericN (Rec (..))
26
29
30+data Exchange a b s t = Exchange (s -> a) (b -> t)
31+
32+instance Functor (Exchange a b s) where
33+ fmap f (Exchange sa bt) = Exchange sa (f . bt)
34+ {-# INLINE fmap #-}
35+
36+instance Profunctor (Exchange a b) where
37+ dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt)
38+ {-# INLINE dimap #-}
39+ lmap f (Exchange sa bt) = Exchange (sa . f) bt
40+ {-# INLINE lmap #-}
41+ rmap f (Exchange sa bt) = Exchange sa (f . bt)
42+ {-# INLINE rmap #-}
43+
27type Iso' s a
44type Iso' s a
28 = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s)
45 = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s)
29
46
30type Iso s t a b
47type Iso s t a b
31 = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
48 = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
32
49
50+fromIso :: Iso s t a b -> Iso b a t s
51+fromIso l = withIso l $ \ sa bt -> iso bt sa
52+{-# inline fromIso #-}
53+
54+-- | Extract the two functions, one from @s -> a@ and
55+-- one from @b -> t@ that characterize an 'Iso'.
56+withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
57+withIso ai k = case ai (Exchange id Identity) of
58+ Exchange sa bt -> k sa (coerce bt)
59+{-# inline withIso #-}
60+
33-- | A type and its generic representation are isomorphic
61-- | A type and its generic representation are isomorphic
34repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
62repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
35repIso = iso from to
63repIso = iso from to
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/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+82−24
@@ -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
@@ -40,12 +41,13 @@ module Data.Generics.Product.Fields
40import Data.Generics.Internal.Families
41import Data.Generics.Internal.Families
41import Data.Generics.Internal.VL.Lens as VL
42import Data.Generics.Internal.VL.Lens as VL
42import Data.Generics.Internal.Void
43import Data.Generics.Internal.Void
43−import Data.Generics.Product.Internal.Keyed
44+import Data.Generics.Product.Internal.GLens
44
45
45import Data.Kind (Constraint, Type)
46import 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
@@ -129,36 +152,68 @@ setField = VL.set (field' @f)
129instance
152instance
130 ( Generic s
153 ( Generic s
131 , ErrorUnless field s (CollectField field (Rep s))
154 , ErrorUnless field s (CollectField field (Rep s))
132− , GHasKey' field (Rep s) a
155+ , GLens' (HasTotalFieldPSym field) (Rep s) a
156+ , Defined (Rep s)
157+ (NoGeneric s '[ 'Text "arising from a generic lens focusing on the "
158+ ':<>: QuoteType field ':<>: 'Text " field of type " ':<>: QuoteType a
159+ , 'Text "in " ':<>: QuoteType s])
160+ (() :: Constraint)
133 ) => HasField' field s a where
161 ) => HasField' field s a where
134− field' f s = VL.ravel (repLens . gkey @field) f s
162+ field' f s = field0 @field f s
163+
164+class (~~) (a :: k) (b :: k) | a -> b, b -> a
165+instance (a ~ b) => (~~) a b
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− , GHasKey' field (Rep s) a
150− , GHasKey' field (Rep s') a'
151− , GHasKey' field (Rep t') b'
152− , GHasKey field (Rep s) (Rep t) a b
153− , t ~ Infer s a' b
172+ , t ~~ Infer s a' b
154− , s ~ Infer t b' a
173+ , s ~~ Infer t b' a
174+ , HasField0 field s t a b
155 ) => HasField field s t a b where
175 ) => HasField field s t a b where
156− field f s = VL.ravel (repLens . gkey @field) f s
176+ field f s = field0 @field f s
157
177
158−-- -- See Note [Uncluttering type signatures]
178+-- | See Note [Uncluttering type signatures]
179+#if __GLASGOW_HASKELL__ < 804
180+-- >>> :t field
181+-- field
182+-- :: (HasField field s t a b, Functor f) => (a -> f b) -> s -> f t
183+#else
184+-- >>> :t field
185+-- field
186+-- :: (Functor f, HasField field s t a b) => (a -> f b) -> s -> f t
187+#endif
159instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where
188instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where
160 field = undefined
189 field = undefined
161
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+
162type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Constraint where
217type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Constraint where
163 ErrorUnless field s ('TypeStat _ _ '[])
218 ErrorUnless field s ('TypeStat _ _ '[])
164 = TypeError
219 = TypeError
@@ -180,3 +235,6 @@ type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Cons
180
235
181 ErrorUnless _ _ ('TypeStat '[] '[] _)
236 ErrorUnless _ _ ('TypeStat '[] '[] _)
182 = ()
237 = ()
238+
239+data HasTotalFieldPSym :: Symbol -> (TyFun (Type -> Type) (Maybe Type))
240+type instance Eval (HasTotalFieldPSym sym) tt = HasTotalFieldP sym tt
src/Data/Generics/Product/HList.hsnew file+46
@@ -0,0 +1,46 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE MonoLocalBinds #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE TypeInType #-}
8+{-# LANGUAGE UndecidableInstances #-}
9+
10+-----------------------------------------------------------------------------
11+-- |
12+-- Module : Data.Generics.Product.HList
13+-- Copyright : (C) 2019 Csongor Kiss
14+-- License : BSD3
15+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16+-- Stability : experimental
17+-- Portability : non-portable
18+--
19+-- Derive an isomorphism between a product type and a flat HList.
20+--
21+-----------------------------------------------------------------------------
22+
23+module Data.Generics.Product.HList
24+ ( IsList (..)
25+ ) where
26+
27+import Data.Generics.Product.Internal.HList
28+import Data.Kind
29+import GHC.Generics
30+import Data.Generics.Internal.VL.Iso (Iso)
31+import Data.Generics.Internal.Profunctor.Iso (repIso, iso2isovl)
32+
33+class IsList
34+ (f :: Type)
35+ (g :: Type)
36+ (as :: [Type])
37+ (bs :: [Type]) | f -> as, g -> bs where
38+ list :: Iso f g (HList as) (HList bs)
39+
40+instance
41+ ( Generic f
42+ , Generic g
43+ , GIsList (Rep f) (Rep g) as bs
44+ ) => IsList f g as bs where
45+ list = iso2isovl (repIso . glist)
46+ {-# INLINE list #-}
src/Data/Generics/Product/Internal/Constraints.hs+2−7
@@ -15,7 +15,7 @@
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.hsnew file+81
@@ -0,0 +1,81 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE TypeInType #-}
3+{-# LANGUAGE AllowAmbiguousTypes #-}
4+{-# LANGUAGE ConstraintKinds #-}
5+{-# LANGUAGE DataKinds #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE FunctionalDependencies #-}
8+{-# LANGUAGE KindSignatures #-}
9+{-# LANGUAGE MultiParamTypeClasses #-}
10+{-# LANGUAGE Rank2Types #-}
11+{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE TypeApplications #-}
13+{-# LANGUAGE TypeFamilies #-}
14+{-# LANGUAGE TypeOperators #-}
15+{-# LANGUAGE UndecidableInstances #-}
16+
17+-----------------------------------------------------------------------------
18+-- |
19+-- Module : Data.Generics.Product.Internal.GLens
20+-- Copyright : (C) 2019 Csongor Kiss
21+-- License : BSD3
22+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
23+-- Stability : experimental
24+-- Portability : non-portable
25+--
26+-- Derive record field getters and setters generically.
27+--
28+-----------------------------------------------------------------------------
29+
30+module Data.Generics.Product.Internal.GLens
31+ ( GLens (..)
32+ , GLens'
33+ , TyFun
34+ , Eval
35+ ) where
36+
37+import Data.Generics.Internal.Profunctor.Lens (Lens, choosing, first, second)
38+import Data.Generics.Internal.Profunctor.Iso (kIso, sumIso, mIso)
39+
40+import Data.Kind (Type)
41+import GHC.Generics
42+
43+type Pred = TyFun (Type -> Type) (Maybe Type)
44+
45+type TyFun a b = a -> b -> Type
46+type family Eval (f :: TyFun a b) (x :: a) :: b
47+
48+-- A generic lens that uses some predicate to determine which field to focus on
49+class GLens (pred :: Pred) (s :: Type -> Type) (t :: Type -> Type) a b | s pred -> a, t pred -> b where
50+ glens :: Lens (s x) (t x) a b
51+
52+type GLens' pred s a = GLens pred s s a a
53+
54+instance GProductLens (Eval pred l) pred l r l' r' a b
55+ => GLens pred (l :*: r) (l' :*: r') a b where
56+
57+ glens = gproductLens @(Eval pred l) @pred
58+ {-# INLINE glens #-}
59+
60+instance (GLens pred l l' a b, GLens pred r r' a b) => GLens pred (l :+: r) (l' :+: r') a b where
61+ glens = sumIso . choosing (glens @pred) (glens @pred)
62+ {-# INLINE glens #-}
63+
64+instance GLens pred (K1 r a) (K1 r b) a b where
65+ glens = kIso
66+ {-# INLINE glens #-}
67+
68+instance (GLens pred f g a b) => GLens pred (M1 m meta f) (M1 m meta g) a b where
69+ glens = mIso . glens @pred
70+ {-# INLINE glens #-}
71+
72+class GProductLens (left :: Maybe Type) (pred :: Pred) l r l' r' a b | pred l r -> a, pred l' r' -> b where
73+ gproductLens :: Lens ((l :*: r) x) ((l' :*: r') x) a b
74+
75+instance GLens pred l l' a b => GProductLens ('Just x) pred l r l' r a b where
76+ gproductLens = first . glens @pred
77+ {-# INLINE gproductLens #-}
78+
79+instance GLens pred r r' a b => GProductLens 'Nothing pred l r l r' a b where
80+ gproductLens = second . glens @pred
81+ {-# INLINE gproductLens #-}
src/Data/Generics/Product/Internal/HList.hsnew file+329
@@ -0,0 +1,329 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE ConstraintKinds #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE FunctionalDependencies #-}
6+{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TupleSections #-}
9+{-# LANGUAGE TypeApplications #-}
10+{-# LANGUAGE TypeFamilies #-}
11+{-# LANGUAGE TypeInType #-}
12+{-# LANGUAGE TypeOperators #-}
13+{-# LANGUAGE UndecidableInstances #-}
14+
15+#if __GLASGOW_HASKELL__ == 802
16+{-# OPTIONS_GHC -fno-solve-constant-dicts #-}
17+#endif
18+
19+
20+-----------------------------------------------------------------------------
21+-- |
22+-- Module : Data.Generics.Product.Internal.HList
23+-- Copyright : (C) 2019 Csongor Kiss
24+-- License : BSD3
25+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
26+-- Stability : experimental
27+-- Portability : non-portable
28+--
29+-- Derive an isomorphism between a product type and a flat HList.
30+--
31+-----------------------------------------------------------------------------
32+
33+module Data.Generics.Product.Internal.HList
34+ ( GIsList(..)
35+ , IndexList (..)
36+ , HList (..)
37+ , type (++)
38+ , Elem
39+ , ListTuple (..)
40+ , TupleToList
41+ ) where
42+
43+#if __GLASGOW_HASKELL__ < 804
44+import Data.Semigroup
45+#endif
46+import GHC.TypeLits
47+
48+import Data.Kind (Type)
49+import GHC.Generics
50+import Data.Profunctor
51+import Data.Generics.Internal.Profunctor.Lens
52+import Data.Generics.Internal.Profunctor.Iso
53+
54+data HList (as :: [Type]) where
55+ Nil :: HList '[]
56+ (:>) :: a -> HList as -> HList (a ': as)
57+
58+infixr 5 :>
59+
60+type family ((as :: [k]) ++ (bs :: [k])) :: [k] where
61+ '[] ++ bs = bs
62+ (a ': as) ++ bs = a ': as ++ bs
63+
64+instance Semigroup (HList '[]) where
65+ _ <> _ = Nil
66+
67+instance Monoid (HList '[]) where
68+ mempty = Nil
69+ mappend _ _ = Nil
70+
71+instance (Semigroup a, Semigroup (HList as)) => Semigroup (HList (a ': as)) where
72+ (x :> xs) <> (y :> ys) = (x <> y) :> (xs <> ys)
73+
74+instance (Monoid a, Monoid (HList as)) => Monoid (HList (a ': as)) where
75+ mempty = mempty :> mempty
76+ mappend (x :> xs) (y :> ys) = mappend x y :> mappend xs ys
77+
78+class Elem (as :: [(k, Type)]) (key :: k) (i :: Nat) a | as key -> i a
79+instance {-# OVERLAPPING #-} pos ~ 0 => Elem (a ': xs) key pos a
80+instance (Elem xs key i a, pos ~ (i + 1)) => Elem (x ': xs) key pos a
81+
82+class GIsList
83+ (f :: Type -> Type)
84+ (g :: Type -> Type)
85+ (as :: [Type])
86+ (bs :: [Type]) | f -> as, g -> bs, bs f -> g, as g -> f where
87+
88+ glist :: Iso (f x) (g x) (HList as) (HList bs)
89+
90+ -- We define this reversed version, otherwise uses of `fromIso glist` are not
91+ -- properly inlined by GHC 8.0.2.
92+ -- This is not actually used.
93+ glistR :: Iso (HList bs) (HList as) (g x) (f x)
94+ glistR = fromIso glist
95+
96+instance
97+ ( GIsList l l' as as'
98+ , GIsList r r' bs bs'
99+ , Appending as bs cs as' bs' cs'
100+ , cs ~ (as ++ bs)
101+ , cs' ~ (as' ++ bs')
102+ ) => GIsList (l :*: r) (l' :*: r') cs cs' where
103+
104+ glist = prodIso . pairing glist glist . appending
105+ {-# INLINE glist #-}
106+
107+instance GIsList f g as bs => GIsList (M1 t meta f) (M1 t meta g) as bs where
108+ glist = mIso . glist
109+ {-# INLINE glist #-}
110+
111+instance GIsList (Rec0 a) (Rec0 b) '[a] '[b] where
112+ glist = kIso . singleton
113+ {-# INLINE glist #-}
114+
115+instance GIsList U1 U1 '[] '[] where
116+ glist = iso (const Nil) (const U1)
117+ {-# INLINE glist #-}
118+
119+--------------------------------------------------------------------------------
120+-- | as ++ bs === cs
121+class Appending as bs cs as' bs' cs'
122+ | as bs cs cs' -> as' bs'
123+ , as' bs' cs cs' -> as bs
124+ , as bs -> cs
125+ , as' bs' -> cs'
126+ where
127+ appending :: Iso (HList as, HList bs) (HList as', HList bs') (HList cs) (HList cs')
128+
129+-- | [] ++ bs === bs
130+instance Appending '[] bs bs '[] bs' bs' where
131+ appending = iso snd (Nil,)
132+
133+-- | (a : as) ++ bs === (a : cs)
134+instance
135+ Appending as bs cs as' bs' cs' -- as ++ bs == cs
136+ => Appending (a ': as) bs (a ': cs) (a' ': as') bs' (a' ': cs') where
137+ appending
138+ = pairing (fromIso consing) id -- ((a, as), bs)
139+ . assoc3 -- (a, (as, bs))
140+ . pairing id appending -- (a, cs)
141+ . consing -- (a : cs)
142+
143+singleton :: Iso a b (HList '[a]) (HList '[ b])
144+singleton = iso (:> Nil) (\(x :> _) -> x)
145+
146+consing :: Iso (a, HList as) (b, HList bs) (HList (a ': as)) (HList (b ': bs))
147+consing = iso (\(x, xs) -> x :> xs) (\(x :> xs) -> (x, xs))
148+
149+--------------------------------------------------------------------------------
150+class IndexList (i :: Nat) as bs a b | i as -> a, i bs -> b, i as b -> bs, i bs a -> as where
151+ point :: Lens (HList as) (HList bs) a b
152+
153+instance {-# OVERLAPPING #-}
154+ ( as ~ (a ': as')
155+ , bs ~ (b ': as')
156+ ) => IndexList 0 as bs a b where
157+ point = lens (\(x :> xs) -> (xs, x)) (\(xs, x') -> x' :> xs)
158+ {-# INLINE point #-}
159+
160+instance
161+ ( IndexList (n - 1) as' bs' a b
162+ , as ~ (x ': as')
163+ , bs ~ (x ': bs')
164+ ) => IndexList n as bs a b where
165+ point = fromIso consing . alongside id (point @(n-1)) . second'
166+ {-# INLINE point #-}
167+
168+--------------------------------------------------------------------------------
169+-- * Convert tuples to/from HLists
170+
171+class ListTuple (tuple :: Type) (as :: [Type]) | as -> tuple where
172+ type ListToTuple as :: Type
173+ tupled :: Iso' (HList as) tuple
174+ tupled = iso listToTuple tupleToList
175+
176+ tupleToList :: tuple -> HList as
177+ listToTuple :: HList as -> tuple
178+
179+instance ListTuple () '[] where
180+ type ListToTuple '[] = ()
181+ tupleToList _ = Nil
182+ listToTuple _ = ()
183+
184+instance ListTuple a '[a] where
185+ type ListToTuple '[a] = a
186+ tupleToList a
187+ = a :> Nil
188+ listToTuple (a :> Nil)
189+ = a
190+
191+instance ListTuple (a, b) '[a, b] where
192+ type ListToTuple '[a, b] = (a, b)
193+ tupleToList (a, b)
194+ = a :> b :> Nil
195+ listToTuple (a :> b :> Nil)
196+ = (a, b)
197+
198+instance ListTuple (a, b, c) '[a, b, c] where
199+ type ListToTuple '[a, b, c] = (a, b, c)
200+ tupleToList (a, b, c)
201+ = a :> b :> c :> Nil
202+ listToTuple (a :> b :> c :> Nil)
203+ = (a, b, c)
204+
205+instance ListTuple (a, b, c, d) '[a, b, c, d] where
206+ type ListToTuple '[a, b, c, d] = (a, b, c, d)
207+ tupleToList (a, b, c, d)
208+ = a :> b :> c :> d:> Nil
209+ listToTuple (a :> b :> c :> d :> Nil)
210+ = (a, b, c, d)
211+
212+instance ListTuple (a, b, c, d, e) '[a, b, c, d, e] where
213+ type ListToTuple '[a, b, c, d, e] = (a, b, c, d, e)
214+ tupleToList (a, b, c, d, e)
215+ = a :> b :> c :> d:> e :> Nil
216+ listToTuple (a :> b :> c :> d :> e :> Nil)
217+ = (a, b, c, d, e)
218+
219+instance ListTuple (a, b, c, d, e, f) '[a, b, c, d, e, f] where
220+ type ListToTuple '[a, b, c, d, e, f] = (a, b, c, d, e, f)
221+ tupleToList (a, b, c, d, e, f)
222+ = a :> b :> c :> d:> e :> f :> Nil
223+ listToTuple (a :> b :> c :> d :> e :> f :> Nil)
224+ = (a, b, c, d, e, f)
225+
226+instance ListTuple (a, b, c, d, e, f, g) '[a, b, c, d, e, f, g] where
227+ type ListToTuple '[a, b, c, d, e, f, g] = (a, b, c, d, e, f, g)
228+ tupleToList (a, b, c, d, e, f, g)
229+ = a :> b :> c :> d:> e :> f :> g :> Nil
230+ listToTuple (a :> b :> c :> d :> e :> f :> g :> Nil)
231+ = (a, b, c, d, e, f, g)
232+
233+instance ListTuple (a, b, c, d, e, f, g, h) '[a, b, c, d, e, f, g, h] where
234+ type ListToTuple '[a, b, c, d, e, f, g, h] = (a, b, c, d, e, f, g, h)
235+ tupleToList (a, b, c, d, e, f, g, h)
236+ = a :> b :> c :> d:> e :> f :> g :> h :> Nil
237+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> Nil)
238+ = (a, b, c, d, e, f, g, h)
239+
240+instance ListTuple (a, b, c, d, e, f, g, h, j) '[a, b, c, d, e, f, g, h, j] where
241+ type ListToTuple '[a, b, c, d, e, f, g, h, j] = (a, b, c, d, e, f, g, h, j)
242+ tupleToList (a, b, c, d, e, f, g, h, j)
243+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> Nil
244+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> Nil)
245+ = (a, b, c, d, e, f, g, h, j)
246+
247+instance ListTuple (a, b, c, d, e, f, g, h, j, k) '[a, b, c, d, e, f, g, h, j, k] where
248+ type ListToTuple '[a, b, c, d, e, f, g, h, j, k] = (a, b, c, d, e, f, g, h, j, k)
249+ tupleToList (a, b, c, d, e, f, g, h, j, k)
250+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> Nil
251+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> Nil)
252+ = (a, b, c, d, e, f, g, h, j, k)
253+
254+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l) '[a, b, c, d, e, f, g, h, j, k, l] where
255+ type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l] = (a, b, c, d, e, f, g, h, j, k, l)
256+ tupleToList (a, b, c, d, e, f, g, h, j, k, l)
257+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> Nil
258+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> Nil)
259+ = (a, b, c, d, e, f, g, h, j, k, l)
260+
261+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m) '[a, b, c, d, e, f, g, h, j, k, l, m] where
262+ type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m] = (a, b, c, d, e, f, g, h, j, k, l, m)
263+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m)
264+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> Nil
265+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> Nil)
266+ = (a, b, c, d, e, f, g, h, j, k, l, m)
267+
268+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n) '[a, b, c, d, e, f, g, h, j, k, l, m, n] where
269+ type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n] = (a, b, c, d, e, f, g, h, j, k, l, m, n)
270+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n)
271+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil
272+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil)
273+ = (a, b, c, d, e, f, g, h, j, k, l, m, n)
274+
275+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o] where
276+ type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
277+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
278+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil
279+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil)
280+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
281+
282+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p] where
283+ type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
284+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
285+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil
286+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil)
287+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
288+
289+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q] where
290+ type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
291+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
292+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil
293+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil)
294+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
295+
296+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r] where
297+ type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
298+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
299+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil
300+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil)
301+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
302+
303+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s] where
304+ type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
305+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
306+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil
307+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil)
308+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
309+
310+type family TupleToList a where
311+ TupleToList () = '[]
312+ TupleToList (a, b) = '[a, b]
313+ TupleToList (a, b, c) = '[a, b, c]
314+ TupleToList (a, b, c, d) = '[a, b, c, d]
315+ TupleToList (a, b, c, d, e) = '[a, b, c, d, e]
316+ TupleToList (a, b, c, d, e, f) = '[a, b, c, d, e, f]
317+ TupleToList (a, b, c, d, e, f, g) = '[a, b, c, d, e, f, g]
318+ TupleToList (a, b, c, d, e, f, g, h) = '[a, b, c, d, e, f, g, h]
319+ TupleToList (a, b, c, d, e, f, g, h, j) = '[a, b, c, d, e, f, g, h, j]
320+ TupleToList (a, b, c, d, e, f, g, h, j, k) = '[a, b, c, d, e, f, g, h, j, k]
321+ TupleToList (a, b, c, d, e, f, g, h, j, k, l) = '[a, b, c, d, e, f, g, h, j, k, l]
322+ TupleToList (a, b, c, d, e, f, g, h, j, k, l, m) = '[a, b, c, d, e, f, g, h, j, k, l, m]
323+ TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n) = '[a, b, c, d, e, f, g, h, j, k, l, m, n]
324+ TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o) = '[a, b, c, d, e, f, g, h, j, k, l, m, n, o]
325+ TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p) = '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p]
326+ TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q) = '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q]
327+ TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r) = '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r]
328+ TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) = '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s]
329+ TupleToList a = '[a]
src/Data/Generics/Product/Internal/Keyed.hsdeleted−60
@@ -1,60 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE CPP #-}
3−{-# LANGUAGE ConstraintKinds #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE FunctionalDependencies #-}
6−{-# LANGUAGE GADTs #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE TypeApplications #-}
9−{-# LANGUAGE TypeFamilies #-}
10−{-# LANGUAGE TypeInType #-}
11−{-# LANGUAGE TypeOperators #-}
12−{-# LANGUAGE UndecidableInstances #-}
13−
14−#if __GLASGOW_HASKELL__ == 802
15−{-# OPTIONS_GHC -fno-solve-constant-dicts #-}
16−#endif
17−
18−--------------------------------------------------------------------------------
19−-- |
20−-- Module : Data.Generics.Product.Internal.Keyed
21−-- Copyright : (C) 2018 Csongor Kiss
22−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
23−-- License : BSD3
24−-- Stability : experimental
25−-- Portability : non-portable
26−--
27−--------------------------------------------------------------------------------
28−
29−module Data.Generics.Product.Internal.Keyed
30− ( GHasKey (..)
31− , GHasKey'
32− ) where
33−
34−import Data.Generics.Product.Internal.List
35−import Data.Kind
36−import GHC.Generics
37−import Data.Generics.Internal.Profunctor.Lens
38−import Data.Generics.Internal.Profunctor.Iso
39−
40−class GHasKey (key :: k) (s :: Type -> Type) (t :: Type -> Type) a b | s key -> a, t key -> b where
41− gkey :: Lens (s x) (t x) a b
42−
43−type GHasKey' key s a = GHasKey key s s a a
44−
45−instance (GHasKey key l l' a b, GHasKey key r r' a b) => GHasKey key (l :+: r) (l' :+: r') a b where
46− gkey = sumIso . choosing (gkey @key) (gkey @key)
47− {-# INLINE gkey #-}
48−
49−instance (GHasKey key f g a b) => GHasKey key (M1 D meta f) (M1 D meta g) a b where
50− gkey = ravel (mLens . gkey @key)
51− {-# INLINE gkey #-}
52−
53−instance
54− ( Elem as key i a
55− , Elem bs key i b
56− , IndexList i as bs a b
57− , GIsList k f g as bs
58− ) => GHasKey (key :: k) (M1 C meta f) (M1 C meta g) a b where
59− gkey = mLens . glist @k . point @i
60− {-# INLINE gkey #-}
src/Data/Generics/Product/Internal/List.hsdeleted−335
@@ -1,335 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE CPP #-}
3−{-# LANGUAGE ConstraintKinds #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE FunctionalDependencies #-}
6−{-# LANGUAGE GADTs #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE TupleSections #-}
9−{-# LANGUAGE TypeApplications #-}
10−{-# LANGUAGE TypeFamilies #-}
11−{-# LANGUAGE TypeInType #-}
12−{-# LANGUAGE TypeOperators #-}
13−{-# LANGUAGE UndecidableInstances #-}
14−
15−#if __GLASGOW_HASKELL__ == 802
16−{-# OPTIONS_GHC -fno-solve-constant-dicts #-}
17−#endif
18−
19−
20−-----------------------------------------------------------------------------
21−-- |
22−-- Module : Data.Generics.Product.Internal.List
23−-- Copyright : (C) 2017 Csongor Kiss
24−-- License : BSD3
25−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
26−-- Stability : experimental
27−-- Portability : non-portable
28−--
29−-- Derive an isomorphism between a product type and a flat HList.
30−--
31−-----------------------------------------------------------------------------
32−
33−module Data.Generics.Product.Internal.List
34− ( GIsList (..)
35− , IndexList (..)
36− , List (..)
37− , type (++)
38− , Elem
39− , ListTuple (..)
40− , TupleToList
41− ) where
42−
43−import GHC.TypeLits
44−import Data.Semigroup
45−
46−import Data.Kind (Type)
47−import GHC.Generics
48−import Data.Profunctor
49−import Data.Generics.Internal.Profunctor.Lens
50−import Data.Generics.Internal.Profunctor.Iso
51−
52−data List (as :: [(m, Type)]) where
53− Nil :: List '[]
54− (:>) :: a -> List as -> List ('(s, a) ': as)
55−
56−infixr 5 :>
57−
58−type family ((as :: [k]) ++ (bs :: [k])) :: [k] where
59− '[] ++ bs = bs
60− (a ': as) ++ bs = a ': as ++ bs
61−
62−instance Semigroup (List '[]) where
63− _ <> _ = Nil
64−
65−instance Monoid (List '[]) where
66− mempty = Nil
67− mappend _ _ = Nil
68−
69−instance (Semigroup a, Semigroup (List as)) => Semigroup (List ('(k, a) ': as)) where
70− (x :> xs) <> (y :> ys) = (x <> y) :> (xs <> ys)
71−
72−instance (Monoid a, Monoid (List as)) => Monoid (List ('(k, a) ': as)) where
73− mempty = mempty :> mempty
74− mappend (x :> xs) (y :> ys) = mappend x y :> mappend xs ys
75−
76−class Elem (as :: [(k, Type)]) (key :: k) (i :: Nat) a | as key -> i a
77−instance {-# OVERLAPPING #-} pos ~ 0 => Elem ('(key, a) ': xs) key pos a
78−instance (Elem xs key i a, pos ~ (i + 1)) => Elem (x ': xs) key pos a
79−
80−class GIsList
81− (m :: Type)
82− (f :: Type -> Type)
83− (g :: Type -> Type)
84− (as :: [(m, Type)])
85− (bs :: [(m, Type)]) | m f -> as, m g -> bs, bs f -> g, as g -> f where
86−
87− glist :: Iso (f x) (g x) (List as) (List bs)
88−
89− -- We define this reversed version, otherwise uses of `fromIso glist` are not
90− -- properly inlined by GHC 8.0.2.
91− -- This is not actually used.
92− glistR :: Iso (List bs) (List as) (g x) (f x)
93− glistR = fromIso (glist @m)
94−
95−instance
96− ( GIsList m l l' as as'
97− , GIsList m r r' bs bs'
98− , Appending List as bs cs as' bs' cs'
99− , cs ~ (as ++ bs)
100− , cs' ~ (as' ++ bs')
101− ) => GIsList m (l :*: r) (l' :*: r') cs cs' where
102−
103− glist = prodIso . pairing (glist @m) (glist @m) . appending
104− {-# INLINE glist #-}
105−
106−instance GIsList m f g as bs => GIsList m (M1 t meta f) (M1 t meta g) as bs where
107− glist = mIso . glist @m
108− {-# INLINE glist #-}
109−
110−instance {-# OVERLAPS #-}
111− GIsList Symbol
112− (S1 ('MetaSel ('Just field) u s i) (Rec0 a))
113− (S1 ('MetaSel ('Just field) u s i) (Rec0 b))
114− '[ '(field, a)] '[ '(field, b)] where
115− glist = mIso . kIso . singleton
116− {-# INLINE glist #-}
117−
118−instance GIsList Type (Rec0 a) (Rec0 a) '[ '(a, a)] '[ '(a, a)] where
119− glist = kIso . singleton
120− {-# INLINE glist #-}
121−
122−instance GIsList () (Rec0 a) (Rec0 b) '[ '( '(), a)] '[ '( '(), b)] where
123− glist = kIso . singleton
124− {-# INLINE glist #-}
125−
126−instance GIsList m U1 U1 '[] '[] where
127− glist = iso (const Nil) (const U1)
128− {-# INLINE glist #-}
129−
130−--------------------------------------------------------------------------------
131−-- | as ++ bs === cs
132−class Appending f (as :: [k]) bs cs (as' :: [k]) bs' cs' | as bs cs cs' -> as' bs', as' bs' cs cs' -> as bs, as bs -> cs, as' bs' -> cs' where
133− appending :: Iso (f as, f bs) (f as', f bs') (f cs) (f cs')
134−
135−-- | [] ++ bs === bs
136−instance Appending List '[] bs bs '[] bs' bs' where
137− appending = iso (\(_, b) -> b) (Nil,)
138−
139−-- | (a : as) ++ bs === (a : cs)
140−instance
141− Appending List as bs cs as' bs' cs' -- as ++ bs == cs
142− => Appending List ('(f, a) ': as) bs ('(f, a) ': cs) ('(f, a') ': as') bs' ('(f, a') ': cs') where
143− appending
144− = pairing (fromIso consing) id -- ((a, as), bs)
145− . assoc3 -- (a, (as, bs))
146− . pairing id appending -- (a, cs)
147− . consing -- (a : cs)
148−
149−singleton :: Iso a b (List '[ '(field, a)]) (List '[ '(field, b)])
150−singleton = iso (:> Nil) (\(x :> _) -> x)
151−
152−consing :: Iso (a, List as) (b, List bs) (List ('(f, a) ': as)) (List ('(f, b) ': bs))
153−consing = iso (\(x, xs) -> x :> xs) (\(x :> xs) -> (x, xs))
154−
155−--------------------------------------------------------------------------------
156−class IndexList (i :: Nat) as bs a b | i as -> a, i bs -> b, i as b -> bs, i bs a -> as where
157− point :: Lens (List as) (List bs) a b
158−
159−instance {-# OVERLAPPING #-}
160− ( as ~ ('(f, a) ': as')
161− , bs ~ ('(f, b) ': as')
162− ) => IndexList 0 as bs a b where
163− point = lens (\(x :> xs) -> (xs, x)) (\(xs, x') -> x' :> xs)
164− {-# INLINE point #-}
165−
166−instance
167− ( IndexList (n - 1) as' bs' a b
168− , as ~ ('(f, x) ': as')
169− , bs ~ ('(f, x) ': bs')
170− ) => IndexList n as bs a b where
171− point = fromIso consing . alongside id (point @(n-1)) . second'
172− {-# INLINE point #-}
173−
174−--------------------------------------------------------------------------------
175−-- * Convert tuples to/from HLists
176−
177−class ListTuple (tuple :: Type) (as :: [(k, Type)]) | as -> tuple where
178− type ListToTuple as :: Type
179− tupled :: Iso' (List as) tuple
180− tupled = iso listToTuple tupleToList
181−
182− tupleToList :: tuple -> List as
183− listToTuple :: List as -> tuple
184−
185−instance ListTuple () '[] where
186− type ListToTuple '[] = ()
187− tupleToList _ = Nil
188− listToTuple _ = ()
189−
190−instance ListTuple a '[ '(fa, a)] where
191− type ListToTuple '[ '(fa, a)] = a
192− tupleToList a
193− = a :> Nil
194− listToTuple (a :> Nil)
195− = a
196−
197−instance ListTuple (a, b) '[ '(fa, a), '(fb, b)] where
198− type ListToTuple '[ '(fa, a), '(fb, b)] = (a, b)
199− tupleToList (a, b)
200− = a :> b :> Nil
201− listToTuple (a :> b :> Nil)
202− = (a, b)
203−
204−instance ListTuple (a, b, c) '[ '(fa, a), '(fb, b), '(fc, c)] where
205− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c)] = (a, b, c)
206− tupleToList (a, b, c)
207− = a :> b :> c :> Nil
208− listToTuple (a :> b :> c :> Nil)
209− = (a, b, c)
210−
211−instance ListTuple (a, b, c, d) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d)] where
212− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d)] = (a, b, c, d)
213− tupleToList (a, b, c, d)
214− = a :> b :> c :> d:> Nil
215− listToTuple (a :> b :> c :> d :> Nil)
216− = (a, b, c, d)
217−
218−instance ListTuple (a, b, c, d, e) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e)] where
219− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e)] = (a, b, c, d, e)
220− tupleToList (a, b, c, d, e)
221− = a :> b :> c :> d:> e :> Nil
222− listToTuple (a :> b :> c :> d :> e :> Nil)
223− = (a, b, c, d, e)
224−
225−instance ListTuple (a, b, c, d, e, f) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f)] where
226− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f)] = (a, b, c, d, e, f)
227− tupleToList (a, b, c, d, e, f)
228− = a :> b :> c :> d:> e :> f :> Nil
229− listToTuple (a :> b :> c :> d :> e :> f :> Nil)
230− = (a, b, c, d, e, f)
231−
232−instance ListTuple (a, b, c, d, e, f, g) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g)] where
233− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g)] = (a, b, c, d, e, f, g)
234− tupleToList (a, b, c, d, e, f, g)
235− = a :> b :> c :> d:> e :> f :> g :> Nil
236− listToTuple (a :> b :> c :> d :> e :> f :> g :> Nil)
237− = (a, b, c, d, e, f, g)
238−
239−instance ListTuple (a, b, c, d, e, f, g, h) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h)] where
240− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h)] = (a, b, c, d, e, f, g, h)
241− tupleToList (a, b, c, d, e, f, g, h)
242− = a :> b :> c :> d:> e :> f :> g :> h :> Nil
243− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> Nil)
244− = (a, b, c, d, e, f, g, h)
245−
246−instance ListTuple (a, b, c, d, e, f, g, h, j) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j)] where
247− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j)] = (a, b, c, d, e, f, g, h, j)
248− tupleToList (a, b, c, d, e, f, g, h, j)
249− = a :> b :> c :> d:> e :> f :> g :> h :> j :> Nil
250− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> Nil)
251− = (a, b, c, d, e, f, g, h, j)
252−
253−instance ListTuple (a, b, c, d, e, f, g, h, j, k) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k)] where
254− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k)] = (a, b, c, d, e, f, g, h, j, k)
255− tupleToList (a, b, c, d, e, f, g, h, j, k)
256− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> Nil
257− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> Nil)
258− = (a, b, c, d, e, f, g, h, j, k)
259−
260−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l)] where
261− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l)] = (a, b, c, d, e, f, g, h, j, k, l)
262− tupleToList (a, b, c, d, e, f, g, h, j, k, l)
263− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> Nil
264− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> Nil)
265− = (a, b, c, d, e, f, g, h, j, k, l)
266−
267−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m)] where
268− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m)] = (a, b, c, d, e, f, g, h, j, k, l, m)
269− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m)
270− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> Nil
271− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> Nil)
272− = (a, b, c, d, e, f, g, h, j, k, l, m)
273−
274−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n)] where
275− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n)] = (a, b, c, d, e, f, g, h, j, k, l, m, n)
276− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n)
277− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil
278− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil)
279− = (a, b, c, d, e, f, g, h, j, k, l, m, n)
280−
281−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o)] where
282− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
283− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
284− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil
285− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil)
286− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
287−
288−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p)] where
289− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
290− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
291− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil
292− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil)
293− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
294−
295−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q)] where
296− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
297− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
298− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil
299− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil)
300− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
301−
302−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r)] where
303− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
304− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
305− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil
306− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil)
307− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
308−
309−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r), '(fs, s)] where
310− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r), '(fs, s)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
311− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
312− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil
313− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil)
314− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
315−
316−type family TupleToList a where
317− TupleToList () = '[]
318− TupleToList (a, b) = '[ '( '(), a), '( '(), b)]
319− TupleToList (a, b, c) = '[ '( '(), a), '( '(), b), '( '(), c)]
320− TupleToList (a, b, c, d) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d)]
321− TupleToList (a, b, c, d, e) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e)]
322− TupleToList (a, b, c, d, e, f) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f)]
323− TupleToList (a, b, c, d, e, f, g) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g)]
324− TupleToList (a, b, c, d, e, f, g, h) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h)]
325− TupleToList (a, b, c, d, e, f, g, h, j) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j)]
326− TupleToList (a, b, c, d, e, f, g, h, j, k) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k)]
327− TupleToList (a, b, c, d, e, f, g, h, j, k, l) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l)]
328− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m)]
329− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n)]
330− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o)]
331− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o), '( '(), p)]
332− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o), '( '(), p), '( '(), q)]
333− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o), '( '(), p), '( '(), q), '( '(), r)]
334− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o), '( '(), p), '( '(), q), '( '(), r), '( '(), s)]
335− TupleToList a = '[ '( '(), a)]
src/Data/Generics/Product/Internal/Positions.hs+46−27
@@ -1,3 +1,4 @@
1+{-# LANGUAGE TypeInType #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE DataKinds #-}
@@ -16,7 +17,7 @@
16-----------------------------------------------------------------------------
17-----------------------------------------------------------------------------
17-- |
18-- |
18-- Module : Data.Generics.Product.Internal.Positions
19-- Module : Data.Generics.Product.Internal.Positions
19−-- Copyright : (C) 2017 Csongor Kiss
20+-- Copyright : (C) 2019 Csongor Kiss
20-- License : BSD3
21-- License : BSD3
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
22-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
22-- Stability : experimental
23-- Stability : experimental
@@ -27,41 +28,61 @@
27-----------------------------------------------------------------------------
28-----------------------------------------------------------------------------
28
29
29module Data.Generics.Product.Internal.Positions
30module Data.Generics.Product.Internal.Positions
30− ( GHasPosition (..)
31− , GHasPosition'
32− , type (<?)
31+ ( type (<?)
33 , Size
32 , Size
33+ , CRep
34 ) where
34 ) where
35
35
36−import Data.Generics.Product.Internal.List
36+import Data.Generics.Internal.Families.Has (Pos)
37import Data.Kind (Type)
37import Data.Kind (Type)
38import Data.Type.Bool (If, Not)
38import Data.Type.Bool (If, Not)
39import GHC.Generics
39import GHC.Generics
40−import GHC.TypeLits (type (<=?), type (+), type (-), Nat)
40+import GHC.TypeLits (type (<=?), type (+), Nat)
41−import Data.Generics.Internal.Profunctor.Lens
42−import Data.Generics.Internal.Profunctor.Iso
43
41
44−-- |As 'HasPosition' but over generic representations as defined by
42+-- | Alias for the kind of the generic rep
45−-- "GHC.Generics".
43+type G = Type -> Type
46−class GHasPosition (i :: Nat) (s :: Type -> Type) (t :: Type -> Type) a b | s i -> a, t i -> b, s t i -> b where
47− gposition :: Lens (s x) (t x) a b
48
44
49−type GHasPosition' i s a = GHasPosition i s s a a
45+--------------------------------------------------------------------------------
50
46
51−instance (GHasPosition i l l' a b, GHasPosition i r r' a b) => GHasPosition i (l :+: r) (l' :+: r') a b where
47+-- | In-order labeling of the generic tree with the field positions
52− gposition = \x -> sumIso (choosing (gposition @i) (gposition @i) x)
48+--
53− {-# INLINE gposition #-}
49+-- We replace the (K1 R a) nodes with (K1 (Pos n) a), where 'n' is the position
50+-- of the field in question in the data type. This is convenient, because we
51+-- can reuse all the existing functions as long as they are polymorphic in the
52+-- first parameter of 'K1'.
53+type family CRep (a :: Type) :: G where
54+ CRep rep = Fst (Traverse (Rep rep) 1)
54
55
55−instance GHasPosition i s t a b => GHasPosition i (M1 D meta s) (M1 D meta t) a b where
56+-- | The actual traversal.
56− gposition x = mLens (gposition @i x)
57+--
57− {-# INLINE gposition #-}
58+-- Might be cleaner if the sum and product parts were separated (as there's
59+-- and invariant that 'n' should be zero when we're at a sum node, which holds
60+-- for derived Generic instances (where the sums are strictly above the products))
61+type family Traverse (a :: G) (n :: Nat) :: (G, Nat) where
62+ Traverse (M1 mt m s) n
63+ = Traverse1 (M1 mt m) (Traverse s n)
64+ Traverse (l :+: r) n
65+ = '(Fst (Traverse l n) :+: Fst (Traverse r n), n)
66+ Traverse (l :*: r) n
67+ = TraverseProd (:*:) (Traverse l n) r
68+ Traverse (K1 _ p) n
69+ = '(K1 (Pos n) p, n + 1)
70+ Traverse U1 n
71+ = '(U1, n)
58
72
59−instance
73+type family Traverse1 (w :: G -> G) (z :: (G, Nat)) :: (G, Nat) where
60− ( IndexList (i - 1) as bs a b
74+ Traverse1 w '(i, n) = '(w i, n)
61− , GIsList () f g as bs
75+
62− ) => GHasPosition i (M1 C meta f) (M1 C meta g) a b where
76+-- | For products, we first traverse the left-hand side, followed by the second
63− gposition x = mIso (glist @() (point @(i - 1) x))
77+-- using the counter returned by the left traversal.
64− {-# INLINE gposition #-}
78+type family TraverseProd (c :: G -> G -> G) (a :: (G, Nat)) (r :: G) :: (G, Nat) where
79+ TraverseProd w '(i, n) r = Traverse1 (w i) (Traverse r n)
80+
81+--------------------------------------------------------------------------------
82+-- Utilities
83+
84+type family Fst (p :: (a, b)) :: a where
85+ Fst '(a, b) = a
65
86
66type family Size f :: Nat where
87type family Size f :: Nat where
67 Size (l :*: r)
88 Size (l :*: r)
@@ -75,8 +96,6 @@ type family Size f :: Nat where
75 Size f
96 Size f
76 = 1
97 = 1
77
98
78−--------------------------------------------------------------------------------
79−
80type x <? y = Not (y <=? x)
99type x <? y = Not (y <=? x)
81infixl 4 <?
100infixl 4 <?
82
101
src/Data/Generics/Product/Internal/Subtype.hs+15−10
@@ -1,3 +1,4 @@
1+{-# LANGUAGE TypeInType #-}
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.Internal.Subtype
18-- Module : Data.Generics.Product.Internal.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
@@ -31,11 +32,12 @@ module Data.Generics.Product.Internal.Subtype
31 ) where
32 ) where
32
33
33import Data.Generics.Internal.Families
34import Data.Generics.Internal.Families
34−import Data.Generics.Product.Internal.Keyed
35+import Data.Generics.Product.Internal.GLens
35
36
36import Data.Kind (Type)
37import Data.Kind (Type)
37import GHC.Generics
38import GHC.Generics
39+import GHC.TypeLits (Symbol)
38−import Data.Generics.Internal.Profunctor.Lens
40+import Data.Generics.Internal.Profunctor.Lens (view)
39
41
40--------------------------------------------------------------------------------
42--------------------------------------------------------------------------------
41-- * Generic upcasting
43-- * Generic upcasting
@@ -47,10 +49,10 @@ instance (GUpcast sub a, GUpcast sub b) => GUpcast sub (a :*: b) where
47 gupcast rep = gupcast rep :*: gupcast rep
49 gupcast rep = gupcast rep :*: gupcast rep
48
50
49instance
51instance
50− GHasKey field sub sub t t
52+ GLens' (HasTotalFieldPSym field) sub t
51 => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
53 => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
52
54
53− gupcast r = M1 (K1 (view (gkey @field) r))
55+ gupcast r = M1 (K1 (view (glens @(HasTotalFieldPSym field)) r))
54
56
55instance GUpcast sub sup => GUpcast sub (C1 c sup) where
57instance GUpcast sub sup => GUpcast sub (C1 c sup) where
56 gupcast = M1 . gupcast
58 gupcast = M1 . gupcast
@@ -80,13 +82,16 @@ instance GSmash sub sup => GSmash (C1 c sub) sup where
80instance GSmash sub sup => GSmash (D1 c sub) sup where
82instance GSmash sub sup => GSmash (D1 c sub) sup where
81 gsmash sup (M1 sub) = M1 (gsmash sup sub)
83 gsmash sup (M1 sub) = M1 (gsmash sup sub)
82
84
83−class GSmashLeaf sub sup (w :: Bool) where
85+class GSmashLeaf sub sup (w :: Maybe Type) where
84 gsmashLeaf :: sup p -> sub p -> sub p
86 gsmashLeaf :: sup p -> sub p -> sub p
85
87
86instance
88instance
87− GHasKey field sup sup t t
89+ GLens' (HasTotalFieldPSym field) sup t
88− => 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
89− gsmashLeaf sup _ = M1 (K1 (view (gkey @field) sup))
91+ gsmashLeaf sup _ = M1 (K1 (view (glens @(HasTotalFieldPSym field)) sup))
90
92
91−instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'False where
93+instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'Nothing where
92 gsmashLeaf _ = id
94 gsmashLeaf _ = id
95+
96+data HasTotalFieldPSym :: Symbol -> (TyFun (Type -> Type) (Maybe Type))
97+type instance Eval (HasTotalFieldPSym sym) tt = HasTotalFieldP sym tt
src/Data/Generics/Product/List.hsdeleted−78
@@ -1,78 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE FunctionalDependencies #-}
5−{-# LANGUAGE MonoLocalBinds #-}
6−{-# LANGUAGE ScopedTypeVariables #-}
7−{-# LANGUAGE TypeApplications #-}
8−{-# LANGUAGE TypeInType #-}
9−{-# LANGUAGE UndecidableInstances #-}
10−
11−-----------------------------------------------------------------------------
12−-- |
13−-- Module : Data.Generics.Product.List
14−-- Copyright : (C) 2017 Csongor Kiss
15−-- License : BSD3
16−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17−-- Stability : experimental
18−-- Portability : non-portable
19−--
20−-- Derive an isomorphism between a product type and a flat HList.
21−--
22−-----------------------------------------------------------------------------
23−
24−module Data.Generics.Product.List
25− ( IsList (..)
26− , IsRecord
27− , IsRecord'
28− ) where
29−
30−import Data.Generics.Product.Internal.List
31−import Data.Kind
32−import GHC.Generics
33−import GHC.TypeLits
34−import Data.Generics.Internal.Profunctor.Iso
35−
36−class IsList
37− (m :: Type)
38− (f :: Type)
39− (g :: Type)
40− (as :: [(m, Type)])
41− (bs :: [(m, Type)]) | m f -> as, m g -> bs where
42− list :: Iso f g (List as) (List bs)
43−
44−instance
45− ( Generic f
46− , Generic g
47− , GIsList m (Rep f) (Rep g) as bs
48− ) => IsList m f g as bs where
49− list = repIso . glist @m
50− {-# INLINE list #-}
51−
52−class IsList Symbol f g as bs => IsRecord f g (as :: [(Symbol, Type)]) (bs :: [(Symbol, Type)]) | f -> as, g -> bs
53−instance IsList Symbol f g as bs => IsRecord f g as bs
54−
55−class IsRecord f f as as => IsRecord' f (as :: [(Symbol, Type)]) | f -> as
56−instance IsRecord f f as as => IsRecord' f as
57−
58−-- example (TODO: move elsewhere)
59−--class PrintRecord (rl :: [(Symbol, Type)]) where
60−-- printRecord' :: List rl -> String
61−--
62−--instance PrintRecord '[] where
63−-- printRecord' _ = ""
64−--
65−--instance (KnownSymbol field, Show a, PrintRecord xs) => PrintRecord ('(field, a) ': xs) where
66−-- printRecord' (x :> xs) = show x ++ ", " ++ printRecord' xs
67−--
68−--printRecord :: (IsRecord' rec rl, PrintRecord rl) => rec -> String
69−--printRecord rec = printRecord' (rec ^. list)
70−--
71−--data MyRecord = MyRecord
72−-- { field1 :: Int
73−-- , field2 :: String
74−-- , field3 :: Bool
75−-- } deriving Generic
76−--
77−-- >>> printRecord (MyRecord 10 "hello" False)
78−-- "10, \"hello\", False, "
src/Data/Generics/Product/Param.hs+10−3
@@ -15,13 +15,13 @@
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+109−24
@@ -1,3 +1,5 @@
1+{-# LANGUAGE TypeInType #-}
2+{-# LANGUAGE PartialTypeSignatures #-}
1{-# LANGUAGE CPP #-}
3{-# LANGUAGE CPP #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
4{-# LANGUAGE AllowAmbiguousTypes #-}
3{-# LANGUAGE ConstraintKinds #-}
5{-# LANGUAGE ConstraintKinds #-}
@@ -17,7 +19,7 @@
17-----------------------------------------------------------------------------
19-----------------------------------------------------------------------------
18-- |
20-- |
19-- Module : Data.Generics.Product.Positions
21-- Module : Data.Generics.Product.Positions
20−-- Copyright : (C) 2017 Csongor Kiss
22+-- Copyright : (C) 2019 Csongor Kiss
21-- License : BSD3
23-- License : BSD3
22-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
24-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
23-- Stability : experimental
25-- Stability : experimental
@@ -33,6 +35,8 @@ module Data.Generics.Product.Positions
33 -- $setup
35 -- $setup
34 HasPosition (..)
36 HasPosition (..)
35 , HasPosition' (..)
37 , HasPosition' (..)
38+ , HasPosition_ (..)
39+ , HasPosition0 (..)
36
40
37 , getPosition
41 , getPosition
38 , setPosition
42 , setPosition
@@ -42,12 +46,15 @@ import Data.Generics.Internal.VL.Lens as VL
42import Data.Generics.Internal.Void
46import Data.Generics.Internal.Void
43import Data.Generics.Internal.Families
47import Data.Generics.Internal.Families
44import Data.Generics.Product.Internal.Positions
48import Data.Generics.Product.Internal.Positions
49+import Data.Generics.Product.Internal.GLens
50+import Data.Generics.Internal.Errors
45
51
46import Data.Kind (Constraint, Type)
52import Data.Kind (Constraint, Type)
47import Data.Type.Bool (type (&&))
53import Data.Type.Bool (type (&&))
48import GHC.Generics
54import GHC.Generics
49import GHC.TypeLits (type (<=?), Nat, TypeError, ErrorMessage(..))
55import GHC.TypeLits (type (<=?), Nat, TypeError, ErrorMessage(..))
50−import Data.Generics.Internal.Profunctor.Lens
56+import Data.Generics.Internal.Profunctor.Lens as P
57+import Data.Coerce
51
58
52-- $setup
59-- $setup
53-- == /Running example:/
60-- == /Running example:/
@@ -89,51 +96,126 @@ class HasPosition (i :: Nat) s t a b | s i -> a, t i -> b, s i b -> t, t i a ->
89 -- ...
96 -- ...
90 position :: VL.Lens s t a b
97 position :: VL.Lens s t a b
91
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_'.
92class HasPosition' (i :: Nat) s a | s i -> a where
108class HasPosition' (i :: Nat) s a | s i -> a where
93 position' :: VL.Lens s s a a
109 position' :: VL.Lens s s a a
94
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
95getPosition :: forall i s a. HasPosition' i s a => s -> a
121getPosition :: forall i s a. HasPosition' i s a => s -> a
96getPosition s = s ^. position' @i
122getPosition s = s ^. position' @i
97
123
124+-- |
125+-- >>> setPosition @2 60 human
126+-- Human {name = "Tunyasz", age = 60, address = "London"}
98setPosition :: forall i s a. HasPosition' i s a => a -> s -> s
127setPosition :: forall i s a. HasPosition' i s a => a -> s -> s
99setPosition = VL.set (position' @i)
128setPosition = VL.set (position' @i)
100
129
101instance
130instance
102 ( Generic s
131 ( Generic s
103 , ErrorUnless i s (0 <? i && i <=? Size (Rep s))
132 , ErrorUnless i s (0 <? i && i <=? Size (Rep s))
104− , GHasPosition' i (Rep s) a
133+ , cs ~ CRep s
134+ , Coercible (Rep s) cs
135+ , GLens' (HasTotalPositionPSym i) cs a
136+ , Defined (Rep s)
137+ (NoGeneric s '[ 'Text "arising from a generic lens focusing on the field at"
138+ , 'Text "position " ':<>: QuoteType i ':<>: 'Text " of type " ':<>: QuoteType a
139+ ':<>: 'Text " in " ':<>: QuoteType s
140+ ])
141+ (() :: Constraint)
105 ) => HasPosition' i s a where
142 ) => HasPosition' i s a where
106− position' f s = VL.ravel (repLens . gposition @i) f s
143+ position' f s = VL.ravel (repLens . coerced @cs @cs . glens @(HasTotalPositionPSym i)) f s
107 {-# INLINE position' #-}
144 {-# INLINE position' #-}
108
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+
109instance -- see Note [Changing type parameters]
151instance -- see Note [Changing type parameters]
110− ( Generic s
111− , ErrorUnless i s (0 <? i && i <=? Size (Rep s))
152+ ( ErrorUnless i s (0 <? i && i <=? Size (Rep s))
112− , Generic t
153+ , HasTotalPositionP i (CRep s) ~~ 'Just a
113− -- see Note [CPP in instance constraints]
154+ , HasTotalPositionP i (CRep t) ~~ 'Just b
114−#if __GLASGOW_HASKELL__ < 802
155+ , HasTotalPositionP i (CRep (Indexed s)) ~~ 'Just a'
115− , '(s', t') ~ '(Proxied s, Proxied t)
156+ , HasTotalPositionP i (CRep (Indexed t)) ~~ 'Just b'
116−#else
157+ , t ~~ Infer s a' b
117− , s' ~ Proxied s
158+ , s ~~ Infer t b' a
118− , t' ~ Proxied t
159+ , Coercible (CRep s) (Rep s)
119−#endif
160+ , Coercible (CRep t) (Rep t)
120− , Generic s'
161+ , HasPosition0 i s t a b
121− , Generic t'
122− , GHasPosition' i (Rep s) a
123− , GHasPosition' i (Rep s') a'
124− , GHasPosition i (Rep s) (Rep t) a b
125− , t ~ Infer s a' b
126− , GHasPosition' i (Rep t') b'
127− , s ~ Infer t b' a
128 ) => HasPosition i s t a b where
162 ) => HasPosition i s t a b where
129
163
130− position = VL.ravel (repLens . gposition @i)
164+ position = position0 @i
131 {-# INLINE position #-}
165 {-# INLINE position #-}
132
166
167+-- We wouldn't need the universal 'x' here if we could express above that
168+-- forall x. Coercible (cs x) (Rep s x), but this requires quantified
169+-- constraints
170+coerced :: forall s t s' t' x a b. (Coercible t t', Coercible s s')
171+ => P.ALens a b (s x) (t x) -> P.ALens a b (s' x) (t' x)
172+coerced = coerce
173+{-# INLINE coerced #-}
174+
133−-- 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
134instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where
185instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where
135 position = undefined
186 position = undefined
136
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+
137type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint where
219type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint where
138 ErrorUnless i s 'False
220 ErrorUnless i s 'False
139 = TypeError
221 = TypeError
@@ -145,3 +227,6 @@ type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint wher
145
227
146 ErrorUnless _ _ 'True
228 ErrorUnless _ _ 'True
147 = ()
229 = ()
230+
231+data HasTotalPositionPSym :: Nat -> (TyFun (Type -> Type) (Maybe Type))
232+type instance Eval (HasTotalPositionPSym t) tt = HasTotalPositionP t tt
src/Data/Generics/Product/Subtype.hs+43−3
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
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+31−5
@@ -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 #-}
@@ -7,13 +8,14 @@
7{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE TypeApplications #-}
9{-# LANGUAGE TypeApplications #-}
9{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE TypeFamilies #-}
11+{-# LANGUAGE TypeInType #-}
10{-# LANGUAGE TypeOperators #-}
12{-# LANGUAGE TypeOperators #-}
11{-# LANGUAGE UndecidableInstances #-}
13{-# LANGUAGE UndecidableInstances #-}
12
14
13-----------------------------------------------------------------------------
15-----------------------------------------------------------------------------
14-- |
16-- |
15-- Module : Data.Generics.Product.Typed
17-- Module : Data.Generics.Product.Typed
16−-- Copyright : (C) 2017 Csongor Kiss
18+-- Copyright : (C) 2019 Csongor Kiss
17-- License : BSD3
19-- License : BSD3
18-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19-- Stability : experimental
21-- Stability : experimental
@@ -33,12 +35,13 @@ module Data.Generics.Product.Typed
33import Data.Generics.Internal.Families
35import Data.Generics.Internal.Families
34import Data.Generics.Internal.VL.Lens as VL
36import Data.Generics.Internal.VL.Lens as VL
35import Data.Generics.Internal.Void
37import Data.Generics.Internal.Void
36−import Data.Generics.Product.Internal.Keyed
38+import Data.Generics.Product.Internal.GLens
37
39
38import Data.Kind (Constraint, Type)
40import Data.Kind (Constraint, Type)
39import GHC.Generics (Generic (Rep))
41import GHC.Generics (Generic (Rep))
40import GHC.TypeLits (TypeError, ErrorMessage (..))
42import GHC.TypeLits (TypeError, ErrorMessage (..))
41import Data.Generics.Internal.Profunctor.Lens
43import Data.Generics.Internal.Profunctor.Lens
44+import Data.Generics.Internal.Errors
42
45
43-- $setup
46-- $setup
44-- == /Running example:/
47-- == /Running example:/
@@ -110,12 +113,31 @@ class HasType a s where
110instance
113instance
111 ( Generic s
114 ( Generic s
112 , 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)
113− , GHasKey a (Rep s) (Rep s) a a
119+ , GLens (HasTotalTypePSym a) (Rep s) (Rep s) a a
114 ) => HasType a s where
120 ) => HasType a s where
115
121
116− typed f s = VL.ravel (repLens . gkey @a) f s
122+ typed f s = VL.ravel (repLens . glens @(HasTotalTypePSym a)) f s
117
123
124+instance {-# OVERLAPPING #-} HasType a a where
125+ getTyped = id
126+ {-# INLINE getTyped #-}
127+
128+ setTyped a _ = a
129+ {-# INLINE setTyped #-}
130+
118−-- 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.
119instance {-# OVERLAPPING #-} HasType a Void where
141instance {-# OVERLAPPING #-} HasType a Void where
120 typed = undefined
142 typed = undefined
121
143
@@ -150,3 +172,7 @@ type family ErrorUnlessOne (a :: Type) (s :: Type) (stat :: TypeStat) :: Constra
150
172
151 ErrorUnlessOne _ _ ('TypeStat '[] '[] _)
173 ErrorUnlessOne _ _ ('TypeStat '[] '[] _)
152 = ()
174 = ()
175+
176+data HasTotalTypePSym :: Type -> (TyFun (Type -> Type) (Maybe Type))
177+type instance Eval (HasTotalTypePSym t) tt = HasTotalTypeP t tt
178+
src/Data/Generics/Product/Types.hs+272−68
@@ -16,7 +16,7 @@
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 ]