on master help sign in
.github/FUNDING.ymlnew file+12
since splitsnapshots
unifiedsplit
@@ -0,0 +1,12 @@
1+# These are supported funding model platforms
2+
3+github: [kcsongor] # Replace with up to 4 GitHub Sponsors-enabled usernames e.g., [user1, user2]
4+patreon: # Replace with a single Patreon username
5+open_collective: # Replace with a single Open Collective username
6+ko_fi: # Replace with a single Ko-fi username
7+tidelift: # Replace with a single Tidelift platform-name/package-name e.g., npm/babel
8+community_bridge: # Replace with a single Community Bridge project-name e.g., cloud-foundry
9+liberapay: # Replace with a single Liberapay username
10+issuehunt: # Replace with a single IssueHunt username
11+otechie: # Replace with a single Otechie username
12+custom: # Replace with up to 4 custom sponsorship URLs e.g., ['link1', 'link2']
.travis.yml+132−72
@@ -1,95 +1,155 @@
1# This Travis job script has been generated by a script via
1# This Travis job script has been generated by a script via
2#
2#
3−# make_travis_yml_2.hs 'generic-lens.cabal'
3+# haskell-ci '--config=cabal.haskell-ci' 'cabal.project'
4#
4#
5−# For more information, see https://github.com/hvr/multi-ghc-travis
5+# For more information, see https://github.com/haskell-CI/haskell-ci
6+#
7+# version: 0.5.20190908
6#
8#
7language: c
9language: c
8−sudo: false
10+dist: xenial
9−
10git:
11git:
11− submodules: false # whether to recursively clone submodules
12+ # whether to recursively clone submodules
12−
13+ submodules: false
13cache:
14cache:
14 directories:
15 directories:
15 - $HOME/.cabal/packages
16 - $HOME/.cabal/packages
16 - $HOME/.cabal/store
17 - $HOME/.cabal/store
17−
18before_cache:
18before_cache:
19− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
19+ - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log
20 # remove files that are regenerated by 'cabal update'
20 # remove files that are regenerated by 'cabal update'
21− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*
21+ - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*
22− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json
22+ - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json
23− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache
23+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache
24− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar
24+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar
25− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx
25+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx
26−
26+ - rm -rfv $CABALHOME/packages/head.hackage
27matrix:
27matrix:
28 include:
28 include:
29− - compiler: "ghc-8.0.2"
29+ - compiler: ghc-8.8.1
30− # env: TEST=--disable-tests BENCH=--disable-benchmarks
31− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.2], sources: [hvr-ghc]}}
30+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}}
31+ - compiler: ghc-8.6.5
32+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-3.0"]}}
32− - compiler: "ghc-8.2.1"
33+ - compiler: ghc-8.4.4
33− # env: TEST=--disable-tests BENCH=--disable-benchmarks
34− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.1], sources: [hvr-ghc]}}
34+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-3.0"]}}
35+ - compiler: ghc-8.4.1
36+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.1","cabal-install-3.0"]}}
35− - compiler: "ghc-8.2.2"
37+ - compiler: ghc-8.2.2
36− # env: TEST=--disable-tests BENCH=--disable-benchmarks
38+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-3.0"]}}
37− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.2], sources: [hvr-ghc]}}
38− - compiler: "ghc-8.4.1"
39+ - compiler: ghc-8.0.2
39− # env: TEST=--disable-tests BENCH=--disable-benchmarks
40− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.4.1], sources: [hvr-ghc]}}
40+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-3.0"]}}
41−
42before_install:
41before_install:
43− - HC=${CC}
42+ - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')
43+ - WITHCOMPILER="-w $HC"
44+ - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//')
44− - HCPKG=${HC/ghc/ghc-pkg}
45+ - HCPKG="$HC-pkg"
45 - unset CC
46 - unset CC
46− - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH
47+ - CABAL=/opt/ghc/bin/cabal
47−
48+ - CABALHOME=$HOME/.cabal
49+ - export PATH="$CABALHOME/bin:$PATH"
50+ - TOP=$(pwd)
51+ - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')"
52+ - echo $HCNUMVER
53+ - CABAL="$CABAL -vnormal+nowrap+markoutput"
54+ - set -o pipefail
55+ - |
56+ echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk
57+ echo 'BEGIN { state = "output"; }' >> .colorful.awk
58+ echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk
59+ echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk
60+ echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk
61+ echo ' if (state == "cabal") {' >> .colorful.awk
62+ echo ' print blue($0)' >> .colorful.awk
63+ echo ' } else {' >> .colorful.awk
64+ echo ' print $0' >> .colorful.awk
65+ echo ' }' >> .colorful.awk
66+ echo '}' >> .colorful.awk
67+ - cat .colorful.awk
68+ - |
69+ color_cabal_output () {
70+ awk -f $TOP/.colorful.awk
71+ }
72+ - echo text | color_cabal_output
48install:
73install:
49− - cabal --version
74+ - ${CABAL} --version
50 - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
75 - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
76+ - TEST=--enable-tests
77+ - if [ $HCNUMVER -ge 80600 ] ; then TEST=--disable-tests ; fi
51− - BENCH=${BENCH---enable-benchmarks}
78+ - BENCH=--enable-benchmarks
52− - TEST=${TEST---enable-tests}
79+ - if [ $HCNUMVER -ge 80800 ] ; then BENCH=--disable-benchmarks ; fi
53− - HADDOCK=${HADDOCK-true}
80+ - HEADHACKAGE=false
54− - INSTALLED=${INSTALLED-true}
81+ - rm -f $CABALHOME/config
82+ - |
83+ echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config
84+ echo "remote-build-reporting: anonymous" >> $CABALHOME/config
85+ echo "write-ghc-environment-files: always" >> $CABALHOME/config
86+ echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config
87+ echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config
88+ echo "world-file: $CABALHOME/world" >> $CABALHOME/config
89+ echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config
90+ echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config
91+ echo "installdir: $CABALHOME/bin" >> $CABALHOME/config
92+ echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config
93+ echo "store-dir: $CABALHOME/store" >> $CABALHOME/config
94+ echo "install-dirs user" >> $CABALHOME/config
95+ echo " prefix: $CABALHOME" >> $CABALHOME/config
96+ echo "repository hackage.haskell.org" >> $CABALHOME/config
97+ echo " url: http://hackage.haskell.org/" >> $CABALHOME/config
98+ - |
99+ echo "program-default-options" >> $CABALHOME/config
100+ echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config
101+ - cat $CABALHOME/config
102+ - rm -fv cabal.project cabal.project.local cabal.project.freeze
55− - travis_retry cabal update -v
103+ - travis_retry ${CABAL} v2-update -v
56− - sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
104+ # Generate cabal.project
105+ - rm -rf cabal.project cabal.project.local cabal.project.freeze
106+ - touch cabal.project
107+ - |
57− - rm -fv cabal.project.local
108+ echo "packages: ." >> cabal.project
58− - "echo 'packages: .' > cabal.project"
109+ - |
110+ - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(generic-lens)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
111+ - cat cabal.project || true
112+ - cat cabal.project.local || true
59− - if [ -f "./configure.ac" ]; then
113+ - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi
60− (cd "."; autoreconf -i);
114+ - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output
61− fi
115+ - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"
62− - rm -f cabal.project.freeze
116+ - rm cabal.project.freeze
63− - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all
117+ - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all | color_cabal_output
64− - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all
118+ - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all | color_cabal_output
65− - rm -rf "."/.ghc.environment.* "."/dist
66− - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
67−
68−# Here starts the actual work to be performed for the package under test;
69−# any command which exits with a non-zero exit code causes the build to fail.
70script:
119script:
71− # test that source-distributions can be generated
120+ - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
72− - (cd "."; cabal sdist)
121+ # Packaging...
122+ - ${CABAL} v2-sdist all | color_cabal_output
123+ # Unpacking...
73− - mv "."/dist/generic-lens-*.tar.gz ${DISTDIR}/
124+ - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
74− - cd ${DISTDIR}
125+ - cd ${DISTDIR} || false
75− - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;
126+ - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \;
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+ - |
76− - "echo 'packages: generic-lens-*/*.cabal' > cabal.project"
133+ echo "packages: ${PKGDIR_generic_lens}" >> cabal.project
77− - "echo 'write-ghc-environment-files: always' >> 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...
78 # this builds all libraries and executables (without tests/benchmarks)
139 # this builds all libraries and executables (without tests/benchmarks)
79− - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all
140+ - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output
80−
141+ # Building with tests and benchmarks...
81− # Build with installed constraints for packages in global-db
82− - if $INSTALLED; then
83− 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;
84− else echo "Not building with installed constraints"; fi
85−
86 # build & run tests, build benchmarks
142 # build & run tests, build benchmarks
87− - cabal new-build -w ${HC} ${TEST} ${BENCH} all
143+ - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output
88− - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} all; fi
144+ # Testing...
89−
145+ - if [ $HCNUMVER -lt 80600 ] ; then ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi
90− # haddock
146+ # cabal check...
91− - rm -rf ./dist-newstyle
147+ - (cd ${PKGDIR_generic_lens} && ${CABAL} -vnormal check)
92− - if $HADDOCK; then cabal new-haddock -w ${HC} --disable-tests --disable-benchmarks all; else echo "Skipping haddock generation";fi
148+ # haddock...
149+ - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all | color_cabal_output
150+ # Building without installed constraints for packages in global-db...
151+ - rm -f cabal.project.local
152+ - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output
93
153
94−# REGENDATA ["generic-lens.cabal"]
154+# REGENDATA ["--config=cabal.haskell-ci","cabal.project"]
95# EOF
155# EOF
ChangeLog.md+7−1
@@ -1,8 +1,14 @@
1+## 1.2.0.1
2+- Give HasAny/AsAny the same VTA behavior on 8.6 and 8.8 (Ryan Scott)
3+
1## 1.2.0.0
4## 1.2.0.0
2- Add `HasTypesUsing` and `HasTypesCustom` for custom traversals (Lysxia)
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
3
8
4### Breaking API changes
9### Breaking API changes
5−- 'HasType' now includes a reflexive case (Matt Parsons) so that every type 'contains' itself
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
6
12
7## 1.1.0.0
13## 1.1.0.0
8- Fix regression in type inference for polymorphic optics
14- Fix regression in type inference for polymorphic optics
LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2018, Csongor Kiss
1+Copyright (c) 2019, Csongor Kiss
2
2
3All rights reserved.
3All rights reserved.
4
4
cabal.haskell-cinew file+5
@@ -0,0 +1,5 @@
1+-- inspection tests fail
2+tests: <8.6
3+
4+-- blocked on vector-th-unbox
5+benchmarks: <8.8
generic-lens.cabal+7−5
@@ -1,5 +1,5 @@
1name: generic-lens
1name: generic-lens
2−version: 1.2.0.0
2+version: 1.2.0.1
3synopsis: Generically derive traversals, lenses and prisms.
3synopsis: Generically derive traversals, lenses and prisms.
4description: This library uses GHC.Generics to derive efficient optics (traversals, lenses and prisms) for algebraic data types in a type-directed way, with a focus on good type inference and error messages when possible.
4description: This library uses GHC.Generics to derive efficient optics (traversals, lenses and prisms) for algebraic data types in a type-directed way, with a focus on good type inference and error messages when possible.
5
5
@@ -11,7 +11,7 @@ maintainer: kiss.csongor.kiss@gmail.com
11category: Generics, Records, Lens
11category: Generics, Records, Lens
12build-type: Simple
12build-type: Simple
13cabal-version: >= 1.10
13cabal-version: >= 1.10
14−Tested-With: GHC == 8.0.2, GHC == 8.2.1, GHC == 8.4.1, GHC == 8.4.3
14+Tested-With: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.1
15
15
16extra-source-files: ChangeLog.md
16extra-source-files: ChangeLog.md
17 , examples/StarWars.hs
17 , examples/StarWars.hs
@@ -56,6 +56,7 @@ library
56 , Data.Generics.Internal.Families.Changing
56 , Data.Generics.Internal.Families.Changing
57 , Data.Generics.Internal.Families.Collect
57 , Data.Generics.Internal.Families.Collect
58 , Data.Generics.Internal.Families.Has
58 , Data.Generics.Internal.Families.Has
59+ , Data.Generics.Internal.Errors
59 , Data.Generics.Internal.Void
60 , Data.Generics.Internal.Void
60
61
61 , Data.Generics.Sum.Internal.Constructors
62 , Data.Generics.Sum.Internal.Constructors
@@ -69,9 +70,10 @@ library
69 , Data.Generics.Product.Internal.Constraints
70 , Data.Generics.Product.Internal.Constraints
70 , Data.Generics.Product.Internal.HList
71 , Data.Generics.Product.Internal.HList
71
72
72− build-depends: base >= 4.9 && <= 5.0
73+ build-depends: base >= 4.9 && < 5
73− , profunctors >= 5.0 && <= 6.0
74+ , profunctors >= 5.0 && < 6.0
74− , tagged >= 0.8 && <= 0.9
75+ , tagged >= 0.8 && < 1
76+ , text >= 1.2 && < 1.3
75
77
76 hs-source-dirs: src
78 hs-source-dirs: src
77 default-language: Haskell2010
79 default-language: Haskell2010
src/Data/GenericLens/Internal.hs+18−1
@@ -1,7 +1,7 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2-- |
2-- |
3-- Module : Data.GenericLens.Internal
3-- Module : Data.GenericLens.Internal
4−-- Copyright : (C) 2018 Csongor Kiss
4+-- Copyright : (C) 2019 Csongor Kiss
5-- License : BSD3
5-- License : BSD3
6-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
6-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
7-- Stability : experimental
7-- Stability : experimental
@@ -18,6 +18,7 @@ module Data.GenericLens.Internal
18 , module Data.Generics.Internal.Families.Collect
18 , module Data.Generics.Internal.Families.Collect
19 , module Data.Generics.Internal.Families.Has
19 , module Data.Generics.Internal.Families.Has
20 , module Data.Generics.Internal.Void
20 , module Data.Generics.Internal.Void
21+ , module Data.Generics.Internal.Errors
21
22
22 , module Data.Generics.Sum.Internal.Constructors
23 , module Data.Generics.Sum.Internal.Constructors
23 , module Data.Generics.Sum.Internal.Typed
24 , module Data.Generics.Sum.Internal.Typed
@@ -28,6 +29,14 @@ module Data.GenericLens.Internal
28 , module Data.Generics.Product.Internal.Subtype
29 , module Data.Generics.Product.Internal.Subtype
29 , module Data.Generics.Product.Internal.Constraints
30 , module Data.Generics.Product.Internal.Constraints
30 , module Data.Generics.Product.Internal.HList
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
31 ) where
40 ) where
32
41
33import Data.Generics.Internal.Families
42import Data.Generics.Internal.Families
@@ -35,6 +44,7 @@ import Data.Generics.Internal.Families.Changing
35import Data.Generics.Internal.Families.Collect
44import Data.Generics.Internal.Families.Collect
36import Data.Generics.Internal.Families.Has
45import Data.Generics.Internal.Families.Has
37import Data.Generics.Internal.Void
46import Data.Generics.Internal.Void
47+import Data.Generics.Internal.Errors
38
48
39import Data.Generics.Sum.Internal.Constructors
49import Data.Generics.Sum.Internal.Constructors
40import Data.Generics.Sum.Internal.Typed
50import Data.Generics.Sum.Internal.Typed
@@ -45,3 +55,10 @@ import Data.Generics.Product.Internal.GLens
45import Data.Generics.Product.Internal.Subtype
55import Data.Generics.Product.Internal.Subtype
46import Data.Generics.Product.Internal.Constraints
56import Data.Generics.Product.Internal.Constraints
47import Data.Generics.Product.Internal.HList
57import 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/Generics/Internal/Errors.hsnew file+59
@@ -0,0 +1,59 @@
1+{-# LANGUAGE UndecidableInstances #-}
2+{-# LANGUAGE TypeFamilies #-}
3+{-# LANGUAGE KindSignatures #-}
4+{-# LANGUAGE PolyKinds #-}
5+{-# LANGUAGE DataKinds #-}
6+{-# LANGUAGE TypeOperators #-}
7+{-# LANGUAGE KindSignatures #-}
8+
9+-------------------------------------------------------------------------------
10+---- |
11+---- Module : Data.Generics.Internal.Errors
12+---- Copyright : (C) 2019 Csongor Kiss
13+---- License : BSD3
14+---- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
15+---- Stability : experimental
16+---- Portability : non-portable
17+----
18+---- Provide more legible type errors as described in
19+---- (https://kcsongor.github.io/report-stuck-families/)[this blog post].
20+-------------------------------------------------------------------------------
21+
22+module Data.Generics.Internal.Errors
23+ ( NoGeneric
24+ , Defined
25+ , Defined_list
26+
27+ , QuoteType
28+ , PrettyError
29+ ) where
30+
31+import GHC.Generics
32+import GHC.TypeLits
33+import Data.Kind
34+
35+type family NoGeneric (a :: Type) (ctxt :: [ErrorMessage]) :: Constraint where
36+ NoGeneric a ctxt = PrettyError ('Text "No instance for " ':<>: QuoteType (Generic a)
37+ ': ctxt)
38+type family PrettyError (ctxt :: [ErrorMessage]) :: k where
39+ PrettyError '[] = TypeError ('Text "")
40+ PrettyError (c ': cs) = TypeError ('Text "| " ':<>: c ':$$: PrettyLines cs)
41+
42+type family PrettyLines (ctxt :: [ErrorMessage]) :: ErrorMessage where
43+ PrettyLines '[] = 'Text ""
44+ PrettyLines (c ': cs) = 'Text "| " ':<>: c ':$$: PrettyLines cs
45+
46+type family Defined (break :: Type -> Type) (err :: Constraint) (a :: k) :: k where
47+ Defined Void1 _ _ = Any
48+ Defined _ _ k = k
49+
50+type family Defined_list (break :: [*]) (err :: Constraint) (a :: k) :: k where
51+ Defined_list '[Void] _ _ = Any
52+ Defined_list _ _ k = k
53+
54+data Void1 a
55+data Void
56+type family Any :: k
57+
58+type family QuoteType (typ :: k) :: ErrorMessage where
59+ QuoteType typ = 'Text "‘" ':<>: 'ShowType typ ':<>: 'Text "’"
src/Data/Generics/Internal/Families.hs+1−1
@@ -9,7 +9,7 @@
9-----------------------------------------------------------------------------
9-----------------------------------------------------------------------------
10-- |
10-- |
11-- Module : Data.Generics.Internal.Families
11-- Module : Data.Generics.Internal.Families
12−-- Copyright : (C) 2018 Csongor Kiss
12+-- Copyright : (C) 2019 Csongor Kiss
13-- License : BSD3
13-- License : BSD3
14-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
14-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
15-- Stability : experimental
15-- Stability : experimental
src/Data/Generics/Internal/Families/Collect.hs+1−1
@@ -7,7 +7,7 @@
7-----------------------------------------------------------------------------
7-----------------------------------------------------------------------------
8-- |
8-- |
9-- Module : Data.Generics.Internal.Families.Collect
9-- Module : Data.Generics.Internal.Families.Collect
10−-- Copyright : (C) 2018 Csongor Kiss
10+-- Copyright : (C) 2019 Csongor Kiss
11-- License : BSD3
11-- License : BSD3
12-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
12-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
13-- Stability : experimental
13-- Stability : experimental
src/Data/Generics/Internal/Families/Has.hs+1−1
@@ -7,7 +7,7 @@
7-----------------------------------------------------------------------------
7-----------------------------------------------------------------------------
8-- |
8-- |
9-- Module : Data.Generics.Internal.Families.Has
9-- Module : Data.Generics.Internal.Families.Has
10−-- Copyright : (C) 2018 Csongor Kiss
10+-- Copyright : (C) 2019 Csongor Kiss
11-- License : BSD3
11-- License : BSD3
12-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
12-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
13-- Stability : experimental
13-- Stability : experimental
src/Data/Generics/Internal/GenericN.hs+3−2
@@ -1,3 +1,4 @@
1+{-# OPTIONS_HADDOCK hide #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
@@ -11,9 +12,9 @@
11--------------------------------------------------------------------------------
12--------------------------------------------------------------------------------
12-- |
13-- |
13-- Module : Data.Generics.Internal.GenericN
14-- Module : Data.Generics.Internal.GenericN
14−-- Copyright : (C) 2018 Csongor Kiss
15+-- Copyright : (C) 2019 Csongor Kiss
15−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16-- License : BSD3
16-- License : BSD3
17+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17-- Stability : experimental
18-- Stability : experimental
18-- Portability : non-portable
19-- Portability : non-portable
19--
20--
src/Data/Generics/Internal/Profunctor/Iso.hs+2−1
@@ -1,3 +1,4 @@
1+{-# OPTIONS_HADDOCK hide #-}
1{-# LANGUAGE TupleSections #-}
2{-# LANGUAGE TupleSections #-}
2{-# LANGUAGE GADTs #-}
3{-# LANGUAGE GADTs #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
4{-# LANGUAGE NoMonomorphismRestriction #-}
@@ -10,7 +11,7 @@
10-----------------------------------------------------------------------------
11-----------------------------------------------------------------------------
11-- |
12-- |
12-- Module : Data.Generics.Internal.Profunctor.Iso
13-- Module : Data.Generics.Internal.Profunctor.Iso
13−-- Copyright : (C) 2018 Csongor Kiss
14+-- Copyright : (C) 2019 Csongor Kiss
14-- License : BSD3
15-- License : BSD3
15-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16-- Stability : experimental
17-- Stability : experimental
src/Data/Generics/Internal/Profunctor/Lens.hs+2−1
@@ -1,3 +1,4 @@
1+{-# OPTIONS_HADDOCK hide #-}
1{-# LANGUAGE GADTs #-}
2{-# LANGUAGE GADTs #-}
2{-# LANGUAGE NoMonomorphismRestriction #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
3{-# LANGUAGE Rank2Types #-}
4{-# LANGUAGE Rank2Types #-}
@@ -10,7 +11,7 @@
10-----------------------------------------------------------------------------
11-----------------------------------------------------------------------------
11-- |
12-- |
12-- Module : Data.Generics.Internal.Profunctor.Lens
13-- Module : Data.Generics.Internal.Profunctor.Lens
13−-- Copyright : (C) 2018 Csongor Kiss
14+-- Copyright : (C) 2019 Csongor Kiss
14-- License : BSD3
15-- License : BSD3
15-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16-- Stability : experimental
17-- Stability : experimental
src/Data/Generics/Internal/Profunctor/Prism.hs+2−1
@@ -1,3 +1,4 @@
1+{-# OPTIONS_HADDOCK hide #-}
1{-# LANGUAGE GADTs #-}
2{-# LANGUAGE GADTs #-}
2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
4{-# LANGUAGE NoMonomorphismRestriction #-}
@@ -10,7 +11,7 @@
10-----------------------------------------------------------------------------
11-----------------------------------------------------------------------------
11-- |
12-- |
12-- Module : Data.Generics.Internal.Profunctor.Prism
13-- Module : Data.Generics.Internal.Profunctor.Prism
13−-- Copyright : (C) 2018 Csongor Kiss
14+-- Copyright : (C) 2019 Csongor Kiss
14-- License : BSD3
15-- License : BSD3
15-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16-- Stability : experimental
17-- Stability : experimental
src/Data/Generics/Internal/VL/Iso.hs+2−1
@@ -1,3 +1,4 @@
1+{-# OPTIONS_HADDOCK hide #-}
1{-# LANGUAGE GADTs #-}
2{-# LANGUAGE GADTs #-}
2{-# LANGUAGE NoMonomorphismRestriction #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
3{-# LANGUAGE Rank2Types #-}
4{-# LANGUAGE Rank2Types #-}
@@ -9,7 +10,7 @@
9-----------------------------------------------------------------------------
10-----------------------------------------------------------------------------
10-- |
11-- |
11-- Module : Data.Generics.Internal.VL.Iso
12-- Module : Data.Generics.Internal.VL.Iso
12−-- Copyright : (C) 2018 Csongor Kiss
13+-- Copyright : (C) 2019 Csongor Kiss
13-- License : BSD3
14-- License : BSD3
14-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
15-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
15-- Stability : experimental
16-- Stability : experimental
src/Data/Generics/Internal/VL/Lens.hs+2−1
@@ -1,3 +1,4 @@
1+{-# OPTIONS_HADDOCK hide #-}
1{-# LANGUAGE GADTs #-}
2{-# LANGUAGE GADTs #-}
2{-# LANGUAGE NoMonomorphismRestriction #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
3{-# LANGUAGE Rank2Types #-}
4{-# LANGUAGE Rank2Types #-}
@@ -10,7 +11,7 @@
10-----------------------------------------------------------------------------
11-----------------------------------------------------------------------------
11-- |
12-- |
12-- Module : Data.Generics.Internal.VL.Lens
13-- Module : Data.Generics.Internal.VL.Lens
13−-- Copyright : (C) 2018 Csongor Kiss
14+-- Copyright : (C) 2019 Csongor Kiss
14-- License : BSD3
15-- License : BSD3
15-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16-- Stability : experimental
17-- Stability : experimental
src/Data/Generics/Internal/VL/Prism.hs+2−1
@@ -1,3 +1,4 @@
1+{-# OPTIONS_HADDOCK hide #-}
1{-# LANGUAGE GADTs #-}
2{-# LANGUAGE GADTs #-}
2{-# LANGUAGE NoMonomorphismRestriction #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
3{-# LANGUAGE Rank2Types #-}
4{-# LANGUAGE Rank2Types #-}
@@ -9,7 +10,7 @@
9-----------------------------------------------------------------------------
10-----------------------------------------------------------------------------
10-- |
11-- |
11-- Module : Data.Generics.Internal.VL.Prism
12-- Module : Data.Generics.Internal.VL.Prism
12−-- Copyright : (C) 2018 Csongor Kiss
13+-- Copyright : (C) 2019 Csongor Kiss
13-- License : BSD3
14-- License : BSD3
14-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
15-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
15-- Stability : experimental
16-- Stability : experimental
src/Data/Generics/Internal/VL/Traversal.hs+2−1
@@ -1,3 +1,4 @@
1+{-# OPTIONS_HADDOCK hide #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE GADTs #-}
4{-# LANGUAGE GADTs #-}
@@ -11,7 +12,7 @@
11-----------------------------------------------------------------------------
12-----------------------------------------------------------------------------
12-- |
13-- |
13-- Module : Data.Generics.Internal.VL.Traversal
14-- Module : Data.Generics.Internal.VL.Traversal
14−-- Copyright : (C) 2018 Csongor Kiss
15+-- Copyright : (C) 2019 Csongor Kiss
15-- License : BSD3
16-- License : BSD3
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17-- Stability : experimental
18-- Stability : experimental
src/Data/Generics/Labels.hs+1−1
@@ -16,7 +16,7 @@
16--------------------------------------------------------------------------------
16--------------------------------------------------------------------------------
17-- |
17-- |
18-- Module : Data.Generics.Labels
18-- Module : Data.Generics.Labels
19−-- Copyright : (C) 2018 Csongor Kiss
19+-- Copyright : (C) 2019 Csongor Kiss
20-- License : BSD3
20-- License : BSD3
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
22-- Stability : experimental
22-- Stability : experimental
src/Data/Generics/Product.hs+1−1
@@ -1,7 +1,7 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2-- |
2-- |
3-- Module : Data.Generics.Product
3-- Module : Data.Generics.Product
4−-- Copyright : (C) 2018 Csongor Kiss
4+-- Copyright : (C) 2019 Csongor Kiss
5-- License : BSD3
5-- License : BSD3
6-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
6-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
7-- Stability : experimental
7-- Stability : experimental
src/Data/Generics/Product/Any.hs+2−2
@@ -12,7 +12,7 @@
12-----------------------------------------------------------------------------
12-----------------------------------------------------------------------------
13-- |
13-- |
14-- Module : Data.Generics.Product.Any
14-- Module : Data.Generics.Product.Any
15−-- Copyright : (C) 2018 Csongor Kiss
15+-- Copyright : (C) 2019 Csongor Kiss
16-- License : BSD3
16-- License : BSD3
17-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
18-- Stability : experimental
18-- Stability : experimental
@@ -53,7 +53,7 @@ import Data.Generics.Product.Typed
53-- human = Human "Tunyasz" 50 "London"
53-- human = Human "Tunyasz" 50 "London"
54-- :}
54-- :}
55
55
56−class HasAny (sel :: k) s t a b | s sel k -> a where
56+class HasAny sel s t a b | s sel -> a where
57 -- |A lens that focuses on a part of a product as identified by some
57 -- |A lens that focuses on a part of a product as identified by some
58 -- selector. Currently supported selectors are field names, positions and
58 -- selector. Currently supported selectors are field names, positions and
59 -- unique types. Compatible with the lens package's 'Control.Lens.Lens'
59 -- unique types. Compatible with the lens package's 'Control.Lens.Lens'
src/Data/Generics/Product/Constraints.hs+1−1
@@ -11,7 +11,7 @@
11-----------------------------------------------------------------------------
11-----------------------------------------------------------------------------
12-- |
12-- |
13-- Module : Data.Generics.Product.Constraints
13-- Module : Data.Generics.Product.Constraints
14−-- Copyright : (C) 2018 Csongor Kiss
14+-- Copyright : (C) 2019 Csongor Kiss
15-- License : BSD3
15-- License : BSD3
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17-- Stability : experimental
17-- Stability : experimental
src/Data/Generics/Product/Fields.hs+29−13
@@ -16,7 +16,7 @@
16-----------------------------------------------------------------------------
16-----------------------------------------------------------------------------
17-- |
17-- |
18-- Module : Data.Generics.Product.Fields
18-- Module : Data.Generics.Product.Fields
19−-- Copyright : (C) 2018 Csongor Kiss
19+-- Copyright : (C) 2019 Csongor Kiss
20-- License : BSD3
20-- License : BSD3
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
22-- Stability : experimental
22-- Stability : experimental
@@ -47,6 +47,7 @@ import Data.Kind (Constraint, Type)
47import GHC.Generics
47import GHC.Generics
48import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError)
48import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError)
49import Data.Generics.Internal.Profunctor.Lens as P
49import Data.Generics.Internal.Profunctor.Lens as P
50+import Data.Generics.Internal.Errors
50
51
51-- $setup
52-- $setup
52-- == /Running example:/
53-- == /Running example:/
@@ -152,39 +153,47 @@ instance
152 ( Generic s
153 ( Generic s
153 , ErrorUnless field s (CollectField field (Rep s))
154 , ErrorUnless field s (CollectField field (Rep s))
154 , GLens' (HasTotalFieldPSym field) (Rep s) a
155 , GLens' (HasTotalFieldPSym field) (Rep s) a
156+ , Defined (Rep s)
157+ (NoGeneric s '[ 'Text "arising from a generic lens focusing on the "
158+ ':<>: QuoteType field ':<>: 'Text " field of type " ':<>: QuoteType a
159+ , 'Text "in " ':<>: QuoteType s])
160+ (() :: Constraint)
155 ) => HasField' field s a where
161 ) => HasField' field s a where
156− field' f s = VL.ravel (repLens . glens @(HasTotalFieldPSym field)) f s
162+ field' f s = field0 @field f s
157
163
158class (~~) (a :: k) (b :: k) | a -> b, b -> a
164class (~~) (a :: k) (b :: k) | a -> b, b -> a
159instance (a ~ b) => (~~) a b
165instance (a ~ b) => (~~) a b
160
166
161instance -- see Note [Changing type parameters]
167instance -- see Note [Changing type parameters]
162− ( Generic s
163− , Generic t
164− , ErrorUnless field s (CollectField field (Rep s))
165− , HasTotalFieldP field (Rep s) ~~ 'Just a
168+ ( HasTotalFieldP field (Rep s) ~~ 'Just a
166 , HasTotalFieldP field (Rep t) ~~ 'Just b
169 , HasTotalFieldP field (Rep t) ~~ 'Just b
167 , HasTotalFieldP field (Rep (Indexed s)) ~~ 'Just a'
170 , HasTotalFieldP field (Rep (Indexed s)) ~~ 'Just a'
168 , HasTotalFieldP field (Rep (Indexed t)) ~~ 'Just b'
171 , HasTotalFieldP field (Rep (Indexed t)) ~~ 'Just b'
169 , t ~~ Infer s a' b
172 , t ~~ Infer s a' b
170 , s ~~ Infer t b' a
173 , s ~~ Infer t b' a
171− , GLens (HasTotalFieldPSym field) (Rep s) (Rep t) a b
174+ , HasField0 field s t a b
172 ) => HasField field s t a b where
175 ) => HasField field s t a b where
173 field f s = field0 @field f s
176 field f s = field0 @field f s
174
177
175−-- -- See Note [Uncluttering type signatures]
178+-- | See Note [Uncluttering type signatures]
179+#if __GLASGOW_HASKELL__ < 804
180+-- >>> :t field
181+-- field
182+-- :: (HasField field s t a b, Functor f) => (a -> f b) -> s -> f t
183+#else
184+-- >>> :t field
185+-- field
186+-- :: (Functor f, HasField field s t a b) => (a -> f b) -> s -> f t
187+#endif
176instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where
188instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where
177 field = undefined
189 field = undefined
178
190
179instance
191instance
180− ( Generic s
181− , Generic t
182− , ErrorUnless field s (CollectField field (Rep s))
183− , HasTotalFieldP field (Rep s) ~~ 'Just a
192+ ( HasTotalFieldP field (Rep s) ~~ 'Just a
184 , HasTotalFieldP field (Rep t) ~~ 'Just b
193 , HasTotalFieldP field (Rep t) ~~ 'Just b
185 , UnifyHead s t
194 , UnifyHead s t
186 , UnifyHead t s
195 , UnifyHead t s
187− , GLens (HasTotalFieldPSym field) (Rep s) (Rep t) a b
196+ , HasField0 field s t a b
188 ) => HasField_ field s t a b where
197 ) => HasField_ field s t a b where
189 field_ f s = field0 @field f s
198 field_ f s = field0 @field f s
190
199
@@ -195,8 +204,15 @@ instance
195 ( Generic s
204 ( Generic s
196 , Generic t
205 , Generic t
197 , GLens (HasTotalFieldPSym field) (Rep s) (Rep t) a b
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)
198 ) => HasField0 field s t a b where
213 ) => HasField0 field s t a b where
199 field0 = VL.ravel (repLens . glens @(HasTotalFieldPSym field))
214 field0 = VL.ravel (repLens . glens @(HasTotalFieldPSym field))
215+ {-# INLINE field0 #-}
200
216
201type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Constraint where
217type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Constraint where
202 ErrorUnless field s ('TypeStat _ _ '[])
218 ErrorUnless field s ('TypeStat _ _ '[])
src/Data/Generics/Product/HList.hs+1−1
@@ -10,7 +10,7 @@
10-----------------------------------------------------------------------------
10-----------------------------------------------------------------------------
11-- |
11-- |
12-- Module : Data.Generics.Product.HList
12-- Module : Data.Generics.Product.HList
13−-- Copyright : (C) 2018 Csongor Kiss
13+-- Copyright : (C) 2019 Csongor Kiss
14-- License : BSD3
14-- License : BSD3
15-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
15-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16-- Stability : experimental
16-- Stability : experimental
src/Data/Generics/Product/Internal/Constraints.hs+1−1
@@ -15,7 +15,7 @@
15-----------------------------------------------------------------------------
15-----------------------------------------------------------------------------
16-- |
16-- |
17-- Module : Data.Generics.Product.Internal.Constraints
17-- Module : Data.Generics.Product.Internal.Constraints
18−-- Copyright : (C) 2018 Csongor Kiss
18+-- Copyright : (C) 2019 Csongor Kiss
19-- License : BSD3
19-- License : BSD3
20-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21-- Stability : experimental
21-- Stability : experimental
src/Data/Generics/Product/Internal/GLens.hs+1−1
@@ -17,7 +17,7 @@
17-----------------------------------------------------------------------------
17-----------------------------------------------------------------------------
18-- |
18-- |
19-- Module : Data.Generics.Product.Internal.GLens
19-- Module : Data.Generics.Product.Internal.GLens
20−-- Copyright : (C) 2018 Csongor Kiss
20+-- Copyright : (C) 2019 Csongor Kiss
21-- License : BSD3
21-- License : BSD3
22-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
22-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
23-- Stability : experimental
23-- Stability : experimental
src/Data/Generics/Product/Internal/HList.hs+1−1
@@ -20,7 +20,7 @@
20-----------------------------------------------------------------------------
20-----------------------------------------------------------------------------
21-- |
21-- |
22-- Module : Data.Generics.Product.Internal.HList
22-- Module : Data.Generics.Product.Internal.HList
23−-- Copyright : (C) 2018 Csongor Kiss
23+-- Copyright : (C) 2019 Csongor Kiss
24-- License : BSD3
24-- License : BSD3
25-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
25-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
26-- Stability : experimental
26-- Stability : experimental
src/Data/Generics/Product/Internal/Positions.hs+1−1
@@ -17,7 +17,7 @@
17-----------------------------------------------------------------------------
17-----------------------------------------------------------------------------
18-- |
18-- |
19-- Module : Data.Generics.Product.Internal.Positions
19-- Module : Data.Generics.Product.Internal.Positions
20−-- Copyright : (C) 2018 Csongor Kiss
20+-- Copyright : (C) 2019 Csongor Kiss
21-- License : BSD3
21-- License : BSD3
22-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
22-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
23-- Stability : experimental
23-- Stability : experimental
src/Data/Generics/Product/Internal/Subtype.hs+1−1
@@ -16,7 +16,7 @@
16-----------------------------------------------------------------------------
16-----------------------------------------------------------------------------
17-- |
17-- |
18-- Module : Data.Generics.Product.Internal.Subtype
18-- Module : Data.Generics.Product.Internal.Subtype
19−-- Copyright : (C) 2018 Csongor Kiss
19+-- Copyright : (C) 2019 Csongor Kiss
20-- License : BSD3
20-- License : BSD3
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
22-- Stability : experimental
22-- Stability : experimental
src/Data/Generics/Product/Param.hs+10−3
@@ -15,13 +15,13 @@
15--------------------------------------------------------------------------------
15--------------------------------------------------------------------------------
16-- |
16-- |
17-- Module : Data.Generics.Product.Param
17-- Module : Data.Generics.Product.Param
18−-- Copyright : (C) 2018 Csongor Kiss
18+-- Copyright : (C) 2019 Csongor Kiss
19−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20-- License : BSD3
19-- License : BSD3
20+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21-- Stability : experimental
21-- Stability : experimental
22-- Portability : non-portable
22-- Portability : non-portable
23--
23--
24−-- Derive traversal over type parameters
24+-- Derive traversals over type parameters
25--
25--
26--------------------------------------------------------------------------------
26--------------------------------------------------------------------------------
27
27
@@ -39,6 +39,7 @@ import GHC.Generics
39import Data.Kind
39import Data.Kind
40import Data.Generics.Internal.VL.Iso
40import Data.Generics.Internal.VL.Iso
41import Data.Generics.Internal.GenericN
41import Data.Generics.Internal.GenericN
42+import Data.Generics.Internal.Errors
42
43
43class HasParam (p :: Nat) s t a b | p t a -> s, p s b -> t, p s -> a, p t -> b where
44class HasParam (p :: Nat) s t a b | p t a -> s, p s b -> t, p s -> a, p t -> b where
44 param :: Applicative g => (a -> g b) -> s -> g t
45 param :: Applicative g => (a -> g b) -> s -> g t
@@ -47,6 +48,12 @@ instance
47 ( GenericN s
48 ( GenericN s
48 , GenericN t
49 , GenericN t
49 -- TODO: merge the old 'Changing' code with 'GenericN'
50 -- TODO: merge the old 'Changing' code with 'GenericN'
51+ , Defined (Rep s)
52+ (NoGeneric s
53+ '[ 'Text "arising from a generic traversal of the type parameter at position " ':<>: QuoteType n
54+ , 'Text "of type " ':<>: QuoteType a ':<>: 'Text " in " ':<>: QuoteType s
55+ ])
56+ (() :: Constraint)
50 , s ~ Infer t (P n b 'PTag) a
57 , s ~ Infer t (P n b 'PTag) a
51 , t ~ Infer s (P n a 'PTag) b
58 , t ~ Infer s (P n a 'PTag) b
52 , Error ((ArgCount s) <=? n) n (ArgCount s) s
59 , Error ((ArgCount s) <=? n) n (ArgCount s) s
src/Data/Generics/Product/Positions.hs+34−10
@@ -19,7 +19,7 @@
19-----------------------------------------------------------------------------
19-----------------------------------------------------------------------------
20-- |
20-- |
21-- Module : Data.Generics.Product.Positions
21-- Module : Data.Generics.Product.Positions
22−-- Copyright : (C) 2018 Csongor Kiss
22+-- Copyright : (C) 2019 Csongor Kiss
23-- License : BSD3
23-- License : BSD3
24-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
24-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
25-- Stability : experimental
25-- Stability : experimental
@@ -47,6 +47,7 @@ import Data.Generics.Internal.Void
47import Data.Generics.Internal.Families
47import Data.Generics.Internal.Families
48import Data.Generics.Product.Internal.Positions
48import Data.Generics.Product.Internal.Positions
49import Data.Generics.Product.Internal.GLens
49import Data.Generics.Product.Internal.GLens
50+import Data.Generics.Internal.Errors
50
51
51import Data.Kind (Constraint, Type)
52import Data.Kind (Constraint, Type)
52import Data.Type.Bool (type (&&))
53import Data.Type.Bool (type (&&))
@@ -114,9 +115,15 @@ class HasPosition' (i :: Nat) s a | s i -> a where
114class HasPosition0 (i :: Nat) s t a b where
115class HasPosition0 (i :: Nat) s t a b where
115 position0 :: VL.Lens s t a b
116 position0 :: VL.Lens s t a b
116
117
118+-- |
119+-- >>> getPosition @2 human
120+-- 50
117getPosition :: forall i s a. HasPosition' i s a => s -> a
121getPosition :: forall i s a. HasPosition' i s a => s -> a
118getPosition s = s ^. position' @i
122getPosition s = s ^. position' @i
119
123
124+-- |
125+-- >>> setPosition @2 60 human
126+-- Human {name = "Tunyasz", age = 60, address = "London"}
120setPosition :: forall i s a. HasPosition' i s a => a -> s -> s
127setPosition :: forall i s a. HasPosition' i s a => a -> s -> s
121setPosition = VL.set (position' @i)
128setPosition = VL.set (position' @i)
122
129
@@ -126,6 +133,12 @@ instance
126 , cs ~ CRep s
133 , cs ~ CRep s
127 , Coercible (Rep s) cs
134 , Coercible (Rep s) cs
128 , GLens' (HasTotalPositionPSym i) cs a
135 , GLens' (HasTotalPositionPSym i) cs a
136+ , Defined (Rep s)
137+ (NoGeneric s '[ 'Text "arising from a generic lens focusing on the field at"
138+ , 'Text "position " ':<>: QuoteType i ':<>: 'Text " of type " ':<>: QuoteType a
139+ ':<>: 'Text " in " ':<>: QuoteType s
140+ ])
141+ (() :: Constraint)
129 ) => HasPosition' i s a where
142 ) => HasPosition' i s a where
130 position' f s = VL.ravel (repLens . coerced @cs @cs . glens @(HasTotalPositionPSym i)) f s
143 position' f s = VL.ravel (repLens . coerced @cs @cs . glens @(HasTotalPositionPSym i)) f s
131 {-# INLINE position' #-}
144 {-# INLINE position' #-}
@@ -136,10 +149,7 @@ class (~~) (a :: k) (b :: k) | a -> b, b -> a
136instance (a ~ b) => (~~) a b
149instance (a ~ b) => (~~) a b
137
150
138instance -- see Note [Changing type parameters]
151instance -- see Note [Changing type parameters]
139− ( Generic s
140− , Generic t
141− , ErrorUnless i s (0 <? i && i <=? Size (Rep s))
152+ ( ErrorUnless i s (0 <? i && i <=? Size (Rep s))
142− , GLens (HasTotalPositionPSym i) (CRep s) (CRep t) a b
143 , HasTotalPositionP i (CRep s) ~~ 'Just a
153 , HasTotalPositionP i (CRep s) ~~ 'Just a
144 , HasTotalPositionP i (CRep t) ~~ 'Just b
154 , HasTotalPositionP i (CRep t) ~~ 'Just b
145 , HasTotalPositionP i (CRep (Indexed s)) ~~ 'Just a'
155 , HasTotalPositionP i (CRep (Indexed s)) ~~ 'Just a'
@@ -148,6 +158,7 @@ instance -- see Note [Changing type parameters]
148 , s ~~ Infer t b' a
158 , s ~~ Infer t b' a
149 , Coercible (CRep s) (Rep s)
159 , Coercible (CRep s) (Rep s)
150 , Coercible (CRep t) (Rep t)
160 , Coercible (CRep t) (Rep t)
161+ , HasPosition0 i s t a b
151 ) => HasPosition i s t a b where
162 ) => HasPosition i s t a b where
152
163
153 position = position0 @i
164 position = position0 @i
@@ -161,19 +172,26 @@ coerced :: forall s t s' t' x a b. (Coercible t t', Coercible s s')
161coerced = coerce
172coerced = coerce
162{-# INLINE coerced #-}
173{-# INLINE coerced #-}
163
174
164−-- See Note [Uncluttering type signatures]
175+-- | See Note [Uncluttering type signatures]
176+#if __GLASGOW_HASKELL__ < 804
177+-- >>> :t position
178+-- position
179+-- :: (HasPosition i s t a b, Functor f) => (a -> f b) -> s -> f t
180+#else
181+-- >>> :t position
182+-- position
183+-- :: (Functor f, HasPosition i s t a b) => (a -> f b) -> s -> f t
184+#endif
165instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where
185instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where
166 position = undefined
186 position = undefined
167
187
168instance
188instance
169− ( Generic s
170− , Generic t
171− , ErrorUnless i s (0 <? i && i <=? Size (Rep s))
189+ ( ErrorUnless i s (0 <? i && i <=? Size (Rep s))
172− , GLens (HasTotalPositionPSym i) (CRep s) (CRep t) a b
173 , UnifyHead s t
190 , UnifyHead s t
174 , UnifyHead t s
191 , UnifyHead t s
175 , Coercible (CRep s) (Rep s)
192 , Coercible (CRep s) (Rep s)
176 , Coercible (CRep t) (Rep t)
193 , Coercible (CRep t) (Rep t)
194+ , HasPosition0 i s t a b
177 ) => HasPosition_ i s t a b where
195 ) => HasPosition_ i s t a b where
178
196
179 position_ = position0 @i
197 position_ = position0 @i
@@ -188,6 +206,12 @@ instance
188 , GLens (HasTotalPositionPSym i) (CRep s) (CRep t) a b
206 , GLens (HasTotalPositionPSym i) (CRep s) (CRep t) a b
189 , Coercible (CRep s) (Rep s)
207 , Coercible (CRep s) (Rep s)
190 , Coercible (CRep t) (Rep t)
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)
191 ) => HasPosition0 i s t a b where
215 ) => HasPosition0 i s t a b where
192 position0 = VL.ravel (repLens . coerced @(CRep s) @(CRep t) . glens @(HasTotalPositionPSym i))
216 position0 = VL.ravel (repLens . coerced @(CRep s) @(CRep t) . glens @(HasTotalPositionPSym i))
193 {-# INLINE position0 #-}
217 {-# INLINE position0 #-}
src/Data/Generics/Product/Subtype.hs+43−3
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
@@ -15,7 +16,7 @@
15-----------------------------------------------------------------------------
16-----------------------------------------------------------------------------
16-- |
17-- |
17-- Module : Data.Generics.Product.Subtype
18-- Module : Data.Generics.Product.Subtype
18−-- Copyright : (C) 2018 Csongor Kiss
19+-- Copyright : (C) 2019 Csongor Kiss
19-- License : BSD3
20-- License : BSD3
20-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21-- Stability : experimental
22-- Stability : experimental
@@ -41,6 +42,7 @@ import GHC.Generics (Generic (Rep, to, from) )
41import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
42import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
42import Data.Kind (Type, Constraint)
43import Data.Kind (Type, Constraint)
43import Data.Generics.Internal.Profunctor.Lens hiding (set)
44import Data.Generics.Internal.Profunctor.Lens hiding (set)
45+import Data.Generics.Internal.Errors
44
46
45-- $setup
47-- $setup
46-- == /Running example:/
48-- == /Running example:/
@@ -113,14 +115,52 @@ instance
113 , Generic b
115 , Generic b
114 , GSmash (Rep a) (Rep b)
116 , GSmash (Rep a) (Rep b)
115 , GUpcast (Rep a) (Rep b)
117 , GUpcast (Rep a) (Rep b)
116− , ErrorUnless b a (CollectFieldsOrdered (Rep b) \\ CollectFieldsOrdered (Rep a))
118+ , CustomError a b
117 ) => Subtype b a where
119 ) => Subtype b a where
118 smash p b = to $ gsmash (from p) (from b)
120 smash p b = to $ gsmash (from p) (from b)
119 upcast = to . gupcast . from
121 upcast = to . gupcast . from
120
122
123+type family CustomError a b :: Constraint where
124+ CustomError a b =
125+ ( ErrorUnless b a (CollectFieldsOrdered (Rep b) \\ CollectFieldsOrdered (Rep a))
126+ , Defined (Rep a)
127+ (NoGeneric a '[ 'Text "arising from a generic lens focusing on " ':<>: QuoteType b
128+ , 'Text "as a supertype of " ':<>: QuoteType a
129+ ])
130+ (() :: Constraint)
131+ , Defined (Rep b)
132+ (NoGeneric b '[ 'Text "arising from a generic lens focusing on " ':<>: QuoteType b
133+ , 'Text "as a supertype of " ':<>: QuoteType a
134+ ])
135+ (() :: Constraint)
136+ )
137+
138+instance {-# OVERLAPPING #-} Subtype a a where
139+ super = id
140+
121−-- See Note [Uncluttering type signatures]
141+-- | See Note [Uncluttering type signatures]
142+#if __GLASGOW_HASKELL__ < 804
143+-- >>> :t super
144+-- super
145+-- :: (Subtype sup sub, Functor f) => (sup -> f sup) -> sub -> f sub
146+#else
147+-- >>> :t super
148+-- super
149+-- :: (Functor f, Subtype sup sub) => (sup -> f sup) -> sub -> f sub
150+#endif
122instance {-# OVERLAPPING #-} Subtype a Void where
151instance {-# OVERLAPPING #-} Subtype a Void where
123 super = undefined
152 super = undefined
153+
154+-- | See Note [Uncluttering type signatures]
155+#if __GLASGOW_HASKELL__ < 804
156+-- >>> :t super @Int
157+-- super @Int
158+-- :: (Subtype Int sub, Functor f) => (Int -> f Int) -> sub -> f sub
159+#else
160+-- >>> :t super @Int
161+-- super @Int
162+-- :: (Functor f, Subtype Int sub) => (Int -> f Int) -> sub -> f sub
163+#endif
124instance {-# OVERLAPPING #-} Subtype Void a where
164instance {-# OVERLAPPING #-} Subtype Void a where
125 super = undefined
165 super = undefined
126
166
src/Data/Generics/Product/Typed.hs+16−2
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
@@ -14,7 +15,7 @@
14-----------------------------------------------------------------------------
15-----------------------------------------------------------------------------
15-- |
16-- |
16-- Module : Data.Generics.Product.Typed
17-- Module : Data.Generics.Product.Typed
17−-- Copyright : (C) 2018 Csongor Kiss
18+-- Copyright : (C) 2019 Csongor Kiss
18-- License : BSD3
19-- License : BSD3
19-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20-- Stability : experimental
21-- Stability : experimental
@@ -40,6 +41,7 @@ import Data.Kind (Constraint, Type)
40import GHC.Generics (Generic (Rep))
41import GHC.Generics (Generic (Rep))
41import GHC.TypeLits (TypeError, ErrorMessage (..))
42import GHC.TypeLits (TypeError, ErrorMessage (..))
42import Data.Generics.Internal.Profunctor.Lens
43import Data.Generics.Internal.Profunctor.Lens
44+import Data.Generics.Internal.Errors
43
45
44-- $setup
46-- $setup
45-- == /Running example:/
47-- == /Running example:/
@@ -111,6 +113,9 @@ class HasType a s where
111instance
113instance
112 ( Generic s
114 ( Generic s
113 , ErrorUnlessOne a s (CollectTotalType a (Rep s))
115 , ErrorUnlessOne a s (CollectTotalType a (Rep s))
116+ , Defined (Rep s)
117+ (NoGeneric s '[ 'Text "arising from a generic lens focusing on a field of type " ':<>: QuoteType a])
118+ (() :: Constraint)
114 , GLens (HasTotalTypePSym a) (Rep s) (Rep s) a a
119 , GLens (HasTotalTypePSym a) (Rep s) (Rep s) a a
115 ) => HasType a s where
120 ) => HasType a s where
116
121
@@ -123,7 +128,16 @@ instance {-# OVERLAPPING #-} HasType a a where
123 setTyped a _ = a
128 setTyped a _ = a
124 {-# INLINE setTyped #-}
129 {-# INLINE setTyped #-}
125
130
126−-- See Note [Uncluttering type signatures]
131+-- | See Note [Uncluttering type signatures]
132+#if __GLASGOW_HASKELL__ < 804
133+-- >>> :t typed
134+-- typed :: (HasType a s, Functor f) => (a -> f a) -> s -> f s
135+#else
136+-- >>> :t typed
137+-- typed :: (Functor f, HasType a s) => (a -> f a) -> s -> f s
138+#endif
139+--
140+-- Note that this might not longer be needed given the above 'HasType a a' instance.
127instance {-# OVERLAPPING #-} HasType a Void where
141instance {-# OVERLAPPING #-} HasType a Void where
128 typed = undefined
142 typed = undefined
129
143
src/Data/Generics/Product/Types.hs+35−5
@@ -16,7 +16,7 @@
16-----------------------------------------------------------------------------
16-----------------------------------------------------------------------------
17-- |
17-- |
18-- Module : Data.Generics.Product.Types
18-- Module : Data.Generics.Product.Types
19−-- Copyright : (C) 2018 Csongor Kiss
19+-- Copyright : (C) 2019 Csongor Kiss
20-- License : BSD3
20-- License : BSD3
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
22-- Stability : experimental
22-- Stability : experimental
@@ -48,9 +48,12 @@ module Data.Generics.Product.Types
48import Data.Kind
48import Data.Kind
49import Data.Int (Int8, Int16, Int32, Int64)
49import Data.Int (Int8, Int16, Int32, Int64)
50import Data.Word (Word, Word8, Word16, Word32, Word64)
50import Data.Word (Word, Word8, Word16, Word32, Word64)
51+import qualified Data.Text as T
51
52
52import GHC.Generics
53import GHC.Generics
54+import GHC.TypeLits
53import Data.Generics.Internal.VL.Traversal
55import Data.Generics.Internal.VL.Traversal
56+import Data.Generics.Internal.Errors
54
57
55-- $setup
58-- $setup
56-- == /Running example:/
59-- == /Running example:/
@@ -131,7 +134,9 @@ instance {-# OVERLAPPING #-} HasTypesUsing ch s Void where
131-- >>> myTree = WithWeight (Fork (Leaf (Opaque "foo")) (Leaf (Opaque "bar"))) False
134-- >>> myTree = WithWeight (Fork (Leaf (Opaque "foo")) (Leaf (Opaque "bar"))) False
132-- >>> over (types @String) (++ "!") myTree
135-- >>> over (types @String) (++ "!") myTree
133-- ...
136-- ...
134−-- ... No instance for (HasTypesOpt
137+-- ... | No instance for ‘Generic Opaque’
138+-- ... | arising from a generic traversal.
139+-- ... | Either derive the instance, or define a custom traversal using ‘HasTypesCustom’
135-- ...
140-- ...
136--
141--
137-- In these cases, we can define a custom traversal strategy to override the
142-- In these cases, we can define a custom traversal strategy to override the
@@ -204,6 +209,13 @@ class HasTypesCustom (ch :: Type) s a where
204instance {-# OVERLAPPABLE #-}
209instance {-# OVERLAPPABLE #-}
205 ( GHasTypes ch (Rep s) a
210 ( GHasTypes ch (Rep s) a
206 , Generic s
211 , Generic s
212+ -- if there's no Generic instance here, it means we got through the
213+ -- Children check by a user-defined custom strategy.
214+ -- Therefore, we can ignore the missing Generic instance, and
215+ -- instead report a missing HasTypesCustom instance
216+ , Defined (Rep s)
217+ (PrettyError '[ 'Text "No instance " ':<>: QuoteType (HasTypesCustom ch s a)])
218+ (() :: Constraint)
207 ) => HasTypesCustom ch s a where
219 ) => HasTypesCustom ch s a where
208 typesCustom f s = to <$> gtypes_ @ch f (from s)
220 typesCustom f s = to <$> gtypes_ @ch f (from s)
209 --{-# INLINE types' #-}
221 --{-# INLINE types' #-}
@@ -230,7 +242,14 @@ type family ChildrenDefault (a :: Type) :: [Type] where
230 ChildrenDefault Word16 = '[]
242 ChildrenDefault Word16 = '[]
231 ChildrenDefault Word32 = '[]
243 ChildrenDefault Word32 = '[]
232 ChildrenDefault Word64 = '[]
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+ ])
233− ChildrenDefault a = ChildrenGeneric (Rep a) '[]
252+ (ChildrenGeneric (Rep a) '[])
234
253
235type family ChildrenGeneric (f :: k -> Type) (cs :: [Type]) :: [Type] where
254type family ChildrenGeneric (f :: k -> Type) (cs :: [Type]) :: [Type] where
236 ChildrenGeneric (M1 _ _ f) cs = ChildrenGeneric f cs
255 ChildrenGeneric (M1 _ _ f) cs = ChildrenGeneric f cs
@@ -303,7 +322,16 @@ instance GHasTypes ch V1 a where
303 {-# INLINE gtypes_ #-}
322 {-# INLINE gtypes_ #-}
304
323
305type Interesting (ch :: Type) (a :: Type) (t :: Type)
324type Interesting (ch :: Type) (a :: Type) (t :: Type)
325+ = Defined_list (Children ch t) (NoChildren ch t)
306− = IsNothing (Interesting' ch a '[t] (Children 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+
307
335
308type family Interesting' (ch :: Type) (a :: Type) (seen :: [Type]) (ts :: [Type]) :: Maybe [Type] where
336type family Interesting' (ch :: Type) (a :: Type) (seen :: [Type]) (ts :: [Type]) :: Maybe [Type] where
309 Interesting' ch _ seen '[] = 'Just seen
337 Interesting' ch _ seen '[] = 'Just seen
@@ -317,7 +345,9 @@ type family InterestingUnless
317 Maybe [Type] where
345 Maybe [Type] where
318 InterestingUnless ch a seen a _ = 'Nothing
346 InterestingUnless ch a seen a _ = 'Nothing
319 InterestingUnless ch a seen t 'True = 'Just seen
347 InterestingUnless ch a seen t 'True = 'Just seen
320− InterestingUnless ch a seen t 'False = Interesting' ch a (t ': seen) (Children ch t)
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))
321
351
322-- Short circuit
352-- Short circuit
323type family InterestingOr
353type family InterestingOr
src/Data/Generics/Sum.hs+1−1
@@ -1,7 +1,7 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2-- |
2-- |
3-- Module : Data.Generics.Sum
3-- Module : Data.Generics.Sum
4−-- Copyright : (C) 2018 Csongor Kiss
4+-- Copyright : (C) 2019 Csongor Kiss
5-- License : BSD3
5-- License : BSD3
6-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
6-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
7-- Stability : experimental
7-- Stability : experimental
src/Data/Generics/Sum/Any.hs+2−2
@@ -11,7 +11,7 @@
11-----------------------------------------------------------------------------
11-----------------------------------------------------------------------------
12-- |
12-- |
13-- Module : Data.Generics.Sum.Any
13-- Module : Data.Generics.Sum.Any
14−-- Copyright : (C) 2018 Csongor Kiss
14+-- Copyright : (C) 2019 Csongor Kiss
15-- License : BSD3
15-- License : BSD3
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17-- Stability : experimental
17-- Stability : experimental
@@ -61,7 +61,7 @@ import Data.Generics.Internal.VL.Prism
61-- :}
61-- :}
62
62
63-- |Sums that have generic prisms.
63-- |Sums that have generic prisms.
64−class AsAny (sel :: k) a s | s sel k -> a where
64+class AsAny sel a s | s sel -> a where
65 -- |A prism that projects a sum as identified by some selector. Currently
65 -- |A prism that projects a sum as identified by some selector. Currently
66 -- supported selectors are constructor names and unique types. Compatible
66 -- supported selectors are constructor names and unique types. Compatible
67 -- with the lens package's 'Control.Lens.Prism' type.
67 -- with the lens package's 'Control.Lens.Prism' type.
src/Data/Generics/Sum/Constructors.hs+31−9
@@ -15,7 +15,7 @@
15-----------------------------------------------------------------------------
15-----------------------------------------------------------------------------
16-- |
16-- |
17-- Module : Data.Generics.Sum.Constructors
17-- Module : Data.Generics.Sum.Constructors
18−-- Copyright : (C) 2018 Csongor Kiss
18+-- Copyright : (C) 2019 Csongor Kiss
19-- License : BSD3
19-- License : BSD3
20-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21-- Stability : experimental
21-- Stability : experimental
@@ -45,6 +45,7 @@ import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
45import Data.Generics.Internal.VL.Prism
45import Data.Generics.Internal.VL.Prism
46import Data.Generics.Internal.Profunctor.Iso
46import Data.Generics.Internal.Profunctor.Iso
47import Data.Generics.Internal.Profunctor.Prism (prismPRavel)
47import Data.Generics.Internal.Profunctor.Prism (prismPRavel)
48+import Data.Generics.Internal.Errors
48
49
49-- $setup
50-- $setup
50-- == /Running example:/
51-- == /Running example:/
@@ -70,7 +71,7 @@ import Data.Generics.Internal.Profunctor.Prism (prismPRavel)
70-- , age :: Age
71-- , age :: Age
71-- , fieldA :: a
72-- , fieldA :: a
72-- }
73-- }
73−-- deriving (Generic, Show)
74+-- deriving Show
74-- type Name = String
75-- type Name = String
75-- type Age = Int
76-- type Age = Int
76-- dog, cat, duck :: Animal Int
77-- dog, cat, duck :: Animal Int
@@ -128,39 +129,55 @@ instance
128 ( Generic s
129 ( Generic s
129 , ErrorUnless ctor s (HasCtorP ctor (Rep s))
130 , ErrorUnless ctor s (HasCtorP ctor (Rep s))
130 , GAsConstructor' ctor (Rep s) a
131 , GAsConstructor' ctor (Rep s) a
132+ , Defined (Rep s)
133+ (NoGeneric s '[ 'Text "arising from a generic prism focusing on the "
134+ ':<>: QuoteType ctor ':<>: 'Text " constructor of type " ':<>: QuoteType a
135+ , 'Text "in " ':<>: QuoteType s])
136+ (() :: Constraint)
131 ) => AsConstructor' ctor s a where
137 ) => AsConstructor' ctor s a where
132 _Ctor' eta = prismRavel (prismPRavel (repIso . _GCtor @ctor)) eta
138 _Ctor' eta = prismRavel (prismPRavel (repIso . _GCtor @ctor)) eta
133 {-# INLINE[2] _Ctor' #-}
139 {-# INLINE[2] _Ctor' #-}
134
140
135instance
141instance
136− ( Generic s
137− , Generic t
138− , ErrorUnless ctor s (HasCtorP ctor (Rep s))
142+ ( ErrorUnless ctor s (HasCtorP ctor (Rep s))
139 , GAsConstructor' ctor (Rep s) a -- TODO: add a test similar to #62 for prisms
143 , GAsConstructor' ctor (Rep s) a -- TODO: add a test similar to #62 for prisms
140 , GAsConstructor' ctor (Rep (Indexed s)) a'
144 , GAsConstructor' ctor (Rep (Indexed s)) a'
141 , GAsConstructor ctor (Rep s) (Rep t) a b
145 , GAsConstructor ctor (Rep s) (Rep t) a b
142 , t ~ Infer s a' b
146 , t ~ Infer s a' b
143 , GAsConstructor' ctor (Rep (Indexed t)) b'
147 , GAsConstructor' ctor (Rep (Indexed t)) b'
144 , s ~ Infer t b' a
148 , s ~ Infer t b' a
149+ , AsConstructor0 ctor s t a b
145 ) => AsConstructor ctor s t a b where
150 ) => AsConstructor ctor s t a b where
146
151
147 _Ctor = _Ctor0 @ctor
152 _Ctor = _Ctor0 @ctor
148 {-# INLINE[2] _Ctor #-}
153 {-# INLINE[2] _Ctor #-}
149
154
150−-- See Note [Uncluttering type signatures]
155+-- | See Note [Uncluttering type signatures]
156+#if __GLASGOW_HASKELL__ < 804
157+-- >>> :t _Ctor
158+-- _Ctor
159+-- :: (Applicative f, Data.Profunctor.Choice.Choice p,
160+-- AsConstructor ctor s t a b) =>
161+-- p a (f b) -> p s (f t)
162+#else
163+-- >>> :t _Ctor
164+-- _Ctor
165+-- :: (AsConstructor ctor s t a b, Data.Profunctor.Choice.Choice p,
166+-- Applicative f) =>
167+-- p a (f b) -> p s (f t)
168+#endif
151instance {-# OVERLAPPING #-} AsConstructor ctor (Void1 a) (Void1 b) a b where
169instance {-# OVERLAPPING #-} AsConstructor ctor (Void1 a) (Void1 b) a b where
152 _Ctor = undefined
170 _Ctor = undefined
153
171
154instance
172instance
155− ( Generic s
156− , Generic t
157− , ErrorUnless ctor s (HasCtorP ctor (Rep s))
173+ ( ErrorUnless ctor s (HasCtorP ctor (Rep s))
158 , GAsConstructor' ctor (Rep s) a -- TODO: add a test similar to #62 for prisms
174 , GAsConstructor' ctor (Rep s) a -- TODO: add a test similar to #62 for prisms
159 , GAsConstructor' ctor (Rep (Indexed s)) a'
175 , GAsConstructor' ctor (Rep (Indexed s)) a'
160 , GAsConstructor ctor (Rep s) (Rep t) a b
176 , GAsConstructor ctor (Rep s) (Rep t) a b
161 , GAsConstructor' ctor (Rep (Indexed t)) b'
177 , GAsConstructor' ctor (Rep (Indexed t)) b'
162 , UnifyHead s t
178 , UnifyHead s t
163 , UnifyHead t s
179 , UnifyHead t s
180+ , AsConstructor0 ctor s t a b
164 ) => AsConstructor_ ctor s t a b where
181 ) => AsConstructor_ ctor s t a b where
165
182
166 _Ctor_ = _Ctor0 @ctor
183 _Ctor_ = _Ctor0 @ctor
@@ -173,6 +190,11 @@ instance
173 ( Generic s
190 ( Generic s
174 , Generic t
191 , Generic t
175 , GAsConstructor ctor (Rep s) (Rep t) a b
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)
176 ) => AsConstructor0 ctor s t a b where
198 ) => AsConstructor0 ctor s t a b where
177 _Ctor0 = prismRavel (prismPRavel (repIso . _GCtor @ctor))
199 _Ctor0 = prismRavel (prismPRavel (repIso . _GCtor @ctor))
178 {-# INLINE[2] _Ctor0 #-}
200 {-# INLINE[2] _Ctor0 #-}
src/Data/Generics/Sum/Internal/Constructors.hs+1−1
@@ -14,7 +14,7 @@
14-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
15-- |
15-- |
16-- Module : Data.Generics.Sum.Internal.Constructors
16-- Module : Data.Generics.Sum.Internal.Constructors
17−-- Copyright : (C) 2018 Csongor Kiss
17+-- Copyright : (C) 2019 Csongor Kiss
18-- License : BSD3
18-- License : BSD3
19-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20-- Stability : experimental
20-- Stability : experimental
src/Data/Generics/Sum/Internal/Subtype.hs+1−1
@@ -14,7 +14,7 @@
14-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
15-- |
15-- |
16-- Module : Data.Generics.Sum.Internal.Subtype
16-- Module : Data.Generics.Sum.Internal.Subtype
17−-- Copyright : (C) 2018 Csongor Kiss
17+-- Copyright : (C) 2019 Csongor Kiss
18-- License : BSD3
18-- License : BSD3
19-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20-- Stability : experimental
20-- Stability : experimental
src/Data/Generics/Sum/Internal/Typed.hs+1−1
@@ -13,7 +13,7 @@
13-----------------------------------------------------------------------------
13-----------------------------------------------------------------------------
14-- |
14-- |
15-- Module : Data.Generics.Sum.Internal.Typed
15-- Module : Data.Generics.Sum.Internal.Typed
16−-- Copyright : (C) 2018 Csongor Kiss
16+-- Copyright : (C) 2019 Csongor Kiss
17-- License : BSD3
17-- License : BSD3
18-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
18-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19-- Stability : experimental
19-- Stability : experimental
src/Data/Generics/Sum/Subtype.hs+38−2
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE MonoLocalBinds #-}
4{-# LANGUAGE MonoLocalBinds #-}
@@ -11,7 +12,7 @@
11-----------------------------------------------------------------------------
12-----------------------------------------------------------------------------
12-- |
13-- |
13-- Module : Data.Generics.Sum.Subtype
14-- Module : Data.Generics.Sum.Subtype
14−-- Copyright : (C) 2018 Csongor Kiss
15+-- Copyright : (C) 2019 Csongor Kiss
15-- License : BSD3
16-- License : BSD3
16-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17-- Stability : experimental
18-- Stability : experimental
@@ -113,10 +114,45 @@ instance
113 _Sub f = prismRavel (repIso . _GSub . fromIso repIso) f
114 _Sub f = prismRavel (repIso . _GSub . fromIso repIso) f
114 {-# INLINE[2] _Sub #-}
115 {-# INLINE[2] _Sub #-}
115
116
117+-- | Reflexive case
118+-- >>> _Sub # dog :: Animal
119+-- Dog (MkDog {name = "Shep", age = 3})
120+instance {-# OVERLAPPING #-} AsSubtype a a where
121+ _Sub = id
122+ {-# INLINE[2] _Sub #-}
123+
116−-- See Note [Uncluttering type signatures]
124+-- | See Note [Uncluttering type signatures]
125+#if __GLASGOW_HASKELL__ < 804
126+-- >>> :t _Sub
127+--_Sub
128+-- :: (Applicative f, Data.Profunctor.Choice.Choice p,
129+-- AsSubtype sub sup) =>
130+-- p sub (f sub) -> p sup (f sup)
131+-- >>> :t _Sub
132+#else
133+--_Sub
134+-- :: (AsSubtype sub sup, Data.Profunctor.Choice.Choice p,
135+-- Applicative f) =>
136+-- p sub (f sub) -> p sup (f sup)
137+#endif
117instance {-# OVERLAPPING #-} AsSubtype a Void where
138instance {-# OVERLAPPING #-} AsSubtype a Void where
118 injectSub = undefined
139 injectSub = undefined
119 projectSub = undefined
140 projectSub = undefined
141+
142+-- | See Note [Uncluttering type signatures]
143+#if __GLASGOW_HASKELL__ < 804
144+-- >>> :t _Sub @Int
145+-- _Sub @Int
146+-- :: (Applicative f, Data.Profunctor.Choice.Choice p,
147+-- AsSubtype Int sup) =>
148+-- p Int (f Int) -> p sup (f sup)
149+#else
150+-- >>> :t _Sub @Int
151+-- _Sub @Int
152+-- :: (AsSubtype Int sup, Data.Profunctor.Choice.Choice p,
153+-- Applicative f) =>
154+-- p Int (f Int) -> p sup (f sup)
155+#endif
120instance {-# OVERLAPPING #-} AsSubtype Void a where
156instance {-# OVERLAPPING #-} AsSubtype Void a where
121 injectSub = undefined
157 injectSub = undefined
122 projectSub = undefined
158 projectSub = undefined
src/Data/Generics/Sum/Typed.hs+33−2
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE TypeApplications #-}
2{-# LANGUAGE TypeApplications #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
3{-# LANGUAGE AllowAmbiguousTypes #-}
3{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE DataKinds #-}
@@ -13,7 +14,7 @@
13-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
14-- |
15-- |
15-- Module : Data.Generics.Sum.Typed
16-- Module : Data.Generics.Sum.Typed
16−-- Copyright : (C) 2018 Csongor Kiss
17+-- Copyright : (C) 2019 Csongor Kiss
17-- License : BSD3
18-- License : BSD3
18-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19-- Stability : experimental
20-- Stability : experimental
@@ -34,6 +35,7 @@ import Data.Kind
34import GHC.Generics
35import GHC.Generics
35import GHC.TypeLits (TypeError, ErrorMessage (..), Symbol)
36import GHC.TypeLits (TypeError, ErrorMessage (..), Symbol)
36import Data.Generics.Sum.Internal.Typed
37import Data.Generics.Sum.Internal.Typed
38+import Data.Generics.Internal.Errors
37
39
38import Data.Generics.Internal.Families
40import Data.Generics.Internal.Families
39import Data.Generics.Internal.Void
41import Data.Generics.Internal.Void
@@ -109,16 +111,45 @@ instance
109 , as ~ TupleToList a
111 , as ~ TupleToList a
110 , ListTuple a as
112 , ListTuple a as
111 , GAsType (Rep s) as
113 , GAsType (Rep s) as
114+ , Defined (Rep s)
115+ (NoGeneric s '[ 'Text "arising from a generic prism focusing on a constructor of type " ':<>: QuoteType a])
116+ (() :: Constraint)
112 ) => AsType a s where
117 ) => AsType a s where
113
118
114 _Typed eta = prismRavel (prismPRavel (repIso . _GTyped @_ @as . tupled)) eta
119 _Typed eta = prismRavel (prismPRavel (repIso . _GTyped @_ @as . tupled)) eta
115 {-# INLINE[2] _Typed #-}
120 {-# INLINE[2] _Typed #-}
116
121
117−-- See Note [Uncluttering type signatures]
122+-- | See Note [Uncluttering type signatures]
123+#if __GLASGOW_HASKELL__ < 804
124+-- >>> :t _Typed
125+-- _Typed
126+-- :: (Applicative f, Data.Profunctor.Choice.Choice p, AsType a s) =>
127+-- p a (f a) -> p s (f s)
128+#else
129+-- >>> :t _Typed
130+-- _Typed
131+-- :: (AsType a s, Data.Profunctor.Choice.Choice p, Applicative f) =>
132+-- p a (f a) -> p s (f s)
133+#endif
118instance {-# OVERLAPPING #-} AsType a Void where
134instance {-# OVERLAPPING #-} AsType a Void where
119 _Typed = undefined
135 _Typed = undefined
120 injectTyped = undefined
136 injectTyped = undefined
121 projectTyped = undefined
137 projectTyped = undefined
138+
139+-- | See Note [Uncluttering type signatures]
140+#if __GLASGOW_HASKELL__ < 804
141+-- >>> :t _Typed @Int
142+-- _Typed @Int
143+-- :: (Applicative f, Data.Profunctor.Choice.Choice p,
144+-- AsType Int s) =>
145+-- p Int (f Int) -> p s (f s)
146+#else
147+-- >>> :t _Typed @Int
148+-- _Typed @Int
149+-- :: (AsType Int s, Data.Profunctor.Choice.Choice p,
150+-- Applicative f) =>
151+-- p Int (f Int) -> p s (f s)
152+#endif
122instance {-# OVERLAPPING #-} AsType Void a where
153instance {-# OVERLAPPING #-} AsType Void a where
123 _Typed = undefined
154 _Typed = undefined
124 injectTyped = undefined
155 injectTyped = undefined
src/Data/Generics/Wrapped.hs+1−1
@@ -14,7 +14,7 @@
14-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
15-- |
15-- |
16-- Module : Data.Generics.Wrapped
16-- Module : Data.Generics.Wrapped
17−-- Copyright : (C) 2018 Csongor Kiss
17+-- Copyright : (C) 2019 Csongor Kiss
18-- License : BSD3
18-- License : BSD3
19-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
19-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
20-- Stability : experimental
20-- Stability : experimental