on master help sign in
.github/FUNDING.ymlnew file+12
since splitsnapshots
unifiedsplit
@@ -0,0 +1,12 @@
1+# These are supported funding model platforms
2+
3+github: [kcsongor] # Replace with up to 4 GitHub Sponsors-enabled usernames e.g., [user1, user2]
4+patreon: # Replace with a single Patreon username
5+open_collective: # Replace with a single Open Collective username
6+ko_fi: # Replace with a single Ko-fi username
7+tidelift: # Replace with a single Tidelift platform-name/package-name e.g., npm/babel
8+community_bridge: # Replace with a single Community Bridge project-name e.g., cloud-foundry
9+liberapay: # Replace with a single Liberapay username
10+issuehunt: # Replace with a single IssueHunt username
11+otechie: # Replace with a single Otechie username
12+custom: # Replace with up to 4 custom sponsorship URLs e.g., ['link1', 'link2']
.gitignore+4
@@ -6,3 +6,7 @@ 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
.gitmodulesdeleted−4
@@ -1,4 +0,0 @@
1−[submodule "inspection-testing"]
2− path = inspection-testing
3− url = https://github.com/nomeata/inspection-testing.git
4− branch = master
.travis.yml+132−69
@@ -1,92 +1,155 @@
1# This Travis job script has been generated by a script via
1# This Travis job script has been generated by a script via
2#
2#
3−# make_travis_yml_2.hs 'generic-lens.cabal'
3+# haskell-ci '--config=cabal.haskell-ci' 'cabal.project'
4#
4#
5−# For more information, see https://github.com/hvr/multi-ghc-travis
5+# For more information, see https://github.com/haskell-CI/haskell-ci
6+#
7+# version: 0.5.20190908
6#
8#
7language: c
9language: c
8−sudo: false
10+dist: xenial
9−
10git:
11git:
11− submodules: true # whether to recursively clone submodules
12+ # whether to recursively clone submodules
12−
13+ submodules: false
13cache:
14cache:
14 directories:
15 directories:
15 - $HOME/.cabal/packages
16 - $HOME/.cabal/packages
16 - $HOME/.cabal/store
17 - $HOME/.cabal/store
17−
18before_cache:
18before_cache:
19− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
19+ - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log
20 # remove files that are regenerated by 'cabal update'
20 # remove files that are regenerated by 'cabal update'
21− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*
21+ - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*
22− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json
22+ - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json
23− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache
23+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache
24− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar
24+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar
25− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx
25+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx
26−
26+ - rm -rfv $CABALHOME/packages/head.hackage
27matrix:
27matrix:
28 include:
28 include:
29− - compiler: "ghc-8.0.2"
29+ - compiler: ghc-8.8.1
30− # env: TEST=--disable-tests BENCH=--disable-benchmarks
31− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.2], sources: [hvr-ghc]}}
30+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}}
32− - compiler: "ghc-8.2.1"
31+ - compiler: ghc-8.6.5
33− # env: TEST=--disable-tests BENCH=--disable-benchmarks
32+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-3.0"]}}
33+ - compiler: ghc-8.4.4
34− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.1], sources: [hvr-ghc]}}
34+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-3.0"]}}
35+ - compiler: ghc-8.4.1
36+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.1","cabal-install-3.0"]}}
35− - compiler: "ghc-8.2.2"
37+ - compiler: ghc-8.2.2
36− # env: TEST=--disable-tests BENCH=--disable-benchmarks
37− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.2], sources: [hvr-ghc]}}
38+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-3.0"]}}
38−
39+ - compiler: ghc-8.0.2
40+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-3.0"]}}
39before_install:
41before_install:
40− - HC=${CC}
42+ - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')
43+ - WITHCOMPILER="-w $HC"
44+ - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//')
41− - HCPKG=${HC/ghc/ghc-pkg}
45+ - HCPKG="$HC-pkg"
42 - unset CC
46 - unset CC
43− - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH
47+ - CABAL=/opt/ghc/bin/cabal
44−
48+ - CABALHOME=$HOME/.cabal
49+ - export PATH="$CABALHOME/bin:$PATH"
50+ - TOP=$(pwd)
51+ - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')"
52+ - echo $HCNUMVER
53+ - CABAL="$CABAL -vnormal+nowrap+markoutput"
54+ - set -o pipefail
55+ - |
56+ echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk
57+ echo 'BEGIN { state = "output"; }' >> .colorful.awk
58+ echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk
59+ echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk
60+ echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk
61+ echo ' if (state == "cabal") {' >> .colorful.awk
62+ echo ' print blue($0)' >> .colorful.awk
63+ echo ' } else {' >> .colorful.awk
64+ echo ' print $0' >> .colorful.awk
65+ echo ' }' >> .colorful.awk
66+ echo '}' >> .colorful.awk
67+ - cat .colorful.awk
68+ - |
69+ color_cabal_output () {
70+ awk -f $TOP/.colorful.awk
71+ }
72+ - echo text | color_cabal_output
45install:
73install:
46− - cabal --version
74+ - ${CABAL} --version
47 - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
75 - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
76+ - TEST=--enable-tests
77+ - if [ $HCNUMVER -ge 80600 ] ; then TEST=--disable-tests ; fi
48− - BENCH=${BENCH---enable-benchmarks}
78+ - BENCH=--enable-benchmarks
49− - TEST=${TEST---enable-tests}
79+ - if [ $HCNUMVER -ge 80800 ] ; then BENCH=--disable-benchmarks ; fi
50− - HADDOCK=${HADDOCK-true}
80+ - HEADHACKAGE=false
51− - INSTALLED=${INSTALLED-true}
81+ - rm -f $CABALHOME/config
82+ - |
83+ echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config
84+ echo "remote-build-reporting: anonymous" >> $CABALHOME/config
85+ echo "write-ghc-environment-files: always" >> $CABALHOME/config
86+ echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config
87+ echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config
88+ echo "world-file: $CABALHOME/world" >> $CABALHOME/config
89+ echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config
90+ echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config
91+ echo "installdir: $CABALHOME/bin" >> $CABALHOME/config
92+ echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config
93+ echo "store-dir: $CABALHOME/store" >> $CABALHOME/config
94+ echo "install-dirs user" >> $CABALHOME/config
95+ echo " prefix: $CABALHOME" >> $CABALHOME/config
96+ echo "repository hackage.haskell.org" >> $CABALHOME/config
97+ echo " url: http://hackage.haskell.org/" >> $CABALHOME/config
98+ - |
99+ echo "program-default-options" >> $CABALHOME/config
100+ echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config
101+ - cat $CABALHOME/config
102+ - rm -fv cabal.project cabal.project.local cabal.project.freeze
52− - travis_retry cabal update -v
103+ - travis_retry ${CABAL} v2-update -v
53− - sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
104+ # Generate cabal.project
105+ - rm -rf cabal.project cabal.project.local cabal.project.freeze
106+ - touch cabal.project
107+ - |
54− - rm -fv cabal.project.local
108+ echo "packages: ." >> cabal.project
55− - "echo 'packages: .' > cabal.project"
109+ - |
110+ - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(generic-lens)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
111+ - cat cabal.project || true
112+ - cat cabal.project.local || true
56− - if [ -f "./configure.ac" ]; then
113+ - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi
57− (cd "."; autoreconf -i);
114+ - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output
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
61− - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all
118+ - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all | color_cabal_output
62− - rm -rf "."/.ghc.environment.* "."/dist
63− - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
64−
65−# Here starts the actual work to be performed for the package under test;
66−# any command which exits with a non-zero exit code causes the build to fail.
67script:
119script:
68− # test that source-distributions can be generated
120+ - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
69− - (cd "."; cabal sdist)
121+ # Packaging...
122+ - ${CABAL} v2-sdist all | color_cabal_output
123+ # Unpacking...
70− - mv "."/dist/generic-lens-*.tar.gz ${DISTDIR}/
124+ - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
71− - mv "."/inspection-testing ${DISTDIR}/inspection-testing
125+ - cd ${DISTDIR} || false
72− - cd ${DISTDIR}
73− - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;
126+ - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \;
74− - "printf 'packages: generic-lens-*/*.cabal\noptional-packages: inspection-testing/*.cabal\n' > cabal.project"
127+ - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \;
128+ - PKGDIR_generic_lens="$(find . -maxdepth 1 -type d -regex '.*/generic-lens-[0-9.]*')"
129+ # Generate cabal.project
130+ - rm -rf cabal.project cabal.project.local cabal.project.freeze
131+ - touch cabal.project
132+ - |
133+ echo "packages: ${PKGDIR_generic_lens}" >> cabal.project
134+ - |
135+ - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(generic-lens)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
136+ - cat cabal.project || true
137+ - cat cabal.project.local || true
138+ # Building...
75 # this builds all libraries and executables (without tests/benchmarks)
139 # this builds all libraries and executables (without tests/benchmarks)
76− - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all
140+ - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output
77−
141+ # Building with tests and benchmarks...
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−
83 # build & run tests, build benchmarks
142 # build & run tests, build benchmarks
84− - cabal new-build -w ${HC} ${TEST} ${BENCH} all
143+ - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output
85− - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} all; fi
144+ # Testing...
86−
145+ - if [ $HCNUMVER -lt 80600 ] ; then ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi
87− # haddock
146+ # cabal check...
88− - rm -rf ./dist-newstyle
147+ - (cd ${PKGDIR_generic_lens} && ${CABAL} -vnormal check)
89− - if $HADDOCK; then cabal new-haddock -w ${HC} --disable-tests --disable-benchmarks all; else echo "Skipping haddock generation";fi
148+ # haddock...
149+ - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all | color_cabal_output
150+ # Building without installed constraints for packages in global-db...
151+ - rm -f cabal.project.local
152+ - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output
90
153
91−# REGENDATA ["generic-lens.cabal"]
154+# REGENDATA ["--config=cabal.haskell-ci","cabal.project"]
92# EOF
155# EOF
ChangeLog.md+35
@@ -1,3 +1,38 @@
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+
1## 0.5.1.0
36## 0.5.1.0
2- Infer input type from result type (#25)
37- Infer input type from result type (#25)
3- Allow changing of multiple type parameters (#24)
38- Allow changing of multiple type parameters (#24)
LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2017, Csongor Kiss
1+Copyright (c) 2019, Csongor Kiss
2
2
3All rights reserved.
3All rights reserved.
4
4
README.md+238−78
@@ -3,26 +3,69 @@
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 lenses and prisms for data types.
6+Generically derive traversals, lenses and prisms.
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 package uses the GHC 8 `Generic` representation to derive various operations
10+This library uses `GHC.Generics` to derive efficient optics (traversals, lenses
11−on data structures with lens interfaces, including structural subtype
11+and prisms) for algebraic data types in a type-directed way, with a focus on
12−relationships between records and positional indexing into arbitrary product
12+good type inference and error messages when possible.
13−types.
13+
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 #-}
14
55
15−This is made possible by GHC 8's new Generics API, which provides metadata
56+```
16−at the type-level (previously only value-level metadata was available).
17
57
18−Examples can be found in the `examples` folder. This library makes heavy use of
58+# Taxonomy of optics
19−[Visible Type Applications](https://ghc.haskell.org/trac/ghc/wiki/TypeApplication).
59+Here is a comprehensive list of the optics exposed by `generic-lens`. The
60+combinators each allow a different way of identifying certain parts of
61+algebraic data types.
20
62
21## Lenses
63## Lenses
22
64
23−### Record fields
65+A lens identifies exactly one part of a product type, and allows querying and
66+updating it.
24
67
25−Record fields can be accessed by their label:
68+### By name
26
69
27```haskell
70```haskell
28data Person = Person { name :: String, age :: Int } deriving (Generic, Show)
71data Person = Person { name :: String, age :: Int } deriving (Generic, Show)
@@ -31,42 +74,83 @@ sally :: Person
31sally = Person "Sally" 25
74sally = Person "Sally" 25
32```
75```
33
76
34−```haskell
77+Record fields can be accessed by their label using the `field` lens.
35−>>> getField @"age" sally
36−25
37−
38−>>> setField @"age" 26 sally
39−Person {name = "Sally", age = 26}
40
78
79+```haskell
41>>> sally ^. field @"name"
80>>> sally ^. field @"name"
42"Sally"
81"Sally"
43
82
44>>> sally & field @"name" .~ "Tamas"
83>>> sally & field @"name" .~ "Tamas"
45Person {name = "Tamas", age = 25}
84Person {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.
46
90
91+Or for standalone use, the `getField` and `setField` functions can be used instead.
92+```haskell
93+>>> getField @"age" sally
94+25
95+
96+>>> setField @"age" 26 sally
97+Person {name = "Sally", age = 26}
98+```
99+
100+When a non-existent field is requested, the library generates a helpful type error:
101+```haskell
47>>> sally ^. field @"pet"
102>>> sally ^. field @"pet"
48error:
103error:
49− • The type Person does not contain a field named "pet"
104+ • The type Person does not contain a field named 'pet'
50```
105```
51
106
52−If the accessed field is a type parameter that appears uniquely in the type,
107+For types with multiple constructors, we can still use `field` as long as all constructors contain the required field
53−then its type can be changed:
108+```haskell
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+```
54
124
125+The type of `field` is
55```haskell
126```haskell
56−data T a b c d = T
127+field :: HasField name s t a b => Lens s t a b
57− { paramA :: a
128+```
58− , paramB :: b
129+Therefore it allows polymorphic (type-changing) updates, when the accessed field mentions type parameters.
59− , paramC :: c
60− , paramD :: d
61− }
62− deriving (Generic, Show)
63
130
64−>>> t = T "a" (10 :: Int) 'c' False
131+```haskell
65−>>> t & field @"paramA" .~ 'a' & field @"paramB" .~ False
132+data Foo f a = Foo
66−T {paramA = 'a', paramB = False, paramC = 'c', paramD = False}
133+ { foo :: f a
134+ } deriving (Generic, Show)
135+
136+foo1 :: Foo Maybe Int
137+foo1 = Foo (Just 10)
138+
139+-- |
140+-- >>> foo2
141+-- Foo {foo = ["10"]}
142+foo2 :: Foo [] String
143+foo2 = foo1 & field @"foo" %~ (maybeToList . fmap show)
67```
144```
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!
68
152
69−### Positional fields
153+### By position
70
154
71Fields can be accessed by their position in the data structure (index starting at 1):
155Fields can be accessed by their position in the data structure (index starting at 1):
72
156
@@ -79,12 +163,6 @@ polygon = Polygon (Point 1 5 3) (Point 2 4 2) (Point 5 7 (-2))
79```
163```
80
164
81```haskell
165```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−
88>>> polygon ^. position @1 . position @2
166>>> polygon ^. position @1 . position @2
895
1675
90
168
@@ -96,49 +174,34 @@ error:
96 • The type Polygon does not contain a field at position 10
174 • The type Polygon does not contain a field at position 10
97```
175```
98
176
99−Since tuples are an instance of `Generic`, they also have positional lenses:
177+Since tuples are an instance of `Generic`, the positional lens readily works:
100
178
101```haskell
179```haskell
102>>> (("hello", True), 5) ^. position @1 . position @2
180>>> (("hello", True), 5) ^. position @1 . position @2
103True
181True
182+>>> (("hello", True, "or"), 5, "even", "longer") ^. position @1 . position @2
183+True
104```
184```
105
185
106−### Typed fields
186+### By type
107
187
108Fields can be accessed by their type in the data structure, assuming that this
188Fields can be accessed by their type in the data structure, assuming that this
109type is unique:
189type is unique:
110
190
111```haskell
191```haskell
112−data Person = Person { name :: String, age :: Int } deriving (Generic, Show)
192+>>> sally ^. typed @String
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
124"Sally"
193"Sally"
125
194
126>>> setTyped @Int sally 26
195>>> setTyped @Int sally 26
127Person {name = "Sally", age = 26}
196Person {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]
136```
197```
137
198
138−### Structural subtyping
199+### By structure
139
200
201+The `super` lens generalises the `field` lens to focus on a collection rather
202+than a single field.
140−A record is a (structural) `subtype' of another, if its fields are a superset of
203+We can say that a record is a (structural) `subtype' of another, if its fields
141−those of the other.
204+are a superset of those of the other.
142
205
143```haskell
206```haskell
144data Human = Human
207data Human = Human
@@ -157,16 +220,10 @@ human = Human {name = "Tunyasz", age = 50, address = "London"}
157```
220```
158
221
159```haskell
222```haskell
160−
161−>>> upcast human :: Animal
223+>>> human ^. super @Animal
162Animal {name = "Tunyasz", age = 50}
224Animal {name = "Tunyasz", age = 50}
163
225
164−-- 'smash' plug the smaller structure into the larger one
226+>>> upcast human :: Animal
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
170Animal {name = "Tunyasz", age = 50}
227Animal {name = "Tunyasz", age = 50}
171```
228```
172
229
@@ -181,9 +238,96 @@ growUp (Animal name age) = Animal name (age + 50)
181Human {name = "Tunyasz", age = 60, address = "London"}
238Human {name = "Tunyasz", age = 60, address = "London"}
182```
239```
183
240
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+
184## Prisms
324## Prisms
185
325
186−### Named constructors
326+A prism focuses on one part of a sum type (which might not be present). Other
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
187
331
188Constructor components can be accessed using the constructor's name:
332Constructor components can be accessed using the constructor's name:
189
333
@@ -205,19 +349,20 @@ Just (MkDog {name = "Shep", age = 4})
205
349
206>>> shep ^? _Ctor @"Cat"
350>>> shep ^? _Ctor @"Cat"
207Nothing
351Nothing
352+```
353+
354+Constructors with multiple fields can be focused as a tuple
208
355
356+```
209>>> mog ^? _Ctor @"Cat"
357>>> mog ^? _Ctor @"Cat"
210Just ("Mog",5)
358Just ("Mog",5)
211
359
212>>> _Ctor @"Cat" # ("Garfield", 6) :: Animal
360>>> _Ctor @"Cat" # ("Garfield", 6) :: Animal
213Cat "Garfield" 6
361Cat "Garfield" 6
214
362
215−>>> donald ^? _Ctor @"Giraffe"
216−error:
217− • The type Animal does not contain a constructor named "Giraffe"
218```
363```
219
364
220−### Typed constructors
365+### By type
221
366
222Constructor components can be accessed using the component's type, assuming
367Constructor components can be accessed using the component's type, assuming
223that this type is unique:
368that this type is unique:
@@ -227,10 +372,10 @@ type Name = String
227type Age = Int
372type Age = Int
228
373
229data Dog = MkDog { name :: Name, age :: Age } deriving (Generic, Show)
374data Dog = MkDog { name :: Name, age :: Age } deriving (Generic, Show)
230−data Animal = Dog Dog | Cat (Name, Age) | Duck Age deriving (Generic, Show)
375+data Animal = Dog Dog | Cat Name Age | Duck Age deriving (Generic, Show)
231
376
232shep = Dog (MkDog "Shep" 4)
377shep = Dog (MkDog "Shep" 4)
233−mog = Cat ("Mog", 5)
378+mog = Cat "Mog" 5
234donald = Duck 4
379donald = Duck 4
235```
380```
236
381
@@ -244,6 +389,9 @@ Just (MkDog {name = "Shep", age = 4})
244>>> donald ^? _Typed @Age
389>>> donald ^? _Typed @Age
245Just 4
390Just 4
246
391
392+>>> mog ^? _Typed @(Name, Age)
393+("Mog", 5)
394+
247>>> donald ^? _Typed @Float
395>>> donald ^? _Typed @Float
248error:
396error:
249 • The type Animal does not contain a constructor whose field is of type Float
397 • The type Animal does not contain a constructor whose field is of type Float
@@ -252,7 +400,19 @@ error:
252Duck 6
400Duck 6
253```
401```
254
402
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.
255−## Contributors
414+# Contributors
256
415
416++ [Matthew Pickering](https://github.com/mpickering)
257+ [Toby Shaw](https://github.com/TobyShaw)
417+ [Toby Shaw](https://github.com/TobyShaw)
258+ [Will Jones](https://github.com/lunaris)
418+ [Will Jones](https://github.com/lunaris)
cabal.haskell-cinew file+5
@@ -0,0 +1,5 @@
1+-- inspection tests fail
2+tests: <8.6
3+
4+-- blocked on vector-th-unbox
5+benchmarks: <8.8
cabal.project+1
@@ -1 +1,2 @@
1packages: generic-lens.cabal
1packages: generic-lens.cabal
2+write-ghc-environment-files: always
examples/Biscuits.hsnew file+150
@@ -0,0 +1,150 @@
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/Examples.hs+6−1
@@ -17,11 +17,16 @@
17module Examples where
17module Examples where
18
18
19import Data.Function ((&))
19import Data.Function ((&))
20−import Data.Generics.Internal.Lens
20+import Data.Generics.Internal.VL.Lens
21import Data.Generics.Product
21import Data.Generics.Product
22import Data.Generics.Sum
22import Data.Generics.Sum
23import GHC.Generics
23import GHC.Generics
24import Data.Generics.Labels
24import Data.Generics.Labels
25+import Data.Generics.Internal.VL.Iso
26+import Data.Generics.Internal.VL.Prism
27+import Data.Generics.Internal.Profunctor.Lens
28+import Data.Generics.Internal.Profunctor.Iso
29+import Data.Generics.Internal.Profunctor.Prism
25
30
26data Animal = Animal
31data Animal = Animal
27 { name :: String
32 { name :: String
examples/doctest.hsnew file+7
@@ -0,0 +1,7 @@
1+import Test.DocTest
2+main
3+ = doctest
4+ [ "-iexamples"
5+ , "-isrc"
6+ , "examples/Biscuits.hs"
7+ ]
generic-lens.cabal+70−24
@@ -1,7 +1,7 @@
1name: generic-lens
1name: generic-lens
2−version: 0.5.1.0
2+version: 1.2.0.1
3−synopsis: Generic data-structure operations exposed as lenses.
3+synopsis: Generically derive traversals, lenses and prisms.
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.
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.
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.1
14+Tested-With: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.1
15
15
16extra-source-files: ChangeLog.md
16extra-source-files: ChangeLog.md
17 , examples/StarWars.hs
17 , examples/StarWars.hs
@@ -23,26 +23,40 @@ flag dump-core
23 default: False
23 default: False
24
24
25library
25library
26− exposed-modules: Data.Generics.Product
26+ exposed-modules: Data.Generics.Wrapped
27+ , Data.Generics.Product
27 , Data.Generics.Product.Any
28 , Data.Generics.Product.Any
28 , Data.Generics.Product.Fields
29 , Data.Generics.Product.Fields
30+ , Data.Generics.Product.Param
29 , Data.Generics.Product.Positions
31 , Data.Generics.Product.Positions
30 , Data.Generics.Product.Subtype
32 , Data.Generics.Product.Subtype
31 , Data.Generics.Product.Typed
33 , Data.Generics.Product.Typed
32 , Data.Generics.Product.Types
34 , Data.Generics.Product.Types
33− , Data.Generics.Product.List
35+ , Data.Generics.Product.Constraints
36+ , Data.Generics.Product.HList
37+ , Data.Generics.Labels
38+ , Data.Generics.Internal.GenericN
34
39
35 , Data.Generics.Sum
40 , Data.Generics.Sum
36 , Data.Generics.Sum.Any
41 , Data.Generics.Sum.Any
37 , Data.Generics.Sum.Constructors
42 , Data.Generics.Sum.Constructors
38 , Data.Generics.Sum.Typed
43 , Data.Generics.Sum.Typed
39 , Data.Generics.Sum.Subtype
44 , Data.Generics.Sum.Subtype
40− , Data.Generics.Internal.Lens
45+ , Data.Generics.Internal.Profunctor.Lens
46+ , Data.Generics.Internal.Profunctor.Prism
47+ , Data.Generics.Internal.Profunctor.Iso
48+ , Data.Generics.Internal.VL.Lens
49+ , Data.Generics.Internal.VL.Traversal
50+ , Data.Generics.Internal.VL.Prism
51+ , Data.Generics.Internal.VL.Iso
52+
53+ , Data.GenericLens.Internal
41
54
42 other-modules: Data.Generics.Internal.Families
55 other-modules: Data.Generics.Internal.Families
43 , Data.Generics.Internal.Families.Changing
56 , Data.Generics.Internal.Families.Changing
44 , Data.Generics.Internal.Families.Collect
57 , Data.Generics.Internal.Families.Collect
45 , Data.Generics.Internal.Families.Has
58 , Data.Generics.Internal.Families.Has
59+ , Data.Generics.Internal.Errors
46 , Data.Generics.Internal.Void
60 , Data.Generics.Internal.Void
47
61
48 , Data.Generics.Sum.Internal.Constructors
62 , Data.Generics.Sum.Internal.Constructors
@@ -50,68 +64,92 @@ library
50 , Data.Generics.Sum.Internal.Subtype
64 , Data.Generics.Sum.Internal.Subtype
51
65
52 , Data.Generics.Product.Internal.Positions
66 , Data.Generics.Product.Internal.Positions
67+ , Data.Generics.Product.Internal.GLens
53 , Data.Generics.Product.Internal.Subtype
68 , Data.Generics.Product.Internal.Subtype
54
69
55− , Data.Generics.Product.Internal.Types
70+ , Data.Generics.Product.Internal.Constraints
56− , Data.Generics.Product.Internal.List
57− , Data.Generics.Product.Internal.Keyed
71+ , Data.Generics.Product.Internal.HList
58
72
59− build-depends: base >= 4.9 && <= 5.0
73+ build-depends: base >= 4.9 && < 5
60− , profunctors >= 5.0 && <= 6.0
74+ , profunctors >= 5.0 && < 6.0
61− , tagged >= 0.8 && <= 0.9
75+ , tagged >= 0.8 && < 1
76+ , text >= 1.2 && < 1.3
62
77
63 hs-source-dirs: src
78 hs-source-dirs: src
64 default-language: Haskell2010
79 default-language: Haskell2010
65 ghc-options: -Wall
80 ghc-options: -Wall
66− if flag(dump-core)
81+-- if flag(dump-core)
67− build-depends: dump-core
82+-- build-depends: dump-core
68− ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
83+-- ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
69
84
70source-repository head
85source-repository head
71 type: git
86 type: git
72 location: https://github.com/kcsongor/generic-lens
87 location: https://github.com/kcsongor/generic-lens
73
88
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+
74test-suite generic-lens-test
102test-suite generic-lens-test
75 type: exitcode-stdio-1.0
103 type: exitcode-stdio-1.0
76 hs-source-dirs: test
104 hs-source-dirs: test
77 main-is: Spec.hs
105 main-is: Spec.hs
78− other-modules: Util
106+ other-modules: Util Test24 Test25 Test40 Test62 Test63 CustomChildren
79
107
80 build-depends: base >= 4.9 && <= 5.0
108 build-depends: base >= 4.9 && <= 5.0
81 , generic-lens
109 , generic-lens
110+ , lens
82 , profunctors
111 , profunctors
83 , inspection-testing >= 0.2
112 , inspection-testing >= 0.2
84 , HUnit
113 , HUnit
85
114
86 default-language: Haskell2010
115 default-language: Haskell2010
87− ghc-options: -Wall -O2 -dsuppress-all
116+ ghc-options: -Wall
88 if flag(dump-core)
117 if flag(dump-core)
89 build-depends: dump-core
118 build-depends: dump-core
90 ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
119 ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
91
120
92−test-suite generic-lens-test-25
121+test-suite generic-lens-bifunctor
93 type: exitcode-stdio-1.0
122 type: exitcode-stdio-1.0
94 hs-source-dirs: test
123 hs-source-dirs: test
95− main-is: 25.hs
124+ main-is: Bifunctor.hs
96
125
97 build-depends: base >= 4.9 && <= 5.0
126 build-depends: base >= 4.9 && <= 5.0
98 , generic-lens
127 , generic-lens
99 , lens
128 , lens
129+ , HUnit
100
130
101 default-language: Haskell2010
131 default-language: Haskell2010
102 ghc-options: -Wall
132 ghc-options: -Wall
133+ if flag(dump-core)
134+ build-depends: dump-core
135+ ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
103
136
104−test-suite generic-lens-test-24
137+test-suite generic-lens-syb-tree
105 type: exitcode-stdio-1.0
138 type: exitcode-stdio-1.0
106− hs-source-dirs: test
139+ hs-source-dirs: test/syb
107− main-is: 24.hs
140+ main-is: Tree.hs
108
141
109 build-depends: base >= 4.9 && <= 5.0
142 build-depends: base >= 4.9 && <= 5.0
110 , generic-lens
143 , generic-lens
111 , lens
144 , lens
145+ , profunctors
146+ , HUnit
112
147
113 default-language: Haskell2010
148 default-language: Haskell2010
114 ghc-options: -Wall
149 ghc-options: -Wall
150+ if flag(dump-core)
151+ build-depends: dump-core
152+ ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
115
153
116test-suite doctests
154test-suite doctests
117 default-language: Haskell2010
155 default-language: Haskell2010
@@ -121,6 +159,14 @@ test-suite doctests
121 build-depends: base >4 && <5, doctest
159 build-depends: base >4 && <5, doctest
122 hs-source-dirs: test
160 hs-source-dirs: test
123
161
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+
124benchmark generic-lens-bench
170benchmark generic-lens-bench
125 type: exitcode-stdio-1.0
171 type: exitcode-stdio-1.0
126 hs-source-dirs: benchmarks
172 hs-source-dirs: benchmarks
@@ -130,7 +176,7 @@ benchmark generic-lens-bench
130
176
131 , base >= 4.9 && <= 5.0
177 , base >= 4.9 && <= 5.0
132 , QuickCheck
178 , QuickCheck
133− , criterion
179+ , criterion >= 1.3.0.0
134 , deepseq
180 , deepseq
135 , lens
181 , lens
136
182
src/Data/GenericLens/Internal.hsnew file+64
@@ -0,0 +1,64 @@
1+-----------------------------------------------------------------------------
2+-- |
3+-- Module : Data.GenericLens.Internal
4+-- Copyright : (C) 2019 Csongor Kiss
5+-- License : BSD3
6+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
7+-- Stability : experimental
8+-- Portability : non-portable
9+--
10+-- The library internals are exposed through this module. Please keep
11+-- in mind that everything here is subject to change irrespective of
12+-- the the version numbers.
13+-----------------------------------------------------------------------------
14+
15+module Data.GenericLens.Internal
16+ ( module Data.Generics.Internal.Families
17+ , module Data.Generics.Internal.Families.Changing
18+ , module Data.Generics.Internal.Families.Collect
19+ , module Data.Generics.Internal.Families.Has
20+ , module Data.Generics.Internal.Void
21+ , module Data.Generics.Internal.Errors
22+
23+ , module Data.Generics.Sum.Internal.Constructors
24+ , module Data.Generics.Sum.Internal.Typed
25+ , module Data.Generics.Sum.Internal.Subtype
26+
27+ , module Data.Generics.Product.Internal.Positions
28+ , module Data.Generics.Product.Internal.GLens
29+ , module Data.Generics.Product.Internal.Subtype
30+ , module Data.Generics.Product.Internal.Constraints
31+ , module Data.Generics.Product.Internal.HList
32+
33+ , module Data.Generics.Internal.GenericN
34+
35+ -- * van Laarhoven optics
36+ , module Data.Generics.Internal.VL.Iso
37+ , module Data.Generics.Internal.VL.Lens
38+ , module Data.Generics.Internal.VL.Prism
39+ , module Data.Generics.Internal.VL.Traversal
40+ ) where
41+
42+import Data.Generics.Internal.Families
43+import Data.Generics.Internal.Families.Changing
44+import Data.Generics.Internal.Families.Collect
45+import Data.Generics.Internal.Families.Has
46+import Data.Generics.Internal.Void
47+import Data.Generics.Internal.Errors
48+
49+import Data.Generics.Sum.Internal.Constructors
50+import Data.Generics.Sum.Internal.Typed
51+import Data.Generics.Sum.Internal.Subtype
52+
53+import Data.Generics.Product.Internal.Positions
54+import Data.Generics.Product.Internal.GLens
55+import Data.Generics.Product.Internal.Subtype
56+import Data.Generics.Product.Internal.Constraints
57+import Data.Generics.Product.Internal.HList
58+
59+import Data.Generics.Internal.GenericN
60+
61+import Data.Generics.Internal.VL.Iso
62+import Data.Generics.Internal.VL.Lens
63+import Data.Generics.Internal.VL.Prism
64+import Data.Generics.Internal.VL.Traversal
src/Data/GenericLens/Internal.hs~new file

No changes to the content.

src/Data/Generics/Internal/Errors.hsnew file+59
@@ -0,0 +1,59 @@
1+{-# LANGUAGE UndecidableInstances #-}
2+{-# LANGUAGE TypeFamilies #-}
3+{-# LANGUAGE KindSignatures #-}
4+{-# LANGUAGE PolyKinds #-}
5+{-# LANGUAGE DataKinds #-}
6+{-# LANGUAGE TypeOperators #-}
7+{-# LANGUAGE KindSignatures #-}
8+
9+-------------------------------------------------------------------------------
10+---- |
11+---- Module : Data.Generics.Internal.Errors
12+---- Copyright : (C) 2019 Csongor Kiss
13+---- License : BSD3
14+---- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
15+---- Stability : experimental
16+---- Portability : non-portable
17+----
18+---- Provide more legible type errors as described in
19+---- (https://kcsongor.github.io/report-stuck-families/)[this blog post].
20+-------------------------------------------------------------------------------
21+
22+module Data.Generics.Internal.Errors
23+ ( NoGeneric
24+ , Defined
25+ , Defined_list
26+
27+ , QuoteType
28+ , PrettyError
29+ ) where
30+
31+import GHC.Generics
32+import GHC.TypeLits
33+import Data.Kind
34+
35+type family NoGeneric (a :: Type) (ctxt :: [ErrorMessage]) :: Constraint where
36+ NoGeneric a ctxt = PrettyError ('Text "No instance for " ':<>: QuoteType (Generic a)
37+ ': ctxt)
38+type family PrettyError (ctxt :: [ErrorMessage]) :: k where
39+ PrettyError '[] = TypeError ('Text "")
40+ PrettyError (c ': cs) = TypeError ('Text "| " ':<>: c ':$$: PrettyLines cs)
41+
42+type family PrettyLines (ctxt :: [ErrorMessage]) :: ErrorMessage where
43+ PrettyLines '[] = 'Text ""
44+ PrettyLines (c ': cs) = 'Text "| " ':<>: c ':$$: PrettyLines cs
45+
46+type family Defined (break :: Type -> Type) (err :: Constraint) (a :: k) :: k where
47+ Defined Void1 _ _ = Any
48+ Defined _ _ k = k
49+
50+type family Defined_list (break :: [*]) (err :: Constraint) (a :: k) :: k where
51+ Defined_list '[Void] _ _ = Any
52+ Defined_list _ _ k = k
53+
54+data Void1 a
55+data Void
56+type family Any :: k
57+
58+type family QuoteType (typ :: k) :: ErrorMessage where
59+ QuoteType typ = 'Text "‘" ':<>: 'ShowType typ ':<>: 'Text "’"
src/Data/Generics/Internal/Families.hs+1−2
@@ -3,14 +3,13 @@
3{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE KindSignatures #-}
4{-# LANGUAGE KindSignatures #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
6−{-# LANGUAGE TypeApplications #-}
7{-# LANGUAGE TypeFamilies #-}
6{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE TypeOperators #-}
7{-# LANGUAGE TypeOperators #-}
9
8
10-----------------------------------------------------------------------------
9-----------------------------------------------------------------------------
11-- |
10-- |
12-- Module : Data.Generics.Internal.Families
11-- Module : Data.Generics.Internal.Families
13−-- Copyright : (C) 2017 Csongor Kiss
12+-- Copyright : (C) 2019 Csongor Kiss
14-- License : BSD3
13-- License : BSD3
15-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
14-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16-- Stability : experimental
15-- Stability : experimental
src/Data/Generics/Internal/Families/Changing.hs+49−16
@@ -9,11 +9,17 @@
9{-# LANGUAGE UndecidableInstances #-}
9{-# LANGUAGE UndecidableInstances #-}
10
10
11module Data.Generics.Internal.Families.Changing
11module Data.Generics.Internal.Families.Changing
12− ( Proxied
12+ ( Indexed
13 , Infer
13 , Infer
14+ , PTag (..)
15+ , P
16+ , LookupParam
17+ , ArgAt
18+ , ArgCount
19+ , UnifyHead
14 ) where
20 ) where
15
21
16−import GHC.TypeLits (TypeError, ErrorMessage (..))
22+import GHC.TypeLits (Nat, type (-), type (+), TypeError, ErrorMessage (..))
17
23
18{-
24{-
19 Note [Changing type parameters]
25 Note [Changing type parameters]
@@ -48,19 +54,19 @@ import GHC.TypeLits (TypeError, ErrorMessage (..))
48-- application form. In order to distinguish between applications of P and other type constructors, we use a tag, `PTag`
54-- application form. In order to distinguish between applications of P and other type constructors, we use a tag, `PTag`
49-- to fake a type constructor.
55-- to fake a type constructor.
50data PTag = PTag
56data PTag = PTag
51−type family P :: Peano -> k -> PTag -> k
57+type family P :: Nat -> k -> PTag -> k
52
58
53−type Proxied t = Proxied' t 'Z
59+type Indexed t = Indexed' t 0
54
60
55−type family Proxied' (t :: k) (next :: Peano) :: k where
61+type family Indexed' (t :: k) (next :: Nat) :: k where
56− Proxied' (t (a :: j) :: k) next = (Proxied' t ('S next)) (P next a 'PTag)
62+ Indexed' (t (a :: j) :: k) next = (Indexed' t (next + 1)) (P next a 'PTag)
57− Proxied' t _ = t
63+ Indexed' t _ = t
58
64
59data Sub where
65data Sub where
60− Sub :: Peano -> k -> Sub
66+ Sub :: Nat -> k -> Sub
61
67
62type family Unify (a :: k) (b :: k) :: [Sub] where
68type family Unify (a :: k) (b :: k) :: [Sub] where
63− Unify (a n _ 'PTag) a' = '[ 'Sub n a']
69+ Unify (p n _ 'PTag) a' = '[ 'Sub n a']
64 Unify (a x) (b y) = Unify x y ++ Unify a b
70 Unify (a x) (b y) = Unify x y ++ Unify a b
65 Unify a a = '[]
71 Unify a a = '[]
66 Unify a b = TypeError
72 Unify a b = TypeError
@@ -81,28 +87,49 @@ type family Infer (s :: *) (a' :: *) (b :: *) :: * where
81
87
82--------------------------------------------------------------------------------
88--------------------------------------------------------------------------------
83
89
84−data Peano = Z | S Peano
85−
86-- [TODO]: work this out
90-- [TODO]: work this out
87--
91--
88−--type family ArgKind (t :: k) (pos :: Peano) :: * where
92+--type family ArgKind (t :: k) (pos :: Nat) :: * where
89-- ArgKind (t (a :: k)) 'Z = k
93-- ArgKind (t (a :: k)) 'Z = k
90-- ArgKind (t _) ('S pos) = ArgKind t pos
94-- ArgKind (t _) ('S pos) = ArgKind t pos
91--
95--
92−--type family ReplaceArg (t :: k) (pos :: Peano) (to :: ArgKind t pos) :: k where
96+--type family ReplaceArg (t :: k) (pos :: Nat) (to :: ArgKind t pos) :: k where
93-- ReplaceArg (t a) 'Z to = t to
97-- ReplaceArg (t a) 'Z to = t to
94-- ReplaceArg (t a) ('S pos) to = ReplaceArg t pos to a
98-- ReplaceArg (t a) ('S pos) to = ReplaceArg t pos to a
95-- ReplaceArg t _ _ = t
99-- ReplaceArg t _ _ = t
96
100
97−type family ReplaceArg (t :: k) (pos :: Peano) (to :: j) :: k where
101+type family ReplaceArg (t :: k) (pos :: Nat) (to :: j) :: k where
98− ReplaceArg (t a) 'Z to = t to
102+ ReplaceArg (t a) 0 to = t to
99− ReplaceArg (t a) ('S pos) to = ReplaceArg t pos to a
103+ ReplaceArg (t a) pos to = ReplaceArg t (pos - 1) to a
100 ReplaceArg t _ _ = t
104 ReplaceArg t _ _ = t
101
105
102type family ReplaceArgs (t :: k) (subs :: [Sub]) :: k where
106type family ReplaceArgs (t :: k) (subs :: [Sub]) :: k where
103 ReplaceArgs t '[] = t
107 ReplaceArgs t '[] = t
104 ReplaceArgs t ('Sub n arg ': ss) = ReplaceArgs (ReplaceArg t n arg) ss
108 ReplaceArgs t ('Sub n arg ': ss) = ReplaceArgs (ReplaceArg t n arg) ss
105
109
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+
106-- Note [CPP in instance constraints]
133-- Note [CPP in instance constraints]
107-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
134-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
108--
135--
@@ -126,3 +153,9 @@ type family ReplaceArgs (t :: k) (subs :: [Sub]) :: k where
126-- However, for some reason, this violates the functional dependencies on 8.2.2.
153-- However, for some reason, this violates the functional dependencies on 8.2.2.
127-- Therefore, when using a newer version of the compiler, the original constraints
154-- Therefore, when using a newer version of the compiler, the original constraints
128-- are used, as the expression size is smaller under 8.2.2.
155-- are used, as the expression size is smaller under 8.2.2.
156+
157+-- | Ensure that the types @a@ and @b@ are both applications of the same
158+-- constructor. The arguments may be different.
159+class UnifyHead (a :: k) (b :: k)
160+instance {-# OVERLAPPING #-} (gb ~ g b, UnifyHead f g) => UnifyHead (f a) gb
161+instance (a ~ b) => UnifyHead a b
src/Data/Generics/Internal/Families/Collect.hs+2−2
@@ -7,7 +7,7 @@
7-----------------------------------------------------------------------------
7-----------------------------------------------------------------------------
8-- |
8-- |
9-- Module : Data.Generics.Internal.Families.Collect
9-- Module : Data.Generics.Internal.Families.Collect
10−-- Copyright : (C) 2017 Csongor Kiss
10+-- Copyright : (C) 2019 Csongor Kiss
11-- License : BSD3
11-- License : BSD3
12-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
12-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
13-- Stability : experimental
13-- Stability : experimental
@@ -28,7 +28,7 @@ import Data.Type.Equality (type (==))
28import GHC.Generics
28import GHC.Generics
29import GHC.TypeLits (Symbol, CmpSymbol)
29import GHC.TypeLits (Symbol, CmpSymbol)
30
30
31−import Data.Generics.Product.Internal.List (type (++))
31+import Data.Generics.Product.Internal.HList (type (++))
32import Data.Generics.Internal.Families.Has (GTypes)
32import Data.Generics.Internal.Families.Has (GTypes)
33
33
34data TypeStat
34data TypeStat
src/Data/Generics/Internal/Families/Has.hs+72−46
@@ -7,7 +7,7 @@
7-----------------------------------------------------------------------------
7-----------------------------------------------------------------------------
8-- |
8-- |
9-- Module : Data.Generics.Internal.Families.Has
9-- Module : Data.Generics.Internal.Families.Has
10−-- Copyright : (C) 2017 Csongor Kiss
10+-- Copyright : (C) 2019 Csongor Kiss
11-- License : BSD3
11-- License : BSD3
12-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
12-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
13-- Stability : experimental
13-- Stability : experimental
@@ -17,73 +17,99 @@
17module Data.Generics.Internal.Families.Has
17module Data.Generics.Internal.Families.Has
18 ( HasTotalFieldP
18 ( HasTotalFieldP
19 , HasTotalTypeP
19 , HasTotalTypeP
20+ , HasTotalPositionP
21+ , Pos
20 , HasPartialTypeP
22 , HasPartialTypeP
21 , HasCtorP
23 , HasCtorP
22 , GTypes
24 , GTypes
23 ) where
25 ) where
24
26
25−import Data.Type.Bool (type (||), type (&&))
27+import Data.Type.Bool (type (||))
26import Data.Type.Equality (type (==))
28import Data.Type.Equality (type (==))
27import GHC.Generics
29import GHC.Generics
28−import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
30+import GHC.TypeLits (Symbol, Nat)
31+import Data.Kind (Type)
29
32
30−import Data.Generics.Product.Internal.List
33+import Data.Generics.Product.Internal.HList
31
34
35+-- Note: these could be factored out into a single traversal
36+
37+type family Both (m1 :: Maybe a) (m2 :: Maybe a) :: Maybe a where
38+ Both ('Just a) ('Just a) = 'Just a
39+
40+type family Alt (m1 :: Maybe a) (m2 :: Maybe a) :: Maybe a where
41+ Alt ('Just a) _ = 'Just a
42+ Alt _ b = b
43+
32−type family HasTotalFieldP (field :: Symbol) f :: Bool where
44+type family HasTotalFieldP (field :: Symbol) f :: Maybe Type where
33− HasTotalFieldP field (S1 ('MetaSel ('Just field) _ _ _) _)
45+ HasTotalFieldP field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 t))
34− = 'True
46+ = 'Just t
35 HasTotalFieldP field (l :*: r)
47 HasTotalFieldP field (l :*: r)
36− = HasTotalFieldP field l || HasTotalFieldP field r
48+ = Alt (HasTotalFieldP field l) (HasTotalFieldP field r)
37 HasTotalFieldP field (l :+: r)
49 HasTotalFieldP field (l :+: r)
38− = HasTotalFieldP field l && HasTotalFieldP field r
50+ = Both (HasTotalFieldP field l) (HasTotalFieldP field r)
39 HasTotalFieldP field (S1 _ _)
51 HasTotalFieldP field (S1 _ _)
40− = 'False
52+ = 'Nothing
41 HasTotalFieldP field (C1 _ f)
53 HasTotalFieldP field (C1 _ f)
42 = HasTotalFieldP field f
54 = HasTotalFieldP field f
43 HasTotalFieldP field (D1 _ f)
55 HasTotalFieldP field (D1 _ f)
44 = HasTotalFieldP field f
56 = HasTotalFieldP field f
45− HasTotalFieldP field (Rec0 _)
57+ HasTotalFieldP field (K1 _ _)
46− = 'False
58+ = 'Nothing
47 HasTotalFieldP field U1
59 HasTotalFieldP field U1
48− = 'False
60+ = 'Nothing
49 HasTotalFieldP field V1
61 HasTotalFieldP field V1
50− = 'False
62+ = 'Nothing
51− HasTotalFieldP field f
52− = TypeError
53− ( 'ShowType f
54− ':<>: 'Text " is not a valid GHC.Generics representation type"
55− )
56
63
57−type family HasTotalTypeP a f :: Bool where
64+type family HasTotalTypeP (typ :: Type) f :: Maybe Type where
58− HasTotalTypeP t (S1 meta (Rec0 t))
65+ HasTotalTypeP typ (S1 _ (K1 _ typ))
59− = 'True
66+ = 'Just typ
60− HasTotalTypeP t (l :*: r)
67+ HasTotalTypeP typ (l :*: r)
61− = HasTotalTypeP t l || HasTotalTypeP t r
68+ = Alt (HasTotalTypeP typ l) (HasTotalTypeP typ r)
62− HasTotalTypeP t (l :+: r)
69+ HasTotalTypeP typ (l :+: r)
63− = HasTotalTypeP t l && HasTotalTypeP t r
70+ = Both (HasTotalTypeP typ l) (HasTotalTypeP typ r)
64− HasTotalTypeP t (S1 _ _)
71+ HasTotalTypeP typ (S1 _ _)
65− = 'False
72+ = 'Nothing
66− HasTotalTypeP t (C1 m f)
73+ HasTotalTypeP typ (C1 _ f)
67− = HasTotalTypeP t f
74+ = HasTotalTypeP typ f
68− HasTotalTypeP t (D1 m f)
75+ HasTotalTypeP typ (D1 _ f)
69− = HasTotalTypeP t f
76+ = HasTotalTypeP typ f
70− HasTotalTypeP t (Rec0 _)
77+ HasTotalTypeP typ (K1 _ _)
71− = 'False
78+ = 'Nothing
72− HasTotalTypeP t U1
79+ HasTotalTypeP typ U1
73− = 'False
80+ = 'Nothing
74− HasTotalTypeP t V1
81+ HasTotalTypeP typ V1
75− = 'False
82+ = 'Nothing
76− HasTotalTypeP t f
83+
77− = TypeError
84+data Pos (p :: Nat)
78− ( 'ShowType f
85+
79− ':<>: 'Text " is not a valid GHC.Generics representation type"
86+type family HasTotalPositionP (pos :: Nat) f :: Maybe Type where
80− )
87+ HasTotalPositionP pos (S1 _ (K1 (Pos pos) t))
88+ = 'Just t
89+ HasTotalPositionP pos (l :*: r)
90+ = Alt (HasTotalPositionP pos l) (HasTotalPositionP pos r)
91+ HasTotalPositionP pos (l :+: r)
92+ = Both (HasTotalPositionP pos l) (HasTotalPositionP pos r)
93+ HasTotalPositionP pos (S1 _ _)
94+ = 'Nothing
95+ HasTotalPositionP pos (C1 _ f)
96+ = HasTotalPositionP pos f
97+ HasTotalPositionP pos (D1 _ f)
98+ = HasTotalPositionP pos f
99+ HasTotalPositionP pos (K1 _ _)
100+ = 'Nothing
101+ HasTotalPositionP pos U1
102+ = 'Nothing
103+ HasTotalPositionP pos V1
104+ = 'Nothing
81
105
82type family HasPartialTypeP a f :: Bool where
106type family HasPartialTypeP a f :: Bool where
83 HasPartialTypeP t (l :+: r)
107 HasPartialTypeP t (l :+: r)
84 = HasPartialTypeP t l || HasPartialTypeP t r
108 = HasPartialTypeP t l || HasPartialTypeP t r
85 HasPartialTypeP t (C1 m f)
109 HasPartialTypeP t (C1 m f)
86 = t == GTypes f
110 = t == GTypes f
111+ HasPartialTypeP t (M1 _ _ f)
112+ = HasPartialTypeP t f
87 HasPartialTypeP t _
113 HasPartialTypeP t _
88 = 'False
114 = 'False
89
115
@@ -97,11 +123,11 @@ type family HasCtorP (ctor :: Symbol) f :: Bool where
97 HasCtorP ctor _
123 HasCtorP ctor _
98 = 'False
124 = 'False
99
125
100−type family GTypes (rep :: * -> *) :: [((), *)] where
126+type family GTypes (rep :: Type -> Type) :: [Type] where
101 GTypes (l :*: r)
127 GTypes (l :*: r)
102 = GTypes l ++ GTypes r
128 = GTypes l ++ GTypes r
103− GTypes (Rec0 a)
129+ GTypes (K1 _ a)
104− = '[ '( '(), a)]
130+ = '[ a]
105 GTypes (M1 _ m a)
131 GTypes (M1 _ m a)
106 = GTypes a
132 = GTypes a
107 GTypes U1 = '[]
133 GTypes U1 = '[]
src/Data/Generics/Internal/GenericN.hsnew file+75
@@ -0,0 +1,75 @@
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/Lens.hsdeleted−515
@@ -1,515 +0,0 @@
1−{-# LANGUAGE GADTs #-}
2−{-# LANGUAGE LambdaCase #-}
3−{-# LANGUAGE Rank2Types #-}
4−{-# LANGUAGE TypeFamilies #-}
5−{-# LANGUAGE TypeFamilyDependencies #-}
6−{-# LANGUAGE TypeOperators #-}
7−{-# LANGUAGE TupleSections #-}
8−{-# LANGUAGE NoMonomorphismRestriction #-}
9−{-# LANGUAGE ScopedTypeVariables #-}
10−
11−-----------------------------------------------------------------------------
12−-- |
13−-- Module : Data.Generics.Internal.Lens
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−-- Internal lens helpers. Only exported for Haddock
21−--
22−-----------------------------------------------------------------------------
23−module Data.Generics.Internal.Lens where
24−
25−import Control.Applicative (Const(..))
26−import Data.Functor.Identity (Identity(..))
27−import Data.Monoid (First (..))
28−import Data.Profunctor (Choice(..), Profunctor(..), Strong(..))
29−import Data.Bifunctor
30−import Data.Profunctor.Unsafe ((#.), (.#))
31−import Data.Tagged
32−import GHC.Generics ((:*:)(..), (:+:)(..), Generic(..), M1(..), K1(..), Rep)
33−import Data.Coerce
34−
35−-- | Type alias for lens
36−type LensVL' s a
37− = Lens s s a a
38−
39−type LensVL s t a b
40− = forall f. Functor f => (a -> f b) -> s -> f t
41−
42−type Lens s t a b
43− = forall p . (Strong p) => p a b -> p s t
44−
45−-- | Type alias for traversal
46−type Traversal' s a
47− = forall f. Applicative f => (a -> f a) -> s -> f s
48−
49−type Traversal s t a b
50− = forall f. Applicative f => (a -> f b) -> s -> f t
51−
52−type LensLike p s t a b
53− = p a b -> p s t
54−
55−-- | Type alias for prism
56−type PrismVL s t a b
57− = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)
58−
59−type Prism s t a b
60− = forall p . (Choice p) => p a b -> p s t
61−
62−type Prism' s a = forall p . (Choice p) => p a a -> p s s
63−
64−type PrismVL' s a
65− = PrismVL s s a a
66−
67−type IsoVL' s a
68− = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s)
69−
70−type IsoVL s t a b
71− = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
72−
73−type Iso s t a b
74− = forall p. (Profunctor p) => p a b -> p s t
75−
76−type Iso' s a = Iso s s a a
77−
78−-- | Getting
79−(^.) :: s -> ((a -> Const a a) -> s -> Const a s) -> a
80−s ^. l = getConst (l Const s)
81−infixl 8 ^.
82−
83−-- | Setting
84−set :: ((a -> b) -> s -> t) -> (s, b) -> t
85−set f (s, b)
86− = f (const b) s
87−
88−viewVL :: ((a -> Const a a) -> s -> Const a s) -> s -> a
89−viewVL l s = (^.) s l
90−
91−viewVL' :: ((a -> Const a a) -> s -> Const a s) -> s -> a
92−viewVL' l s = (^.) s l
93−
94−setVL :: LensVL s t a b -> b -> s -> t
95−setVL l x = runIdentity . (l (Identity . const x))
96−
97−
98−view :: Lens s s a a -> s -> a
99−view l = withLens l (\get _ -> get)
100−
101−withLens :: Lens s t a b -> ((s -> a) -> ((s, b) -> t) -> r) -> r
102−withLens l k =
103− case l idLens of
104− ALens get set -> k get set
105−
106−idLens :: ALens a b a b
107−idLens = ALens id snd
108−
109−infixr 4 .~
110−(.~) :: ((a -> b) -> s -> t) -> b -> s -> t
111−(.~) f b s = set f (s, b)
112−
113−infixl 8 ^?
114−(^?) :: s -> ((a -> Const (First a) a) -> s -> Const (First a) s) -> Maybe a
115−s ^? l = getFirst (fmof l (First #. Just) s)
116− where fmof l' f = getConst #. l' (Const #. f)
117−
118−buildVL :: (Tagged b (Identity b) -> Tagged t (Identity t)) -> b -> t
119−buildVL p = runIdentity #. unTagged #. p .# Tagged .# Identity
120−
121−matchVL :: PrismVL s t a b -> s -> Either t a
122−matchVL k = withPrismVL k $ \_ match -> match
123−
124−
125−
126−build :: (Tagged b b -> Tagged t t) -> b -> t
127−build p = unTagged . p . Tagged
128−
129−
130−-- | Lens focusing on the first element of a product
131−first :: Lens ((a :*: b) x) ((a' :*: b) x) (a x) (a' x)
132−first
133− = lens (\(a :*: b) -> a) (\((a :*: b), a') -> a' :*: b)
134−
135−-- | Lens focusing on the second element of a product
136−second :: Lens ((a :*: b) x) ((a :*: b') x) (b x) (b' x)
137−second
138− = lens (\(a :*: b) -> b) (\((a :*: b), b') -> a :*: b')
139−
140−left :: Prism ((a :+: c) x) ((b :+: c) x) (a x) (b x)
141−left = prism L1 $ gsum Right (Left . R1)
142−
143−right :: Prism ((a :+: b) x) ((a :+: c) x) (b x) (c x)
144−right = prism R1 $ gsum (Left . L1) Right
145−
146−gsum :: (a x -> c) -> (b x -> c) -> ((a :+: b) x) -> c
147−gsum f _ (L1 x) = f x
148−gsum _ g (R1 y) = g y
149−
150−prismVL :: (b -> t) -> (s -> Either t a) -> PrismVL s t a b
151−prismVL bt seta eta = dimap (\x -> plus pure id (seta x)) (either id (\x -> fmap bt x)) (right' eta)
152−{-# INLINE prismVL #-}
153−
154−prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
155−prism bt seta eta = dimap seta (either id bt) (right' eta)
156−
157−plus :: (a -> b) -> (c -> d) -> Either a c -> Either b d
158−plus f _ (Left x) = Left (f x)
159−plus _ g (Right y) = Right (g y)
160−
161−fork :: (a -> b) -> (a -> c) -> a -> (b, c)
162−fork f g a = (f a, g a)
163−
164−swap :: (a, b) -> (b, a)
165−swap (a, b) = (b, a)
166−
167−cross :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
168−cross = bimap
169−
170−-- | A type and its generic representation are isomorphic
171−repIsoVL :: (Generic a, Generic b) => IsoVL a b (Rep a x) (Rep b x)
172−repIsoVL = isoVL from to
173−
174−repLens :: (Generic a, Generic b) => Lens a b (Rep a x) (Rep b x)
175−repLens f = repIso f
176−
177−-- | A type and its generic representation are isomorphic
178−repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
179−repIso = iso from to
180−
181−
182−
183−-- | 'M1' is just a wrapper around `f p`
184−mIsoVL :: IsoVL (M1 i c f p) (M1 i c g p) (f p) (g p)
185−mIsoVL = isoVL unM1 M1
186−
187−-- | 'M1' is just a wrapper around `f p`
188−--mIso :: Iso' (M1 i c f p) (f p)
189−mIso :: Iso (M1 i c f p) (M1 i c g p) (f p) (g p)
190−mIso = iso unM1 M1
191−
192−-- These are specialised versions of the Isos above. On GHC 8.0.2, having
193−-- these functions eta-expanded allows the optimiser to inline these functions.
194−mLens :: Lens (M1 i c f p) (M1 i c g p) (f p) (g p)
195−mLens f = mIso f
196−
197−kIso :: Iso (K1 r a p) (K1 r b p) a b
198−kIso = iso unK1 K1
199−
200−sumIso :: Iso ((a :+: b) x) ((a' :+: b') x) (Either (a x) (b x)) (Either (a' x) (b' x))
201−sumIso = iso back forth
202− where forth (Left l) = (L1 l)
203− forth (Right r) = (R1 r)
204− back (L1 l) = (Left l)
205− back (R1 r) = (Right r)
206−
207−_Left :: Prism (Either a c) (Either b c) a b
208−_Left = prism Left $ either Right (Left . Right)
209−
210−_Right :: Prism (Either c a) (Either c b) a b
211−_Right = prism Right $ either (Left . Left) Right
212−
213−--------------------------------------------------------------------------------
214−
215−data Coyoneda f b = forall a. Coyoneda (a -> b) (f a)
216−
217−instance Functor (Coyoneda f) where
218− fmap f (Coyoneda g fa)
219− = Coyoneda (f . g) fa
220−
221−inj :: Functor f => Coyoneda f a -> f a
222−inj (Coyoneda f a) = fmap f a
223−
224−proj :: Functor f => f a -> Coyoneda f a
225−proj fa = Coyoneda id fa
226−
227−lens2lensvl :: ALens a b s t -> LensVL s t a b
228−lens2lensvl (ALens get set) = lensVL get set
229−
230−ravel :: (ALens a b a b -> ALens a b s t)
231− -> LensVL s t a b
232−ravel l pab = (lens2lensvl $ l idLens) pab
233−
234−prismPRavel ::
235− (Market a b a b -> Market a b s t)
236− -> Prism s t a b
237−prismPRavel l pab = (prism2prismp $ l idPrism) pab
238−
239−prismVLRavel ::
240− (Market a b a b -> Market a b s t)
241− -> PrismVL s t a b
242−prismVLRavel l pab = (prism2prismvl $ l idPrism) pab
243−
244−newtype Alongside p s t a b = Alongside { getAlongside :: p (s, a) (t, b) }
245−
246−instance Profunctor p => Profunctor (Alongside p c d) where
247− dimap f g (Alongside pab) = Alongside $ dimap (fmap f) (fmap g) pab
248−
249−instance Strong p => Strong (Alongside p c d) where
250− second' (Alongside pab) = Alongside . dimap shuffle shuffle . second' $ pab
251− where
252− shuffle (x,(y,z)) = (y,(x,z))
253−
254−(??) :: Functor f => f (a -> b) -> a -> f b
255−fab ?? a = fmap ($ a) fab
256−
257−-- Could implement this using primitives?
258−alongside :: Profunctor p =>
259− LensLike (Alongside p s' t') s t a b
260− -> LensLike (Alongside p a b) s' t' a' b'
261− -> LensLike p (s, s') (t, t') (a, a') (b, b')
262−alongside l1 l2
263− = dimap swap swap . getAlongside . l1 . Alongside . dimap swap swap . getAlongside . l2 . Alongside
264−
265−prodIsoVL :: IsoVL ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
266−prodIsoVL = isoVL (\(a :*: b) -> (a, b)) (\(a, b) -> (a :*: b))
267−
268−prodIso :: Iso ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
269−prodIso = iso (\(a :*: b) -> (a, b)) (\(a, b) -> (a :*: b))
270−
271−prodL :: Lens ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
272−prodL f = prodIso f
273−
274−prodR :: Lens (a' x, b' x) (a x, b x) ((a' :*: b') x) ((a :*: b) x)
275−prodR f = fromIso prodIso f
276−
277−assoc3 :: Iso ((a, b), c) ((a', b'), c') (a, (b, c)) (a', (b', c'))
278−assoc3 = iso (\((a, b), c) -> (a, (b, c))) (\(a, (b, c)) -> ((a, b), c))
279−
280−assoc3L :: Lens ((a, b), c) ((a', b'), c') (a, (b, c)) (a', (b', c'))
281−assoc3L f = assoc3 f
282−
283−assoc3R :: Lens (a', (b', c')) (a, (b, c)) ((a', b'), c') ((a, b), c)
284−assoc3R f = fromIso assoc3 f
285−
286−stron :: (Either s s', b) -> Either (s, b) (s', b)
287−stron (e, b) = bimap (,b) (, b) e
288−
289−choosing :: 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
290−choosing l r = withLens l (\getl setl ->
291− withLens r (\getr setr ->
292− let g :: Either s s' -> a
293− g = either getl getr
294− s = bimap setl setr . stron
295− in lens g s))
296−
297−lens :: (s -> a) -> ((s,b) -> t) -> Lens s t a b
298−lens get set = dimap (fork id get) set . second'
299−
300−lensVL :: (s -> a) -> ((s, b) -> t) -> LensVL s t a b
301−lensVL get set f x = curry set x <$> f (get x)
302−
303−--------------------------------------------------------------------------------
304−-- Iso stuff
305−
306−data Exchange a b s t = Exchange (s -> a) (b -> t)
307−
308−instance Functor (Exchange a b s) where
309− fmap f (Exchange sa bt) = Exchange sa (f . bt)
310− {-# INLINE fmap #-}
311−
312−instance Profunctor (Exchange a b) where
313− dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt)
314− {-# INLINE dimap #-}
315− lmap f (Exchange sa bt) = Exchange (sa . f) bt
316− {-# INLINE lmap #-}
317− rmap f (Exchange sa bt) = Exchange sa (f . bt)
318− {-# INLINE rmap #-}
319− ( #. ) _ = coerce
320− {-# INLINE ( #. ) #-}
321− ( .# ) p _ = coerce p
322− {-# INLINE ( .# ) #-}
323−
324−fromIso :: Iso s t a b -> Iso b a t s
325−fromIso l = withIso l $ \ sa bt -> iso bt sa
326−{-# INLINE fromIso #-}
327−
328−isoVL :: (s -> a) -> (b -> t) -> IsoVL s t a b
329−isoVL sa bt = dimap sa (fmap bt)
330−{-# INLINE iso #-}
331−
332−iso :: (s -> a) -> (b -> t) -> Iso s t a b
333−iso = dimap
334−
335−withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
336−withIso ai k = case ai (Exchange id id) of
337− Exchange sa bt -> k sa bt
338−
339−pairing :: Iso s t a b -> Iso s' t' a' b' -> Iso (s, s') (t, t') (a, a') (b, b')
340−pairing f g = withIso f $ \ sa bt -> withIso g $ \s'a' b't' ->
341− iso (bmap sa s'a') (bmap bt b't')
342− where bmap f' g' (a, b) = (f' a, g' b)
343−
344−--------------------------------------------------------------------------------
345−-- Prism stuff
346−
347−type APrism s t a b = Market a b a b -> Market a b s t
348−type APrismVL s t a b = Market a b a (Identity b) -> Market a b s (Identity t)
349−
350−-- without :: APrism s t a b
351−-- -> APrism u v c d
352−-- -> Prism (Either s u) (Either t v) (Either a c) (Either b d)
353−-- without k =
354−-- withPrism k $ \bt seta k' ->
355−-- withPrism k' $ \dv uevc ->
356−-- prism (bimapE bt dv) $ \su ->
357−-- case su of
358−-- Left s -> bimapE Left Left (seta s)
359−-- Right u -> bimapE Right Right (uevc u)
360−-- where bimapE :: (a -> b) -> (c -> d) -> Either a c -> Either b d
361−-- bimapE f _ (Left a) = Left (f a)
362−-- bimapE _ g (Right a) = Right (g a)
363−-- {-# INLINE bimapE #-}
364−
365−without' :: Prism s t a b -> Prism s t c d -> Prism s t (Either a c) (Either b d)
366−without' k =
367− withPrism k $ \bt _ k' ->
368− withPrism k' $ \dt setc ->
369− prism (foldEither bt dt) $ \s -> fmap Right (setc s)
370− where foldEither _ g (Right r) = g r
371− foldEither f _ (Left l) = f l
372−
373−withPrism :: APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
374−withPrism k f = case k idPrism of
375− Market bt seta -> f bt seta
376−
377−withPrismVL :: APrismVL s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
378−withPrismVL k f = case coerce (k (Market Identity Right)) of
379− Market bt seta -> f bt seta
380−
381−--------------------------------------------------------------------------------
382−-- Market
383−
384−data Market a b s t = Market (b -> t) (s -> Either t a)
385−
386−instance Functor (Market a b s) where
387− fmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)
388− {-# INLINE fmap #-}
389−
390−instance Profunctor (Market a b) where
391− dimap f g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta . f)
392− {-# INLINE dimap #-}
393− lmap f (Market bt seta) = Market bt (seta . f)
394− {-# INLINE lmap #-}
395− rmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)
396− {-# INLINE rmap #-}
397− ( #. ) _ = coerce
398− {-# INLINE ( #. ) #-}
399− ( .# ) p _ = coerce p
400− {-# INLINE ( .# ) #-}
401−
402−instance Choice (Market a b) where
403− left' (Market bt seta) = Market (Left . bt) $ \sc -> case sc of
404− Left s -> case seta s of
405− Left t -> Left (Left t)
406− Right a -> Right a
407− Right c -> Left (Right c)
408− {-# INLINE left' #-}
409−
410−prism2prismp :: Market a b s t -> Prism s t a b
411−prism2prismp (Market bt seta) = prism bt seta
412−
413−prism2prismvl :: Market a b s t -> PrismVL s t a b
414−prism2prismvl (Market bt seta) = prismVL bt seta
415−{-# INLINE prism2prismvl #-}
416−
417−idPrism :: Market a b a b
418−idPrism = Market id Right
419−
420−------------------------------------------------------------------------------
421−
422−data ALens a b s t = ALens (s -> a) ((s, b) -> t)
423−
424−instance Functor (ALens a b s) where
425− fmap f (ALens get set) = ALens get (f . set)
426−
427−instance Profunctor (ALens a b) where
428− dimap f g (ALens get set) = ALens (get . f) (g . set . cross f id)
429−
430−instance Strong (ALens a b) where
431− second' (ALens get set) = ALens (get . snd) (bimap id set . assoc)
432− where
433− assoc ((a, b), c) = (a, (b, c))
434−
435−newtype Curried f a =
436− Curried { runCurried :: forall r. f (a -> r) -> f r }
437−
438−instance Functor f => Functor (Curried f) where
439− fmap f (Curried g) = Curried (g . fmap (.f))
440− {-# INLINE fmap #-}
441−
442−instance (Functor f) => Applicative (Curried f) where
443− pure a = Curried (fmap ($ a))
444− {-# INLINE pure #-}
445− Curried mf <*> Curried ma = Curried (ma . mf . fmap (.))
446− {-# INLINE (<*>) #-}
447−
448−-- | The natural isomorphism between @f@ and @Curried f f@.
449−-- @
450−-- 'lowerCurried' '.' 'liftCurried' ≡ 'id'
451−-- 'liftCurried' '.' 'lowerCurried' ≡ 'id'
452−-- @
453−--
454−-- @
455−-- 'lowerCurried' ('liftCurried' x) -- definition
456−-- 'lowerCurried' ('Curried' ('<*>' x)) -- definition
457−-- ('<*>' x) ('pure' 'id') -- beta reduction
458−-- 'pure' 'id' '<*>' x -- Applicative identity law
459−-- x
460−-- @
461−liftCurried :: Applicative f => f a -> Curried f a
462−liftCurried fa = Curried (<*> fa)
463−
464−-- | Lower 'Curried' by applying 'pure' 'id' to the continuation.
465−--
466−-- See 'liftCurried'.
467−lowerCurried :: Applicative f => Curried f a -> f a
468−lowerCurried (Curried f) = f (pure id)
469−
470−confusing :: Applicative f => Traversal s t a b -> (a -> f b) -> s -> f t
471−confusing t = \f -> lowerYoneda . lowerCurried . t (liftCurriedYoneda . f)
472− where
473− liftCurriedYoneda :: Applicative f => f a -> Curried (Yoneda f) a
474− liftCurriedYoneda fa = Curried (`yap` fa)
475− {-# INLINE liftCurriedYoneda #-}
476−
477− yap :: Applicative f => Yoneda f (a -> b) -> f a -> Yoneda f b
478− yap (Yoneda k) fa = Yoneda (\ab_r -> k (ab_r .) <*> fa)
479− {-# INLINE yap #-}
480−{-# INLINE confusing #-}
481−
482−-- | @Yoneda f a@ can be viewed as the partial application of 'fmap' to its second argument.
483−newtype Yoneda f a = Yoneda { runYoneda :: forall b. (a -> b) -> f b }
484−
485−-- | The natural isomorphism between @f@ and @'Yoneda' f@ given by the Yoneda lemma
486−-- is witnessed by 'liftYoneda' and 'lowerYoneda'
487−--
488−-- @
489−-- 'liftYoneda' . 'lowerYoneda' ≡ 'id'
490−-- 'lowerYoneda' . 'liftYoneda' ≡ 'id'
491−-- @
492−--
493−-- @
494−-- lowerYoneda (liftYoneda fa) = -- definition
495−-- lowerYoneda (Yoneda (\f -> fmap f a)) -- definition
496−-- (\f -> fmap f fa) id -- beta reduction
497−-- fmap id fa -- functor law
498−-- fa
499−-- @
500−--
501−-- @
502−-- 'lift' = 'liftYoneda'
503−-- @
504−liftYoneda :: Functor f => f a -> Yoneda f a
505−liftYoneda a = Yoneda (\f -> fmap f a)
506−
507−lowerYoneda :: Yoneda f a -> f a
508−lowerYoneda (Yoneda f) = f id
509−
510−instance Functor (Yoneda f) where
511− fmap f m = Yoneda (\k -> runYoneda m (k . f))
512−
513−instance Applicative f => Applicative (Yoneda f) where
514− pure a = Yoneda (\f -> pure (f a))
515− Yoneda m <*> Yoneda n = Yoneda (\f -> m (f .) <*> n id)
src/Data/Generics/Internal/Profunctor/Iso.hsnew file+111
@@ -0,0 +1,111 @@
1+{-# OPTIONS_HADDOCK hide #-}
2+{-# LANGUAGE TupleSections #-}
3+{-# LANGUAGE GADTs #-}
4+{-# LANGUAGE NoMonomorphismRestriction #-}
5+{-# LANGUAGE Rank2Types #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE TypeFamilies #-}
8+{-# LANGUAGE TypeFamilyDependencies #-}
9+{-# LANGUAGE TypeOperators #-}
10+
11+-----------------------------------------------------------------------------
12+-- |
13+-- Module : Data.Generics.Internal.Profunctor.Iso
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+-- Internal lens helpers. Only exported for Haddock
21+--
22+-----------------------------------------------------------------------------
23+module Data.Generics.Internal.Profunctor.Iso where
24+
25+import Data.Profunctor (Profunctor(..))
26+import Data.Profunctor.Unsafe ((#.), (.#))
27+import GHC.Generics ((:*:)(..), (:+:)(..), Generic(..), M1(..), K1(..), Rep)
28+import Data.Coerce
29+import Data.Generics.Internal.GenericN (Rec (..))
30+
31+import qualified Data.Generics.Internal.VL.Iso as VL
32+
33+type Iso s t a b
34+ = forall p. (Profunctor p) => p a b -> p s t
35+
36+type Iso' s a = Iso s s a a
37+
38+-- | A type and its generic representation are isomorphic
39+repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
40+repIso = iso from to
41+
42+-- | 'M1' is just a wrapper around `f p`
43+--mIso :: Iso' (M1 i c f p) (f p)
44+mIso :: Iso (M1 i c f p) (M1 i c g p) (f p) (g p)
45+mIso = iso unM1 M1
46+{-# INLINE mIso #-}
47+
48+kIso :: Iso (K1 r a p) (K1 r b p) a b
49+kIso = iso unK1 K1
50+{-# INLINE kIso #-}
51+
52+recIso :: Iso (Rec r a p) (Rec r b p) a b
53+recIso = iso (unK1 . unRec) (Rec . K1)
54+{-# INLINE recIso #-}
55+
56+sumIso :: Iso ((a :+: b) x) ((a' :+: b') x) (Either (a x) (b x)) (Either (a' x) (b' x))
57+sumIso = iso back forth
58+ where forth (Left l) = L1 l
59+ forth (Right r) = R1 r
60+ back (L1 l) = Left l
61+ back (R1 r) = Right r
62+{-# INLINE sumIso #-}
63+
64+prodIso :: Iso ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
65+prodIso = iso (\(a :*: b) -> (a, b)) (\(a, b) -> (a :*: b))
66+
67+assoc3 :: Iso ((a, b), c) ((a', b'), c') (a, (b, c)) (a', (b', c'))
68+assoc3 = iso (\((a, b), c) -> (a, (b, c))) (\(a, (b, c)) -> ((a, b), c))
69+
70+--------------------------------------------------------------------------------
71+-- Iso stuff
72+
73+fromIso :: Iso s t a b -> Iso b a t s
74+fromIso l = withIso l $ \ sa bt -> iso bt sa
75+{-# INLINE fromIso #-}
76+
77+iso :: (s -> a) -> (b -> t) -> Iso s t a b
78+iso = dimap
79+{-# INLINE iso #-}
80+
81+iso2isovl :: Iso s t a b -> VL.Iso s t a b
82+iso2isovl _iso = withIso _iso VL.iso
83+{-# INLINE iso2isovl #-}
84+
85+withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
86+withIso ai k = case ai (Exchange id id) of
87+ Exchange sa bt -> k sa bt
88+
89+pairing :: Iso s t a b -> Iso s' t' a' b' -> Iso (s, s') (t, t') (a, a') (b, b')
90+pairing f g = withIso f $ \ sa bt -> withIso g $ \s'a' b't' ->
91+ iso (bmap sa s'a') (bmap bt b't')
92+ where bmap f' g' (a, b) = (f' a, g' b)
93+
94+data Exchange a b s t = Exchange (s -> a) (b -> t)
95+
96+instance Functor (Exchange a b s) where
97+ fmap f (Exchange sa bt) = Exchange sa (f . bt)
98+ {-# INLINE fmap #-}
99+
100+instance Profunctor (Exchange a b) where
101+ dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt)
102+ {-# INLINE dimap #-}
103+ lmap f (Exchange sa bt) = Exchange (sa . f) bt
104+ {-# INLINE lmap #-}
105+ rmap f (Exchange sa bt) = Exchange sa (f . bt)
106+ {-# INLINE rmap #-}
107+ ( #. ) _ = coerce
108+ {-# INLINE ( #. ) #-}
109+ ( .# ) p _ = coerce p
110+ {-# INLINE ( .# ) #-}
111+
src/Data/Generics/Internal/Profunctor/Lens.hsnew file+171
@@ -0,0 +1,171 @@
1+{-# OPTIONS_HADDOCK hide #-}
2+{-# LANGUAGE GADTs #-}
3+{-# LANGUAGE NoMonomorphismRestriction #-}
4+{-# LANGUAGE Rank2Types #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TupleSections #-}
7+{-# LANGUAGE TypeFamilies #-}
8+{-# LANGUAGE TypeFamilyDependencies #-}
9+{-# LANGUAGE TypeOperators #-}
10+
11+-----------------------------------------------------------------------------
12+-- |
13+-- Module : Data.Generics.Internal.Profunctor.Lens
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+-- Internal lens helpers. Only exported for Haddock
21+--
22+-----------------------------------------------------------------------------
23+module Data.Generics.Internal.Profunctor.Lens where
24+
25+import Data.Profunctor (Profunctor(..), Strong(..))
26+import Data.Bifunctor
27+import GHC.Generics
28+import Data.Generics.Internal.Profunctor.Iso
29+
30+type Lens s t a b
31+ = forall p . (Strong p) => p a b -> p s t
32+
33+type LensLike p s t a b
34+ = p a b -> p s t
35+
36+
37+ravel :: (ALens a b a b -> ALens a b s t) -> Lens s t a b
38+ravel l pab = conv (l idLens) pab
39+ where
40+ conv :: ALens a b s t -> Lens s t a b
41+ conv (ALens _get _set) = lens _get _set
42+
43+-- | Setting
44+set :: ((a -> b) -> s -> t) -> (s, b) -> t
45+set f (s, b)
46+ = f (const b) s
47+
48+view :: Lens s s a a -> s -> a
49+view l = withLensPrim l (\get _ -> snd . 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+
56+withLensPrim :: Lens s t a b -> (forall c . (s -> (c,a)) -> ((c, b) -> t) -> r) -> r
57+withLensPrim l k =
58+ case l idLens of
59+ ALens _get _set -> k _get _set
60+
61+idLens :: ALens a b a b
62+idLens = ALens (fork (const ()) id) snd
63+{-# INLINE idLens #-}
64+
65+-- | Lens focusing on the first element of a product
66+first :: Lens ((a :*: b) x) ((a' :*: b) x) (a x) (a' x)
67+first
68+ = lens (\(a :*: b) -> (b,a)) (\(b, a') -> a' :*: b)
69+
70+-- | Lens focusing on the second element of a product
71+second :: Lens ((a :*: b) x) ((a :*: b') x) (b x) (b' x)
72+second
73+ = lens (\(a :*: b) -> (a,b)) (\(a, b') -> a :*: b')
74+
75+fork :: (a -> b) -> (a -> c) -> a -> (b, c)
76+fork f g a = (f a, g a)
77+
78+swap :: (a, b) -> (b, a)
79+swap (a, b) = (b, a)
80+
81+cross :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
82+cross = bimap
83+
84+--------------------------------------------------------------------------------
85+
86+data Coyoneda f b = forall a. Coyoneda (a -> b) (f a)
87+
88+instance Functor (Coyoneda f) where
89+ fmap f (Coyoneda g fa)
90+ = Coyoneda (f . g) fa
91+
92+inj :: Functor f => Coyoneda f a -> f a
93+inj (Coyoneda f a) = fmap f a
94+
95+proj :: Functor f => f a -> Coyoneda f a
96+proj fa = Coyoneda id fa
97+
98+newtype Alongside p s t a b = Alongside { getAlongside :: p (s, a) (t, b) }
99+
100+instance Profunctor p => Profunctor (Alongside p c d) where
101+ dimap f g (Alongside pab) = Alongside $ dimap (fmap f) (fmap g) pab
102+
103+instance Strong p => Strong (Alongside p c d) where
104+ second' (Alongside pab) = Alongside . dimap shuffle shuffle . second' $ pab
105+ where
106+ shuffle (x,(y,z)) = (y,(x,z))
107+
108+(??) :: Functor f => f (a -> b) -> a -> f b
109+fab ?? a = fmap ($ a) fab
110+
111+-- Could implement this using primitives?
112+alongside :: Profunctor p =>
113+ LensLike (Alongside p s' t') s t a b
114+ -> LensLike (Alongside p a b) s' t' a' b'
115+ -> LensLike p (s, s') (t, t') (a, a') (b, b')
116+alongside l1 l2
117+ = dimap swap swap . getAlongside . l1 . Alongside . dimap swap swap . getAlongside . l2 . Alongside
118+
119+assoc3L :: Lens ((a, b), c) ((a', b'), c') (a, (b, c)) (a', (b', c'))
120+assoc3L f = assoc3 f
121+
122+stron :: (Either s s', b) -> Either (s, b) (s', b)
123+stron (e, b) = bimap (,b) (, b) e
124+
125+choosing :: 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 ->
127+ withLensPrim r (\getr setr ->
128+ let --g :: Either s s' -> a
129+ g e = case e of
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
133+ in lens g s))
134+
135+lens :: (s -> (c,a)) -> ((c,b) -> t) -> Lens s t a b
136+lens get _set = dimap get _set . second'
137+{-# INLINE lens #-}
138+
139+------------------------------------------------------------------------------
140+
141+data ALens a b s t = forall c . ALens (s -> (c,a)) ((c, b) -> t)
142+
143+instance Functor (ALens a b s) where
144+ fmap f (ALens _get _set) = ALens _get (f . _set)
145+
146+instance Profunctor (ALens a b) where
147+ dimap f g (ALens get _set) = ALens (get . f) (g . _set)
148+
149+instance Strong (ALens a b) where
150+ second' (ALens get _set) = ALens get' set' --(bimap id _set . assoc)
151+ where
152+ get' (c, a1) = let (c1, a) = get a1 in ((c, c1), a)
153+ set' ((c, c1), b) = (c, _set (c1, b))
154+ {-# INLINE second' #-}
155+
156+-- 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.
158+mLens :: Lens (M1 i c f p) (M1 i c g p) (f p) (g p)
159+mLens f = mIso f
160+
161+repLens :: (Generic a, Generic b) => Lens a b (Rep a x) (Rep b x)
162+repLens f = repIso f
163+
164+prodL :: Lens ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
165+prodL f = prodIso f
166+
167+prodR :: Lens (a' x, b' x) (a x, b x) ((a' :*: b') x) ((a :*: b) x)
168+prodR f = fromIso prodIso f
169+
170+assoc3R :: Lens (a', (b', c')) (a, (b, c)) ((a', b'), c') ((a, b), c)
171+assoc3R f = fromIso assoc3 f
src/Data/Generics/Internal/Profunctor/Prism.hsnew file+117
@@ -0,0 +1,117 @@
1+{-# OPTIONS_HADDOCK hide #-}
2+{-# LANGUAGE GADTs #-}
3+{-# LANGUAGE LambdaCase #-}
4+{-# LANGUAGE NoMonomorphismRestriction #-}
5+{-# LANGUAGE Rank2Types #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE TypeFamilies #-}
8+{-# LANGUAGE TypeFamilyDependencies #-}
9+{-# LANGUAGE TypeOperators #-}
10+
11+-----------------------------------------------------------------------------
12+-- |
13+-- Module : Data.Generics.Internal.Profunctor.Prism
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+-- Internal lens helpers. Only exported for Haddock
21+--
22+-----------------------------------------------------------------------------
23+module Data.Generics.Internal.Profunctor.Prism where
24+
25+import Data.Bifunctor (bimap)
26+import Data.Profunctor (Choice(..), Profunctor(..))
27+import Data.Tagged
28+import Data.Profunctor.Unsafe ((#.), (.#))
29+import GHC.Generics
30+import Data.Coerce
31+
32+type APrism s t a b = Market a b a b -> Market a b s t
33+
34+type Prism s t a b
35+ = forall p . (Choice p) => p a b -> p s t
36+
37+type Prism' s a = forall p . (Choice p) => p a a -> p s s
38+
39+left :: Prism ((a :+: c) x) ((b :+: c) x) (a x) (b x)
40+left = prism L1 $ gsum Right (Left . R1)
41+
42+right :: Prism ((a :+: b) x) ((a :+: c) x) (b x) (c x)
43+right = prism R1 $ gsum (Left . L1) Right
44+
45+prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
46+prism bt seta eta = dimap seta (either id bt) (right' eta)
47+
48+_Left :: Prism (Either a c) (Either b c) a b
49+_Left = left'
50+
51+_Right :: Prism (Either c a) (Either c b) a b
52+_Right = right'
53+
54+prismPRavel :: APrism s t a b -> Prism s t a b
55+prismPRavel l pab = (prism2prismp $ l idPrism) pab
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+--------------------------------------------------------------------------------
64+-- Prism stuff
65+
66+without' :: Prism s t a b -> Prism s t c d -> Prism s t (Either a c) (Either b d)
67+without' k =
68+ withPrism k $ \bt _ k' ->
69+ withPrism k' $ \dt setc ->
70+ prism (either bt dt) $ \s -> fmap Right (setc s)
71+{-# INLINE without' #-}
72+
73+withPrism :: APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
74+withPrism k f = case k idPrism of
75+ Market bt seta -> f bt seta
76+
77+prism2prismp :: Market a b s t -> Prism s t a b
78+prism2prismp (Market bt seta) = prism bt seta
79+
80+idPrism :: Market a b a b
81+idPrism = Market id Right
82+
83+gsum :: (a x -> c) -> (b x -> c) -> ((a :+: b) x) -> c
84+gsum f _ (L1 x) = f x
85+gsum _ g (R1 y) = g y
86+
87+plus :: (a -> b) -> (c -> d) -> Either a c -> Either b d
88+plus = bimap
89+
90+--------------------------------------------------------------------------------
91+-- Market
92+
93+data Market a b s t = Market (b -> t) (s -> Either t a)
94+
95+instance Functor (Market a b s) where
96+ fmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)
97+ {-# INLINE fmap #-}
98+
99+instance Profunctor (Market a b) where
100+ dimap f g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta . f)
101+ {-# INLINE dimap #-}
102+ lmap f (Market bt seta) = Market bt (seta . f)
103+ {-# INLINE lmap #-}
104+ rmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)
105+ {-# INLINE rmap #-}
106+ ( #. ) _ = coerce
107+ {-# INLINE ( #. ) #-}
108+ ( .# ) p _ = coerce p
109+ {-# INLINE ( .# ) #-}
110+
111+instance Choice (Market a b) where
112+ left' (Market bt seta) = Market (Left . bt) $ \case
113+ Left s -> case seta s of
114+ Left t -> Left (Left t)
115+ Right a -> Right a
116+ Right c -> Left (Right c)
117+ {-# INLINE left' #-}
src/Data/Generics/Internal/VL/Iso.hsnew file+80
@@ -0,0 +1,80 @@
1+{-# OPTIONS_HADDOCK hide #-}
2+{-# LANGUAGE GADTs #-}
3+{-# LANGUAGE NoMonomorphismRestriction #-}
4+{-# LANGUAGE Rank2Types #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TypeFamilies #-}
7+{-# LANGUAGE TypeFamilyDependencies #-}
8+{-# LANGUAGE TypeOperators #-}
9+
10+-----------------------------------------------------------------------------
11+-- |
12+-- Module : Data.Generics.Internal.VL.Iso
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+-- Internal lens helpers. Only exported for Haddock
20+--
21+-----------------------------------------------------------------------------
22+module Data.Generics.Internal.VL.Iso where
23+
24+import Data.Coerce (coerce)
25+import Data.Functor.Identity (Identity(..))
26+import Data.Profunctor (Profunctor(..))
27+import 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+
44+type Iso' s a
45+ = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s)
46+
47+type Iso s t a b
48+ = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
49+
50+fromIso :: Iso s t a b -> Iso b a t s
51+fromIso l = withIso l $ \ sa bt -> iso bt sa
52+{-# inline fromIso #-}
53+
54+-- | Extract the two functions, one from @s -> a@ and
55+-- one from @b -> t@ that characterize an 'Iso'.
56+withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
57+withIso ai k = case ai (Exchange id Identity) of
58+ Exchange sa bt -> k sa (coerce bt)
59+{-# inline withIso #-}
60+
61+-- | A type and its generic representation are isomorphic
62+repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
63+repIso = iso from to
64+
65+-- | 'M1' is just a wrapper around `f p`
66+mIso :: Iso (M1 i c f p) (M1 i c g p) (f p) (g p)
67+mIso = iso unM1 M1
68+
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+
75+prodIso :: Iso ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
76+prodIso = iso (\(a :*: b) -> (a, b)) (\(a, b) -> (a :*: b))
77+
78+iso :: (s -> a) -> (b -> t) -> Iso s t a b
79+iso sa bt = dimap sa (fmap bt)
80+{-# INLINE iso #-}
src/Data/Generics/Internal/VL/Lens.hsnew file+70
@@ -0,0 +1,70 @@
1+{-# OPTIONS_HADDOCK hide #-}
2+{-# LANGUAGE GADTs #-}
3+{-# LANGUAGE NoMonomorphismRestriction #-}
4+{-# LANGUAGE Rank2Types #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TypeFamilies #-}
7+{-# LANGUAGE TypeFamilyDependencies #-}
8+{-# LANGUAGE TypeOperators #-}
9+{-# LANGUAGE TupleSections #-}
10+
11+-----------------------------------------------------------------------------
12+-- |
13+-- Module : Data.Generics.Internal.VL.Lens
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+-- Internal lens helpers. Only exported for Haddock
21+--
22+-----------------------------------------------------------------------------
23+module Data.Generics.Internal.VL.Lens where
24+
25+import Control.Applicative (Const(..))
26+import Data.Coerce (coerce)
27+import Data.Functor.Identity (Identity(..))
28+import Data.Generics.Internal.Profunctor.Lens (ALens (..), idLens)
29+
30+-- | Type alias for lens
31+type Lens' s a
32+ = Lens s s a a
33+
34+type Lens s t a b
35+ = forall f. Functor f => (a -> f b) -> s -> f t
36+
37+view :: ((a -> Const a a) -> s -> Const a s) -> s -> a
38+view l s = (^.) s l
39+
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+
49+set :: Lens s t a b -> b -> s -> t
50+set l x = l .~ x
51+
52+over :: ((a -> Identity b) -> s -> Identity t) -> (a -> b) -> s -> t
53+over = coerce
54+
55+lens2lensvl :: ALens a b s t -> Lens s t a b
56+lens2lensvl (ALens _get _set) =
57+ \f x ->
58+ case _get x of
59+ (c, a) -> _set . (c, ) <$> f a
60+{-# INLINE lens2lensvl #-}
61+
62+ravel :: (ALens a b a b -> ALens a b s t)
63+ -> Lens s t a b
64+ravel l pab = (lens2lensvl $ l idLens) pab
65+
66+
67+lens :: (s -> a) -> ((s, b) -> t) -> Lens s t a b
68+lens get _set = \f x -> curry _set x <$> f (get x)
69+{-# INLINE[0] lens #-}
70+
src/Data/Generics/Internal/VL/Prism.hsnew file+74
@@ -0,0 +1,74 @@
1+{-# OPTIONS_HADDOCK hide #-}
2+{-# LANGUAGE GADTs #-}
3+{-# LANGUAGE NoMonomorphismRestriction #-}
4+{-# LANGUAGE Rank2Types #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TypeFamilies #-}
7+{-# LANGUAGE TypeFamilyDependencies #-}
8+{-# LANGUAGE TypeOperators #-}
9+
10+-----------------------------------------------------------------------------
11+-- |
12+-- Module : Data.Generics.Internal.VL.Prism
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+-- Internal lens helpers. Only exported for Haddock
20+--
21+-----------------------------------------------------------------------------
22+module Data.Generics.Internal.VL.Prism where
23+
24+import Data.Functor.Identity (Identity(..))
25+import Data.Profunctor (Choice(..), Profunctor(..))
26+import Data.Coerce
27+import Data.Generics.Internal.Profunctor.Prism (Market (..), plus, idPrism)
28+import Data.Tagged
29+import Data.Profunctor.Unsafe ((#.), (.#))
30+import Data.Monoid (First (..))
31+import Control.Applicative (Const(..))
32+
33+-- | Type alias for prism
34+type Prism s t a b
35+ = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)
36+
37+type Prism' s a
38+ = Prism s s a a
39+
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+
46+match :: Prism s t a b -> s -> Either t a
47+match 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+
54+prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
55+prism bt seta eta = dimap (\x -> plus pure id (seta x)) (either id (\x -> fmap bt x)) (right' eta)
56+{-# INLINE prism #-}
57+
58+prismRavel :: (Market a b a b -> Market a b s t) -> Prism s t a b
59+prismRavel l pab = (prism2prismvl $ l idPrism) pab
60+{-# INLINE prismRavel #-}
61+
62+type APrismVL s t a b = Market a b a (Identity b) -> Market a b s (Identity t)
63+
64+withPrism :: APrismVL s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
65+withPrism k f = case coerce (k (Market Identity Right)) of
66+ Market bt seta -> f bt seta
67+
68+prism2prismvl :: Market a b s t -> Prism s t a b
69+prism2prismvl (Market bt seta) = prism bt seta
70+{-# INLINE prism2prismvl #-}
71+
72+build :: (Tagged b (Identity b) -> Tagged t (Identity t)) -> b -> t
73+build p = runIdentity #. unTagged #. p .# Tagged .# Identity
74+{-# INLINE build #-}
src/Data/Generics/Internal/VL/Traversal.hsnew file+92
@@ -0,0 +1,92 @@
1+{-# OPTIONS_HADDOCK hide #-}
2+{-# LANGUAGE AllowAmbiguousTypes #-}
3+{-# LANGUAGE ConstraintKinds #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE NoMonomorphismRestriction #-}
6+{-# LANGUAGE Rank2Types #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeFamilies #-}
9+{-# LANGUAGE TypeFamilyDependencies #-}
10+{-# LANGUAGE TypeOperators #-}
11+
12+-----------------------------------------------------------------------------
13+-- |
14+-- Module : Data.Generics.Internal.VL.Traversal
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+-- Internal lens helpers. Only exported for Haddock
22+--
23+-----------------------------------------------------------------------------
24+module Data.Generics.Internal.VL.Traversal where
25+
26+import Data.Kind (Constraint)
27+
28+-- | Type alias for traversal
29+type Traversal' s a
30+ = forall f. Applicative f => (a -> f a) -> s -> f s
31+
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+
38+type Traversal s t a b
39+ = forall f. Applicative f => (a -> f b) -> s -> f t
40+
41+type LensLikeC c f s
42+ = (forall a. c a => a -> f a) -> s -> f s
43+
44+confusing :: Applicative f => Traversal s t a b -> (a -> f b) -> s -> f t
45+confusing t = \f -> lowerYoneda . lowerCurried . t (liftCurriedYoneda . f)
46+{-# INLINE confusing #-}
47+
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+
61+newtype Curried f a =
62+ Curried { runCurried :: forall r. f (a -> r) -> f r }
63+
64+instance Functor f => Functor (Curried f) where
65+ fmap f (Curried g) = Curried (g . fmap (.f))
66+ {-# INLINE fmap #-}
67+
68+instance (Functor f) => Applicative (Curried f) where
69+ pure a = Curried (fmap ($ a))
70+ {-# INLINE pure #-}
71+ Curried mf <*> Curried ma = Curried (ma . mf . fmap (.))
72+ {-# INLINE (<*>) #-}
73+
74+liftCurried :: Applicative f => f a -> Curried f a
75+liftCurried fa = Curried (<*> fa)
76+
77+lowerCurried :: Applicative f => Curried f a -> f a
78+lowerCurried (Curried f) = f (pure id)
79+newtype Yoneda f a = Yoneda { runYoneda :: forall b. (a -> b) -> f b }
80+
81+liftYoneda :: Functor f => f a -> Yoneda f a
82+liftYoneda a = Yoneda (\f -> fmap f a)
83+
84+lowerYoneda :: Yoneda f a -> f a
85+lowerYoneda (Yoneda f) = f id
86+
87+instance Functor (Yoneda f) where
88+ fmap f m = Yoneda (\k -> runYoneda m (k . f))
89+
90+instance Applicative f => Applicative (Yoneda f) where
91+ pure a = Yoneda (\f -> pure (f a))
92+ Yoneda m <*> Yoneda n = Yoneda (\f -> m (f .) <*> n id)
src/Data/Generics/Labels.hs+123−17
@@ -1,36 +1,142 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE ConstraintKinds #-}
4+{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE FunctionalDependencies #-}
3−{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE PolyKinds #-}
4−{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
5−{-# LANGUAGE TypeApplications #-}
10+{-# LANGUAGE TypeApplications #-}
11+{-# LANGUAGE TypeOperators #-}
6−{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE TypeFamilies #-}
7−{-# LANGUAGE UndecidableInstances #-}
13+{-# LANGUAGE UndecidableInstances #-}
8−{-# OPTIONS_GHC -Wno-orphans #-}
14+{-# OPTIONS_GHC -Wno-orphans #-}
9−
10
15
11--------------------------------------------------------------------------------
16--------------------------------------------------------------------------------
12-- |
17-- |
13-- Module : Data.Generics.Labels
18-- Module : Data.Generics.Labels
14−-- Copyright : (C) 2017 Csongor Kiss
19+-- Copyright : (C) 2019 Csongor Kiss
15−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16-- License : BSD3
20-- License : BSD3
21+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17-- Stability : experimental
22-- Stability : experimental
18-- Portability : non-portable
23-- Portability : non-portable
19--
24--
20−-- Provides an (orphan) IsLabel instance for field lenses.
25+-- Provides an (orphan) IsLabel instance for field lenses and constructor prisms.
21-- Use at your own risk.
26-- Use at your own risk.
22--------------------------------------------------------------------------------
27--------------------------------------------------------------------------------
23
28
24−module Data.Generics.Labels () where
29+module Data.Generics.Labels
30+ ( -- * Orphan IsLabel Instance
31+ -- $sec1
32+ Field(..)
33+ , Field'
34+ , Constructor(..)
35+ , Constructor'
36+ ) where
25
37
26import Data.Generics.Product
38import Data.Generics.Product
39+import Data.Generics.Sum
40+import Data.Generics.Internal.VL.Lens (Lens)
41+import Data.Generics.Internal.VL.Prism (Prism)
42+
43+import Data.Profunctor (Choice)
44+import Data.Type.Bool (type (&&))
45+import Data.Type.Equality (type (==))
46+
27import GHC.OverloadedLabels
47import GHC.OverloadedLabels
48+import GHC.TypeLits
49+
50+-- $sec1
51+-- An instance for creating lenses and prisms with @#identifiers@ from the
52+-- @OverloadedLabels@ extension. Note that since overloaded labels do not
53+-- support symbols starting with capital letters, all prisms (which come from
54+-- constructor names, which are capitalized) must be prefixed with an underscore
55+-- (e.g. @#_ConstructorName@).
56+--
57+-- Morally:
58+--
59+-- @
60+-- instance (HasField name s t a b) => IsLabel name (Lens s t a b) where ...
61+-- @
62+-- and
63+--
64+-- @
65+-- instance (AsConstructor name s t a b) => IsLabel name (Prism s t a b) where ...
66+-- @
67+--
68+-- Remember:
69+--
70+-- @
71+-- type Lens = forall f. Functor f => (a -> f b) -> s -> f t
72+--
73+-- type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)
74+-- @
75+--
76+-- The orphan instance is unavoidable if we want to work with
77+-- lenses-as-functions (as opposed to a 'ReifiedLens'-like newtype).
78+
79+-- | 'Field' is morally the same as 'HasField', but it is constructed from an
80+-- incoherent combination of 'HasField' and 'HasField''. In this way, it can be
81+-- seamlessly used in the 'IsLabel' instance even when dealing with data types
82+-- that don't have 'Field' instances (like data instances).
83+class Field name s t a b | s name -> a, t name -> b, s name b -> t, t name a -> s where
84+ fieldLens :: Lens s t a b
85+
86+type Field' name s a = Field name s s a a
87+
88+instance {-# INCOHERENT #-} HasField name s t a b => Field name s t a b where
89+ fieldLens = field @name
90+
91+instance {-# INCOHERENT #-} HasField' name s a => Field name s s a a where
92+ fieldLens = field' @name
93+
94+-- | 'Constructor' is morally the same as 'AsConstructor', but it is constructed from an
95+-- incoherent combination of 'AsConstructor' and 'AsConstructor''. In this way, it can be
96+-- seamlessly used in the 'IsLabel' instance even when dealing with data types
97+-- that don't have 'Constructor' instances (like data instances).
98+class Constructor name s t a b | name s -> a, name t -> b where
99+ constructorPrism :: Prism s t a b
100+
101+type Constructor' name s a = Constructor name s s a a
102+
103+instance {-# INCOHERENT #-} AsConstructor name s t a b => Constructor name s t a b where
104+ constructorPrism = _Ctor @name
105+
106+instance {-# INCOHERENT #-} AsConstructor' name s a => Constructor name s s a a where
107+ constructorPrism = _Ctor' @name
108+
109+type family BeginsWithCapital (name :: Symbol) :: Bool where
110+ BeginsWithCapital name = CmpSymbol "_@" name == 'LT && CmpSymbol "_[" name == 'GT
111+
112+instance ( capital ~ BeginsWithCapital name
113+ , IsLabelHelper capital name p f s t a b
114+ , pafb ~ p a (f b), psft ~ p s (f t)) => IsLabel name (pafb -> psft) where
115+#if __GLASGOW_HASKELL__ >= 802
116+ fromLabel = labelOutput @capital @name @p @f
117+#else
118+ fromLabel _ = labelOutput @capital @name @p @f
119+#endif
120+
121+-- | This helper class allows us to customize the output type of the lens to be
122+-- either 'Prism' or 'Lens' (by choosing appropriate @p@ and @f@) as well as to
123+-- choose between whether we're dealing with a lens or a prism. The choice is
124+-- made by whether the @capital@ argument is true or false, which is determined by
125+-- whether the symbol starts with an underscore followed by a capital letter
126+-- (a check done in the 'IsLabel' instance above). If so, then we're dealing
127+-- with a constructor name, which should be a prism, and otherwise, it's a field
128+-- name, so we have a lens.
129+class IsLabelHelper capital name p f s t a b where
130+ labelOutput :: p a (f b) -> p s (f t)
28
131
132+instance (Functor f, Field name s t a b) => IsLabelHelper 'False name (->) f s t a b where
133+ labelOutput = fieldLens @name
29
134
30−instance (HasField field s t a b, Functor f, sft ~ (s -> f t)) =>
31− IsLabel field ((a -> f b) -> sft) where
32#if __GLASGOW_HASKELL__ >= 802
135#if __GLASGOW_HASKELL__ >= 802
33− fromLabel = field @field
136+instance ( Applicative f, Choice p, Constructor name s t a b
137+ , name' ~ AppendSymbol "_" name) => IsLabelHelper 'True name' p f s t a b where
138+ labelOutput = constructorPrism @name
34#else
139#else
35− fromLabel _ = field @field
140+instance (TypeError ('Text "Labels for Prisms require at least GHC 8.2"), Choice p) => IsLabelHelper 'True name' p f s t a b where
141+ labelOutput = undefined
36#endif
142#endif
src/Data/Generics/Product.hs+8−3
@@ -1,7 +1,7 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2-- |
2-- |
3-- Module : Data.Generics.Product
3-- Module : Data.Generics.Product
4−-- Copyright : (C) 2017 Csongor Kiss
4+-- Copyright : (C) 2019 Csongor Kiss
5-- License : BSD3
5-- License : BSD3
6-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
6-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
7-- Stability : experimental
7-- Stability : experimental
@@ -22,8 +22,11 @@ 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
25 , module Data.Generics.Product.Types
27 , module Data.Generics.Product.Types
26− , module Data.Generics.Product.List
28+ , module Data.Generics.Product.Param
29+ , module Data.Generics.Product.Constraints
27 ) where
30 ) where
28
31
29import Data.Generics.Product.Any
32import Data.Generics.Product.Any
@@ -32,4 +35,6 @@ import Data.Generics.Product.Positions
32import Data.Generics.Product.Subtype
35import Data.Generics.Product.Subtype
33import Data.Generics.Product.Typed
36import Data.Generics.Product.Typed
34import Data.Generics.Product.Types
37import Data.Generics.Product.Types
35−import Data.Generics.Product.List
38+import Data.Generics.Product.Constraints
39+import Data.Generics.Product.Param
40+import Data.Generics.Product.HList
src/Data/Generics/Product/Any.hs+5−5
@@ -12,7 +12,7 @@
12-----------------------------------------------------------------------------
12-----------------------------------------------------------------------------
13-- |
13-- |
14-- Module : Data.Generics.Product.Any
14-- Module : Data.Generics.Product.Any
15−-- Copyright : (C) 2017 Csongor Kiss
15+-- Copyright : (C) 2019 Csongor Kiss
16-- License : BSD3
16-- License : BSD3
17-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
18-- Stability : experimental
18-- Stability : experimental
@@ -29,7 +29,7 @@ module Data.Generics.Product.Any
29 HasAny (..)
29 HasAny (..)
30 ) where
30 ) where
31
31
32−import Data.Generics.Internal.Lens
32+import Data.Generics.Internal.VL.Lens
33import Data.Generics.Product.Fields
33import Data.Generics.Product.Fields
34import Data.Generics.Product.Positions
34import Data.Generics.Product.Positions
35import Data.Generics.Product.Typed
35import Data.Generics.Product.Typed
@@ -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.Lens
44+-- >>> :m +Data.Generics.Internal.VL.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 :: k) s t a b | s sel k -> a where
56+class HasAny sel s t a b | s sel -> a where
57 -- |A lens that focuses on a part of a product as identified by some
57 -- |A lens that focuses on a part of a product as identified by some
58 -- selector. Currently supported selectors are field names, positions and
58 -- selector. Currently supported selectors are field names, positions and
59 -- unique types. Compatible with the lens package's 'Control.Lens.Lens'
59 -- unique types. Compatible with the lens package's 'Control.Lens.Lens'
@@ -67,7 +67,7 @@ class HasAny (sel :: k) s t a b | s sel k -> a where
67 --
67 --
68 -- >>> human ^. the @3
68 -- >>> human ^. the @3
69 -- "London"
69 -- "London"
70− the :: LensVL s t a b
70+ the :: Lens s t a b
71
71
72instance HasPosition i s t a b => HasAny i s t a b where
72instance HasPosition i s t a b => HasAny i s t a b where
73 the = position @i
73 the = position @i
src/Data/Generics/Product/Constraints.hsnew file+57
@@ -0,0 +1,57 @@
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+96−30
@@ -16,7 +16,7 @@
16-----------------------------------------------------------------------------
16-----------------------------------------------------------------------------
17-- |
17-- |
18-- Module : Data.Generics.Product.Fields
18-- Module : Data.Generics.Product.Fields
19−-- Copyright : (C) 2017 Csongor Kiss
19+-- Copyright : (C) 2019 Csongor Kiss
20-- License : BSD3
20-- License : BSD3
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
22-- Stability : experimental
22-- Stability : experimental
@@ -31,20 +31,23 @@ module Data.Generics.Product.Fields
31
31
32 -- $setup
32 -- $setup
33 HasField (..)
33 HasField (..)
34− , HasField'
34+ , HasField' (..)
35+ , HasField_ (..)
35
36
36 , getField
37 , getField
37 , setField
38 , setField
38 ) where
39 ) where
39
40
40import Data.Generics.Internal.Families
41import Data.Generics.Internal.Families
41−import Data.Generics.Internal.Lens
42+import Data.Generics.Internal.VL.Lens as VL
42import Data.Generics.Internal.Void
43import Data.Generics.Internal.Void
43−import Data.Generics.Product.Internal.Keyed
44+import Data.Generics.Product.Internal.GLens
44
45
45import Data.Kind (Constraint, Type)
46import Data.Kind (Constraint, Type)
46import GHC.Generics
47import GHC.Generics
47import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError)
48import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError)
49+import Data.Generics.Internal.Profunctor.Lens as P
50+import Data.Generics.Internal.Errors
48
51
49-- $setup
52-- $setup
50-- == /Running example:/
53-- == /Running example:/
@@ -55,7 +58,7 @@ import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError)
55-- >>> :set -XGADTs
58-- >>> :set -XGADTs
56-- >>> :set -XFlexibleContexts
59-- >>> :set -XFlexibleContexts
57-- >>> import GHC.Generics
60-- >>> import GHC.Generics
58−-- >>> :m +Data.Generics.Internal.Lens
61+-- >>> :m +Data.Generics.Internal.VL.Lens
59-- >>> :m +Data.Function
62-- >>> :m +Data.Function
60-- >>> :{
63-- >>> :{
61-- data Human a
64-- data Human a
@@ -108,49 +111,109 @@ class HasField (field :: Symbol) s t a b | s field -> a, t field -> b, s field b
108 -- ... The offending constructors are:
111 -- ... The offending constructors are:
109 -- ... HumanNoAddress
112 -- ... HumanNoAddress
110 -- ...
113 -- ...
111− field :: LensVL s t a b
114+ field :: VL.Lens s t a b
112
115
113−type HasField' field s a = HasField field s s a a
116+-- |Records that have a field with a given name.
117+--
118+-- This is meant to be more general than 'HasField', but that is not quite the
119+-- case due to the lack of functional dependencies.
120+--
121+-- The types @s@ and @t@ must be applications of the same type constructor.
122+-- In contrast, 'HasField' also requires the parameters of that type constructor
123+-- to have representational roles.
124+--
125+-- One use case of 'HasField_' over 'HasField' is for records defined with
126+-- @data instance@.
127+class HasField_ (field :: Symbol) s t a b where
128+ field_ :: VL.Lens s t a b
129+
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
114
139
115-- |
140-- |
116-- >>> getField @"age" human
141-- >>> getField @"age" human
117-- 50
142-- 50
118−getField :: forall f s t a b . HasField' f s a => s -> a
143+getField :: forall f a s. HasField' f s a => s -> a
119−getField = viewVL' (field @f)
144+getField = VL.view (field' @f)
120
145
121-- |
146-- |
122-- >>> setField @"age" 60 human
147-- >>> setField @"age" 60 human
123-- Human {name = "Tunyasz", age = 60, address = "London", other = False}
148-- Human {name = "Tunyasz", age = 60, address = "London", other = False}
124setField :: forall f s a. HasField' f s a => a -> s -> s
149setField :: forall f s a. HasField' f s a => a -> s -> s
125−setField = setVL (field @f)
150+setField = VL.set (field' @f)
126
151
127−instance -- see Note [Changing type parameters]
152+instance
128 ( Generic s
153 ( Generic s
129 , ErrorUnless field s (CollectField field (Rep s))
154 , ErrorUnless field s (CollectField field (Rep s))
130− , Generic t
155+ , GLens' (HasTotalFieldPSym field) (Rep s) a
131− -- see Note [CPP in instance constraints]
156+ , Defined (Rep s)
132−#if __GLASGOW_HASKELL__ < 802
157+ (NoGeneric s '[ 'Text "arising from a generic lens focusing on the "
133− , '(s', t') ~ '(Proxied s, Proxied t)
158+ ':<>: QuoteType field ':<>: 'Text " field of type " ':<>: QuoteType a
134−#else
159+ , 'Text "in " ':<>: QuoteType s])
135− , s' ~ Proxied s
160+ (() :: Constraint)
136− , t' ~ Proxied t
137−#endif
138− , Generic s'
139− , Generic t'
140− , GHasKey' field (Rep s) a
141− , GHasKey' field (Rep s') a'
142− , GHasKey' field (Rep t') b'
143− , GHasKey field (Rep s) (Rep t) a b
144− , t ~ Infer s a' b
145− , s ~ Infer t b' a
146− ) => HasField field s t a b where
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
147
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
148− field f s = ravel (repLens . gkey @field) f s
176+ field f s = field0 @field f s
149
177
150−-- -- See Note [Uncluttering type signatures]
178+-- | See Note [Uncluttering type signatures]
179+#if __GLASGOW_HASKELL__ < 804
180+-- >>> :t field
181+-- field
182+-- :: (HasField field s t a b, Functor f) => (a -> f b) -> s -> f t
183+#else
184+-- >>> :t field
185+-- field
186+-- :: (Functor f, HasField field s t a b) => (a -> f b) -> s -> f t
187+#endif
151instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where
188instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where
152 field = undefined
189 field = undefined
153
190
191+instance
192+ ( HasTotalFieldP field (Rep s) ~~ 'Just a
193+ , HasTotalFieldP field (Rep t) ~~ 'Just b
194+ , UnifyHead s t
195+ , UnifyHead t s
196+ , HasField0 field s t a b
197+ ) => HasField_ field s t a b where
198+ field_ f s = field0 @field f s
199+
200+instance {-# OVERLAPPING #-} HasField_ f (Void1 a) (Void1 b) a b where
201+ field_ = undefined
202+
203+instance
204+ ( Generic s
205+ , Generic t
206+ , GLens (HasTotalFieldPSym field) (Rep s) (Rep t) a b
207+ , ErrorUnless field s (CollectField field (Rep s))
208+ , Defined (Rep s)
209+ (NoGeneric s '[ 'Text "arising from a generic lens focusing on the "
210+ ':<>: QuoteType field ':<>: 'Text " field of type " ':<>: QuoteType a
211+ , 'Text "in " ':<>: QuoteType s])
212+ (() :: Constraint)
213+ ) => HasField0 field s t a b where
214+ field0 = VL.ravel (repLens . glens @(HasTotalFieldPSym field))
215+ {-# INLINE field0 #-}
216+
154type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Constraint where
217type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Constraint where
155 ErrorUnless field s ('TypeStat _ _ '[])
218 ErrorUnless field s ('TypeStat _ _ '[])
156 = TypeError
219 = TypeError
@@ -172,3 +235,6 @@ type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Cons
172
235
173 ErrorUnless _ _ ('TypeStat '[] '[] _)
236 ErrorUnless _ _ ('TypeStat '[] '[] _)
174 = ()
237 = ()
238+
239+data HasTotalFieldPSym :: Symbol -> (TyFun (Type -> Type) (Maybe Type))
240+type instance Eval (HasTotalFieldPSym sym) tt = HasTotalFieldP sym tt
src/Data/Generics/Product/HList.hsnew file+46
@@ -0,0 +1,46 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE MonoLocalBinds #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE TypeInType #-}
8+{-# LANGUAGE UndecidableInstances #-}
9+
10+-----------------------------------------------------------------------------
11+-- |
12+-- Module : Data.Generics.Product.HList
13+-- Copyright : (C) 2019 Csongor Kiss
14+-- License : BSD3
15+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16+-- Stability : experimental
17+-- Portability : non-portable
18+--
19+-- Derive an isomorphism between a product type and a flat HList.
20+--
21+-----------------------------------------------------------------------------
22+
23+module Data.Generics.Product.HList
24+ ( IsList (..)
25+ ) where
26+
27+import Data.Generics.Product.Internal.HList
28+import Data.Kind
29+import GHC.Generics
30+import Data.Generics.Internal.VL.Iso (Iso)
31+import Data.Generics.Internal.Profunctor.Iso (repIso, iso2isovl)
32+
33+class IsList
34+ (f :: Type)
35+ (g :: Type)
36+ (as :: [Type])
37+ (bs :: [Type]) | f -> as, g -> bs where
38+ list :: Iso f g (HList as) (HList bs)
39+
40+instance
41+ ( Generic f
42+ , Generic g
43+ , GIsList (Rep f) (Rep g) as bs
44+ ) => IsList f g as bs where
45+ list = iso2isovl (repIso . glist)
46+ {-# INLINE list #-}
src/Data/Generics/Product/Internal/Constraints.hsnew file+136
@@ -0,0 +1,136 @@
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.hsnew file+81
@@ -0,0 +1,81 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE TypeInType #-}
3+{-# LANGUAGE AllowAmbiguousTypes #-}
4+{-# LANGUAGE ConstraintKinds #-}
5+{-# LANGUAGE DataKinds #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE FunctionalDependencies #-}
8+{-# LANGUAGE KindSignatures #-}
9+{-# LANGUAGE MultiParamTypeClasses #-}
10+{-# LANGUAGE Rank2Types #-}
11+{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE TypeApplications #-}
13+{-# LANGUAGE TypeFamilies #-}
14+{-# LANGUAGE TypeOperators #-}
15+{-# LANGUAGE UndecidableInstances #-}
16+
17+-----------------------------------------------------------------------------
18+-- |
19+-- Module : Data.Generics.Product.Internal.GLens
20+-- Copyright : (C) 2019 Csongor Kiss
21+-- License : BSD3
22+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
23+-- Stability : experimental
24+-- Portability : non-portable
25+--
26+-- Derive record field getters and setters generically.
27+--
28+-----------------------------------------------------------------------------
29+
30+module Data.Generics.Product.Internal.GLens
31+ ( GLens (..)
32+ , GLens'
33+ , TyFun
34+ , Eval
35+ ) where
36+
37+import Data.Generics.Internal.Profunctor.Lens (Lens, choosing, first, second)
38+import Data.Generics.Internal.Profunctor.Iso (kIso, sumIso, mIso)
39+
40+import Data.Kind (Type)
41+import GHC.Generics
42+
43+type Pred = TyFun (Type -> Type) (Maybe Type)
44+
45+type TyFun a b = a -> b -> Type
46+type family Eval (f :: TyFun a b) (x :: a) :: b
47+
48+-- A generic lens that uses some predicate to determine which field to focus on
49+class GLens (pred :: Pred) (s :: Type -> Type) (t :: Type -> Type) a b | s pred -> a, t pred -> b where
50+ glens :: Lens (s x) (t x) a b
51+
52+type GLens' pred s a = GLens pred s s a a
53+
54+instance GProductLens (Eval pred l) pred l r l' r' a b
55+ => GLens pred (l :*: r) (l' :*: r') a b where
56+
57+ glens = gproductLens @(Eval pred l) @pred
58+ {-# INLINE glens #-}
59+
60+instance (GLens pred l l' a b, GLens pred r r' a b) => GLens pred (l :+: r) (l' :+: r') a b where
61+ glens = sumIso . choosing (glens @pred) (glens @pred)
62+ {-# INLINE glens #-}
63+
64+instance GLens pred (K1 r a) (K1 r b) a b where
65+ glens = kIso
66+ {-# INLINE glens #-}
67+
68+instance (GLens pred f g a b) => GLens pred (M1 m meta f) (M1 m meta g) a b where
69+ glens = mIso . glens @pred
70+ {-# INLINE glens #-}
71+
72+class GProductLens (left :: Maybe Type) (pred :: Pred) l r l' r' a b | pred l r -> a, pred l' r' -> b where
73+ gproductLens :: Lens ((l :*: r) x) ((l' :*: r') x) a b
74+
75+instance GLens pred l l' a b => GProductLens ('Just x) pred l r l' r a b where
76+ gproductLens = first . glens @pred
77+ {-# INLINE gproductLens #-}
78+
79+instance GLens pred r r' a b => GProductLens 'Nothing pred l r l r' a b where
80+ gproductLens = second . glens @pred
81+ {-# INLINE gproductLens #-}
src/Data/Generics/Product/Internal/HList.hsnew file+329
@@ -0,0 +1,329 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE ConstraintKinds #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE FunctionalDependencies #-}
6+{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TupleSections #-}
9+{-# LANGUAGE TypeApplications #-}
10+{-# LANGUAGE TypeFamilies #-}
11+{-# LANGUAGE TypeInType #-}
12+{-# LANGUAGE TypeOperators #-}
13+{-# LANGUAGE UndecidableInstances #-}
14+
15+#if __GLASGOW_HASKELL__ == 802
16+{-# OPTIONS_GHC -fno-solve-constant-dicts #-}
17+#endif
18+
19+
20+-----------------------------------------------------------------------------
21+-- |
22+-- Module : Data.Generics.Product.Internal.HList
23+-- Copyright : (C) 2019 Csongor Kiss
24+-- License : BSD3
25+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
26+-- Stability : experimental
27+-- Portability : non-portable
28+--
29+-- Derive an isomorphism between a product type and a flat HList.
30+--
31+-----------------------------------------------------------------------------
32+
33+module Data.Generics.Product.Internal.HList
34+ ( GIsList(..)
35+ , IndexList (..)
36+ , HList (..)
37+ , type (++)
38+ , Elem
39+ , ListTuple (..)
40+ , TupleToList
41+ ) where
42+
43+#if __GLASGOW_HASKELL__ < 804
44+import Data.Semigroup
45+#endif
46+import GHC.TypeLits
47+
48+import Data.Kind (Type)
49+import GHC.Generics
50+import Data.Profunctor
51+import Data.Generics.Internal.Profunctor.Lens
52+import Data.Generics.Internal.Profunctor.Iso
53+
54+data HList (as :: [Type]) where
55+ Nil :: HList '[]
56+ (:>) :: a -> HList as -> HList (a ': as)
57+
58+infixr 5 :>
59+
60+type family ((as :: [k]) ++ (bs :: [k])) :: [k] where
61+ '[] ++ bs = bs
62+ (a ': as) ++ bs = a ': as ++ bs
63+
64+instance Semigroup (HList '[]) where
65+ _ <> _ = Nil
66+
67+instance Monoid (HList '[]) where
68+ mempty = Nil
69+ mappend _ _ = Nil
70+
71+instance (Semigroup a, Semigroup (HList as)) => Semigroup (HList (a ': as)) where
72+ (x :> xs) <> (y :> ys) = (x <> y) :> (xs <> ys)
73+
74+instance (Monoid a, Monoid (HList as)) => Monoid (HList (a ': as)) where
75+ mempty = mempty :> mempty
76+ mappend (x :> xs) (y :> ys) = mappend x y :> mappend xs ys
77+
78+class Elem (as :: [(k, Type)]) (key :: k) (i :: Nat) a | as key -> i a
79+instance {-# OVERLAPPING #-} pos ~ 0 => Elem (a ': xs) key pos a
80+instance (Elem xs key i a, pos ~ (i + 1)) => Elem (x ': xs) key pos a
81+
82+class GIsList
83+ (f :: Type -> Type)
84+ (g :: Type -> Type)
85+ (as :: [Type])
86+ (bs :: [Type]) | f -> as, g -> bs, bs f -> g, as g -> f where
87+
88+ glist :: Iso (f x) (g x) (HList as) (HList bs)
89+
90+ -- We define this reversed version, otherwise uses of `fromIso glist` are not
91+ -- properly inlined by GHC 8.0.2.
92+ -- This is not actually used.
93+ glistR :: Iso (HList bs) (HList as) (g x) (f x)
94+ glistR = fromIso glist
95+
96+instance
97+ ( GIsList l l' as as'
98+ , GIsList r r' bs bs'
99+ , Appending as bs cs as' bs' cs'
100+ , cs ~ (as ++ bs)
101+ , cs' ~ (as' ++ bs')
102+ ) => GIsList (l :*: r) (l' :*: r') cs cs' where
103+
104+ glist = prodIso . pairing glist glist . appending
105+ {-# INLINE glist #-}
106+
107+instance GIsList f g as bs => GIsList (M1 t meta f) (M1 t meta g) as bs where
108+ glist = mIso . glist
109+ {-# INLINE glist #-}
110+
111+instance GIsList (Rec0 a) (Rec0 b) '[a] '[b] where
112+ glist = kIso . singleton
113+ {-# INLINE glist #-}
114+
115+instance GIsList U1 U1 '[] '[] where
116+ glist = iso (const Nil) (const U1)
117+ {-# INLINE glist #-}
118+
119+--------------------------------------------------------------------------------
120+-- | as ++ bs === cs
121+class Appending as bs cs as' bs' cs'
122+ | as bs cs cs' -> as' bs'
123+ , as' bs' cs cs' -> as bs
124+ , as bs -> cs
125+ , as' bs' -> cs'
126+ where
127+ appending :: Iso (HList as, HList bs) (HList as', HList bs') (HList cs) (HList cs')
128+
129+-- | [] ++ bs === bs
130+instance Appending '[] bs bs '[] bs' bs' where
131+ appending = iso snd (Nil,)
132+
133+-- | (a : as) ++ bs === (a : cs)
134+instance
135+ Appending as bs cs as' bs' cs' -- as ++ bs == cs
136+ => Appending (a ': as) bs (a ': cs) (a' ': as') bs' (a' ': cs') where
137+ appending
138+ = pairing (fromIso consing) id -- ((a, as), bs)
139+ . assoc3 -- (a, (as, bs))
140+ . pairing id appending -- (a, cs)
141+ . consing -- (a : cs)
142+
143+singleton :: Iso a b (HList '[a]) (HList '[ b])
144+singleton = iso (:> Nil) (\(x :> _) -> x)
145+
146+consing :: Iso (a, HList as) (b, HList bs) (HList (a ': as)) (HList (b ': bs))
147+consing = iso (\(x, xs) -> x :> xs) (\(x :> xs) -> (x, xs))
148+
149+--------------------------------------------------------------------------------
150+class IndexList (i :: Nat) as bs a b | i as -> a, i bs -> b, i as b -> bs, i bs a -> as where
151+ point :: Lens (HList as) (HList bs) a b
152+
153+instance {-# OVERLAPPING #-}
154+ ( as ~ (a ': as')
155+ , bs ~ (b ': as')
156+ ) => IndexList 0 as bs a b where
157+ point = lens (\(x :> xs) -> (xs, x)) (\(xs, x') -> x' :> xs)
158+ {-# INLINE point #-}
159+
160+instance
161+ ( IndexList (n - 1) as' bs' a b
162+ , as ~ (x ': as')
163+ , bs ~ (x ': bs')
164+ ) => IndexList n as bs a b where
165+ point = fromIso consing . alongside id (point @(n-1)) . second'
166+ {-# INLINE point #-}
167+
168+--------------------------------------------------------------------------------
169+-- * Convert tuples to/from HLists
170+
171+class ListTuple (tuple :: Type) (as :: [Type]) | as -> tuple where
172+ type ListToTuple as :: Type
173+ tupled :: Iso' (HList as) tuple
174+ tupled = iso listToTuple tupleToList
175+
176+ tupleToList :: tuple -> HList as
177+ listToTuple :: HList as -> tuple
178+
179+instance ListTuple () '[] where
180+ type ListToTuple '[] = ()
181+ tupleToList _ = Nil
182+ listToTuple _ = ()
183+
184+instance ListTuple a '[a] where
185+ type ListToTuple '[a] = a
186+ tupleToList a
187+ = a :> Nil
188+ listToTuple (a :> Nil)
189+ = a
190+
191+instance ListTuple (a, b) '[a, b] where
192+ type ListToTuple '[a, b] = (a, b)
193+ tupleToList (a, b)
194+ = a :> b :> Nil
195+ listToTuple (a :> b :> Nil)
196+ = (a, b)
197+
198+instance ListTuple (a, b, c) '[a, b, c] where
199+ type ListToTuple '[a, b, c] = (a, b, c)
200+ tupleToList (a, b, c)
201+ = a :> b :> c :> Nil
202+ listToTuple (a :> b :> c :> Nil)
203+ = (a, b, c)
204+
205+instance ListTuple (a, b, c, d) '[a, b, c, d] where
206+ type ListToTuple '[a, b, c, d] = (a, b, c, d)
207+ tupleToList (a, b, c, d)
208+ = a :> b :> c :> d:> Nil
209+ listToTuple (a :> b :> c :> d :> Nil)
210+ = (a, b, c, d)
211+
212+instance ListTuple (a, b, c, d, e) '[a, b, c, d, e] where
213+ type ListToTuple '[a, b, c, d, e] = (a, b, c, d, e)
214+ tupleToList (a, b, c, d, e)
215+ = a :> b :> c :> d:> e :> Nil
216+ listToTuple (a :> b :> c :> d :> e :> Nil)
217+ = (a, b, c, d, e)
218+
219+instance ListTuple (a, b, c, d, e, f) '[a, b, c, d, e, f] where
220+ type ListToTuple '[a, b, c, d, e, f] = (a, b, c, d, e, f)
221+ tupleToList (a, b, c, d, e, f)
222+ = a :> b :> c :> d:> e :> f :> Nil
223+ listToTuple (a :> b :> c :> d :> e :> f :> Nil)
224+ = (a, b, c, d, e, f)
225+
226+instance ListTuple (a, b, c, d, e, f, g) '[a, b, c, d, e, f, g] where
227+ type ListToTuple '[a, b, c, d, e, f, g] = (a, b, c, d, e, f, g)
228+ tupleToList (a, b, c, d, e, f, g)
229+ = a :> b :> c :> d:> e :> f :> g :> Nil
230+ listToTuple (a :> b :> c :> d :> e :> f :> g :> Nil)
231+ = (a, b, c, d, e, f, g)
232+
233+instance ListTuple (a, b, c, d, e, f, g, h) '[a, b, c, d, e, f, g, h] where
234+ type ListToTuple '[a, b, c, d, e, f, g, h] = (a, b, c, d, e, f, g, h)
235+ tupleToList (a, b, c, d, e, f, g, h)
236+ = a :> b :> c :> d:> e :> f :> g :> h :> Nil
237+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> Nil)
238+ = (a, b, c, d, e, f, g, h)
239+
240+instance ListTuple (a, b, c, d, e, f, g, h, j) '[a, b, c, d, e, f, g, h, j] where
241+ type ListToTuple '[a, b, c, d, e, f, g, h, j] = (a, b, c, d, e, f, g, h, j)
242+ tupleToList (a, b, c, d, e, f, g, h, j)
243+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> Nil
244+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> Nil)
245+ = (a, b, c, d, e, f, g, h, j)
246+
247+instance ListTuple (a, b, c, d, e, f, g, h, j, k) '[a, b, c, d, e, f, g, h, j, k] where
248+ type ListToTuple '[a, b, c, d, e, f, g, h, j, k] = (a, b, c, d, e, f, g, h, j, k)
249+ tupleToList (a, b, c, d, e, f, g, h, j, k)
250+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> Nil
251+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> Nil)
252+ = (a, b, c, d, e, f, g, h, j, k)
253+
254+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l) '[a, b, c, d, e, f, g, h, j, k, l] where
255+ type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l] = (a, b, c, d, e, f, g, h, j, k, l)
256+ tupleToList (a, b, c, d, e, f, g, h, j, k, l)
257+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> Nil
258+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> Nil)
259+ = (a, b, c, d, e, f, g, h, j, k, l)
260+
261+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m) '[a, b, c, d, e, f, g, h, j, k, l, m] where
262+ type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m] = (a, b, c, d, e, f, g, h, j, k, l, m)
263+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m)
264+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> Nil
265+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> Nil)
266+ = (a, b, c, d, e, f, g, h, j, k, l, m)
267+
268+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n) '[a, b, c, d, e, f, g, h, j, k, l, m, n] where
269+ type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n] = (a, b, c, d, e, f, g, h, j, k, l, m, n)
270+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n)
271+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil
272+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil)
273+ = (a, b, c, d, e, f, g, h, j, k, l, m, n)
274+
275+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o] where
276+ type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
277+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
278+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil
279+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil)
280+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
281+
282+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p] where
283+ type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
284+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
285+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil
286+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil)
287+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
288+
289+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q] where
290+ type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
291+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
292+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil
293+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil)
294+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
295+
296+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r] where
297+ type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
298+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
299+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil
300+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil)
301+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
302+
303+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s] where
304+ type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
305+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
306+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil
307+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil)
308+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
309+
310+type family TupleToList a where
311+ TupleToList () = '[]
312+ TupleToList (a, b) = '[a, b]
313+ TupleToList (a, b, c) = '[a, b, c]
314+ TupleToList (a, b, c, d) = '[a, b, c, d]
315+ TupleToList (a, b, c, d, e) = '[a, b, c, d, e]
316+ TupleToList (a, b, c, d, e, f) = '[a, b, c, d, e, f]
317+ TupleToList (a, b, c, d, e, f, g) = '[a, b, c, d, e, f, g]
318+ TupleToList (a, b, c, d, e, f, g, h) = '[a, b, c, d, e, f, g, h]
319+ TupleToList (a, b, c, d, e, f, g, h, j) = '[a, b, c, d, e, f, g, h, j]
320+ TupleToList (a, b, c, d, e, f, g, h, j, k) = '[a, b, c, d, e, f, g, h, j, k]
321+ TupleToList (a, b, c, d, e, f, g, h, j, k, l) = '[a, b, c, d, e, f, g, h, j, k, l]
322+ TupleToList (a, b, c, d, e, f, g, h, j, k, l, m) = '[a, b, c, d, e, f, g, h, j, k, l, m]
323+ TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n) = '[a, b, c, d, e, f, g, h, j, k, l, m, n]
324+ TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o) = '[a, b, c, d, e, f, g, h, j, k, l, m, n, o]
325+ TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p) = '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p]
326+ TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q) = '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q]
327+ TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r) = '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r]
328+ TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) = '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s]
329+ TupleToList a = '[a]
src/Data/Generics/Product/Internal/Keyed.hsdeleted−53
@@ -1,53 +0,0 @@
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.Internal.Lens
31−import Data.Generics.Product.Internal.List
32−import Data.Kind
33−import GHC.Generics
34−
35−class GHasKey (key :: k) (s :: Type -> Type) (t :: Type -> Type) a b | s key -> a, t key -> b where
36− gkey :: Lens (s x) (t x) a b
37−
38−type GHasKey' key s a = GHasKey key s s a a
39−
40−instance (GHasKey key l l' a b, GHasKey key r r' a b) => GHasKey key (l :+: r) (l' :+: r') a b where
41− gkey = sumIso . choosing (gkey @key) (gkey @key)
42−
43−instance (GHasKey key f g a b) => GHasKey key (M1 D meta f) (M1 D meta g) a b where
44− gkey = mLens . gkey @key
45−
46−instance
47− ( Elem as key i a
48− , Elem bs key i b
49− , IndexList i as bs a b
50− , GIsList k f g as bs
51− ) => GHasKey (key :: k) (M1 C meta f) (M1 C meta g) a b where
52− gkey = mIso . (glist @k) . point @i
53−
src/Data/Generics/Product/Internal/List.hsdeleted−344
@@ -1,344 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE CPP #-}
3−{-# LANGUAGE ConstraintKinds #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE FunctionalDependencies #-}
6−{-# LANGUAGE GADTs #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE TupleSections #-}
9−{-# LANGUAGE TypeApplications #-}
10−{-# LANGUAGE TypeFamilies #-}
11−{-# LANGUAGE TypeInType #-}
12−{-# LANGUAGE TypeOperators #-}
13−{-# LANGUAGE UndecidableInstances #-}
14−
15−#if __GLASGOW_HASKELL__ == 802
16−{-# OPTIONS_GHC -fno-solve-constant-dicts #-}
17−#endif
18−
19−
20−-----------------------------------------------------------------------------
21−-- |
22−-- Module : Data.Generics.Product.Internal.List
23−-- Copyright : (C) 2017 Csongor Kiss
24−-- License : BSD3
25−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
26−-- Stability : experimental
27−-- Portability : non-portable
28−--
29−-- Derive an isomorphism between a product type and a flat HList.
30−--
31−-----------------------------------------------------------------------------
32−
33−module Data.Generics.Product.Internal.List
34− ( GIsList (..)
35− , IndexList (..)
36− , List (..)
37− , type (++)
38− , Elem
39− , ListTuple (..)
40− , TupleToList
41− , Permuting (..)
42− , Appending (..)
43− ) where
44−
45−import GHC.TypeLits
46−import Data.Generics.Internal.Lens
47−
48−import Data.Kind (Type)
49−import GHC.Generics
50−import Data.Profunctor
51−
52−data List (as :: [(m, Type)]) where
53− Nil :: List '[]
54− (:>) :: a -> List as -> List ('(s, a) ': as)
55−
56−infixr 5 :>
57−
58−type family ((as :: [k]) ++ (bs :: [k])) :: [k] where
59− '[] ++ bs = bs
60− (a ': as) ++ bs = a ': as ++ bs
61−
62−instance Monoid (List '[]) where
63− mempty = Nil
64− mappend _ _ = Nil
65−
66−instance (Monoid a, Monoid (List as)) => Monoid (List ('(k, a) ': as)) where
67− mempty = mempty :> mempty
68− mappend (x :> xs) (y :> ys) = mappend x y :> mappend xs ys
69−
70−class Elem (as :: [(k, Type)]) (key :: k) (i :: Nat) a | as key -> i a
71−instance {-# OVERLAPPING #-} pos ~ 0 => Elem ('(key, a) ': xs) key pos a
72−instance (Elem xs key i a, pos ~ (i + 1)) => Elem (x ': xs) key pos a
73−
74−class GIsList
75− (m :: Type)
76− (f :: Type -> Type)
77− (g :: Type -> Type)
78− (as :: [(m, Type)])
79− (bs :: [(m, Type)]) | m f -> as, m g -> bs, bs f -> g, as g -> f where
80−
81− glist :: Iso (f x) (g x) (List as) (List bs)
82−
83− glistL :: Lens (f x) (g x) (List as) (List bs)
84− glistL f = glist @m f
85−
86− glistR :: Lens (List bs) (List as) (g x) (f x)
87− glistR f = fromIso (glist @m) f
88−
89−instance
90− ( GIsList m l l' as as'
91− , GIsList m r r' bs bs'
92− , Appending List as bs cs as' bs' cs'
93− , cs ~ (as ++ bs)
94− , cs' ~ (as' ++ bs')
95− ) => GIsList m (l :*: r) (l' :*: r') cs cs' where
96−
97− glist = prodIso . pairing (glist @m) (glist @m) . appending
98−
99−instance GIsList m f g as bs => GIsList m (M1 t meta f) (M1 t meta g) as bs where
100− glist = mIso . glist @m
101−
102−instance {-# OVERLAPS #-}
103− GIsList Symbol
104− (S1 ('MetaSel ('Just field) u s i) (Rec0 a))
105− (S1 ('MetaSel ('Just field) u s i) (Rec0 b))
106− '[ '(field, a)] '[ '(field, b)] where
107− glist = mIso . kIso . singleton
108−
109−instance GIsList Type (Rec0 a) (Rec0 a) '[ '(a, a)] '[ '(a, a)] where
110− glist = kIso . singleton
111−
112−instance GIsList () (Rec0 a) (Rec0 b) '[ '( '(), a)] '[ '( '(), b)] where
113− glist = kIso . singleton
114−
115−instance GIsList m U1 U1 '[] '[] where
116− glist = iso (const Nil) (const U1)
117−
118−--------------------------------------------------------------------------------
119−-- as ++ bs == cs
120−-- as' + == cs'
121−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
122− appending :: Iso (f as, f bs) (f as', f bs') (f cs) (f cs')
123−
124−instance Appending List '[] bs bs '[] bs' bs' where
125− appending = iso snd (Nil,)
126−
127−instance Appending List as bs cs as' bs' cs'
128− => Appending List ('(f, a) ': as) bs ('(f, a) ': cs) ('(f, a') ': as') bs' ('(f, a') ': cs') where
129− appending = pairing (fromIso consing) id . assoc3 . pairing id appending . consing
130−
131−singleton :: Iso a b (List '[ '(field, a)]) (List '[ '(field, b)])
132−singleton = iso (:> Nil) (\(x :> _) -> x)
133−
134−consing :: Iso (a, List as) (b, List bs) (List ('(f, a) ': as)) (List ('(f, b) ': bs))
135−consing = iso (\(x, xs) -> x :> xs) (\(x :> xs) -> (x, xs))
136−
137−--------------------------------------------------------------------------------
138−
139−-- This ended up not being used now... still cool to have
140−flipping :: Iso' (List (a1 ': a2 ': as)) (List (a2 ': a1 ': as))
141−flipping = iso
142− (\(a1 :> a2 :> as) -> a2 :> a1 :> as)
143− (\(a2 :> a1 :> as) -> a1 :> a2 :> as)
144−
145−class Inserting f a as bs | bs a -> as where
146− inserting :: Iso' (f (a ': as)) (f bs)
147−
148−instance Inserting f a as (a ': as) where
149− inserting = id
150−
151−instance Inserting List a as bs => Inserting List a ('(fb, b) ': as) ('(fb, b) ': bs) where
152− inserting = flipping . fromIso consing . pairing id (inserting @_ @a) . consing
153−
154−class Permuting f as bs where
155− permuting :: Iso' (f as) (f bs)
156−
157−instance Permuting List '[] '[] where
158− permuting = id
159−
160−instance (Permuting List as as', Inserting List '(fa, a) as' bs')
161− => Permuting List ('(fa, a) ': as) bs' where
162− permuting = fromIso consing . pairing id permuting . consing . (inserting @_ @'(fa, _))
163−
164−--------------------------------------------------------------------------------
165−class IndexList (i :: Nat) as bs a b | i as -> a, i bs -> b, i as b -> bs, i bs a -> as where
166− point :: Lens (List as) (List bs) a b
167−
168−instance {-# OVERLAPPING #-}
169− ( as ~ ('(f, a) ': as')
170− , bs ~ ('(f, b) ': as')
171− ) => IndexList 0 as bs a b where
172− point = lens (\(x :> xs) -> x) (\((x :> xs), x') -> x' :> xs)
173− {-# INLINE point #-}
174−
175−instance
176− ( IndexList (n - 1) as' bs' a b
177− , as ~ ('(f, x) ': as')
178− , bs ~ ('(f, x) ': bs')
179− ) => IndexList n as bs a b where
180− point = fromIso consing . alongside id (point @(n-1)) . second'
181− {-# INLINE point #-}
182−
183−--------------------------------------------------------------------------------
184−-- * Convert tuples to/from HLists
185−
186−class ListTuple (tuple :: Type) (as :: [(k, Type)]) | as -> tuple where
187− type ListToTuple as :: Type
188− tupled :: Iso' (List as) tuple
189− tupled = iso listToTuple tupleToList
190−
191− tupleToList :: tuple -> List as
192− listToTuple :: List as -> tuple
193−
194−instance ListTuple () '[] where
195− type ListToTuple '[] = ()
196− tupleToList _ = Nil
197− listToTuple _ = ()
198−
199−instance ListTuple a '[ '(fa, a)] where
200− type ListToTuple '[ '(fa, a)] = a
201− tupleToList a
202− = a :> Nil
203− listToTuple (a :> Nil)
204− = a
205−
206−instance ListTuple (a, b) '[ '(fa, a), '(fb, b)] where
207− type ListToTuple '[ '(fa, a), '(fb, b)] = (a, b)
208− tupleToList (a, b)
209− = a :> b :> Nil
210− listToTuple (a :> b :> Nil)
211− = (a, b)
212−
213−instance ListTuple (a, b, c) '[ '(fa, a), '(fb, b), '(fc, c)] where
214− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c)] = (a, b, c)
215− tupleToList (a, b, c)
216− = a :> b :> c :> Nil
217− listToTuple (a :> b :> c :> Nil)
218− = (a, b, c)
219−
220−instance ListTuple (a, b, c, d) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d)] where
221− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d)] = (a, b, c, d)
222− tupleToList (a, b, c, d)
223− = a :> b :> c :> d:> Nil
224− listToTuple (a :> b :> c :> d :> Nil)
225− = (a, b, c, d)
226−
227−instance ListTuple (a, b, c, d, e) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e)] where
228− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e)] = (a, b, c, d, e)
229− tupleToList (a, b, c, d, e)
230− = a :> b :> c :> d:> e :> Nil
231− listToTuple (a :> b :> c :> d :> e :> Nil)
232− = (a, b, c, d, e)
233−
234−instance ListTuple (a, b, c, d, e, f) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f)] where
235− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f)] = (a, b, c, d, e, f)
236− tupleToList (a, b, c, d, e, f)
237− = a :> b :> c :> d:> e :> f :> Nil
238− listToTuple (a :> b :> c :> d :> e :> f :> Nil)
239− = (a, b, c, d, e, f)
240−
241−instance ListTuple (a, b, c, d, e, f, g) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g)] where
242− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g)] = (a, b, c, d, e, f, g)
243− tupleToList (a, b, c, d, e, f, g)
244− = a :> b :> c :> d:> e :> f :> g :> Nil
245− listToTuple (a :> b :> c :> d :> e :> f :> g :> Nil)
246− = (a, b, c, d, e, f, g)
247−
248−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
249− 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)
250− tupleToList (a, b, c, d, e, f, g, h)
251− = a :> b :> c :> d:> e :> f :> g :> h :> Nil
252− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> Nil)
253− = (a, b, c, d, e, f, g, h)
254−
255−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
256− 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)
257− tupleToList (a, b, c, d, e, f, g, h, j)
258− = a :> b :> c :> d:> e :> f :> g :> h :> j :> Nil
259− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> Nil)
260− = (a, b, c, d, e, f, g, h, j)
261−
262−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
263− 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)
264− tupleToList (a, b, c, d, e, f, g, h, j, k)
265− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> Nil
266− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> Nil)
267− = (a, b, c, d, e, f, g, h, j, k)
268−
269−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
270− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l)] = (a, b, c, d, e, f, g, h, j, k, l)
271− tupleToList (a, b, c, d, e, f, g, h, j, k, l)
272− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> Nil
273− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> Nil)
274− = (a, b, c, d, e, f, g, h, j, k, l)
275−
276−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
277− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m)] = (a, b, c, d, e, f, g, h, j, k, l, m)
278− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m)
279− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> Nil
280− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> Nil)
281− = (a, b, c, d, e, f, g, h, j, k, l, m)
282−
283−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
284− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n)] = (a, b, c, d, e, f, g, h, j, k, l, m, n)
285− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n)
286− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil
287− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil)
288− = (a, b, c, d, e, f, g, h, j, k, l, m, n)
289−
290−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
291− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
292− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
293− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil
294− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil)
295− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)
296−
297−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
298− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
299− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
300− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil
301− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil)
302− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)
303−
304−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
305− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
306− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
307− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil
308− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil)
309− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)
310−
311−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
312− type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
313− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
314− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil
315− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil)
316− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)
317−
318−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
319− 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)
320− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
321− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil
322− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil)
323− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)
324−
325−type family TupleToList a where
326− TupleToList () = '[]
327− TupleToList (a, b) = '[ '( '(), a), '( '(), b)]
328− TupleToList (a, b, c) = '[ '( '(), a), '( '(), b), '( '(), c)]
329− TupleToList (a, b, c, d) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d)]
330− TupleToList (a, b, c, d, e) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e)]
331− TupleToList (a, b, c, d, e, f) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f)]
332− TupleToList (a, b, c, d, e, f, g) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g)]
333− TupleToList (a, b, c, d, e, f, g, h) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h)]
334− TupleToList (a, b, c, d, e, f, g, h, j) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j)]
335− TupleToList (a, b, c, d, e, f, g, h, j, k) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k)]
336− TupleToList (a, b, c, d, e, f, g, h, j, k, l) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l)]
337− 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)]
338− 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)]
339− 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)]
340− 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)]
341− 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)]
342− 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)]
343− 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)]
344− TupleToList a = '[ '( '(), a)]
src/Data/Generics/Product/Internal/Positions.hs+46−24
@@ -1,3 +1,4 @@
1+{-# LANGUAGE TypeInType #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE DataKinds #-}
@@ -16,7 +17,7 @@
16-----------------------------------------------------------------------------
17-----------------------------------------------------------------------------
17-- |
18-- |
18-- Module : Data.Generics.Product.Internal.Positions
19-- Module : Data.Generics.Product.Internal.Positions
19−-- Copyright : (C) 2017 Csongor Kiss
20+-- Copyright : (C) 2019 Csongor Kiss
20-- License : BSD3
21-- License : BSD3
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
22-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
22-- Stability : experimental
23-- Stability : experimental
@@ -27,38 +28,61 @@
27-----------------------------------------------------------------------------
28-----------------------------------------------------------------------------
28
29
29module Data.Generics.Product.Internal.Positions
30module Data.Generics.Product.Internal.Positions
30− ( GHasPosition (..)
31− , GHasPosition'
32− , type (<?)
31+ ( type (<?)
33 , Size
32 , Size
33+ , CRep
34 ) where
34 ) where
35
35
36−import Data.Generics.Internal.Lens
36+import Data.Generics.Internal.Families.Has (Pos)
37−
38−import Data.Generics.Product.Internal.List
39import Data.Kind (Type)
37import Data.Kind (Type)
40import Data.Type.Bool (If, Not)
38import Data.Type.Bool (If, Not)
41import GHC.Generics
39import GHC.Generics
42−import GHC.TypeLits (type (<=?), type (+), type (-), Nat)
40+import GHC.TypeLits (type (<=?), type (+), Nat)
41+
42+-- | Alias for the kind of the generic rep
43+type G = Type -> Type
44+
45+--------------------------------------------------------------------------------
46+
47+-- | In-order labeling of the generic tree with the field positions
48+--
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)
43
55
44−-- |As 'HasPosition' but over generic representations as defined by
56+-- | The actual traversal.
45−-- "GHC.Generics".
57+--
46−class GHasPosition (i :: Nat) (s :: Type -> Type) (t :: Type -> Type) a b | s i -> a, t i -> b, s t i -> b where
58+-- Might be cleaner if the sum and product parts were separated (as there's
47− gposition :: Lens (s x) (t x) a b
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)
48
72
49−type GHasPosition' i s a = GHasPosition i s s a a
73+type family Traverse1 (w :: G -> G) (z :: (G, Nat)) :: (G, Nat) where
74+ Traverse1 w '(i, n) = '(w i, n)
50
75
51−instance (GHasPosition i l l' a b, GHasPosition i r r' a b) => GHasPosition i (l :+: r) (l' :+: r') a b where
76+-- | For products, we first traverse the left-hand side, followed by the second
52− gposition = sumIso . choosing (gposition @i) (gposition @i)
77+-- using the counter returned by the left traversal.
78+type family TraverseProd (c :: G -> G -> G) (a :: (G, Nat)) (r :: G) :: (G, Nat) where
79+ TraverseProd w '(i, n) r = Traverse1 (w i) (Traverse r n)
53
80
54−instance GHasPosition i s t a b => GHasPosition i (M1 D meta s) (M1 D meta t) a b where
81+--------------------------------------------------------------------------------
55− gposition = mLens . gposition @i
82+-- Utilities
56
83
57−instance
84+type family Fst (p :: (a, b)) :: a where
58− ( IndexList (i - 1) as bs a b
85+ Fst '(a, b) = a
59− , GIsList () f g as bs
60− ) => GHasPosition i (M1 C meta f) (M1 C meta g) a b where
61− gposition = mIso . (glist @()) . point @(i - 1)
62
86
63type family Size f :: Nat where
87type family Size f :: Nat where
64 Size (l :*: r)
88 Size (l :*: r)
@@ -72,8 +96,6 @@ type family Size f :: Nat where
72 Size f
96 Size f
73 = 1
97 = 1
74
98
75−--------------------------------------------------------------------------------
76−
77type x <? y = Not (y <=? x)
99type x <? y = Not (y <=? x)
78infixl 4 <?
100infixl 4 <?
79
101
src/Data/Generics/Product/Internal/Subtype.hs+15−10
@@ -1,3 +1,4 @@
1+{-# LANGUAGE TypeInType #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
@@ -15,7 +16,7 @@
15-----------------------------------------------------------------------------
16-----------------------------------------------------------------------------
16-- |
17-- |
17-- Module : Data.Generics.Product.Internal.Subtype
18-- Module : Data.Generics.Product.Internal.Subtype
18−-- Copyright : (C) 2017 Csongor Kiss
19+-- Copyright : (C) 2019 Csongor Kiss
19-- License : BSD3
20-- License : BSD3
20-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21-- Stability : experimental
22-- Stability : experimental
@@ -31,11 +32,12 @@ module Data.Generics.Product.Internal.Subtype
31 ) where
32 ) where
32
33
33import Data.Generics.Internal.Families
34import Data.Generics.Internal.Families
34−import Data.Generics.Internal.Lens
35+import Data.Generics.Product.Internal.GLens
35−import Data.Generics.Product.Internal.Keyed
36
36
37import Data.Kind (Type)
37import Data.Kind (Type)
38import GHC.Generics
38import GHC.Generics
39+import GHC.TypeLits (Symbol)
40+import Data.Generics.Internal.Profunctor.Lens (view)
39
41
40--------------------------------------------------------------------------------
42--------------------------------------------------------------------------------
41-- * Generic upcasting
43-- * Generic upcasting
@@ -47,10 +49,10 @@ instance (GUpcast sub a, GUpcast sub b) => GUpcast sub (a :*: b) where
47 gupcast rep = gupcast rep :*: gupcast rep
49 gupcast rep = gupcast rep :*: gupcast rep
48
50
49instance
51instance
50− GHasKey field sub sub t t
52+ GLens' (HasTotalFieldPSym field) sub t
51 => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
53 => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
52
54
53− gupcast r = M1 (K1 (view (gkey @field) r))
55+ gupcast r = M1 (K1 (view (glens @(HasTotalFieldPSym field)) r))
54
56
55instance GUpcast sub sup => GUpcast sub (C1 c sup) where
57instance GUpcast sub sup => GUpcast sub (C1 c sup) where
56 gupcast = M1 . gupcast
58 gupcast = M1 . gupcast
@@ -80,13 +82,16 @@ instance GSmash sub sup => GSmash (C1 c sub) sup where
80instance GSmash sub sup => GSmash (D1 c sub) sup where
82instance GSmash sub sup => GSmash (D1 c sub) sup where
81 gsmash sup (M1 sub) = M1 (gsmash sup sub)
83 gsmash sup (M1 sub) = M1 (gsmash sup sub)
82
84
83−class GSmashLeaf sub sup (w :: Bool) where
85+class GSmashLeaf sub sup (w :: Maybe Type) where
84 gsmashLeaf :: sup p -> sub p -> sub p
86 gsmashLeaf :: sup p -> sub p -> sub p
85
87
86instance
88instance
87− GHasKey field sup sup t t
89+ GLens' (HasTotalFieldPSym field) sup t
88− => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'True where
90+ => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup ('Just t) where
89− gsmashLeaf sup _ = M1 (K1 (view (gkey @field) sup))
91+ gsmashLeaf sup _ = M1 (K1 (view (glens @(HasTotalFieldPSym field)) sup))
90
92
91−instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'False where
93+instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'Nothing where
92 gsmashLeaf _ = id
94 gsmashLeaf _ = id
95+
96+data HasTotalFieldPSym :: Symbol -> (TyFun (Type -> Type) (Maybe Type))
97+type instance Eval (HasTotalFieldPSym sym) tt = HasTotalFieldP sym tt
src/Data/Generics/Product/Internal/Types.hsdeleted−56
@@ -1,56 +0,0 @@
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.hsdeleted−77
@@ -1,77 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE FunctionalDependencies #-}
5−{-# LANGUAGE MonoLocalBinds #-}
6−{-# LANGUAGE ScopedTypeVariables #-}
7−{-# LANGUAGE TypeApplications #-}
8−{-# LANGUAGE TypeInType #-}
9−{-# LANGUAGE UndecidableInstances #-}
10−
11−-----------------------------------------------------------------------------
12−-- |
13−-- Module : Data.Generics.Product.List
14−-- Copyright : (C) 2017 Csongor Kiss
15−-- License : BSD3
16−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17−-- Stability : experimental
18−-- Portability : non-portable
19−--
20−-- Derive an isomorphism between a product type and a flat HList.
21−--
22−-----------------------------------------------------------------------------
23−
24−module Data.Generics.Product.List
25− ( IsList (..)
26− , IsRecord
27− , IsRecord'
28− ) where
29−
30−import Data.Generics.Internal.Lens
31−import Data.Generics.Product.Internal.List
32−import Data.Kind
33−import GHC.Generics
34−import GHC.TypeLits
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.hsnew file+121
@@ -0,0 +1,121 @@
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+124−28
@@ -1,3 +1,5 @@
1+{-# LANGUAGE TypeInType #-}
2+{-# LANGUAGE PartialTypeSignatures #-}
1{-# LANGUAGE CPP #-}
3{-# LANGUAGE CPP #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
4{-# LANGUAGE AllowAmbiguousTypes #-}
3{-# LANGUAGE ConstraintKinds #-}
5{-# LANGUAGE ConstraintKinds #-}
@@ -17,7 +19,7 @@
17-----------------------------------------------------------------------------
19-----------------------------------------------------------------------------
18-- |
20-- |
19-- Module : Data.Generics.Product.Positions
21-- Module : Data.Generics.Product.Positions
20−-- Copyright : (C) 2017 Csongor Kiss
22+-- Copyright : (C) 2019 Csongor Kiss
21-- License : BSD3
23-- License : BSD3
22-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
24-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
23-- Stability : experimental
25-- Stability : experimental
@@ -32,21 +34,27 @@ module Data.Generics.Product.Positions
32
34
33 -- $setup
35 -- $setup
34 HasPosition (..)
36 HasPosition (..)
35− , HasPosition'
37+ , HasPosition' (..)
38+ , HasPosition_ (..)
39+ , HasPosition0 (..)
36
40
37 , getPosition
41 , getPosition
38 , setPosition
42 , setPosition
39 ) where
43 ) where
40
44
41−import Data.Generics.Internal.Lens
45+import Data.Generics.Internal.VL.Lens as VL
42import Data.Generics.Internal.Void
46import Data.Generics.Internal.Void
43import Data.Generics.Internal.Families
47import Data.Generics.Internal.Families
44import Data.Generics.Product.Internal.Positions
48import Data.Generics.Product.Internal.Positions
49+import Data.Generics.Product.Internal.GLens
50+import Data.Generics.Internal.Errors
45
51
46import Data.Kind (Constraint, Type)
52import Data.Kind (Constraint, Type)
47import Data.Type.Bool (type (&&))
53import Data.Type.Bool (type (&&))
48import GHC.Generics
54import GHC.Generics
49import GHC.TypeLits (type (<=?), Nat, TypeError, ErrorMessage(..))
55import GHC.TypeLits (type (<=?), Nat, TypeError, ErrorMessage(..))
56+import Data.Generics.Internal.Profunctor.Lens as P
57+import Data.Coerce
50
58
51-- $setup
59-- $setup
52-- == /Running example:/
60-- == /Running example:/
@@ -57,7 +65,7 @@ import GHC.TypeLits (type (<=?), Nat, TypeError, ErrorMessage(..))
57-- >>> :set -XGADTs
65-- >>> :set -XGADTs
58-- >>> :set -XFlexibleContexts
66-- >>> :set -XFlexibleContexts
59-- >>> import GHC.Generics
67-- >>> import GHC.Generics
60−-- >>> :m +Data.Generics.Internal.Lens
68+-- >>> :m +Data.Generics.Internal.VL.Lens
61-- >>> :m +Data.Function
69-- >>> :m +Data.Function
62-- >>> :{
70-- >>> :{
63-- data Human = Human
71-- data Human = Human
@@ -86,43 +94,128 @@ class HasPosition (i :: Nat) s t a b | s i -> a, t i -> b, s i b -> t, t i a ->
86 -- ...
94 -- ...
87 -- ... The type Human does not contain a field at position 4
95 -- ... The type Human does not contain a field at position 4
88 -- ...
96 -- ...
89− position :: LensVL s t a b
97+ position :: VL.Lens s t a b
90
98
91−type HasPosition' i s a = HasPosition i s s a a
99+class HasPosition_ (i :: Nat) s t a b where
100+ position_ :: VL.Lens s t a b
92
101
102+-- |Records that have a field at a given position.
103+--
104+-- The difference between 'HasPosition' and 'HasPosition_' is similar to the
105+-- one between 'Data.Generics.Product.Fields.HasField' and
106+-- 'Data.Generics.Product.Fields.HasField_'.
107+-- See 'Data.Generics.Product.Fields.HasField_'.
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
93getPosition :: forall i s a. HasPosition' i s a => s -> a
121getPosition :: forall i s a. HasPosition' i s a => s -> a
94−getPosition s = s ^. position @i
122+getPosition s = s ^. position' @i
95
123
124+-- |
125+-- >>> setPosition @2 60 human
126+-- Human {name = "Tunyasz", age = 60, address = "London"}
96setPosition :: forall i s a. HasPosition' i s a => a -> s -> s
127setPosition :: forall i s a. HasPosition' i s a => a -> s -> s
97−setPosition = setVL (position @i)
128+setPosition = VL.set (position' @i)
98
129
99−instance -- see Note [Changing type parameters]
130+instance
100 ( Generic s
131 ( Generic s
101 , ErrorUnless i s (0 <? i && i <=? Size (Rep s))
132 , ErrorUnless i s (0 <? i && i <=? Size (Rep s))
102− , Generic t
133+ , cs ~ CRep s
103− -- see Note [CPP in instance constraints]
134+ , Coercible (Rep s) cs
104−#if __GLASGOW_HASKELL__ < 802
135+ , GLens' (HasTotalPositionPSym i) cs a
105− , '(s', t') ~ '(Proxied s, Proxied t)
136+ , Defined (Rep s)
106−#else
137+ (NoGeneric s '[ 'Text "arising from a generic lens focusing on the field at"
107− , s' ~ Proxied s
138+ , 'Text "position " ':<>: QuoteType i ':<>: 'Text " of type " ':<>: QuoteType a
108− , t' ~ Proxied t
139+ ':<>: 'Text " in " ':<>: QuoteType s
109−#endif
140+ ])
110− , Generic s'
141+ (() :: Constraint)
111− , Generic t'
112− , GHasPosition' i (Rep s) a
113− , GHasPosition' i (Rep s') a'
114− , GHasPosition i (Rep s) (Rep t) a b
115− , t ~ Infer s a' b
116− , GHasPosition' i (Rep t') b'
117− , s ~ Infer t b' a
118− ) => HasPosition i s t a b where
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
119
150
120− position f s = ravel (repLens . gposition @i) f s
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
121
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
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+
122−-- See Note [Uncluttering type signatures]
175+-- | See Note [Uncluttering type signatures]
176+#if __GLASGOW_HASKELL__ < 804
177+-- >>> :t position
178+-- position
179+-- :: (HasPosition i s t a b, Functor f) => (a -> f b) -> s -> f t
180+#else
181+-- >>> :t position
182+-- position
183+-- :: (Functor f, HasPosition i s t a b) => (a -> f b) -> s -> f t
184+#endif
123instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where
185instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where
124 position = undefined
186 position = undefined
125
187
188+instance
189+ ( ErrorUnless i s (0 <? i && i <=? Size (Rep s))
190+ , UnifyHead s t
191+ , UnifyHead t s
192+ , Coercible (CRep s) (Rep s)
193+ , Coercible (CRep t) (Rep t)
194+ , HasPosition0 i s t a b
195+ ) => HasPosition_ i s t a b where
196+
197+ position_ = position0 @i
198+ {-# INLINE position_ #-}
199+
200+instance {-# OVERLAPPING #-} HasPosition_ f (Void1 a) (Void1 b) a b where
201+ position_ = undefined
202+
203+instance
204+ ( Generic s
205+ , Generic t
206+ , GLens (HasTotalPositionPSym i) (CRep s) (CRep t) a b
207+ , Coercible (CRep s) (Rep s)
208+ , Coercible (CRep t) (Rep t)
209+ , Defined (Rep s)
210+ (NoGeneric s '[ 'Text "arising from a generic lens focusing on the field at"
211+ , 'Text "position " ':<>: QuoteType i ':<>: 'Text " of type " ':<>: QuoteType a
212+ ':<>: 'Text " in " ':<>: QuoteType s
213+ ])
214+ (() :: Constraint)
215+ ) => HasPosition0 i s t a b where
216+ position0 = VL.ravel (repLens . coerced @(CRep s) @(CRep t) . glens @(HasTotalPositionPSym i))
217+ {-# INLINE position0 #-}
218+
126type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint where
219type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint where
127 ErrorUnless i s 'False
220 ErrorUnless i s 'False
128 = TypeError
221 = TypeError
@@ -134,3 +227,6 @@ type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint wher
134
227
135 ErrorUnless _ _ 'True
228 ErrorUnless _ _ 'True
136 = ()
229 = ()
230+
231+data HasTotalPositionPSym :: Nat -> (TyFun (Type -> Type) (Maybe Type))
232+type instance Eval (HasTotalPositionPSym t) tt = HasTotalPositionP t tt
src/Data/Generics/Product/Subtype.hs+49−8
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
@@ -15,7 +16,7 @@
15-----------------------------------------------------------------------------
16-----------------------------------------------------------------------------
16-- |
17-- |
17-- Module : Data.Generics.Product.Subtype
18-- Module : Data.Generics.Product.Subtype
18−-- Copyright : (C) 2017 Csongor Kiss
19+-- Copyright : (C) 2019 Csongor Kiss
19-- License : BSD3
20-- License : BSD3
20-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21-- Stability : experimental
22-- Stability : experimental
@@ -33,13 +34,15 @@ module Data.Generics.Product.Subtype
33 ) where
34 ) where
34
35
35import Data.Generics.Internal.Families
36import Data.Generics.Internal.Families
36−import Data.Generics.Internal.Lens
37+import Data.Generics.Internal.VL.Lens as VL
37import Data.Generics.Internal.Void
38import Data.Generics.Internal.Void
38import Data.Generics.Product.Internal.Subtype
39import Data.Generics.Product.Internal.Subtype
39
40
40import GHC.Generics (Generic (Rep, to, from) )
41import GHC.Generics (Generic (Rep, to, from) )
41import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
42import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
42import Data.Kind (Type, Constraint)
43import Data.Kind (Type, Constraint)
44+import Data.Generics.Internal.Profunctor.Lens hiding (set)
45+import Data.Generics.Internal.Errors
43
46
44-- $setup
47-- $setup
45-- == /Running example:/
48-- == /Running example:/
@@ -49,7 +52,7 @@ import Data.Kind (Type, Constraint)
49-- >>> :set -XDeriveGeneric
52-- >>> :set -XDeriveGeneric
50-- >>> :set -XDuplicateRecordFields
53-- >>> :set -XDuplicateRecordFields
51-- >>> import GHC.Generics
54-- >>> import GHC.Generics
52−-- >>> :m +Data.Generics.Internal.Lens
55+-- >>> :m +Data.Generics.Internal.VL.Lens
53-- >>> :{
56-- >>> :{
54-- data Human = Human
57-- data Human = Human
55-- { name :: String
58-- { name :: String
@@ -80,9 +83,9 @@ class Subtype sup sub where
80 --
83 --
81 -- >>> set (super @Animal) (Animal "dog" 10) human
84 -- >>> set (super @Animal) (Animal "dog" 10) human
82 -- Human {name = "dog", age = 10, address = "London"}
85 -- Human {name = "dog", age = 10, address = "London"}
83− super :: LensVL sub sub sup sup
86+ super :: VL.Lens sub sub sup sup
84 super
87 super
85− = lensVL upcast (uncurry smash . swap)
88+ = VL.lens upcast (uncurry smash . swap)
86
89
87 -- |Cast the more specific subtype to the more general supertype
90 -- |Cast the more specific subtype to the more general supertype
88 --
91 --
@@ -103,7 +106,7 @@ class Subtype sup sub where
103 -- >>> smash (Animal "dog" 10) human
106 -- >>> smash (Animal "dog" 10) human
104 -- Human {name = "dog", age = 10, address = "London"}
107 -- Human {name = "dog", age = 10, address = "London"}
105 smash :: sup -> sub -> sub
108 smash :: sup -> sub -> sub
106− smash = setVL (super @sup)
109+ smash = VL.set (super @sup)
107
110
108 {-# MINIMAL super | smash, upcast #-}
111 {-# MINIMAL super | smash, upcast #-}
109
112
@@ -112,14 +115,52 @@ instance
112 , Generic b
115 , Generic b
113 , GSmash (Rep a) (Rep b)
116 , GSmash (Rep a) (Rep b)
114 , GUpcast (Rep a) (Rep b)
117 , GUpcast (Rep a) (Rep b)
115− , ErrorUnless b a (CollectFieldsOrdered (Rep b) \\ CollectFieldsOrdered (Rep a))
118+ , CustomError a b
116 ) => Subtype b a where
119 ) => Subtype b a where
117 smash p b = to $ gsmash (from p) (from b)
120 smash p b = to $ gsmash (from p) (from b)
118 upcast = to . gupcast . from
121 upcast = to . gupcast . from
119
122
123+type family CustomError a b :: Constraint where
124+ CustomError a b =
125+ ( ErrorUnless b a (CollectFieldsOrdered (Rep b) \\ CollectFieldsOrdered (Rep a))
126+ , Defined (Rep a)
127+ (NoGeneric a '[ 'Text "arising from a generic lens focusing on " ':<>: QuoteType b
128+ , 'Text "as a supertype of " ':<>: QuoteType a
129+ ])
130+ (() :: Constraint)
131+ , Defined (Rep b)
132+ (NoGeneric b '[ 'Text "arising from a generic lens focusing on " ':<>: QuoteType b
133+ , 'Text "as a supertype of " ':<>: QuoteType a
134+ ])
135+ (() :: Constraint)
136+ )
137+
138+instance {-# OVERLAPPING #-} Subtype a a where
139+ super = id
140+
120−-- See Note [Uncluttering type signatures]
141+-- | See Note [Uncluttering type signatures]
142+#if __GLASGOW_HASKELL__ < 804
143+-- >>> :t super
144+-- super
145+-- :: (Subtype sup sub, Functor f) => (sup -> f sup) -> sub -> f sub
146+#else
147+-- >>> :t super
148+-- super
149+-- :: (Functor f, Subtype sup sub) => (sup -> f sup) -> sub -> f sub
150+#endif
121instance {-# OVERLAPPING #-} Subtype a Void where
151instance {-# OVERLAPPING #-} Subtype a Void where
122 super = undefined
152 super = undefined
153+
154+-- | See Note [Uncluttering type signatures]
155+#if __GLASGOW_HASKELL__ < 804
156+-- >>> :t super @Int
157+-- super @Int
158+-- :: (Subtype Int sub, Functor f) => (Int -> f Int) -> sub -> f sub
159+#else
160+-- >>> :t super @Int
161+-- super @Int
162+-- :: (Functor f, Subtype Int sub) => (Int -> f Int) -> sub -> f sub
163+#endif
123instance {-# OVERLAPPING #-} Subtype Void a where
164instance {-# OVERLAPPING #-} Subtype Void a where
124 super = undefined
165 super = undefined
125
166
src/Data/Generics/Product/Typed.hs+38−10
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
@@ -7,13 +8,14 @@
7{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE TypeApplications #-}
9{-# LANGUAGE TypeApplications #-}
9{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE TypeFamilies #-}
11+{-# LANGUAGE TypeInType #-}
10{-# LANGUAGE TypeOperators #-}
12{-# LANGUAGE TypeOperators #-}
11{-# LANGUAGE UndecidableInstances #-}
13{-# LANGUAGE UndecidableInstances #-}
12
14
13-----------------------------------------------------------------------------
15-----------------------------------------------------------------------------
14-- |
16-- |
15-- Module : Data.Generics.Product.Typed
17-- Module : Data.Generics.Product.Typed
16−-- Copyright : (C) 2017 Csongor Kiss
18+-- Copyright : (C) 2019 Csongor Kiss
17-- License : BSD3
19-- License : BSD3
18-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19-- Stability : experimental
21-- Stability : experimental
@@ -31,13 +33,15 @@ module Data.Generics.Product.Typed
31 ) where
33 ) where
32
34
33import Data.Generics.Internal.Families
35import Data.Generics.Internal.Families
34−import Data.Generics.Internal.Lens
36+import Data.Generics.Internal.VL.Lens as VL
35import Data.Generics.Internal.Void
37import Data.Generics.Internal.Void
36−import Data.Generics.Product.Internal.Keyed
38+import Data.Generics.Product.Internal.GLens
37
39
38import Data.Kind (Constraint, Type)
40import Data.Kind (Constraint, Type)
39import GHC.Generics (Generic (Rep))
41import GHC.Generics (Generic (Rep))
40import GHC.TypeLits (TypeError, ErrorMessage (..))
42import GHC.TypeLits (TypeError, ErrorMessage (..))
43+import Data.Generics.Internal.Profunctor.Lens
44+import Data.Generics.Internal.Errors
41
45
42-- $setup
46-- $setup
43-- == /Running example:/
47-- == /Running example:/
@@ -46,7 +50,7 @@ import GHC.TypeLits (TypeError, ErrorMessage (..))
46-- >>> :set -XDataKinds
50-- >>> :set -XDataKinds
47-- >>> :set -XDeriveGeneric
51-- >>> :set -XDeriveGeneric
48-- >>> import GHC.Generics
52-- >>> import GHC.Generics
49−-- >>> :m +Data.Generics.Internal.Lens
53+-- >>> :m +Data.Generics.Internal.VL.Lens
50-- >>> :{
54-- >>> :{
51-- data Human
55-- data Human
52-- = Human
56-- = Human
@@ -91,9 +95,10 @@ class HasType a s where
91 -- ... The offending constructors are:
95 -- ... The offending constructors are:
92 -- ... HumanNoTall
96 -- ... HumanNoTall
93 -- ...
97 -- ...
94− typed :: LensVL s s a a
98+ typed :: VL.Lens s s a a
95 typed
99 typed
96− = lensVL (getTyped @a) (uncurry (setTyped @a) . swap)
100+ = VL.lens (getTyped @a) (uncurry (setTyped @a) . swap)
101+ {-# INLINE typed #-}
97
102
98 -- |Get field at type.
103 -- |Get field at type.
99 getTyped :: s -> a
104 getTyped :: s -> a
@@ -101,19 +106,38 @@ class HasType a s where
101
106
102 -- |Set field at type.
107 -- |Set field at type.
103 setTyped :: a -> s -> s
108 setTyped :: a -> s -> s
104− setTyped = setVL (typed @a)
109+ setTyped = VL.set (typed @a)
105
110
106 {-# MINIMAL typed | setTyped, getTyped #-}
111 {-# MINIMAL typed | setTyped, getTyped #-}
107
112
108instance
113instance
109 ( Generic s
114 ( Generic s
110 , ErrorUnlessOne a s (CollectTotalType a (Rep s))
115 , ErrorUnlessOne a s (CollectTotalType a (Rep s))
116+ , Defined (Rep s)
117+ (NoGeneric s '[ 'Text "arising from a generic lens focusing on a field of type " ':<>: QuoteType a])
118+ (() :: Constraint)
111− , GHasKey a (Rep s) (Rep s) a a
119+ , GLens (HasTotalTypePSym a) (Rep s) (Rep s) a a
112 ) => HasType a s where
120 ) => HasType a s where
113
121
114− typed = ravel (repLens . gkey @a)
122+ typed f s = VL.ravel (repLens . glens @(HasTotalTypePSym a)) f s
115
123
124+instance {-# OVERLAPPING #-} HasType a a where
125+ getTyped = id
126+ {-# INLINE getTyped #-}
127+
128+ setTyped a _ = a
129+ {-# INLINE setTyped #-}
130+
116−-- See Note [Uncluttering type signatures]
131+-- | See Note [Uncluttering type signatures]
132+#if __GLASGOW_HASKELL__ < 804
133+-- >>> :t typed
134+-- typed :: (HasType a s, Functor f) => (a -> f a) -> s -> f s
135+#else
136+-- >>> :t typed
137+-- typed :: (Functor f, HasType a s) => (a -> f a) -> s -> f s
138+#endif
139+--
140+-- Note that this might not longer be needed given the above 'HasType a a' instance.
117instance {-# OVERLAPPING #-} HasType a Void where
141instance {-# OVERLAPPING #-} HasType a Void where
118 typed = undefined
142 typed = undefined
119
143
@@ -148,3 +172,7 @@ type family ErrorUnlessOne (a :: Type) (s :: Type) (stat :: TypeStat) :: Constra
148
172
149 ErrorUnlessOne _ _ ('TypeStat '[] '[] _)
173 ErrorUnlessOne _ _ ('TypeStat '[] '[] _)
150 = ()
174 = ()
175+
176+data HasTotalTypePSym :: Type -> (TyFun (Type -> Type) (Maybe Type))
177+type instance Eval (HasTotalTypePSym t) tt = HasTotalTypeP t tt
178+
src/Data/Generics/Product/Types.hs+333−14
@@ -1,9 +1,12 @@
1{-# LANGUAGE AllowAmbiguousTypes #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE DefaultSignatures #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE KindSignatures #-}
6{-# LANGUAGE KindSignatures #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE PolyKinds #-}
9+{-# LANGUAGE Rank2Types #-}
7{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE TypeApplications #-}
11{-# LANGUAGE TypeApplications #-}
9{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE TypeFamilies #-}
@@ -13,7 +16,7 @@
13-----------------------------------------------------------------------------
16-----------------------------------------------------------------------------
14-- |
17-- |
15-- Module : Data.Generics.Product.Types
18-- Module : Data.Generics.Product.Types
16−-- Copyright : (C) 2017 Csongor Kiss
19+-- Copyright : (C) 2019 Csongor Kiss
17-- License : BSD3
20-- License : BSD3
18-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19-- Stability : experimental
22-- Stability : experimental
@@ -26,23 +29,339 @@
26module Data.Generics.Product.Types
29module Data.Generics.Product.Types
27 ( -- *Traversals
30 ( -- *Traversals
28 --
31 --
29− -- $example
32+ -- $setup
30− HasTypes (..)
33+ HasTypes
34+ , types
35+
36+ -- * Custom traversal strategies
37+ -- $custom
38+ , Children
39+ , ChGeneric
40+
41+ , HasTypesUsing
42+ , typesUsing
43+
44+ , HasTypesCustom (typesCustom)
45+
31 ) where
46 ) where
32
47
48+import Data.Kind
49+import Data.Int (Int8, Int16, Int32, Int64)
50+import Data.Word (Word, Word8, Word16, Word32, Word64)
51+import qualified Data.Text as T
52+
53+import GHC.Generics
54+import GHC.TypeLits
55+import 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
33−import Data.Generics.Internal.Lens
66+-- >>> :m +Data.Generics.Internal.VL.Lens
34−import Data.Generics.Product.Internal.Types
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+--------------------------------------------------------------------------------
35
78
36−import GHC.Generics (Generic (Rep), from, to)
79+-- TODO [1.0.0.0]: use type-changing variant internally
37
80
81+-- | Traverse all types in the given structure.
82+--
83+-- For example, to update all 'String's in a @WTree (Maybe String) String@, we can write
84+--
85+-- >>> myTree = WithWeight (Fork (Leaf (Just "hello")) (Leaf Nothing)) "world"
86+-- >>> over (types @String) (++ "!") myTree
87+-- WithWeight (Fork (Leaf (Just "hello!")) (Leaf Nothing)) "world!"
88+--
89+-- The traversal is /deep/, which means that not just the immediate
90+-- children are visited, but all nested values too.
91+types :: forall a s. HasTypes s a => Traversal' s a
92+types = types_ @s @a
93+{-# INLINE types #-}
94+
38−class HasTypes a s where
95+class HasTypes s a where
96+ types_ :: Traversal' s a
97+
39− types :: Traversal' s a
98+ default types_ :: Traversal' s a
99+ types_ _ = pure
100+ {-# INLINE types_ #-}
40
101
41instance
102instance
42− ( Generic s
103+ ( HasTypesUsing ChGeneric s a
43− , GHasTypes (Rep s) a
104+ ) => HasTypes s a where
44− ) => HasTypes a s 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
211+ , Generic s
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
45
363
46− types = confusing (\f s -> to <$> gtypes f (from s))
364+type family IsNothing a where
47− {-# INLINE types #-}
365+ IsNothing ('Just _) = 'False
366+ IsNothing 'Nothing = 'True
48
367
src/Data/Generics/Sum.hs+1−1
@@ -1,7 +1,7 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2-- |
2-- |
3-- Module : Data.Generics.Sum
3-- Module : Data.Generics.Sum
4−-- Copyright : (C) 2017 Csongor Kiss
4+-- Copyright : (C) 2019 Csongor Kiss
5-- License : BSD3
5-- License : BSD3
6-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
6-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
7-- Stability : experimental
7-- Stability : experimental
src/Data/Generics/Sum/Any.hs+5−5
@@ -11,7 +11,7 @@
11-----------------------------------------------------------------------------
11-----------------------------------------------------------------------------
12-- |
12-- |
13-- Module : Data.Generics.Sum.Any
13-- Module : Data.Generics.Sum.Any
14−-- Copyright : (C) 2017 Csongor Kiss
14+-- Copyright : (C) 2019 Csongor Kiss
15-- License : BSD3
15-- License : BSD3
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17-- Stability : experimental
17-- Stability : experimental
@@ -28,9 +28,9 @@ module Data.Generics.Sum.Any
28 AsAny (..)
28 AsAny (..)
29 ) where
29 ) where
30
30
31−import Data.Generics.Internal.Lens
32import Data.Generics.Sum.Constructors
31import Data.Generics.Sum.Constructors
33import Data.Generics.Sum.Typed
32import Data.Generics.Sum.Typed
33+import Data.Generics.Internal.VL.Prism
34
34
35-- $setup
35-- $setup
36-- == /Running example:/
36-- == /Running example:/
@@ -39,7 +39,7 @@ import Data.Generics.Sum.Typed
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.Lens
42+-- >>> :m +Data.Generics.Internal.VL.Prism
43-- >>> :{
43-- >>> :{
44-- data Animal
44-- data Animal
45-- = Dog Dog
45-- = Dog Dog
@@ -61,7 +61,7 @@ import Data.Generics.Sum.Typed
61-- :}
61-- :}
62
62
63-- |Sums that have generic prisms.
63-- |Sums that have generic prisms.
64−class AsAny (sel :: k) a s | s sel k -> a where
64+class AsAny sel a s | s sel -> a where
65 -- |A prism that projects a sum as identified by some selector. Currently
65 -- |A prism that projects a sum as identified by some selector. Currently
66 -- supported selectors are constructor names and unique types. Compatible
66 -- supported selectors are constructor names and unique types. Compatible
67 -- with the lens package's 'Control.Lens.Prism' type.
67 -- with the lens package's 'Control.Lens.Prism' type.
@@ -86,7 +86,7 @@ class AsAny (sel :: k) a s | s sel k -> a where
86 --
86 --
87 -- >>> duck ^? _As @Age
87 -- >>> duck ^? _As @Age
88 -- Just 2
88 -- Just 2
89− _As :: PrismVL s s a a
89+ _As :: Prism s s a a
90
90
91instance AsConstructor ctor s s a a => AsAny ctor a s where
91instance AsConstructor ctor s s a a => AsAny ctor a s where
92 _As = _Ctor @ctor
92 _As = _Ctor @ctor
src/Data/Generics/Sum/Constructors.hs+91−20
@@ -15,7 +15,7 @@
15-----------------------------------------------------------------------------
15-----------------------------------------------------------------------------
16-- |
16-- |
17-- Module : Data.Generics.Sum.Constructors
17-- Module : Data.Generics.Sum.Constructors
18−-- Copyright : (C) 2017 Csongor Kiss
18+-- Copyright : (C) 2019 Csongor Kiss
19-- License : BSD3
19-- License : BSD3
20-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21-- Stability : experimental
21-- Stability : experimental
@@ -30,16 +30,22 @@ module Data.Generics.Sum.Constructors
30
30
31 -- $setup
31 -- $setup
32 AsConstructor (..)
32 AsConstructor (..)
33+ , AsConstructor_ (..)
34+ , AsConstructor' (..)
35+ , AsConstructor0 (..)
33 ) where
36 ) where
34
37
35import Data.Generics.Internal.Families
38import Data.Generics.Internal.Families
36−import Data.Generics.Internal.Lens
37import Data.Generics.Internal.Void
39import Data.Generics.Internal.Void
38import Data.Generics.Sum.Internal.Constructors
40import Data.Generics.Sum.Internal.Constructors
39
41
40import Data.Kind (Constraint, Type)
42import Data.Kind (Constraint, Type)
41import GHC.Generics (Generic (Rep))
43import GHC.Generics (Generic (Rep))
42import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
44import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
45+import Data.Generics.Internal.VL.Prism
46+import Data.Generics.Internal.Profunctor.Iso
47+import Data.Generics.Internal.Profunctor.Prism (prismPRavel)
48+import Data.Generics.Internal.Errors
43
49
44-- $setup
50-- $setup
45-- == /Running example:/
51-- == /Running example:/
@@ -50,7 +56,7 @@ import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
50-- >>> :set -XFlexibleContexts
56-- >>> :set -XFlexibleContexts
51-- >>> :set -XTypeFamilies
57-- >>> :set -XTypeFamilies
52-- >>> import GHC.Generics
58-- >>> import GHC.Generics
53−-- >>> :m +Data.Generics.Internal.Lens
59+-- >>> :m +Data.Generics.Internal.VL.Prism
54-- >>> :m +Data.Generics.Product.Fields
60-- >>> :m +Data.Generics.Product.Fields
55-- >>> :m +Data.Function
61-- >>> :m +Data.Function
56-- >>> :{
62-- >>> :{
@@ -65,7 +71,7 @@ import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
65-- , age :: Age
71-- , age :: Age
66-- , fieldA :: a
72-- , fieldA :: a
67-- }
73-- }
68−-- deriving (Generic, Show)
74+-- deriving Show
69-- type Name = String
75-- type Name = String
70-- type Age = Int
76-- type Age = Int
71-- dog, cat, duck :: Animal Int
77-- dog, cat, duck :: Animal Int
@@ -98,36 +104,101 @@ class AsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where
98 -- ...
104 -- ...
99 -- ... The type Animal Int does not contain a constructor named "Turtle"
105 -- ... The type Animal Int does not contain a constructor named "Turtle"
100 -- ...
106 -- ...
101− _Ctor :: PrismVL s t a b
107+ _Ctor :: Prism s t a b
108+
109+-- |Sums that have a constructor with a given name.
110+--
111+-- The difference between 'HasConstructor' and 'HasConstructor_' is similar to
112+-- the one between 'Data.Generics.Product.Fields.HasField' and
113+-- 'Data.Generics.Product.Fields.HasField_'.
114+-- See 'Data.Generics.Product.Fields.HasField_'.
115+class AsConstructor_ (ctor :: Symbol) s t a b where
116+ _Ctor_ :: Prism s t a b
117+
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
102
127
103instance
128instance
104 ( Generic s
129 ( Generic s
105 , ErrorUnless ctor s (HasCtorP ctor (Rep s))
130 , ErrorUnless ctor s (HasCtorP ctor (Rep s))
106− , Generic t
107− -- see Note [CPP in instance constraints]
108−#if __GLASGOW_HASKELL__ < 802
109− , '(s', t') ~ '(Proxied s, Proxied t)
110−#else
111− , s' ~ Proxied s
112− , t' ~ Proxied t
113−#endif
114− , Generic s'
115− , Generic t'
116 , GAsConstructor' ctor (Rep s) a
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
144+ , GAsConstructor' ctor (Rep (Indexed s)) a'
118 , GAsConstructor ctor (Rep s) (Rep t) a b
145 , GAsConstructor ctor (Rep s) (Rep t) a b
119 , t ~ Infer s a' b
146 , t ~ Infer s a' b
120− , GAsConstructor' ctor (Rep t') b'
147+ , GAsConstructor' ctor (Rep (Indexed t)) b'
121 , s ~ Infer t b' a
148 , s ~ Infer t b' a
149+ , AsConstructor0 ctor s t a b
122 ) => AsConstructor ctor s t a b where
150 ) => AsConstructor ctor s t a b where
123
151
124− _Ctor eta = prismVLRavel (repIso . _GCtor @ctor) eta
152+ _Ctor = _Ctor0 @ctor
125− {-# INLINE _Ctor #-}
153+ {-# INLINE[2] _Ctor #-}
126
154
127−-- See Note [Uncluttering type signatures]
155+-- | See Note [Uncluttering type signatures]
156+#if __GLASGOW_HASKELL__ < 804
157+-- >>> :t _Ctor
158+-- _Ctor
159+-- :: (Applicative f, Data.Profunctor.Choice.Choice p,
160+-- AsConstructor ctor s t a b) =>
161+-- p a (f b) -> p s (f t)
162+#else
163+-- >>> :t _Ctor
164+-- _Ctor
165+-- :: (AsConstructor ctor s t a b, Data.Profunctor.Choice.Choice p,
166+-- Applicative f) =>
167+-- p a (f b) -> p s (f t)
168+#endif
128instance {-# OVERLAPPING #-} AsConstructor ctor (Void1 a) (Void1 b) a b where
169instance {-# OVERLAPPING #-} AsConstructor ctor (Void1 a) (Void1 b) a b where
129 _Ctor = undefined
170 _Ctor = undefined
130
171
172+instance
173+ ( ErrorUnless ctor s (HasCtorP ctor (Rep s))
174+ , GAsConstructor' ctor (Rep s) a -- TODO: add a test similar to #62 for prisms
175+ , GAsConstructor' ctor (Rep (Indexed s)) a'
176+ , GAsConstructor ctor (Rep s) (Rep t) a b
177+ , GAsConstructor' ctor (Rep (Indexed t)) b'
178+ , UnifyHead s t
179+ , UnifyHead t s
180+ , AsConstructor0 ctor s t a b
181+ ) => AsConstructor_ ctor s t a b where
182+
183+ _Ctor_ = _Ctor0 @ctor
184+ {-# INLINE[2] _Ctor_ #-}
185+
186+instance {-# OVERLAPPING #-} AsConstructor_ ctor (Void1 a) (Void1 b) a b where
187+ _Ctor_ = undefined
188+
189+instance
190+ ( Generic s
191+ , Generic t
192+ , GAsConstructor ctor (Rep s) (Rep t) a b
193+ , Defined (Rep s)
194+ (NoGeneric s '[ 'Text "arising from a generic prism focusing on the "
195+ ':<>: QuoteType ctor ':<>: 'Text " constructor of type " ':<>: QuoteType a
196+ , 'Text "in " ':<>: QuoteType s])
197+ (() :: Constraint)
198+ ) => AsConstructor0 ctor s t a b where
199+ _Ctor0 = prismRavel (prismPRavel (repIso . _GCtor @ctor))
200+ {-# INLINE[2] _Ctor0 #-}
201+
131type family ErrorUnless (ctor :: Symbol) (s :: Type) (contains :: Bool) :: Constraint where
202type family ErrorUnless (ctor :: Symbol) (s :: Type) (contains :: Bool) :: Constraint where
132 ErrorUnless ctor s 'False
203 ErrorUnless ctor s 'False
133 = TypeError
204 = TypeError
src/Data/Generics/Sum/Internal/Constructors.hs+14−14
@@ -14,7 +14,7 @@
14-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
15-- |
15-- |
16-- Module : Data.Generics.Sum.Internal.Constructors
16-- Module : Data.Generics.Sum.Internal.Constructors
17−-- Copyright : (C) 2017 Csongor Kiss
17+-- Copyright : (C) 2019 Csongor Kiss
18-- License : BSD3
18-- License : BSD3
19-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20-- Stability : experimental
20-- Stability : experimental
@@ -30,12 +30,14 @@ module Data.Generics.Sum.Internal.Constructors
30 ) where
30 ) where
31
31
32import Data.Generics.Internal.Families
32import Data.Generics.Internal.Families
33−import Data.Generics.Product.Internal.List
33+import Data.Generics.Product.Internal.HList
34−import Data.Generics.Internal.Lens
34+import Data.Profunctor (Profunctor(..))
35
35
36import GHC.Generics
36import GHC.Generics
37import GHC.TypeLits (Symbol)
37import GHC.TypeLits (Symbol)
38−import Data.Kind
38+import Data.Generics.Internal.Profunctor.Lens
39+import Data.Generics.Internal.Profunctor.Iso
40+import Data.Generics.Internal.Profunctor.Prism
39
41
40-- |As 'AsConstructor' but over generic representations as defined by
42-- |As 'AsConstructor' but over generic representations as defined by
41-- "GHC.Generics".
43-- "GHC.Generics".
@@ -45,32 +47,30 @@ class GAsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where
45type GAsConstructor' ctor s a = GAsConstructor ctor s s a a
47type GAsConstructor' ctor s a = GAsConstructor ctor s s a a
46
48
47instance
49instance
48− ( GIsList Type f f as as
50+ ( GIsList f f as as
49− , GIsList Type g g bs bs
51+ , GIsList g g bs bs
50 , ListTuple a as
52 , ListTuple a as
51 , ListTuple b bs
53 , ListTuple b bs
52 ) => 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
53
55
54−-- _GCtor = prismP (M1 . gfromCollection . tupleToList) (Right . listToTuple . gtoCollection . unM1)
56+ _GCtor = dimap (listToTuple . view glist . unM1) (M1 . view (fromIso glist) . tupleToList)
55−-- {-# INLINE _GCtor #-}
57+ {-# INLINE[0] _GCtor #-}
56− _GCtor = prism (M1 . (view (fromIso (glist @Type))) . tupleToList) (Right . listToTuple . (view (glist @Type)) . unM1)
57−
58
58
59instance GSumAsConstructor ctor (HasCtorP ctor l) l r l' r' a b => GAsConstructor ctor (l :+: r) (l' :+: r') a b where
59instance GSumAsConstructor ctor (HasCtorP ctor l) l r l' r' a b => GAsConstructor ctor (l :+: r) (l' :+: r') a b where
60 _GCtor = _GSumCtor @ctor @(HasCtorP ctor l)
60 _GCtor = _GSumCtor @ctor @(HasCtorP ctor l)
61− {-# INLINE _GCtor #-}
61+ {-# INLINE[0] _GCtor #-}
62
62
63instance GAsConstructor ctor f f' a b => GAsConstructor ctor (M1 D meta f) (M1 D meta f') a b where
63instance GAsConstructor ctor f f' a b => GAsConstructor ctor (M1 D meta f) (M1 D meta f') a b where
64 _GCtor = mIso . _GCtor @ctor
64 _GCtor = mIso . _GCtor @ctor
65− {-# INLINE _GCtor #-}
65+ {-# INLINE[0] _GCtor #-}
66
66
67class GSumAsConstructor (ctor :: Symbol) (contains :: Bool) l r l' r' a b | ctor l r -> a, ctor l' r' -> b where
67class 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
68 _GSumCtor :: Prism ((l :+: r) x) ((l' :+: r') x) a b
69
69
70instance GAsConstructor ctor l l' a b => GSumAsConstructor ctor 'True l r l' r a b where
70instance GAsConstructor ctor l l' a b => GSumAsConstructor ctor 'True l r l' r a b where
71 _GSumCtor = left . _GCtor @ctor
71 _GSumCtor = left . _GCtor @ctor
72− {-# INLINE _GSumCtor #-}
72+ {-# INLINE[0] _GSumCtor #-}
73
73
74instance GAsConstructor ctor r r' a b => GSumAsConstructor ctor 'False l r l r' a b where
74instance GAsConstructor ctor r r' a b => GSumAsConstructor ctor 'False l r l r' a b where
75 _GSumCtor = right . _GCtor @ctor
75 _GSumCtor = right . _GCtor @ctor
76− {-# INLINE _GSumCtor #-}
76+ {-# INLINE[0] _GSumCtor #-}
src/Data/Generics/Sum/Internal/Subtype.hs+73−16
@@ -1,9 +1,10 @@
1−{-# LANGUAGE DataKinds #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE PolyKinds #-}
2+{-# LANGUAGE DataKinds #-}
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 #-}
7{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE TypeApplications #-}
9{-# LANGUAGE TypeApplications #-}
9{-# LANGUAGE TypeOperators #-}
10{-# LANGUAGE TypeOperators #-}
@@ -13,7 +14,7 @@
13-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
14-- |
15-- |
15-- Module : Data.Generics.Sum.Internal.Subtype
16-- Module : Data.Generics.Sum.Internal.Subtype
16−-- Copyright : (C) 2017 Csongor Kiss
17+-- Copyright : (C) 2019 Csongor Kiss
17-- License : BSD3
18-- License : BSD3
18-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19-- Stability : experimental
20-- Stability : experimental
@@ -27,12 +28,14 @@ module Data.Generics.Sum.Internal.Subtype
27 ( GAsSubtype (..)
28 ( GAsSubtype (..)
28 ) where
29 ) where
29
30
30−import Data.Generics.Internal.Lens
31+import Data.Generics.Product.Internal.HList
31−import Data.Generics.Product.Internal.List
32import Data.Generics.Sum.Internal.Typed
32import Data.Generics.Sum.Internal.Typed
33
33
34import Data.Kind
34import Data.Kind
35import GHC.Generics
35import GHC.Generics
36+import Data.Generics.Internal.Profunctor.Iso
37+import Data.Generics.Internal.Profunctor.Prism
38+import Data.Generics.Internal.Families.Has
36
39
37-- |As 'AsSubtype' but over generic representations as defined by
40-- |As 'AsSubtype' but over generic representations as defined by
38-- "GHC.Generics".
41-- "GHC.Generics".
@@ -40,19 +43,73 @@ class GAsSubtype (subf :: Type -> Type) (supf :: Type -> Type) where
40 _GSub :: Prism' (supf x) (subf x)
43 _GSub :: Prism' (supf x) (subf x)
41
44
42instance
45instance
43− ( GAsSubtype l supf
46+ ( GSplash sub sup
44− , GAsSubtype r supf
47+ , GDowncast sub sup
45− ) => GAsSubtype (l :+: r) supf where
48+ ) => GAsSubtype sub sup where
46− _GSub = without' _GSub _GSub . fromIso sumIso
49+ _GSub f = prism _GSplash _GDowncast f
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 #-}
47
61
48instance
62instance
49− ( GIsList () subf subf as as
63+ ( GIsList subf subf as as
50 , GAsType supf as
64 , GAsType supf as
51− ) => GAsSubtype (C1 meta subf) supf where
65+ ) => GSplash (C1 meta subf) supf where
52− _GSub = _GTyped . fromIso (glist @()) . fromIso mIso
66+ _GSplash p = build (_GTyped . fromIso (mIso . glist)) p
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 #-}
53
72
54−-- instance GAsType supf a => GAsSubtype (S1 meta (Rec0 a)) supf where
73+--------------------------------------------------------------------------------
55−-- _GSub = _GTyped . fromIso (mIso . kIso)
74+
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 #-}
56
115
57−instance GAsSubtype subf supf => GAsSubtype (D1 meta subf) supf where
58− _GSub = _GSub . fromIso mIso
src/Data/Generics/Sum/Internal/Typed.hs+22−9
@@ -13,7 +13,7 @@
13-----------------------------------------------------------------------------
13-----------------------------------------------------------------------------
14-- |
14-- |
15-- Module : Data.Generics.Sum.Internal.Typed
15-- Module : Data.Generics.Sum.Internal.Typed
16−-- Copyright : (C) 2017 Csongor Kiss
16+-- Copyright : (C) 2019 Csongor Kiss
17-- License : BSD3
17-- License : BSD3
18-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
18-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19-- Stability : experimental
19-- Stability : experimental
@@ -29,31 +29,44 @@ module Data.Generics.Sum.Internal.Typed
29
29
30import Data.Kind
30import Data.Kind
31import GHC.Generics
31import GHC.Generics
32+import Data.Tagged
32
33
33import Data.Generics.Internal.Families
34import Data.Generics.Internal.Families
34−import Data.Generics.Product.Internal.List
35+import Data.Generics.Product.Internal.HList
35−import Data.Generics.Internal.Lens
36+import Data.Generics.Internal.Profunctor.Iso
37+import Data.Generics.Internal.Profunctor.Prism
36
38
37-- |As 'AsType' but over generic representations as defined by "GHC.Generics".
39-- |As 'AsType' but over generic representations as defined by "GHC.Generics".
38−class GAsType (f :: Type -> Type) (as :: [((), Type)]) where
40+class GAsType (f :: Type -> Type) (as :: [Type]) where
39− _GTyped :: Prism (f x) (f x) (List as) (List as)
41+ _GTyped :: Prism (f x) (f x) (HList as) (HList as)
42+-- We create this specialised version as we use it in the subtype prism
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+
40
48
41instance
49instance
42− ( GIsList () f f as as
50+ ( GIsList f f as as
43 ) => GAsType (M1 C meta f) as where
51 ) => GAsType (M1 C meta f) as where
44− _GTyped = mIso . glist @()
52+ _GTyped = mIso . glist
53+ {-# INLINE[0] _GTyped #-}
45
54
46instance GSumAsType (HasPartialTypeP a l) l r a => GAsType (l :+: r) a where
55instance GSumAsType (HasPartialTypeP a l) l r a => GAsType (l :+: r) a where
47 _GTyped = _GSumTyped @(HasPartialTypeP a l)
56 _GTyped = _GSumTyped @(HasPartialTypeP a l)
57+ {-# INLINE[0] _GTyped #-}
48
58
49instance GAsType f a => GAsType (M1 D meta f) a where
59instance GAsType f a => GAsType (M1 D meta f) a where
50 _GTyped = mIso . _GTyped
60 _GTyped = mIso . _GTyped
61+ {-# INLINE[0] _GTyped #-}
51
62
52−class GSumAsType (contains :: Bool) l r (a :: [((), Type)]) where
63+class GSumAsType (contains :: Bool) l r (a :: [Type]) where
53− _GSumTyped :: Prism ((l :+: r) x) ((l :+: r) x) (List a) (List a)
64+ _GSumTyped :: Prism ((l :+: r) x) ((l :+: r) x) (HList a) (HList a)
54
65
55instance GAsType l a => GSumAsType 'True l r a where
66instance GAsType l a => GSumAsType 'True l r a where
56 _GSumTyped = left . _GTyped
67 _GSumTyped = left . _GTyped
68+ {-# INLINE[0] _GSumTyped #-}
57
69
58instance GAsType r a => GSumAsType 'False l r a where
70instance GAsType r a => GSumAsType 'False l r a where
59 _GSumTyped = right . _GTyped
71 _GSumTyped = right . _GTyped
72+ {-# INLINE[0] _GSumTyped #-}
src/Data/Generics/Sum/Subtype.hs+53−12
@@ -1,8 +1,10 @@
1−{-# LANGUAGE TypeApplications #-}
1+{-# LANGUAGE CPP #-}
2{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE MonoLocalBinds #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE TypeApplications #-}
6{-# LANGUAGE TypeOperators #-}
8{-# LANGUAGE TypeOperators #-}
7{-# LANGUAGE TypeSynonymInstances #-}
9{-# LANGUAGE TypeSynonymInstances #-}
8{-# LANGUAGE UndecidableInstances #-}
10{-# LANGUAGE UndecidableInstances #-}
@@ -10,7 +12,7 @@
10-----------------------------------------------------------------------------
12-----------------------------------------------------------------------------
11-- |
13-- |
12-- Module : Data.Generics.Sum.Subtype
14-- Module : Data.Generics.Sum.Subtype
13−-- Copyright : (C) 2017 Csongor Kiss
15+-- Copyright : (C) 2019 Csongor Kiss
14-- License : BSD3
16-- License : BSD3
15-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16-- Stability : experimental
18-- Stability : experimental
@@ -27,11 +29,12 @@ module Data.Generics.Sum.Subtype
27 AsSubtype (..)
29 AsSubtype (..)
28 ) where
30 ) where
29
31
30−import Data.Generics.Internal.Lens
31import Data.Generics.Internal.Void
32import Data.Generics.Internal.Void
32import Data.Generics.Sum.Internal.Subtype
33import Data.Generics.Sum.Internal.Subtype
33
34
34import GHC.Generics (Generic (Rep))
35import GHC.Generics (Generic (Rep))
36+import Data.Generics.Internal.VL.Prism
37+import Data.Generics.Internal.Profunctor.Iso
35
38
36-- $setup
39-- $setup
37-- == /Running example:/
40-- == /Running example:/
@@ -40,7 +43,7 @@ import GHC.Generics (Generic (Rep))
40-- >>> :set -XDataKinds
43-- >>> :set -XDataKinds
41-- >>> :set -XDeriveGeneric
44-- >>> :set -XDeriveGeneric
42-- >>> import GHC.Generics
45-- >>> import GHC.Generics
43−-- >>> :m +Data.Generics.Internal.Lens
46+-- >>> :m +Data.Generics.Internal.VL.Prism
44-- >>> :{
47-- >>> :{
45-- data Animal
48-- data Animal
46-- = Dog Dog
49-- = Dog Dog
@@ -86,17 +89,19 @@ class AsSubtype sub sup where
86 --
89 --
87 -- >>> duck ^? _Sub :: Maybe FourLeggedAnimal
90 -- >>> duck ^? _Sub :: Maybe FourLeggedAnimal
88 -- Nothing
91 -- Nothing
89− _Sub :: PrismVL' sup sub
92+ _Sub :: Prism' sup sub
90− _Sub eta = prismVL injectSub projectSub eta
93+ _Sub = prism injectSub (\i -> maybe (Left i) Right (projectSub i))
91− {-# INLINE _Sub #-}
94+ {-# INLINE[2] _Sub #-}
92
95
93 -- |Injects a subtype into a supertype (upcast).
96 -- |Injects a subtype into a supertype (upcast).
94 injectSub :: sub -> sup
97 injectSub :: sub -> sup
95− injectSub = buildVL (_Sub @sub @sup)
98+ injectSub
99+ = build (_Sub @sub @sup)
96
100
97 -- |Projects a subtype from a supertype (downcast).
101 -- |Projects a subtype from a supertype (downcast).
98− projectSub :: sup -> Either sup sub
102+ projectSub :: sup -> Maybe sub
99− projectSub = matchVL (_Sub @sub @sup)
103+ projectSub
104+ = either (const Nothing) Just . match (_Sub @sub @sup)
100
105
101 {-# MINIMAL (injectSub, projectSub) | _Sub #-}
106 {-# MINIMAL (injectSub, projectSub) | _Sub #-}
102
107
@@ -106,12 +111,48 @@ instance
106 , GAsSubtype (Rep sub) (Rep sup)
111 , GAsSubtype (Rep sub) (Rep sup)
107 ) => AsSubtype sub sup where
112 ) => AsSubtype sub sup where
108
113
109− _Sub = prismVLRavel (repIso . _GSub . fromIso repIso)
114+ _Sub f = prismRavel (repIso . _GSub . fromIso repIso) f
115+ {-# INLINE[2] _Sub #-}
110
116
111−-- See Note [Uncluttering type signatures]
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]
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
112instance {-# OVERLAPPING #-} AsSubtype a Void where
138instance {-# OVERLAPPING #-} AsSubtype a Void where
113 injectSub = undefined
139 injectSub = undefined
114 projectSub = undefined
140 projectSub = undefined
141+
142+-- | See Note [Uncluttering type signatures]
143+#if __GLASGOW_HASKELL__ < 804
144+-- >>> :t _Sub @Int
145+-- _Sub @Int
146+-- :: (Applicative f, Data.Profunctor.Choice.Choice p,
147+-- AsSubtype Int sup) =>
148+-- p Int (f Int) -> p sup (f sup)
149+#else
150+-- >>> :t _Sub @Int
151+-- _Sub @Int
152+-- :: (AsSubtype Int sup, Data.Profunctor.Choice.Choice p,
153+-- Applicative f) =>
154+-- p Int (f Int) -> p sup (f sup)
155+#endif
115instance {-# OVERLAPPING #-} AsSubtype Void a where
156instance {-# OVERLAPPING #-} AsSubtype Void a where
116 injectSub = undefined
157 injectSub = undefined
117 projectSub = undefined
158 projectSub = undefined
src/Data/Generics/Sum/Typed.hs+48−18
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE TypeApplications #-}
2{-# LANGUAGE TypeApplications #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
3{-# LANGUAGE AllowAmbiguousTypes #-}
3{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE DataKinds #-}
@@ -13,7 +14,7 @@
13-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
14-- |
15-- |
15-- Module : Data.Generics.Sum.Typed
16-- Module : Data.Generics.Sum.Typed
16−-- Copyright : (C) 2017 Csongor Kiss
17+-- Copyright : (C) 2019 Csongor Kiss
17-- License : BSD3
18-- License : BSD3
18-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19-- Stability : experimental
20-- Stability : experimental
@@ -34,18 +35,21 @@ import Data.Kind
34import GHC.Generics
35import GHC.Generics
35import GHC.TypeLits (TypeError, ErrorMessage (..), Symbol)
36import GHC.TypeLits (TypeError, ErrorMessage (..), Symbol)
36import Data.Generics.Sum.Internal.Typed
37import Data.Generics.Sum.Internal.Typed
38+import Data.Generics.Internal.Errors
37
39
38import Data.Generics.Internal.Families
40import Data.Generics.Internal.Families
39−import Data.Generics.Internal.Lens
40import Data.Generics.Internal.Void
41import Data.Generics.Internal.Void
41−import Data.Generics.Product.Internal.List
42+import Data.Generics.Product.Internal.HList
43+import Data.Generics.Internal.VL.Prism
44+import Data.Generics.Internal.Profunctor.Iso
45+import Data.Generics.Internal.Profunctor.Prism (prismPRavel)
42
46
43-- $setup
47-- $setup
44-- >>> :set -XTypeApplications
48-- >>> :set -XTypeApplications
45-- >>> :set -XDataKinds
49-- >>> :set -XDataKinds
46-- >>> :set -XDeriveGeneric
50-- >>> :set -XDeriveGeneric
47-- >>> import GHC.Generics
51-- >>> import GHC.Generics
48−-- >>> :m +Data.Generics.Internal.Lens
52+-- >>> :m +Data.Generics.Internal.VL.Prism
49-- >>> :{
53-- >>> :{
50-- data Animal
54-- data Animal
51-- = Dog Dog
55-- = Dog Dog
@@ -85,17 +89,21 @@ class AsType a s where
85 -- ... Duck
89 -- ... Duck
86 -- ... Turtle
90 -- ... Turtle
87 -- ...
91 -- ...
88− _Typed :: PrismVL' s a
92+ _Typed :: Prism' s a
93+ _Typed = prism injectTyped (\i -> maybe (Left i) Right (projectTyped i))
94+ {-# INLINE[2] _Typed #-}
89
95
90 -- |Inject by type.
96 -- |Inject by type.
91 injectTyped :: a -> s
97 injectTyped :: a -> s
92 injectTyped
98 injectTyped
93− = buildVL _Typed
99+ = build _Typed
94
100
95 -- |Project by type.
101 -- |Project by type.
96 projectTyped :: s -> Maybe a
102 projectTyped :: s -> Maybe a
97 projectTyped
103 projectTyped
98− = either (const Nothing) Just . (matchVL _Typed)
104+ = either (const Nothing) Just . match _Typed
105+
106+ {-# MINIMAL (injectTyped, projectTyped) | _Typed #-}
99
107
100instance
108instance
101 ( Generic s
109 ( Generic s
@@ -103,23 +111,45 @@ instance
103 , as ~ TupleToList a
111 , as ~ TupleToList a
104 , ListTuple a as
112 , ListTuple a as
105 , GAsType (Rep s) as
113 , GAsType (Rep s) as
114+ , Defined (Rep s)
115+ (NoGeneric s '[ 'Text "arising from a generic prism focusing on a constructor of type " ':<>: QuoteType a])
116+ (() :: Constraint)
106 ) => AsType a s where
117 ) => AsType a s where
107
118
108−-- _Typed
119+ _Typed eta = prismRavel (prismPRavel (repIso . _GTyped @_ @as . tupled)) eta
109−-- = prism injectTyped (either (Left . to) Right . gprojectTyped . from)
120+ {-# INLINE[2] _Typed #-}
110−-- {-# INLINE _Typed #-}
121+
111−-- injectTyped
122+-- | See Note [Uncluttering type signatures]
112−-- = to . ginjectTyped
123+#if __GLASGOW_HASKELL__ < 804
113−-- projectTyped
124+-- >>> :t _Typed
114−-- = either (const Nothing) Just . gprojectTyped . from
125+-- _Typed
115− _Typed = prismVLRavel (repIso . _GTyped @_ @as . tupled)
126+-- :: (Applicative f, Data.Profunctor.Choice.Choice p, AsType a s) =>
116− {-# INLINE _Typed #-}
127+-- p a (f a) -> p s (f s)
117−
128+#else
118−-- See Note [Uncluttering type signatures]
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
119instance {-# OVERLAPPING #-} AsType a Void where
134instance {-# OVERLAPPING #-} AsType a Void where
120 _Typed = undefined
135 _Typed = undefined
121 injectTyped = undefined
136 injectTyped = undefined
122 projectTyped = undefined
137 projectTyped = undefined
138+
139+-- | See Note [Uncluttering type signatures]
140+#if __GLASGOW_HASKELL__ < 804
141+-- >>> :t _Typed @Int
142+-- _Typed @Int
143+-- :: (Applicative f, Data.Profunctor.Choice.Choice p,
144+-- AsType Int s) =>
145+-- p Int (f Int) -> p s (f s)
146+#else
147+-- >>> :t _Typed @Int
148+-- _Typed @Int
149+-- :: (AsType Int s, Data.Profunctor.Choice.Choice p,
150+-- Applicative f) =>
151+-- p Int (f Int) -> p s (f s)
152+#endif
123instance {-# OVERLAPPING #-} AsType Void a where
153instance {-# OVERLAPPING #-} AsType Void a where
124 _Typed = undefined
154 _Typed = undefined
125 injectTyped = undefined
155 injectTyped = undefined
src/Data/Generics/Wrapped.hsnew file+104
@@ -0,0 +1,104 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE TypeApplications #-}
3+{-# language ConstraintKinds #-}
4+{-# language DataKinds #-}
5+{-# language FlexibleContexts #-}
6+{-# language FlexibleInstances #-}
7+{-# language FunctionalDependencies #-}
8+{-# language MultiParamTypeClasses #-}
9+{-# language ScopedTypeVariables #-}
10+{-# language TypeFamilies #-}
11+{-# language TypeOperators #-}
12+{-# language UndecidableInstances #-}
13+
14+-----------------------------------------------------------------------------
15+-- |
16+-- Module : Data.Generics.Wrapped
17+-- Copyright : (C) 2019 Csongor Kiss
18+-- License : BSD3
19+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20+-- Stability : experimental
21+-- Portability : non-portable
22+--
23+-- Derive an isomorphism between a newtype and its wrapped type.
24+--
25+-----------------------------------------------------------------------------
26+
27+module Data.Generics.Wrapped
28+ ( Wrapped (..)
29+ , wrappedTo
30+ , wrappedFrom
31+ , _Unwrapped
32+ , _Wrapped
33+ )
34+where
35+
36+import Control.Applicative (Const(..))
37+import Data.Generics.Internal.Profunctor.Iso
38+
39+import qualified Data.Generics.Internal.VL.Iso as VL
40+import Data.Generics.Internal.Families.Changing ( UnifyHead )
41+
42+import Data.Kind (Constraint)
43+import GHC.Generics
44+import GHC.TypeLits
45+
46+type family ErrorUnlessOnlyOne a b :: Constraint where
47+ ErrorUnlessOnlyOne t (M1 i k a) = ErrorUnlessOnlyOne t a
48+ ErrorUnlessOnlyOne t (K1 i a) = ()
49+ ErrorUnlessOnlyOne t a =
50+ TypeError ('ShowType t ':<>: 'Text " is not a single-constructor, single-field datatype")
51+
52+-- | @since 1.1.0.0
53+_Unwrapped :: Wrapped s t a b => VL.Iso s t a b
54+_Unwrapped = wrappedIso
55+{-# inline _Unwrapped #-}
56+
57+-- | @since 1.1.0.0
58+_Wrapped :: Wrapped s t a b => VL.Iso b a t s
59+_Wrapped = VL.fromIso wrappedIso
60+{-# inline _Wrapped #-}
61+
62+-- TODO: move this into doctets
63+
64+-- newtype FlippedEither a b = FlippedEither (Either b a)
65+-- deriving Generic
66+
67+-- test :: (a -> c) -> FlippedEither a b -> FlippedEither c b
68+-- test f = over wrappedIso (fmap f)
69+
70+class GWrapped s t a b | s -> a, t -> b, s b -> t, t a -> s where
71+ gWrapped :: Iso (s x) (t x) a b
72+
73+instance GWrapped s t a b => GWrapped (M1 i k s) (M1 i k t) a b where
74+ gWrapped = mIso . gWrapped
75+
76+instance (a ~ c, b ~ d) => GWrapped (K1 i a) (K1 i b) c d where
77+ gWrapped = kIso
78+
79+-- | @since 1.1.0.0
80+class Wrapped s t a b | s -> a, t -> b where
81+ -- | @since 1.1.0.0
82+ wrappedIso :: VL.Iso s t a b
83+
84+-- | @since 1.1.0.0
85+wrappedTo :: forall s t a b. Wrapped s t a b => s -> a
86+wrappedTo a = view (wrappedIso @s @t @a @b) a
87+ where view l s = getConst (l Const s)
88+{-# INLINE wrappedTo #-}
89+
90+-- | @since 1.1.0.0
91+wrappedFrom :: forall s t a b. Wrapped s t a b => b -> t
92+wrappedFrom a = view (VL.fromIso (wrappedIso @s @t @a @b)) a
93+ where view l s = getConst (l Const s)
94+{-# INLINE wrappedFrom #-}
95+
96+instance
97+ ( Generic s
98+ , Generic t
99+ , GWrapped (Rep s) (Rep t) a b
100+ , UnifyHead s t
101+ , UnifyHead t s
102+ ) => Wrapped s t a b where
103+ wrappedIso = iso2isovl (repIso . gWrapped)
104+ {-# INLINE wrappedIso #-}
stack.yaml+1−4
@@ -1,11 +1,8 @@
1−resolver: lts-9.2
1+resolver: nightly-2018-08-09
2
2
3packages:
3packages:
4- '.'
4- '.'
5
5
6−extra-deps:
7−- 'inspection-testing-0.1.1.2'
8−
9flags: {}
6flags: {}
10
7
11extra-package-dbs: []
8extra-package-dbs: []
test/Bifunctor.hsnew file+47
@@ -0,0 +1,47 @@
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.hsnew file+63
@@ -0,0 +1,63 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE KindSignatures #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE TypeApplications #-}
7+{-# LANGUAGE TypeFamilies #-}
8+{-# LANGUAGE UndecidableInstances #-}
9+
10+module CustomChildren
11+ ( customTypesTest
12+ ) where
13+
14+import GHC.Generics
15+import Data.Generics.Product
16+import Test.HUnit
17+import Data.Generics.Internal.VL.Lens
18+import Data.Generics.Labels ()
19+import Data.Kind
20+
21+-- Opaque has no Generic instance
22+data Opaque = Opaque String
23+ deriving (Show, Eq)
24+
25+-- Hide does have a Generic instance, but we want to hide its contents
26+-- from the traversal
27+data Hide = Hide String
28+ deriving (Show, Generic, Eq)
29+
30+-- We first define a symbol for the custom traversal
31+data Custom
32+
33+type instance Children Custom a = ChildrenCustom a
34+
35+type family ChildrenCustom (a :: Type) where
36+ ChildrenCustom Opaque = '[String] -- here we state explicitly that Opaque contains a String
37+ ChildrenCustom Hide = '[] -- and hide the contents of Hide
38+ ChildrenCustom a = Children ChGeneric a -- for the rest, we defer to the generic children
39+
40+-- We define the traversal of Opaque like so:
41+instance HasTypesCustom Custom Opaque String where
42+ typesCustom f (Opaque str) = Opaque <$> f str
43+
44+customTypesTest1 :: Test
45+customTypesTest1
46+ = TestCase (assertEqual "foo" (over (typesUsing @Custom @String) (++ "!") original) expected)
47+ where original = (Opaque "foo", Hide "bar")
48+ expected = (Opaque "foo!", Hide "bar") -- only Opaque's String gets modified
49+
50+customTypesTest2 :: Test
51+customTypesTest2
52+ = TestCase (assertEqual "foo" (over (typesUsing @Custom @String) (++ "!") original) expected)
53+ where original = Opaque "foo"
54+ expected = Opaque "foo!"
55+
56+customTypesTest3 :: Test
57+customTypesTest3
58+ = TestCase (assertEqual "foo" (over (typesUsing @Custom @String) (++ "!") original) expected)
59+ where original = Hide "foo"
60+ expected = Hide "foo"
61+
62+customTypesTest :: Test
63+customTypesTest = TestList [customTypesTest1, customTypesTest2, customTypesTest3]
test/Spec.hs+133−47
@@ -1,7 +1,8 @@
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 #-}
5{-# LANGUAGE DataKinds #-}
6{-# LANGUAGE DataKinds #-}
6{-# LANGUAGE DeriveGeneric #-}
7{-# LANGUAGE DeriveGeneric #-}
7{-# LANGUAGE DuplicateRecordFields #-}
8{-# LANGUAGE DuplicateRecordFields #-}
@@ -10,19 +11,29 @@
10{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE TypeApplications #-}
12{-# LANGUAGE TypeApplications #-}
12{-# LANGUAGE TemplateHaskell #-}
13{-# LANGUAGE TemplateHaskell #-}
13−-- For the VL prism test
14+{-# LANGUAGE OverloadedLabels #-}
14
15
15module Main where
16module Main where
16
17
17import GHC.Generics
18import GHC.Generics
18−import Data.Profunctor
19import Data.Generics.Product
19import Data.Generics.Product
20−import Data.Generics.Internal.Lens (prismPRavel, plus)
21import Data.Generics.Sum
20import Data.Generics.Sum
22import Test.Inspection
21import Test.Inspection
23import Test.HUnit
22import Test.HUnit
24import Util
23import Util
25import System.Exit
24import System.Exit
25+import Data.Generics.Internal.VL.Lens
26+import Data.Generics.Internal.VL.Prism
27+import 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)
26
37
27main :: IO ()
38main :: IO ()
28main = do
39main = do
@@ -45,24 +56,6 @@ data Record3 a = MkRecord3
45 , fieldB :: Bool
56 , fieldB :: Bool
46 } deriving (Generic, Show)
57 } deriving (Generic, Show)
47
58
48−type Lens' s a = Lens s s a a
49−type Prism' s a = Prism s s a a
50−type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t
51−type Prism s t a b =
52− forall p f . (Choice p, Applicative f) => p a (f b) -> p s (f t)
53−
54−type PrismP s t a b =
55− forall p . (Choice p) => p a b -> p s t
56−type Traversal' s a = forall f. Applicative f => (a -> f a) -> s -> f s
57−
58−prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
59−prism bt seta eta = dimap (\x -> plus pure id (seta x)) (either id (\x -> fmap bt x)) (right' eta)
60−{-# INLINE prism #-}
61−
62−prismP :: (b -> t) -> (s -> Either t a) -> PrismP s t a b
63−prismP bt seta eta = dimap seta (either id bt) (right' eta)
64−{-# INLINE prismP #-}
65−
66data Record4 a = MkRecord4
59data Record4 a = MkRecord4
67 { fieldA :: a
60 { fieldA :: a
68 , fieldB :: a
61 , fieldB :: a
@@ -77,8 +70,6 @@ data Record5 = MkRecord5
77 , fieldF :: Int
70 , fieldF :: Int
78 } deriving Generic
71 } deriving Generic
79
72
80−
81−
82typeChangingManual :: Lens (Record3 a) (Record3 b) a b
73typeChangingManual :: Lens (Record3 a) (Record3 b) a b
83typeChangingManual f (MkRecord3 a b) = (\a' -> MkRecord3 a' b) <$> f a
74typeChangingManual f (MkRecord3 a b) = (\a' -> MkRecord3 a' b) <$> f a
84
75
@@ -106,6 +97,36 @@ subtypeLensManual f record
106data Sum1 = A Char | B Int | C () | D () deriving (Generic, Show)
97data Sum1 = A Char | B Int | C () | D () deriving (Generic, Show)
107data Sum2 = A2 Char | B2 Int deriving (Generic, Show)
98data Sum2 = A2 Char | B2 Int deriving (Generic, Show)
108
99
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+
109sum1PrismManual :: Prism Sum1 Sum1 Int Int
130sum1PrismManual :: Prism Sum1 Sum1 Int Int
110sum1PrismManual eta = prism g f eta
131sum1PrismManual eta = prism g f eta
111 where
132 where
@@ -114,22 +135,42 @@ sum1PrismManual eta = prism g f eta
114 s -> Left s
135 s -> Left s
115 g = B
136 g = B
116
137
117−sum1PrismPManual :: PrismP Sum1 Sum1 Int Int
138+sum1PrismManualChar :: Prism Sum1 Sum1 Char Char
118−sum1PrismPManual eta = prismP g f eta
139+sum1PrismManualChar eta = prism g f eta
119 where
140 where
120 f s1 = case s1 of
141 f s1 = case s1 of
121− B i -> Right i
142+ A i -> Right i
122− s -> Left s
143+ B _ -> Left s1
123− g = B
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
124
164
165+-- Note we don't have a catch-all case because of #14684
125subtypePrismManual :: Prism Sum1 Sum1 Sum2 Sum2
166subtypePrismManual :: Prism Sum1 Sum1 Sum2 Sum2
126subtypePrismManual eta = prism g f eta
167subtypePrismManual eta = prism g f eta
127 where
168 where
128 f s1 = case s1 of
169 f s1 = case s1 of
129 A c -> Right (A2 c)
170 A c -> Right (A2 c)
130 B i -> Right (B2 i)
171 B i -> Right (B2 i)
131− C _ -> Left s1
172+ C _ -> Left s1
132− D _ -> Left s1
173+ D _ -> Left s1
133 g (A2 c) = A c
174 g (A2 c) = A c
134 g (B2 i) = B i
175 g (B2 i) = B i
135
176
@@ -144,47 +185,92 @@ subtypePrismManual eta = prism g f eta
144fieldALensName :: Lens' Record Int
185fieldALensName :: Lens' Record Int
145fieldALensName = field @"fieldA"
186fieldALensName = field @"fieldA"
146
187
188+fieldALensName_ :: Lens' Record Int
189+fieldALensName_ = field_ @"fieldA"
190+
147fieldALensType :: Lens' Record Int
191fieldALensType :: Lens' Record Int
148fieldALensType = typed @Int
192fieldALensType = typed @Int
149
193
150fieldALensPos :: Lens' Record Int
194fieldALensPos :: Lens' Record Int
151fieldALensPos = position @1
195fieldALensPos = position @1
152
196
197+fieldALensPos_ :: Lens' Record Int
198+fieldALensPos_ = position_ @1
199+
153subtypeLensGeneric :: Lens' Record Record2
200subtypeLensGeneric :: Lens' Record Record2
154subtypeLensGeneric = super
201subtypeLensGeneric = super
155
202
156typeChangingGeneric :: Lens (Record3 a) (Record3 b) a b
203typeChangingGeneric :: Lens (Record3 a) (Record3 b) a b
157−typeChangingGeneric = field @"fieldA"
204+typeChangingGeneric = #fieldA
158
205
159typeChangingGenericPos :: Lens (Record3 a) (Record3 b) a b
206typeChangingGenericPos :: Lens (Record3 a) (Record3 b) a b
160typeChangingGenericPos = position @1
207typeChangingGenericPos = position @1
161
208
162typeChangingGenericCompose :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b
209typeChangingGenericCompose :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b
163−typeChangingGenericCompose = field @"fieldA" . field @"fieldA"
210+typeChangingGenericCompose = #fieldA . #fieldA
211+
212+typeChangingGenericCompose_ :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b
213+typeChangingGenericCompose_ = field_ @"fieldA" . field_ @"fieldA"
164
214
165sum1PrismB :: Prism Sum1 Sum1 Int Int
215sum1PrismB :: Prism Sum1 Sum1 Int Int
166sum1PrismB = _Ctor @"B"
216sum1PrismB = _Ctor @"B"
167
217
168−--sum1PrismBP :: PrismP Sum1 Sum1 Int Int
169−--sum1PrismBP = prismPRavel (_CtorRaw @"B")
170−
171subtypePrismGeneric :: Prism Sum1 Sum1 Sum2 Sum2
218subtypePrismGeneric :: Prism Sum1 Sum1 Sum2 Sum2
172subtypePrismGeneric = _Sub
219subtypePrismGeneric = _Sub
173
220
174sum1TypePrism :: Prism Sum1 Sum1 Int Int
221sum1TypePrism :: Prism Sum1 Sum1 Int Int
175sum1TypePrism = _Typed @Int
222sum1TypePrism = _Typed @Int
176
223
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+
177tests :: Test
239tests :: Test
178tests = TestList $ map mkHUnitTest
240tests = TestList $ map mkHUnitTest
179− [ $(inspectTest $ 'fieldALensManual === 'fieldALensName)
241+ [ $(inspectTest $ 'fieldALensManual === 'fieldALensName)
180− , $(inspectTest $ 'fieldALensManual === 'fieldALensType)
242+ , $(inspectTest $ 'fieldALensManual === 'fieldALensName_)
181− , $(inspectTest $ 'fieldALensManual === 'fieldALensPos)
243+ , $(inspectTest $ 'fieldALensManual === 'fieldALensType)
182− , $(inspectTest $ 'subtypeLensManual === 'subtypeLensGeneric)
244+ , $(inspectTest $ 'fieldALensManual === 'fieldALensPos)
183− , $(inspectTest $ 'typeChangingManual === 'typeChangingGeneric)
245+ , $(inspectTest $ 'fieldALensManual === 'fieldALensPos_)
184− , $(inspectTest $ 'typeChangingManual === 'typeChangingGenericPos)
246+ , $(inspectTest $ 'subtypeLensManual === 'subtypeLensGeneric)
247+ , $(inspectTest $ 'typeChangingManual === 'typeChangingGeneric)
248+ , $(inspectTest $ 'typeChangingManual === 'typeChangingGenericPos)
185 , $(inspectTest $ 'typeChangingManualCompose === 'typeChangingGenericCompose)
249 , $(inspectTest $ 'typeChangingManualCompose === 'typeChangingGenericCompose)
186− , $(inspectTest $ 'intTraversalManual === 'intTraversalDerived)
250+ , $(inspectTest $ 'typeChangingManualCompose === 'typeChangingGenericCompose_)
187− , $(inspectTest $ 'sum1PrismManual === 'sum1PrismB)
251+ , $(inspectTest $ 'sum1PrismManual === 'sum1PrismB)
188− -- , $(inspectTest $ 'sum1PrismPManual === 'sum1PrismBP)
252+ , $(inspectTest $ 'subtypePrismManual === 'subtypePrismGeneric)
189− , $(inspectTest $ 'subtypePrismManual === 'subtypePrismGeneric)
253+ , $(inspectTest $ 'sum2PrismManualChar === 'sum2TypePrismChar)
190− , $(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/24.hs → test/Test24.hsrenamed+1−1
@@ -1,6 +1,6 @@
1{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications #-}
1{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications #-}
2
2
3−module Main where
3+module Test24 where
4
4
5-- Test case from #24, comments preserved
5-- Test case from #24, comments preserved
6import Control.Lens
6import Control.Lens
test/25.hs → test/Test25.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 Main where
7+module Test25 where
8
8
9import Control.Lens
9import Control.Lens
10import Data.Generics.Product
10import Data.Generics.Product
test/Test40.hsnew file+22
@@ -0,0 +1,22 @@
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.hsnew file+20
@@ -0,0 +1,20 @@
1+{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications #-}
2+module Test62 (example, example_) where
3+import Data.Generics.Product (field, field_, position, position_)
4+import Data.Generics.Internal.VL.Lens (set)
5+import GHC.Generics (Generic)
6+
7+data Foo a = Foo { bar :: Bar a } deriving Generic
8+data Bar a = Bar { x :: a, y :: a } deriving Generic
9+
10+example :: Foo ()
11+example =
12+ set (field @"bar" . position @1) ()
13+ . set (position @1 . field @"y") ()
14+ $ Foo{ bar = Bar{ x = (), y = () } }
15+
16+example_ :: Foo ()
17+example_ =
18+ set (field_ @"bar" . position_ @1) ()
19+ . set (position_ @1 . field_ @"y") ()
20+ $ Foo{ bar = Bar{ x = (), y = () } }
test/Test63.hsnew file+12
@@ -0,0 +1,12 @@
1+{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications #-}
2+module Test63 (example) where
3+import Data.Generics.Product (types)
4+import Data.Generics.Internal.VL.Lens (over)
5+import Data.Word (Word32)
6+import GHC.Generics (Generic)
7+
8+data Record = Record {field1 :: Word32, field2 :: Int}
9+ deriving (Generic, Show)
10+
11+example :: Record
12+example = over (types @Int) (+1) (Record 0 0)
test/Test71.hsnew file+17
@@ -0,0 +1,17 @@
1+{-# LANGUAGE FlexibleContexts, DeriveGeneric, TypeApplications #-}
2+
3+module Test71 where
4+
5+import GHC.Generics
6+import Control.Lens
7+import Data.Generics.Product
8+
9+data Foobar = Foobar Int Char String
10+ deriving Generic
11+
12+foo :: HasType Foobar ctx => ctx -> Char
13+foo ctx = case view (typed @Foobar) ctx of
14+ Foobar _ c _ -> c
15+
16+bar :: Char
17+bar = foo (Foobar 3 'a' "Hello")
test/doctest.hs+1
@@ -4,4 +4,5 @@ main
4 [ "-isrc"
4 [ "-isrc"
5 , "src/Data/Generics/Product.hs"
5 , "src/Data/Generics/Product.hs"
6 , "src/Data/Generics/Sum.hs"
6 , "src/Data/Generics/Sum.hs"
7+ , "src/Data/Generics/Labels.hs"
7 ]
8 ]
test/syb/Tree.hsnew file+76
@@ -0,0 +1,76 @@
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 _ = []