master..db4a810 · generic-lens

git.iko.soy/generic-lens

55 files changed+403−1578

unifiedsplit

.github/FUNDING.ymldeleted−12

@@ -1,12 +0,0 @@

1−# These are supported funding model platforms

2−

3−github: [kcsongor] # Replace with up to 4 GitHub Sponsors-enabled usernames e.g., [user1, user2]

4−patreon: # Replace with a single Patreon username

5−open_collective: # Replace with a single Open Collective username

6−ko_fi: # Replace with a single Ko-fi username

7−tidelift: # Replace with a single Tidelift platform-name/package-name e.g., npm/babel

8−community_bridge: # Replace with a single Community Bridge project-name e.g., cloud-foundry

9−liberapay: # Replace with a single Liberapay username

10−issuehunt: # Replace with a single IssueHunt username

11−otechie: # Replace with a single Otechie username

12−custom: # Replace with up to 4 custom sponsorship URLs e.g., ['link1', 'link2']

.gitignore−3

@@ -7,6 +7,3 @@ cabal.sandbox.config

77*.hi

88*.o

99core-html

10−*~

11−*.org

12−cabal.project.local

.travis.yml+71−132

@@ -1,155 +1,94 @@

11# This Travis job script has been generated by a script via

22#

3−# haskell-ci '--config=cabal.haskell-ci' 'cabal.project'

3+# make_travis_yml_2.hs 'generic-lens.cabal'

44#

5−# For more information, see https://github.com/haskell-CI/haskell-ci

6−#

7−# version: 0.5.20190908

5+# For more information, see https://github.com/hvr/multi-ghc-travis

86#

97language: c

10−dist: xenial

8+sudo: false

1110git:

12− # whether to recursively clone submodules

13− submodules: false

11+ submodules: false # whether to recursively clone submodules

12+

1413cache:

1514 directories:

1615 - $HOME/.cabal/packages

1716 - $HOME/.cabal/store

17+

1818before_cache:

19− - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log

19+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log

2020 # remove files that are regenerated by 'cabal update'

21− - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*

22− - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json

23− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache

24− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar

25− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx

26− - rm -rfv $CABALHOME/packages/head.hackage

21+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*

22+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json

23+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache

24+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar

25+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx

26+

2727matrix:

2828 include:

29− - compiler: ghc-8.8.1

30− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}}

31− - compiler: ghc-8.6.5

32− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-3.0"]}}

33− - compiler: ghc-8.4.4

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"]}}

37− - compiler: ghc-8.2.2

38− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-3.0"]}}

39− - compiler: ghc-8.0.2

40− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-3.0"]}}

29+ - compiler: "ghc-8.0.2"

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]}}

32+ - compiler: "ghc-8.2.1"

33+ # env: TEST=--disable-tests BENCH=--disable-benchmarks

34+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.1], sources: [hvr-ghc]}}

35+ - 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+ - compiler: "ghc-8.4.1"

39+ # env: TEST=--disable-tests BENCH=--disable-benchmarks

40+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.4.1], sources: [hvr-ghc]}}

41+

4142before_install:

42− - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')

43− - WITHCOMPILER="-w $HC"

44− - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//')

45− - HCPKG="$HC-pkg"

43+ - HC=${CC}

44+ - HCPKG=${HC/ghc/ghc-pkg}

4645 - unset CC

47− - CABAL=/opt/ghc/bin/cabal

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

46+ - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH

47+

7348install:

74− - ${CABAL} --version

49+ - cabal --version

7550 - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"

76− - TEST=--enable-tests

77− - if [ $HCNUMVER -ge 80600 ] ; then TEST=--disable-tests ; fi

78− - BENCH=--enable-benchmarks

79− - if [ $HCNUMVER -ge 80800 ] ; then BENCH=--disable-benchmarks ; fi

80− - HEADHACKAGE=false

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

103− - travis_retry ${CABAL} v2-update -v

104− # Generate cabal.project

105− - rm -rf cabal.project cabal.project.local cabal.project.freeze

106− - touch cabal.project

107− - |

108− 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

113− - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi

114− - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output

115− - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"

116− - rm cabal.project.freeze

117− - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all | color_cabal_output

118− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all | color_cabal_output

119−script:

51+ - BENCH=${BENCH---enable-benchmarks}

52+ - TEST=${TEST---enable-tests}

53+ - HADDOCK=${HADDOCK-true}

54+ - INSTALLED=${INSTALLED-true}

55+ - travis_retry cabal update -v

56+ - sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config

57+ - rm -fv cabal.project.local

58+ - "echo 'packages: .' > cabal.project"

59+ - if [ -f "./configure.ac" ]; then

60+ (cd "."; autoreconf -i);

61+ fi

62+ - rm -f cabal.project.freeze

63+ - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all

64+ - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all

65+ - rm -rf "."/.ghc.environment.* "."/dist

12066 - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)

121− # Packaging...

122− - ${CABAL} v2-sdist all | color_cabal_output

123− # Unpacking...

124− - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/

125− - cd ${DISTDIR} || false

126− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \;

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...

67+

68+# Here starts the actual work to be performed for the package under test;

69+# any command which exits with a non-zero exit code causes the build to fail.

70+script:

71+ # test that source-distributions can be generated

72+ - (cd "."; cabal sdist)

73+ - mv "."/dist/generic-lens-*.tar.gz ${DISTDIR}/

74+ - cd ${DISTDIR}

75+ - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;

76+ - "printf 'packages: generic-lens-*/*.cabal' > cabal.project"

13977 # this builds all libraries and executables (without tests/benchmarks)

140− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output

141− # Building with tests and benchmarks...

78+ - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all

79+

80+ # Build with installed constraints for packages in global-db

81+ - if $INSTALLED; then

82+ echo cabal new-build -w ${HC} --disable-tests --disable-benchmarks $(${HCPKG} list --global --simple-output --names-only | sed 's/$[a-zA-Z0-9-]\{1,\}$ */--constraint="\1 installed" /g') all | sh;

83+ else echo "Not building with installed constraints"; fi

84+

14285 # build & run tests, build benchmarks

143− - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output

144− # Testing...

145− - if [ $HCNUMVER -lt 80600 ] ; then ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi

146− # cabal check...

147− - (cd ${PKGDIR_generic_lens} && ${CABAL} -vnormal check)

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

86+ - cabal new-build -w ${HC} ${TEST} ${BENCH} all

87+ - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} all; fi

88+

89+ # haddock

90+ - rm -rf ./dist-newstyle

91+ - if $HADDOCK; then cabal new-haddock -w ${HC} --disable-tests --disable-benchmarks all; else echo "Skipping haddock generation";fi

15392

154−# REGENDATA ["--config=cabal.haskell-ci","cabal.project"]

93+# REGENDATA ["generic-lens.cabal"]

15594# EOF

ChangeLog.md−20

@@ -1,23 +1,3 @@

1−## 1.2.0.1

2−- Give HasAny/AsAny the same VTA behavior on 8.6 and 8.8 (Ryan Scott)

3−

4−## 1.2.0.0

5−- Add `HasTypesUsing` and `HasTypesCustom` for custom traversals (Lysxia)

6−- Improve type errors when no Generic instance is defined

7−- `types` now supports Text by default

8−

9−### Breaking API changes

10−- `HasType` now includes a reflexive case so that every type 'contains' itself (Matt Parsons)

11−- `AsSubtype` and `Subtype` now include a reflexive case so that every type is a subtype of itself

12−

13−## 1.1.0.0

14−- Fix regression in type inference for polymorphic optics

15−- Add `HasField0`, `HasPosition0`, `AsConstructor0`, `HasField_`, `HasPositon_`, and `AsConstructor_` (Lysxia)

16−- `types` now supports Data.Word and Data.Int (Lysxia)

17−- Add `Wrapped` iso for newtypes (Isaac Elliott)

18−- Expose internals through Data.GenericLens.Internal

19−- Add labels for prisms (Daniel Winograd-Cort)

20−

211## 1.0.0.2

222- Fix compile-time performance regression

233

LICENSE+1−1

@@ -1,4 +1,4 @@

33All rights reserved.

README.md+1−4

@@ -16,9 +16,6 @@ fully interoperable with the combinators found in mainstream lens libraries.

1616

1717Examples can be found in the `examples` and `tests` folders.

1818

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−

2219Table of contents

2320=================

2421

@@ -410,7 +407,7 @@ The

410407library is used to ensure (see [here](test/Spec.hs)) that everything gets

411408inlined away.

412409

