on 882b766 help sign in
.github/FUNDING.ymldeleted−12
since splitsnapshots
unifiedsplit
@@ -1,12 +0,0 @@
1−# These are supported funding model platforms
2−
3−github: [kcsongor] # Replace with up to 4 GitHub Sponsors-enabled usernames e.g., [user1, user2]
4−patreon: # Replace with a single Patreon username
5−open_collective: # Replace with a single Open Collective username
6−ko_fi: # Replace with a single Ko-fi username
7−tidelift: # Replace with a single Tidelift platform-name/package-name e.g., npm/babel
8−community_bridge: # Replace with a single Community Bridge project-name e.g., cloud-foundry
9−liberapay: # Replace with a single Liberapay username
10−issuehunt: # Replace with a single IssueHunt username
11−otechie: # Replace with a single Otechie username
12−custom: # Replace with up to 4 custom sponsorship URLs e.g., ['link1', 'link2']
.gitignore−4
@@ -6,7 +6,3 @@ cabal.sandbox.config
6.ghc*
6.ghc*
7*.hi
7*.hi
8*.o
8*.o
9−core-html
10−*~
11−*.org
12−cabal.project.local
.gitmodulesnew file+4
@@ -0,0 +1,4 @@
1+[submodule "inspection-testing"]
2+ path = inspection-testing
3+ url = https://github.com/nomeata/inspection-testing.git
4+ branch = master
.travis.yml+69−132
@@ -1,155 +1,92 @@
1# This Travis job script has been generated by a script via
1# This Travis job script has been generated by a script via
2#
2#
3−# haskell-ci '--config=cabal.haskell-ci' 'cabal.project'
3+# make_travis_yml_2.hs 'generic-lens.cabal'
4#
4#
5−# For more information, see https://github.com/haskell-CI/haskell-ci
5+# For more information, see https://github.com/hvr/multi-ghc-travis
6−#
7−# version: 0.5.20190908
8#
6#
9language: c
7language: c
10−dist: xenial
8+sudo: false
9+
11git:
10git:
12− # whether to recursively clone submodules
11+ submodules: true # whether to recursively clone submodules
13− submodules: false
12+
14cache:
13cache:
15 directories:
14 directories:
16 - $HOME/.cabal/packages
15 - $HOME/.cabal/packages
17 - $HOME/.cabal/store
16 - $HOME/.cabal/store
17+
18before_cache:
18before_cache:
19− - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log
19+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
20 # remove files that are regenerated by 'cabal update'
20 # remove files that are regenerated by 'cabal update'
21− - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*
21+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*
22− - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json
22+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json
23− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache
23+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache
24− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar
24+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar
25− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx
25+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx
26− - rm -rfv $CABALHOME/packages/head.hackage
26+
27matrix:
27matrix:
28 include:
28 include:
29− - compiler: ghc-8.8.1
29+ - compiler: "ghc-8.0.2"
30+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
30− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}}
31+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.2], sources: [hvr-ghc]}}
31− - compiler: ghc-8.6.5
32− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-3.0"]}}
33− - compiler: ghc-8.4.4
32+ - compiler: "ghc-8.2.1"
33+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
34− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-3.0"]}}
34+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.1], sources: [hvr-ghc]}}
35− - compiler: ghc-8.4.1
36− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.1","cabal-install-3.0"]}}
37− - compiler: ghc-8.2.2
35+ - compiler: "ghc-8.2.2"
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]}}
39− - compiler: ghc-8.0.2
38+
40− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-3.0"]}}
41before_install:
39before_install:
42− - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')
40+ - HC=${CC}
43− - WITHCOMPILER="-w $HC"
44− - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//')
45− - HCPKG="$HC-pkg"
41+ - HCPKG=${HC/ghc/ghc-pkg}
46 - unset CC
42 - unset CC
47− - CABAL=/opt/ghc/bin/cabal
43+ - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH
48− - CABALHOME=$HOME/.cabal
44+
49− - export PATH="$CABALHOME/bin:$PATH"
50− - TOP=$(pwd)
51− - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')"
52− - echo $HCNUMVER
53− - CABAL="$CABAL -vnormal+nowrap+markoutput"
54− - set -o pipefail
55− - |
56− echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk
57− echo 'BEGIN { state = "output"; }' >> .colorful.awk
58− echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk
59− echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk
60− echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk
61− echo ' if (state == "cabal") {' >> .colorful.awk
62− echo ' print blue($0)' >> .colorful.awk
63− echo ' } else {' >> .colorful.awk
64− echo ' print $0' >> .colorful.awk
65− echo ' }' >> .colorful.awk
66− echo '}' >> .colorful.awk
67− - cat .colorful.awk
68− - |
69− color_cabal_output () {
70− awk -f $TOP/.colorful.awk
71− }
72− - echo text | color_cabal_output
73install:
45install:
74− - ${CABAL} --version
46+ - cabal --version
75 - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
47 - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
76− - TEST=--enable-tests
77− - if [ $HCNUMVER -ge 80600 ] ; then TEST=--disable-tests ; fi
78− - BENCH=--enable-benchmarks
48+ - BENCH=${BENCH---enable-benchmarks}
79− - if [ $HCNUMVER -ge 80800 ] ; then BENCH=--disable-benchmarks ; fi
49+ - TEST=${TEST---enable-tests}
80− - HEADHACKAGE=false
50+ - HADDOCK=${HADDOCK-true}
81− - rm -f $CABALHOME/config
51+ - INSTALLED=${INSTALLED-true}
82− - |
83− echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config
84− echo "remote-build-reporting: anonymous" >> $CABALHOME/config
85− echo "write-ghc-environment-files: always" >> $CABALHOME/config
86− echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config
87− echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config
88− echo "world-file: $CABALHOME/world" >> $CABALHOME/config
89− echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config
90− echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config
91− echo "installdir: $CABALHOME/bin" >> $CABALHOME/config
92− echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config
93− echo "store-dir: $CABALHOME/store" >> $CABALHOME/config
94− echo "install-dirs user" >> $CABALHOME/config
95− echo " prefix: $CABALHOME" >> $CABALHOME/config
96− echo "repository hackage.haskell.org" >> $CABALHOME/config
97− echo " url: http://hackage.haskell.org/" >> $CABALHOME/config
98− - |
99− echo "program-default-options" >> $CABALHOME/config
100− echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config
101− - cat $CABALHOME/config
102− - rm -fv cabal.project cabal.project.local cabal.project.freeze
103− - travis_retry ${CABAL} v2-update -v
52+ - travis_retry cabal update -v
104− # Generate cabal.project
53+ - sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
105− - rm -rf cabal.project cabal.project.local cabal.project.freeze
106− - touch cabal.project
107− - |
108− echo "packages: ." >> cabal.project
54+ - rm -fv cabal.project.local
109− - |
55+ - "echo 'packages: .' > cabal.project"
110− - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(generic-lens)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
111− - cat cabal.project || true
112− - cat cabal.project.local || true
113− - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi
56+ - if [ -f "./configure.ac" ]; then
114− - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output
57+ (cd "."; autoreconf -i);
58+ fi
115− - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"
59+ - rm -f cabal.project.freeze
116− - rm cabal.project.freeze
60+ - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all
117− - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all | color_cabal_output
118− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all | color_cabal_output
61+ - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all
119−script:
62+ - rm -rf "."/.ghc.environment.* "."/dist
120 - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
63 - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
121− # Packaging...
64+
122− - ${CABAL} v2-sdist all | color_cabal_output
65+# Here starts the actual work to be performed for the package under test;
123− # Unpacking...
66+# any command which exits with a non-zero exit code causes the build to fail.
67+script:
68+ # test that source-distributions can be generated
69+ - (cd "."; cabal sdist)
124− - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
70+ - mv "."/dist/generic-lens-*.tar.gz ${DISTDIR}/
125− - cd ${DISTDIR} || false
71+ - mv "."/inspection-testing ${DISTDIR}/inspection-testing
72+ - cd ${DISTDIR}
126− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \;
73+ - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;
127− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \;
74+ - "printf 'packages: generic-lens-*/*.cabal\noptional-packages: inspection-testing/*.cabal\n' > cabal.project"
128− - PKGDIR_generic_lens="$(find . -maxdepth 1 -type d -regex '.*/generic-lens-[0-9.]*')"
129− # Generate cabal.project
130− - rm -rf cabal.project cabal.project.local cabal.project.freeze
131− - touch cabal.project
132− - |
133− echo "packages: ${PKGDIR_generic_lens}" >> cabal.project
134− - |
135− - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(generic-lens)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
136− - cat cabal.project || true
137− - cat cabal.project.local || true
138− # Building...
139 # this builds all libraries and executables (without tests/benchmarks)
75 # this builds all libraries and executables (without tests/benchmarks)
140− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output
76+ - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all
141− # Building with tests and benchmarks...
77+
78+ # Build with installed constraints for packages in global-db
79+ - if $INSTALLED; then
80+ 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;
81+ else echo "Not building with installed constraints"; fi
82+
142 # build & run tests, build benchmarks
83 # build & run tests, build benchmarks
143− - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output
84+ - cabal new-build -w ${HC} ${TEST} ${BENCH} all
144− # Testing...
85+ - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} all; fi
145− - if [ $HCNUMVER -lt 80600 ] ; then ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi
86+
146− # cabal check...
147− - (cd ${PKGDIR_generic_lens} && ${CABAL} -vnormal check)
148− # haddock...
87+ # haddock
149− - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all | color_cabal_output
88+ - rm -rf ./dist-newstyle
150− # Building without installed constraints for packages in global-db...
89+ - if $HADDOCK; then cabal new-haddock -w ${HC} --disable-tests --disable-benchmarks all; else echo "Skipping haddock generation";fi
151− - rm -f cabal.project.local
152− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output
153
90
154−# REGENDATA ["--config=cabal.haskell-ci","cabal.project"]
91+# REGENDATA ["generic-lens.cabal"]
155# EOF
92# EOF
ChangeLog.md−35
@@ -1,38 +1,3 @@
1−## 1.2.0.1
2−- Give HasAny/AsAny the same VTA behavior on 8.6 and 8.8 (Ryan Scott)
3−
4−## 1.2.0.0
5−- Add `HasTypesUsing` and `HasTypesCustom` for custom traversals (Lysxia)
6−- Improve type errors when no Generic instance is defined
7−- `types` now supports Text by default
8−
9−### Breaking API changes
10−- `HasType` now includes a reflexive case so that every type 'contains' itself (Matt Parsons)
11−- `AsSubtype` and `Subtype` now include a reflexive case so that every type is a subtype of itself
12−
13−## 1.1.0.0
14−- Fix regression in type inference for polymorphic optics
15−- Add `HasField0`, `HasPosition0`, `AsConstructor0`, `HasField_`, `HasPositon_`, and `AsConstructor_` (Lysxia)
16−- `types` now supports Data.Word and Data.Int (Lysxia)
17−- Add `Wrapped` iso for newtypes (Isaac Elliott)
18−- Expose internals through Data.GenericLens.Internal
19−- Add labels for prisms (Daniel Winograd-Cort)
20−
21−## 1.0.0.2
22−- Fix compile-time performance regression
23−
24−## 1.0.0.1
25−- Remove dump-core dependency
26−- Relax upper bound on criterion (#42)
27−
28−## 1.0.0.0
29−- Traversals (types, param, constraints)
30−- Prisms are now optimal too
31−- Monomorphic versions of lenses and prisms also included
32−
33−### Breaking API changes
34−- `projectSub` now returns `Maybe sub` instead of `Either sup sub` (#21)
35−
36## 0.5.1.0
1## 0.5.1.0
37- Infer input type from result type (#25)
2- Infer input type from result type (#25)
38- Allow changing of multiple type parameters (#24)
3- Allow changing of multiple type parameters (#24)
LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2019, Csongor Kiss
1+Copyright (c) 2017, Csongor Kiss
2
2
3All rights reserved.
3All rights reserved.
4
4
README.md+78−238
@@ -3,69 +3,26 @@
3[![Build Status](https://travis-ci.org/kcsongor/generic-lens.svg?branch=master)](https://travis-ci.org/kcsongor/generic-lens)
3[![Build Status](https://travis-ci.org/kcsongor/generic-lens.svg?branch=master)](https://travis-ci.org/kcsongor/generic-lens)
4[![Hackage](https://img.shields.io/hackage/v/generic-lens.svg)](https://hackage.haskell.org/package/generic-lens)
4[![Hackage](https://img.shields.io/hackage/v/generic-lens.svg)](https://hackage.haskell.org/package/generic-lens)
5
5
6−Generically derive traversals, lenses and prisms.
6+Generically derive lenses and prisms for data types.
7
7
8Available on [Hackage](https://hackage.haskell.org/package/generic-lens)
8Available on [Hackage](https://hackage.haskell.org/package/generic-lens)
9
9
10−This library uses `GHC.Generics` to derive efficient optics (traversals, lenses
10+This package uses the GHC 8 `Generic` representation to derive various operations
11−and prisms) for algebraic data types in a type-directed way, with a focus on
11+on data structures with lens interfaces, including structural subtype
12−good type inference and error messages when possible.
12+relationships between records and positional indexing into arbitrary product
13−
13+types.
14−The derived optics use the so-called van Laarhoven representation, thus are
15−fully interoperable with the combinators found in mainstream lens libraries.
16−
17−Examples can be found in the `examples` and `tests` folders.
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−
22−Table of contents
23−=================
24−
25−* [Preliminaries](#preliminaries)
26−* [Taxonomy of optics](#taxonomy-of-optics)
27− * [Lenses](#lenses)
28− * [By name](#by-name)
29− * [By position](#by-position)
30− * [By type](#by-type)
31− * [By structure](#by-structure)
32− * [Traversals](#traversals)
33− * [By type](#by-type-1)
34− * [By parameter](#by-parameter)
35− * [By constraint](#by-constraint)
36− * [Prisms](#prisms)
37− * [By name](#by-name-1)
38− * [By type](#by-type-2)
39−* [Performance](#performance)
40− * [Inspection testing](#inspection-testing)
41− * [Benchmarks](#benchmarks)
42−* [Contributors](#contributors)
43−
44−# Preliminaries
45−A typical module using `generic-lens` will usually have the following
46−extensions turned on:
47−```haskell
48−{-# LANGUAGE AllowAmbiguousTypes #-}
49−{-# LANGUAGE DataKinds #-}
50−{-# LANGUAGE DeriveGeneric #-}
51−{-# LANGUAGE DuplicateRecordFields #-}
52−{-# LANGUAGE FlexibleContexts #-}
53−{-# LANGUAGE NoMonomorphismRestriction #-}
54−{-# LANGUAGE TypeApplications #-}
55
14
56−```
15+This is made possible by GHC 8's new Generics API, which provides metadata
16+at the type-level (previously only value-level metadata was available).
57
17
58−# Taxonomy of optics
18+Examples can be found in the `examples` folder. This library makes heavy use of
59−Here is a comprehensive list of the optics exposed by `generic-lens`. The
19+[Visible Type Applications](https://ghc.haskell.org/trac/ghc/wiki/TypeApplication).
60−combinators each allow a different way of identifying certain parts of
61−algebraic data types.
62
20
63## Lenses
21## Lenses
64
22
65−A lens identifies exactly one part of a product type, and allows querying and
23+### Record fields
66−updating it.
67
24
68−### By name
25+Record fields can be accessed by their label:
69
26
70```haskell
27```haskell
71data Person = Person { name :: String, age :: Int } deriving (Generic, Show)
28data Person = Person { name :: String, age :: Int } deriving (Generic, Show)
@@ -74,83 +31,42 @@ sally :: Person
74sally = Person "Sally" 25
31sally = Person "Sally" 25
75```
32```
76
33
77−Record fields can be accessed by their label using the `field` lens.
78−
79−```haskell
80−>>> sally ^. field @"name"
81−"Sally"
82−
83−>>> sally & field @"name" .~ "Tamas"
84−Person {name = "Tamas", age = 25}
85−```
86−Here we use [visible type application](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#visible-type-application)
87−to specify which field we're interested in, and use the `^.` and `.~` combinators from a lens library
88−([lens](https://hackage.haskell.org/package/lens), [microlens](https://hackage.haskell.org/package/microlens), etc.)
89−to query and update the field.
90−
91−Or for standalone use, the `getField` and `setField` functions can be used instead.
92```haskell
34```haskell
93>>> getField @"age" sally
35>>> getField @"age" sally
9425
3625
95
37
96>>> setField @"age" 26 sally
38>>> setField @"age" 26 sally
97Person {name = "Sally", age = 26}
39Person {name = "Sally", age = 26}
98−```
99
40
100−When a non-existent field is requested, the library generates a helpful type error:
41+>>> sally ^. field @"name"
101−```haskell
42+"Sally"
43+
44+>>> sally & field @"name" .~ "Tamas"
45+Person {name = "Tamas", age = 25}
46+
102>>> sally ^. field @"pet"
47>>> sally ^. field @"pet"
103error:
48error:
104− • The type Person does not contain a field named 'pet'
49+ • The type Person does not contain a field named "pet"
105```
50```
106
51
107−For types with multiple constructors, we can still use `field` as long as all constructors contain the required field
52+If the accessed field is a type parameter that appears uniquely in the type,
108−```haskell
53+then its type can be changed:
109−data Two
110− = First { wurble :: String, banana :: Int }
111− | Second { wurble :: String }
112− deriving (Generic, Show)
113−
114−>>> Second "woops" ^. field @"wurble"
115−"woops"
116−>>> Second "woops" ^. field @"banana"
117− ...
118− • Not all constructors of the type Two
119− contain a field named 'banana'.
120− The offending constructors are:
121− • Second
122− ...
123−```
124−
125−The type of `field` is
126−```haskell
127−field :: HasField name s t a b => Lens s t a b
128−```
129−Therefore it allows polymorphic (type-changing) updates, when the accessed field mentions type parameters.
130
54
131```haskell
55```haskell
132−data Foo f a = Foo
56+data T a b c d = T
133− { foo :: f a
57+ { paramA :: a
58+ , paramB :: b
59+ , paramC :: c
60+ , paramD :: d
61+ }
134− } deriving (Generic, Show)
62+ deriving (Generic, Show)
135−
136−foo1 :: Foo Maybe Int
137−foo1 = Foo (Just 10)
138
63
139−-- |
64+>>> t = T "a" (10 :: Int) 'c' False
140−-- >>> foo2
65+>>> t & field @"paramA" .~ 'a' & field @"paramB" .~ False
141−-- Foo {foo = ["10"]}
66+T {paramA = 'a', paramB = False, paramC = 'c', paramD = False}
142−foo2 :: Foo [] String
143−foo2 = foo1 & field @"foo" %~ (maybeToList . fmap show)
144```
67```
145−This example shows that higher-kinded parameters can also be changed (`Maybe`
146−-> `[]`). We turn a `Foo Maybe Int` into a `Foo [] String` by turning the inner
147−`Maybe Int` into a `[String]`.
148−
149−With `DuplicateRecordFields`, multiple data types can share the same field
150−name, and the `field` lens works in this case too. No more field name
151−prefixing!
152
68
153−### By position
69+### Positional fields
154
70
155Fields can be accessed by their position in the data structure (index starting at 1):
71Fields can be accessed by their position in the data structure (index starting at 1):
156
72
@@ -163,6 +79,12 @@ polygon = Polygon (Point 1 5 3) (Point 2 4 2) (Point 5 7 (-2))
163```
79```
164
80
165```haskell
81```haskell
82+>>> getPosition @2 polygon
83+Point 2 4 2
84+
85+>>> setPosition @1 (Point 26 5 3) polygon
86+Polygon (Point 26 5 3) (Point 2 4 2) (Point 5 7 (-2))
87+
166>>> polygon ^. position @1 . position @2
88>>> polygon ^. position @1 . position @2
1675
895
168
90
@@ -174,34 +96,49 @@ error:
174 • The type Polygon does not contain a field at position 10
96 • The type Polygon does not contain a field at position 10
175```
97```
176
98
177−Since tuples are an instance of `Generic`, the positional lens readily works:
99+Since tuples are an instance of `Generic`, they also have positional lenses:
178
100
179```haskell
101```haskell
180>>> (("hello", True), 5) ^. position @1 . position @2
102>>> (("hello", True), 5) ^. position @1 . position @2
181True
103True
182−>>> (("hello", True, "or"), 5, "even", "longer") ^. position @1 . position @2
183−True
184```
104```
185
105
186−### By type
106+### Typed fields
187
107
188Fields can be accessed by their type in the data structure, assuming that this
108Fields can be accessed by their type in the data structure, assuming that this
189type is unique:
109type is unique:
190
110
191```haskell
111```haskell
192−>>> sally ^. typed @String
112+data Person = Person { name :: String, age :: Int } deriving (Generic, Show)
113+data Point = Point Int Int Int deriving (Generic, Show)
114+
115+sally :: Person
116+sally = Person "Sally" 25
117+
118+point :: Point
119+point = Point 1 2 3
120+```
121+
122+```haskell
123+>>> getTyped @String sally
193"Sally"
124"Sally"
194
125
195>>> setTyped @Int sally 26
126>>> setTyped @Int sally 26
196Person {name = "Sally", age = 26}
127Person {name = "Sally", age = 26}
128+
129+>>> point ^. typed @Int
130+error:
131+ • The type Point contains multiple values of type Int; the choice of value is thus ambiguous
132+
133+>>> point & typed @String .~ "Point"
134+error:
135+ • The type Point does not contain a value of type [Char]
197```
136```
198
137
199−### By structure
138+### Structural subtyping
200
139
201−The `super` lens generalises the `field` lens to focus on a collection rather
202−than a single field.
203−We can say that a record is a (structural) `subtype' of another, if its fields
140+A record is a (structural) `subtype' of another, if its fields are a superset of
204−are a superset of those of the other.
141+those of the other.
205
142
206```haskell
143```haskell
207data Human = Human
144data Human = Human
@@ -220,11 +157,17 @@ human = Human {name = "Tunyasz", age = 50, address = "London"}
220```
157```
221
158
222```haskell
159```haskell
223−>>> human ^. super @Animal
224−Animal {name = "Tunyasz", age = 50}
225
160
226>>> upcast human :: Animal
161>>> upcast human :: Animal
227Animal {name = "Tunyasz", age = 50}
162Animal {name = "Tunyasz", age = 50}
163+
164+-- 'smash' plug the smaller structure into the larger one
165+>>> smash (Animal "dog" 10) human
166+Human {name = "dog", age = 10, address = "London"}
167+
168+-- 'super' is a lens that focuses on a subrecord of a larger record:
169+>>> human ^. super @Animal
170+Animal {name = "Tunyasz", age = 50}
228```
171```
229
172
230We can apply a function that operates on a supertype to the larger (subtype)
173We can apply a function that operates on a supertype to the larger (subtype)
@@ -238,96 +181,9 @@ growUp (Animal name age) = Animal name (age + 50)
238Human {name = "Tunyasz", age = 60, address = "London"}
181Human {name = "Tunyasz", age = 60, address = "London"}
239```
182```
240
183
241−## Traversals
242−
243−Traversals allow multiple values to be queried or updated at the same time.
244−
245−As a running example, consider a data type of weighted trees. There are two
246−type parameters, which correspond to the type of elements and weights in the
247−tree:
248−```haskell
249−data WTree a w
250− = Leaf a
251− | Fork (WTree a w) (WTree a w)
252− | WithWeight (WTree a w) w
253− deriving (Generic, Show)
254−
255−mytree :: WTree Int Int
256−mytree = Fork (WithWeight (Leaf 42) 1)
257− (WithWeight (Fork (Leaf 88) (Leaf 37)) 2)
258−```
259−
260−### By type
261−Focus on all values of a given type.
262−
263−```haskell
264−types :: HasTypes s a => Traversal' s a
265−```
266−
267−```haskell
268−>>> toListOf (types @Int) myTree
269−[42,1,88,37,2]
270−```
271−
272−Note that this traversal is "deep": the subtrees are recursively traversed.
273−
274−### By parameter
275−As the above example shows, the `types` traversal is limited in that it cannot
276−distinguish between the two types of `Int`s: the weights and the values.
277−
278−Instead, the `param` traversal allows specifying types that correspond to a
279−certain type parameter.
280−```haskell
281−param :: HasParam pos s t a b => Traversal s t a b
282−```
283−
284−```haskell
285−>>> toListOf (param @1) myTree
286−[42,88,37]
287−```
288−
289−Here, the numbering starts from 0, with 0 being the rightmost parameter.
290−Because `param` is guaranteed to focus on parametric values, it allows the type
291−to be changed as well.
292−
293−For example, we can implement `Functor` for `WTree` as simply as:
294−
295−```haskell
296−instance Functor (WTree a) where
297− fmap = over (param @0)
298−```
299−
300−### By constraint
301−The most general type of traversal: we can apply a given function to every
302−value in a structure, by requiring that all values have an instance for some
303−type class.
304−
305−```haskell
306−constraints :: HasConstraints c s t => Applicative g => (forall a b . c a b => a -> g b) -> s -> g t
307−constraints' :: HasConstraints' c s => Applicative g => (forall a . c a => a -> g a) -> s -> g s
308−```
309−
310−Consider the `Numbers` type, which contains three different numeric types:
311−```haskell
312−data Numbers = Numbers Int Float Double
313− deriving (Show, Generic)
314−
315−numbers = Numbers 10 20.0 30.0
316−```
317−
318−With `constraints'`, we can uniformly add 20 to each number in one go:
319−```haskell
320−>>> constraints' @Num (\x -> pure (x + 20)) numbers
321−Numbers 30 40.0 50.0
322−```
323−
324## Prisms
184## Prisms
325
185
326−A prism focuses on one part of a sum type (which might not be present). Other
186+### Named constructors
327−than querying the type, they can be "turned around" to inject the data into the
328−sum (like a constructor).
329−
330−### By name
331
187
332Constructor components can be accessed using the constructor's name:
188Constructor components can be accessed using the constructor's name:
333
189
@@ -349,20 +205,19 @@ Just (MkDog {name = "Shep", age = 4})
349
205
350>>> shep ^? _Ctor @"Cat"
206>>> shep ^? _Ctor @"Cat"
351Nothing
207Nothing
352−```
353−
354−Constructors with multiple fields can be focused as a tuple
355
208
356−```
357>>> mog ^? _Ctor @"Cat"
209>>> mog ^? _Ctor @"Cat"
358Just ("Mog",5)
210Just ("Mog",5)
359
211
360>>> _Ctor @"Cat" # ("Garfield", 6) :: Animal
212>>> _Ctor @"Cat" # ("Garfield", 6) :: Animal
361Cat "Garfield" 6
213Cat "Garfield" 6
362
214
215+>>> donald ^? _Ctor @"Giraffe"
216+error:
217+ • The type Animal does not contain a constructor named "Giraffe"
363```
218```
364
219
365−### By type
220+### Typed constructors
366
221
367Constructor components can be accessed using the component's type, assuming
222Constructor components can be accessed using the component's type, assuming
368that this type is unique:
223that this type is unique:
@@ -372,10 +227,10 @@ type Name = String
372type Age = Int
227type Age = Int
373
228
374data Dog = MkDog { name :: Name, age :: Age } deriving (Generic, Show)
229data Dog = MkDog { name :: Name, age :: Age } deriving (Generic, Show)
375−data Animal = Dog Dog | Cat Name Age | Duck Age deriving (Generic, Show)
230+data Animal = Dog Dog | Cat (Name, Age) | Duck Age deriving (Generic, Show)
376
231
377shep = Dog (MkDog "Shep" 4)
232shep = Dog (MkDog "Shep" 4)
378−mog = Cat "Mog" 5
233+mog = Cat ("Mog", 5)
379donald = Duck 4
234donald = Duck 4
380```
235```
381
236
@@ -389,9 +244,6 @@ Just (MkDog {name = "Shep", age = 4})
389>>> donald ^? _Typed @Age
244>>> donald ^? _Typed @Age
390Just 4
245Just 4
391
246
392−>>> mog ^? _Typed @(Name, Age)
393−("Mog", 5)
394−
395>>> donald ^? _Typed @Float
247>>> donald ^? _Typed @Float
396error:
248error:
397 • The type Animal does not contain a constructor whose field is of type Float
249 • The type Animal does not contain a constructor whose field is of type Float
@@ -400,19 +252,7 @@ error:
400Duck 6
252Duck 6
401```
253```
402
254
403−# Performance
404−The runtime characteristics of the derived optics is in most cases identical at
405−`-O1`, in some cases only slightly slower than the hand-written version. This
406−is thanks to GHC's optimiser eliminating the generic overhead.
407−
408−The
409−[inspection-testing](https://hackage.haskell.org/package/inspection-testing)
410−library is used to ensure (see [here](test/Spec.hs)) that everything gets
411−inlined away.
412−
413−There is also a [benchmark suite](https://github.com/mpickering/generic-lens-benchmarks) with larger, real-world examples.
414−# Contributors
255+## Contributors
415
256
416−+ [Matthew Pickering](https://github.com/mpickering)
417+ [Toby Shaw](https://github.com/TobyShaw)
257+ [Toby Shaw](https://github.com/TobyShaw)
418+ [Will Jones](https://github.com/lunaris)
258+ [Will Jones](https://github.com/lunaris)
cabal.haskell-cideleted−5
@@ -1,5 +0,0 @@
1−-- inspection tests fail
2−tests: <8.6
3−
4−-- blocked on vector-th-unbox
5−benchmarks: <8.8
cabal.project−1
@@ -1,2 +1 @@
1packages: generic-lens.cabal
1packages: generic-lens.cabal
2−write-ghc-environment-files: always
examples/Biscuits.hsdeleted−150
@@ -1,150 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE DuplicateRecordFields #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE NoMonomorphismRestriction #-}
6−{-# LANGUAGE TypeApplications #-}
7−
8−module Main where
9−
10−import Control.Lens
11−import Data.Maybe (maybeToList)
12−import Data.Generics.Product
13−import Data.Generics.Sum
14−import GHC.Generics (Generic)
15−
16−-- $setup
17−--
18−-- >>> :set -XTypeApplications
19−-- >>> :set -XDataKinds
20−-- >>> :set -XFlexibleContexts
21−
22−main :: IO ()
23−main = putStrLn "hello"
24−
25−data Item = Item
26− { name :: String
27− , cost :: Cost
28− } deriving (Generic, Show)
29−
30−newtype Cost = Cost Double deriving (Generic, Show)
31−
32−data Invoice p = Invoice
33− { item :: Item
34− , name :: String
35− , number :: Int
36− , priority :: p
37− } deriving (Generic, Show)
38−
39−data Orders = Orders [ Invoice Int ] [ Invoice (Int, Double) ]
40− deriving (Generic, Show)
41−
42−-- |
43−-- >>> view (field @"name") bourbon
44−-- "Bourbon"
45−-- >>> bourbon & field @"cost" .~ Cost 110
46−-- Item {name = "Bourbon", cost = Cost 110.0}
47−--
48−-- >>> bourbon & field @"cost" %~ (\(Cost c) -> (Cost (c + 5)))
49−-- Item {name = "Bourbon", cost = Cost 105.0}
50−--
51−-- >>> Invoice bourbon "Johnny" 2 2 & field @"priority" %~ (\i -> (i, 0))
52−-- Invoice {item = Item {name = "Bourbon", cost = Cost 100.0}, name = "Johnny", number = 2, priority = (2,0)}
53−--
54−-- >>> view (field @"weight") bourbon
55−-- ...
56−-- ... The type Item does not contain a field named 'weight'.
57−-- ...
58−--
59−-- >>> bourbon & typed @Cost .~ Cost 200
60−-- Item {name = "Bourbon", cost = Cost 200.0}
61−--
62−-- >>> bourbon & typed %~ ("Chocolate " ++)
63−-- Item {name = "Chocolate Bourbon", cost = Cost 100.0}
64−--
65−-- >>> view (position @1) (42, "foo")
66−-- 42
67−-- >>> view (position @1) (42, "foo", False)
68−-- 42
69−-- >>> view (position @2) orders
70−-- [Invoice {item = Item {name = "Bourbon", cost = Cost 100.0}, name = "George", number = 2, priority = (0,3.0)}]
71−--
72−-- >>> view (position @2) orders
73−-- [Invoice {item = Item {name = "Bourbon", cost = Cost 100.0}, name = "George", number = 2, priority = (0,3.0)}]
74−--
75−-- >>> view (position @3) orders
76−-- ...
77−-- ... The type Orders does not contain a field at position 3
78−-- ...
79−--
80−-- >>> view (super @Item) (WItem "Bourbon" (Cost 2000) (Weight 0.03))
81−-- Item {name = "Bourbon", cost = Cost 2000.0}
82−--
83−-- >>> (WItem "Bourbon+" (Cost 500) (Weight 0.03)) & super @Item .~ bourbon
84−-- WItem {name = "Bourbon", cost = Cost 100.0, weight = Weight 3.0e-2}
85−--
86−-- >>> DInt 1 ^? _Ctor @"DInt"
87−-- Just 1
88−--
89−-- >>> _Typed # (False, "wurble") :: D
90−-- DPair False "wurble"
91−--
92−-- >>> EChar 'a' ^? _Sub @D
93−-- Nothing
94−--
95−-- >>> _Sub # DInt 10 :: E
96−-- EInt 10
97−bourbon :: Item
98−bourbon = Item "Bourbon" (Cost 100)
99−
100−orders :: Orders
101−orders = Orders [Invoice bourbon "Earl" 1 0 , Invoice bourbon "Johnny" 2 2]
102− [Invoice bourbon "George" 2 (0, 3)]
103−
104−nameOfItem :: Invoice p -> String
105−nameOfItem = view (field @"item" . field @"name")
106−
107−thankYou :: Orders -> Orders
108−thankYou = over (types @Cost) (\(Cost c) -> Cost (c * 0.85))
109−
110−thankYouPriority :: Orders -> Orders
111−thankYouPriority = over (position @2 . types @Cost) (\(Cost c) -> Cost (c * 0.85))
112−
113−upgrade :: Double -> Invoice Int -> Invoice (Int, Double)
114−upgrade bribe invoice = over (param @0) (\i -> (i, bribe)) invoice
115−
116−audit :: Orders -> [Item]
117−audit = toListOf (types @Item)
118−
119−newtype Weight = Weight Double deriving (Generic, Show)
120−data WeighedItem = WItem
121− { name :: String
122− , cost :: Cost
123− , weight :: Weight
124− } deriving (Generic, Show)
125−
126−data D = DInt Int | DPair Bool String
127− deriving (Generic, Show)
128−
129−data E = EInt Int | EPair Bool String | EChar Char
130− deriving (Generic, Show)
131−
132−costInc :: HasTypes t Cost => t -> t
133−costInc = over (types @Cost) (\(Cost c) -> Cost (c + 5))
134−
135−modifyPriority :: (Int -> Int) -> Invoice Int -> Invoice Int
136−modifyPriority = over (types @Int)
137−
138−treeIncParam :: HasParam 0 s s Int Int => s -> s
139−treeIncParam = over (param @0) (+ 1)
140−
141−instance Functor Invoice where
142− fmap = over (param @0)
143−
144−data Numbers = Numbers Int Float Double
145− deriving (Show, Generic)
146−
147−-- |
148−-- >>> constraints' @Num (\x -> pure (x + 20)) numbers
149−-- Numbers 30 40.0 50.0
150−numbers = Numbers 10 20.0 30.0
examples/doctest.hsdeleted−7
@@ -1,7 +0,0 @@
1−import Test.DocTest
2−main
3− = doctest
4− [ "-iexamples"
5− , "-isrc"
6− , "examples/Biscuits.hs"
7− ]
generic-lens.cabal+23−63
@@ -1,7 +1,7 @@
1name: generic-lens
1name: generic-lens
2−version: 1.2.0.1
2+version: 0.5.1.0
3−synopsis: Generically derive traversals, lenses and prisms.
3+synopsis: Generic data-structure operations exposed as lenses.
4−description: 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.
4+description: This package uses the GHC 8 Generic representation to derive various operations on data structures with a lens interface, including structural subtype relationship between records and positional indexing into arbitrary product types.
5
5
6homepage: https://github.com/kcsongor/generic-lens
6homepage: https://github.com/kcsongor/generic-lens
7license: BSD3
7license: BSD3
@@ -11,7 +11,7 @@ maintainer: kiss.csongor.kiss@gmail.com
11category: Generics, Records, Lens
11category: Generics, Records, Lens
12build-type: Simple
12build-type: Simple
13cabal-version: >= 1.10
13cabal-version: >= 1.10
14−Tested-With: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.1
14+Tested-With: GHC == 8.0.2, GHC == 8.2.1
15
15
16extra-source-files: ChangeLog.md
16extra-source-files: ChangeLog.md
17 , examples/StarWars.hs
17 , examples/StarWars.hs
@@ -23,19 +23,14 @@ flag dump-core
23 default: False
23 default: False
24
24
25library
25library
26− exposed-modules: Data.Generics.Wrapped
26+ exposed-modules: Data.Generics.Product
27− , Data.Generics.Product
28 , Data.Generics.Product.Any
27 , Data.Generics.Product.Any
29 , Data.Generics.Product.Fields
28 , Data.Generics.Product.Fields
30− , Data.Generics.Product.Param
31 , Data.Generics.Product.Positions
29 , Data.Generics.Product.Positions
32 , Data.Generics.Product.Subtype
30 , Data.Generics.Product.Subtype
33 , Data.Generics.Product.Typed
31 , Data.Generics.Product.Typed
34 , Data.Generics.Product.Types
32 , Data.Generics.Product.Types
35− , Data.Generics.Product.Constraints
33+ , Data.Generics.Product.List
36− , Data.Generics.Product.HList
37− , Data.Generics.Labels
38− , Data.Generics.Internal.GenericN
39
34
40 , Data.Generics.Sum
35 , Data.Generics.Sum
41 , Data.Generics.Sum.Any
36 , Data.Generics.Sum.Any
@@ -50,13 +45,10 @@ library
50 , Data.Generics.Internal.VL.Prism
45 , Data.Generics.Internal.VL.Prism
51 , Data.Generics.Internal.VL.Iso
46 , Data.Generics.Internal.VL.Iso
52
47
53− , Data.GenericLens.Internal
54−
55 other-modules: Data.Generics.Internal.Families
48 other-modules: Data.Generics.Internal.Families
56 , Data.Generics.Internal.Families.Changing
49 , Data.Generics.Internal.Families.Changing
57 , Data.Generics.Internal.Families.Collect
50 , Data.Generics.Internal.Families.Collect
58 , Data.Generics.Internal.Families.Has
51 , Data.Generics.Internal.Families.Has
59− , Data.Generics.Internal.Errors
60 , Data.Generics.Internal.Void
52 , Data.Generics.Internal.Void
61
53
62 , Data.Generics.Sum.Internal.Constructors
54 , Data.Generics.Sum.Internal.Constructors
@@ -64,92 +56,68 @@ library
64 , Data.Generics.Sum.Internal.Subtype
56 , Data.Generics.Sum.Internal.Subtype
65
57
66 , Data.Generics.Product.Internal.Positions
58 , Data.Generics.Product.Internal.Positions
67− , Data.Generics.Product.Internal.GLens
68 , Data.Generics.Product.Internal.Subtype
59 , Data.Generics.Product.Internal.Subtype
69
60
70− , Data.Generics.Product.Internal.Constraints
61+ , Data.Generics.Product.Internal.Types
71− , Data.Generics.Product.Internal.HList
62+ , Data.Generics.Product.Internal.List
63+ , Data.Generics.Product.Internal.Keyed
72
64
73− build-depends: base >= 4.9 && < 5
65+ build-depends: base >= 4.9 && <= 5.0
74− , profunctors >= 5.0 && < 6.0
66+ , profunctors >= 5.0 && <= 6.0
75− , tagged >= 0.8 && < 1
67+ , tagged >= 0.8 && <= 0.9
76− , text >= 1.2 && < 1.3
77
68
78 hs-source-dirs: src
69 hs-source-dirs: src
79 default-language: Haskell2010
70 default-language: Haskell2010
80 ghc-options: -Wall
71 ghc-options: -Wall
81−-- if flag(dump-core)
72+ if flag(dump-core)
82−-- build-depends: dump-core
73+ build-depends: dump-core
83−-- ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
74+ ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
84
75
85source-repository head
76source-repository head
86 type: git
77 type: git
87 location: https://github.com/kcsongor/generic-lens
78 location: https://github.com/kcsongor/generic-lens
88
79
89−test-suite generic-lens-examples
90− type: exitcode-stdio-1.0
91− hs-source-dirs: examples
92− main-is: Biscuits.hs
93−
94− build-depends: base >= 4.9 && <= 5.0
95− , generic-lens
96− , lens
97− , profunctors
98− , HUnit
99−
100− default-language: Haskell2010
101−
102test-suite generic-lens-test
80test-suite generic-lens-test
103 type: exitcode-stdio-1.0
81 type: exitcode-stdio-1.0
104 hs-source-dirs: test
82 hs-source-dirs: test
105 main-is: Spec.hs
83 main-is: Spec.hs
106− other-modules: Util Test24 Test25 Test40 Test62 Test63 CustomChildren
84+ other-modules: Util
107
85
108 build-depends: base >= 4.9 && <= 5.0
86 build-depends: base >= 4.9 && <= 5.0
109 , generic-lens
87 , generic-lens
110− , lens
111 , profunctors
88 , profunctors
112 , inspection-testing >= 0.2
89 , inspection-testing >= 0.2
113 , HUnit
90 , HUnit
114
91
115 default-language: Haskell2010
92 default-language: Haskell2010
116− ghc-options: -Wall
93+ ghc-options: -Wall -O2 -dsuppress-all
117 if flag(dump-core)
94 if flag(dump-core)
118 build-depends: dump-core
95 build-depends: dump-core
119 ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
96 ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
120
97
121−test-suite generic-lens-bifunctor
98+test-suite generic-lens-test-25
122 type: exitcode-stdio-1.0
99 type: exitcode-stdio-1.0
123 hs-source-dirs: test
100 hs-source-dirs: test
124− main-is: Bifunctor.hs
101+ main-is: 25.hs
125
102
126 build-depends: base >= 4.9 && <= 5.0
103 build-depends: base >= 4.9 && <= 5.0
127 , generic-lens
104 , generic-lens
128 , lens
105 , lens
129− , HUnit
130
106
131 default-language: Haskell2010
107 default-language: Haskell2010
132 ghc-options: -Wall
108 ghc-options: -Wall
133− if flag(dump-core)
134− build-depends: dump-core
135− ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
136
109
137−test-suite generic-lens-syb-tree
110+test-suite generic-lens-test-24
138 type: exitcode-stdio-1.0
111 type: exitcode-stdio-1.0
139− hs-source-dirs: test/syb
112+ hs-source-dirs: test
140− main-is: Tree.hs
113+ main-is: 24.hs
141
114
142 build-depends: base >= 4.9 && <= 5.0
115 build-depends: base >= 4.9 && <= 5.0
143 , generic-lens
116 , generic-lens
144 , lens
117 , lens
145− , profunctors
146− , HUnit
147
118
148 default-language: Haskell2010
119 default-language: Haskell2010
149 ghc-options: -Wall
120 ghc-options: -Wall
150− if flag(dump-core)
151− build-depends: dump-core
152− ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
153
121
154test-suite doctests
122test-suite doctests
155 default-language: Haskell2010
123 default-language: Haskell2010
@@ -159,14 +127,6 @@ test-suite doctests
159 build-depends: base >4 && <5, doctest
127 build-depends: base >4 && <5, doctest
160 hs-source-dirs: test
128 hs-source-dirs: test
161
129
162−test-suite examples-doctests
163− default-language: Haskell2010
164− type: exitcode-stdio-1.0
165− ghc-options: -threaded
166− main-is: doctest.hs
167− build-depends: base >4 && <5, doctest
168− hs-source-dirs: examples
169−
170benchmark generic-lens-bench
130benchmark generic-lens-bench
171 type: exitcode-stdio-1.0
131 type: exitcode-stdio-1.0
172 hs-source-dirs: benchmarks
132 hs-source-dirs: benchmarks
@@ -176,7 +136,7 @@ benchmark generic-lens-bench
176
136
177 , base >= 4.9 && <= 5.0
137 , base >= 4.9 && <= 5.0
178 , QuickCheck
138 , QuickCheck
179− , criterion >= 1.3.0.0
139+ , criterion
180 , deepseq
140 , deepseq
181 , lens
141 , lens
182
142
src/Data/GenericLens/Internal.hsdeleted−64
@@ -1,64 +0,0 @@
1−-----------------------------------------------------------------------------
2−-- |
3−-- Module : Data.GenericLens.Internal
4−-- Copyright : (C) 2019 Csongor Kiss
5−-- License : BSD3
6−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
7−-- Stability : experimental
8−-- Portability : non-portable
9−--
10−-- The library internals are exposed through this module. Please keep
11−-- in mind that everything here is subject to change irrespective of
12−-- the the version numbers.
13−-----------------------------------------------------------------------------
14−
15−module Data.GenericLens.Internal
16− ( module Data.Generics.Internal.Families
17− , module Data.Generics.Internal.Families.Changing
18− , module Data.Generics.Internal.Families.Collect
19− , module Data.Generics.Internal.Families.Has
20− , module Data.Generics.Internal.Void
21− , module Data.Generics.Internal.Errors
22−
23− , module Data.Generics.Sum.Internal.Constructors
24− , module Data.Generics.Sum.Internal.Typed
25− , module Data.Generics.Sum.Internal.Subtype
26−
27− , module Data.Generics.Product.Internal.Positions
28− , module Data.Generics.Product.Internal.GLens
29− , module Data.Generics.Product.Internal.Subtype
30− , module Data.Generics.Product.Internal.Constraints
31− , module Data.Generics.Product.Internal.HList
32−
33− , module Data.Generics.Internal.GenericN
34−
35− -- * van Laarhoven optics
36− , module Data.Generics.Internal.VL.Iso
37− , module Data.Generics.Internal.VL.Lens
38− , module Data.Generics.Internal.VL.Prism
39− , module Data.Generics.Internal.VL.Traversal
40− ) where
41−
42−import Data.Generics.Internal.Families
43−import Data.Generics.Internal.Families.Changing
44−import Data.Generics.Internal.Families.Collect
45−import Data.Generics.Internal.Families.Has
46−import Data.Generics.Internal.Void
47−import Data.Generics.Internal.Errors
48−
49−import Data.Generics.Sum.Internal.Constructors
50−import Data.Generics.Sum.Internal.Typed
51−import Data.Generics.Sum.Internal.Subtype
52−
53−import Data.Generics.Product.Internal.Positions
54−import Data.Generics.Product.Internal.GLens
55−import Data.Generics.Product.Internal.Subtype
56−import Data.Generics.Product.Internal.Constraints
57−import Data.Generics.Product.Internal.HList
58−
59−import Data.Generics.Internal.GenericN
60−
61−import Data.Generics.Internal.VL.Iso
62−import Data.Generics.Internal.VL.Lens
63−import Data.Generics.Internal.VL.Prism
64−import Data.Generics.Internal.VL.Traversal
src/Data/GenericLens/Internal.hs~deleted

No changes to the content.

src/Data/Generics/Internal/Errors.hsdeleted−59
@@ -1,59 +0,0 @@
1−{-# LANGUAGE UndecidableInstances #-}
2−{-# LANGUAGE TypeFamilies #-}
3−{-# LANGUAGE KindSignatures #-}
4−{-# LANGUAGE PolyKinds #-}
5−{-# LANGUAGE DataKinds #-}
6−{-# LANGUAGE TypeOperators #-}
7−{-# LANGUAGE KindSignatures #-}
8−
9−-------------------------------------------------------------------------------
10−---- |
11−---- Module : Data.Generics.Internal.Errors
12−---- Copyright : (C) 2019 Csongor Kiss
13−---- License : BSD3
14−---- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
15−---- Stability : experimental
16−---- Portability : non-portable
17−----
18−---- Provide more legible type errors as described in
19−---- (https://kcsongor.github.io/report-stuck-families/)[this blog post].
20−-------------------------------------------------------------------------------
21−
22−module Data.Generics.Internal.Errors
23− ( NoGeneric
24− , Defined
25− , Defined_list
26−
27− , QuoteType
28− , PrettyError
29− ) where
30−
31−import GHC.Generics
32−import GHC.TypeLits
33−import Data.Kind
34−
35−type family NoGeneric (a :: Type) (ctxt :: [ErrorMessage]) :: Constraint where
36− NoGeneric a ctxt = PrettyError ('Text "No instance for " ':<>: QuoteType (Generic a)
37− ': ctxt)
38−type family PrettyError (ctxt :: [ErrorMessage]) :: k where
39− PrettyError '[] = TypeError ('Text "")
40− PrettyError (c ': cs) = TypeError ('Text "| " ':<>: c ':$$: PrettyLines cs)
41−
42−type family PrettyLines (ctxt :: [ErrorMessage]) :: ErrorMessage where
43− PrettyLines '[] = 'Text ""
44− PrettyLines (c ': cs) = 'Text "| " ':<>: c ':$$: PrettyLines cs
45−
46−type family Defined (break :: Type -> Type) (err :: Constraint) (a :: k) :: k where
47− Defined Void1 _ _ = Any
48− Defined _ _ k = k
49−
50−type family Defined_list (break :: [*]) (err :: Constraint) (a :: k) :: k where
51− Defined_list '[Void] _ _ = Any
52− Defined_list _ _ k = k
53−
54−data Void1 a
55−data Void
56−type family Any :: k
57−
58−type family QuoteType (typ :: k) :: ErrorMessage where
59− QuoteType typ = 'Text "‘" ':<>: 'ShowType typ ':<>: 'Text "’"
src/Data/Generics/Internal/Families.hs+2−1
@@ -3,13 +3,14 @@
3{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE KindSignatures #-}
4{-# LANGUAGE KindSignatures #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE TypeApplications #-}
6{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeOperators #-}
8{-# LANGUAGE TypeOperators #-}
8
9
9-----------------------------------------------------------------------------
10-----------------------------------------------------------------------------
10-- |
11-- |
11-- Module : Data.Generics.Internal.Families
12-- Module : Data.Generics.Internal.Families
12−-- Copyright : (C) 2019 Csongor Kiss
13+-- Copyright : (C) 2017 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/Families/Changing.hs+16−49
@@ -9,17 +9,11 @@
9{-# LANGUAGE UndecidableInstances #-}
9{-# LANGUAGE UndecidableInstances #-}
10
10
11module Data.Generics.Internal.Families.Changing
11module Data.Generics.Internal.Families.Changing
12− ( Indexed
12+ ( Proxied
13 , Infer
13 , Infer
14− , PTag (..)
15− , P
16− , LookupParam
17− , ArgAt
18− , ArgCount
19− , UnifyHead
20 ) where
14 ) where
21
15
22−import GHC.TypeLits (Nat, type (-), type (+), TypeError, ErrorMessage (..))
16+import GHC.TypeLits (TypeError, ErrorMessage (..))
23
17
24{-
18{-
25 Note [Changing type parameters]
19 Note [Changing type parameters]
@@ -54,19 +48,19 @@ import GHC.TypeLits (Nat, type (-), type (+), TypeError, ErrorMessage (..))
54-- application form. In order to distinguish between applications of P and other type constructors, we use a tag, `PTag`
48-- application form. In order to distinguish between applications of P and other type constructors, we use a tag, `PTag`
55-- to fake a type constructor.
49-- to fake a type constructor.
56data PTag = PTag
50data PTag = PTag
57−type family P :: Nat -> k -> PTag -> k
51+type family P :: Peano -> k -> PTag -> k
58
52
59−type Indexed t = Indexed' t 0
53+type Proxied t = Proxied' t 'Z
60
54
61−type family Indexed' (t :: k) (next :: Nat) :: k where
55+type family Proxied' (t :: k) (next :: Peano) :: k where
62− Indexed' (t (a :: j) :: k) next = (Indexed' t (next + 1)) (P next a 'PTag)
56+ Proxied' (t (a :: j) :: k) next = (Proxied' t ('S next)) (P next a 'PTag)
63− Indexed' t _ = t
57+ Proxied' t _ = t
64
58
65data Sub where
59data Sub where
66− Sub :: Nat -> k -> Sub
60+ Sub :: Peano -> k -> Sub
67
61
68type family Unify (a :: k) (b :: k) :: [Sub] where
62type family Unify (a :: k) (b :: k) :: [Sub] where
69− Unify (p n _ 'PTag) a' = '[ 'Sub n a']
63+ Unify (a n _ 'PTag) a' = '[ 'Sub n a']
70 Unify (a x) (b y) = Unify x y ++ Unify a b
64 Unify (a x) (b y) = Unify x y ++ Unify a b
71 Unify a a = '[]
65 Unify a a = '[]
72 Unify a b = TypeError
66 Unify a b = TypeError
@@ -87,49 +81,28 @@ type family Infer (s :: *) (a' :: *) (b :: *) :: * where
87
81
88--------------------------------------------------------------------------------
82--------------------------------------------------------------------------------
89
83
84+data Peano = Z | S Peano
85+
90-- [TODO]: work this out
86-- [TODO]: work this out
91--
87--
92−--type family ArgKind (t :: k) (pos :: Nat) :: * where
88+--type family ArgKind (t :: k) (pos :: Peano) :: * where
93-- ArgKind (t (a :: k)) 'Z = k
89-- ArgKind (t (a :: k)) 'Z = k
94-- ArgKind (t _) ('S pos) = ArgKind t pos
90-- ArgKind (t _) ('S pos) = ArgKind t pos
95--
91--
96−--type family ReplaceArg (t :: k) (pos :: Nat) (to :: ArgKind t pos) :: k where
92+--type family ReplaceArg (t :: k) (pos :: Peano) (to :: ArgKind t pos) :: k where
97-- ReplaceArg (t a) 'Z to = t to
93-- ReplaceArg (t a) 'Z to = t to
98-- ReplaceArg (t a) ('S pos) to = ReplaceArg t pos to a
94-- ReplaceArg (t a) ('S pos) to = ReplaceArg t pos to a
99-- ReplaceArg t _ _ = t
95-- ReplaceArg t _ _ = t
100
96
101−type family ReplaceArg (t :: k) (pos :: Nat) (to :: j) :: k where
97+type family ReplaceArg (t :: k) (pos :: Peano) (to :: j) :: k where
102− ReplaceArg (t a) 0 to = t to
98+ ReplaceArg (t a) 'Z to = t to
103− ReplaceArg (t a) pos to = ReplaceArg t (pos - 1) to a
99+ ReplaceArg (t a) ('S pos) to = ReplaceArg t pos to a
104 ReplaceArg t _ _ = t
100 ReplaceArg t _ _ = t
105
101
106type family ReplaceArgs (t :: k) (subs :: [Sub]) :: k where
102type family ReplaceArgs (t :: k) (subs :: [Sub]) :: k where
107 ReplaceArgs t '[] = t
103 ReplaceArgs t '[] = t
108 ReplaceArgs t ('Sub n arg ': ss) = ReplaceArgs (ReplaceArg t n arg) ss
104 ReplaceArgs t ('Sub n arg ': ss) = ReplaceArgs (ReplaceArg t n arg) ss
109
105
110−type family LookupParam (a :: k) (p :: Nat) :: Maybe Nat where
111− LookupParam (param (n :: Nat)) m = 'Nothing
112− LookupParam (a (_ (m :: Nat))) n = IfEq m n ('Just 0) (MaybeAdd (LookupParam a n) 1)
113− LookupParam (a _) n = MaybeAdd (LookupParam a n) 1
114− LookupParam a _ = 'Nothing
115−
116−type family MaybeAdd (a :: Maybe Nat) (b :: Nat) :: Maybe Nat where
117− MaybeAdd 'Nothing _ = 'Nothing
118− MaybeAdd ('Just a) b = 'Just (a + b)
119−
120−type family IfEq (a :: k) (b :: k) (t :: l) (f :: l) :: l where
121− IfEq a a t _ = t
122− IfEq _ _ _ f = f
123−
124−type family ArgCount (t :: k) :: Nat where
125− ArgCount (f a) = 1 + ArgCount f
126− ArgCount a = 0
127−
128−type family ArgAt (t :: k) (n :: Nat) :: j where
129− ArgAt (t a) 0 = a
130− ArgAt (t a) n = ArgAt t (n - 1)
131−
132−
133-- Note [CPP in instance constraints]
106-- Note [CPP in instance constraints]
134-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
107-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
135--
108--
@@ -153,9 +126,3 @@ type family ArgAt (t :: k) (n :: Nat) :: j where
153-- However, for some reason, this violates the functional dependencies on 8.2.2.
126-- However, for some reason, this violates the functional dependencies on 8.2.2.
154-- Therefore, when using a newer version of the compiler, the original constraints
127-- Therefore, when using a newer version of the compiler, the original constraints
155-- are used, as the expression size is smaller under 8.2.2.
128-- are used, as the expression size is smaller under 8.2.2.
156−
157−-- | Ensure that the types @a@ and @b@ are both applications of the same
158−-- constructor. The arguments may be different.
159−class UnifyHead (a :: k) (b :: k)
160−instance {-# OVERLAPPING #-} (gb ~ g b, UnifyHead f g) => UnifyHead (f a) gb
161−instance (a ~ b) => UnifyHead a b
src/Data/Generics/Internal/Families/Collect.hs+2−2
@@ -7,7 +7,7 @@
7-----------------------------------------------------------------------------
7-----------------------------------------------------------------------------
8-- |
8-- |
9-- Module : Data.Generics.Internal.Families.Collect
9-- Module : Data.Generics.Internal.Families.Collect
10−-- Copyright : (C) 2019 Csongor Kiss
10+-- Copyright : (C) 2017 Csongor Kiss
11-- License : BSD3
11-- License : BSD3
12-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
12-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
13-- Stability : experimental
13-- Stability : experimental
@@ -28,7 +28,7 @@ import Data.Type.Equality (type (==))
28import GHC.Generics
28import GHC.Generics
29import GHC.TypeLits (Symbol, CmpSymbol)
29import GHC.TypeLits (Symbol, CmpSymbol)
30
30
31−import Data.Generics.Product.Internal.HList (type (++))
31+import Data.Generics.Product.Internal.List (type (++))
32import Data.Generics.Internal.Families.Has (GTypes)
32import Data.Generics.Internal.Families.Has (GTypes)
33
33
34data TypeStat
34data TypeStat
src/Data/Generics/Internal/Families/Has.hs+46−72
@@ -7,7 +7,7 @@
7-----------------------------------------------------------------------------
7-----------------------------------------------------------------------------
8-- |
8-- |
9-- Module : Data.Generics.Internal.Families.Has
9-- Module : Data.Generics.Internal.Families.Has
10−-- Copyright : (C) 2019 Csongor Kiss
10+-- Copyright : (C) 2017 Csongor Kiss
11-- License : BSD3
11-- License : BSD3
12-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
12-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
13-- Stability : experimental
13-- Stability : experimental
@@ -17,99 +17,73 @@
17module Data.Generics.Internal.Families.Has
17module Data.Generics.Internal.Families.Has
18 ( HasTotalFieldP
18 ( HasTotalFieldP
19 , HasTotalTypeP
19 , HasTotalTypeP
20− , HasTotalPositionP
21− , Pos
22 , HasPartialTypeP
20 , HasPartialTypeP
23 , HasCtorP
21 , HasCtorP
24 , GTypes
22 , GTypes
25 ) where
23 ) where
26
24
27−import Data.Type.Bool (type (||))
25+import Data.Type.Bool (type (||), type (&&))
28import Data.Type.Equality (type (==))
26import Data.Type.Equality (type (==))
29import GHC.Generics
27import GHC.Generics
30−import GHC.TypeLits (Symbol, Nat)
28+import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
31−import Data.Kind (Type)
32
29
33−import Data.Generics.Product.Internal.HList
30+import Data.Generics.Product.Internal.List
34
31
35−-- Note: these could be factored out into a single traversal
36−
37−type family Both (m1 :: Maybe a) (m2 :: Maybe a) :: Maybe a where
38− Both ('Just a) ('Just a) = 'Just a
39−
40−type family Alt (m1 :: Maybe a) (m2 :: Maybe a) :: Maybe a where
41− Alt ('Just a) _ = 'Just a
42− Alt _ b = b
43−
44−type family HasTotalFieldP (field :: Symbol) f :: Maybe Type where
32+type family HasTotalFieldP (field :: Symbol) f :: Bool where
45− HasTotalFieldP field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 t))
33+ HasTotalFieldP field (S1 ('MetaSel ('Just field) _ _ _) _)
46− = 'Just t
34+ = 'True
47 HasTotalFieldP field (l :*: r)
35 HasTotalFieldP field (l :*: r)
48− = Alt (HasTotalFieldP field l) (HasTotalFieldP field r)
36+ = HasTotalFieldP field l || HasTotalFieldP field r
49 HasTotalFieldP field (l :+: r)
37 HasTotalFieldP field (l :+: r)
50− = Both (HasTotalFieldP field l) (HasTotalFieldP field r)
38+ = HasTotalFieldP field l && HasTotalFieldP field r
51 HasTotalFieldP field (S1 _ _)
39 HasTotalFieldP field (S1 _ _)
52− = 'Nothing
40+ = 'False
53 HasTotalFieldP field (C1 _ f)
41 HasTotalFieldP field (C1 _ f)
54 = HasTotalFieldP field f
42 = HasTotalFieldP field f
55 HasTotalFieldP field (D1 _ f)
43 HasTotalFieldP field (D1 _ f)
56 = HasTotalFieldP field f
44 = HasTotalFieldP field f
57− HasTotalFieldP field (K1 _ _)
45+ HasTotalFieldP field (Rec0 _)
58− = 'Nothing
46+ = 'False
59 HasTotalFieldP field U1
47 HasTotalFieldP field U1
60− = 'Nothing
48+ = 'False
61 HasTotalFieldP field V1
49 HasTotalFieldP field V1
62− = 'Nothing
50+ = 'False
63−
51+ HasTotalFieldP field f
64−type family HasTotalTypeP (typ :: Type) f :: Maybe Type where
52+ = TypeError
65− HasTotalTypeP typ (S1 _ (K1 _ typ))
53+ ( 'ShowType f
66− = 'Just typ
54+ ':<>: 'Text " is not a valid GHC.Generics representation type"
67− HasTotalTypeP typ (l :*: r)
55+ )
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
56
86−type family HasTotalPositionP (pos :: Nat) f :: Maybe Type where
57+type family HasTotalTypeP a f :: Bool where
87− HasTotalPositionP pos (S1 _ (K1 (Pos pos) t))
58+ HasTotalTypeP t (S1 meta (Rec0 t))
88− = 'Just t
59+ = 'True
89− HasTotalPositionP pos (l :*: r)
60+ HasTotalTypeP t (l :*: r)
90− = Alt (HasTotalPositionP pos l) (HasTotalPositionP pos r)
61+ = HasTotalTypeP t l || HasTotalTypeP t r
91− HasTotalPositionP pos (l :+: r)
62+ HasTotalTypeP t (l :+: r)
92− = Both (HasTotalPositionP pos l) (HasTotalPositionP pos r)
63+ = HasTotalTypeP t l && HasTotalTypeP t r
93− HasTotalPositionP pos (S1 _ _)
64+ HasTotalTypeP t (S1 _ _)
94− = 'Nothing
65+ = 'False
95− HasTotalPositionP pos (C1 _ f)
66+ HasTotalTypeP t (C1 m f)
96− = HasTotalPositionP pos f
67+ = HasTotalTypeP t f
97− HasTotalPositionP pos (D1 _ f)
68+ HasTotalTypeP t (D1 m f)
98− = HasTotalPositionP pos f
69+ = HasTotalTypeP t f
99− HasTotalPositionP pos (K1 _ _)
70+ HasTotalTypeP t (Rec0 _)
100− = 'Nothing
71+ = 'False
101− HasTotalPositionP pos U1
72+ HasTotalTypeP t U1
102− = 'Nothing
73+ = 'False
103− HasTotalPositionP pos V1
74+ HasTotalTypeP t V1
104− = 'Nothing
75+ = 'False
76+ HasTotalTypeP t f
77+ = TypeError
78+ ( 'ShowType f
79+ ':<>: 'Text " is not a valid GHC.Generics representation type"
80+ )
105
81
106type family HasPartialTypeP a f :: Bool where
82type family HasPartialTypeP a f :: Bool where
107 HasPartialTypeP t (l :+: r)
83 HasPartialTypeP t (l :+: r)
108 = HasPartialTypeP t l || HasPartialTypeP t r
84 = HasPartialTypeP t l || HasPartialTypeP t r
109 HasPartialTypeP t (C1 m f)
85 HasPartialTypeP t (C1 m f)
110 = t == GTypes f
86 = t == GTypes f
111− HasPartialTypeP t (M1 _ _ f)
112− = HasPartialTypeP t f
113 HasPartialTypeP t _
87 HasPartialTypeP t _
114 = 'False
88 = 'False
115
89
@@ -123,11 +97,11 @@ type family HasCtorP (ctor :: Symbol) f :: Bool where
123 HasCtorP ctor _
97 HasCtorP ctor _
124 = 'False
98 = 'False
125
99
126−type family GTypes (rep :: Type -> Type) :: [Type] where
100+type family GTypes (rep :: * -> *) :: [((), *)] where
127 GTypes (l :*: r)
101 GTypes (l :*: r)
128 = GTypes l ++ GTypes r
102 = GTypes l ++ GTypes r
129− GTypes (K1 _ a)
103+ GTypes (Rec0 a)
130− = '[ a]
104+ = '[ '( '(), a)]
131 GTypes (M1 _ m a)
105 GTypes (M1 _ m a)
132 = GTypes a
106 = GTypes a
133 GTypes U1 = '[]
107 GTypes U1 = '[]
src/Data/Generics/Internal/GenericN.hsdeleted−75
@@ -1,75 +0,0 @@
1−{-# OPTIONS_HADDOCK hide #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE InstanceSigs #-}
6−{-# LANGUAGE PolyKinds #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE TypeFamilies #-}
9−{-# LANGUAGE TypeOperators #-}
10−{-# LANGUAGE UndecidableInstances #-}
11−
12−--------------------------------------------------------------------------------
13−-- |
14−-- Module : Data.Generics.Internal.GenericN
15−-- Copyright : (C) 2019 Csongor Kiss
16−-- License : BSD3
17−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
18−-- Stability : experimental
19−-- Portability : non-portable
20−--
21−-- Generic representation of types with multiple parameters
22−--
23−--------------------------------------------------------------------------------
24−
25−module Data.Generics.Internal.GenericN
26− ( Param
27− , Rec (Rec, unRec)
28− , GenericN (..)
29− ) where
30−
31−import Data.Kind
32−import GHC.Generics
33−import GHC.TypeLits
34−import Data.Coerce
35−
36−type family Param :: Nat -> k where
37−
38−type family Indexed (t :: k) (i :: Nat) :: k where
39− Indexed (t a) i = Indexed t (i + 1) (Param i)
40− Indexed t _ = t
41−
42−newtype Rec (p :: Type) a x = Rec { unRec :: K1 R a x }
43−
44−type family Zip (a :: Type -> Type) (b :: Type -> Type) :: Type -> Type where
45− Zip (M1 mt m s) (M1 mt m t)
46− = M1 mt m (Zip s t)
47− Zip (l :+: r) (l' :+: r')
48− = Zip l l' :+: Zip r r'
49− Zip (l :*: r) (l' :*: r')
50− = Zip l l' :*: Zip r r'
51− Zip (Rec0 p) (Rec0 a)
52− = Rec p a
53− Zip U1 U1
54− = U1
55−
56−class
57− ( Coercible (Rep a) (RepN a)
58− , Generic a
59− ) => GenericN (a :: Type) where
60− type family RepN (a :: Type) :: Type -> Type
61− type instance RepN a = Zip (Rep (Indexed a 0)) (Rep a)
62− toN :: RepN a x -> a
63− fromN :: a -> RepN a x
64−
65−instance
66− ( Coercible (Rep a) (RepN a)
67− , Generic a
68− ) => GenericN a where
69− toN :: forall x. RepN a x -> a
70− toN = coerce (to :: Rep a x -> a)
71− {-# INLINE toN #-}
72−
73− fromN :: forall x. a -> RepN a x
74− fromN = coerce (from :: a -> Rep a x)
75− {-# INLINE fromN #-}
src/Data/Generics/Internal/Profunctor/Iso.hs+7−19
@@ -1,9 +1,9 @@
1−{-# OPTIONS_HADDOCK hide #-}
2−{-# LANGUAGE TupleSections #-}
3{-# LANGUAGE GADTs #-}
1{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE NoMonomorphismRestriction #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
5{-# LANGUAGE Rank2Types #-}
4{-# LANGUAGE Rank2Types #-}
6{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TupleSections #-}
7{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE TypeFamilyDependencies #-}
8{-# LANGUAGE TypeFamilyDependencies #-}
9{-# LANGUAGE TypeOperators #-}
9{-# LANGUAGE TypeOperators #-}
@@ -11,7 +11,7 @@
11-----------------------------------------------------------------------------
11-----------------------------------------------------------------------------
12-- |
12-- |
13-- Module : Data.Generics.Internal.Profunctor.Iso
13-- Module : Data.Generics.Internal.Profunctor.Iso
14−-- Copyright : (C) 2019 Csongor Kiss
14+-- Copyright : (C) 2017 Csongor Kiss
15-- License : BSD3
15-- License : BSD3
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17-- Stability : experimental
17-- Stability : experimental
@@ -26,9 +26,6 @@ import Data.Profunctor (Profunctor(..))
26import Data.Profunctor.Unsafe ((#.), (.#))
26import Data.Profunctor.Unsafe ((#.), (.#))
27import GHC.Generics ((:*:)(..), (:+:)(..), Generic(..), M1(..), K1(..), Rep)
27import GHC.Generics ((:*:)(..), (:+:)(..), Generic(..), M1(..), K1(..), Rep)
28import Data.Coerce
28import Data.Coerce
29−import Data.Generics.Internal.GenericN (Rec (..))
30−
31−import qualified Data.Generics.Internal.VL.Iso as VL
32
29
33type Iso s t a b
30type Iso s t a b
34 = forall p. (Profunctor p) => p a b -> p s t
31 = forall p. (Profunctor p) => p a b -> p s t
@@ -49,17 +46,12 @@ kIso :: Iso (K1 r a p) (K1 r b p) a b
49kIso = iso unK1 K1
46kIso = iso unK1 K1
50{-# INLINE kIso #-}
47{-# INLINE kIso #-}
51
48
52−recIso :: Iso (Rec r a p) (Rec r b p) a b
53−recIso = iso (unK1 . unRec) (Rec . K1)
54−{-# INLINE recIso #-}
55−
56sumIso :: Iso ((a :+: b) x) ((a' :+: b') x) (Either (a x) (b x)) (Either (a' x) (b' x))
49sumIso :: Iso ((a :+: b) x) ((a' :+: b') x) (Either (a x) (b x)) (Either (a' x) (b' x))
57sumIso = iso back forth
50sumIso = iso back forth
58− where forth (Left l) = L1 l
51+ where forth (Left l) = (L1 l)
59− forth (Right r) = R1 r
52+ forth (Right r) = (R1 r)
60− back (L1 l) = Left l
53+ back (L1 l) = (Left l)
61− back (R1 r) = Right r
54+ back (R1 r) = (Right r)
62−{-# INLINE sumIso #-}
63
55
64prodIso :: Iso ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
56prodIso :: Iso ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
65prodIso = iso (\(a :*: b) -> (a, b)) (\(a, b) -> (a :*: b))
57prodIso = iso (\(a :*: b) -> (a, b)) (\(a, b) -> (a :*: b))
@@ -78,10 +70,6 @@ iso :: (s -> a) -> (b -> t) -> Iso s t a b
78iso = dimap
70iso = dimap
79{-# INLINE iso #-}
71{-# INLINE iso #-}
80
72
81−iso2isovl :: Iso s t a b -> VL.Iso s t a b
82−iso2isovl _iso = withIso _iso VL.iso
83−{-# INLINE iso2isovl #-}
84−
85withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
73withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
86withIso ai k = case ai (Exchange id id) of
74withIso ai k = case ai (Exchange id id) of
87 Exchange sa bt -> k sa bt
75 Exchange sa bt -> k sa bt
src/Data/Generics/Internal/Profunctor/Lens.hs+39−35
@@ -1,5 +1,5 @@
1−{-# OPTIONS_HADDOCK hide #-}
2{-# LANGUAGE GADTs #-}
1{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
4{-# LANGUAGE Rank2Types #-}
4{-# LANGUAGE Rank2Types #-}
5{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE ScopedTypeVariables #-}
@@ -11,7 +11,7 @@
11-----------------------------------------------------------------------------
11-----------------------------------------------------------------------------
12-- |
12-- |
13-- Module : Data.Generics.Internal.Profunctor.Lens
13-- Module : Data.Generics.Internal.Profunctor.Lens
14−-- Copyright : (C) 2019 Csongor Kiss
14+-- Copyright : (C) 2017 Csongor Kiss
15-- License : BSD3
15-- License : BSD3
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17-- Stability : experimental
17-- Stability : experimental
@@ -22,8 +22,12 @@
22-----------------------------------------------------------------------------
22-----------------------------------------------------------------------------
23module Data.Generics.Internal.Profunctor.Lens where
23module Data.Generics.Internal.Profunctor.Lens where
24
24
25+import Control.Applicative (Const(..))
26+import Data.Monoid (First (..))
25import Data.Profunctor (Profunctor(..), Strong(..))
27import Data.Profunctor (Profunctor(..), Strong(..))
26import Data.Bifunctor
28import Data.Bifunctor
29+import Data.Profunctor.Unsafe ((#.))
30+import Data.Tagged
27import GHC.Generics
31import GHC.Generics
28import Data.Generics.Internal.Profunctor.Iso
32import Data.Generics.Internal.Profunctor.Iso
29
33
@@ -33,12 +37,10 @@ type Lens s t a b
33type LensLike p s t a b
37type LensLike p s t a b
34 = p a b -> p s t
38 = p a b -> p s t
35
39
36−
40+-- | Getting
37−ravel :: (ALens a b a b -> ALens a b s t) -> Lens s t a b
41+(^.) :: s -> ((a -> Const a a) -> s -> Const a s) -> a
38−ravel l pab = conv (l idLens) pab
42+s ^. l = getConst (l Const s)
39− where
43+infixl 8 ^.
40− conv :: ALens a b s t -> Lens s t a b
41− conv (ALens _get _set) = lens _get _set
42
44
43-- | Setting
45-- | Setting
44set :: ((a -> b) -> s -> t) -> (s, b) -> t
46set :: ((a -> b) -> s -> t) -> (s, b) -> t
@@ -46,31 +48,38 @@ set f (s, b)
46 = f (const b) s
48 = f (const b) s
47
49
48view :: Lens s s a a -> s -> a
50view :: Lens s s a a -> s -> a
49−view l = withLensPrim l (\get _ -> snd . get)
51+view l = withLens l (\get _ -> get)
50−
51−--withLens :: Lens s t a b -> ((s -> a) -> ((s, b) -> t) -> r) -> r
52−--ithLens l k =
53−-- case l idLens of
54−-- ALens _get _set -> k (snd . _get) (\(s, b) -> _set ((fst $ _get s), b))
55
52
56−withLensPrim :: Lens s t a b -> (forall c . (s -> (c,a)) -> ((c, b) -> t) -> r) -> r
53+withLens :: Lens s t a b -> ((s -> a) -> ((s, b) -> t) -> r) -> r
57−withLensPrim l k =
54+withLens l k =
58 case l idLens of
55 case l idLens of
59 ALens _get _set -> k _get _set
56 ALens _get _set -> k _get _set
60
57
61idLens :: ALens a b a b
58idLens :: ALens a b a b
62−idLens = ALens (fork (const ()) id) snd
59+idLens = ALens id snd
63−{-# INLINE idLens #-}
60+
61+infixr 4 .~
62+(.~) :: ((a -> b) -> s -> t) -> b -> s -> t
63+(.~) f b s = set f (s, b)
64+
65+infixl 8 ^?
66+(^?) :: s -> ((a -> Const (First a) a) -> s -> Const (First a) s) -> Maybe a
67+s ^? l = getFirst (fmof l (First #. Just) s)
68+ where fmof l' f = getConst #. l' (Const #. f)
69+
70+build :: (Tagged b b -> Tagged t t) -> b -> t
71+build p = unTagged . p . Tagged
72+
64
73
65-- | Lens focusing on the first element of a product
74-- | Lens focusing on the first element of a product
66first :: Lens ((a :*: b) x) ((a' :*: b) x) (a x) (a' x)
75first :: Lens ((a :*: b) x) ((a' :*: b) x) (a x) (a' x)
67first
76first
68− = lens (\(a :*: b) -> (b,a)) (\(b, a') -> a' :*: b)
77+ = lens (\(a :*: _) -> a) (\((_ :*: b), a') -> a' :*: b)
69
78
70-- | Lens focusing on the second element of a product
79-- | Lens focusing on the second element of a product
71second :: Lens ((a :*: b) x) ((a :*: b') x) (b x) (b' x)
80second :: Lens ((a :*: b) x) ((a :*: b') x) (b x) (b' x)
72second
81second
73− = lens (\(a :*: b) -> (a,b)) (\(a, b') -> a :*: b')
82+ = lens (\(_ :*: b) -> b) (\((a :*: _), b') -> a :*: b')
74
83
75fork :: (a -> b) -> (a -> c) -> a -> (b, c)
84fork :: (a -> b) -> (a -> c) -> a -> (b, c)
76fork f g a = (f a, g a)
85fork f g a = (f a, g a)
@@ -123,35 +132,30 @@ stron :: (Either s s', b) -> Either (s, b) (s', b)
123stron (e, b) = bimap (,b) (, b) e
132stron (e, b) = bimap (,b) (, b) e
124
133
125choosing :: forall s t a b s' t' . Lens s t a b -> Lens s' t' a b -> Lens (Either s s') (Either t t') a b
134choosing :: forall s t a b s' t' . Lens s t a b -> Lens s' t' a b -> Lens (Either s s') (Either t t') a b
126−choosing l r = withLensPrim l (\getl setl ->
135+choosing l r = withLens l (\getl setl ->
127− withLensPrim r (\getr setr ->
136+ withLens r (\getr setr ->
128− let --g :: Either s s' -> a
137+ let g :: Either s s' -> a
129− g e = case e of
138+ g = either getl getr
130− Left v -> let (c, v') = getl v in (Left c, v')
131− Right v -> let (c, v') = getr v in (Right c, v')
132 s = bimap setl setr . stron
139 s = bimap setl setr . stron
133 in lens g s))
140 in lens g s))
134
141
135−lens :: (s -> (c,a)) -> ((c,b) -> t) -> Lens s t a b
142+lens :: (s -> a) -> ((s,b) -> t) -> Lens s t a b
136−lens get _set = dimap get _set . second'
143+lens get _set = dimap (fork id get) _set . second'
137−{-# INLINE lens #-}
138
144
139------------------------------------------------------------------------------
145------------------------------------------------------------------------------
140
146
141−data ALens a b s t = forall c . ALens (s -> (c,a)) ((c, b) -> t)
147+data ALens a b s t = ALens (s -> a) ((s, b) -> t)
142
148
143instance Functor (ALens a b s) where
149instance Functor (ALens a b s) where
144 fmap f (ALens _get _set) = ALens _get (f . _set)
150 fmap f (ALens _get _set) = ALens _get (f . _set)
145
151
146instance Profunctor (ALens a b) where
152instance Profunctor (ALens a b) where
147− dimap f g (ALens get _set) = ALens (get . f) (g . _set)
153+ dimap f g (ALens get _set) = ALens (get . f) (g . _set . cross f id)
148
154
149instance Strong (ALens a b) where
155instance Strong (ALens a b) where
150− second' (ALens get _set) = ALens get' set' --(bimap id _set . assoc)
156+ second' (ALens get _set) = ALens (get . snd) (bimap id _set . assoc)
151 where
157 where
152− get' (c, a1) = let (c1, a) = get a1 in ((c, c1), a)
158+ assoc ((a, b), c) = (a, (b, c))
153− set' ((c, c1), b) = (c, _set (c1, b))
154− {-# INLINE second' #-}
155
159
156-- These are specialised versions of the Isos. On GHC 8.0.2, having
160-- These are specialised versions of the Isos. On GHC 8.0.2, having
157-- these functions eta-expanded allows the optimiser to inline these functions.
161-- these functions eta-expanded allows the optimiser to inline these functions.
src/Data/Generics/Internal/Profunctor/Prism.hs+13−16
@@ -1,9 +1,9 @@
1−{-# OPTIONS_HADDOCK hide #-}
2{-# LANGUAGE GADTs #-}
1{-# LANGUAGE GADTs #-}
3{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE NoMonomorphismRestriction #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
5{-# LANGUAGE Rank2Types #-}
4{-# LANGUAGE Rank2Types #-}
6{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TupleSections #-}
7{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE TypeFamilyDependencies #-}
8{-# LANGUAGE TypeFamilyDependencies #-}
9{-# LANGUAGE TypeOperators #-}
9{-# LANGUAGE TypeOperators #-}
@@ -11,7 +11,7 @@
11-----------------------------------------------------------------------------
11-----------------------------------------------------------------------------
12-- |
12-- |
13-- Module : Data.Generics.Internal.Profunctor.Prism
13-- Module : Data.Generics.Internal.Profunctor.Prism
14−-- Copyright : (C) 2019 Csongor Kiss
14+-- Copyright : (C) 2017 Csongor Kiss
15-- License : BSD3
15-- License : BSD3
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17-- Stability : experimental
17-- Stability : experimental
@@ -22,9 +22,7 @@
22-----------------------------------------------------------------------------
22-----------------------------------------------------------------------------
23module Data.Generics.Internal.Profunctor.Prism where
23module Data.Generics.Internal.Profunctor.Prism where
24
24
25−import Data.Bifunctor (bimap)
26import Data.Profunctor (Choice(..), Profunctor(..))
25import Data.Profunctor (Choice(..), Profunctor(..))
27−import Data.Tagged
28import Data.Profunctor.Unsafe ((#.), (.#))
26import Data.Profunctor.Unsafe ((#.), (.#))
29import GHC.Generics
27import GHC.Generics
30import Data.Coerce
28import Data.Coerce
@@ -46,20 +44,16 @@ prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
46prism bt seta eta = dimap seta (either id bt) (right' eta)
44prism bt seta eta = dimap seta (either id bt) (right' eta)
47
45
48_Left :: Prism (Either a c) (Either b c) a b
46_Left :: Prism (Either a c) (Either b c) a b
49−_Left = left'
47+_Left = prism Left $ either Right (Left . Right)
50
48
51_Right :: Prism (Either c a) (Either c b) a b
49_Right :: Prism (Either c a) (Either c b) a b
52−_Right = right'
50+_Right = prism Right $ either (Left . Left) Right
53
51
54−prismPRavel :: APrism s t a b -> Prism s t a b
52+prismPRavel ::
53+ (Market a b a b -> Market a b s t)
54+ -> Prism s t a b
55prismPRavel l pab = (prism2prismp $ l idPrism) pab
55prismPRavel l pab = (prism2prismp $ l idPrism) pab
56
56
57−build :: (Tagged b b -> Tagged t t) -> b -> t
58−build p = unTagged #. p .# Tagged
59−
60−match :: Prism s t a b -> s -> Either t a
61−match k = withPrism k $ \_ _match -> _match
62−
63--------------------------------------------------------------------------------
57--------------------------------------------------------------------------------
64-- Prism stuff
58-- Prism stuff
65
59
@@ -67,7 +61,9 @@ without' :: Prism s t a b -> Prism s t c d -> Prism s t (Either a c) (Either b d
67without' k =
61without' k =
68 withPrism k $ \bt _ k' ->
62 withPrism k $ \bt _ k' ->
69 withPrism k' $ \dt setc ->
63 withPrism k' $ \dt setc ->
70− prism (either bt dt) $ \s -> fmap Right (setc s)
64+ prism (foldEither bt dt) $ \s -> fmap Right (setc s)
65+ where foldEither _ g (Right r) = g r
66+ foldEither f _ (Left l) = f l
71{-# INLINE without' #-}
67{-# INLINE without' #-}
72
68
73withPrism :: APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
69withPrism :: APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
@@ -85,7 +81,8 @@ gsum f _ (L1 x) = f x
85gsum _ g (R1 y) = g y
81gsum _ g (R1 y) = g y
86
82
87plus :: (a -> b) -> (c -> d) -> Either a c -> Either b d
83plus :: (a -> b) -> (c -> d) -> Either a c -> Either b d
88−plus = bimap
84+plus f _ (Left x) = Left (f x)
85+plus _ g (Right y) = Right (g y)
89
86
90--------------------------------------------------------------------------------
87--------------------------------------------------------------------------------
91-- Market
88-- Market
@@ -109,7 +106,7 @@ instance Profunctor (Market a b) where
109 {-# INLINE ( .# ) #-}
106 {-# INLINE ( .# ) #-}
110
107
111instance Choice (Market a b) where
108instance Choice (Market a b) where
112− left' (Market bt seta) = Market (Left . bt) $ \case
109+ left' (Market bt seta) = Market (Left . bt) $ \sc -> case sc of
113 Left s -> case seta s of
110 Left s -> case seta s of
114 Left t -> Left (Left t)
111 Left t -> Left (Left t)
115 Right a -> Right a
112 Right a -> Right a
src/Data/Generics/Internal/VL/Iso.hs+4−37
@@ -1,8 +1,9 @@
1−{-# OPTIONS_HADDOCK hide #-}
2{-# LANGUAGE GADTs #-}
1{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
4{-# LANGUAGE Rank2Types #-}
4{-# LANGUAGE Rank2Types #-}
5{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TupleSections #-}
6{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeFamilyDependencies #-}
8{-# LANGUAGE TypeFamilyDependencies #-}
8{-# LANGUAGE TypeOperators #-}
9{-# LANGUAGE TypeOperators #-}
@@ -10,7 +11,7 @@
10-----------------------------------------------------------------------------
11-----------------------------------------------------------------------------
11-- |
12-- |
12-- Module : Data.Generics.Internal.VL.Iso
13-- Module : Data.Generics.Internal.VL.Iso
13−-- Copyright : (C) 2019 Csongor Kiss
14+-- Copyright : (C) 2017 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,25 +22,8 @@
21-----------------------------------------------------------------------------
22-----------------------------------------------------------------------------
22module Data.Generics.Internal.VL.Iso where
23module Data.Generics.Internal.VL.Iso where
23
24
24−import Data.Coerce (coerce)
25−import Data.Functor.Identity (Identity(..))
26−import Data.Profunctor (Profunctor(..))
25+import Data.Profunctor (Profunctor(..))
27import GHC.Generics
26import GHC.Generics
28−import Data.Generics.Internal.GenericN (Rec (..))
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
27
44type Iso' s a
28type Iso' s a
45 = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s)
29 = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s)
@@ -47,17 +31,6 @@ type Iso' s a
47type Iso s t a b
31type Iso s t a b
48 = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
32 = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
49
33
50−fromIso :: Iso s t a b -> Iso b a t s
51−fromIso l = withIso l $ \ sa bt -> iso bt sa
52−{-# inline fromIso #-}
53−
54−-- | Extract the two functions, one from @s -> a@ and
55−-- one from @b -> t@ that characterize an 'Iso'.
56−withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
57−withIso ai k = case ai (Exchange id Identity) of
58− Exchange sa bt -> k sa (coerce bt)
59−{-# inline withIso #-}
60−
61-- | A type and its generic representation are isomorphic
34-- | A type and its generic representation are isomorphic
62repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
35repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
63repIso = iso from to
36repIso = iso from to
@@ -66,12 +39,6 @@ repIso = iso from to
66mIso :: Iso (M1 i c f p) (M1 i c g p) (f p) (g p)
39mIso :: Iso (M1 i c f p) (M1 i c g p) (f p) (g p)
67mIso = iso unM1 M1
40mIso = iso unM1 M1
68
41
69−kIso :: Iso (K1 r a p) (K1 r b p) a b
70−kIso = iso unK1 K1
71−
72−recIso :: Iso (Rec r a p) (Rec r b p) a b
73−recIso = iso (unK1 . unRec) (Rec . K1)
74−
75prodIso :: Iso ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
42prodIso :: Iso ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
76prodIso = iso (\(a :*: b) -> (a, b)) (\(a, b) -> (a :*: b))
43prodIso = iso (\(a :*: b) -> (a, b)) (\(a, b) -> (a :*: b))
77
44
src/Data/Generics/Internal/VL/Lens.hs+7−26
@@ -1,17 +1,17 @@
1−{-# OPTIONS_HADDOCK hide #-}
2{-# LANGUAGE GADTs #-}
1{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
4{-# LANGUAGE Rank2Types #-}
4{-# LANGUAGE Rank2Types #-}
5{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TupleSections #-}
6{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeFamilyDependencies #-}
8{-# LANGUAGE TypeFamilyDependencies #-}
8{-# LANGUAGE TypeOperators #-}
9{-# LANGUAGE TypeOperators #-}
9−{-# LANGUAGE TupleSections #-}
10
10
11-----------------------------------------------------------------------------
11-----------------------------------------------------------------------------
12-- |
12-- |
13-- Module : Data.Generics.Internal.VL.Lens
13-- Module : Data.Generics.Internal.VL.Lens
14−-- Copyright : (C) 2019 Csongor Kiss
14+-- Copyright : (C) 2017 Csongor Kiss
15-- License : BSD3
15-- License : BSD3
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17-- Stability : experimental
17-- Stability : experimental
@@ -23,9 +23,8 @@
23module Data.Generics.Internal.VL.Lens where
23module Data.Generics.Internal.VL.Lens where
24
24
25import Control.Applicative (Const(..))
25import Control.Applicative (Const(..))
26−import Data.Coerce (coerce)
27import Data.Functor.Identity (Identity(..))
26import Data.Functor.Identity (Identity(..))
28−import Data.Generics.Internal.Profunctor.Lens (ALens (..), idLens)
27+import Data.Generics.Internal.Profunctor.Lens (ALens (..), (^.), idLens)
29
28
30-- | Type alias for lens
29-- | Type alias for lens
31type Lens' s a
30type Lens' s a
@@ -37,34 +36,16 @@ type Lens s t a b
37view :: ((a -> Const a a) -> s -> Const a s) -> s -> a
36view :: ((a -> Const a a) -> s -> Const a s) -> s -> a
38view l s = (^.) s l
37view l s = (^.) s l
39
38
40−-- | Getting
41−(^.) :: s -> ((a -> Const a a) -> s -> Const a s) -> a
42−s ^. l = getConst (l Const s)
43−infixl 8 ^.
44−
45−infixr 4 .~
46−(.~) :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t
47−(.~) f b = runIdentity . f (Identity . const b)
48−
49set :: Lens s t a b -> b -> s -> t
39set :: Lens s t a b -> b -> s -> t
50−set l x = l .~ x
40+set l x = runIdentity . (l (Identity . const x))
51−
52−over :: ((a -> Identity b) -> s -> Identity t) -> (a -> b) -> s -> t
53−over = coerce
54
41
55lens2lensvl :: ALens a b s t -> Lens s t a b
42lens2lensvl :: ALens a b s t -> Lens s t a b
56−lens2lensvl (ALens _get _set) =
43+lens2lensvl (ALens _get _set) = lens _get _set
57− \f x ->
58− case _get x of
59− (c, a) -> _set . (c, ) <$> f a
60−{-# INLINE lens2lensvl #-}
61
44
62ravel :: (ALens a b a b -> ALens a b s t)
45ravel :: (ALens a b a b -> ALens a b s t)
63 -> Lens s t a b
46 -> Lens s t a b
64ravel l pab = (lens2lensvl $ l idLens) pab
47ravel l pab = (lens2lensvl $ l idLens) pab
65
48
66−
67lens :: (s -> a) -> ((s, b) -> t) -> Lens s t a b
49lens :: (s -> a) -> ((s, b) -> t) -> Lens s t a b
68−lens get _set = \f x -> curry _set x <$> f (get x)
50+lens get _set f x = curry _set x <$> f (get x)
69−{-# INLINE[0] lens #-}
70
51
src/Data/Generics/Internal/VL/Prism.hs+4−16
@@ -1,8 +1,9 @@
1−{-# OPTIONS_HADDOCK hide #-}
2{-# LANGUAGE GADTs #-}
1{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
4{-# LANGUAGE Rank2Types #-}
4{-# LANGUAGE Rank2Types #-}
5{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TupleSections #-}
6{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeFamilyDependencies #-}
8{-# LANGUAGE TypeFamilyDependencies #-}
8{-# LANGUAGE TypeOperators #-}
9{-# LANGUAGE TypeOperators #-}
@@ -10,7 +11,7 @@
10-----------------------------------------------------------------------------
11-----------------------------------------------------------------------------
11-- |
12-- |
12-- Module : Data.Generics.Internal.VL.Prism
13-- Module : Data.Generics.Internal.VL.Prism
13−-- Copyright : (C) 2019 Csongor Kiss
14+-- Copyright : (C) 2017 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
@@ -27,8 +28,6 @@ import Data.Coerce
27import Data.Generics.Internal.Profunctor.Prism (Market (..), plus, idPrism)
28import Data.Generics.Internal.Profunctor.Prism (Market (..), plus, idPrism)
28import Data.Tagged
29import Data.Tagged
29import Data.Profunctor.Unsafe ((#.), (.#))
30import Data.Profunctor.Unsafe ((#.), (.#))
30−import Data.Monoid (First (..))
31−import Control.Applicative (Const(..))
32
31
33-- | Type alias for prism
32-- | Type alias for prism
34type Prism s t a b
33type Prism s t a b
@@ -37,19 +36,8 @@ type Prism s t a b
37type Prism' s a
36type Prism' s a
38 = Prism s s a a
37 = Prism s s a a
39
38
40−infixl 8 ^?
41−(^?) :: s -> ((a -> Const (First a) a) -> s -> Const (First a) s) -> Maybe a
42−s ^? l = getFirst (fmof l (First #. Just) s)
43− where fmof l' f = getConst #. l' (Const #. f)
44−
45−
46match :: Prism s t a b -> s -> Either t a
39match :: Prism s t a b -> s -> Either t a
47match k = withPrism k $ \_ _match -> _match
40match k = withPrism k $ \_ _match -> _match
48−{-# INLINE match #-}
49−
50−(#) :: (Tagged b (Identity b) -> Tagged t (Identity t)) -> b -> t
51−(#) = build
52−{-# INLINE (#) #-}
53
41
54prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
42prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
55prism bt seta eta = dimap (\x -> plus pure id (seta x)) (either id (\x -> fmap bt x)) (right' eta)
43prism bt seta eta = dimap (\x -> plus pure id (seta x)) (either id (\x -> fmap bt x)) (right' eta)
@@ -71,4 +59,4 @@ prism2prismvl (Market bt seta) = prism bt seta
71
59
72build :: (Tagged b (Identity b) -> Tagged t (Identity t)) -> b -> t
60build :: (Tagged b (Identity b) -> Tagged t (Identity t)) -> b -> t
73build p = runIdentity #. unTagged #. p .# Tagged .# Identity
61build p = runIdentity #. unTagged #. p .# Tagged .# Identity
74−{-# INLINE build #-}
62+
src/Data/Generics/Internal/VL/Traversal.hs+10−28
@@ -1,10 +1,9 @@
1−{-# OPTIONS_HADDOCK hide #-}
2−{-# LANGUAGE AllowAmbiguousTypes #-}
3−{-# LANGUAGE ConstraintKinds #-}
4{-# LANGUAGE GADTs #-}
1{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE LambdaCase #-}
5{-# LANGUAGE NoMonomorphismRestriction #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
6{-# LANGUAGE Rank2Types #-}
4{-# LANGUAGE Rank2Types #-}
7{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TupleSections #-}
8{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE TypeFamilyDependencies #-}
8{-# LANGUAGE TypeFamilyDependencies #-}
10{-# LANGUAGE TypeOperators #-}
9{-# LANGUAGE TypeOperators #-}
@@ -12,7 +11,7 @@
12-----------------------------------------------------------------------------
11-----------------------------------------------------------------------------
13-- |
12-- |
14-- Module : Data.Generics.Internal.VL.Traversal
13-- Module : Data.Generics.Internal.VL.Traversal
15−-- Copyright : (C) 2019 Csongor Kiss
14+-- Copyright : (C) 2017 Csongor Kiss
16-- License : BSD3
15-- License : BSD3
17-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
18-- Stability : experimental
17-- Stability : experimental
@@ -23,41 +22,24 @@
23-----------------------------------------------------------------------------
22-----------------------------------------------------------------------------
24module Data.Generics.Internal.VL.Traversal where
23module Data.Generics.Internal.VL.Traversal where
25
24
26−import Data.Kind (Constraint)
27−
28-- | Type alias for traversal
25-- | Type alias for traversal
29type Traversal' s a
26type Traversal' s a
30 = forall f. Applicative f => (a -> f a) -> s -> f s
27 = forall f. Applicative f => (a -> f a) -> s -> f s
31
28
32−type TraversalC (c :: * -> * -> Constraint) s t
33− = forall f. Applicative f => (forall a b. c a b => a -> f b) -> s -> f t
34−
35−type TraversalC' (c :: * -> Constraint) s
36− = forall f. Applicative f => (forall a. c a => a -> f a) -> s -> f s
37−
38type Traversal s t a b
29type Traversal s t a b
39 = forall f. Applicative f => (a -> f b) -> s -> f t
30 = forall f. Applicative f => (a -> f b) -> s -> f t
40
31
41−type LensLikeC c f s
42− = (forall a. c a => a -> f a) -> s -> f s
43−
44confusing :: Applicative f => Traversal s t a b -> (a -> f b) -> s -> f t
32confusing :: Applicative f => Traversal s t a b -> (a -> f b) -> s -> f t
45confusing t = \f -> lowerYoneda . lowerCurried . t (liftCurriedYoneda . f)
33confusing t = \f -> lowerYoneda . lowerCurried . t (liftCurriedYoneda . f)
34+ where
35+ liftCurriedYoneda :: Applicative f => f a -> Curried (Yoneda f) a
36+ liftCurriedYoneda fa = Curried (`yap` fa)
37+ {-# INLINE liftCurriedYoneda #-}
38+ yap :: Applicative f => Yoneda f (a -> b) -> f a -> Yoneda f b
39+ yap (Yoneda k) fa = Yoneda (\ab_r -> k (ab_r .) <*> fa)
40+ {-# INLINE yap #-}
46{-# INLINE confusing #-}
41{-# INLINE confusing #-}
47
42
48−-- fuse constrained traversals
49−confusingC :: forall c f s. Applicative f => TraversalC' c s -> LensLikeC c f s
50−confusingC t = \f -> lowerYoneda . lowerCurried . t (liftCurriedYoneda . f)
51−{-# INLINE confusingC #-}
52−
53−liftCurriedYoneda :: Applicative f => f a -> Curried (Yoneda f) a
54−liftCurriedYoneda fa = Curried (`yap` fa)
55−{-# INLINE liftCurriedYoneda #-}
56−
57−yap :: Applicative f => Yoneda f (a -> b) -> f a -> Yoneda f b
58−yap (Yoneda k) fa = Yoneda (\ab_r -> k (ab_r .) <*> fa)
59−{-# INLINE yap #-}
60−
61newtype Curried f a =
43newtype Curried f a =
62 Curried { runCurried :: forall r. f (a -> r) -> f r }
44 Curried { runCurried :: forall r. f (a -> r) -> f r }
63
45
src/Data/Generics/Labels.hs+17−123
@@ -1,142 +1,36 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
1+{-# LANGUAGE CPP #-}
2−{-# LANGUAGE CPP #-}
3−{-# LANGUAGE ConstraintKinds #-}
4−{-# LANGUAGE DataKinds #-}
5−{-# LANGUAGE FlexibleInstances #-}
2+{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE FunctionalDependencies #-}
7−{-# LANGUAGE MultiParamTypeClasses #-}
3+{-# LANGUAGE MultiParamTypeClasses #-}
8−{-# LANGUAGE PolyKinds #-}
9−{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE TypeApplications #-}
5+{-# LANGUAGE TypeApplications #-}
11−{-# LANGUAGE TypeOperators #-}
6+{-# LANGUAGE TypeFamilies #-}
12−{-# LANGUAGE TypeFamilies #-}
13−{-# LANGUAGE UndecidableInstances #-}
7+{-# LANGUAGE UndecidableInstances #-}
14−{-# OPTIONS_GHC -Wno-orphans #-}
8+{-# OPTIONS_GHC -Wno-orphans #-}
9+
15
10
16--------------------------------------------------------------------------------
11--------------------------------------------------------------------------------
17-- |
12-- |
18-- Module : Data.Generics.Labels
13-- Module : Data.Generics.Labels
19−-- Copyright : (C) 2019 Csongor Kiss
14+-- Copyright : (C) 2017 Csongor Kiss
20−-- License : BSD3
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
15-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16+-- License : BSD3
22-- Stability : experimental
17-- Stability : experimental
23-- Portability : non-portable
18-- Portability : non-portable
24--
19--
25−-- Provides an (orphan) IsLabel instance for field lenses and constructor prisms.
20+-- Provides an (orphan) IsLabel instance for field lenses.
26-- Use at your own risk.
21-- Use at your own risk.
27--------------------------------------------------------------------------------
22--------------------------------------------------------------------------------
28
23
29−module Data.Generics.Labels
24+module Data.Generics.Labels () where
30− ( -- * Orphan IsLabel Instance
31− -- $sec1
32− Field(..)
33− , Field'
34− , Constructor(..)
35− , Constructor'
36− ) where
37
25
38import Data.Generics.Product
26import Data.Generics.Product
39−import Data.Generics.Sum
40−import Data.Generics.Internal.VL.Lens (Lens)
41−import Data.Generics.Internal.VL.Prism (Prism)
42−
43−import Data.Profunctor (Choice)
44−import Data.Type.Bool (type (&&))
45−import Data.Type.Equality (type (==))
46−
47import GHC.OverloadedLabels
27import GHC.OverloadedLabels
48−import GHC.TypeLits
49−
50−-- $sec1
51−-- An instance for creating lenses and prisms with @#identifiers@ from the
52−-- @OverloadedLabels@ extension. Note that since overloaded labels do not
53−-- support symbols starting with capital letters, all prisms (which come from
54−-- constructor names, which are capitalized) must be prefixed with an underscore
55−-- (e.g. @#_ConstructorName@).
56−--
57−-- Morally:
58−--
59−-- @
60−-- instance (HasField name s t a b) => IsLabel name (Lens s t a b) where ...
61−-- @
62−-- and
63−--
64−-- @
65−-- instance (AsConstructor name s t a b) => IsLabel name (Prism s t a b) where ...
66−-- @
67−--
68−-- Remember:
69−--
70−-- @
71−-- type Lens = forall f. Functor f => (a -> f b) -> s -> f t
72−--
73−-- type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)
74−-- @
75−--
76−-- The orphan instance is unavoidable if we want to work with
77−-- lenses-as-functions (as opposed to a 'ReifiedLens'-like newtype).
78−
79−-- | 'Field' is morally the same as 'HasField', but it is constructed from an
80−-- incoherent combination of 'HasField' and 'HasField''. In this way, it can be
81−-- seamlessly used in the 'IsLabel' instance even when dealing with data types
82−-- that don't have 'Field' instances (like data instances).
83−class Field name s t a b | s name -> a, t name -> b, s name b -> t, t name a -> s where
84− fieldLens :: Lens s t a b
85−
86−type Field' name s a = Field name s s a a
87−
88−instance {-# INCOHERENT #-} HasField name s t a b => Field name s t a b where
89− fieldLens = field @name
90−
91−instance {-# INCOHERENT #-} HasField' name s a => Field name s s a a where
92− fieldLens = field' @name
93−
94−-- | 'Constructor' is morally the same as 'AsConstructor', but it is constructed from an
95−-- incoherent combination of 'AsConstructor' and 'AsConstructor''. In this way, it can be
96−-- seamlessly used in the 'IsLabel' instance even when dealing with data types
97−-- that don't have 'Constructor' instances (like data instances).
98−class Constructor name s t a b | name s -> a, name t -> b where
99− constructorPrism :: Prism s t a b
100−
101−type Constructor' name s a = Constructor name s s a a
102−
103−instance {-# INCOHERENT #-} AsConstructor name s t a b => Constructor name s t a b where
104− constructorPrism = _Ctor @name
105−
106−instance {-# INCOHERENT #-} AsConstructor' name s a => Constructor name s s a a where
107− constructorPrism = _Ctor' @name
108−
109−type family BeginsWithCapital (name :: Symbol) :: Bool where
110− BeginsWithCapital name = CmpSymbol "_@" name == 'LT && CmpSymbol "_[" name == 'GT
111−
112−instance ( capital ~ BeginsWithCapital name
113− , IsLabelHelper capital name p f s t a b
114− , pafb ~ p a (f b), psft ~ p s (f t)) => IsLabel name (pafb -> psft) where
115−#if __GLASGOW_HASKELL__ >= 802
116− fromLabel = labelOutput @capital @name @p @f
117−#else
118− fromLabel _ = labelOutput @capital @name @p @f
119−#endif
120−
121−-- | This helper class allows us to customize the output type of the lens to be
122−-- either 'Prism' or 'Lens' (by choosing appropriate @p@ and @f@) as well as to
123−-- choose between whether we're dealing with a lens or a prism. The choice is
124−-- made by whether the @capital@ argument is true or false, which is determined by
125−-- whether the symbol starts with an underscore followed by a capital letter
126−-- (a check done in the 'IsLabel' instance above). If so, then we're dealing
127−-- with a constructor name, which should be a prism, and otherwise, it's a field
128−-- name, so we have a lens.
129−class IsLabelHelper capital name p f s t a b where
130− labelOutput :: p a (f b) -> p s (f t)
131
28
132−instance (Functor f, Field name s t a b) => IsLabelHelper 'False name (->) f s t a b where
133− labelOutput = fieldLens @name
134
29
30+instance (HasField field s t a b, Functor f, sft ~ (s -> f t)) =>
31+ IsLabel field ((a -> f b) -> sft) where
135#if __GLASGOW_HASKELL__ >= 802
32#if __GLASGOW_HASKELL__ >= 802
136−instance ( Applicative f, Choice p, Constructor name s t a b
33+ fromLabel = field @field
137− , name' ~ AppendSymbol "_" name) => IsLabelHelper 'True name' p f s t a b where
138− labelOutput = constructorPrism @name
139#else
34#else
140−instance (TypeError ('Text "Labels for Prisms require at least GHC 8.2"), Choice p) => IsLabelHelper 'True name' p f s t a b where
35+ fromLabel _ = field @field
141− labelOutput = undefined
142#endif
36#endif
src/Data/Generics/Product.hs+3−8
@@ -1,7 +1,7 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2-- |
2-- |
3-- Module : Data.Generics.Product
3-- Module : Data.Generics.Product
4−-- Copyright : (C) 2019 Csongor Kiss
4+-- Copyright : (C) 2017 Csongor Kiss
5-- License : BSD3
5-- License : BSD3
6-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
6-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
7-- Stability : experimental
7-- Stability : experimental
@@ -22,11 +22,8 @@ module Data.Generics.Product
22 , module Data.Generics.Product.Positions
22 , module Data.Generics.Product.Positions
23 , module Data.Generics.Product.Subtype
23 , module Data.Generics.Product.Subtype
24 , module Data.Generics.Product.Typed
24 , module Data.Generics.Product.Typed
25− , module Data.Generics.Product.HList
26− -- *Traversals
27 , module Data.Generics.Product.Types
25 , module Data.Generics.Product.Types
28− , module Data.Generics.Product.Param
26+ , module Data.Generics.Product.List
29− , module Data.Generics.Product.Constraints
30 ) where
27 ) where
31
28
32import Data.Generics.Product.Any
29import Data.Generics.Product.Any
@@ -35,6 +32,4 @@ import Data.Generics.Product.Positions
35import Data.Generics.Product.Subtype
32import Data.Generics.Product.Subtype
36import Data.Generics.Product.Typed
33import Data.Generics.Product.Typed
37import Data.Generics.Product.Types
34import Data.Generics.Product.Types
38−import Data.Generics.Product.Constraints
35+import Data.Generics.Product.List
39−import Data.Generics.Product.Param
40−import Data.Generics.Product.HList
src/Data/Generics/Product/Any.hs+3−3
@@ -12,7 +12,7 @@
12-----------------------------------------------------------------------------
12-----------------------------------------------------------------------------
13-- |
13-- |
14-- Module : Data.Generics.Product.Any
14-- Module : Data.Generics.Product.Any
15−-- Copyright : (C) 2019 Csongor Kiss
15+-- Copyright : (C) 2017 Csongor Kiss
16-- License : BSD3
16-- License : BSD3
17-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
18-- Stability : experimental
18-- Stability : experimental
@@ -41,7 +41,7 @@ import Data.Generics.Product.Typed
41-- >>> :set -XDataKinds
41-- >>> :set -XDataKinds
42-- >>> :set -XDeriveGeneric
42-- >>> :set -XDeriveGeneric
43-- >>> import GHC.Generics
43-- >>> import GHC.Generics
44−-- >>> :m +Data.Generics.Internal.VL.Lens
44+-- >>> :m +Data.Generics.Internal.Lens
45-- >>> :{
45-- >>> :{
46-- data Human = Human
46-- data Human = Human
47-- { name :: String
47-- { name :: String
@@ -53,7 +53,7 @@ import Data.Generics.Product.Typed
53-- human = Human "Tunyasz" 50 "London"
53-- human = Human "Tunyasz" 50 "London"
54-- :}
54-- :}
55
55
56−class HasAny sel s t a b | s sel -> a where
56+class HasAny (sel :: k) s t a b | s sel k -> a where
57 -- |A lens that focuses on a part of a product as identified by some
57 -- |A lens that focuses on a part of a product as identified by some
58 -- selector. Currently supported selectors are field names, positions and
58 -- selector. Currently supported selectors are field names, positions and
59 -- unique types. Compatible with the lens package's 'Control.Lens.Lens'
59 -- unique types. Compatible with the lens package's 'Control.Lens.Lens'
src/Data/Generics/Product/Constraints.hsdeleted−57
@@ -1,57 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE ConstraintKinds #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE KindSignatures #-}
5−{-# LANGUAGE MultiParamTypeClasses #-}
6−{-# LANGUAGE Rank2Types #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE TypeApplications #-}
9−{-# LANGUAGE UndecidableInstances #-}
10−
11−-----------------------------------------------------------------------------
12−-- |
13−-- Module : Data.Generics.Product.Constraints
14−-- Copyright : (C) 2019 Csongor Kiss
15−-- License : BSD3
16−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17−-- Stability : experimental
18−-- Portability : non-portable
19−--
20−-- Constrained traversals.
21−--
22−-----------------------------------------------------------------------------
23−
24−module Data.Generics.Product.Constraints
25− ( -- *Traversals
26− --
27− -- $example
28− HasConstraints (..)
29− , HasConstraints' (..)
30− ) where
31−
32−import Data.Generics.Product.Internal.Constraints
33−import Data.Kind (Constraint)
34−
35−import GHC.Generics (Generic (Rep), from, to)
36−import Data.Generics.Internal.VL.Traversal
37−
38−class HasConstraints' (c :: * -> Constraint) s where
39− constraints' :: TraversalC' c s
40−
41−instance
42− ( Generic s
43− , GHasConstraints' c (Rep s)
44− ) => HasConstraints' c s where
45− constraints' = confusingC @c (\f s -> to <$> gconstraints' @c f (from s))
46− {-# INLINE constraints' #-}
47−
48−class HasConstraints (c :: * -> * -> Constraint) s t where
49− constraints :: TraversalC c s t
50−
51−instance
52− ( Generic s
53− , Generic t
54− , GHasConstraints c (Rep s) (Rep t)
55− ) => HasConstraints c s t where
56− constraints f s = to <$> gconstraints @c f (from s)
57− {-# INLINE constraints #-}
src/Data/Generics/Product/Fields.hs+28−93
@@ -16,7 +16,7 @@
16-----------------------------------------------------------------------------
16-----------------------------------------------------------------------------
17-- |
17-- |
18-- Module : Data.Generics.Product.Fields
18-- Module : Data.Generics.Product.Fields
19−-- Copyright : (C) 2019 Csongor Kiss
19+-- Copyright : (C) 2017 Csongor Kiss
20-- License : BSD3
20-- License : BSD3
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
22-- Stability : experimental
22-- Stability : experimental
@@ -31,8 +31,7 @@ module Data.Generics.Product.Fields
31
31
32 -- $setup
32 -- $setup
33 HasField (..)
33 HasField (..)
34− , HasField' (..)
34+ , HasField'
35− , HasField_ (..)
36
35
37 , getField
36 , getField
38 , setField
37 , setField
@@ -41,13 +40,12 @@ module Data.Generics.Product.Fields
41import Data.Generics.Internal.Families
40import Data.Generics.Internal.Families
42import Data.Generics.Internal.VL.Lens as VL
41import Data.Generics.Internal.VL.Lens as VL
43import Data.Generics.Internal.Void
42import Data.Generics.Internal.Void
44−import Data.Generics.Product.Internal.GLens
43+import Data.Generics.Product.Internal.Keyed
45
44
46import Data.Kind (Constraint, Type)
45import Data.Kind (Constraint, Type)
47import GHC.Generics
46import GHC.Generics
48import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError)
47import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError)
49−import Data.Generics.Internal.Profunctor.Lens as P
48+import Data.Generics.Internal.Profunctor.Lens
50−import Data.Generics.Internal.Errors
51
49
52-- $setup
50-- $setup
53-- == /Running example:/
51-- == /Running example:/
@@ -58,7 +56,7 @@ import Data.Generics.Internal.Errors
58-- >>> :set -XGADTs
56-- >>> :set -XGADTs
59-- >>> :set -XFlexibleContexts
57-- >>> :set -XFlexibleContexts
60-- >>> import GHC.Generics
58-- >>> import GHC.Generics
61−-- >>> :m +Data.Generics.Internal.VL.Lens
59+-- >>> :m +Data.Generics.Internal.Lens
62-- >>> :m +Data.Function
60-- >>> :m +Data.Function
63-- >>> :{
61-- >>> :{
64-- data Human a
62-- data Human a
@@ -113,106 +111,46 @@ class HasField (field :: Symbol) s t a b | s field -> a, t field -> b, s field b
113 -- ...
111 -- ...
114 field :: VL.Lens s t a b
112 field :: VL.Lens s t a b
115
113
116−-- |Records that have a field with a given name.
114+type HasField' field s a = HasField field s s a a
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−
130−class HasField' (field :: Symbol) s a | s field -> a where
131− field' :: VL.Lens s s a a
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
115
140-- |
116-- |
141-- >>> getField @"age" human
117-- >>> getField @"age" human
142-- 50
118-- 50
143getField :: forall f a s. HasField' f s a => s -> a
119getField :: forall f a s. HasField' f s a => s -> a
144−getField = VL.view (field' @f)
120+getField = VL.view (field @f)
145
121
146-- |
122-- |
147-- >>> setField @"age" 60 human
123-- >>> setField @"age" 60 human
148-- Human {name = "Tunyasz", age = 60, address = "London", other = False}
124-- Human {name = "Tunyasz", age = 60, address = "London", other = False}
149setField :: forall f s a. HasField' f s a => a -> s -> s
125setField :: forall f s a. HasField' f s a => a -> s -> s
150−setField = VL.set (field' @f)
126+setField = VL.set (field @f)
151
127
152−instance
128+instance -- see Note [Changing type parameters]
153 ( Generic s
129 ( Generic s
154 , ErrorUnless field s (CollectField field (Rep s))
130 , ErrorUnless field s (CollectField field (Rep s))
155− , GLens' (HasTotalFieldPSym field) (Rep s) a
131+ , Generic t
156− , Defined (Rep s)
132+ -- see Note [CPP in instance constraints]
157− (NoGeneric s '[ 'Text "arising from a generic lens focusing on the "
158− ':<>: QuoteType field ':<>: 'Text " field of type " ':<>: QuoteType a
159− , 'Text "in " ':<>: QuoteType s])
160− (() :: Constraint)
161− ) => HasField' field s a where
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
166−
167−instance -- see Note [Changing type parameters]
168− ( HasTotalFieldP field (Rep s) ~~ 'Just a
169− , HasTotalFieldP field (Rep t) ~~ 'Just b
170− , HasTotalFieldP field (Rep (Indexed s)) ~~ 'Just a'
171− , HasTotalFieldP field (Rep (Indexed t)) ~~ 'Just b'
172− , t ~~ Infer s a' b
173− , s ~~ Infer t b' a
174− , HasField0 field s t a b
175− ) => HasField field s t a b where
176− field f s = field0 @field f s
177−
178−-- | See Note [Uncluttering type signatures]
179−#if __GLASGOW_HASKELL__ < 804
133+#if __GLASGOW_HASKELL__ < 802
180−-- >>> :t field
134+ , '(s', t') ~ '(Proxied s, Proxied t)
181−-- field
182−-- :: (HasField field s t a b, Functor f) => (a -> f b) -> s -> f t
183#else
135#else
184−-- >>> :t field
136+ , s' ~ Proxied s
185−-- field
137+ , t' ~ Proxied t
186−-- :: (Functor f, HasField field s t a b) => (a -> f b) -> s -> f t
187#endif
138#endif
188−instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where
139+ , Generic s'
189− field = undefined
140+ , Generic t'
190−
141+ , GHasKey' field (Rep s) a
191−instance
142+ , GHasKey' field (Rep s') a'
192− ( HasTotalFieldP field (Rep s) ~~ 'Just a
143+ , GHasKey' field (Rep t') b'
193− , HasTotalFieldP field (Rep t) ~~ 'Just b
144+ , GHasKey field (Rep s) (Rep t) a b
194− , UnifyHead s t
145+ , t ~ Infer s a' b
195− , UnifyHead t s
146+ , s ~ Infer t b' a
196− , HasField0 field s t a b
197− ) => HasField_ field s t a b where
147+ ) => HasField field s t a b where
198− field_ f s = field0 @field f s
199
148
200−instance {-# OVERLAPPING #-} HasField_ f (Void1 a) (Void1 b) a b where
149+ field f s = ravel (repLens . gkey @field) f s
201− field_ = undefined
202
150
203−instance
151+-- -- See Note [Uncluttering type signatures]
204− ( Generic s
152+instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where
205− , Generic t
153+ field = undefined
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
154
217type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Constraint where
155type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Constraint where
218 ErrorUnless field s ('TypeStat _ _ '[])
156 ErrorUnless field s ('TypeStat _ _ '[])
@@ -235,6 +173,3 @@ type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Cons
235
173
236 ErrorUnless _ _ ('TypeStat '[] '[] _)
174 ErrorUnless _ _ ('TypeStat '[] '[] _)
237 = ()
175 = ()
238−
239−data HasTotalFieldPSym :: Symbol -> (TyFun (Type -> Type) (Maybe Type))
240−type instance Eval (HasTotalFieldPSym sym) tt = HasTotalFieldP sym tt
src/Data/Generics/Product/HList.hsdeleted−46
@@ -1,46 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE FunctionalDependencies #-}
5−{-# LANGUAGE MonoLocalBinds #-}
6−{-# LANGUAGE ScopedTypeVariables #-}
7−{-# LANGUAGE TypeInType #-}
8−{-# LANGUAGE UndecidableInstances #-}
9−
10−-----------------------------------------------------------------------------
11−-- |
12−-- Module : Data.Generics.Product.HList
13−-- Copyright : (C) 2019 Csongor Kiss
14−-- License : BSD3
15−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16−-- Stability : experimental
17−-- Portability : non-portable
18−--
19−-- Derive an isomorphism between a product type and a flat HList.
20−--
21−-----------------------------------------------------------------------------
22−
23−module Data.Generics.Product.HList
24− ( IsList (..)
25− ) where
26−
27−import Data.Generics.Product.Internal.HList
28−import Data.Kind
29−import GHC.Generics
30−import Data.Generics.Internal.VL.Iso (Iso)
31−import Data.Generics.Internal.Profunctor.Iso (repIso, iso2isovl)
32−
33−class IsList
34− (f :: Type)
35− (g :: Type)
36− (as :: [Type])
37− (bs :: [Type]) | f -> as, g -> bs where
38− list :: Iso f g (HList as) (HList bs)
39−
40−instance
41− ( Generic f
42− , Generic g
43− , GIsList (Rep f) (Rep g) as bs
44− ) => IsList f g as bs where
45− list = iso2isovl (repIso . glist)
46− {-# INLINE list #-}
src/Data/Generics/Product/Internal/Constraints.hsdeleted−136
@@ -1,136 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE ConstraintKinds #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE FunctionalDependencies #-}
7−{-# LANGUAGE GADTs #-}
8−{-# LANGUAGE Rank2Types #-}
9−{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE TypeApplications #-}
11−{-# LANGUAGE TypeFamilyDependencies #-}
12−{-# LANGUAGE TypeOperators #-}
13−{-# LANGUAGE UndecidableInstances #-}
14−
15−-----------------------------------------------------------------------------
16−-- |
17−-- Module : Data.Generics.Product.Internal.Constraints
18−-- Copyright : (C) 2019 Csongor Kiss
19−-- License : BSD3
20−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21−-- Stability : experimental
22−-- Portability : non-portable
23−--
24−-- Derive constrained traversals
25−--
26−-----------------------------------------------------------------------------
27−
28−-- TODO: use type-changing variant
29−
30−module Data.Generics.Product.Internal.Constraints
31− (
32− GHasConstraints (..)
33− , GHasConstraints' (..)
34− ) where
35−
36−import Data.Kind (Type, Constraint)
37−import GHC.Generics
38−import Data.Generics.Internal.VL.Iso
39−import Data.Generics.Internal.VL.Traversal
40−import Data.Generics.Product.Internal.HList
41−
42−-- | Constrained traversal.
43−class GHasConstraints' (c :: * -> Constraint) (f :: * -> *) where
44− gconstraints' :: forall g x.
45− Applicative g => (forall a. c a => a -> g a) -> f x -> g (f x)
46−
47−instance
48− ( GHasConstraints' c l
49− , GHasConstraints' c r
50− ) => GHasConstraints' c (l :*: r) where
51− gconstraints' f (l :*: r)
52− = (:*:) <$> gconstraints' @c f l <*> gconstraints' @c f r
53−
54−instance
55− ( GHasConstraints' c l
56− , GHasConstraints' c r
57− ) => GHasConstraints' c (l :+: r) where
58− gconstraints' f (L1 l) = L1 <$> gconstraints' @c f l
59− gconstraints' f (R1 r) = R1 <$> gconstraints' @c f r
60−
61−instance c a => GHasConstraints' c (Rec0 a) where
62− gconstraints' = kIso
63−
64−instance GHasConstraints' c f
65− => GHasConstraints' c (M1 m meta f) where
66− gconstraints' f (M1 x) = M1 <$> gconstraints' @c f x
67−
68−instance GHasConstraints' c U1 where
69− gconstraints' _ _ = pure U1
70−
71−--------------------------------------------------------------------------------
72−
73−class GHasConstraints (c :: * -> * -> Constraint) s t where
74− gconstraints :: TraversalC c (s x) (t x)
75−
76−instance
77− ( GHasConstraints c l l'
78− , GHasConstraints c r r'
79− ) => GHasConstraints c (l :*: r) (l' :*: r') where
80− gconstraints f (l :*: r)
81− = (:*:) <$> gconstraints @c f l <*> gconstraints @c f r
82−
83−instance
84− ( GHasConstraints c l l'
85− , GHasConstraints c r r'
86− ) => GHasConstraints c (l :+: r) (l' :+: r') where
87− gconstraints f (L1 l) = L1 <$> gconstraints @c f l
88− gconstraints f (R1 r) = R1 <$> gconstraints @c f r
89−
90−instance GHasConstraints c s t
91− => GHasConstraints c (M1 i m s) (M1 i m t) where
92− gconstraints f (M1 x) = M1 <$> gconstraints @c f x
93−
94−instance GHasConstraints c U1 U1 where
95− gconstraints _ _ = pure U1
96−
97−instance GHasConstraints c V1 V1 where
98− gconstraints _ = pure
99−
100−instance c a b => GHasConstraints c (Rec0 a) (Rec0 b) where
101− gconstraints = kIso
102−
103−--------------------------------------------------------------------------------
104−
105−-- | Multi-traversal
106−--type GHasTypes rep as = GHasConstraints (Contains as) rep
107−
108−-- Try to use a function from the list, or default to 'pure' if not present
109−{-
110−gtypes
111− :: forall as x f g.
112− ( GHasTypes f as
113− , Applicative g
114− ) => HList (Functions as g) -> f x -> g (f x)
115−gtypes hl s = gconstraints @(Contains as) (pick hl) s
116−-}
117−
118−--------------------------------------------------------------------------------
119−
120−-- >>> :kind! Functions '[Int, Char, Bool] Maybe
121−-- '[Int -> Maybe Int, Char -> Maybe Char, Bool -> Maybe Bool]
122−type family Functions (ts :: [Type]) (g :: Type -> Type) = r | r -> ts where
123− Functions '[] _ = '[]
124− Functions (t ': ts) g = ((t -> g t) ': Functions ts g)
125−
126−class Contains as a where
127− pick :: Applicative g => HList (Functions as g) -> a -> g a
128−
129−instance {-# OVERLAPPING #-} Contains (a ': as) a where
130− pick (h :> _) = h
131−
132−instance Contains as a => Contains (b ': as) a where
133− pick (_ :> hs) = pick hs
134−
135−instance Contains '[] a where
136− pick _ = pure
src/Data/Generics/Product/Internal/GLens.hsdeleted−81
@@ -1,81 +0,0 @@
1−{-# LANGUAGE FlexibleContexts #-}
2−{-# LANGUAGE TypeInType #-}
3−{-# LANGUAGE AllowAmbiguousTypes #-}
4−{-# LANGUAGE ConstraintKinds #-}
5−{-# LANGUAGE DataKinds #-}
6−{-# LANGUAGE FlexibleInstances #-}
7−{-# LANGUAGE FunctionalDependencies #-}
8−{-# LANGUAGE KindSignatures #-}
9−{-# LANGUAGE MultiParamTypeClasses #-}
10−{-# LANGUAGE Rank2Types #-}
11−{-# LANGUAGE ScopedTypeVariables #-}
12−{-# LANGUAGE TypeApplications #-}
13−{-# LANGUAGE TypeFamilies #-}
14−{-# LANGUAGE TypeOperators #-}
15−{-# LANGUAGE UndecidableInstances #-}
16−
17−-----------------------------------------------------------------------------
18−-- |
19−-- Module : Data.Generics.Product.Internal.GLens
20−-- Copyright : (C) 2019 Csongor Kiss
21−-- License : BSD3
22−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
23−-- Stability : experimental
24−-- Portability : non-portable
25−--
26−-- Derive record field getters and setters generically.
27−--
28−-----------------------------------------------------------------------------
29−
30−module Data.Generics.Product.Internal.GLens
31− ( GLens (..)
32− , GLens'
33− , TyFun
34− , Eval
35− ) where
36−
37−import Data.Generics.Internal.Profunctor.Lens (Lens, choosing, first, second)
38−import Data.Generics.Internal.Profunctor.Iso (kIso, sumIso, mIso)
39−
40−import Data.Kind (Type)
41−import GHC.Generics
42−
43−type Pred = TyFun (Type -> Type) (Maybe Type)
44−
45−type TyFun a b = a -> b -> Type
46−type family Eval (f :: TyFun a b) (x :: a) :: b
47−
48−-- A generic lens that uses some predicate to determine which field to focus on
49−class GLens (pred :: Pred) (s :: Type -> Type) (t :: Type -> Type) a b | s pred -> a, t pred -> b where
50− glens :: Lens (s x) (t x) a b
51−
52−type GLens' pred s a = GLens pred s s a a
53−
54−instance GProductLens (Eval pred l) pred l r l' r' a b
55− => GLens pred (l :*: r) (l' :*: r') a b where
56−
57− glens = gproductLens @(Eval pred l) @pred
58− {-# INLINE glens #-}
59−
60−instance (GLens pred l l' a b, GLens pred r r' a b) => GLens pred (l :+: r) (l' :+: r') a b where
61− glens = sumIso . choosing (glens @pred) (glens @pred)
62− {-# INLINE glens #-}
63−
64−instance GLens pred (K1 r a) (K1 r b) a b where
65− glens = kIso
66− {-# INLINE glens #-}
67−
68−instance (GLens pred f g a b) => GLens pred (M1 m meta f) (M1 m meta g) a b where
69− glens = mIso . glens @pred
70− {-# INLINE glens #-}
71−
72−class GProductLens (left :: Maybe Type) (pred :: Pred) l r l' r' a b | pred l r -> a, pred l' r' -> b where
73− gproductLens :: Lens ((l :*: r) x) ((l' :*: r') x) a b
74−
75−instance GLens pred l l' a b => GProductLens ('Just x) pred l r l' r a b where
76− gproductLens = first . glens @pred
77− {-# INLINE gproductLens #-}
78−
79−instance GLens pred r r' a b => GProductLens 'Nothing pred l r l r' a b where
80− gproductLens = second . glens @pred
81− {-# INLINE gproductLens #-}
src/Data/Generics/Product/Internal/HList.hsdeleted−329
@@ -1,329 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE CPP #-}
3−{-# LANGUAGE ConstraintKinds #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE FunctionalDependencies #-}
6−{-# LANGUAGE GADTs #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE TupleSections #-}
9−{-# LANGUAGE TypeApplications #-}
10−{-# LANGUAGE TypeFamilies #-}
11−{-# LANGUAGE TypeInType #-}
12−{-# LANGUAGE TypeOperators #-}
13−{-# LANGUAGE UndecidableInstances #-}
14−
15−#if __GLASGOW_HASKELL__ == 802
16−{-# OPTIONS_GHC -fno-solve-constant-dicts #-}
17−#endif
18−
19−
20−-----------------------------------------------------------------------------
21−-- |
22−-- Module : Data.Generics.Product.Internal.HList
23−-- Copyright : (C) 2019 Csongor Kiss
24−-- License : BSD3
25−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
26−-- Stability : experimental
27−-- Portability : non-portable
28−--
29−-- Derive an isomorphism between a product type and a flat HList.
30−--
31−-----------------------------------------------------------------------------
32−
33−module Data.Generics.Product.Internal.HList
34− ( GIsList(..)
35− , IndexList (..)
36− , HList (..)
37− , type (++)
38− , Elem
39− , ListTuple (..)
40− , TupleToList
41− ) where
42−
43−#if __GLASGOW_HASKELL__ < 804
44−import Data.Semigroup
45−#endif
46−import GHC.TypeLits
47−
48−import Data.Kind (Type)
49−import GHC.Generics
50−import Data.Profunctor
51−import Data.Generics.Internal.Profunctor.Lens
52−import Data.Generics.Internal.Profunctor.Iso
53−
54−data HList (as :: [Type]) where
55− Nil :: HList '[]
56− (:>) :: a -> HList as -> HList (a ': as)
57−
58−infixr 5 :>
59−
60−type family ((as :: [k]) ++ (bs :: [k])) :: [k] where
61− '[] ++ bs = bs
62− (a ': as) ++ bs = a ': as ++ bs
63−
64−instance Semigroup (HList '[]) where
65− _ <> _ = Nil
66−
67−instance Monoid (HList '[]) where
68− mempty = Nil
69− mappend _ _ = Nil
70−
71−instance (Semigroup a, Semigroup (HList as)) => Semigroup (HList (a ': as)) where
72− (x :> xs) <> (y :> ys) = (x <> y) :> (xs <> ys)
73−
74−instance (Monoid a, Monoid (HList as)) => Monoid (HList (a ': as)) where
75− mempty = mempty :> mempty
76− mappend (x :> xs) (y :> ys) = mappend x y :> mappend xs ys
77−
78−class Elem (as :: [(k, Type)]) (key :: k) (i :: Nat) a | as key -> i a
79−instance {-# OVERLAPPING #-} pos ~ 0 => Elem (a ': xs) key pos a
80−instance (Elem xs key i a, pos ~ (i + 1)) => Elem (x ': xs) key pos a
81−
82−class GIsList
83− (f :: Type -> Type)
84− (g :: Type -> Type)
85− (as :: [Type])
86− (bs :: [Type]) | f -> as, g -> bs, bs f -> g, as g -> f where
87−
88− glist :: Iso (f x) (g x) (HList as) (HList bs)
89−
90− -- We define this reversed version, otherwise uses of `fromIso glist` are not
91− -- properly inlined by GHC 8.0.2.
92− -- This is not actually used.
93− glistR :: Iso (HList bs) (HList as) (g x) (f x)
94− glistR = fromIso glist
95−
96−instance
97− ( GIsList l l' as as'
98− , GIsList r r' bs bs'
99− , Appending as bs cs as' bs' cs'
100− , cs ~ (as ++ bs)
101− , cs' ~ (as' ++ bs')
102− ) => GIsList (l :*: r) (l' :*: r') cs cs' where
103−
104− glist = prodIso . pairing glist glist . appending
105− {-# INLINE glist #-}
106−
107−instance GIsList f g as bs => GIsList (M1 t meta f) (M1 t meta g) as bs where
108− glist = mIso . glist
109− {-# INLINE glist #-}
110−
111−instance GIsList (Rec0 a) (Rec0 b) '[a] '[b] where
112− glist = kIso . singleton
113− {-# INLINE glist #-}
114−
115−instance GIsList U1 U1 '[] '[] where
116− glist = iso (const Nil) (const U1)
117− {-# INLINE glist #-}
118−
119−--------------------------------------------------------------------------------
120−-- | as ++ bs === cs
121−class Appending as bs cs as' bs' cs'
122− | as bs cs cs' -> as' bs'
123− , as' bs' cs cs' -> as bs
124− , as bs -> cs
125− , as' bs' -> cs'
126− where
127− appending :: Iso (HList as, HList bs) (HList as', HList bs') (HList cs) (HList cs')
128−
129−-- | [] ++ bs === bs
130−instance Appending '[] bs bs '[] bs' bs' where
131− appending = iso snd (Nil,)
132−
133−-- | (a : as) ++ bs === (a : cs)
134−instance
135− Appending as bs cs as' bs' cs' -- as ++ bs == cs
136− => Appending (a ': as) bs (a ': cs) (a' ': as') bs' (a' ': cs') where
137− appending
138− = pairing (fromIso consing) id -- ((a, as), bs)
139− . assoc3 -- (a, (as, bs))
140− . pairing id appending -- (a, cs)
141− . consing -- (a : cs)
142−
143−singleton :: Iso a b (HList '[a]) (HList '[ b])
144−singleton = iso (:> Nil) (\(x :> _) -> x)
145−
146−consing :: Iso (a, HList as) (b, HList bs) (HList (a ': as)) (HList (b ': bs))
147−consing = iso (\(x, xs) -> x :> xs) (\(x :> xs) -> (x, xs))
148−
149−--------------------------------------------------------------------------------
150−class IndexList (i :: Nat) as bs a b | i as -> a, i bs -> b, i as b -> bs, i bs a -> as where
151− point :: Lens (HList as) (HList bs) a b
152−
153−instance {-# OVERLAPPING #-}
154− ( as ~ (a ': as')
155− , bs ~ (b ': as')
156− ) => IndexList 0 as bs a b where
157− point = lens (\(x :> xs) -> (xs, x)) (\(xs, x') -> x' :> xs)
158− {-# INLINE point #-}
159−
160−instance
161− ( IndexList (n - 1) as' bs' a b
162− , as ~ (x ': as')
163− , bs ~ (x ': bs')
164− ) => IndexList n as bs a b where
165− point = fromIso consing . alongside id (point @(n-1)) . second'
166− {-# INLINE point #-}
167−
168−--------------------------------------------------------------------------------
169−-- * Convert tuples to/from HLists
170−
171−class ListTuple (tuple :: Type) (as :: [Type]) | as -> tuple where
172− type ListToTuple as :: Type
173− tupled :: Iso' (HList as) tuple
174− tupled = iso listToTuple tupleToList
175−
176− tupleToList :: tuple -> HList as
177− listToTuple :: HList as -> tuple
178−
179−instance ListTuple () '[] where
180− type ListToTuple '[] = ()
181− tupleToList _ = Nil
182− listToTuple _ = ()
183−
184−instance ListTuple a '[a] where
185− type ListToTuple '[a] = a
186− tupleToList a
187− = a :> Nil
188− listToTuple (a :> Nil)
189− = a
190−
191−instance ListTuple (a, b) '[a, b] where
192− type ListToTuple '[a, b] = (a, b)
193− tupleToList (a, b)
194− = a :> b :> Nil
195− listToTuple (a :> b :> Nil)
196− = (a, b)
197−
198−instance ListTuple (a, b, c) '[a, b, c] where
199− type ListToTuple '[a, b, c] = (a, b, c)
200− tupleToList (a, b, c)
201− = a :> b :> c :> Nil
202− listToTuple (a :> b :> c :> Nil)
203− = (a, b, c)
204−
205−instance ListTuple (a, b, c, d) '[a, b, c, d] where
206− type ListToTuple '[a, b, c, d] = (a, b, c, d)
207− tupleToList (a, b, c, d)
208− = a :> b :> c :> d:> Nil
209− listToTuple (a :> b :> c :> d :> Nil)
210− = (a, b, c, d)
211−
212−instance ListTuple (a, b, c, d, e) '[a, b, c, d, e] where
213− type ListToTuple '[a, b, c, d, e] = (a, b, c, d, e)
214− tupleToList (a, b, c, d, e)
215− = a :> b :> c :> d:> e :> Nil
216− listToTuple (a :> b :> c :> d :> e :> Nil)
217− = (a, b, c, d, e)
218−
219−instance ListTuple (a, b, c, d, e, f) '[a, b, c, d, e, f] where
220− type ListToTuple '[a, b, c, d, e, f] = (a, b, c, d, e, f)
221− tupleToList (a, b, c, d, e, f)
222− = a :> b :> c :> d:> e :> f :> Nil
223− listToTuple (a :> b :> c :> d :> e :> f :> Nil)
224− = (a, b, c, d, e, f)
225−
226−instance ListTuple (a, b, c, d, e, f, g) '[a, b, c, d, e, f, g] where
227− type ListToTuple '[a, b, c, d, e, f, g] = (a, b, c, d, e, f, g)
228− tupleToList (a, b, c, d, e, f, g)
229− = a :> b :> c :> d:> e :> f :> g :> Nil
230− listToTuple (a :> b :> c :> d :> e :> f :> g :> Nil)
231− = (a, b, c, d, e, f, g)
232−
233−instance ListTuple (a, b, c, d, e, f, g, h) '[a, b, c, d, e, f, g, h] where
234− type ListToTuple '[a, b, c, d, e, f, g, h] = (a, b, c, d, e, f, g, h)
235− tupleToList (a, b, c, d, e, f, g, h)
236− = a :> b :> c :> d:> e :> f :> g :> h :> Nil
237− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> Nil)
238− = (a, b, c, d, e, f, g, h)
239−
240−instance ListTuple (a, b, c, d, e, f, g, h, j) '[a, b, c, d, e, f, g, h, j] where
241− type ListToTuple '[a, b, c, d, e, f, g, h, j] = (a, b, c, d, e, f, g, h, j)
242− tupleToList (a, b, c, d, e, f, g, h, j)
243− = a :> b :> c :> d:> e :> f :> g :> h :> j :> Nil
244− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> Nil)
245− = (a, b, c, d, e, f, g, h, j)
246−
247−instance ListTuple (a, b, c, d, e, f, g, h, j, k) '[a, b, c, d, e, f, g, h, j, k] where
248− type ListToTuple '[a, b, c, d, e, f, g, h, j, k] = (a, b, c, d, e, f, g, h, j, k)
249− tupleToList (a, b, c, d, e, f, g, h, j, k)
250− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> Nil
251− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> Nil)
252− = (a, b, c, d, e, f, g, h, j, k)
253−
254−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l) '[a, b, c, d, e, f, g, h, j, k, l] where
255− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l] = (a, b, c, d, e, f, g, h, j, k, l)
256− tupleToList (a, b, c, d, e, f, g, h, j, k, l)
257− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> Nil
258− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> Nil)
259− = (a, b, c, d, e, f, g, h, j, k, l)
260−
261−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m) '[a, b, c, d, e, f, g, h, j, k, l, m] where
262− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m] = (a, b, c, d, e, f, g, h, j, k, l, m)
263− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m)
264− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> Nil
265− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> Nil)
266− = (a, b, c, d, e, f, g, h, j, k, l, m)
267−
268−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n) '[a, b, c, d, e, f, g, h, j, k, l, m, n] where
269− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n] = (a, b, c, d, e, f, g, h, j, k, l, m, n)
270− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n)
271− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil
272− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil)
273− = (a, b, c, d, e, f, g, h, j, k, l, m, n)
274−
275−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o] where
276− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
277− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
278− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil
279− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil)
280− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
281−
282−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p] where
283− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
284− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
285− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil
286− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil)
287− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
288−
289−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q] where
290− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
291− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
292− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil
293− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil)
294− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
295−
296−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r] where
297− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
298− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
299− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil
300− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil)
301− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
302−
303−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s] where
304− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
305− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
306− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil
307− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil)
308− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
309−
310−type family TupleToList a where
311− TupleToList () = '[]
312− TupleToList (a, b) = '[a, b]
313− TupleToList (a, b, c) = '[a, b, c]
314− TupleToList (a, b, c, d) = '[a, b, c, d]
315− TupleToList (a, b, c, d, e) = '[a, b, c, d, e]
316− TupleToList (a, b, c, d, e, f) = '[a, b, c, d, e, f]
317− TupleToList (a, b, c, d, e, f, g) = '[a, b, c, d, e, f, g]
318− TupleToList (a, b, c, d, e, f, g, h) = '[a, b, c, d, e, f, g, h]
319− TupleToList (a, b, c, d, e, f, g, h, j) = '[a, b, c, d, e, f, g, h, j]
320− TupleToList (a, b, c, d, e, f, g, h, j, k) = '[a, b, c, d, e, f, g, h, j, k]
321− TupleToList (a, b, c, d, e, f, g, h, j, k, l) = '[a, b, c, d, e, f, g, h, j, k, l]
322− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m) = '[a, b, c, d, e, f, g, h, j, k, l, m]
323− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n) = '[a, b, c, d, e, f, g, h, j, k, l, m, n]
324− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o) = '[a, b, c, d, e, f, g, h, j, k, l, m, n, o]
325− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p) = '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p]
326− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q) = '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q]
327− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r) = '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r]
328− TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) = '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s]
329− TupleToList a = '[a]
src/Data/Generics/Product/Internal/Keyed.hsnew file+54
@@ -0,0 +1,54 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE GADTs #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE TupleSections #-}
8+{-# LANGUAGE TypeApplications #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeInType #-}
11+{-# LANGUAGE TypeOperators #-}
12+{-# LANGUAGE UndecidableInstances #-}
13+
14+--------------------------------------------------------------------------------
15+-- |
16+-- Module : Data.Generics.Product.Internal.Keyed
17+-- Copyright : (C) 2018 Csongor Kiss
18+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19+-- License : BSD3
20+-- Stability : experimental
21+-- Portability : non-portable
22+--
23+--------------------------------------------------------------------------------
24+
25+module Data.Generics.Product.Internal.Keyed
26+ ( GHasKey (..)
27+ , GHasKey'
28+ ) where
29+
30+import Data.Generics.Product.Internal.List
31+import Data.Kind
32+import GHC.Generics
33+import Data.Generics.Internal.Profunctor.Lens
34+import Data.Generics.Internal.Profunctor.Iso
35+
36+class GHasKey (key :: k) (s :: Type -> Type) (t :: Type -> Type) a b | s key -> a, t key -> b where
37+ gkey :: Lens (s x) (t x) a b
38+
39+type GHasKey' key s a = GHasKey key s s a a
40+
41+instance (GHasKey key l l' a b, GHasKey key r r' a b) => GHasKey key (l :+: r) (l' :+: r') a b where
42+ gkey = sumIso . choosing (gkey @key) (gkey @key)
43+
44+instance (GHasKey key f g a b) => GHasKey key (M1 D meta f) (M1 D meta g) a b where
45+ gkey = mLens . gkey @key
46+
47+instance
48+ ( Elem as key i a
49+ , Elem bs key i b
50+ , IndexList i as bs a b
51+ , GIsList k f g as bs
52+ ) => GHasKey (key :: k) (M1 C meta f) (M1 C meta g) a b where
53+ gkey = mIso . (glist @k) . point @i
54+
src/Data/Generics/Product/Internal/List.hsnew file+345
@@ -0,0 +1,345 @@
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+ , Permuting (..)
42+ , Appending (..)
43+ ) where
44+
45+import GHC.TypeLits
46+
47+import Data.Kind (Type)
48+import GHC.Generics
49+import Data.Profunctor
50+import Data.Generics.Internal.Profunctor.Lens
51+import Data.Generics.Internal.Profunctor.Iso
52+
53+data List (as :: [(m, Type)]) where
54+ Nil :: List '[]
55+ (:>) :: a -> List as -> List ('(s, a) ': as)
56+
57+infixr 5 :>
58+
59+type family ((as :: [k]) ++ (bs :: [k])) :: [k] where
60+ '[] ++ bs = bs
61+ (a ': as) ++ bs = a ': as ++ bs
62+
63+instance Monoid (List '[]) where
64+ mempty = Nil
65+ mappend _ _ = Nil
66+
67+instance (Monoid a, Monoid (List as)) => Monoid (List ('(k, a) ': as)) where
68+ mempty = mempty :> mempty
69+ mappend (x :> xs) (y :> ys) = mappend x y :> mappend xs ys
70+
71+class Elem (as :: [(k, Type)]) (key :: k) (i :: Nat) a | as key -> i a
72+instance {-# OVERLAPPING #-} pos ~ 0 => Elem ('(key, a) ': xs) key pos a
73+instance (Elem xs key i a, pos ~ (i + 1)) => Elem (x ': xs) key pos a
74+
75+class GIsList
76+ (m :: Type)
77+ (f :: Type -> Type)
78+ (g :: Type -> Type)
79+ (as :: [(m, Type)])
80+ (bs :: [(m, Type)]) | m f -> as, m g -> bs, bs f -> g, as g -> f where
81+
82+ glist :: Iso (f x) (g x) (List as) (List bs)
83+
84+ glistL :: Lens (f x) (g x) (List as) (List bs)
85+ glistL f = glist @m f
86+
87+ glistR :: Lens (List bs) (List as) (g x) (f x)
88+ glistR f = fromIso (glist @m) f
89+
90+instance
91+ ( GIsList m l l' as as'
92+ , GIsList m r r' bs bs'
93+ , Appending List as bs cs as' bs' cs'
94+ , cs ~ (as ++ bs)
95+ , cs' ~ (as' ++ bs')
96+ ) => GIsList m (l :*: r) (l' :*: r') cs cs' where
97+
98+ glist = prodIso . pairing (glist @m) (glist @m) . appending
99+
100+instance GIsList m f g as bs => GIsList m (M1 t meta f) (M1 t meta g) as bs where
101+ glist = mIso . glist @m
102+
103+instance {-# OVERLAPS #-}
104+ GIsList Symbol
105+ (S1 ('MetaSel ('Just field) u s i) (Rec0 a))
106+ (S1 ('MetaSel ('Just field) u s i) (Rec0 b))
107+ '[ '(field, a)] '[ '(field, b)] where
108+ glist = mIso . kIso . singleton
109+
110+instance GIsList Type (Rec0 a) (Rec0 a) '[ '(a, a)] '[ '(a, a)] where
111+ glist = kIso . singleton
112+
113+instance GIsList () (Rec0 a) (Rec0 b) '[ '( '(), a)] '[ '( '(), b)] where
114+ glist = kIso . singleton
115+
116+instance GIsList m U1 U1 '[] '[] where
117+ glist = iso (const Nil) (const U1)
118+
119+--------------------------------------------------------------------------------
120+-- as ++ bs == cs
121+-- as' + == cs'
122+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
123+ appending :: Iso (f as, f bs) (f as', f bs') (f cs) (f cs')
124+
125+instance Appending List '[] bs bs '[] bs' bs' where
126+ appending = iso snd (Nil,)
127+
128+instance Appending List as bs cs as' bs' cs'
129+ => Appending List ('(f, a) ': as) bs ('(f, a) ': cs) ('(f, a') ': as') bs' ('(f, a') ': cs') where
130+ appending = pairing (fromIso consing) id . assoc3 . pairing id appending . consing
131+
132+singleton :: Iso a b (List '[ '(field, a)]) (List '[ '(field, b)])
133+singleton = iso (:> Nil) (\(x :> _) -> x)
134+
135+consing :: Iso (a, List as) (b, List bs) (List ('(f, a) ': as)) (List ('(f, b) ': bs))
136+consing = iso (\(x, xs) -> x :> xs) (\(x :> xs) -> (x, xs))
137+
138+--------------------------------------------------------------------------------
139+
140+-- This ended up not being used now... still cool to have
141+flipping :: Iso' (List (a1 ': a2 ': as)) (List (a2 ': a1 ': as))
142+flipping = iso
143+ (\(a1 :> a2 :> as) -> a2 :> a1 :> as)
144+ (\(a2 :> a1 :> as) -> a1 :> a2 :> as)
145+
146+class Inserting f a as bs | bs a -> as where
147+ inserting :: Iso' (f (a ': as)) (f bs)
148+
149+instance Inserting f a as (a ': as) where
150+ inserting = id
151+
152+instance Inserting List a as bs => Inserting List a ('(fb, b) ': as) ('(fb, b) ': bs) where
153+ inserting = flipping . fromIso consing . pairing id (inserting @_ @a) . consing
154+
155+class Permuting f as bs where
156+ permuting :: Iso' (f as) (f bs)
157+
158+instance Permuting List '[] '[] where
159+ permuting = id
160+
161+instance (Permuting List as as', Inserting List '(fa, a) as' bs')
162+ => Permuting List ('(fa, a) ': as) bs' where
163+ permuting = fromIso consing . pairing id permuting . consing . (inserting @_ @'(fa, _))
164+
165+--------------------------------------------------------------------------------
166+class IndexList (i :: Nat) as bs a b | i as -> a, i bs -> b, i as b -> bs, i bs a -> as where
167+ point :: Lens (List as) (List bs) a b
168+
169+instance {-# OVERLAPPING #-}
170+ ( as ~ ('(f, a) ': as')
171+ , bs ~ ('(f, b) ': as')
172+ ) => IndexList 0 as bs a b where
173+ point = lens (\(x :> _) -> x) (\((_ :> xs), x') -> x' :> xs)
174+ {-# INLINE point #-}
175+
176+instance
177+ ( IndexList (n - 1) as' bs' a b
178+ , as ~ ('(f, x) ': as')
179+ , bs ~ ('(f, x) ': bs')
180+ ) => IndexList n as bs a b where
181+ point = fromIso consing . alongside id (point @(n-1)) . second'
182+ {-# INLINE point #-}
183+
184+--------------------------------------------------------------------------------
185+-- * Convert tuples to/from HLists
186+
187+class ListTuple (tuple :: Type) (as :: [(k, Type)]) | as -> tuple where
188+ type ListToTuple as :: Type
189+ tupled :: Iso' (List as) tuple
190+ tupled = iso listToTuple tupleToList
191+
192+ tupleToList :: tuple -> List as
193+ listToTuple :: List as -> tuple
194+
195+instance ListTuple () '[] where
196+ type ListToTuple '[] = ()
197+ tupleToList _ = Nil
198+ listToTuple _ = ()
199+
200+instance ListTuple a '[ '(fa, a)] where
201+ type ListToTuple '[ '(fa, a)] = a
202+ tupleToList a
203+ = a :> Nil
204+ listToTuple (a :> Nil)
205+ = a
206+
207+instance ListTuple (a, b) '[ '(fa, a), '(fb, b)] where
208+ type ListToTuple '[ '(fa, a), '(fb, b)] = (a, b)
209+ tupleToList (a, b)
210+ = a :> b :> Nil
211+ listToTuple (a :> b :> Nil)
212+ = (a, b)
213+
214+instance ListTuple (a, b, c) '[ '(fa, a), '(fb, b), '(fc, c)] where
215+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c)] = (a, b, c)
216+ tupleToList (a, b, c)
217+ = a :> b :> c :> Nil
218+ listToTuple (a :> b :> c :> Nil)
219+ = (a, b, c)
220+
221+instance ListTuple (a, b, c, d) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d)] where
222+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d)] = (a, b, c, d)
223+ tupleToList (a, b, c, d)
224+ = a :> b :> c :> d:> Nil
225+ listToTuple (a :> b :> c :> d :> Nil)
226+ = (a, b, c, d)
227+
228+instance ListTuple (a, b, c, d, e) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e)] where
229+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e)] = (a, b, c, d, e)
230+ tupleToList (a, b, c, d, e)
231+ = a :> b :> c :> d:> e :> Nil
232+ listToTuple (a :> b :> c :> d :> e :> Nil)
233+ = (a, b, c, d, e)
234+
235+instance ListTuple (a, b, c, d, e, f) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f)] where
236+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f)] = (a, b, c, d, e, f)
237+ tupleToList (a, b, c, d, e, f)
238+ = a :> b :> c :> d:> e :> f :> Nil
239+ listToTuple (a :> b :> c :> d :> e :> f :> Nil)
240+ = (a, b, c, d, e, f)
241+
242+instance ListTuple (a, b, c, d, e, f, g) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g)] where
243+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g)] = (a, b, c, d, e, f, g)
244+ tupleToList (a, b, c, d, e, f, g)
245+ = a :> b :> c :> d:> e :> f :> g :> Nil
246+ listToTuple (a :> b :> c :> d :> e :> f :> g :> Nil)
247+ = (a, b, c, d, e, f, g)
248+
249+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
250+ 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)
251+ tupleToList (a, b, c, d, e, f, g, h)
252+ = a :> b :> c :> d:> e :> f :> g :> h :> Nil
253+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> Nil)
254+ = (a, b, c, d, e, f, g, h)
255+
256+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
257+ 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)
258+ tupleToList (a, b, c, d, e, f, g, h, j)
259+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> Nil
260+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> Nil)
261+ = (a, b, c, d, e, f, g, h, j)
262+
263+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
264+ 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)
265+ tupleToList (a, b, c, d, e, f, g, h, j, k)
266+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> Nil
267+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> Nil)
268+ = (a, b, c, d, e, f, g, h, j, k)
269+
270+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
271+ 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)
272+ tupleToList (a, b, c, d, e, f, g, h, j, k, l)
273+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> Nil
274+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> Nil)
275+ = (a, b, c, d, e, f, g, h, j, k, l)
276+
277+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
278+ 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)
279+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m)
280+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> Nil
281+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> Nil)
282+ = (a, b, c, d, e, f, g, h, j, k, l, m)
283+
284+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
285+ 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)
286+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n)
287+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil
288+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil)
289+ = (a, b, c, d, e, f, g, h, j, k, l, m, n)
290+
291+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
292+ 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)
293+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
294+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil
295+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil)
296+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
297+
298+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
299+ 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)
300+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
301+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil
302+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil)
303+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
304+
305+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
306+ 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)
307+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
308+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil
309+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil)
310+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
311+
312+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
313+ 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)
314+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
315+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil
316+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil)
317+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
318+
319+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
320+ 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)
321+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
322+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil
323+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil)
324+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
325+
326+type family TupleToList a where
327+ TupleToList () = '[]
328+ TupleToList (a, b) = '[ '( '(), a), '( '(), b)]
329+ TupleToList (a, b, c) = '[ '( '(), a), '( '(), b), '( '(), c)]
330+ TupleToList (a, b, c, d) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d)]
331+ TupleToList (a, b, c, d, e) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e)]
332+ TupleToList (a, b, c, d, e, f) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f)]
333+ TupleToList (a, b, c, d, e, f, g) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g)]
334+ TupleToList (a, b, c, d, e, f, g, h) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h)]
335+ TupleToList (a, b, c, d, e, f, g, h, j) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j)]
336+ TupleToList (a, b, c, d, e, f, g, h, j, k) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k)]
337+ TupleToList (a, b, c, d, e, f, g, h, j, k, l) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l)]
338+ 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)]
339+ 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)]
340+ 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)]
341+ 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)]
342+ 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)]
343+ 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)]
344+ 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)]
345+ TupleToList a = '[ '( '(), a)]
src/Data/Generics/Product/Internal/Positions.hs+24−46
@@ -1,4 +1,3 @@
1−{-# LANGUAGE TypeInType #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
3{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ConstraintKinds #-}
4{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
@@ -17,7 +16,7 @@
17-----------------------------------------------------------------------------
16-----------------------------------------------------------------------------
18-- |
17-- |
19-- Module : Data.Generics.Product.Internal.Positions
18-- Module : Data.Generics.Product.Internal.Positions
20−-- Copyright : (C) 2019 Csongor Kiss
19+-- Copyright : (C) 2017 Csongor Kiss
21-- License : BSD3
20-- License : BSD3
22-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
23-- Stability : experimental
22-- Stability : experimental
@@ -28,61 +27,38 @@
28-----------------------------------------------------------------------------
27-----------------------------------------------------------------------------
29
28
30module Data.Generics.Product.Internal.Positions
29module Data.Generics.Product.Internal.Positions
30+ ( GHasPosition (..)
31+ , GHasPosition'
31− ( type (<?)
32+ , type (<?)
32 , Size
33 , Size
33− , CRep
34 ) where
34 ) where
35
35
36−import Data.Generics.Internal.Families.Has (Pos)
36+import Data.Generics.Product.Internal.List
37import Data.Kind (Type)
37import Data.Kind (Type)
38import Data.Type.Bool (If, Not)
38import Data.Type.Bool (If, Not)
39import GHC.Generics
39import GHC.Generics
40−import GHC.TypeLits (type (<=?), type (+), Nat)
40+import GHC.TypeLits (type (<=?), type (+), type (-), Nat)
41+import Data.Generics.Internal.Profunctor.Lens
42+import Data.Generics.Internal.Profunctor.Iso
41
43
42−-- | Alias for the kind of the generic rep
44+-- |As 'HasPosition' but over generic representations as defined by
43−type G = Type -> Type
45+-- "GHC.Generics".
46+class GHasPosition (i :: Nat) (s :: Type -> Type) (t :: Type -> Type) a b | s i -> a, t i -> b, s t i -> b where
47+ gposition :: Lens (s x) (t x) a b
44
48
45−--------------------------------------------------------------------------------
49+type GHasPosition' i s a = GHasPosition i s s a a
46
50
47−-- | In-order labeling of the generic tree with the field positions
51+instance (GHasPosition i l l' a b, GHasPosition i r r' a b) => GHasPosition i (l :+: r) (l' :+: r') a b where
48−--
52+ gposition = sumIso . choosing (gposition @i) (gposition @i)
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)
55
53
56−-- | The actual traversal.
54+instance GHasPosition i s t a b => GHasPosition i (M1 D meta s) (M1 D meta t) a b where
57−--
55+ gposition = mLens . gposition @i
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)
72
56
73−type family Traverse1 (w :: G -> G) (z :: (G, Nat)) :: (G, Nat) where
57+instance
74− Traverse1 w '(i, n) = '(w i, n)
58+ ( IndexList (i - 1) as bs a b
75−
59+ , GIsList () f g as bs
76−-- | For products, we first traverse the left-hand side, followed by the second
60+ ) => GHasPosition i (M1 C meta f) (M1 C meta g) a b where
77−-- using the counter returned by the left traversal.
61+ gposition = mIso . (glist @()) . point @(i - 1)
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
86
62
87type family Size f :: Nat where
63type family Size f :: Nat where
88 Size (l :*: r)
64 Size (l :*: r)
@@ -96,6 +72,8 @@ type family Size f :: Nat where
96 Size f
72 Size f
97 = 1
73 = 1
98
74
75+--------------------------------------------------------------------------------
76+
99type x <? y = Not (y <=? x)
77type x <? y = Not (y <=? x)
100infixl 4 <?
78infixl 4 <?
101
79
src/Data/Generics/Product/Internal/Subtype.hs+10−15
@@ -1,4 +1,3 @@
1−{-# LANGUAGE TypeInType #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
3{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
@@ -16,7 +15,7 @@
16-----------------------------------------------------------------------------
15-----------------------------------------------------------------------------
17-- |
16-- |
18-- Module : Data.Generics.Product.Internal.Subtype
17-- Module : Data.Generics.Product.Internal.Subtype
19−-- Copyright : (C) 2019 Csongor Kiss
18+-- Copyright : (C) 2017 Csongor Kiss
20-- License : BSD3
19-- License : BSD3
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
22-- Stability : experimental
21-- Stability : experimental
@@ -32,12 +31,11 @@ module Data.Generics.Product.Internal.Subtype
32 ) where
31 ) where
33
32
34import Data.Generics.Internal.Families
33import Data.Generics.Internal.Families
35−import Data.Generics.Product.Internal.GLens
34+import Data.Generics.Product.Internal.Keyed
36
35
37import Data.Kind (Type)
36import Data.Kind (Type)
38import GHC.Generics
37import GHC.Generics
39−import GHC.TypeLits (Symbol)
40−import Data.Generics.Internal.Profunctor.Lens (view)
38+import Data.Generics.Internal.Profunctor.Lens
41
39
42--------------------------------------------------------------------------------
40--------------------------------------------------------------------------------
43-- * Generic upcasting
41-- * Generic upcasting
@@ -49,10 +47,10 @@ instance (GUpcast sub a, GUpcast sub b) => GUpcast sub (a :*: b) where
49 gupcast rep = gupcast rep :*: gupcast rep
47 gupcast rep = gupcast rep :*: gupcast rep
50
48
51instance
49instance
52− GLens' (HasTotalFieldPSym field) sub t
50+ GHasKey field sub sub t t
53 => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
51 => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
54
52
55− gupcast r = M1 (K1 (view (glens @(HasTotalFieldPSym field)) r))
53+ gupcast r = M1 (K1 (view (gkey @field) r))
56
54
57instance GUpcast sub sup => GUpcast sub (C1 c sup) where
55instance GUpcast sub sup => GUpcast sub (C1 c sup) where
58 gupcast = M1 . gupcast
56 gupcast = M1 . gupcast
@@ -82,16 +80,13 @@ instance GSmash sub sup => GSmash (C1 c sub) sup where
82instance GSmash sub sup => GSmash (D1 c sub) sup where
80instance GSmash sub sup => GSmash (D1 c sub) sup where
83 gsmash sup (M1 sub) = M1 (gsmash sup sub)
81 gsmash sup (M1 sub) = M1 (gsmash sup sub)
84
82
85−class GSmashLeaf sub sup (w :: Maybe Type) where
83+class GSmashLeaf sub sup (w :: Bool) where
86 gsmashLeaf :: sup p -> sub p -> sub p
84 gsmashLeaf :: sup p -> sub p -> sub p
87
85
88instance
86instance
89− GLens' (HasTotalFieldPSym field) sup t
87+ GHasKey field sup sup t t
90− => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup ('Just t) where
88+ => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'True where
91− gsmashLeaf sup _ = M1 (K1 (view (glens @(HasTotalFieldPSym field)) sup))
89+ gsmashLeaf sup _ = M1 (K1 (view (gkey @field) sup))
92
90
93−instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'Nothing where
91+instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'False where
94 gsmashLeaf _ = id
92 gsmashLeaf _ = id
95−
96−data HasTotalFieldPSym :: Symbol -> (TyFun (Type -> Type) (Maybe Type))
97−type instance Eval (HasTotalFieldPSym sym) tt = HasTotalFieldP sym tt
src/Data/Generics/Product/Internal/Types.hsnew file+56
@@ -0,0 +1,56 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE KindSignatures #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeApplications #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeOperators #-}
11+{-# LANGUAGE UndecidableInstances #-}
12+
13+-----------------------------------------------------------------------------
14+-- |
15+-- Module : Data.Generics.Product.Internal.Types
16+-- Copyright : (C) 2017 Csongor Kiss
17+-- License : BSD3
18+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19+-- Stability : experimental
20+-- Portability : non-portable
21+--
22+-- Derive traversals of a given type in a product.
23+--
24+-----------------------------------------------------------------------------
25+
26+module Data.Generics.Product.Internal.Types
27+ ( GHasTypes (..)
28+ ) where
29+
30+import Data.Kind (Type)
31+import GHC.Generics
32+
33+-- |As 'HasTypes' but over generic representations as defined by
34+-- "GHC.Generics".
35+class GHasTypes (f :: Type -> Type) a where
36+ gtypes :: forall g . Applicative g => (a -> g a) -> f a -> g (f a)
37+
38+instance (GHasTypes l a, GHasTypes r a) => GHasTypes (l :*: r) a where
39+ gtypes f (l :*: r) = (:*:) <$> gtypes f l <*> gtypes f r
40+ {-# INLINE gtypes #-}
41+
42+-- TODO:
43+-- instance (GHasTypes l a, GHasTypes r a) => GHasTypes (l :+: r) a where
44+
45+instance GHasTypes (K1 R a) a where
46+ gtypes f (K1 x) = fmap K1 (f x)
47+ {-# INLINE gtypes #-}
48+
49+
50+instance {-# OVERLAPS #-} GHasTypes (K1 R a) b where
51+ gtypes _ k = pure k
52+ {-# INLINE gtypes #-}
53+
54+instance GHasTypes f a => GHasTypes (M1 m meta f) a where
55+ gtypes f (M1 x) = M1 <$> gtypes f x
56+ {-# INLINE gtypes #-}
src/Data/Generics/Product/List.hsnew file+77
@@ -0,0 +1,77 @@
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+
51+class IsList Symbol f g as bs => IsRecord f g (as :: [(Symbol, Type)]) (bs :: [(Symbol, Type)]) | f -> as, g -> bs
52+instance IsList Symbol f g as bs => IsRecord f g as bs
53+
54+class IsRecord f f as as => IsRecord' f (as :: [(Symbol, Type)]) | f -> as
55+instance IsRecord f f as as => IsRecord' f as
56+
57+-- example (TODO: move elsewhere)
58+--class PrintRecord (rl :: [(Symbol, Type)]) where
59+-- printRecord' :: List rl -> String
60+--
61+--instance PrintRecord '[] where
62+-- printRecord' _ = ""
63+--
64+--instance (KnownSymbol field, Show a, PrintRecord xs) => PrintRecord ('(field, a) ': xs) where
65+-- printRecord' (x :> xs) = show x ++ ", " ++ printRecord' xs
66+--
67+--printRecord :: (IsRecord' rec rl, PrintRecord rl) => rec -> String
68+--printRecord rec = printRecord' (rec ^. list)
69+--
70+--data MyRecord = MyRecord
71+-- { field1 :: Int
72+-- , field2 :: String
73+-- , field3 :: Bool
74+-- } deriving Generic
75+--
76+-- >>> printRecord (MyRecord 10 "hello" False)
77+-- "10, \"hello\", False, "
src/Data/Generics/Product/Param.hsdeleted−121
@@ -1,121 +0,0 @@
1−{-# LANGUAGE PolyKinds #-}
2−{-# LANGUAGE TypeFamilies #-}
3−{-# LANGUAGE AllowAmbiguousTypes #-}
4−{-# LANGUAGE DataKinds #-}
5−{-# LANGUAGE FlexibleContexts #-}
6−{-# LANGUAGE FlexibleInstances #-}
7−{-# LANGUAGE FunctionalDependencies #-}
8−{-# LANGUAGE GADTs #-}
9−{-# LANGUAGE KindSignatures #-}
10−{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE TypeApplications #-}
12−{-# LANGUAGE TypeOperators #-}
13−{-# LANGUAGE UndecidableInstances #-}
14−
15−--------------------------------------------------------------------------------
16−-- |
17−-- Module : Data.Generics.Product.Param
18−-- Copyright : (C) 2019 Csongor Kiss
19−-- License : BSD3
20−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21−-- Stability : experimental
22−-- Portability : non-portable
23−--
24−-- Derive traversals over type parameters
25−--
26−--------------------------------------------------------------------------------
27−
28−module Data.Generics.Product.Param
29− ( Rec (Rec) -- TODO: this has to be re-exported so the constructor is visible for Coercible... is there a better way?
30− , HasParam (..)
31− ) where
32−
33−import GHC.TypeLits
34−import Data.Generics.Internal.Void
35−import Data.Generics.Internal.Families.Changing
36−import Data.Generics.Internal.VL.Traversal
37−
38−import GHC.Generics
39−import Data.Kind
40−import Data.Generics.Internal.VL.Iso
41−import Data.Generics.Internal.GenericN
42−import Data.Generics.Internal.Errors
43−
44−class HasParam (p :: Nat) s t a b | p t a -> s, p s b -> t, p s -> a, p t -> b where
45− param :: Applicative g => (a -> g b) -> s -> g t
46−
47−instance
48− ( GenericN s
49− , GenericN t
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)
57− , s ~ Infer t (P n b 'PTag) a
58− , t ~ Infer s (P n a 'PTag) b
59− , Error ((ArgCount s) <=? n) n (ArgCount s) s
60− , a ~ ArgAt s n
61− , b ~ ArgAt t n
62− , GHasParam n (RepN s) (RepN t) a b
63− ) => HasParam n s t a b where
64−
65− param = confusing (\f s -> toN <$> gparam @n f (fromN s))
66− {-# INLINE param #-}
67−
68−type family Error (b :: Bool) (expected :: Nat) (actual :: Nat) (s :: Type) :: Constraint where
69− Error 'False _ _ _
70− = ()
71−
72− Error 'True expected actual typ
73− = TypeError
74− ( 'Text "Expected a type with at least "
75− ':<>: 'ShowType (expected + 1)
76− ':<>: 'Text " parameters, but "
77− ':$$: 'ShowType typ
78− ':<>: 'Text " only has "
79− ':<>: 'ShowType actual
80− )
81−
82−-- TODO [1.0.0.0]: none of this is needed.
83−
84−instance {-# OVERLAPPING #-} HasParam p (Void1 a) (Void1 b) a b where
85− param = undefined
86−
87−class GHasParam (p :: Nat) s t a b where
88− gparam :: forall g (x :: Type). Applicative g => (a -> g b) -> s x -> g (t x)
89−
90−instance (GHasParam p l l' a b, GHasParam p r r' a b) => GHasParam p (l :*: r) (l' :*: r') a b where
91− gparam f (l :*: r) = (:*:) <$> gparam @p f l <*> gparam @p f r
92−
93−instance (GHasParam p l l' a b, GHasParam p r r' a b) => GHasParam p (l :+: r) (l' :+: r') a b where
94− gparam f (L1 l) = L1 <$> gparam @p f l
95− gparam f (R1 r) = R1 <$> gparam @p f r
96−
97−instance GHasParam p U1 U1 a b where
98− gparam _ _ = pure U1
99−
100−instance GHasParam p s t a b => GHasParam p (M1 m meta s) (M1 m meta t) a b where
101− gparam f (M1 x) = M1 <$> gparam @p f x
102−
103−-- the parameter we're looking for
104−instance GHasParam p (Rec (param p) a) (Rec (param p) b) a b where
105− gparam = recIso
106−
107−-- other recursion
108−instance {-# OVERLAPPABLE #-}
109− ( GHasParamRec (LookupParam si p) s t a b
110− -- TODO: reindex `ti`
111− ) => GHasParam p (Rec si s) (Rec ti t) a b where
112− gparam f (Rec (K1 x)) = Rec . K1 <$> gparamRec @(LookupParam si p) f x
113−
114−class GHasParamRec (param :: Maybe Nat) s t a b | param t a b -> s, param s a b -> t where
115− gparamRec :: forall g. Applicative g => (a -> g b) -> s -> g t
116−
117−instance GHasParamRec 'Nothing a a c d where
118− gparamRec _ = pure
119−
120−instance (HasParam n s t a b) => GHasParamRec ('Just n) s t a b where
121− gparamRec = param @n
src/Data/Generics/Product/Positions.hs+27−122
@@ -1,5 +1,3 @@
1−{-# LANGUAGE TypeInType #-}
2−{-# LANGUAGE PartialTypeSignatures #-}
3{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
4{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
5{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE ConstraintKinds #-}
@@ -19,7 +17,7 @@
19-----------------------------------------------------------------------------
17-----------------------------------------------------------------------------
20-- |
18-- |
21-- Module : Data.Generics.Product.Positions
19-- Module : Data.Generics.Product.Positions
22−-- Copyright : (C) 2019 Csongor Kiss
20+-- Copyright : (C) 2017 Csongor Kiss
23-- License : BSD3
21-- License : BSD3
24-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
22-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
25-- Stability : experimental
23-- Stability : experimental
@@ -34,9 +32,7 @@ module Data.Generics.Product.Positions
34
32
35 -- $setup
33 -- $setup
36 HasPosition (..)
34 HasPosition (..)
37− , HasPosition' (..)
35+ , HasPosition'
38− , HasPosition_ (..)
39− , HasPosition0 (..)
40
36
41 , getPosition
37 , getPosition
42 , setPosition
38 , setPosition
@@ -46,15 +42,12 @@ import Data.Generics.Internal.VL.Lens as VL
46import Data.Generics.Internal.Void
42import Data.Generics.Internal.Void
47import Data.Generics.Internal.Families
43import Data.Generics.Internal.Families
48import Data.Generics.Product.Internal.Positions
44import Data.Generics.Product.Internal.Positions
49−import Data.Generics.Product.Internal.GLens
50−import Data.Generics.Internal.Errors
51
45
52import Data.Kind (Constraint, Type)
46import Data.Kind (Constraint, Type)
53import Data.Type.Bool (type (&&))
47import Data.Type.Bool (type (&&))
54import GHC.Generics
48import GHC.Generics
55import GHC.TypeLits (type (<=?), Nat, TypeError, ErrorMessage(..))
49import GHC.TypeLits (type (<=?), Nat, TypeError, ErrorMessage(..))
56−import Data.Generics.Internal.Profunctor.Lens as P
50+import Data.Generics.Internal.Profunctor.Lens
57−import Data.Coerce
58
51
59-- $setup
52-- $setup
60-- == /Running example:/
53-- == /Running example:/
@@ -65,7 +58,7 @@ import Data.Coerce
65-- >>> :set -XGADTs
58-- >>> :set -XGADTs
66-- >>> :set -XFlexibleContexts
59-- >>> :set -XFlexibleContexts
67-- >>> import GHC.Generics
60-- >>> import GHC.Generics
68−-- >>> :m +Data.Generics.Internal.VL.Lens
61+-- >>> :m +Data.Generics.Internal.Lens
69-- >>> :m +Data.Function
62-- >>> :m +Data.Function
70-- >>> :{
63-- >>> :{
71-- data Human = Human
64-- data Human = Human
@@ -96,125 +89,40 @@ class HasPosition (i :: Nat) s t a b | s i -> a, t i -> b, s i b -> t, t i a ->
96 -- ...
89 -- ...
97 position :: VL.Lens s t a b
90 position :: VL.Lens s t a b
98
91
99−class HasPosition_ (i :: Nat) s t a b where
92+type HasPosition' i s a = HasPosition i s s a a
100− position_ :: VL.Lens s t a b
101
93
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_'.
108−class HasPosition' (i :: Nat) s a | s i -> a where
109− position' :: VL.Lens s s a a
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
121getPosition :: forall i s a. HasPosition' i s a => s -> a
94getPosition :: forall i s a. HasPosition' i s a => s -> a
122−getPosition s = s ^. position' @i
95+getPosition s = s ^. position @i
123
96
124−-- |
125−-- >>> setPosition @2 60 human
126−-- Human {name = "Tunyasz", age = 60, address = "London"}
127setPosition :: forall i s a. HasPosition' i s a => a -> s -> s
97setPosition :: forall i s a. HasPosition' i s a => a -> s -> s
128−setPosition = VL.set (position' @i)
98+setPosition = VL.set (position @i)
129
99
130−instance
100+instance -- see Note [Changing type parameters]
131 ( Generic s
101 ( Generic s
132 , ErrorUnless i s (0 <? i && i <=? Size (Rep s))
102 , ErrorUnless i s (0 <? i && i <=? Size (Rep s))
133− , cs ~ CRep s
103+ , Generic t
134− , Coercible (Rep s) cs
135− , GLens' (HasTotalPositionPSym i) cs a
136− , Defined (Rep s)
137− (NoGeneric s '[ 'Text "arising from a generic lens focusing on the field at"
138− , 'Text "position " ':<>: QuoteType i ':<>: 'Text " of type " ':<>: QuoteType a
139− ':<>: 'Text " in " ':<>: QuoteType s
140− ])
141− (() :: Constraint)
142− ) => HasPosition' i s a where
143− position' f s = VL.ravel (repLens . coerced @cs @cs . glens @(HasTotalPositionPSym i)) f s
144− {-# INLINE position' #-}
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−
151−instance -- see Note [Changing type parameters]
152− ( ErrorUnless i s (0 <? i && i <=? Size (Rep s))
153− , HasTotalPositionP i (CRep s) ~~ 'Just a
154− , HasTotalPositionP i (CRep t) ~~ 'Just b
155− , HasTotalPositionP i (CRep (Indexed s)) ~~ 'Just a'
156− , HasTotalPositionP i (CRep (Indexed t)) ~~ 'Just b'
157− , t ~~ Infer s a' b
158− , s ~~ Infer t b' a
159− , Coercible (CRep s) (Rep s)
160− , Coercible (CRep t) (Rep t)
161− , HasPosition0 i s t a b
162− ) => HasPosition i s t a b where
163−
164− position = position0 @i
165− {-# INLINE position #-}
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
104+ -- see Note [CPP in instance constraints]
170−coerced :: forall s t s' t' x a b. (Coercible t t', Coercible s s')
171− => P.ALens a b (s x) (t x) -> P.ALens a b (s' x) (t' x)
172−coerced = coerce
173−{-# INLINE coerced #-}
174−
175−-- | See Note [Uncluttering type signatures]
176−#if __GLASGOW_HASKELL__ < 804
105+#if __GLASGOW_HASKELL__ < 802
177−-- >>> :t position
106+ , '(s', t') ~ '(Proxied s, Proxied t)
178−-- position
179−-- :: (HasPosition i s t a b, Functor f) => (a -> f b) -> s -> f t
180#else
107#else
181−-- >>> :t position
108+ , s' ~ Proxied s
182−-- position
109+ , t' ~ Proxied t
183−-- :: (Functor f, HasPosition i s t a b) => (a -> f b) -> s -> f t
184#endif
110#endif
185−instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where
111+ , Generic s'
186− position = undefined
112+ , Generic t'
187−
113+ , GHasPosition' i (Rep s) a
188−instance
114+ , GHasPosition' i (Rep s') a'
189− ( ErrorUnless i s (0 <? i && i <=? Size (Rep s))
115+ , GHasPosition i (Rep s) (Rep t) a b
190− , UnifyHead s t
116+ , t ~ Infer s a' b
191− , UnifyHead t s
117+ , GHasPosition' i (Rep t') b'
192− , Coercible (CRep s) (Rep s)
118+ , s ~ Infer t b' a
193− , Coercible (CRep t) (Rep t)
119+ ) => HasPosition i s t a b where
194− , HasPosition0 i s t a b
195− ) => HasPosition_ i s t a b where
196−
197− position_ = position0 @i
198− {-# INLINE position_ #-}
199
120
200−instance {-# OVERLAPPING #-} HasPosition_ f (Void1 a) (Void1 b) a b where
121+ position f s = ravel (repLens . gposition @i) f s
201− position_ = undefined
202
122
203−instance
123+-- See Note [Uncluttering type signatures]
204− ( Generic s
124+instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where
205− , Generic t
125+ position = undefined
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
126
219type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint where
127type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint where
220 ErrorUnless i s 'False
128 ErrorUnless i s 'False
@@ -227,6 +135,3 @@ type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint wher
227
135
228 ErrorUnless _ _ 'True
136 ErrorUnless _ _ 'True
229 = ()
137 = ()
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+5−45
@@ -1,4 +1,3 @@
1−{-# LANGUAGE CPP #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
3{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
@@ -16,7 +15,7 @@
16-----------------------------------------------------------------------------
15-----------------------------------------------------------------------------
17-- |
16-- |
18-- Module : Data.Generics.Product.Subtype
17-- Module : Data.Generics.Product.Subtype
19−-- Copyright : (C) 2019 Csongor Kiss
18+-- Copyright : (C) 2017 Csongor Kiss
20-- License : BSD3
19-- License : BSD3
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
22-- Stability : experimental
21-- Stability : experimental
@@ -41,8 +40,7 @@ import Data.Generics.Product.Internal.Subtype
41import GHC.Generics (Generic (Rep, to, from) )
40import GHC.Generics (Generic (Rep, to, from) )
42import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
41import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
43import Data.Kind (Type, Constraint)
42import Data.Kind (Type, Constraint)
44−import Data.Generics.Internal.Profunctor.Lens hiding (set)
43+import Data.Generics.Internal.Profunctor.Lens
45−import Data.Generics.Internal.Errors
46
44
47-- $setup
45-- $setup
48-- == /Running example:/
46-- == /Running example:/
@@ -52,7 +50,7 @@ import Data.Generics.Internal.Errors
52-- >>> :set -XDeriveGeneric
50-- >>> :set -XDeriveGeneric
53-- >>> :set -XDuplicateRecordFields
51-- >>> :set -XDuplicateRecordFields
54-- >>> import GHC.Generics
52-- >>> import GHC.Generics
55−-- >>> :m +Data.Generics.Internal.VL.Lens
53+-- >>> :m +Data.Generics.Internal.Lens
56-- >>> :{
54-- >>> :{
57-- data Human = Human
55-- data Human = Human
58-- { name :: String
56-- { name :: String
@@ -115,52 +113,14 @@ instance
115 , Generic b
113 , Generic b
116 , GSmash (Rep a) (Rep b)
114 , GSmash (Rep a) (Rep b)
117 , GUpcast (Rep a) (Rep b)
115 , GUpcast (Rep a) (Rep b)
118− , CustomError a b
116+ , ErrorUnless b a (CollectFieldsOrdered (Rep b) \\ CollectFieldsOrdered (Rep a))
119 ) => Subtype b a where
117 ) => Subtype b a where
120 smash p b = to $ gsmash (from p) (from b)
118 smash p b = to $ gsmash (from p) (from b)
121 upcast = to . gupcast . from
119 upcast = to . gupcast . from
122
120
123−type family CustomError a b :: Constraint where
124− CustomError a b =
125− ( ErrorUnless b a (CollectFieldsOrdered (Rep b) \\ CollectFieldsOrdered (Rep a))
126− , Defined (Rep a)
127− (NoGeneric a '[ 'Text "arising from a generic lens focusing on " ':<>: QuoteType b
128− , 'Text "as a supertype of " ':<>: QuoteType a
129− ])
130− (() :: Constraint)
131− , Defined (Rep b)
132− (NoGeneric b '[ 'Text "arising from a generic lens focusing on " ':<>: QuoteType b
133− , 'Text "as a supertype of " ':<>: QuoteType a
134− ])
135− (() :: Constraint)
136− )
137−
138−instance {-# OVERLAPPING #-} Subtype a a where
139− super = id
140−
141−-- | See Note [Uncluttering type signatures]
121+-- See Note [Uncluttering type signatures]
142−#if __GLASGOW_HASKELL__ < 804
143−-- >>> :t super
144−-- super
145−-- :: (Subtype sup sub, Functor f) => (sup -> f sup) -> sub -> f sub
146−#else
147−-- >>> :t super
148−-- super
149−-- :: (Functor f, Subtype sup sub) => (sup -> f sup) -> sub -> f sub
150−#endif
151instance {-# OVERLAPPING #-} Subtype a Void where
122instance {-# OVERLAPPING #-} Subtype a Void where
152 super = undefined
123 super = undefined
153−
154−-- | See Note [Uncluttering type signatures]
155−#if __GLASGOW_HASKELL__ < 804
156−-- >>> :t super @Int
157−-- super @Int
158−-- :: (Subtype Int sub, Functor f) => (Int -> f Int) -> sub -> f sub
159−#else
160−-- >>> :t super @Int
161−-- super @Int
162−-- :: (Functor f, Subtype Int sub) => (Int -> f Int) -> sub -> f sub
163−#endif
164instance {-# OVERLAPPING #-} Subtype Void a where
124instance {-# OVERLAPPING #-} Subtype Void a where
165 super = undefined
125 super = undefined
166
126
src/Data/Generics/Product/Typed.hs+6−33
@@ -1,4 +1,3 @@
1−{-# LANGUAGE CPP #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
3{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
@@ -8,14 +7,13 @@
8{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE TypeApplications #-}
8{-# LANGUAGE TypeApplications #-}
10{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE TypeFamilies #-}
11−{-# LANGUAGE TypeInType #-}
12{-# LANGUAGE TypeOperators #-}
10{-# LANGUAGE TypeOperators #-}
13{-# LANGUAGE UndecidableInstances #-}
11{-# LANGUAGE UndecidableInstances #-}
14
12
15-----------------------------------------------------------------------------
13-----------------------------------------------------------------------------
16-- |
14-- |
17-- Module : Data.Generics.Product.Typed
15-- Module : Data.Generics.Product.Typed
18−-- Copyright : (C) 2019 Csongor Kiss
16+-- Copyright : (C) 2017 Csongor Kiss
19-- License : BSD3
17-- License : BSD3
20-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
18-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21-- Stability : experimental
19-- Stability : experimental
@@ -35,13 +33,12 @@ module Data.Generics.Product.Typed
35import Data.Generics.Internal.Families
33import Data.Generics.Internal.Families
36import Data.Generics.Internal.VL.Lens as VL
34import Data.Generics.Internal.VL.Lens as VL
37import Data.Generics.Internal.Void
35import Data.Generics.Internal.Void
38−import Data.Generics.Product.Internal.GLens
36+import Data.Generics.Product.Internal.Keyed
39
37
40import Data.Kind (Constraint, Type)
38import Data.Kind (Constraint, Type)
41import GHC.Generics (Generic (Rep))
39import GHC.Generics (Generic (Rep))
42import GHC.TypeLits (TypeError, ErrorMessage (..))
40import GHC.TypeLits (TypeError, ErrorMessage (..))
43import Data.Generics.Internal.Profunctor.Lens
41import Data.Generics.Internal.Profunctor.Lens
44−import Data.Generics.Internal.Errors
45
42
46-- $setup
43-- $setup
47-- == /Running example:/
44-- == /Running example:/
@@ -50,7 +47,7 @@ import Data.Generics.Internal.Errors
50-- >>> :set -XDataKinds
47-- >>> :set -XDataKinds
51-- >>> :set -XDeriveGeneric
48-- >>> :set -XDeriveGeneric
52-- >>> import GHC.Generics
49-- >>> import GHC.Generics
53−-- >>> :m +Data.Generics.Internal.VL.Lens
50+-- >>> :m +Data.Generics.Internal.Lens
54-- >>> :{
51-- >>> :{
55-- data Human
52-- data Human
56-- = Human
53-- = Human
@@ -98,7 +95,6 @@ class HasType a s where
98 typed :: VL.Lens s s a a
95 typed :: VL.Lens s s a a
99 typed
96 typed
100 = VL.lens (getTyped @a) (uncurry (setTyped @a) . swap)
97 = VL.lens (getTyped @a) (uncurry (setTyped @a) . swap)
101− {-# INLINE typed #-}
102
98
103 -- |Get field at type.
99 -- |Get field at type.
104 getTyped :: s -> a
100 getTyped :: s -> a
@@ -113,31 +109,12 @@ class HasType a s where
113instance
109instance
114 ( Generic s
110 ( Generic s
115 , ErrorUnlessOne a s (CollectTotalType a (Rep s))
111 , ErrorUnlessOne a s (CollectTotalType a (Rep s))
116− , Defined (Rep s)
117− (NoGeneric s '[ 'Text "arising from a generic lens focusing on a field of type " ':<>: QuoteType a])
118− (() :: Constraint)
119− , GLens (HasTotalTypePSym a) (Rep s) (Rep s) a a
112+ , GHasKey a (Rep s) (Rep s) a a
120 ) => HasType a s where
113 ) => HasType a s where
121
114
122− typed f s = VL.ravel (repLens . glens @(HasTotalTypePSym a)) f s
115+ typed = ravel (repLens . gkey @a)
123
116
124−instance {-# OVERLAPPING #-} HasType a a where
125− getTyped = id
126− {-# INLINE getTyped #-}
127−
128− setTyped a _ = a
129− {-# INLINE setTyped #-}
130−
131−-- | See Note [Uncluttering type signatures]
117+-- See Note [Uncluttering type signatures]
132−#if __GLASGOW_HASKELL__ < 804
133−-- >>> :t typed
134−-- typed :: (HasType a s, Functor f) => (a -> f a) -> s -> f s
135−#else
136−-- >>> :t typed
137−-- typed :: (Functor f, HasType a s) => (a -> f a) -> s -> f s
138−#endif
139−--
140−-- Note that this might not longer be needed given the above 'HasType a a' instance.
141instance {-# OVERLAPPING #-} HasType a Void where
118instance {-# OVERLAPPING #-} HasType a Void where
142 typed = undefined
119 typed = undefined
143
120
@@ -172,7 +149,3 @@ type family ErrorUnlessOne (a :: Type) (s :: Type) (stat :: TypeStat) :: Constra
172
149
173 ErrorUnlessOne _ _ ('TypeStat '[] '[] _)
150 ErrorUnlessOne _ _ ('TypeStat '[] '[] _)
174 = ()
151 = ()
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+13−332
@@ -1,12 +1,9 @@
1{-# LANGUAGE AllowAmbiguousTypes #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE DefaultSignatures #-}
3+{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE KindSignatures #-}
5{-# LANGUAGE KindSignatures #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
8−{-# LANGUAGE PolyKinds #-}
9−{-# LANGUAGE Rank2Types #-}
10{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE TypeApplications #-}
8{-# LANGUAGE TypeApplications #-}
12{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE TypeFamilies #-}
@@ -16,7 +13,7 @@
16-----------------------------------------------------------------------------
13-----------------------------------------------------------------------------
17-- |
14-- |
18-- Module : Data.Generics.Product.Types
15-- Module : Data.Generics.Product.Types
19−-- Copyright : (C) 2019 Csongor Kiss
16+-- Copyright : (C) 2017 Csongor Kiss
20-- License : BSD3
17-- License : BSD3
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
18-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
22-- Stability : experimental
19-- Stability : experimental
@@ -29,339 +26,23 @@
29module Data.Generics.Product.Types
26module Data.Generics.Product.Types
30 ( -- *Traversals
27 ( -- *Traversals
31 --
28 --
32− -- $setup
29+ -- $example
33− HasTypes
30+ HasTypes (..)
34− , types
35−
36− -- * Custom traversal strategies
37− -- $custom
38− , Children
39− , ChGeneric
40−
41− , HasTypesUsing
42− , typesUsing
43−
44− , HasTypesCustom (typesCustom)
45−
46 ) where
31 ) where
47
32
48−import Data.Kind
33+import Data.Generics.Product.Internal.Types
49−import Data.Int (Int8, Int16, Int32, Int64)
50−import Data.Word (Word, Word8, Word16, Word32, Word64)
51−import qualified Data.Text as T
52
34
53−import GHC.Generics
35+import GHC.Generics (Generic (Rep), from, to)
54−import GHC.TypeLits
55import Data.Generics.Internal.VL.Traversal
36import Data.Generics.Internal.VL.Traversal
56−import Data.Generics.Internal.Errors
57−
58−-- $setup
59−-- == /Running example:/
60−--
61−-- >>> :set -XTypeApplications
62−-- >>> :set -XDeriveGeneric
63−-- >>> :set -XScopedTypeVariables
64−-- >>> import GHC.Generics
65−-- >>> :m +Data.Generics.Internal.VL.Traversal
66−-- >>> :m +Data.Generics.Internal.VL.Lens
67−-- >>> :{
68−-- data WTree a w
69−-- = Leaf a
70−-- | Fork (WTree a w) (WTree a w)
71−-- | WithWeight (WTree a w) w
72−-- deriving (Generic, Show)
73−-- :}
74−
75−--------------------------------------------------------------------------------
76−-- HasTypes
77−--------------------------------------------------------------------------------
78−
79−-- TODO [1.0.0.0]: use type-changing variant internally
80
37
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.
91−types :: forall a s. HasTypes s a => Traversal' s a
92−types = types_ @s @a
93−{-# INLINE types #-}
94−
95−class HasTypes s a where
38+class HasTypes a s where
96− types_ :: Traversal' s a
97−
98− default types_ :: Traversal' s a
39+ types :: Traversal' s a
99− types_ _ = pure
100− {-# INLINE types_ #-}
101
40
102instance
41instance
103− ( HasTypesUsing ChGeneric s a
42+ ( Generic s
104− ) => HasTypes s a where
105− types_ = typesUsing_ @ChGeneric
106− {-# INLINE types_ #-}
107−
108−--------------------------------------------------------------------------------
109−data Void
110−instance {-# OVERLAPPING #-} HasTypes Void a where
111− types_ _ = pure
112−
113−instance {-# OVERLAPPING #-} HasTypes s Void where
114− types_ _ = pure
115−
116−instance {-# OVERLAPPING #-} HasTypesUsing ch Void a where
117− typesUsing_ _ = pure
118−
119−instance {-# OVERLAPPING #-} HasTypesUsing ch s Void where
120− typesUsing_ _ = pure
121−--------------------------------------------------------------------------------
122−
123−--------------------------------------------------------------------------------
124−-- HasTypesUsing
125−--------------------------------------------------------------------------------
126−
127−-- $custom
128−--
129−-- The default traversal strategy 'types' recurses into each node of the type
130−-- using the 'Generic' instance for the nodes. However, in general not all
131−-- nodes will have a 'Generic' instance. For example:
132−--
133−-- >>> data Opaque = Opaque String deriving Show
134−-- >>> myTree = WithWeight (Fork (Leaf (Opaque "foo")) (Leaf (Opaque "bar"))) False
135−-- >>> over (types @String) (++ "!") myTree
136−-- ...
137−-- ... | No instance for ‘Generic Opaque’
138−-- ... | arising from a generic traversal.
139−-- ... | Either derive the instance, or define a custom traversal using ‘HasTypesCustom’
140−-- ...
141−--
142−-- In these cases, we can define a custom traversal strategy to override the
143−-- generic behaviour for certain types.
144−-- For a self-contained example, see the CustomChildren module in the tests directory.
145−
146−-- | The children of a type are the types of its fields.
147−-- The 'Children' type family maps a type @a@ to its set of children.
148−--
149−-- This type family is parameterized by a symbol @ch@ (that can be declared as
150−-- an empty data type).
151−-- The symbol 'ChGeneric' provides a default definition. You can create new
152−-- symbols to override the set of children of abstract, non-generic types.
153−--
154−-- The following example declares a @Custom@ symbol to redefine 'Children'
155−-- for some abstract types from the @time@ library.
156−--
157−-- @
158−-- data Custom
159−-- type instance 'Children' Custom a = ChildrenCustom a
160−--
161−-- type family ChildrenCustom (a :: Type) where
162−-- ChildrenCustom DiffTime = '[]
163−-- ChildrenCustom NominalDiffTime = '[]
164−-- -- Add more custom mappings here.
165−--
166−-- ChildrenCustom a = Children ChGeneric a
167−-- @
168−--
169−-- To use this definition, replace 'types' with @'typesUsing' \@Custom@.
170−type family Children (ch :: Type) (a :: Type) :: [Type]
171−
172−-- | @since 1.2.0.0
173−typesUsing :: forall ch a s. HasTypesUsing ch s a => Traversal' s a
174−typesUsing = typesUsing_ @ch @s @a
175−{-# INLINE typesUsing #-}
176−
177−-- | @since 1.2.0.0
178−class HasTypesUsing (ch :: Type) s a where
179− typesUsing_ :: Traversal' s a
180−
181−instance {-# OVERLAPPABLE #-}
182− ( HasTypesOpt ch (Interesting ch a s) s a
183− ) => HasTypesUsing ch s a where
184− typesUsing_ = typesOpt @ch @(Interesting ch a s)
185− {-# INLINE typesUsing_ #-}
186−
187−-- TODO: should this instance be incoherent?
188−instance {-# OVERLAPPABLE #-} HasTypesUsing ch a a where
189− typesUsing_ = id
190−
191−-- | By adding instances to this class, we can override the default
192−-- behaviour in an ad-hoc manner.
193−-- For example:
194−--
195−-- @
196−-- instance HasTypesCustom Custom Opaque String where
197−-- typesCustom f (Opaque str) = Opaque <$> f str
198−-- @
199−--
200−-- @since 1.2.0.0
201−class HasTypesCustom (ch :: Type) s a where
202− -- | This function should never be used directly, only to override
203− -- the default traversal behaviour. To actually use the custom
204− -- traversal strategy, see 'typesUsing'. This is because 'typesUsing' does
205− -- additional optimisations, like ensuring that nodes with no relevant members will
206− -- not be traversed at runtime.
207− typesCustom :: Traversal' s a
208−
209−instance {-# OVERLAPPABLE #-}
210− ( GHasTypes ch (Rep s) a
43+ , GHasTypes (Rep s) a
211− , Generic s
44+ ) => HasTypes a s 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
220− typesCustom f s = to <$> gtypes_ @ch f (from s)
221− --{-# INLINE types' #-}
222−
223−
224−-- | The default definition of 'Children'.
225−-- Primitive types from core libraries have no children, and other types are
226−-- assumed to be 'Generic'.
227−data ChGeneric
228−type instance Children ChGeneric a = ChildrenDefault a
229−
230−type family ChildrenDefault (a :: Type) :: [Type] where
231− ChildrenDefault Char = '[]
232− ChildrenDefault Double = '[]
233− ChildrenDefault Float = '[]
234− ChildrenDefault Integer = '[]
235− ChildrenDefault Int = '[]
236− ChildrenDefault Int8 = '[]
237− ChildrenDefault Int16 = '[]
238− ChildrenDefault Int32 = '[]
239− ChildrenDefault Int64 = '[]
240− ChildrenDefault Word = '[]
241− ChildrenDefault Word8 = '[]
242− ChildrenDefault Word16 = '[]
243− ChildrenDefault Word32 = '[]
244− ChildrenDefault Word64 = '[]
245− ChildrenDefault T.Text = '[]
246− ChildrenDefault a
247− = Defined (Rep a)
248− (NoGeneric a
249− '[ 'Text "arising from a generic traversal."
250− , 'Text "Either derive the instance, or define a custom traversal using " ':<>: QuoteType HasTypesCustom
251− ])
252− (ChildrenGeneric (Rep a) '[])
253−
254−type family ChildrenGeneric (f :: k -> Type) (cs :: [Type]) :: [Type] where
255− ChildrenGeneric (M1 _ _ f) cs = ChildrenGeneric f cs
256− ChildrenGeneric (l :*: r) cs = ChildrenGeneric l (ChildrenGeneric r cs)
257− ChildrenGeneric (l :+: r) cs = ChildrenGeneric l (ChildrenGeneric r cs)
258− ChildrenGeneric (Rec0 a) cs = a ': cs
259− ChildrenGeneric _ cs = cs
260−
261−--------------------------------------------------------------------------------
262−-- Internals
263−--------------------------------------------------------------------------------
264−-- TODO: these should never leak out in error messages
265−
266−class HasTypesOpt (ch :: Type) (t :: Bool) s a where
267− typesOpt :: Traversal' s a
268−
269−instance HasTypesCustom ch s a => HasTypesOpt ch 'True s a where
270− typesOpt = typesCustom @ch
271−
272−instance HasTypesOpt ch 'False s a where
273− typesOpt _ = pure
274− --{-# INLINE typesOpt #-}
275−
276−--------------------------------------------------------------------------------
277−
278−class GHasTypes ch s a where
279− gtypes_ :: Traversal' (s x) a
280−
281−instance
282− ( GHasTypes ch l a
283− , GHasTypes ch r a
284− ) => GHasTypes ch (l :*: r) a where
285− gtypes_ f (l :*: r) = (:*:) <$> gtypes_ @ch f l <*> gtypes_ @ch f r
286− {-# INLINE gtypes_ #-}
287−
288−instance
289− ( GHasTypes ch l a
290− , GHasTypes ch r a
291− ) => GHasTypes ch (l :+: r) a where
292− gtypes_ f (L1 l) = L1 <$> gtypes_ @ch f l
293− gtypes_ f (R1 r) = R1 <$> gtypes_ @ch f r
294− {-# INLINE gtypes_ #-}
295−
296−instance (GHasTypes ch s a) => GHasTypes ch (M1 m meta s) a where
297− gtypes_ f (M1 s) = M1 <$> gtypes_ @ch f s
298− {-# INLINE gtypes_ #-}
299−
300−-- | In the recursive case, we invoke 'HasTypesUsing' again, using the
301−-- same strategy
302−instance HasTypesUsing ch b a => GHasTypes ch (Rec0 b) a where
303− gtypes_ f (K1 x) = K1 <$> typesUsing_ @ch @b @a f x
304− {-# INLINE gtypes_ #-}
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')
312−instance {-# OVERLAPPING #-} HasTypes b a => GHasTypes ChGeneric (Rec0 b) a where
313− gtypes_ f (K1 x) = K1 <$> types_ @b @a f x
314− {-# INLINE gtypes_ #-}
315−
316−instance GHasTypes ch U1 a where
317− gtypes_ _ _ = pure U1
318− {-# INLINE gtypes_ #-}
319−
320−instance GHasTypes ch V1 a where
321− gtypes_ _ = pure
322− {-# INLINE gtypes_ #-}
323−
324−type Interesting (ch :: Type) (a :: Type) (t :: Type)
325− = Defined_list (Children ch t) (NoChildren ch t)
326− (IsNothing (Interesting' ch a '[t] (Children ch t)))
327−
328−type family NoChildren (ch :: Type) (a :: Type) :: Constraint where
329− NoChildren ch a = PrettyError
330− '[ 'Text "No type family instance for " ':<>: QuoteType (Children ch a)
331− , 'Text "arising from a traversal over " ':<>: QuoteType a
332− , 'Text "with custom strategy " ':<>: QuoteType ch
333− ]
334−
335−
336−type family Interesting' (ch :: Type) (a :: Type) (seen :: [Type]) (ts :: [Type]) :: Maybe [Type] where
337− Interesting' ch _ seen '[] = 'Just seen
338− Interesting' ch a seen (t ': ts) =
339− InterestingOr ch a (InterestingUnless ch a seen t (Elem t seen)) ts
340−
341−-- Short circuit
342−-- Note: we only insert 't' to the seen list if it's not already there (which is precisely when `s` is 'False)
343−type family InterestingUnless
344− (ch :: Type) (a :: Type) (seen :: [Type]) (t :: Type) (alreadySeen :: Bool) ::
345− Maybe [Type] where
346− InterestingUnless ch a seen a _ = 'Nothing
347− InterestingUnless ch a seen t 'True = 'Just seen
348− InterestingUnless ch a seen t 'False
349− = Defined_list (Children ch t) (NoChildren ch t)
350− (Interesting' ch a (t ': seen) (Children ch t))
351−
352−-- Short circuit
353−type family InterestingOr
354− (ch :: Type) (a :: Type) (seen' :: Maybe [Type]) (ts :: [Type]) ::
355− Maybe [Type] where
356− InterestingOr ch a 'Nothing _ = 'Nothing
357− InterestingOr ch a ('Just seen) ts = Interesting' ch a seen ts
358−
359−type family Elem a as where
360− Elem a (a ': _) = 'True
361− Elem a (_ ': as) = Elem a as
362− Elem a '[] = 'False
363
45
364−type family IsNothing a where
46+ types = confusing (\f s -> to <$> gtypes f (from s))
365− IsNothing ('Just _) = 'False
47+ {-# INLINE types #-}
366− IsNothing 'Nothing = 'True
367
48
src/Data/Generics/Sum.hs+1−1
@@ -1,7 +1,7 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2-- |
2-- |
3-- Module : Data.Generics.Sum
3-- Module : Data.Generics.Sum
4−-- Copyright : (C) 2019 Csongor Kiss
4+-- Copyright : (C) 2017 Csongor Kiss
5-- License : BSD3
5-- License : BSD3
6-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
6-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
7-- Stability : experimental
7-- Stability : experimental
src/Data/Generics/Sum/Any.hs+3−3
@@ -11,7 +11,7 @@
11-----------------------------------------------------------------------------
11-----------------------------------------------------------------------------
12-- |
12-- |
13-- Module : Data.Generics.Sum.Any
13-- Module : Data.Generics.Sum.Any
14−-- Copyright : (C) 2019 Csongor Kiss
14+-- Copyright : (C) 2017 Csongor Kiss
15-- License : BSD3
15-- License : BSD3
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17-- Stability : experimental
17-- Stability : experimental
@@ -39,7 +39,7 @@ import Data.Generics.Internal.VL.Prism
39-- >>> :set -XDataKinds
39-- >>> :set -XDataKinds
40-- >>> :set -XDeriveGeneric
40-- >>> :set -XDeriveGeneric
41-- >>> import GHC.Generics
41-- >>> import GHC.Generics
42−-- >>> :m +Data.Generics.Internal.VL.Prism
42+-- >>> :m +Data.Generics.Internal.Lens
43-- >>> :{
43-- >>> :{
44-- data Animal
44-- data Animal
45-- = Dog Dog
45-- = Dog Dog
@@ -61,7 +61,7 @@ import Data.Generics.Internal.VL.Prism
61-- :}
61-- :}
62
62
63-- |Sums that have generic prisms.
63-- |Sums that have generic prisms.
64−class AsAny sel a s | s sel -> a where
64+class AsAny (sel :: k) a s | s sel k -> a where
65 -- |A prism that projects a sum as identified by some selector. Currently
65 -- |A prism that projects a sum as identified by some selector. Currently
66 -- supported selectors are constructor names and unique types. Compatible
66 -- supported selectors are constructor names and unique types. Compatible
67 -- with the lens package's 'Control.Lens.Prism' type.
67 -- with the lens package's 'Control.Lens.Prism' type.
src/Data/Generics/Sum/Constructors.hs+18−88
@@ -15,7 +15,7 @@
15-----------------------------------------------------------------------------
15-----------------------------------------------------------------------------
16-- |
16-- |
17-- Module : Data.Generics.Sum.Constructors
17-- Module : Data.Generics.Sum.Constructors
18−-- Copyright : (C) 2019 Csongor Kiss
18+-- Copyright : (C) 2017 Csongor Kiss
19-- License : BSD3
19-- License : BSD3
20-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21-- Stability : experimental
21-- Stability : experimental
@@ -30,9 +30,6 @@ module Data.Generics.Sum.Constructors
30
30
31 -- $setup
31 -- $setup
32 AsConstructor (..)
32 AsConstructor (..)
33− , AsConstructor_ (..)
34− , AsConstructor' (..)
35− , AsConstructor0 (..)
36 ) where
33 ) where
37
34
38import Data.Generics.Internal.Families
35import Data.Generics.Internal.Families
@@ -44,8 +41,6 @@ import GHC.Generics (Generic (Rep))
44import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
41import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
45import Data.Generics.Internal.VL.Prism
42import Data.Generics.Internal.VL.Prism
46import Data.Generics.Internal.Profunctor.Iso
43import Data.Generics.Internal.Profunctor.Iso
47−import Data.Generics.Internal.Profunctor.Prism (prismPRavel)
48−import Data.Generics.Internal.Errors
49
44
50-- $setup
45-- $setup
51-- == /Running example:/
46-- == /Running example:/
@@ -56,7 +51,7 @@ import Data.Generics.Internal.Errors
56-- >>> :set -XFlexibleContexts
51-- >>> :set -XFlexibleContexts
57-- >>> :set -XTypeFamilies
52-- >>> :set -XTypeFamilies
58-- >>> import GHC.Generics
53-- >>> import GHC.Generics
59−-- >>> :m +Data.Generics.Internal.VL.Prism
54+-- >>> :m +Data.Generics.Internal.Lens
60-- >>> :m +Data.Generics.Product.Fields
55-- >>> :m +Data.Generics.Product.Fields
61-- >>> :m +Data.Function
56-- >>> :m +Data.Function
62-- >>> :{
57-- >>> :{
@@ -71,7 +66,7 @@ import Data.Generics.Internal.Errors
71-- , age :: Age
66-- , age :: Age
72-- , fieldA :: a
67-- , fieldA :: a
73-- }
68-- }
74−-- deriving Show
69+-- deriving (Generic, Show)
75-- type Name = String
70-- type Name = String
76-- type Age = Int
71-- type Age = Int
77-- dog, cat, duck :: Animal Int
72-- dog, cat, duck :: Animal Int
@@ -106,99 +101,34 @@ class AsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where
106 -- ...
101 -- ...
107 _Ctor :: Prism s t a b
102 _Ctor :: Prism s t a b
108
103
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−
118−class AsConstructor' (ctor :: Symbol) s a | ctor s -> a where
119− _Ctor' :: Prism s s a a
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−
128instance
104instance
129 ( Generic s
105 ( Generic s
130 , ErrorUnless ctor s (HasCtorP ctor (Rep s))
106 , ErrorUnless ctor s (HasCtorP ctor (Rep s))
107+ , Generic t
108+ -- see Note [CPP in instance constraints]
109+#if __GLASGOW_HASKELL__ < 802
110+ , '(s', t') ~ '(Proxied s, Proxied t)
111+#else
112+ , s' ~ Proxied s
113+ , t' ~ Proxied t
114+#endif
115+ , Generic s'
116+ , Generic t'
131 , GAsConstructor' ctor (Rep s) a
117 , GAsConstructor' ctor (Rep s) a
132− , Defined (Rep s)
133− (NoGeneric s '[ 'Text "arising from a generic prism focusing on the "
134− ':<>: QuoteType ctor ':<>: 'Text " constructor of type " ':<>: QuoteType a
135− , 'Text "in " ':<>: QuoteType s])
136− (() :: Constraint)
137− ) => AsConstructor' ctor s a where
138− _Ctor' eta = prismRavel (prismPRavel (repIso . _GCtor @ctor)) eta
139− {-# INLINE[2] _Ctor' #-}
140−
141−instance
142− ( ErrorUnless ctor s (HasCtorP ctor (Rep s))
143− , GAsConstructor' ctor (Rep s) a -- TODO: add a test similar to #62 for prisms
118+ , GAsConstructor' ctor (Rep s') a'
144− , GAsConstructor' ctor (Rep (Indexed s)) a'
145 , GAsConstructor ctor (Rep s) (Rep t) a b
119 , GAsConstructor ctor (Rep s) (Rep t) a b
146 , t ~ Infer s a' b
120 , t ~ Infer s a' b
147− , GAsConstructor' ctor (Rep (Indexed t)) b'
121+ , GAsConstructor' ctor (Rep t') b'
148 , s ~ Infer t b' a
122 , s ~ Infer t b' a
149− , AsConstructor0 ctor s t a b
150 ) => AsConstructor ctor s t a b where
123 ) => AsConstructor ctor s t a b where
151
124
152− _Ctor = _Ctor0 @ctor
125+ _Ctor eta = prismRavel (repIso . _GCtor @ctor) eta
153− {-# INLINE[2] _Ctor #-}
126+ {-# INLINE _Ctor #-}
154
127
155−-- | See Note [Uncluttering type signatures]
128+-- See Note [Uncluttering type signatures]
156−#if __GLASGOW_HASKELL__ < 804
157−-- >>> :t _Ctor
158−-- _Ctor
159−-- :: (Applicative f, Data.Profunctor.Choice.Choice p,
160−-- AsConstructor ctor s t a b) =>
161−-- p a (f b) -> p s (f t)
162−#else
163−-- >>> :t _Ctor
164−-- _Ctor
165−-- :: (AsConstructor ctor s t a b, Data.Profunctor.Choice.Choice p,
166−-- Applicative f) =>
167−-- p a (f b) -> p s (f t)
168−#endif
169instance {-# OVERLAPPING #-} AsConstructor ctor (Void1 a) (Void1 b) a b where
129instance {-# OVERLAPPING #-} AsConstructor ctor (Void1 a) (Void1 b) a b where
170 _Ctor = undefined
130 _Ctor = undefined
171
131
172−instance
173− ( ErrorUnless ctor s (HasCtorP ctor (Rep s))
174− , GAsConstructor' ctor (Rep s) a -- TODO: add a test similar to #62 for prisms
175− , GAsConstructor' ctor (Rep (Indexed s)) a'
176− , GAsConstructor ctor (Rep s) (Rep t) a b
177− , GAsConstructor' ctor (Rep (Indexed t)) b'
178− , UnifyHead s t
179− , UnifyHead t s
180− , AsConstructor0 ctor s t a b
181− ) => AsConstructor_ ctor s t a b where
182−
183− _Ctor_ = _Ctor0 @ctor
184− {-# INLINE[2] _Ctor_ #-}
185−
186−instance {-# OVERLAPPING #-} AsConstructor_ ctor (Void1 a) (Void1 b) a b where
187− _Ctor_ = undefined
188−
189−instance
190− ( Generic s
191− , Generic t
192− , GAsConstructor ctor (Rep s) (Rep t) a b
193− , Defined (Rep s)
194− (NoGeneric s '[ 'Text "arising from a generic prism focusing on the "
195− ':<>: QuoteType ctor ':<>: 'Text " constructor of type " ':<>: QuoteType a
196− , 'Text "in " ':<>: QuoteType s])
197− (() :: Constraint)
198− ) => AsConstructor0 ctor s t a b where
199− _Ctor0 = prismRavel (prismPRavel (repIso . _GCtor @ctor))
200− {-# INLINE[2] _Ctor0 #-}
201−
202type family ErrorUnless (ctor :: Symbol) (s :: Type) (contains :: Bool) :: Constraint where
132type family ErrorUnless (ctor :: Symbol) (s :: Type) (contains :: Bool) :: Constraint where
203 ErrorUnless ctor s 'False
133 ErrorUnless ctor s 'False
204 = TypeError
134 = TypeError
src/Data/Generics/Sum/Internal/Constructors.hs+13−11
@@ -14,7 +14,7 @@
14-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
15-- |
15-- |
16-- Module : Data.Generics.Sum.Internal.Constructors
16-- Module : Data.Generics.Sum.Internal.Constructors
17−-- Copyright : (C) 2019 Csongor Kiss
17+-- Copyright : (C) 2017 Csongor Kiss
18-- License : BSD3
18-- License : BSD3
19-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20-- Stability : experimental
20-- Stability : experimental
@@ -30,11 +30,11 @@ module Data.Generics.Sum.Internal.Constructors
30 ) where
30 ) where
31
31
32import Data.Generics.Internal.Families
32import Data.Generics.Internal.Families
33−import Data.Generics.Product.Internal.HList
33+import Data.Generics.Product.Internal.List
34−import Data.Profunctor (Profunctor(..))
35
34
36import GHC.Generics
35import GHC.Generics
37import GHC.TypeLits (Symbol)
36import GHC.TypeLits (Symbol)
37+import Data.Kind
38import Data.Generics.Internal.Profunctor.Lens
38import Data.Generics.Internal.Profunctor.Lens
39import Data.Generics.Internal.Profunctor.Iso
39import Data.Generics.Internal.Profunctor.Iso
40import Data.Generics.Internal.Profunctor.Prism
40import Data.Generics.Internal.Profunctor.Prism
@@ -47,30 +47,32 @@ class GAsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where
47type GAsConstructor' ctor s a = GAsConstructor ctor s s a a
47type GAsConstructor' ctor s a = GAsConstructor ctor s s a a
48
48
49instance
49instance
50− ( GIsList f f as as
50+ ( GIsList Type f f as as
51− , GIsList g g bs bs
51+ , GIsList Type g g bs bs
52 , ListTuple a as
52 , ListTuple a as
53 , ListTuple b bs
53 , ListTuple b bs
54 ) => GAsConstructor ctor (M1 C ('MetaCons ctor fixity fields) f) (M1 C ('MetaCons ctor fixity fields) g) a b where
54 ) => GAsConstructor ctor (M1 C ('MetaCons ctor fixity fields) f) (M1 C ('MetaCons ctor fixity fields) g) a b where
55
55
56− _GCtor = dimap (listToTuple . view glist . unM1) (M1 . view (fromIso glist) . tupleToList)
56+-- _GCtor = prismP (M1 . gfromCollection . tupleToList) (Right . listToTuple . gtoCollection . unM1)
57− {-# INLINE[0] _GCtor #-}
57+-- {-# INLINE _GCtor #-}
58+ _GCtor = prism (M1 . (view (fromIso (glist @Type))) . tupleToList) (Right . listToTuple . (view (glist @Type)) . unM1)
59+
58
60
59instance GSumAsConstructor ctor (HasCtorP ctor l) l r l' r' a b => GAsConstructor ctor (l :+: r) (l' :+: r') a b where
61instance GSumAsConstructor ctor (HasCtorP ctor l) l r l' r' a b => GAsConstructor ctor (l :+: r) (l' :+: r') a b where
60 _GCtor = _GSumCtor @ctor @(HasCtorP ctor l)
62 _GCtor = _GSumCtor @ctor @(HasCtorP ctor l)
61− {-# INLINE[0] _GCtor #-}
63+ {-# INLINE _GCtor #-}
62
64
63instance GAsConstructor ctor f f' a b => GAsConstructor ctor (M1 D meta f) (M1 D meta f') a b where
65instance GAsConstructor ctor f f' a b => GAsConstructor ctor (M1 D meta f) (M1 D meta f') a b where
64 _GCtor = mIso . _GCtor @ctor
66 _GCtor = mIso . _GCtor @ctor
65− {-# INLINE[0] _GCtor #-}
67+ {-# INLINE _GCtor #-}
66
68
67class GSumAsConstructor (ctor :: Symbol) (contains :: Bool) l r l' r' a b | ctor l r -> a, ctor l' r' -> b where
69class GSumAsConstructor (ctor :: Symbol) (contains :: Bool) l r l' r' a b | ctor l r -> a, ctor l' r' -> b where
68 _GSumCtor :: Prism ((l :+: r) x) ((l' :+: r') x) a b
70 _GSumCtor :: Prism ((l :+: r) x) ((l' :+: r') x) a b
69
71
70instance GAsConstructor ctor l l' a b => GSumAsConstructor ctor 'True l r l' r a b where
72instance GAsConstructor ctor l l' a b => GSumAsConstructor ctor 'True l r l' r a b where
71 _GSumCtor = left . _GCtor @ctor
73 _GSumCtor = left . _GCtor @ctor
72− {-# INLINE[0] _GSumCtor #-}
74+ {-# INLINE _GSumCtor #-}
73
75
74instance GAsConstructor ctor r r' a b => GSumAsConstructor ctor 'False l r l r' a b where
76instance GAsConstructor ctor r r' a b => GSumAsConstructor ctor 'False l r l r' a b where
75 _GSumCtor = right . _GCtor @ctor
77 _GSumCtor = right . _GCtor @ctor
76− {-# INLINE[0] _GSumCtor #-}
78+ {-# INLINE _GSumCtor #-}
src/Data/Generics/Sum/Internal/Subtype.hs+15−71
@@ -1,10 +1,9 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
1+{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE PolyKinds #-}
3{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE KindSignatures #-}
5{-# LANGUAGE KindSignatures #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE PolyKinds #-}
8{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE TypeApplications #-}
8{-# LANGUAGE TypeApplications #-}
10{-# LANGUAGE TypeOperators #-}
9{-# LANGUAGE TypeOperators #-}
@@ -14,7 +13,7 @@
14-----------------------------------------------------------------------------
13-----------------------------------------------------------------------------
15-- |
14-- |
16-- Module : Data.Generics.Sum.Internal.Subtype
15-- Module : Data.Generics.Sum.Internal.Subtype
17−-- Copyright : (C) 2019 Csongor Kiss
16+-- Copyright : (C) 2017 Csongor Kiss
18-- License : BSD3
17-- License : BSD3
19-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
18-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20-- Stability : experimental
19-- Stability : experimental
@@ -28,14 +27,13 @@ module Data.Generics.Sum.Internal.Subtype
28 ( GAsSubtype (..)
27 ( GAsSubtype (..)
29 ) where
28 ) where
30
29
31−import Data.Generics.Product.Internal.HList
30+import Data.Generics.Product.Internal.List
32import Data.Generics.Sum.Internal.Typed
31import Data.Generics.Sum.Internal.Typed
33
32
34import Data.Kind
33import Data.Kind
35import GHC.Generics
34import GHC.Generics
36import Data.Generics.Internal.Profunctor.Iso
35import Data.Generics.Internal.Profunctor.Iso
37import Data.Generics.Internal.Profunctor.Prism
36import Data.Generics.Internal.Profunctor.Prism
38−import Data.Generics.Internal.Families.Has
39
37
40-- |As 'AsSubtype' but over generic representations as defined by
38-- |As 'AsSubtype' but over generic representations as defined by
41-- "GHC.Generics".
39-- "GHC.Generics".
@@ -43,73 +41,19 @@ class GAsSubtype (subf :: Type -> Type) (supf :: Type -> Type) where
43 _GSub :: Prism' (supf x) (subf x)
41 _GSub :: Prism' (supf x) (subf x)
44
42
45instance
43instance
46− ( GSplash sub sup
44+ ( GAsSubtype l supf
47− , GDowncast sub sup
45+ , GAsSubtype r supf
48− ) => GAsSubtype sub sup where
46+ ) => GAsSubtype (l :+: r) supf where
49− _GSub f = prism _GSplash _GDowncast f
47+ _GSub = without' _GSub _GSub . fromIso sumIso
50− {-# INLINE[0] _GSub #-}
51−
52−--------------------------------------------------------------------------------
53−
54−class GSplash (sub :: Type -> Type) (sup :: Type -> Type) where
55− _GSplash :: sub x -> sup x
56−
57−instance (GSplash a sup, GSplash b sup) => GSplash (a :+: b) sup where
58− _GSplash (L1 rep) = _GSplash rep
59− _GSplash (R1 rep) = _GSplash rep
60− {-# INLINE[0] _GSplash #-}
61
48
62instance
49instance
63− ( GIsList subf subf as as
50+ ( GIsList () subf subf as as
64 , GAsType supf as
51 , GAsType supf as
65− ) => GSplash (C1 meta subf) supf where
52+ ) => GAsSubtype (C1 meta subf) supf where
66− _GSplash p = build (_GTyped . fromIso (mIso . glist)) p
53+ _GSub = _GTyped . fromIso (glist @()) . fromIso mIso
67− {-# INLINE[0] _GSplash #-}
68−
69−instance GSplash sub sup => GSplash (D1 c sub) sup where
70− _GSplash (M1 m) = _GSplash m
71− {-# INLINE[0] _GSplash #-}
72
54
73−--------------------------------------------------------------------------------
55+-- instance GAsType supf a => GAsSubtype (S1 meta (Rec0 a)) supf where
74−
56+-- _GSub = _GTyped . fromIso (mIso . kIso)
75−class GDowncast sub sup where
76− _GDowncast :: sup x -> Either (sup x) (sub x)
77−
78−instance
79− ( GIsList sup sup as as
80− , GDowncastC (HasPartialTypeP as sub) sub sup
81− ) => GDowncast sub (C1 m sup) where
82− _GDowncast (M1 m) = case _GDowncastC @(HasPartialTypeP as sub) m of
83− Left _ -> Left (M1 m)
84− Right r -> Right r
85− {-# INLINE[0] _GDowncast #-}
86−
87−instance (GDowncast sub l, GDowncast sub r) => GDowncast sub (l :+: r) where
88− _GDowncast (L1 x) = case _GDowncast x of
89− Left _ -> Left (L1 x)
90− Right r -> Right r
91− _GDowncast (R1 x) = case _GDowncast x of
92− Left _ -> Left (R1 x)
93− Right r -> Right r
94− {-# INLINE[0] _GDowncast #-}
95−
96−instance GDowncast sub sup => GDowncast sub (D1 m sup) where
97− _GDowncast (M1 m) = case _GDowncast m of
98− Left _ -> Left (M1 m)
99− Right r -> Right r
100− {-# INLINE[0] _GDowncast #-}
101−
102−class GDowncastC (contains :: Bool) sub sup where
103− _GDowncastC :: sup x -> Either (sup x) (sub x)
104−
105−instance GDowncastC 'False sub sup where
106− _GDowncastC sup = Left sup
107− {-# INLINE[0] _GDowncastC #-}
108−
109−instance
110− ( GAsType sub subl
111− , GIsList sup sup subl subl
112− ) => GDowncastC 'True sub sup where
113− _GDowncastC sup = Right (build (_GTyped . fromIso glist) sup)
114− {-# INLINE[0] _GDowncastC #-}
115
57
58+instance GAsSubtype subf supf => GAsSubtype (D1 meta subf) supf where
59+ _GSub = _GSub . fromIso mIso
src/Data/Generics/Sum/Internal/Typed.hs+8−20
@@ -13,7 +13,7 @@
13-----------------------------------------------------------------------------
13-----------------------------------------------------------------------------
14-- |
14-- |
15-- Module : Data.Generics.Sum.Internal.Typed
15-- Module : Data.Generics.Sum.Internal.Typed
16−-- Copyright : (C) 2019 Csongor Kiss
16+-- Copyright : (C) 2017 Csongor Kiss
17-- License : BSD3
17-- License : BSD3
18-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
18-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19-- Stability : experimental
19-- Stability : experimental
@@ -29,44 +29,32 @@ module Data.Generics.Sum.Internal.Typed
29
29
30import Data.Kind
30import Data.Kind
31import GHC.Generics
31import GHC.Generics
32−import Data.Tagged
33
32
34import Data.Generics.Internal.Families
33import Data.Generics.Internal.Families
35−import Data.Generics.Product.Internal.HList
34+import Data.Generics.Product.Internal.List
36import Data.Generics.Internal.Profunctor.Iso
35import Data.Generics.Internal.Profunctor.Iso
37import Data.Generics.Internal.Profunctor.Prism
36import Data.Generics.Internal.Profunctor.Prism
38
37
39-- |As 'AsType' but over generic representations as defined by "GHC.Generics".
38-- |As 'AsType' but over generic representations as defined by "GHC.Generics".
40−class GAsType (f :: Type -> Type) (as :: [Type]) where
39+class GAsType (f :: Type -> Type) (as :: [((), Type)]) where
41− _GTyped :: Prism (f x) (f x) (HList as) (HList as)
40+ _GTyped :: Prism (f x) (f x) (List as) (List as)
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
44−-- created after specialisation happens, I think a late specialisation pass
45−-- would pick up this case.
46−{-# SPECIALISE _GTyped :: (Tagged b b -> Tagged t t) #-}
47−
48
41
49instance
42instance
50− ( GIsList f f as as
43+ ( GIsList () f f as as
51 ) => GAsType (M1 C meta f) as where
44 ) => GAsType (M1 C meta f) as where
52− _GTyped = mIso . glist
45+ _GTyped = mIso . glist @()
53− {-# INLINE[0] _GTyped #-}
54
46
55instance GSumAsType (HasPartialTypeP a l) l r a => GAsType (l :+: r) a where
47instance GSumAsType (HasPartialTypeP a l) l r a => GAsType (l :+: r) a where
56 _GTyped = _GSumTyped @(HasPartialTypeP a l)
48 _GTyped = _GSumTyped @(HasPartialTypeP a l)
57− {-# INLINE[0] _GTyped #-}
58
49
59instance GAsType f a => GAsType (M1 D meta f) a where
50instance GAsType f a => GAsType (M1 D meta f) a where
60 _GTyped = mIso . _GTyped
51 _GTyped = mIso . _GTyped
61− {-# INLINE[0] _GTyped #-}
62
52
63−class GSumAsType (contains :: Bool) l r (a :: [Type]) where
53+class GSumAsType (contains :: Bool) l r (a :: [((), Type)]) where
64− _GSumTyped :: Prism ((l :+: r) x) ((l :+: r) x) (HList a) (HList a)
54+ _GSumTyped :: Prism ((l :+: r) x) ((l :+: r) x) (List a) (List a)
65
55
66instance GAsType l a => GSumAsType 'True l r a where
56instance GAsType l a => GSumAsType 'True l r a where
67 _GSumTyped = left . _GTyped
57 _GSumTyped = left . _GTyped
68− {-# INLINE[0] _GSumTyped #-}
69
58
70instance GAsType r a => GSumAsType 'False l r a where
59instance GAsType r a => GSumAsType 'False l r a where
71 _GSumTyped = right . _GTyped
60 _GSumTyped = right . _GTyped
72− {-# INLINE[0] _GSumTyped #-}
src/Data/Generics/Sum/Subtype.hs+10−50
@@ -1,10 +1,8 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE TypeApplications #-}
2{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE MonoLocalBinds #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE ScopedTypeVariables #-}
7−{-# LANGUAGE TypeApplications #-}
8{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE TypeOperators #-}
9{-# LANGUAGE TypeSynonymInstances #-}
7{-# LANGUAGE TypeSynonymInstances #-}
10{-# LANGUAGE UndecidableInstances #-}
8{-# LANGUAGE UndecidableInstances #-}
@@ -12,7 +10,7 @@
12-----------------------------------------------------------------------------
10-----------------------------------------------------------------------------
13-- |
11-- |
14-- Module : Data.Generics.Sum.Subtype
12-- Module : Data.Generics.Sum.Subtype
15−-- Copyright : (C) 2019 Csongor Kiss
13+-- Copyright : (C) 2017 Csongor Kiss
16-- License : BSD3
14-- License : BSD3
17-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
15-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
18-- Stability : experimental
16-- Stability : experimental
@@ -43,7 +41,7 @@ import Data.Generics.Internal.Profunctor.Iso
43-- >>> :set -XDataKinds
41-- >>> :set -XDataKinds
44-- >>> :set -XDeriveGeneric
42-- >>> :set -XDeriveGeneric
45-- >>> import GHC.Generics
43-- >>> import GHC.Generics
46−-- >>> :m +Data.Generics.Internal.VL.Prism
44+-- >>> :m +Data.Generics.Internal.Lens
47-- >>> :{
45-- >>> :{
48-- data Animal
46-- data Animal
49-- = Dog Dog
47-- = Dog Dog
@@ -90,18 +88,16 @@ class AsSubtype sub sup where
90 -- >>> duck ^? _Sub :: Maybe FourLeggedAnimal
88 -- >>> duck ^? _Sub :: Maybe FourLeggedAnimal
91 -- Nothing
89 -- Nothing
92 _Sub :: Prism' sup sub
90 _Sub :: Prism' sup sub
93− _Sub = prism injectSub (\i -> maybe (Left i) Right (projectSub i))
91+ _Sub eta = prism injectSub projectSub eta
94− {-# INLINE[2] _Sub #-}
92+ {-# INLINE _Sub #-}
95
93
96 -- |Injects a subtype into a supertype (upcast).
94 -- |Injects a subtype into a supertype (upcast).
97 injectSub :: sub -> sup
95 injectSub :: sub -> sup
98− injectSub
99− = build (_Sub @sub @sup)
96+ injectSub = build (_Sub @sub @sup)
100
97
101 -- |Projects a subtype from a supertype (downcast).
98 -- |Projects a subtype from a supertype (downcast).
102− projectSub :: sup -> Maybe sub
99+ projectSub :: sup -> Either sup sub
103− projectSub
100+ projectSub = match (_Sub @sub @sup)
104− = either (const Nothing) Just . match (_Sub @sub @sup)
105
101
106 {-# MINIMAL (injectSub, projectSub) | _Sub #-}
102 {-# MINIMAL (injectSub, projectSub) | _Sub #-}
107
103
@@ -111,48 +107,12 @@ instance
111 , GAsSubtype (Rep sub) (Rep sup)
107 , GAsSubtype (Rep sub) (Rep sup)
112 ) => AsSubtype sub sup where
108 ) => AsSubtype sub sup where
113
109
114− _Sub f = prismRavel (repIso . _GSub . fromIso repIso) f
110+ _Sub = prismRavel (repIso . _GSub . fromIso repIso)
115− {-# INLINE[2] _Sub #-}
116
111
117−-- | Reflexive case
118−-- >>> _Sub # dog :: Animal
119−-- Dog (MkDog {name = "Shep", age = 3})
120−instance {-# OVERLAPPING #-} AsSubtype a a where
121− _Sub = id
122− {-# INLINE[2] _Sub #-}
123−
124−-- | See Note [Uncluttering type signatures]
112+-- See Note [Uncluttering type signatures]
125−#if __GLASGOW_HASKELL__ < 804
126−-- >>> :t _Sub
127−--_Sub
128−-- :: (Applicative f, Data.Profunctor.Choice.Choice p,
129−-- AsSubtype sub sup) =>
130−-- p sub (f sub) -> p sup (f sup)
131−-- >>> :t _Sub
132−#else
133−--_Sub
134−-- :: (AsSubtype sub sup, Data.Profunctor.Choice.Choice p,
135−-- Applicative f) =>
136−-- p sub (f sub) -> p sup (f sup)
137−#endif
138instance {-# OVERLAPPING #-} AsSubtype a Void where
113instance {-# OVERLAPPING #-} AsSubtype a Void where
139 injectSub = undefined
114 injectSub = undefined
140 projectSub = undefined
115 projectSub = undefined
141−
142−-- | See Note [Uncluttering type signatures]
143−#if __GLASGOW_HASKELL__ < 804
144−-- >>> :t _Sub @Int
145−-- _Sub @Int
146−-- :: (Applicative f, Data.Profunctor.Choice.Choice p,
147−-- AsSubtype Int sup) =>
148−-- p Int (f Int) -> p sup (f sup)
149−#else
150−-- >>> :t _Sub @Int
151−-- _Sub @Int
152−-- :: (AsSubtype Int sup, Data.Profunctor.Choice.Choice p,
153−-- Applicative f) =>
154−-- p Int (f Int) -> p sup (f sup)
155−#endif
156instance {-# OVERLAPPING #-} AsSubtype Void a where
116instance {-# OVERLAPPING #-} AsSubtype Void a where
157 injectSub = undefined
117 injectSub = undefined
158 projectSub = undefined
118 projectSub = undefined
src/Data/Generics/Sum/Typed.hs+7−43
@@ -1,4 +1,3 @@
1−{-# LANGUAGE CPP #-}
2{-# LANGUAGE TypeApplications #-}
1{-# LANGUAGE TypeApplications #-}
3{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
4{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
@@ -14,7 +13,7 @@
14-----------------------------------------------------------------------------
13-----------------------------------------------------------------------------
15-- |
14-- |
16-- Module : Data.Generics.Sum.Typed
15-- Module : Data.Generics.Sum.Typed
17−-- Copyright : (C) 2019 Csongor Kiss
16+-- Copyright : (C) 2017 Csongor Kiss
18-- License : BSD3
17-- License : BSD3
19-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
18-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20-- Stability : experimental
19-- Stability : experimental
@@ -35,21 +34,19 @@ import Data.Kind
35import GHC.Generics
34import GHC.Generics
36import GHC.TypeLits (TypeError, ErrorMessage (..), Symbol)
35import GHC.TypeLits (TypeError, ErrorMessage (..), Symbol)
37import Data.Generics.Sum.Internal.Typed
36import Data.Generics.Sum.Internal.Typed
38−import Data.Generics.Internal.Errors
39
37
40import Data.Generics.Internal.Families
38import Data.Generics.Internal.Families
41import Data.Generics.Internal.Void
39import Data.Generics.Internal.Void
42−import Data.Generics.Product.Internal.HList
40+import Data.Generics.Product.Internal.List
43import Data.Generics.Internal.VL.Prism
41import Data.Generics.Internal.VL.Prism
44import Data.Generics.Internal.Profunctor.Iso
42import Data.Generics.Internal.Profunctor.Iso
45−import Data.Generics.Internal.Profunctor.Prism (prismPRavel)
46
43
47-- $setup
44-- $setup
48-- >>> :set -XTypeApplications
45-- >>> :set -XTypeApplications
49-- >>> :set -XDataKinds
46-- >>> :set -XDataKinds
50-- >>> :set -XDeriveGeneric
47-- >>> :set -XDeriveGeneric
51-- >>> import GHC.Generics
48-- >>> import GHC.Generics
52−-- >>> :m +Data.Generics.Internal.VL.Prism
49+-- >>> :m +Data.Generics.Internal.Lens
53-- >>> :{
50-- >>> :{
54-- data Animal
51-- data Animal
55-- = Dog Dog
52-- = Dog Dog
@@ -90,8 +87,6 @@ class AsType a s where
90 -- ... Turtle
87 -- ... Turtle
91 -- ...
88 -- ...
92 _Typed :: Prism' s a
89 _Typed :: Prism' s a
93− _Typed = prism injectTyped (\i -> maybe (Left i) Right (projectTyped i))
94− {-# INLINE[2] _Typed #-}
95
90
96 -- |Inject by type.
91 -- |Inject by type.
97 injectTyped :: a -> s
92 injectTyped :: a -> s
@@ -101,9 +96,7 @@ class AsType a s where
101 -- |Project by type.
96 -- |Project by type.
102 projectTyped :: s -> Maybe a
97 projectTyped :: s -> Maybe a
103 projectTyped
98 projectTyped
104− = either (const Nothing) Just . match _Typed
99+ = either (const Nothing) Just . (match _Typed)
105−
106− {-# MINIMAL (injectTyped, projectTyped) | _Typed #-}
107
100
108instance
101instance
109 ( Generic s
102 ( Generic s
@@ -111,45 +104,16 @@ instance
111 , as ~ TupleToList a
104 , as ~ TupleToList a
112 , ListTuple a as
105 , ListTuple a as
113 , GAsType (Rep s) as
106 , GAsType (Rep s) as
114− , Defined (Rep s)
115− (NoGeneric s '[ 'Text "arising from a generic prism focusing on a constructor of type " ':<>: QuoteType a])
116− (() :: Constraint)
117 ) => AsType a s where
107 ) => AsType a s where
118
108
119− _Typed eta = prismRavel (prismPRavel (repIso . _GTyped @_ @as . tupled)) eta
109+ _Typed = prismRavel (repIso . _GTyped @_ @as . tupled)
120− {-# INLINE[2] _Typed #-}
110+ {-# INLINE _Typed #-}
121
111
122−-- | See Note [Uncluttering type signatures]
112+-- See Note [Uncluttering type signatures]
123−#if __GLASGOW_HASKELL__ < 804
124−-- >>> :t _Typed
125−-- _Typed
126−-- :: (Applicative f, Data.Profunctor.Choice.Choice p, AsType a s) =>
127−-- p a (f a) -> p s (f s)
128−#else
129−-- >>> :t _Typed
130−-- _Typed
131−-- :: (AsType a s, Data.Profunctor.Choice.Choice p, Applicative f) =>
132−-- p a (f a) -> p s (f s)
133−#endif
134instance {-# OVERLAPPING #-} AsType a Void where
113instance {-# OVERLAPPING #-} AsType a Void where
135 _Typed = undefined
114 _Typed = undefined
136 injectTyped = undefined
115 injectTyped = undefined
137 projectTyped = undefined
116 projectTyped = undefined
138−
139−-- | See Note [Uncluttering type signatures]
140−#if __GLASGOW_HASKELL__ < 804
141−-- >>> :t _Typed @Int
142−-- _Typed @Int
143−-- :: (Applicative f, Data.Profunctor.Choice.Choice p,
144−-- AsType Int s) =>
145−-- p Int (f Int) -> p s (f s)
146−#else
147−-- >>> :t _Typed @Int
148−-- _Typed @Int
149−-- :: (AsType Int s, Data.Profunctor.Choice.Choice p,
150−-- Applicative f) =>
151−-- p Int (f Int) -> p s (f s)
152−#endif
153instance {-# OVERLAPPING #-} AsType Void a where
117instance {-# OVERLAPPING #-} AsType Void a where
154 _Typed = undefined
118 _Typed = undefined
155 injectTyped = undefined
119 injectTyped = undefined
src/Data/Generics/Wrapped.hsdeleted−104
@@ -1,104 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE TypeApplications #-}
3−{-# language ConstraintKinds #-}
4−{-# language DataKinds #-}
5−{-# language FlexibleContexts #-}
6−{-# language FlexibleInstances #-}
7−{-# language FunctionalDependencies #-}
8−{-# language MultiParamTypeClasses #-}
9−{-# language ScopedTypeVariables #-}
10−{-# language TypeFamilies #-}
11−{-# language TypeOperators #-}
12−{-# language UndecidableInstances #-}
13−
14−-----------------------------------------------------------------------------
15−-- |
16−-- Module : Data.Generics.Wrapped
17−-- Copyright : (C) 2019 Csongor Kiss
18−-- License : BSD3
19−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20−-- Stability : experimental
21−-- Portability : non-portable
22−--
23−-- Derive an isomorphism between a newtype and its wrapped type.
24−--
25−-----------------------------------------------------------------------------
26−
27−module Data.Generics.Wrapped
28− ( Wrapped (..)
29− , wrappedTo
30− , wrappedFrom
31− , _Unwrapped
32− , _Wrapped
33− )
34−where
35−
36−import Control.Applicative (Const(..))
37−import Data.Generics.Internal.Profunctor.Iso
38−
39−import qualified Data.Generics.Internal.VL.Iso as VL
40−import Data.Generics.Internal.Families.Changing ( UnifyHead )
41−
42−import Data.Kind (Constraint)
43−import GHC.Generics
44−import GHC.TypeLits
45−
46−type family ErrorUnlessOnlyOne a b :: Constraint where
47− ErrorUnlessOnlyOne t (M1 i k a) = ErrorUnlessOnlyOne t a
48− ErrorUnlessOnlyOne t (K1 i a) = ()
49− ErrorUnlessOnlyOne t a =
50− TypeError ('ShowType t ':<>: 'Text " is not a single-constructor, single-field datatype")
51−
52−-- | @since 1.1.0.0
53−_Unwrapped :: Wrapped s t a b => VL.Iso s t a b
54−_Unwrapped = wrappedIso
55−{-# inline _Unwrapped #-}
56−
57−-- | @since 1.1.0.0
58−_Wrapped :: Wrapped s t a b => VL.Iso b a t s
59−_Wrapped = VL.fromIso wrappedIso
60−{-# inline _Wrapped #-}
61−
62−-- TODO: move this into doctets
63−
64−-- newtype FlippedEither a b = FlippedEither (Either b a)
65−-- deriving Generic
66−
67−-- test :: (a -> c) -> FlippedEither a b -> FlippedEither c b
68−-- test f = over wrappedIso (fmap f)
69−
70−class GWrapped s t a b | s -> a, t -> b, s b -> t, t a -> s where
71− gWrapped :: Iso (s x) (t x) a b
72−
73−instance GWrapped s t a b => GWrapped (M1 i k s) (M1 i k t) a b where
74− gWrapped = mIso . gWrapped
75−
76−instance (a ~ c, b ~ d) => GWrapped (K1 i a) (K1 i b) c d where
77− gWrapped = kIso
78−
79−-- | @since 1.1.0.0
80−class Wrapped s t a b | s -> a, t -> b where
81− -- | @since 1.1.0.0
82− wrappedIso :: VL.Iso s t a b
83−
84−-- | @since 1.1.0.0
85−wrappedTo :: forall s t a b. Wrapped s t a b => s -> a
86−wrappedTo a = view (wrappedIso @s @t @a @b) a
87− where view l s = getConst (l Const s)
88−{-# INLINE wrappedTo #-}
89−
90−-- | @since 1.1.0.0
91−wrappedFrom :: forall s t a b. Wrapped s t a b => b -> t
92−wrappedFrom a = view (VL.fromIso (wrappedIso @s @t @a @b)) a
93− where view l s = getConst (l Const s)
94−{-# INLINE wrappedFrom #-}
95−
96−instance
97− ( Generic s
98− , Generic t
99− , GWrapped (Rep s) (Rep t) a b
100− , UnifyHead s t
101− , UnifyHead t s
102− ) => Wrapped s t a b where
103− wrappedIso = iso2isovl (repIso . gWrapped)
104− {-# INLINE wrappedIso #-}
stack.yaml+4−1
@@ -1,8 +1,11 @@
1−resolver: nightly-2018-08-09
1+resolver: lts-10.3
2
2
3packages:
3packages:
4- '.'
4- '.'
5
5
6+extra-deps:
7+- 'inspection-testing-0.2'
8+
6flags: {}
9flags: {}
7
10
8extra-package-dbs: []
11extra-package-dbs: []
test/Test24.hs → test/24.hsrenamed+1−1
@@ -1,6 +1,6 @@
1{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications #-}
1{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications #-}
2
2
3−module Test24 where
3+module Main where
4
4
5-- Test case from #24, comments preserved
5-- Test case from #24, comments preserved
6import Control.Lens
6import Control.Lens
test/Test25.hs → test/25.hsrenamed+1−1
@@ -4,7 +4,7 @@
4{-# LANGUAGE DeriveGeneric #-}
4{-# LANGUAGE DeriveGeneric #-}
5{-# OPTIONS_GHC -Wall #-}
5{-# OPTIONS_GHC -Wall #-}
6
6
7−module Test25 where
7+module Main where
8
8
9import Control.Lens
9import Control.Lens
10import Data.Generics.Product
10import Data.Generics.Product
test/Bifunctor.hsdeleted−47
@@ -1,47 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DefaultSignatures #-}
3−{-# LANGUAGE DeriveAnyClass #-}
4−{-# LANGUAGE DeriveGeneric #-}
5−{-# LANGUAGE FlexibleContexts #-}
6−{-# LANGUAGE MonoLocalBinds #-}
7−{-# LANGUAGE StandaloneDeriving #-}
8−{-# LANGUAGE TypeApplications #-}
9−
10−module Main (main) where
11−
12−import Control.Lens hiding (Bifunctor(..))
13−import Control.Monad (void)
14−import Data.Generics.Product
15−import GHC.Generics
16−import Test.HUnit
17−
18−main :: IO ()
19−main = void $ runTestTT $
20− bimap (* 2) show mytree ~=? mytreeBimapped
21−
22−data Tree a w = Leaf a
23− | Fork (Tree a w) (Tree a w)
24− | WithWeight (Tree a w) w
25− deriving (Show, Eq, Generic)
26−
27−instance Bifunctor Tree where
28− bimap = gbimap
29−
30−mytree :: Tree Int Int
31−mytree = Fork (WithWeight (Leaf 42) 1)
32− (WithWeight (Fork (Leaf 88) (Leaf 37)) 2)
33−
34−mytreeBimapped :: Tree Int String
35−mytreeBimapped = Fork (WithWeight (Leaf 84) "1")
36− (WithWeight (Fork (Leaf 176) (Leaf 74)) "2")
37−
38−--------------------------------------------------------------------------------
39−
40−class Bifunctor p where
41− bimap :: (a -> c) -> (b -> d) -> p a b -> p c d
42−
43−gbimap ::
44− ( HasParam 0 (p a b) (p a d) b d
45− , HasParam 1 (p a d) (p c d) a c
46− ) => (a -> c) -> (b -> d) -> p a b -> p c d
47−gbimap f g s = s & param @0 %~ g & param @1 %~ f
test/CustomChildren.hsdeleted−63
@@ -1,63 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE KindSignatures #-}
5−{-# LANGUAGE MultiParamTypeClasses #-}
6−{-# LANGUAGE TypeApplications #-}
7−{-# LANGUAGE TypeFamilies #-}
8−{-# LANGUAGE UndecidableInstances #-}
9−
10−module CustomChildren
11− ( customTypesTest
12− ) where
13−
14−import GHC.Generics
15−import Data.Generics.Product
16−import Test.HUnit
17−import Data.Generics.Internal.VL.Lens
18−import Data.Generics.Labels ()
19−import Data.Kind
20−
21−-- Opaque has no Generic instance
22−data Opaque = Opaque String
23− deriving (Show, Eq)
24−
25−-- Hide does have a Generic instance, but we want to hide its contents
26−-- from the traversal
27−data Hide = Hide String
28− deriving (Show, Generic, Eq)
29−
30−-- We first define a symbol for the custom traversal
31−data Custom
32−
33−type instance Children Custom a = ChildrenCustom a
34−
35−type family ChildrenCustom (a :: Type) where
36− ChildrenCustom Opaque = '[String] -- here we state explicitly that Opaque contains a String
37− ChildrenCustom Hide = '[] -- and hide the contents of Hide
38− ChildrenCustom a = Children ChGeneric a -- for the rest, we defer to the generic children
39−
40−-- We define the traversal of Opaque like so:
41−instance HasTypesCustom Custom Opaque String where
42− typesCustom f (Opaque str) = Opaque <$> f str
43−
44−customTypesTest1 :: Test
45−customTypesTest1
46− = TestCase (assertEqual "foo" (over (typesUsing @Custom @String) (++ "!") original) expected)
47− where original = (Opaque "foo", Hide "bar")
48− expected = (Opaque "foo!", Hide "bar") -- only Opaque's String gets modified
49−
50−customTypesTest2 :: Test
51−customTypesTest2
52− = TestCase (assertEqual "foo" (over (typesUsing @Custom @String) (++ "!") original) expected)
53− where original = Opaque "foo"
54− expected = Opaque "foo!"
55−
56−customTypesTest3 :: Test
57−customTypesTest3
58− = TestCase (assertEqual "foo" (over (typesUsing @Custom @String) (++ "!") original) expected)
59− where original = Hide "foo"
60− expected = Hide "foo"
61−
62−customTypesTest :: Test
63−customTypesTest = TestList [customTypesTest1, customTypesTest2, customTypesTest3]
test/Spec.hs+17−133
@@ -1,8 +1,7 @@
1{-# OPTIONS_GHC -O -fplugin Test.Inspection.Plugin #-}
1{-# OPTIONS_GHC -O -fplugin Test.Inspection.Plugin #-}
2−{-# OPTIONS_GHC -dsuppress-all #-}
2+{-# OPTIONS_GHC -dsuppress-all #-}
3
3
4{-# LANGUAGE AllowAmbiguousTypes #-}
4{-# LANGUAGE AllowAmbiguousTypes #-}
5−{-# LANGUAGE CPP #-}
6{-# LANGUAGE DataKinds #-}
5{-# LANGUAGE DataKinds #-}
7{-# LANGUAGE DeriveGeneric #-}
6{-# LANGUAGE DeriveGeneric #-}
8{-# LANGUAGE DuplicateRecordFields #-}
7{-# LANGUAGE DuplicateRecordFields #-}
@@ -11,7 +10,6 @@
11{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE TypeApplications #-}
11{-# LANGUAGE TypeApplications #-}
13{-# LANGUAGE TemplateHaskell #-}
12{-# LANGUAGE TemplateHaskell #-}
14−{-# LANGUAGE OverloadedLabels #-}
15
13
16module Main where
14module Main where
17
15
@@ -25,15 +23,6 @@ import System.Exit
25import Data.Generics.Internal.VL.Lens
23import Data.Generics.Internal.VL.Lens
26import Data.Generics.Internal.VL.Prism
24import Data.Generics.Internal.VL.Prism
27import Data.Generics.Internal.VL.Traversal
25import Data.Generics.Internal.VL.Traversal
28−import Control.Lens (_1, (+~))
29−import Data.Function ((&))
30−import Data.Generics.Labels ()
31−
32−-- This is sufficient at we only want to test that they typecheck
33−import Test24 ()
34−import Test25 ()
35−
36−import CustomChildren (customTypesTest)
37
26
38main :: IO ()
27main :: IO ()
39main = do
28main = do
@@ -70,6 +59,8 @@ data Record5 = MkRecord5
70 , fieldF :: Int
59 , fieldF :: Int
71 } deriving Generic
60 } deriving Generic
72
61
62+
63+
73typeChangingManual :: Lens (Record3 a) (Record3 b) a b
64typeChangingManual :: Lens (Record3 a) (Record3 b) a b
74typeChangingManual f (MkRecord3 a b) = (\a' -> MkRecord3 a' b) <$> f a
65typeChangingManual f (MkRecord3 a b) = (\a' -> MkRecord3 a' b) <$> f a
75
66
@@ -97,36 +88,6 @@ subtypeLensManual f record
97data Sum1 = A Char | B Int | C () | D () deriving (Generic, Show)
88data Sum1 = A Char | B Int | C () | D () deriving (Generic, Show)
98data Sum2 = A2 Char | B2 Int deriving (Generic, Show)
89data Sum2 = A2 Char | B2 Int deriving (Generic, Show)
99
90
100−data Sum3 a b c
101− = A3 a a
102− | B3 String b a a b
103− | C3 c a Int
104− deriving Generic
105−
106−sum3Param0Derived :: Traversal (Sum3 a b xxx) (Sum3 a b yyy) xxx yyy
107−sum3Param0Derived = param @0
108−
109−sum3Param0Manual :: Traversal (Sum3 a b xxx) (Sum3 a b yyy) xxx yyy
110−sum3Param0Manual _ (A3 a1 a2) = pure (A3 a1 a2)
111−sum3Param0Manual _ (B3 s b1 a1 a2 b2) = pure (B3 s b1 a1 a2 b2)
112−sum3Param0Manual f (C3 c a i) = pure (\c' -> C3 c' a i) <*> f c
113−
114−sum3Param1Derived :: Traversal (Sum3 a xxx c) (Sum3 a yyy c) xxx yyy
115−sum3Param1Derived = param @1
116−
117−sum3Param1Manual :: Traversal (Sum3 a xxx c) (Sum3 a yyy c) xxx yyy
118−sum3Param1Manual _ (A3 a1 a2) = pure (A3 a1 a2)
119−sum3Param1Manual f (B3 s b1 a1 a2 b2) = pure (\b1' b2' -> B3 s b1' a1 a2 b2') <*> f b1 <*> f b2
120−sum3Param1Manual _ (C3 c a i) = pure (C3 c a i)
121−
122−sum3Param2Derived :: Traversal (Sum3 xxx b c) (Sum3 yyy b c) xxx yyy
123−sum3Param2Derived = param @2
124−
125−sum3Param2Manual :: Traversal (Sum3 xxx b c) (Sum3 yyy b c) xxx yyy
126−sum3Param2Manual f (A3 a1 a2) = pure (\a1' a2' -> A3 a1' a2') <*> f a1 <*> f a2
127−sum3Param2Manual f (B3 s b1 a1 a2 b2) = pure (\a1' a2' -> B3 s b1 a1' a2' b2) <*> f a1 <*> f a2
128−sum3Param2Manual f (C3 c a i) = pure (\a' -> C3 c a' i) <*> f a
129−
130sum1PrismManual :: Prism Sum1 Sum1 Int Int
91sum1PrismManual :: Prism Sum1 Sum1 Int Int
131sum1PrismManual eta = prism g f eta
92sum1PrismManual eta = prism g f eta
132 where
93 where
@@ -135,42 +96,14 @@ sum1PrismManual eta = prism g f eta
135 s -> Left s
96 s -> Left s
136 g = B
97 g = B
137
98
138−sum1PrismManualChar :: Prism Sum1 Sum1 Char Char
139−sum1PrismManualChar eta = prism g f eta
140− where
141− f s1 = case s1 of
142− A i -> Right i
143− B _ -> Left s1
144− C _ -> Left s1
145− D _ -> Left s1
146− g = A
147−
148−sum2PrismManual :: Prism Sum2 Sum2 Int Int
149−sum2PrismManual eta = prism g f eta
150− where
151− f s1 = case s1 of
152− B2 i -> Right i
153− s -> Left s
154− g = B2
155−
156−
157−sum2PrismManualChar :: Prism Sum2 Sum2 Char Char
158−sum2PrismManualChar eta = prism g f eta
159− where
160− f s1 = case s1 of
161− A2 i -> Right i
162− s -> Left s
163− g = A2
164−
165−-- Note we don't have a catch-all case because of #14684
166subtypePrismManual :: Prism Sum1 Sum1 Sum2 Sum2
99subtypePrismManual :: Prism Sum1 Sum1 Sum2 Sum2
167subtypePrismManual eta = prism g f eta
100subtypePrismManual eta = prism g f eta
168 where
101 where
169 f s1 = case s1 of
102 f s1 = case s1 of
170 A c -> Right (A2 c)
103 A c -> Right (A2 c)
171 B i -> Right (B2 i)
104 B i -> Right (B2 i)
172− C _ -> Left s1
105+ C _ -> Left s1
173− D _ -> Left s1
106+ D _ -> Left s1
174 g (A2 c) = A c
107 g (A2 c) = A c
175 g (B2 i) = B i
108 g (B2 i) = B i
176
109
@@ -185,32 +118,23 @@ subtypePrismManual eta = prism g f eta
185fieldALensName :: Lens' Record Int
118fieldALensName :: Lens' Record Int
186fieldALensName = field @"fieldA"
119fieldALensName = field @"fieldA"
187
120
188−fieldALensName_ :: Lens' Record Int
189−fieldALensName_ = field_ @"fieldA"
190−
191fieldALensType :: Lens' Record Int
121fieldALensType :: Lens' Record Int
192fieldALensType = typed @Int
122fieldALensType = typed @Int
193
123
194fieldALensPos :: Lens' Record Int
124fieldALensPos :: Lens' Record Int
195fieldALensPos = position @1
125fieldALensPos = position @1
196
126
197−fieldALensPos_ :: Lens' Record Int
198−fieldALensPos_ = position_ @1
199−
200subtypeLensGeneric :: Lens' Record Record2
127subtypeLensGeneric :: Lens' Record Record2
201subtypeLensGeneric = super
128subtypeLensGeneric = super
202
129
203typeChangingGeneric :: Lens (Record3 a) (Record3 b) a b
130typeChangingGeneric :: Lens (Record3 a) (Record3 b) a b
204−typeChangingGeneric = #fieldA
131+typeChangingGeneric = field @"fieldA"
205
132
206typeChangingGenericPos :: Lens (Record3 a) (Record3 b) a b
133typeChangingGenericPos :: Lens (Record3 a) (Record3 b) a b
207typeChangingGenericPos = position @1
134typeChangingGenericPos = position @1
208
135
209typeChangingGenericCompose :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b
136typeChangingGenericCompose :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b
210−typeChangingGenericCompose = #fieldA . #fieldA
137+typeChangingGenericCompose = field @"fieldA" . field @"fieldA"
211−
212−typeChangingGenericCompose_ :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b
213−typeChangingGenericCompose_ = field_ @"fieldA" . field_ @"fieldA"
214
138
215sum1PrismB :: Prism Sum1 Sum1 Int Int
139sum1PrismB :: Prism Sum1 Sum1 Int Int
216sum1PrismB = _Ctor @"B"
140sum1PrismB = _Ctor @"B"
@@ -221,56 +145,16 @@ subtypePrismGeneric = _Sub
221sum1TypePrism :: Prism Sum1 Sum1 Int Int
145sum1TypePrism :: Prism Sum1 Sum1 Int Int
222sum1TypePrism = _Typed @Int
146sum1TypePrism = _Typed @Int
223
147
224−sum1TypePrismChar :: Prism Sum1 Sum1 Char Char
225−sum1TypePrismChar = _Typed @Char
226−
227−sum2TypePrism :: Prism Sum2 Sum2 Int Int
228−sum2TypePrism = _Typed @Int
229−
230−sum2TypePrismChar :: Prism Sum2 Sum2 Char Char
231−sum2TypePrismChar = _Typed @Char
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−
239tests :: Test
148tests :: Test
240tests = TestList $ map mkHUnitTest
149tests = TestList $ map mkHUnitTest
241− [ $(inspectTest $ 'fieldALensManual === 'fieldALensName)
150+ [ $(inspectTest $ 'fieldALensManual === 'fieldALensName)
242− , $(inspectTest $ 'fieldALensManual === 'fieldALensName_)
151+ , $(inspectTest $ 'fieldALensManual === 'fieldALensType)
243− , $(inspectTest $ 'fieldALensManual === 'fieldALensType)
244− , $(inspectTest $ 'fieldALensManual === 'fieldALensPos)
152+ , $(inspectTest $ 'fieldALensManual === 'fieldALensPos)
245− , $(inspectTest $ 'fieldALensManual === 'fieldALensPos_)
246− , $(inspectTest $ 'subtypeLensManual === 'subtypeLensGeneric)
153+ , $(inspectTest $ 'subtypeLensManual === 'subtypeLensGeneric)
247− , $(inspectTest $ 'typeChangingManual === 'typeChangingGeneric)
154+ , $(inspectTest $ 'typeChangingManual === 'typeChangingGeneric)
248− , $(inspectTest $ 'typeChangingManual === 'typeChangingGenericPos)
155+ , $(inspectTest $ 'typeChangingManual === 'typeChangingGenericPos)
249 , $(inspectTest $ 'typeChangingManualCompose === 'typeChangingGenericCompose)
156 , $(inspectTest $ 'typeChangingManualCompose === 'typeChangingGenericCompose)
250− , $(inspectTest $ 'typeChangingManualCompose === 'typeChangingGenericCompose_)
157+ , $(inspectTest $ 'intTraversalManual === 'intTraversalDerived)
251− , $(inspectTest $ 'sum1PrismManual === 'sum1PrismB)
158+ , $(inspectTest $ 'sum1PrismManual === 'sum1PrismB)
252− , $(inspectTest $ 'subtypePrismManual === 'subtypePrismGeneric)
159+ , $(inspectTest $ 'subtypePrismManual === 'subtypePrismGeneric)
253− , $(inspectTest $ 'sum2PrismManualChar === 'sum2TypePrismChar)
160+ , $(inspectTest $ 'sum1PrismManual === 'sum1TypePrism) ]
254− , $(inspectTest $ 'sum2PrismManual === 'sum2TypePrism)
255− , $(inspectTest $ 'sum1PrismManualChar === 'sum1TypePrismChar)
256− , $(inspectTest $ 'sum2PrismManualChar === 'sum2TypePrismChar)
257− , $(inspectTest $ 'sum1PrismManual === 'sum1TypePrism)
258− --, $(inspectTest $ 'intTraversalManual === 'intTraversalDerived)
259− --, $(inspectTest $ 'sum3Param0Manual === 'sum3Param0Derived)
260− -- TODO [1.0.0.0]: these tests pass with the new implementation
261−-- , $(inspectTest $ 'sum3Param1Manual === 'sum3Param1Derived)
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
273− ]
274− where valLabel = RecB 3 True
275−
276−-- TODO: add test for traversals over multiple types
test/Test40.hsdeleted−22
@@ -1,22 +0,0 @@
1−{-# LANGUAGE TypeFamilies #-}
2−{-# LANGUAGE TypeApplications #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE DeriveGeneric #-}
5−{-# OPTIONS_GHC -Wall #-}
6−
7−module Test40 where
8−
9−import Data.Generics.Product
10−import GHC.Generics
11−
12−class MyClass a where
13− data AssocData a
14−
15−instance MyClass Int where
16− data AssocData Int = SomeData
17− { val :: Int
18− } deriving (Generic)
19−
20−main :: IO ()
21−main
22− = print $ getField @"val" (SomeData 3)
test/Test62.hsdeleted−20
@@ -1,20 +0,0 @@
1−{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications #-}
2−module Test62 (example, example_) where
3−import Data.Generics.Product (field, field_, position, position_)
4−import Data.Generics.Internal.VL.Lens (set)
5−import GHC.Generics (Generic)
6−
7−data Foo a = Foo { bar :: Bar a } deriving Generic
8−data Bar a = Bar { x :: a, y :: a } deriving Generic
9−
10−example :: Foo ()
11−example =
12− set (field @"bar" . position @1) ()
13− . set (position @1 . field @"y") ()
14− $ Foo{ bar = Bar{ x = (), y = () } }
15−
16−example_ :: Foo ()
17−example_ =
18− set (field_ @"bar" . position_ @1) ()
19− . set (position_ @1 . field_ @"y") ()
20− $ Foo{ bar = Bar{ x = (), y = () } }
test/Test63.hsdeleted−12
@@ -1,12 +0,0 @@
1−{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications #-}
2−module Test63 (example) where
3−import Data.Generics.Product (types)
4−import Data.Generics.Internal.VL.Lens (over)
5−import Data.Word (Word32)
6−import GHC.Generics (Generic)
7−
8−data Record = Record {field1 :: Word32, field2 :: Int}
9− deriving (Generic, Show)
10−
11−example :: Record
12−example = over (types @Int) (+1) (Record 0 0)
test/Test71.hsdeleted−17
@@ -1,17 +0,0 @@
1−{-# LANGUAGE FlexibleContexts, DeriveGeneric, TypeApplications #-}
2−
3−module Test71 where
4−
5−import GHC.Generics
6−import Control.Lens
7−import Data.Generics.Product
8−
9−data Foobar = Foobar Int Char String
10− deriving Generic
11−
12−foo :: HasType Foobar ctx => ctx -> Char
13−foo ctx = case view (typed @Foobar) ctx of
14− Foobar _ c _ -> c
15−
16−bar :: Char
17−bar = foo (Foobar 3 'a' "Hello")
test/doctest.hs−1
@@ -4,5 +4,4 @@ main
4 [ "-isrc"
4 [ "-isrc"
5 , "src/Data/Generics/Product.hs"
5 , "src/Data/Generics/Product.hs"
6 , "src/Data/Generics/Sum.hs"
6 , "src/Data/Generics/Sum.hs"
7− , "src/Data/Generics/Labels.hs"
8 ]
7 ]
test/syb/Tree.hsdeleted−76
@@ -1,76 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4−{-# LANGUAGE TypeApplications #-}
5−
6−{-
7−Example adapted from SYB
8−========================
9−-}
10−
11−module Main (main) where
12−
13−import Control.Lens
14−import Control.Monad (void)
15−import Data.Generics.Product
16−import GHC.Generics
17−import Test.HUnit
18−
19−main :: IO ()
20−main = void $ runTestTT tests
21−
22−-- A parameterised datatype for binary trees with data at the leafs
23−data Tree a w = Leaf a
24− | Fork (Tree a w) (Tree a w)
25− | WithWeight (Tree a w) w
26− deriving (Show, Generic, Eq)
27−
28−-- A typical tree
29−mytree :: Tree Int Int
30−mytree = Fork (WithWeight (Leaf 42) 1)
31− (WithWeight (Fork (Leaf 88) (Leaf 37)) 2)
32−
33−mytreeShown :: Tree String Int
34−mytreeShown = Fork (WithWeight (Leaf "42") 1)
35− (WithWeight (Fork (Leaf "88") (Leaf "37")) 2)
36−
37−-- A polymorphic-recursive structure
38−data Poly a b
39− = PNil
40− | PCons a (Poly b a)
41− deriving (Show, Generic)
42−
43−poly :: Poly Int String
44−poly = PCons 10 (PCons "hello" (PCons 20 (PCons "world" PNil)))
45−
46−-- Print everything like an Int in mytree
47−-- In fact, we show two attempts:
48−-- 1. print really just everything like an Int
49−-- 2. print everything wrapped with Leaf
50−-- So (1.) confuses leafs and weights whereas (2.) does not.
51−tests :: Test
52−tests = TestList
53− [ toListOf (types @Int) mytree ~=? [42,1,88,37,2]
54− , toListOf (param @1) mytree ~=? [42,88,37]
55−
56− -- Things not (easily) doable in SYB:
57− -- change type of Tree by mapping a function over the second (from the right) param
58− , (mytree & param @1 %~ show) ~=? mytreeShown
59− -- collect values in poly corresponding to the first param
60− , toListOf (param @0) poly ~=? ["hello", "world"]
61− -- collect all Ints inside poly
62− , toListOf (types @Int) poly ~=? [10, 20]
63− -- map length over the Strings, then collect all Ints
64− , toListOf (types @Int) (poly & param @0 %~ length) ~=? [10, 5, 20, 5]
65− -- map length over the Strings, then collect all the resulting Ints
66− , toListOf (param @0) (poly & param @0 %~ length) ~=? [5,5]
67− ]
68−
69−-- original code from SYB:
70−--tests = show ( listify (\(_::Int) -> True) mytree
71−-- , everything (++) ([] `mkQ` fromLeaf) mytree
72−-- ) ~=? output
73−-- where
74−-- fromLeaf :: Tree Int Int -> [Int]
75−-- fromLeaf (Leaf x) = [x]
76−-- fromLeaf _ = []