413−There is also a [benchmark suite](https://github.com/mpickering/generic-lens-benchmarks) with larger, real-world examples.

410+TODO push benchmarks too

414411# Contributors

415412

416413+ [Matthew Pickering](https://github.com/mpickering)

cabal.haskell-cideleted−5

@@ -1,5 +0,0 @@

1−-- inspection tests fail

2−tests: <8.6

3−

4−-- blocked on vector-th-unbox

5−benchmarks: <8.8

cabal.project−1

@@ -1,2 +1 @@

11packages: generic-lens.cabal

2−write-ghc-environment-files: always

generic-lens.cabal+7−13

@@ -1,5 +1,5 @@

11name: generic-lens

2−version: 1.2.0.1

2+version: 1.0.0.2

33synopsis: Generically derive traversals, lenses and prisms.

44description: 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.

@@ -11,7 +11,7 @@ maintainer: kiss.csongor.kiss@gmail.com

1111category: Generics, Records, Lens

1212build-type: Simple

1313cabal-version: >= 1.10

14−Tested-With: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.1

14+Tested-With: GHC == 8.0.2, GHC == 8.2.1, GHC == 8.4.1, GHC == 8.4.3

1515

1616extra-source-files: ChangeLog.md

1717 , examples/StarWars.hs

@@ -23,8 +23,7 @@ flag dump-core

2323 default: False

2424

2525library

26− exposed-modules: Data.Generics.Wrapped

27− , Data.Generics.Product

26+ exposed-modules: Data.Generics.Product

2827 , Data.Generics.Product.Any

2928 , Data.Generics.Product.Fields

3029 , Data.Generics.Product.Param

@@ -34,7 +33,6 @@ library

3433 , Data.Generics.Product.Types

3534 , Data.Generics.Product.Constraints

3635 , Data.Generics.Product.HList

37− , Data.Generics.Labels

3836 , Data.Generics.Internal.GenericN

3937

4038 , Data.Generics.Sum

@@ -50,13 +48,10 @@ library

5048 , Data.Generics.Internal.VL.Prism

5149 , Data.Generics.Internal.VL.Iso

5250

53− , Data.GenericLens.Internal

54−

5551 other-modules: Data.Generics.Internal.Families

5652 , Data.Generics.Internal.Families.Changing

5753 , Data.Generics.Internal.Families.Collect

5854 , Data.Generics.Internal.Families.Has

59− , Data.Generics.Internal.Errors

6055 , Data.Generics.Internal.Void

6156

6257 , Data.Generics.Sum.Internal.Constructors

@@ -70,10 +65,9 @@ library

7065 , Data.Generics.Product.Internal.Constraints

7166 , Data.Generics.Product.Internal.HList

7267

73− build-depends: base >= 4.9 && < 5

74− , profunctors >= 5.0 && < 6.0

75− , tagged >= 0.8 && < 1

76− , text >= 1.2 && < 1.3

68+ build-depends: base >= 4.9 && <= 5.0

69+ , profunctors >= 5.0 && <= 6.0

70+ , tagged >= 0.8 && <= 0.9

7771

7872 hs-source-dirs: src

7973 default-language: Haskell2010

@@ -103,7 +97,7 @@ test-suite generic-lens-test

10397 type: exitcode-stdio-1.0

10498 hs-source-dirs: test

10599 main-is: Spec.hs

106− other-modules: Util Test24 Test25 Test40 Test62 Test63 CustomChildren

100+ other-modules: Util Test24 Test25 Test40

107101

108102 build-depends: base >= 4.9 && <= 5.0

109103 , generic-lens

src/Data/GenericLens/Internal.hsdeleted−64

@@ -1,64 +0,0 @@

1−-----------------------------------------------------------------------------

2−-- |

3−-- Module : Data.GenericLens.Internal

5−-- License : BSD3

6−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

7−-- Stability : experimental

8−-- Portability : non-portable

9−--

10−-- The library internals are exposed through this module. Please keep

11−-- in mind that everything here is subject to change irrespective of

12−-- the the version numbers.

13−-----------------------------------------------------------------------------

14−

15−module Data.GenericLens.Internal

16− ( module Data.Generics.Internal.Families

17− , module Data.Generics.Internal.Families.Changing

18− , module Data.Generics.Internal.Families.Collect

19− , module Data.Generics.Internal.Families.Has

20− , module Data.Generics.Internal.Void

21− , module Data.Generics.Internal.Errors

22−

23− , module Data.Generics.Sum.Internal.Constructors

24− , module Data.Generics.Sum.Internal.Typed

25− , module Data.Generics.Sum.Internal.Subtype

26−

27− , module Data.Generics.Product.Internal.Positions

28− , module Data.Generics.Product.Internal.GLens

29− , module Data.Generics.Product.Internal.Subtype

30− , module Data.Generics.Product.Internal.Constraints

31− , module Data.Generics.Product.Internal.HList

32−

33− , module Data.Generics.Internal.GenericN

34−

35− -- * van Laarhoven optics

36− , module Data.Generics.Internal.VL.Iso

37− , module Data.Generics.Internal.VL.Lens

38− , module Data.Generics.Internal.VL.Prism

39− , module Data.Generics.Internal.VL.Traversal

40− ) where

41−

42−import Data.Generics.Internal.Families

43−import Data.Generics.Internal.Families.Changing

44−import Data.Generics.Internal.Families.Collect

45−import Data.Generics.Internal.Families.Has

46−import Data.Generics.Internal.Void

47−import Data.Generics.Internal.Errors

48−

49−import Data.Generics.Sum.Internal.Constructors

50−import Data.Generics.Sum.Internal.Typed

51−import Data.Generics.Sum.Internal.Subtype

52−

53−import Data.Generics.Product.Internal.Positions

54−import Data.Generics.Product.Internal.GLens

55−import Data.Generics.Product.Internal.Subtype

56−import Data.Generics.Product.Internal.Constraints

57−import Data.Generics.Product.Internal.HList

58−

59−import Data.Generics.Internal.GenericN

60−

61−import Data.Generics.Internal.VL.Iso

62−import Data.Generics.Internal.VL.Lens

63−import Data.Generics.Internal.VL.Prism

64−import Data.Generics.Internal.VL.Traversal

src/Data/GenericLens/Internal.hs~deleted

No changes to the content.

src/Data/Generics/Internal/Errors.hsdeleted−59

@@ -1,59 +0,0 @@

1−{-# LANGUAGE UndecidableInstances #-}

2−{-# LANGUAGE TypeFamilies #-}

3−{-# LANGUAGE KindSignatures #-}

4−{-# LANGUAGE PolyKinds #-}

5−{-# LANGUAGE DataKinds #-}

6−{-# LANGUAGE TypeOperators #-}

7−{-# LANGUAGE KindSignatures #-}

8−

9−-------------------------------------------------------------------------------

10−---- |

11−---- Module : Data.Generics.Internal.Errors

13−---- License : BSD3

14−---- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

15−---- Stability : experimental

16−---- Portability : non-portable

17−----

18−---- Provide more legible type errors as described in

19−---- (https://kcsongor.github.io/report-stuck-families/)[this blog post].

20−-------------------------------------------------------------------------------

21−

22−module Data.Generics.Internal.Errors

23− ( NoGeneric

24− , Defined

25− , Defined_list

26−

27− , QuoteType

28− , PrettyError

29− ) where

30−

31−import GHC.Generics

32−import GHC.TypeLits

33−import Data.Kind

34−

35−type family NoGeneric (a :: Type) (ctxt :: [ErrorMessage]) :: Constraint where

36− NoGeneric a ctxt = PrettyError ('Text "No instance for " ':<>: QuoteType (Generic a)

37− ': ctxt)

38−type family PrettyError (ctxt :: [ErrorMessage]) :: k where

39− PrettyError '[] = TypeError ('Text "")

40− PrettyError (c ': cs) = TypeError ('Text "| " ':<>: c ':$$: PrettyLines cs)

41−

42−type family PrettyLines (ctxt :: [ErrorMessage]) :: ErrorMessage where

43− PrettyLines '[] = 'Text ""

44− PrettyLines (c ': cs) = 'Text "| " ':<>: c ':$$: PrettyLines cs

45−

46−type family Defined (break :: Type -> Type) (err :: Constraint) (a :: k) :: k where

47− Defined Void1 _ _ = Any

48− Defined _ _ k = k

49−

50−type family Defined_list (break :: [*]) (err :: Constraint) (a :: k) :: k where

51− Defined_list '[Void] _ _ = Any

52− Defined_list _ _ k = k

53−

54−data Void1 a

55−data Void

56−type family Any :: k

57−

58−type family QuoteType (typ :: k) :: ErrorMessage where

59− QuoteType typ = 'Text "‘" ':<>: 'ShowType typ ':<>: 'Text "’"

src/Data/Generics/Internal/Families.hs+2−1

@@ -9,7 +9,7 @@

99-----------------------------------------------------------------------------

1010-- |

1111-- Module : Data.Generics.Internal.Families

1313-- License : BSD3

1414-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

1515-- Stability : experimental

@@ -27,6 +27,7 @@ import Data.Generics.Internal.Families.Changing as Families

2727

2828import GHC.TypeLits (ErrorMessage (..), Symbol)

2929

30+-- * Stuff

3031type family ShowSymbols (ctors :: [Symbol]) :: ErrorMessage where

3132 ShowSymbols '[]

3233 = 'Text ""

src/Data/Generics/Internal/Families/Changing.hs+5−12

@@ -9,14 +9,13 @@

99{-# LANGUAGE UndecidableInstances #-}

1010

1111module Data.Generics.Internal.Families.Changing

12− ( Indexed

12+ ( Proxied

1313 , Infer

1414 , PTag (..)

1515 , P

1616 , LookupParam

1717 , ArgAt

1818 , ArgCount

19− , UnifyHead

2019 ) where

2120

2221import GHC.TypeLits (Nat, type (-), type (+), TypeError, ErrorMessage (..))

@@ -56,11 +55,11 @@ import GHC.TypeLits (Nat, type (-), type (+), TypeError, ErrorMessage (..))

5655data PTag = PTag

5756type family P :: Nat -> k -> PTag -> k

5857

59−type Indexed t = Indexed' t 0

58+type Proxied t = Proxied' t 0

6059

61−type family Indexed' (t :: k) (next :: Nat) :: k where

62− Indexed' (t (a :: j) :: k) next = (Indexed' t (next + 1)) (P next a 'PTag)

63− Indexed' t _ = t

60+type family Proxied' (t :: k) (next :: Nat) :: k where

61+ Proxied' (t (a :: j) :: k) next = (Proxied' t (next + 1)) (P next a 'PTag)

62+ Proxied' t _ = t

6463

6564data Sub where

6665 Sub :: Nat -> k -> Sub

@@ -153,9 +152,3 @@ type family ArgAt (t :: k) (n :: Nat) :: j where

153152-- However, for some reason, this violates the functional dependencies on 8.2.2.

154153-- Therefore, when using a newer version of the compiler, the original constraints

155154-- 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+1−1

@@ -7,7 +7,7 @@

77-----------------------------------------------------------------------------

88-- |

99-- Module : Data.Generics.Internal.Families.Collect

1111-- License : BSD3

1212-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

1313-- Stability : experimental

src/Data/Generics/Internal/Families/Has.hs+29−36

@@ -7,7 +7,7 @@

77-----------------------------------------------------------------------------

88-- |

99-- Module : Data.Generics.Internal.Families.Has

1111-- License : BSD3

1212-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

1313-- Stability : experimental

@@ -24,7 +24,7 @@ module Data.Generics.Internal.Families.Has

2424 , GTypes

2525 ) where

2626

27−import Data.Type.Bool (type (||))

27+import Data.Type.Bool (type (||), type (&&))

2828import Data.Type.Equality (type (==))

2929import GHC.Generics

3030import GHC.TypeLits (Symbol, Nat)

@@ -34,74 +34,67 @@ import Data.Generics.Product.Internal.HList

3434

3535-- Note: these could be factored out into a single traversal

3636

37−type family Both (m1 :: Maybe a) (m2 :: Maybe a) :: Maybe a where

38− Both ('Just a) ('Just a) = 'Just a

39−

40−type family Alt (m1 :: Maybe a) (m2 :: Maybe a) :: Maybe a where

41− Alt ('Just a) _ = 'Just a

42− Alt _ b = b

43−

44−type family HasTotalFieldP (field :: Symbol) f :: Maybe Type where

45− HasTotalFieldP field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 t))

46− = 'Just t

37+type family HasTotalFieldP (field :: Symbol) f :: Bool where

38+ HasTotalFieldP field (S1 ('MetaSel ('Just field) _ _ _) _)

39+ = 'True

4740 HasTotalFieldP field (l :*: r)

48− = Alt (HasTotalFieldP field l) (HasTotalFieldP field r)

41+ = HasTotalFieldP field l || HasTotalFieldP field r

4942 HasTotalFieldP field (l :+: r)

50− = Both (HasTotalFieldP field l) (HasTotalFieldP field r)

43+ = HasTotalFieldP field l && HasTotalFieldP field r

5144 HasTotalFieldP field (S1 _ _)

52− = 'Nothing

45+ = 'False

5346 HasTotalFieldP field (C1 _ f)

5447 = HasTotalFieldP field f

5548 HasTotalFieldP field (D1 _ f)

5649 = HasTotalFieldP field f

5750 HasTotalFieldP field (K1 _ _)

58− = 'Nothing

51+ = 'False

5952 HasTotalFieldP field U1

60− = 'Nothing

53+ = 'False

6154 HasTotalFieldP field V1

62− = 'Nothing

55+ = 'False

6356

64−type family HasTotalTypeP (typ :: Type) f :: Maybe Type where

57+type family HasTotalTypeP (typ :: Type) f :: Bool where

6558 HasTotalTypeP typ (S1 _ (K1 _ typ))

66− = 'Just typ

59+ = 'True

6760 HasTotalTypeP typ (l :*: r)

68− = Alt (HasTotalTypeP typ l) (HasTotalTypeP typ r)

61+ = HasTotalTypeP typ l || HasTotalTypeP typ r

6962 HasTotalTypeP typ (l :+: r)

70− = Both (HasTotalTypeP typ l) (HasTotalTypeP typ r)

63+ = HasTotalTypeP typ l && HasTotalTypeP typ r

7164 HasTotalTypeP typ (S1 _ _)

72− = 'Nothing

65+ = 'False

7366 HasTotalTypeP typ (C1 _ f)

7467 = HasTotalTypeP typ f

7568 HasTotalTypeP typ (D1 _ f)

7669 = HasTotalTypeP typ f

7770 HasTotalTypeP typ (K1 _ _)

78− = 'Nothing

71+ = 'False

7972 HasTotalTypeP typ U1

80− = 'Nothing

73+ = 'False

8174 HasTotalTypeP typ V1

82− = 'Nothing

75+ = 'False

8376

8477data Pos (p :: Nat)

8578

86−type family HasTotalPositionP (pos :: Nat) f :: Maybe Type where

87− HasTotalPositionP pos (S1 _ (K1 (Pos pos) t))

88− = 'Just t

79+type family HasTotalPositionP (pos :: Nat) f :: Bool where

80+ HasTotalPositionP pos (S1 _ (K1 (Pos pos) _))

81+ = 'True

8982 HasTotalPositionP pos (l :*: r)

90− = Alt (HasTotalPositionP pos l) (HasTotalPositionP pos r)

83+ = HasTotalPositionP pos l || HasTotalPositionP pos r

9184 HasTotalPositionP pos (l :+: r)

92− = Both (HasTotalPositionP pos l) (HasTotalPositionP pos r)

85+ = HasTotalPositionP pos l && HasTotalPositionP pos r

9386 HasTotalPositionP pos (S1 _ _)

94− = 'Nothing

87+ = 'False

9588 HasTotalPositionP pos (C1 _ f)

9689 = HasTotalPositionP pos f

9790 HasTotalPositionP pos (D1 _ f)

9891 = HasTotalPositionP pos f

9992 HasTotalPositionP pos (K1 _ _)

100− = 'Nothing

93+ = 'False

10194 HasTotalPositionP pos U1

102− = 'Nothing

95+ = 'False

10396 HasTotalPositionP pos V1

104− = 'Nothing

97+ = 'False

10598

10699type family HasPartialTypeP a f :: Bool where

107100 HasPartialTypeP t (l :+: r)

@@ -123,7 +116,7 @@ type family HasCtorP (ctor :: Symbol) f :: Bool where

123116 HasCtorP ctor _

124117 = 'False

125118

126−type family GTypes (rep :: Type -> Type) :: [Type] where

119+type family GTypes (rep :: Type -> Type) :: [(Type)] where

127120 GTypes (l :*: r)

128121 = GTypes l ++ GTypes r

129122 GTypes (K1 _ a)

src/Data/Generics/Internal/GenericN.hs+2−3

@@ -1,4 +1,3 @@

1−{-# OPTIONS_HADDOCK hide #-}

21{-# LANGUAGE DataKinds #-}

32{-# LANGUAGE FlexibleContexts #-}

43{-# LANGUAGE FlexibleInstances #-}

@@ -12,9 +11,9 @@

1211--------------------------------------------------------------------------------

1312-- |

1413-- Module : Data.Generics.Internal.GenericN

16−-- License : BSD3

1715-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

16+-- License : BSD3

1817-- Stability : experimental

1918-- Portability : non-portable

2019--

src/Data/Generics/Internal/Profunctor/Iso.hs+1−9

@@ -1,5 +1,3 @@

1−{-# OPTIONS_HADDOCK hide #-}

2−{-# LANGUAGE TupleSections #-}

31{-# LANGUAGE GADTs #-}

42{-# LANGUAGE NoMonomorphismRestriction #-}

53{-# LANGUAGE Rank2Types #-}

@@ -11,7 +9,7 @@

119-----------------------------------------------------------------------------

1210-- |

1311-- Module : Data.Generics.Internal.Profunctor.Iso

1513-- License : BSD3

1614-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

1715-- Stability : experimental

@@ -28,8 +26,6 @@ import GHC.Generics ((:*:)(..), (:+:)(..), Generic(..), M1(..), K1(..)

2826import Data.Coerce

2927import Data.Generics.Internal.GenericN (Rec (..))

3028

31−import qualified Data.Generics.Internal.VL.Iso as VL

32−

3329type Iso s t a b

3430 = forall p. (Profunctor p) => p a b -> p s t

3531

@@ -78,10 +74,6 @@ iso :: (s -> a) -> (b -> t) -> Iso s t a b

7874iso = dimap

7975{-# INLINE iso #-}

8076

81−iso2isovl :: Iso s t a b -> VL.Iso s t a b

82−iso2isovl _iso = withIso _iso VL.iso

83−{-# INLINE iso2isovl #-}

84−

8577withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r

8678withIso ai k = case ai (Exchange id id) of

8779 Exchange sa bt -> k sa bt

src/Data/Generics/Internal/Profunctor/Lens.hs+1−2

@@ -1,4 +1,3 @@

1−{-# OPTIONS_HADDOCK hide #-}

21{-# LANGUAGE GADTs #-}

32{-# LANGUAGE NoMonomorphismRestriction #-}

43{-# LANGUAGE Rank2Types #-}

@@ -11,7 +10,7 @@

1110-----------------------------------------------------------------------------

1211-- |

1312-- Module : Data.Generics.Internal.Profunctor.Lens

1514-- License : BSD3

1615-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

1716-- Stability : experimental

src/Data/Generics/Internal/Profunctor/Prism.hs+9−8

@@ -1,4 +1,3 @@

1−{-# OPTIONS_HADDOCK hide #-}

21{-# LANGUAGE GADTs #-}

32{-# LANGUAGE LambdaCase #-}

43{-# LANGUAGE NoMonomorphismRestriction #-}

@@ -11,7 +10,7 @@

1110-----------------------------------------------------------------------------

1211-- |

1312-- Module : Data.Generics.Internal.Profunctor.Prism

1514-- License : BSD3

1615-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

1716-- Stability : experimental

@@ -22,7 +21,6 @@

2221-----------------------------------------------------------------------------

2322module Data.Generics.Internal.Profunctor.Prism where

2423

25−import Data.Bifunctor (bimap)

2624import Data.Profunctor (Choice(..), Profunctor(..))

2725import Data.Tagged

2826import Data.Profunctor.Unsafe ((#.), (.#))

@@ -46,12 +44,12 @@ prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b

4644prism bt seta eta = dimap seta (either id bt) (right' eta)

4745

4846_Left :: Prism (Either a c) (Either b c) a b

49−_Left = left'

47+_Left = prism Left $ either Right (Left . Right)

5048

5149_Right :: Prism (Either c a) (Either c b) a b

52−_Right = right'

50+_Right = prism Right $ either (Left . Left) Right

5351

54−prismPRavel :: APrism s t a b -> Prism s t a b

52+prismPRavel :: (Market a b a b -> Market a b s t) -> Prism s t a b

5553prismPRavel l pab = (prism2prismp $ l idPrism) pab

5654

5755build :: (Tagged b b -> Tagged t t) -> b -> t

@@ -67,7 +65,9 @@ without' :: Prism s t a b -> Prism s t c d -> Prism s t (Either a c) (Either b d

6765without' k =

6866 withPrism k $ \bt _ k' ->

6967 withPrism k' $ \dt setc ->

70− prism (either bt dt) $ \s -> fmap Right (setc s)

68+ prism (foldEither bt dt) $ \s -> fmap Right (setc s)

69+ where foldEither _ g (Right r) = g r

70+ foldEither f _ (Left l) = f l

7171{-# INLINE without' #-}

7272

7373withPrism :: APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r

@@ -85,7 +85,8 @@ gsum f _ (L1 x) = f x

8585gsum _ g (R1 y) = g y

8686

8787plus :: (a -> b) -> (c -> d) -> Either a c -> Either b d

88−plus = bimap

88+plus f _ (Left x) = Left (f x)

89+plus _ g (Right y) = Right (g y)

8990

9091--------------------------------------------------------------------------------

9192-- Market

src/Data/Generics/Internal/VL/Iso.hs+2−30

@@ -1,4 +1,3 @@

1−{-# OPTIONS_HADDOCK hide #-}

21{-# LANGUAGE GADTs #-}

32{-# LANGUAGE NoMonomorphismRestriction #-}

43{-# LANGUAGE Rank2Types #-}

@@ -10,7 +9,7 @@

109-----------------------------------------------------------------------------

1110-- |

1211-- Module : Data.Generics.Internal.VL.Iso

1413-- License : BSD3

1514-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

1615-- Stability : experimental

@@ -21,43 +20,16 @@

2120-----------------------------------------------------------------------------

2221module Data.Generics.Internal.VL.Iso where

2322

24−import Data.Coerce (coerce)

25−import Data.Functor.Identity (Identity(..))

26−import Data.Profunctor (Profunctor(..))

23+import Data.Profunctor (Profunctor(..))

2724import GHC.Generics

2825import Data.Generics.Internal.GenericN (Rec (..))

2926

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−

4427type Iso' s a

4528 = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s)

4629

4730type Iso s t a b

4831 = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)

4932

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−

6133-- | A type and its generic representation are isomorphic

6234repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)

6335repIso = iso from to

src/Data/Generics/Internal/VL/Lens.hs+1−6

@@ -1,4 +1,3 @@

1−{-# OPTIONS_HADDOCK hide #-}

21{-# LANGUAGE GADTs #-}

32{-# LANGUAGE NoMonomorphismRestriction #-}

43{-# LANGUAGE Rank2Types #-}

@@ -11,7 +10,7 @@

1110-----------------------------------------------------------------------------

1211-- |

1312-- Module : Data.Generics.Internal.VL.Lens

1514-- License : BSD3

1615-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

1716-- Stability : experimental

@@ -23,7 +22,6 @@

2322module Data.Generics.Internal.VL.Lens where

2423

2524import Control.Applicative (Const(..))

26−import Data.Coerce (coerce)

2725import Data.Functor.Identity (Identity(..))

2826import Data.Generics.Internal.Profunctor.Lens (ALens (..), idLens)

2927

@@ -49,9 +47,6 @@ infixr 4 .~

4947set :: Lens s t a b -> b -> s -> t

5048set l x = l .~ x

5149

52−over :: ((a -> Identity b) -> s -> Identity t) -> (a -> b) -> s -> t

53−over = coerce

54−

5550lens2lensvl :: ALens a b s t -> Lens s t a b

5651lens2lensvl (ALens _get _set) =

5752 \f x ->

src/Data/Generics/Internal/VL/Prism.hs+1−2

@@ -1,4 +1,3 @@

1−{-# OPTIONS_HADDOCK hide #-}

21{-# LANGUAGE GADTs #-}

32{-# LANGUAGE NoMonomorphismRestriction #-}

43{-# LANGUAGE Rank2Types #-}

@@ -10,7 +9,7 @@

109-----------------------------------------------------------------------------

1110-- |

1211-- Module : Data.Generics.Internal.VL.Prism

1413-- License : BSD3

1514-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

1615-- Stability : experimental

src/Data/Generics/Internal/VL/Traversal.hs+1−2

@@ -1,4 +1,3 @@

1−{-# OPTIONS_HADDOCK hide #-}

21{-# LANGUAGE AllowAmbiguousTypes #-}

32{-# LANGUAGE ConstraintKinds #-}

43{-# LANGUAGE GADTs #-}

@@ -12,7 +11,7 @@

1211-----------------------------------------------------------------------------

1312-- |

1413-- Module : Data.Generics.Internal.VL.Traversal

1615-- License : BSD3

1716-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

1817-- Stability : experimental

src/Data/Generics/Labels.hs+17−123

@@ -1,142 +1,36 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE CPP #-}

3−{-# LANGUAGE ConstraintKinds #-}

4−{-# LANGUAGE DataKinds #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE FunctionalDependencies #-}

7−{-# LANGUAGE MultiParamTypeClasses #-}

8−{-# LANGUAGE PolyKinds #-}

9−{-# LANGUAGE ScopedTypeVariables #-}

10−{-# LANGUAGE TypeApplications #-}

11−{-# LANGUAGE TypeOperators #-}

12−{-# LANGUAGE TypeFamilies #-}

13−{-# LANGUAGE UndecidableInstances #-}

14−{-# OPTIONS_GHC -Wno-orphans #-}

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE MultiParamTypeClasses #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE TypeApplications #-}

6+{-# LANGUAGE TypeFamilies #-}

7+{-# LANGUAGE UndecidableInstances #-}

8+{-# OPTIONS_GHC -Wno-orphans #-}

1510

1611--------------------------------------------------------------------------------

1712-- |

1813-- Module : Data.Generics.Labels

20−-- License : BSD3

2115-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

16+-- License : BSD3

2217-- Stability : experimental

2318-- Portability : non-portable

2419--

25−-- Provides an (orphan) IsLabel instance for field lenses and constructor prisms.

20+-- Provides an (orphan) IsLabel instance for field lenses.

2621-- Use at your own risk.

2722--------------------------------------------------------------------------------

2823

29−module Data.Generics.Labels

30− ( -- * Orphan IsLabel Instance

31− -- $sec1

32− Field(..)

33− , Field'

34− , Constructor(..)

35− , Constructor'

36− ) where

24+module Data.Generics.Labels () where

3725

3826import 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−

4727import 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)

13128

132−instance (Functor f, Field name s t a b) => IsLabelHelper 'False name (->) f s t a b where

133− labelOutput = fieldLens @name

13429

30+instance (HasField field s t a b, Functor f, sft ~ (s -> f t)) =>

31+ IsLabel field ((a -> f b) -> sft) where

13532#if __GLASGOW_HASKELL__ >= 802

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

33+ fromLabel = field @field

13934#else

140−instance (TypeError ('Text "Labels for Prisms require at least GHC 8.2"), Choice p) => IsLabelHelper 'True name' p f s t a b where

141− labelOutput = undefined

35+ fromLabel _ = field @field

14236#endif

src/Data/Generics/Product.hs+1−1

@@ -1,7 +1,7 @@

11-----------------------------------------------------------------------------

22-- |

33-- Module : Data.Generics.Product

55-- License : BSD3

66-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

77-- Stability : experimental

src/Data/Generics/Product/Any.hs+2−2

@@ -12,7 +12,7 @@

1212-----------------------------------------------------------------------------

1313-- |

1414-- Module : Data.Generics.Product.Any

1616-- License : BSD3

1717-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

1818-- Stability : experimental

@@ -53,7 +53,7 @@ import Data.Generics.Product.Typed

5353-- human = Human "Tunyasz" 50 "London"

5454-- :}

5555

56−class HasAny sel s t a b | s sel -> a where

56+class HasAny (sel :: k) s t a b | s sel k -> a where

5757 -- |A lens that focuses on a part of a product as identified by some

5858 -- selector. Currently supported selectors are field names, positions and

5959 -- unique types. Compatible with the lens package's 'Control.Lens.Lens'

src/Data/Generics/Product/Constraints.hs+1−1

@@ -11,7 +11,7 @@

1111-----------------------------------------------------------------------------

1212-- |

1313-- Module : Data.Generics.Product.Constraints

1515-- License : BSD3

1616-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

1717-- Stability : experimental

src/Data/Generics/Product/Fields.hs+22−78

@@ -16,7 +16,7 @@

1616-----------------------------------------------------------------------------

1717-- |

1818-- Module : Data.Generics.Product.Fields

2020-- License : BSD3

2121-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

2222-- Stability : experimental

@@ -32,7 +32,6 @@ module Data.Generics.Product.Fields

3232 -- $setup

3333 HasField (..)

3434 , HasField' (..)

35− , HasField_ (..)

3635

3736 , getField

3837 , setField

@@ -47,7 +46,6 @@ import Data.Kind (Constraint, Type)

4746import GHC.Generics

4847import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError)

4948import Data.Generics.Internal.Profunctor.Lens as P

50−import Data.Generics.Internal.Errors

5149

5250-- $setup

5351-- == /Running example:/

@@ -113,30 +111,9 @@ class HasField (field :: Symbol) s t a b | s field -> a, t field -> b, s field b

113111 -- ...

114112 field :: VL.Lens s t a b

115113

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−

130114class HasField' (field :: Symbol) s a | s field -> a where

131115 field' :: VL.Lens s s a a

132116

133−-- |Records that have a field with a given name.

134−--

135−-- This class gives the minimal constraints needed to define this lens.

136−-- For common uses, see 'HasField'.

137−class HasField0 (field :: Symbol) s t a b where

138− field0 :: VL.Lens s t a b

139−

140117-- |

141118-- >>> getField @"age" human

142119-- 50

@@ -153,67 +130,34 @@ instance

153130 ( Generic s

154131 , ErrorUnless field s (CollectField field (Rep s))

155132 , GLens' (HasTotalFieldPSym field) (Rep s) a

156− , Defined (Rep s)

157− (NoGeneric s '[ 'Text "arising from a generic lens focusing on the "

158− ':<>: QuoteType field ':<>: 'Text " field of type " ':<>: QuoteType a

159− , 'Text "in " ':<>: QuoteType s])

160− (() :: Constraint)

161133 ) => 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

134+ field' f s = VL.ravel (repLens . glens @(HasTotalFieldPSym field)) f s

166135

167136instance -- see Note [Changing type parameters]

168− ( HasTotalFieldP field (Rep s) ~~ 'Just a

169− , HasTotalFieldP field (Rep t) ~~ 'Just b

170− , HasTotalFieldP field (Rep (Indexed s)) ~~ 'Just a'

171− , HasTotalFieldP field (Rep (Indexed t)) ~~ 'Just b'

172− , t ~~ Infer s a' b

173− , s ~~ Infer t b' a

174− , HasField0 field s t a b

175− ) => HasField field s t a b where

176− field f s = field0 @field f s

177−

178−-- | See Note [Uncluttering type signatures]

179−#if __GLASGOW_HASKELL__ < 804

180−-- >>> :t field

181−-- field

182−-- :: (HasField field s t a b, Functor f) => (a -> f b) -> s -> f t

137+ ( Generic s

138+ , ErrorUnless field s (CollectField field (Rep s))

139+ , Generic t

140+ -- see Note [CPP in instance constraints]

141+#if __GLASGOW_HASKELL__ < 802

142+ , '(s', t') ~ '(Proxied s, Proxied t)

183143#else

184−-- >>> :t field

185−-- field

186−-- :: (Functor f, HasField field s t a b) => (a -> f b) -> s -> f t

144+ , s' ~ Proxied s

145+ , t' ~ Proxied t

187146#endif

147+ , Generic s'

148+ , Generic t'

149+ , GLens' (HasTotalFieldPSym field) (Rep s') a'

150+ , GLens' (HasTotalFieldPSym field) (Rep t') b'

151+ , GLens (HasTotalFieldPSym field) (Rep s) (Rep t) a b

152+ , t ~ Infer s a' b

153+ , s ~ Infer t b' a

154+ ) => HasField field s t a b where

155+ field f s = VL.ravel (repLens . glens @(HasTotalFieldPSym field)) f s

156+

157+-- -- See Note [Uncluttering type signatures]

188158instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where

189159 field = undefined

190160

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−

217161type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Constraint where

218162 ErrorUnless field s ('TypeStat _ _ '[])

219163 = TypeError

@@ -236,5 +180,5 @@ type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Cons

236180 ErrorUnless _ _ ('TypeStat '[] '[] _)

237181 = ()

238182

239−data HasTotalFieldPSym :: Symbol -> (TyFun (Type -> Type) (Maybe Type))

183+data HasTotalFieldPSym :: Symbol -> (TyFun (Type -> Type) Bool)

240184type instance Eval (HasTotalFieldPSym sym) tt = HasTotalFieldP sym tt

src/Data/Generics/Product/HList.hs+3−4

@@ -10,7 +10,7 @@

1010-----------------------------------------------------------------------------

1111-- |

1212-- Module : Data.Generics.Product.HList

1414-- License : BSD3

1515-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

1616-- Stability : experimental

@@ -27,8 +27,7 @@ module Data.Generics.Product.HList

2727import Data.Generics.Product.Internal.HList

2828import Data.Kind

2929import GHC.Generics

30−import Data.Generics.Internal.VL.Iso (Iso)

31−import Data.Generics.Internal.Profunctor.Iso (repIso, iso2isovl)

30+import Data.Generics.Internal.Profunctor.Iso

3231

3332class IsList

3433 (f :: Type)

@@ -42,5 +41,5 @@ instance

4241 , Generic g

4342 , GIsList (Rep f) (Rep g) as bs

4443 ) => IsList f g as bs where

45− list = iso2isovl (repIso . glist)

44+ list = repIso . glist

4645 {-# INLINE list #-}

src/Data/Generics/Product/Internal/Constraints.hs+1−1

@@ -15,7 +15,7 @@

1515-----------------------------------------------------------------------------

1616-- |

1717-- Module : Data.Generics.Product.Internal.Constraints

1919-- License : BSD3

2020-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

2121-- Stability : experimental

src/Data/Generics/Product/Internal/GLens.hs+12−14

@@ -17,7 +17,7 @@

1717-----------------------------------------------------------------------------

1818-- |

1919-- Module : Data.Generics.Product.Internal.GLens

2121-- License : BSD3

2222-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

2323-- Stability : experimental

@@ -40,13 +40,11 @@ import Data.Generics.Internal.Profunctor.Iso (kIso, sumIso, mIso)

4040import Data.Kind (Type)

4141import GHC.Generics

4242

43−type Pred = TyFun (Type -> Type) (Maybe Type)

44−

4543type TyFun a b = a -> b -> Type

4644type family Eval (f :: TyFun a b) (x :: a) :: b

4745

4846-- A generic lens that uses some predicate to determine which field to focus on

49−class GLens (pred :: Pred) (s :: Type -> Type) (t :: Type -> Type) a b | s pred -> a, t pred -> b where

47+class GLens (pred :: TyFun (Type -> Type) Bool) (s :: Type -> Type) (t :: Type -> Type) a b | s pred -> a, t pred -> b where

5048 glens :: Lens (s x) (t x) a b

5149

5250type GLens' pred s a = GLens pred s s a a

@@ -54,7 +52,7 @@ type GLens' pred s a = GLens pred s s a a

5452instance GProductLens (Eval pred l) pred l r l' r' a b

5553 => GLens pred (l :*: r) (l' :*: r') a b where

5654

57− glens = gproductLens @(Eval pred l) @pred

55+ glens = gproductField @(Eval pred l) @pred

5856 {-# INLINE glens #-}

5957

6058instance (GLens pred l l' a b, GLens pred r r' a b) => GLens pred (l :+: r) (l' :+: r') a b where

@@ -65,17 +63,17 @@ instance GLens pred (K1 r a) (K1 r b) a b where

6563 glens = kIso

6664 {-# INLINE glens #-}

6765

68−instance (GLens pred f g a b) => GLens pred (M1 m meta f) (M1 m meta g) a b where

66+instance (Functor g, GLens pred f g a b) => GLens pred (M1 m meta f) (M1 m meta g) a b where

6967 glens = mIso . glens @pred

7068 {-# INLINE glens #-}

7169

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

70+class GProductLens (left :: Bool) (pred :: TyFun (Type -> Type) Bool) l r l' r' a b | pred l r -> a, pred l' r' -> b where

71+ gproductField :: Lens ((l :*: r) x) ((l' :*: r') x) a b

7472

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 #-}

73+instance GLens pred l l' a b => GProductLens 'True pred l r l' r a b where

74+ gproductField = first . glens @pred

75+ {-# INLINE gproductField #-}

7876

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 #-}

77+instance GLens pred r r' a b => GProductLens 'False pred l r l r' a b where

78+ gproductField = second . glens @pred

79+ {-# INLINE gproductField #-}

src/Data/Generics/Product/Internal/HList.hs+63−68

@@ -20,7 +20,7 @@

2020-----------------------------------------------------------------------------

2121-- |

2222-- Module : Data.Generics.Product.Internal.HList

2424-- License : BSD3

2525-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

2626-- Stability : experimental

@@ -96,7 +96,7 @@ class GIsList

9696instance

9797 ( GIsList l l' as as'

9898 , GIsList r r' bs bs'

99− , Appending as bs cs as' bs' cs'

99+ , Appending HList as bs cs as' bs' cs'

100100 , cs ~ (as ++ bs)

101101 , cs' ~ (as' ++ bs')

102102 ) => GIsList (l :*: r) (l' :*: r') cs cs' where

@@ -118,29 +118,24 @@ instance GIsList U1 U1 '[] '[] where

118118

119119--------------------------------------------------------------------------------

120120-- | 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')

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')

128123

129124-- | [] ++ bs === bs

130−instance Appending '[] bs bs '[] bs' bs' where

131− appending = iso snd (Nil,)

125+instance Appending HList '[] bs bs '[] bs' bs' where

126+ appending = iso (\(_, b) -> b) (Nil,)

132127

133128-- | (a : as) ++ bs === (a : cs)

134129instance

135− Appending as bs cs as' bs' cs' -- as ++ bs == cs

136− => Appending (a ': as) bs (a ': cs) (a' ': as') bs' (a' ': cs') where

130+ Appending HList as bs cs as' bs' cs' -- as ++ bs == cs

131+ => Appending HList (a ': as) bs (a ': cs) (a' ': as') bs' (a' ': cs') where

137132 appending

138133 = pairing (fromIso consing) id -- ((a, as), bs)

139134 . assoc3 -- (a, (as, bs))

140135 . pairing id appending -- (a, cs)

141136 . consing -- (a : cs)

142137

143−singleton :: Iso a b (HList '[a]) (HList '[ b])

138+singleton :: Iso a b (HList '[ a]) (HList '[ b])

144139singleton = iso (:> Nil) (\(x :> _) -> x)

145140

146141consing :: Iso (a, HList as) (b, HList bs) (HList (a ': as)) (HList (b ': bs))

@@ -181,127 +176,127 @@ instance ListTuple () '[] where

181176 tupleToList _ = Nil

182177 listToTuple _ = ()

183178

184−instance ListTuple a '[a] where

185− type ListToTuple '[a] = a

179+instance ListTuple a '[ a] where

180+ type ListToTuple '[ a] = a

186181 tupleToList a

187182 = a :> Nil

188183 listToTuple (a :> Nil)

189184 = a

190185

191−instance ListTuple (a, b) '[a, b] where

192− type ListToTuple '[a, b] = (a, b)

186+instance ListTuple (a, b) '[ a, b] where

187+ type ListToTuple '[ a, b] = (a, b)

193188 tupleToList (a, b)

194189 = a :> b :> Nil

195190 listToTuple (a :> b :> Nil)

196191 = (a, b)

197192

198−instance ListTuple (a, b, c) '[a, b, c] where

199− type ListToTuple '[a, b, c] = (a, b, c)

193+instance ListTuple (a, b, c) '[ a, b, c] where

194+ type ListToTuple '[ a, b, c] = (a, b, c)

200195 tupleToList (a, b, c)

201196 = a :> b :> c :> Nil

202197 listToTuple (a :> b :> c :> Nil)

203198 = (a, b, c)

204199

205−instance ListTuple (a, b, c, d) '[a, b, c, d] where

206− type ListToTuple '[a, b, c, d] = (a, b, c, d)

200+instance ListTuple (a, b, c, d) '[ a, b, c, d] where

201+ type ListToTuple '[ a, b, c, d] = (a, b, c, d)

207202 tupleToList (a, b, c, d)

208203 = a :> b :> c :> d:> Nil

209204 listToTuple (a :> b :> c :> d :> Nil)

210205 = (a, b, c, d)

211206

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)

207+instance ListTuple (a, b, c, d, e) '[ a, b, c, d, e] where

208+ type ListToTuple '[ a, b, c, d, e] = (a, b, c, d, e)

214209 tupleToList (a, b, c, d, e)

215210 = a :> b :> c :> d:> e :> Nil

216211 listToTuple (a :> b :> c :> d :> e :> Nil)

217212 = (a, b, c, d, e)

218213

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)

214+instance ListTuple (a, b, c, d, e, f) '[ a, b, c, d, e, f] where

215+ type ListToTuple '[ a, b, c, d, e, f] = (a, b, c, d, e, f)

221216 tupleToList (a, b, c, d, e, f)

222217 = a :> b :> c :> d:> e :> f :> Nil

223218 listToTuple (a :> b :> c :> d :> e :> f :> Nil)

224219 = (a, b, c, d, e, f)

225220

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)

221+instance ListTuple (a, b, c, d, e, f, g) '[ a, b, c, d, e, f, g] where

222+ type ListToTuple '[ a, b, c, d, e, f, g] = (a, b, c, d, e, f, g)

228223 tupleToList (a, b, c, d, e, f, g)

229224 = a :> b :> c :> d:> e :> f :> g :> Nil

230225 listToTuple (a :> b :> c :> d :> e :> f :> g :> Nil)

231226 = (a, b, c, d, e, f, g)

232227

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)

228+instance ListTuple (a, b, c, d, e, f, g, h) '[ a, b, c, d, e, f, g, h] where

229+ type ListToTuple '[ a, b, c, d, e, f, g, h] = (a, b, c, d, e, f, g, h)

235230 tupleToList (a, b, c, d, e, f, g, h)

236231 = a :> b :> c :> d:> e :> f :> g :> h :> Nil

237232 listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> Nil)

238233 = (a, b, c, d, e, f, g, h)

239234

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)

235+instance ListTuple (a, b, c, d, e, f, g, h, j) '[ a, b, c, d, e, f, g, h, j] where

236+ type ListToTuple '[ a, b, c, d, e, f, g, h, j] = (a, b, c, d, e, f, g, h, j)

242237 tupleToList (a, b, c, d, e, f, g, h, j)

243238 = a :> b :> c :> d:> e :> f :> g :> h :> j :> Nil

244239 listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> Nil)

245240 = (a, b, c, d, e, f, g, h, j)

246241

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)

242+instance ListTuple (a, b, c, d, e, f, g, h, j, k) '[ a, b, c, d, e, f, g, h, j, k] where

243+ type ListToTuple '[ a, b, c, d, e, f, g, h, j, k] = (a, b, c, d, e, f, g, h, j, k)

249244 tupleToList (a, b, c, d, e, f, g, h, j, k)

250245 = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> Nil

251246 listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> Nil)

252247 = (a, b, c, d, e, f, g, h, j, k)

253248

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)

249+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

250+ type ListToTuple '[ a, b, c, d, e, f, g, h, j, k, l] = (a, b, c, d, e, f, g, h, j, k, l)

256251 tupleToList (a, b, c, d, e, f, g, h, j, k, l)

257252 = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> Nil

258253 listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> Nil)

259254 = (a, b, c, d, e, f, g, h, j, k, l)

260255

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)

256+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

257+ 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)

263258 tupleToList (a, b, c, d, e, f, g, h, j, k, l, m)

264259 = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> Nil

265260 listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> Nil)

266261 = (a, b, c, d, e, f, g, h, j, k, l, m)

267262

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)

263+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

264+ 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)

270265 tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n)

271266 = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil

272267 listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil)

273268 = (a, b, c, d, e, f, g, h, j, k, l, m, n)

274269

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)

270+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

271+ 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)

277272 tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o)

278273 = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil

279274 listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil)

280275 = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)

281276

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)

277+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

278+ 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)

284279 tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)

285280 = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil

286281 listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil)

287282 = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)

288283

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)

284+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

285+ 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)

291286 tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)

292287 = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil

293288 listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil)

294289 = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)

295290

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)

291+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

292+ 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)

298293 tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)

299294 = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil

300295 listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil)

301296 = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)

302297

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)

298+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

299+ 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)

305300 tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)

306301 = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil

307302 listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil)

@@ -309,21 +304,21 @@ instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) '[a, b

309304

310305type family TupleToList a where

311306 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]

307+ TupleToList (a, b) = '[ a, b]

308+ TupleToList (a, b, c) = '[ a, b, c]

309+ TupleToList (a, b, c, d) = '[ a, b, c, d]

310+ TupleToList (a, b, c, d, e) = '[ a, b, c, d, e]

311+ TupleToList (a, b, c, d, e, f) = '[ a, b, c, d, e, f]

312+ TupleToList (a, b, c, d, e, f, g) = '[ a, b, c, d, e, f, g]

313+ TupleToList (a, b, c, d, e, f, g, h) = '[ a, b, c, d, e, f, g, h]

314+ TupleToList (a, b, c, d, e, f, g, h, j) = '[ a, b, c, d, e, f, g, h, j]

315+ TupleToList (a, b, c, d, e, f, g, h, j, k) = '[ a, b, c, d, e, f, g, h, j, k]

316+ TupleToList (a, b, c, d, e, f, g, h, j, k, l) = '[ a, b, c, d, e, f, g, h, j, k, l]

317+ 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]

318+ 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]

319+ 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]

320+ 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]

321+ 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]

322+ 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]

323+ 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]

324+ TupleToList a = '[ a]

src/Data/Generics/Product/Internal/Positions.hs+6−6

@@ -17,7 +17,7 @@

1717-----------------------------------------------------------------------------

1818-- |

1919-- Module : Data.Generics.Product.Internal.Positions

2121-- License : BSD3

2222-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

2323-- Stability : experimental

@@ -40,7 +40,7 @@ import GHC.Generics

4040import GHC.TypeLits (type (<=?), type (+), Nat)

4141

4242-- | Alias for the kind of the generic rep

43−type G = Type -> Type

43+type G k = k -> Type

4444

4545--------------------------------------------------------------------------------

4646

@@ -50,7 +50,7 @@ type G = Type -> Type

5050-- of the field in question in the data type. This is convenient, because we

5151-- can reuse all the existing functions as long as they are polymorphic in the

5252-- first parameter of 'K1'.

53−type family CRep (a :: Type) :: G where

53+type family CRep (a :: Type) :: G k where

5454 CRep rep = Fst (Traverse (Rep rep) 1)

5555

5656-- | The actual traversal.

@@ -58,7 +58,7 @@ type family CRep (a :: Type) :: G where

5858-- Might be cleaner if the sum and product parts were separated (as there's

5959-- and invariant that 'n' should be zero when we're at a sum node, which holds

6060-- for derived Generic instances (where the sums are strictly above the products))

61−type family Traverse (a :: G) (n :: Nat) :: (G, Nat) where

61+type family Traverse (a :: G k) (n :: Nat) :: (G k, Nat) where

6262 Traverse (M1 mt m s) n

6363 = Traverse1 (M1 mt m) (Traverse s n)

6464 Traverse (l :+: r) n

@@ -70,12 +70,12 @@ type family Traverse (a :: G) (n :: Nat) :: (G, Nat) where

7070 Traverse U1 n

7171 = '(U1, n)

7272

73−type family Traverse1 (w :: G -> G) (z :: (G, Nat)) :: (G, Nat) where

73+type family Traverse1 (w :: G k -> G k) (z :: (G k, Nat)) :: (G k, Nat) where

7474 Traverse1 w '(i, n) = '(w i, n)

7575

7676-- | For products, we first traverse the left-hand side, followed by the second

7777-- using the counter returned by the left traversal.

78−type family TraverseProd (c :: G -> G -> G) (a :: (G, Nat)) (r :: G) :: (G, Nat) where

78+type family TraverseProd (c :: G k -> G k -> G k) (a :: (G k, Nat)) (r :: G k) :: (G k, Nat) where

7979 TraverseProd w '(i, n) r = Traverse1 (w i) (Traverse r n)

8080

8181--------------------------------------------------------------------------------

src/Data/Generics/Product/Internal/Subtype.hs+5−5

@@ -16,7 +16,7 @@

1616-----------------------------------------------------------------------------

1717-- |

1818-- Module : Data.Generics.Product.Internal.Subtype

2020-- License : BSD3

2121-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

2222-- Stability : experimental

@@ -82,16 +82,16 @@ instance GSmash sub sup => GSmash (C1 c sub) sup where

8282instance GSmash sub sup => GSmash (D1 c sub) sup where

8383 gsmash sup (M1 sub) = M1 (gsmash sup sub)

8484

85−class GSmashLeaf sub sup (w :: Maybe Type) where

85+class GSmashLeaf sub sup (w :: Bool) where

8686 gsmashLeaf :: sup p -> sub p -> sub p

8787

8888instance

8989 GLens' (HasTotalFieldPSym field) sup t

90− => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup ('Just t) where

90+ => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'True where

9191 gsmashLeaf sup _ = M1 (K1 (view (glens @(HasTotalFieldPSym field)) sup))

9292

93−instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'Nothing where

93+instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'False where

9494 gsmashLeaf _ = id

9595

96−data HasTotalFieldPSym :: Symbol -> (TyFun (Type -> Type) (Maybe Type))

96+data HasTotalFieldPSym :: Symbol -> (TyFun (Type -> Type) Bool)

9797type instance Eval (HasTotalFieldPSym sym) tt = HasTotalFieldP sym tt

src/Data/Generics/Product/Param.hs+3−10

@@ -15,13 +15,13 @@

1515--------------------------------------------------------------------------------

1616-- |

1717-- Module : Data.Generics.Product.Param

19−-- License : BSD3

2019-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

20+-- License : BSD3

2121-- Stability : experimental

2222-- Portability : non-portable

2323--

24−-- Derive traversals over type parameters

24+-- Derive traversal over type parameters

2525--

2626--------------------------------------------------------------------------------

2727

@@ -39,7 +39,6 @@ import GHC.Generics

3939import Data.Kind

4040import Data.Generics.Internal.VL.Iso

4141import Data.Generics.Internal.GenericN

42−import Data.Generics.Internal.Errors

4342

4443class HasParam (p :: Nat) s t a b | p t a -> s, p s b -> t, p s -> a, p t -> b where

4544 param :: Applicative g => (a -> g b) -> s -> g t

@@ -48,12 +47,6 @@ instance

4847 ( GenericN s

4948 , GenericN t

5049 -- 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)

5750 , s ~ Infer t (P n b 'PTag) a

5851 , t ~ Infer s (P n a 'PTag) b

5952 , Error ((ArgCount s) <=? n) n (ArgCount s) s

src/Data/Generics/Product/Positions.hs+25−90

@@ -19,7 +19,7 @@

1919-----------------------------------------------------------------------------

2020-- |

2121-- Module : Data.Generics.Product.Positions

2323-- License : BSD3

2424-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

2525-- Stability : experimental

@@ -35,8 +35,6 @@ module Data.Generics.Product.Positions

3535 -- $setup

3636 HasPosition (..)

3737 , HasPosition' (..)

38− , HasPosition_ (..)

39− , HasPosition0 (..)

4038

4139 , getPosition

4240 , setPosition

@@ -47,7 +45,6 @@ import Data.Generics.Internal.Void

4745import Data.Generics.Internal.Families

4846import Data.Generics.Product.Internal.Positions

4947import Data.Generics.Product.Internal.GLens

50−import Data.Generics.Internal.Errors

5148

5249import Data.Kind (Constraint, Type)

5350import Data.Type.Bool (type (&&))

@@ -96,34 +93,12 @@ class HasPosition (i :: Nat) s t a b | s i -> a, t i -> b, s i b -> t, t i a ->

9693 -- ...

9794 position :: VL.Lens s t a b

9895

99−class HasPosition_ (i :: Nat) s t a b where

100− position_ :: VL.Lens s t a b

101−

102−-- |Records that have a field at a given position.

103−--

104−-- The difference between 'HasPosition' and 'HasPosition_' is similar to the

105−-- one between 'Data.Generics.Product.Fields.HasField' and

106−-- 'Data.Generics.Product.Fields.HasField_'.

107−-- See 'Data.Generics.Product.Fields.HasField_'.

10896class HasPosition' (i :: Nat) s a | s i -> a where

10997 position' :: VL.Lens s s a a

11098

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

12199getPosition :: forall i s a. HasPosition' i s a => s -> a

122100getPosition s = s ^. position' @i

123101

124−-- |

125−-- >>> setPosition @2 60 human

126−-- Human {name = "Tunyasz", age = 60, address = "London"}

127102setPosition :: forall i s a. HasPosition' i s a => a -> s -> s

128103setPosition = VL.set (position' @i)

129104

@@ -133,35 +108,35 @@ instance

133108 , cs ~ CRep s

134109 , Coercible (Rep s) cs

135110 , GLens' (HasTotalPositionPSym i) cs a

136− , Defined (Rep s)

137− (NoGeneric s '[ 'Text "arising from a generic lens focusing on the field at"

138− , 'Text "position " ':<>: QuoteType i ':<>: 'Text " of type " ':<>: QuoteType a

139− ':<>: 'Text " in " ':<>: QuoteType s

140− ])

141− (() :: Constraint)

142111 ) => HasPosition' i s a where

143112 position' f s = VL.ravel (repLens . coerced @cs @cs . glens @(HasTotalPositionPSym i)) f s

144113 {-# INLINE position' #-}

145114

146−-- this is to 'hide' the equality constraints which interfere with inlining

147−-- pre 8.4.3

148−class (~~) (a :: k) (b :: k) | a -> b, b -> a

149−instance (a ~ b) => (~~) a b

150−

151115instance -- 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

116+ ( Generic s

117+ , ErrorUnless i s (0 <? i && i <=? Size (Rep s))

118+ , Generic t

119+ -- see Note [CPP in instance constraints]

120+#if __GLASGOW_HASKELL__ < 802

121+ , '(s', t') ~ '(Proxied s, Proxied t)

122+#else

123+ , s' ~ Proxied s

124+ , t' ~ Proxied t

125+#endif

126+ , Generic s'

127+ , Generic t'

128+ , GLens (HasTotalPositionPSym i) cs ct a b

129+ , cs ~ CRep s

130+ , ct ~ CRep t

131+ , GLens' (HasTotalPositionPSym i) (CRep s') a'

132+ , GLens' (HasTotalPositionPSym i) (CRep t') b'

133+ , t ~ Infer s a' b

134+ , s ~ Infer t b' a

135+ , Coercible cs (Rep s)

136+ , Coercible ct (Rep t)

162137 ) => HasPosition i s t a b where

163138

164− position = position0 @i

139+ position = VL.ravel (repLens . coerced @cs @ct . glens @(HasTotalPositionPSym i))

165140 {-# INLINE position #-}

166141

167142-- We wouldn't need the universal 'x' here if we could express above that

@@ -172,50 +147,10 @@ coerced :: forall s t s' t' x a b. (Coercible t t', Coercible s s')

172147coerced = coerce

173148{-# INLINE coerced #-}

174149

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

150+-- See Note [Uncluttering type signatures]

185151instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where

186152 position = undefined

187153

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−

219154type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint where

220155 ErrorUnless i s 'False

221156 = TypeError

@@ -228,5 +163,5 @@ type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint wher

228163 ErrorUnless _ _ 'True

229164 = ()

230165

231−data HasTotalPositionPSym :: Nat -> (TyFun (Type -> Type) (Maybe Type))

166+data HasTotalPositionPSym :: Nat -> (TyFun (Type -> Type) Bool)

232167type instance Eval (HasTotalPositionPSym t) tt = HasTotalPositionP t tt

src/Data/Generics/Product/Subtype.hs+3−43

@@ -1,4 +1,3 @@

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE AllowAmbiguousTypes #-}

32{-# LANGUAGE DataKinds #-}

43{-# LANGUAGE FlexibleContexts #-}

@@ -16,7 +15,7 @@

1615-----------------------------------------------------------------------------

1716-- |

1817-- Module : Data.Generics.Product.Subtype

2019-- License : BSD3

2120-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

2221-- Stability : experimental

@@ -42,7 +41,6 @@ import GHC.Generics (Generic (Rep, to, from) )

4241import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))

4342import Data.Kind (Type, Constraint)

4443import Data.Generics.Internal.Profunctor.Lens hiding (set)

45−import Data.Generics.Internal.Errors

4644

4745-- $setup

4846-- == /Running example:/

@@ -115,52 +113,14 @@ instance

115113 , Generic b

116114 , GSmash (Rep a) (Rep b)

117115 , GUpcast (Rep a) (Rep b)

118− , CustomError a b

116+ , ErrorUnless b a (CollectFieldsOrdered (Rep b) \\ CollectFieldsOrdered (Rep a))

119117 ) => Subtype b a where

120118 smash p b = to $ gsmash (from p) (from b)

121119 upcast = to . gupcast . from

122120

123−type family CustomError a b :: Constraint where

124− CustomError a b =

125− ( ErrorUnless b a (CollectFieldsOrdered (Rep b) \\ CollectFieldsOrdered (Rep a))

126− , Defined (Rep a)

127− (NoGeneric a '[ 'Text "arising from a generic lens focusing on " ':<>: QuoteType b

128− , 'Text "as a supertype of " ':<>: QuoteType a

129− ])

130− (() :: Constraint)

131− , Defined (Rep b)

132− (NoGeneric b '[ 'Text "arising from a generic lens focusing on " ':<>: QuoteType b

133− , 'Text "as a supertype of " ':<>: QuoteType a

134− ])

135− (() :: Constraint)

136− )

137−

138−instance {-# OVERLAPPING #-} Subtype a a where

139− super = id

140−

141−-- | See Note [Uncluttering type signatures]

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

121+-- See Note [Uncluttering type signatures]

151122instance {-# OVERLAPPING #-} Subtype a Void where

152123 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

164124instance {-# OVERLAPPING #-} Subtype Void a where

165125 super = undefined

166126

src/Data/Generics/Product/Typed.hs+3−24

@@ -1,4 +1,3 @@

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE AllowAmbiguousTypes #-}

32{-# LANGUAGE DataKinds #-}

43{-# LANGUAGE FlexibleContexts #-}

@@ -15,7 +14,7 @@

1514-----------------------------------------------------------------------------

1615-- |

1716-- Module : Data.Generics.Product.Typed

1918-- License : BSD3

2019-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

2120-- Stability : experimental

@@ -41,7 +40,6 @@ import Data.Kind (Constraint, Type)

4140import GHC.Generics (Generic (Rep))

4241import GHC.TypeLits (TypeError, ErrorMessage (..))

4342import Data.Generics.Internal.Profunctor.Lens

44−import Data.Generics.Internal.Errors

4543

4644-- $setup

4745-- == /Running example:/

@@ -113,31 +111,12 @@ class HasType a s where

113111instance

114112 ( Generic s

115113 , 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)

119114 , GLens (HasTotalTypePSym a) (Rep s) (Rep s) a a

120115 ) => HasType a s where

121116

122117 typed f s = VL.ravel (repLens . glens @(HasTotalTypePSym a)) f s

123118

124−instance {-# OVERLAPPING #-} HasType a a where

125− getTyped = id

126− {-# INLINE getTyped #-}

127−

128− setTyped a _ = a

129− {-# INLINE setTyped #-}

130−

131−-- | See Note [Uncluttering type signatures]

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.

119+-- See Note [Uncluttering type signatures]

141120instance {-# OVERLAPPING #-} HasType a Void where

142121 typed = undefined

143122

@@ -173,6 +152,6 @@ type family ErrorUnlessOne (a :: Type) (s :: Type) (stat :: TypeStat) :: Constra

173152 ErrorUnlessOne _ _ ('TypeStat '[] '[] _)

174153 = ()

175154

176−data HasTotalTypePSym :: Type -> (TyFun (Type -> Type) (Maybe Type))

155+data HasTotalTypePSym :: Type -> (TyFun (Type -> Type) Bool)

177156type instance Eval (HasTotalTypePSym t) tt = HasTotalTypeP t tt

178157

src/Data/Generics/Product/Types.hs+68−272

@@ -16,7 +16,7 @@

1616-----------------------------------------------------------------------------

1717-- |

1818-- Module : Data.Generics.Product.Types

2020-- License : BSD3

2121-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

2222-- Stability : experimental

@@ -29,65 +29,18 @@

2929module Data.Generics.Product.Types

3030 ( -- *Traversals

3131 --

32− -- $setup

32+ -- $example

3333 HasTypes

3434 , types

35−

36− -- * Custom traversal strategies

37− -- $custom

38− , Children

39− , ChGeneric

40−

41− , HasTypesUsing

42− , typesUsing

43−

44− , HasTypesCustom (typesCustom)

45−

4635 ) where

4736

4837import 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

5238

5339import GHC.Generics

54−import GHC.TypeLits

5540import Data.Generics.Internal.VL.Traversal

56−import Data.Generics.Internal.Errors

57−

58−-- $setup

59−-- == /Running example:/

60−--

61−-- >>> :set -XTypeApplications

62−-- >>> :set -XDeriveGeneric

63−-- >>> :set -XScopedTypeVariables

64−-- >>> import GHC.Generics

65−-- >>> :m +Data.Generics.Internal.VL.Traversal

66−-- >>> :m +Data.Generics.Internal.VL.Lens

67−-- >>> :{

68−-- data WTree a w

69−-- = Leaf a

70−-- | Fork (WTree a w) (WTree a w)

71−-- | WithWeight (WTree a w) w

72−-- deriving (Generic, Show)

73−-- :}

74−

75−--------------------------------------------------------------------------------

76−-- HasTypes

77−--------------------------------------------------------------------------------

7841

7942-- TODO [1.0.0.0]: use type-changing variant internally

8043

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.

9144types :: forall a s. HasTypes s a => Traversal' s a

9245types = types_ @s @a

9346{-# INLINE types #-}

@@ -100,268 +53,111 @@ class HasTypes s a where

10053 {-# INLINE types_ #-}

10154

10255instance

103− ( HasTypesUsing ChGeneric s a

56+ ( HasTypes' (Interesting s a) s a

10457 ) => HasTypes s a where

105− types_ = typesUsing_ @ChGeneric

58+ types_ = types' @(Interesting s a)

10659 {-# INLINE types_ #-}

10760

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

61+class HasTypes' (t :: Bool) s a where

62+ types' :: Traversal' s a

11863

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

64+instance

65+ ( GHasTypes (Rep s) a

21166 , 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)

67+ ) => HasTypes' 'True s a where

68+ types' f s = to <$> gtypes_ f (from s)

22169 --{-# INLINE types' #-}

22270

71+instance HasTypes' 'False s a where

72+ types' _ = pure

73+ --{-# INLINE types' #-}

22374

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 #-}

75+instance {-# OVERLAPPING #-} HasTypes Bool a

76+instance {-# OVERLAPPING #-} HasTypes Char a

77+instance {-# OVERLAPPING #-} HasTypes Double a

78+instance {-# OVERLAPPING #-} HasTypes Float a

79+instance {-# OVERLAPPING #-} HasTypes Int a

80+instance {-# OVERLAPPING #-} HasTypes Integer a

81+instance {-# OVERLAPPING #-} HasTypes Ordering a

27582

27683--------------------------------------------------------------------------------

27784

278−class GHasTypes ch s a where

85+class GHasTypes s a where

27986 gtypes_ :: Traversal' (s x) a

28087

28188instance

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

89+ ( GHasTypes l a

90+ , GHasTypes r a

91+ ) => GHasTypes (l :*: r) a where

92+ gtypes_ f (l :*: r) = (:*:) <$> gtypes_ f l <*> gtypes_ f r

28693 {-# INLINE gtypes_ #-}

28794

28895instance

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

96+ ( GHasTypes l a

97+ , GHasTypes r a

98+ ) => GHasTypes (l :+: r) a where

99+ gtypes_ f (L1 l) = L1 <$> gtypes_ f l

100+ gtypes_ f (R1 r) = R1 <$> gtypes_ f r

294101 {-# INLINE gtypes_ #-}

295102

296−instance (GHasTypes ch s a) => GHasTypes ch (M1 m meta s) a where

297− gtypes_ f (M1 s) = M1 <$> gtypes_ @ch f s

103+instance (GHasTypes s a) => GHasTypes (M1 m meta s) a where

104+ gtypes_ f (M1 s) = M1 <$> gtypes_ f s

298105 {-# INLINE gtypes_ #-}

299106

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

107+instance {-# OVERLAPPING #-} GHasTypes (Rec0 a) a where

108+ gtypes_ f (K1 x) = K1 <$> f x

304109 {-# INLINE gtypes_ #-}

305110

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

111+instance HasTypes b a => GHasTypes (Rec0 b) a where

112+ gtypes_ f (K1 x) = K1 <$> types_ @_ @a f x

314113 {-# INLINE gtypes_ #-}

315114

316−instance GHasTypes ch U1 a where

115+instance GHasTypes U1 a where

317116 gtypes_ _ _ = pure U1

318117 {-# INLINE gtypes_ #-}

319118

320−instance GHasTypes ch V1 a where

119+instance GHasTypes V1 a where

321120 gtypes_ _ = pure

322121 {-# INLINE gtypes_ #-}

323122

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

123+type Interesting f a = Snd (Interesting' (Rep f) a '[f])

124+

125+type family Interesting' f (a :: Type) (seen :: [Type]) :: ([Type], Bool) where

126+ Interesting' (M1 _ m f) t seen

127+ = Interesting' f t seen

128+ -- The result of the left branch is passed on to the right branch in order to avoid duplicate work

129+ Interesting' (l :*: r) t seen

130+ = InterestingOr (Interesting' l t seen) r t

131+ Interesting' (l :+: r) t seen

132+ = InterestingOr (Interesting' l t seen) r t

133+ Interesting' (Rec0 t) t seen

134+ = '(seen, 'True)

135+ Interesting' (Rec0 Char) _ seen = '(seen ,'False)

136+ Interesting' (Rec0 Double) _ seen = '(seen ,'False)

137+ Interesting' (Rec0 Float) _ seen = '(seen ,'False)

138+ Interesting' (Rec0 Int) _ seen = '(seen ,'False)

139+ Interesting' (Rec0 Integer) _ seen = '(seen ,'False)

140+ Interesting' (Rec0 r) t seen

141+ = InterestingUnless (Elem r seen) (Rep r) t r seen

142+ Interesting' _ _ seen

143+ = '(seen, 'False)

340144

341145-- 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))

146+-- Note: we only insert 'r' to the seen list if it's not already there (which is precisely when `s` is 'False)

147+type family InterestingUnless (s :: Bool) f (a :: Type) (r :: Type) (seen :: [Type]) :: ([Type], Bool) where

148+ InterestingUnless 'True _ _ _ seen = '(seen, 'False)

149+ InterestingUnless 'False f a r seen = Interesting' f a (r ': seen)

351150

352151-- 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

152+type family InterestingOr (b :: ([Type], Bool)) r t :: ([Type], Bool) where

153+ InterestingOr '(seen, 'True) _ _ = '(seen, 'True)

154+ InterestingOr '(seen, 'False) r t = Interesting' r t seen

358155

359156type family Elem a as where

360157 Elem a (a ': _) = 'True

361158 Elem a (_ ': as) = Elem a as

362159 Elem a '[] = 'False

363160

364−type family IsNothing a where

365− IsNothing ('Just _) = 'False

366− IsNothing 'Nothing = 'True

161+type family Snd a where

162+ Snd '(_, b) = b

367163

src/Data/Generics/Sum.hs+1−1

@@ -1,7 +1,7 @@

11-----------------------------------------------------------------------------

22-- |

33-- Module : Data.Generics.Sum

55-- License : BSD3

66-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

77-- Stability : experimental

src/Data/Generics/Sum/Any.hs+2−2

@@ -11,7 +11,7 @@

1111-----------------------------------------------------------------------------

1212-- |

1313-- Module : Data.Generics.Sum.Any

1515-- License : BSD3

1616-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

1717-- Stability : experimental

@@ -61,7 +61,7 @@ import Data.Generics.Internal.VL.Prism

6161-- :}

6262

6363-- |Sums that have generic prisms.

64−class AsAny sel a s | s sel -> a where

64+class AsAny (sel :: k) a s | s sel k -> a where

6565 -- |A prism that projects a sum as identified by some selector. Currently

6666 -- supported selectors are constructor names and unique types. Compatible

6767 -- with the lens package's 'Control.Lens.Prism' type.

src/Data/Generics/Sum/Constructors.hs+19−76

@@ -15,7 +15,7 @@

1515-----------------------------------------------------------------------------

1616-- |

1717-- Module : Data.Generics.Sum.Constructors

1919-- License : BSD3

2020-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

2121-- Stability : experimental

@@ -30,9 +30,7 @@ module Data.Generics.Sum.Constructors

3030

3131 -- $setup

3232 AsConstructor (..)

33− , AsConstructor_ (..)

3433 , AsConstructor' (..)

35− , AsConstructor0 (..)

3634 ) where

3735

3836import Data.Generics.Internal.Families

@@ -45,7 +43,6 @@ import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))

4543import Data.Generics.Internal.VL.Prism

4644import Data.Generics.Internal.Profunctor.Iso

4745import Data.Generics.Internal.Profunctor.Prism (prismPRavel)

48−import Data.Generics.Internal.Errors

4946

5047-- $setup

5148-- == /Running example:/

@@ -71,7 +68,7 @@ import Data.Generics.Internal.Errors

7168-- , age :: Age

7269-- , fieldA :: a

7370-- }

74−-- deriving Show

71+-- deriving (Generic, Show)

7572-- type Name = String

7673-- type Age = Int

7774-- dog, cat, duck :: Animal Int

@@ -106,99 +103,45 @@ class AsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where

106103 -- ...

107104 _Ctor :: Prism s t a b

108105

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−

118106class AsConstructor' (ctor :: Symbol) s a | ctor s -> a where

119107 _Ctor' :: Prism s s a a

120108

121−-- |Sums that have a constructor with a given name.

122−--

123−-- This class gives the minimal constraints needed to define this prism.

124−-- For common uses, see 'HasConstructor'.

125−class AsConstructor0 (ctor :: Symbol) s t a b where

126− _Ctor0 :: Prism s t a b

127−

128109instance

129110 ( Generic s

130111 , ErrorUnless ctor s (HasCtorP ctor (Rep s))

131112 , 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)

137113 ) => AsConstructor' ctor s a where

138114 _Ctor' eta = prismRavel (prismPRavel (repIso . _GCtor @ctor)) eta

139115 {-# INLINE[2] _Ctor' #-}

140116

141117instance

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+ ( Generic s

119+ , ErrorUnless ctor s (HasCtorP ctor (Rep s))

120+ , Generic t

121+ -- see Note [CPP in instance constraints]

122+#if __GLASGOW_HASKELL__ < 802

123+ , '(s', t') ~ '(Proxied s, Proxied t)

124+#else

125+ , s' ~ Proxied s

126+ , t' ~ Proxied t

127+#endif

128+ , Generic s'

129+ , Generic t'

130+ , GAsConstructor' ctor (Rep s) a

131+ , GAsConstructor' ctor (Rep s') a'

145132 , GAsConstructor ctor (Rep s) (Rep t) a b

146133 , t ~ Infer s a' b

147− , GAsConstructor' ctor (Rep (Indexed t)) b'

134+ , GAsConstructor' ctor (Rep t') b'

148135 , s ~ Infer t b' a

149− , AsConstructor0 ctor s t a b

150136 ) => AsConstructor ctor s t a b where

151137

152− _Ctor = _Ctor0 @ctor

138+ _Ctor eta = prismRavel (prismPRavel (repIso . _GCtor @ctor)) eta

153139 {-# INLINE[2] _Ctor #-}

154140

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

141+-- See Note [Uncluttering type signatures]

169142instance {-# OVERLAPPING #-} AsConstructor ctor (Void1 a) (Void1 b) a b where

170143 _Ctor = undefined

171144

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−

202145type family ErrorUnless (ctor :: Symbol) (s :: Type) (contains :: Bool) :: Constraint where

203146 ErrorUnless ctor s 'False

204147 = TypeError

src/Data/Generics/Sum/Internal/Constructors.hs+3−3

@@ -14,7 +14,7 @@

1414-----------------------------------------------------------------------------

1515-- |

1616-- Module : Data.Generics.Sum.Internal.Constructors

1818-- License : BSD3

1919-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

2020-- Stability : experimental

@@ -31,7 +31,6 @@ module Data.Generics.Sum.Internal.Constructors

3131

3232import Data.Generics.Internal.Families

3333import Data.Generics.Product.Internal.HList

34−import Data.Profunctor (Profunctor(..))

3534

3635import GHC.Generics

3736import GHC.TypeLits (Symbol)

@@ -53,9 +52,10 @@ instance

5352 , ListTuple b bs

5453 ) => GAsConstructor ctor (M1 C ('MetaCons ctor fixity fields) f) (M1 C ('MetaCons ctor fixity fields) g) a b where

5554

56− _GCtor = dimap (listToTuple . view glist . unM1) (M1 . view (fromIso glist) . tupleToList)

55+ _GCtor = prism (M1 . view (fromIso glist) . tupleToList) (Right . listToTuple . view glist . unM1)

5756 {-# INLINE[0] _GCtor #-}

5857

58+

5959instance GSumAsConstructor ctor (HasCtorP ctor l) l r l' r' a b => GAsConstructor ctor (l :+: r) (l' :+: r') a b where

6060 _GCtor = _GSumCtor @ctor @(HasCtorP ctor l)

6161 {-# INLINE[0] _GCtor #-}

src/Data/Generics/Sum/Internal/Subtype.hs+1−1

@@ -14,7 +14,7 @@

1414-----------------------------------------------------------------------------

1515-- |

1616-- Module : Data.Generics.Sum.Internal.Subtype

1818-- License : BSD3

1919-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

2020-- Stability : experimental

src/Data/Generics/Sum/Internal/Typed.hs+1−1

@@ -13,7 +13,7 @@

1313-----------------------------------------------------------------------------

1414-- |

1515-- Module : Data.Generics.Sum.Internal.Typed

1717-- License : BSD3

1818-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

1919-- Stability : experimental

src/Data/Generics/Sum/Subtype.hs+2−38

@@ -1,4 +1,3 @@

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE FlexibleContexts #-}

32{-# LANGUAGE FlexibleInstances #-}

43{-# LANGUAGE MonoLocalBinds #-}

@@ -12,7 +11,7 @@

1211-----------------------------------------------------------------------------

1312-- |

1413-- Module : Data.Generics.Sum.Subtype

1615-- License : BSD3

1716-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

1817-- Stability : experimental

@@ -114,45 +113,10 @@ instance

114113 _Sub f = prismRavel (repIso . _GSub . fromIso repIso) f

115114 {-# INLINE[2] _Sub #-}

116115

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

116+-- See Note [Uncluttering type signatures]

138117instance {-# OVERLAPPING #-} AsSubtype a Void where

139118 injectSub = undefined

140119 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

156120instance {-# OVERLAPPING #-} AsSubtype Void a where

157121 injectSub = undefined

158122 projectSub = undefined

src/Data/Generics/Sum/Typed.hs+2−33

@@ -1,4 +1,3 @@

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE TypeApplications #-}

32{-# LANGUAGE AllowAmbiguousTypes #-}

43{-# LANGUAGE DataKinds #-}

@@ -14,7 +13,7 @@

1413-----------------------------------------------------------------------------

1514-- |

1615-- Module : Data.Generics.Sum.Typed

1817-- License : BSD3

1918-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

2019-- Stability : experimental

@@ -35,7 +34,6 @@ import Data.Kind

3534import GHC.Generics

3635import GHC.TypeLits (TypeError, ErrorMessage (..), Symbol)

3736import Data.Generics.Sum.Internal.Typed

38−import Data.Generics.Internal.Errors

3937

4038import Data.Generics.Internal.Families

4139import Data.Generics.Internal.Void

@@ -111,45 +109,16 @@ instance

111109 , as ~ TupleToList a

112110 , ListTuple a as

113111 , 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)

117112 ) => AsType a s where

118113

119114 _Typed eta = prismRavel (prismPRavel (repIso . _GTyped @_ @as . tupled)) eta

120115 {-# INLINE[2] _Typed #-}

121116

122−-- | See Note [Uncluttering type signatures]

123−#if __GLASGOW_HASKELL__ < 804

124−-- >>> :t _Typed

125−-- _Typed

126−-- :: (Applicative f, Data.Profunctor.Choice.Choice p, AsType a s) =>

127−-- p a (f a) -> p s (f s)

128−#else

129−-- >>> :t _Typed

130−-- _Typed

131−-- :: (AsType a s, Data.Profunctor.Choice.Choice p, Applicative f) =>

132−-- p a (f a) -> p s (f s)

133−#endif

117+-- See Note [Uncluttering type signatures]

134118instance {-# OVERLAPPING #-} AsType a Void where

135119 _Typed = undefined

136120 injectTyped = undefined

137121 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

153122instance {-# OVERLAPPING #-} AsType Void a where

154123 _Typed = undefined

155124 injectTyped = undefined

src/Data/Generics/Wrapped.hsdeleted−104

@@ -1,104 +0,0 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE TypeApplications #-}

3−{-# language ConstraintKinds #-}

4−{-# language DataKinds #-}

5−{-# language FlexibleContexts #-}

6−{-# language FlexibleInstances #-}

7−{-# language FunctionalDependencies #-}

8−{-# language MultiParamTypeClasses #-}

9−{-# language ScopedTypeVariables #-}

10−{-# language TypeFamilies #-}

11−{-# language TypeOperators #-}

12−{-# language UndecidableInstances #-}

13−

14−-----------------------------------------------------------------------------

15−-- |

16−-- Module : Data.Generics.Wrapped

18−-- License : BSD3

19−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

20−-- Stability : experimental

21−-- Portability : non-portable

22−--

23−-- Derive an isomorphism between a newtype and its wrapped type.

24−--

25−-----------------------------------------------------------------------------

26−

27−module Data.Generics.Wrapped

28− ( Wrapped (..)

29− , wrappedTo

30− , wrappedFrom

31− , _Unwrapped

32− , _Wrapped

33− )

34−where

35−

36−import Control.Applicative (Const(..))

37−import Data.Generics.Internal.Profunctor.Iso

38−

39−import qualified Data.Generics.Internal.VL.Iso as VL

40−import Data.Generics.Internal.Families.Changing ( UnifyHead )

41−

42−import Data.Kind (Constraint)

43−import GHC.Generics

44−import GHC.TypeLits

45−

46−type family ErrorUnlessOnlyOne a b :: Constraint where

47− ErrorUnlessOnlyOne t (M1 i k a) = ErrorUnlessOnlyOne t a

48− ErrorUnlessOnlyOne t (K1 i a) = ()

49− ErrorUnlessOnlyOne t a =

50− TypeError ('ShowType t ':<>: 'Text " is not a single-constructor, single-field datatype")

51−

52−-- | @since 1.1.0.0

53−_Unwrapped :: Wrapped s t a b => VL.Iso s t a b

54−_Unwrapped = wrappedIso

55−{-# inline _Unwrapped #-}

56−

57−-- | @since 1.1.0.0

58−_Wrapped :: Wrapped s t a b => VL.Iso b a t s

59−_Wrapped = VL.fromIso wrappedIso

60−{-# inline _Wrapped #-}

61−

62−-- TODO: move this into doctets

63−

64−-- newtype FlippedEither a b = FlippedEither (Either b a)

65−-- deriving Generic

66−

67−-- test :: (a -> c) -> FlippedEither a b -> FlippedEither c b

68−-- test f = over wrappedIso (fmap f)

69−

70−class GWrapped s t a b | s -> a, t -> b, s b -> t, t a -> s where

71− gWrapped :: Iso (s x) (t x) a b

72−

73−instance GWrapped s t a b => GWrapped (M1 i k s) (M1 i k t) a b where

74− gWrapped = mIso . gWrapped

75−

76−instance (a ~ c, b ~ d) => GWrapped (K1 i a) (K1 i b) c d where

77− gWrapped = kIso

78−

79−-- | @since 1.1.0.0

80−class Wrapped s t a b | s -> a, t -> b where

81− -- | @since 1.1.0.0

82− wrappedIso :: VL.Iso s t a b

83−

84−-- | @since 1.1.0.0

85−wrappedTo :: forall s t a b. Wrapped s t a b => s -> a

86−wrappedTo a = view (wrappedIso @s @t @a @b) a

87− where view l s = getConst (l Const s)

88−{-# INLINE wrappedTo #-}

89−

90−-- | @since 1.1.0.0

91−wrappedFrom :: forall s t a b. Wrapped s t a b => b -> t

92−wrappedFrom a = view (VL.fromIso (wrappedIso @s @t @a @b)) a

93− where view l s = getConst (l Const s)

94−{-# INLINE wrappedFrom #-}

95−

96−instance

97− ( Generic s

98− , Generic t

99− , GWrapped (Rep s) (Rep t) a b

100− , UnifyHead s t

101− , UnifyHead t s

102− ) => Wrapped s t a b where

103− wrappedIso = iso2isovl (repIso . gWrapped)

104− {-# INLINE wrappedIso #-}

test/CustomChildren.hsdeleted−63

@@ -1,63 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE FlexibleInstances #-}

4−{-# LANGUAGE KindSignatures #-}

5−{-# LANGUAGE MultiParamTypeClasses #-}

6−{-# LANGUAGE TypeApplications #-}

7−{-# LANGUAGE TypeFamilies #-}

8−{-# LANGUAGE UndecidableInstances #-}

9−

10−module CustomChildren

11− ( customTypesTest

12− ) where

13−

14−import GHC.Generics

15−import Data.Generics.Product

16−import Test.HUnit

17−import Data.Generics.Internal.VL.Lens

18−import Data.Generics.Labels ()

19−import Data.Kind

20−

21−-- Opaque has no Generic instance

22−data Opaque = Opaque String

23− deriving (Show, Eq)

24−

25−-- Hide does have a Generic instance, but we want to hide its contents

26−-- from the traversal

27−data Hide = Hide String

28− deriving (Show, Generic, Eq)

29−

30−-- We first define a symbol for the custom traversal

31−data Custom

32−

33−type instance Children Custom a = ChildrenCustom a

34−

35−type family ChildrenCustom (a :: Type) where

36− ChildrenCustom Opaque = '[String] -- here we state explicitly that Opaque contains a String

37− ChildrenCustom Hide = '[] -- and hide the contents of Hide

38− ChildrenCustom a = Children ChGeneric a -- for the rest, we defer to the generic children

39−

40−-- We define the traversal of Opaque like so:

41−instance HasTypesCustom Custom Opaque String where

42− typesCustom f (Opaque str) = Opaque <$> f str

43−

44−customTypesTest1 :: Test

45−customTypesTest1

46− = TestCase (assertEqual "foo" (over (typesUsing @Custom @String) (++ "!") original) expected)

47− where original = (Opaque "foo", Hide "bar")

48− expected = (Opaque "foo!", Hide "bar") -- only Opaque's String gets modified

49−

50−customTypesTest2 :: Test

51−customTypesTest2

52− = TestCase (assertEqual "foo" (over (typesUsing @Custom @String) (++ "!") original) expected)

53− where original = Opaque "foo"

54− expected = Opaque "foo!"

55−

56−customTypesTest3 :: Test

57−customTypesTest3

58− = TestCase (assertEqual "foo" (over (typesUsing @Custom @String) (++ "!") original) expected)

59− where original = Hide "foo"

60− expected = Hide "foo"

61−

62−customTypesTest :: Test

63−customTypesTest = TestList [customTypesTest1, customTypesTest2, customTypesTest3]

test/Spec.hs+2−38

@@ -2,7 +2,6 @@

22{-# OPTIONS_GHC -dsuppress-all #-}

44{-# LANGUAGE AllowAmbiguousTypes #-}

5−{-# LANGUAGE CPP #-}

65{-# LANGUAGE DataKinds #-}

76{-# LANGUAGE DeriveGeneric #-}

87{-# LANGUAGE DuplicateRecordFields #-}

@@ -11,7 +10,6 @@

1110{-# LANGUAGE ScopedTypeVariables #-}

1211{-# LANGUAGE TypeApplications #-}

1312{-# LANGUAGE TemplateHaskell #-}

14−{-# LANGUAGE OverloadedLabels #-}

1513

1614module Main where

1715

@@ -25,16 +23,11 @@ import System.Exit

2523import Data.Generics.Internal.VL.Lens

2624import Data.Generics.Internal.VL.Prism

2725import Data.Generics.Internal.VL.Traversal

28−import Control.Lens (_1, (+~))

29−import Data.Function ((&))

30−import Data.Generics.Labels ()

3126

3227-- This is sufficient at we only want to test that they typecheck

3328import Test24 ()

3429import Test25 ()

3530

36−import CustomChildren (customTypesTest)

37−

3831main :: IO ()

3932main = do

4033 res <- runTestTT tests

@@ -185,32 +178,23 @@ subtypePrismManual eta = prism g f eta

185178fieldALensName :: Lens' Record Int

186179fieldALensName = field @"fieldA"

187180

188−fieldALensName_ :: Lens' Record Int

189−fieldALensName_ = field_ @"fieldA"

190−

191181fieldALensType :: Lens' Record Int

192182fieldALensType = typed @Int

193183

194184fieldALensPos :: Lens' Record Int

195185fieldALensPos = position @1

196186

197−fieldALensPos_ :: Lens' Record Int

198−fieldALensPos_ = position_ @1

199−

200187subtypeLensGeneric :: Lens' Record Record2

201188subtypeLensGeneric = super

202189

203190typeChangingGeneric :: Lens (Record3 a) (Record3 b) a b

204−typeChangingGeneric = #fieldA

191+typeChangingGeneric = field @"fieldA"

205192

206193typeChangingGenericPos :: Lens (Record3 a) (Record3 b) a b

207194typeChangingGenericPos = position @1

208195

209196typeChangingGenericCompose :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b

210−typeChangingGenericCompose = #fieldA . #fieldA

211−

212−typeChangingGenericCompose_ :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b

213−typeChangingGenericCompose_ = field_ @"fieldA" . field_ @"fieldA"

197+typeChangingGenericCompose = field @"fieldA" . field @"fieldA"

214198

215199sum1PrismB :: Prism Sum1 Sum1 Int Int

216200sum1PrismB = _Ctor @"B"

@@ -230,24 +214,15 @@ sum2TypePrism = _Typed @Int

230214sum2TypePrismChar :: Prism Sum2 Sum2 Char Char

231215sum2TypePrismChar = _Typed @Char

232216

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−

239217tests :: Test

240218tests = TestList $ map mkHUnitTest

241219 [ $(inspectTest $ 'fieldALensManual === 'fieldALensName)

242− , $(inspectTest $ 'fieldALensManual === 'fieldALensName_)

243220 , $(inspectTest $ 'fieldALensManual === 'fieldALensType)

244221 , $(inspectTest $ 'fieldALensManual === 'fieldALensPos)

245− , $(inspectTest $ 'fieldALensManual === 'fieldALensPos_)

246222 , $(inspectTest $ 'subtypeLensManual === 'subtypeLensGeneric)

247223 , $(inspectTest $ 'typeChangingManual === 'typeChangingGeneric)

248224 , $(inspectTest $ 'typeChangingManual === 'typeChangingGenericPos)

249225 , $(inspectTest $ 'typeChangingManualCompose === 'typeChangingGenericCompose)

250− , $(inspectTest $ 'typeChangingManualCompose === 'typeChangingGenericCompose_)

251226 , $(inspectTest $ 'sum1PrismManual === 'sum1PrismB)

252227 , $(inspectTest $ 'subtypePrismManual === 'subtypePrismGeneric)

253228 , $(inspectTest $ 'sum2PrismManualChar === 'sum2TypePrismChar)

@@ -260,17 +235,6 @@ tests = TestList $ map mkHUnitTest

260235 -- TODO [1.0.0.0]: these tests pass with the new implementation

261236-- , $(inspectTest $ 'sum3Param1Manual === 'sum3Param1Derived)

262237-- , $(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

273238 ]

274− where valLabel = RecB 3 True

275239

276240-- TODO: add test for traversals over multiple types

test/Test62.hsdeleted−20

@@ -1,20 +0,0 @@

1−{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications #-}

2−module Test62 (example, example_) where

3−import Data.Generics.Product (field, field_, position, position_)

4−import Data.Generics.Internal.VL.Lens (set)

5−import GHC.Generics (Generic)

6−

7−data Foo a = Foo { bar :: Bar a } deriving Generic

8−data Bar a = Bar { x :: a, y :: a } deriving Generic

9−

10−example :: Foo ()

11−example =

12− set (field @"bar" . position @1) ()

13− . set (position @1 . field @"y") ()

14− $ Foo{ bar = Bar{ x = (), y = () } }

15−

16−example_ :: Foo ()

17−example_ =

18− set (field_ @"bar" . position_ @1) ()

19− . set (position_ @1 . field_ @"y") ()

20− $ Foo{ bar = Bar{ x = (), y = () } }

test/Test63.hsdeleted−12

@@ -1,12 +0,0 @@

1−{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications #-}

2−module Test63 (example) where

3−import Data.Generics.Product (types)

4−import Data.Generics.Internal.VL.Lens (over)

5−import Data.Word (Word32)

6−import GHC.Generics (Generic)

7−

8−data Record = Record {field1 :: Word32, field2 :: Int}

9− deriving (Generic, Show)

10−

11−example :: Record

12−example = over (types @Int) (+1) (Record 0 0)

test/Test71.hsdeleted−17

@@ -1,17 +0,0 @@

1−{-# LANGUAGE FlexibleContexts, DeriveGeneric, TypeApplications #-}

2−

3−module Test71 where

4−

5−import GHC.Generics

6−import Control.Lens

7−import Data.Generics.Product

8−

9−data Foobar = Foobar Int Char String

10− deriving Generic

11−

12−foo :: HasType Foobar ctx => ctx -> Char

13−foo ctx = case view (typed @Foobar) ctx of

14− Foobar _ c _ -> c

15−

16−bar :: Char

17−bar = foo (Foobar 3 'a' "Hello")

test/doctest.hs−1

@@ -4,5 +4,4 @@ main

44 [ "-isrc"

55 , "src/Data/Generics/Product.hs"

66 , "src/Data/Generics/Sum.hs"

7− , "src/Data/Generics/Labels.hs"

87 ]