├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── cabal.haskell-ci ├── cabal.project ├── generic-deriving.cabal ├── misc └── Tuples.hs ├── src └── Generics │ ├── Deriving.hs │ └── Deriving │ ├── Base.hs │ ├── ConNames.hs │ ├── Copoint.hs │ ├── Default.hs │ ├── Enum.hs │ ├── Eq.hs │ ├── Foldable.hs │ ├── Functor.hs │ ├── Instances.hs │ ├── Monoid.hs │ ├── Monoid │ └── Internal.hs │ ├── Semigroup.hs │ ├── Semigroup │ └── Internal.hs │ ├── Show.hs │ ├── TH.hs │ ├── TH │ ├── Internal.hs │ └── Post4_9.hs │ ├── Traversable.hs │ └── Uniplate.hs └── tests ├── DefaultSpec.hs ├── EmptyCaseSpec.hs ├── ExampleSpec.hs ├── Spec.hs ├── T68Spec.hs ├── T80Spec.hs ├── T82Spec.hs └── TypeInTypeSpec.hs /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' '--config=cabal.haskell-ci' 'cabal.project' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20250216 12 | # 13 | # REGENDATA ("0.19.20250216",["github","--config=cabal.haskell-ci","cabal.project"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | linux: 21 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 22 | runs-on: ubuntu-24.04 23 | timeout-minutes: 24 | 60 25 | container: 26 | image: buildpack-deps:jammy 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-9.12.1 32 | compilerKind: ghc 33 | compilerVersion: 9.12.1 34 | setup-method: ghcup 35 | allow-failure: false 36 | - compiler: ghc-9.10.1 37 | compilerKind: ghc 38 | compilerVersion: 9.10.1 39 | setup-method: ghcup 40 | allow-failure: false 41 | - compiler: ghc-9.8.4 42 | compilerKind: ghc 43 | compilerVersion: 9.8.4 44 | setup-method: ghcup 45 | allow-failure: false 46 | - compiler: ghc-9.6.6 47 | compilerKind: ghc 48 | compilerVersion: 9.6.6 49 | setup-method: ghcup 50 | allow-failure: false 51 | - compiler: ghc-9.4.8 52 | compilerKind: ghc 53 | compilerVersion: 9.4.8 54 | setup-method: ghcup 55 | allow-failure: false 56 | - compiler: ghc-9.2.8 57 | compilerKind: ghc 58 | compilerVersion: 9.2.8 59 | setup-method: ghcup 60 | allow-failure: false 61 | - compiler: ghc-9.0.2 62 | compilerKind: ghc 63 | compilerVersion: 9.0.2 64 | setup-method: ghcup 65 | allow-failure: false 66 | - compiler: ghc-8.10.7 67 | compilerKind: ghc 68 | compilerVersion: 8.10.7 69 | setup-method: ghcup 70 | allow-failure: false 71 | - compiler: ghc-8.8.4 72 | compilerKind: ghc 73 | compilerVersion: 8.8.4 74 | setup-method: ghcup 75 | allow-failure: false 76 | - compiler: ghc-8.6.5 77 | compilerKind: ghc 78 | compilerVersion: 8.6.5 79 | setup-method: ghcup 80 | allow-failure: false 81 | - compiler: ghc-8.4.4 82 | compilerKind: ghc 83 | compilerVersion: 8.4.4 84 | setup-method: ghcup 85 | allow-failure: false 86 | - compiler: ghc-8.2.2 87 | compilerKind: ghc 88 | compilerVersion: 8.2.2 89 | setup-method: ghcup 90 | allow-failure: false 91 | - compiler: ghc-8.0.2 92 | compilerKind: ghc 93 | compilerVersion: 8.0.2 94 | setup-method: ghcup 95 | allow-failure: false 96 | fail-fast: false 97 | steps: 98 | - name: apt-get install 99 | run: | 100 | apt-get update 101 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 libnuma-dev 102 | - name: Install GHCup 103 | run: | 104 | mkdir -p "$HOME/.ghcup/bin" 105 | curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup" 106 | chmod a+x "$HOME/.ghcup/bin/ghcup" 107 | - name: Install cabal-install 108 | run: | 109 | "$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 110 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" 111 | - name: Install GHC (GHCup) 112 | if: matrix.setup-method == 'ghcup' 113 | run: | 114 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 115 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 116 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 117 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 118 | echo "HC=$HC" >> "$GITHUB_ENV" 119 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 120 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 121 | env: 122 | HCKIND: ${{ matrix.compilerKind }} 123 | HCNAME: ${{ matrix.compiler }} 124 | HCVER: ${{ matrix.compilerVersion }} 125 | - name: Set PATH and environment variables 126 | run: | 127 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 128 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 129 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 130 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 131 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 132 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 133 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 134 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 135 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 136 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 137 | env: 138 | HCKIND: ${{ matrix.compilerKind }} 139 | HCNAME: ${{ matrix.compiler }} 140 | HCVER: ${{ matrix.compilerVersion }} 141 | - name: env 142 | run: | 143 | env 144 | - name: write cabal config 145 | run: | 146 | mkdir -p $CABAL_DIR 147 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 180 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 181 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 182 | rm -f cabal-plan.xz 183 | chmod a+x $HOME/.cabal/bin/cabal-plan 184 | cabal-plan --version 185 | - name: checkout 186 | uses: actions/checkout@v4 187 | with: 188 | path: source 189 | - name: initial cabal.project for sdist 190 | run: | 191 | touch cabal.project 192 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 193 | cat cabal.project 194 | - name: sdist 195 | run: | 196 | mkdir -p sdist 197 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 198 | - name: unpack 199 | run: | 200 | mkdir -p unpacked 201 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 202 | - name: generate cabal.project 203 | run: | 204 | PKGDIR_generic_deriving="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/generic-deriving-[0-9.]*')" 205 | echo "PKGDIR_generic_deriving=${PKGDIR_generic_deriving}" >> "$GITHUB_ENV" 206 | rm -f cabal.project cabal.project.local 207 | touch cabal.project 208 | touch cabal.project.local 209 | echo "packages: ${PKGDIR_generic_deriving}" >> cabal.project 210 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package generic-deriving" >> cabal.project ; fi 211 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi 212 | cat >> cabal.project <> cabal.project.local 217 | cat cabal.project 218 | cat cabal.project.local 219 | - name: dump install plan 220 | run: | 221 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 222 | cabal-plan 223 | - name: restore cache 224 | uses: actions/cache/restore@v4 225 | with: 226 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 227 | path: ~/.cabal/store 228 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 229 | - name: install dependencies 230 | run: | 231 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 232 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 233 | - name: build 234 | run: | 235 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 236 | - name: tests 237 | run: | 238 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 239 | - name: cabal check 240 | run: | 241 | cd ${PKGDIR_generic_deriving} || false 242 | ${CABAL} -vnormal check 243 | - name: haddock 244 | run: | 245 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 246 | - name: save cache 247 | if: always() 248 | uses: actions/cache/save@v4 249 | with: 250 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 251 | path: ~/.cabal/store 252 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | cabal.project.local~ 21 | .HTF/ 22 | .ghc.environment.* 23 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # 1.14.6 [2024.12.05] 2 | * Drop support for GHC 7.10 and earlier. 3 | 4 | # 1.14.5 [2023.08.06] 5 | * Support building with `template-haskell-2.21.*` (GHC 9.8). 6 | * The Template Haskell machinery now uses `TemplateHaskellQuotes` when 7 | building with GHC 8.0+ instead of manually constructing each Template Haskell 8 | `Name`. A consequence of this is that `generic-deriving` will now build with 9 | GHC 9.8, as `TemplateHaskellQuotes` abstracts over some internal Template 10 | Haskell changes introduced in 9.8. 11 | 12 | # 1.14.4 [2023.04.30] 13 | * Allow building with GHC backends where `HTYPE_SIG_ATOMIC_T` is not defined, 14 | such as the WASM backend. 15 | * Place `INLINE [1]` pragmas on `from` and `to` implementations when types 16 | don't have too many constructors or fields, following the heuristics that GHC 17 | 9.2+ uses for `Generic` deriving. 18 | 19 | # 1.14.3 [2023.02.27] 20 | * Support `th-abstraction-0.5.*`. 21 | 22 | # 1.14.2 [2022.07.23] 23 | * Fix a bug in which `deriveAll1` could generate ill kinded code when using 24 | `kindSigOptions=False`, or when using GHC 8.0 or earlier. 25 | * Fix a bug in which `deriveAll1` would reject data types whose last type 26 | variable has a kind besides `Type` or `k` on GHC 8.2 or later. 27 | 28 | # 1.14.1 [2021.08.30] 29 | * Backport the `Generic(1)` instances introduced for tuples (8 through 15) in 30 | `base-4.16`. 31 | * Make the test suite compile on GHC 9.2 or later. 32 | * Always import `Data.List` qualified to fix the build with recent GHCs. 33 | 34 | # 1.14 [2020.09.30] 35 | * Remove instances for `Data.Semigroup.Option`, which is deprecated as of 36 | `base-4.15.0.0`. 37 | * Allow building with `template-haskell-2.17.0.0` (GHC 9.0). 38 | * Fix a bug in which `deriveAll1` would needlessly reject data types whose last 39 | type parameter appears as an oversaturated argument to a type family. 40 | 41 | # 1.13.1 [2019.11.26] 42 | * Backport the `Generic(1)` instances for `Kleisli` introduced in `base-4.14`. 43 | 44 | # 1.13 [2019.08.27] 45 | * Make `GSemigroup` a superclass of `GMonoid`. Similarly, make 46 | `GSemigroup'` a superclass of `GMonoid'`. 47 | * In the instance `GMonoid (Maybe a)`, relax the constraint on `a` from 48 | `GMonoid` to `GSemigroup`. 49 | 50 | # 1.12.4 [2019.04.26] 51 | * Support `th-abstraction-0.3.0.0` or later. 52 | 53 | # 1.12.3 [2019.02.09] 54 | * Support `template-haskell-2.15`. 55 | * Add a `gshowList` method to `GShow`, which lets us avoid the need for 56 | `OverlappingInstances` in `Generics.Deriving.TH`. As a consequence, the 57 | `GShow String` instance has been removed, as it is now fully subsumed by 58 | the `GShow [a]` instance (with which it previously overlapped). 59 | * Functions in `Generics.Deriving.TH` now balance groups of `(:*:)` and `(:+:)` 60 | as much as possible (`deriving Generic` was already performing this 61 | optimization, and now `generic-deriving` does too). 62 | * Add a `Generics.Deriving.Default` module demonstrating and explaining 63 | how and why to use `DerivingVia`. There is also a test suite with 64 | further examples. 65 | 66 | # 1.12.2 [2018.06.28] 67 | * Backport the `Generic(1)` instances for `Data.Ord.Down`, introduced in 68 | `base-4.12`. Add `GEq`, `GShow`, `GSemigroup`, `GMonoid`, `GFunctor`, 69 | `GFoldable`, `GTraversable`, and `GCopoint` instances for `Down`. 70 | * Refactor internals using `th-abstraction`. 71 | * Adapt to `Maybe` moving to `GHC.Maybe` in GHC 8.6. 72 | 73 | # 1.12.1 [2018.01.11] 74 | * Remove a test that won't work on GHC 8.4. 75 | 76 | # 1.12 [2017.12.07] 77 | * Adapt to the `EmptyDataDeriving` proposal (introduced in GHC 8.4): 78 | * `Generics.Deriving.TH` now derives `to(1)` and `from(1)` implementations 79 | for empty data types that are strict in the argument. 80 | * Introduce an `EmptyCaseOptions` field to `Options` in 81 | `Generics.Deriving.TH`, which controls whether generated `from(1)`/`to(1)` 82 | implementations for empty data types should use the `EmptyCase` extension 83 | or not (as is the case in GHC 8.4). 84 | * Add `mkFrom0Options`, `mkFrom1Options`, `mkTo0Options`, and `mkTo1Options` 85 | functions to `Generics.Deriving.TH`, which take `EmptyCaseOptions` as 86 | arguments. 87 | * The backported instances for `V1` are now maximally lazy, as per 88 | `EmptyDataDeriving`. (Previously, some instances would unnecessarily force 89 | their argument, such as the `Eq` and `Ord` instances.) 90 | * Add instances for `V1` in `Generics.Deriving.Copoint`, `.Eq`, `.Foldable`, 91 | `.Functor`, `.Show`, and `.Traversable`. 92 | * Remove the bitrotting `simplInstance` function from `Generics.Deriving.TH`. 93 | 94 | # 1.11.2 [2017.04.10] 95 | * Add `GEq`, `GShow`, `GEnum`, and `GIx` instances for the new data types 96 | in `Foreign.C.Types` (`CBool`) and `System.Posix.Types` (`CBlkSize`, 97 | `CBlkCnt`, `CClockId`, `CFsBlkCnt`, `CFsFilCnt`, `CId`, `CKey`, and `CTimer`) 98 | introduced in `base-4.10.0.0` 99 | 100 | # 1.11.1 [2016.09.10] 101 | * Fix Template Haskell regression involving data families 102 | * Convert examples to test suite 103 | * Backport missing `Data` and `Typeable` instances for `Rec1`, `M1`, `(:*:)`, 104 | `(:+:)`, and `(:.:)` 105 | 106 | # 1.11 107 | * The behavior of functions in `Generics.Deriving.TH` have changed with respect 108 | to when type synonyms are generated for `Rep(1)` definitions. In particular: 109 | 110 | * By default, `deriveRepresentable(1)` will no longer define its `Rep(1)` 111 | type family instance in terms of the type synonym that has to be generated 112 | with `deriveRep(1)`. Similarly, `deriveAll(1)` and `deriveAll0And1` will no 113 | longer generate a type synonym. Instead, they will generate `Generic(1)` 114 | instances that directly define the `Rep(1)` instance inline. If you wish 115 | to revert to the old behavior, you will need to use the variants of those 116 | functions suffixed with `-Options`. 117 | * New functions `makeRep0Inline` and `makeRep1Inline` have been added which, 118 | for most purposes, should replace uses of `makeRep0`/`makeRep0FromType` 119 | and `makeRep1`/`makeRep1FromType` (but see the next bullet point for a 120 | caveat). 121 | * The use of `deriveRep(1)`, `makeRep0`/`makeRep0FromType`, and 122 | `makeRep1`/`makeRep1FromType` are now discouraged, but those functions are 123 | still available. The reason is that on GHC 7.0/7.2/7.4, it is impossible to use 124 | `makeRep0Inline`/`makeRep1Inline` due to a GHC bug. Therefore, you must use 125 | `makeRep0`/`makeRep1` and `deriveRep(1)` on GHC 7.0/7.2/7.4 out of necessity. 126 | 127 | These changes make dealing with `Generic` instances that involve `PolyKinds` 128 | and `TypeInType` much easier. 129 | * All functions suffixed in `-WithKindSigs` in `Generics.Deriving.TH` have been 130 | removed in favor of a more sensible `-Options` suffixing scheme. The ability to 131 | toggle whether explicit kind signatures are used on type variable binders has 132 | been folded into `KindSigOptions`, which is an explicit argument to 133 | `deriveRep0Options`/`deriveRep1Options` and also a field in the more general 134 | 'Options' data type. 135 | * Furthermore, the behavior of derived instances' kind signatures has changed. 136 | By default, the TH code will now _always_ use explicit kind signatures 137 | whenever possible, regardless of whether you're working with plain data types 138 | or data family instances. This makes working with `TypeInType` less 139 | surprising, but at the cost of making it slightly more awkward to work with 140 | derived `Generic1` instances that constrain kinds to `*` by means of `(:.:)`. 141 | * Since `Generic1` is polykinded on GHC 8.2 and later, the functions in 142 | `Generics.Deriving.TH` will no longer unify the kind of the last type 143 | parameter to be `*`. 144 | * Fix a bug in which `makeRep` (and similarly named functions) would not check 145 | whether the argument type can actually have a well kinded `Generic(1)` 146 | instance. 147 | * Backport missing `Foldable` and `Traversable` instances for `Rec1` 148 | 149 | # 1.10.7 150 | * Renamed internal modules to avoid using apostrophes (averting this bug: 151 | https://github.com/haskell/cabal/issues/3631) 152 | 153 | # 1.10.6 154 | * A new `base-4-9` Cabal flag was added to more easily facilitate installing 155 | `generic-deriving` with manually installed versions of `template-haskell`. 156 | 157 | # 1.10.5 158 | * Apply an optimization to generated `to(1)`/`from(1)` instances that factors out 159 | common occurrences of `M1`. See 160 | http://git.haskell.org/ghc.git/commit/9649fc0ae45e006c2ed54cc5ea2414158949fadb 161 | * Export internal typeclass names 162 | * Fix Haddock issues with GHC 7.8 163 | 164 | # 1.10.4.1 165 | * Fix Haddock parsing issue on GHC 8.0 166 | 167 | # 1.10.4 168 | * Backported `MonadPlus` and `MonadZip` instances for `U1`, and made the 169 | `Functor`, `Foldable`, `Traversable`, `Alternative`, and `Monad` instances 170 | for `U1` lazier to correspond with `base-4.9` 171 | 172 | # 1.10.3 173 | * Backported `Enum`, `Bounded`, `Ix`, `Functor`, `Applicative`, `Monad`, 174 | `MonadFix`, `MonadPlus`, `MonadZip`, `Foldable`, `Traversable`, and 175 | `Data` instances (introduced in `base-4.9`) for datatypes in the 176 | `Generics.Deriving.Base` module 177 | 178 | # 1.10.2 179 | * Fix TH regression on GHC 7.0 180 | 181 | # 1.10.1 182 | * Added `Generics.Deriving.Semigroup` 183 | * Added `GMonoid` instance for `Data.Monoid.Alt` 184 | * Fixed a bug in the `GEnum` instances for unsigned `Integral` types 185 | * Added `Safe`/`Trustworthy` pragmas 186 | * Made instances polykinded where possible 187 | 188 | # 1.10.0 189 | * On GHC 8.0 and up, `Generics.Deriving.TH` uses the new type literal-based 190 | machinery 191 | * Rewrote the Template Haskell code to be robust. Among other things, this fixes 192 | a bug with deriving Generic1 instances on GHC 7.8, and makes it easier to 193 | derive Generic1 instances for datatypes that utilize GHC 8.0's `-XTypeInType` 194 | extension. 195 | * Added `deriveAll0` and `makeRep0` for symmetry with `deriveAll1` and 196 | `makeRep1` 197 | * Added`makeRep0FromType` and `makeRep1FromType` to make it easier to pass 198 | in the type instance (instead of having to pass each individual type 199 | variable, which can be error-prone) 200 | * Added functions with the suffix `-WithKindSigs` to allow generating type 201 | synonyms with explicit kind signatures in the presence of kind-polymorphic 202 | type variables. This is necessary for some datatypes that use 203 | `-XTypeInType` to have derived `Generic(1)` instances, but is not turned on 204 | by default since the TH kind inference is not perfect and would cause 205 | otherwise valid code to be rejected. Use only if you know what you are doing. 206 | * Fixed bug where a datatype with a single, nullary constructor would generate 207 | incorrect `Generic` instances 208 | * More sensible `GEnum` instances for fixed-size integral types 209 | * Added `GCopoint`, `GEnum`, `GEq`, `GFoldable`, `GFunctor`, `GMonoid`, 210 | `GShow`, and `GTraversable` instances for datatypes introduced in GHC 8.0 211 | * Backported `Generic(1)` instances added in GHC 8.0. Specifically, `Generic` 212 | instances for `Complex` (`base-4.4` and later) `ExitCode`, and `Version`; and 213 | `Generic1` instances for `Complex` (`base-4.4` and later) and `Proxy` 214 | (`base-4.7` and later). Added `GEnum`, `GEq`, `GFoldable`, `GFunctor`, `GIx`, 215 | `GShow`, and `GTraversable` instances for these datatypes where appropriate. 216 | 217 | # 1.9.0 218 | * Allow deriving of Generic1 using Template Haskell 219 | * Allow deriving of Generic(1) for data families 220 | * Allow deriving of Generic(1) for constructor-less plain datatypes (but not 221 | data families, due to technical restrictions) 222 | * Support for unboxed representation types on GHC 7.11+ 223 | * More `GCopoint`, `GEnum`, `GEq`, `GFoldable`, `GFunctor`, `GIx`, `GMonoid`, 224 | `GShow`, and `GTraversable` instances 225 | * The field accessors for the `(:+:)` type in `Generics.Deriving.Base` have 226 | been removed to be consistent with `GHC.Generics` 227 | * Ensure that TH generates definitions for isNewtype and packageName, if a 228 | recent-enough version of GHC is used 229 | * Ensure that TH-generated names are unique for a given data type's module and 230 | package (similar in spirit to Trac #10487) 231 | * Allow building on stage-1 compilers 232 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2010 Universiteit Utrecht 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, 5 | are permitted provided that the following conditions are met: 6 | 7 | 1. Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | 2. Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | 3. Neither the name of Universiteit Utrecht nor the names of its contributors 15 | may be used to endorse or promote products derived from this software without 16 | specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 19 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR 22 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 23 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 24 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 25 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 26 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 27 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | 29 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## `generic-deriving`: Generic programming library for generalised deriving 2 | [![Hackage](https://img.shields.io/hackage/v/generic-deriving.svg)][Hackage: generic-deriving] 3 | [![Hackage Dependencies](https://img.shields.io/hackage-deps/v/generic-deriving.svg)](http://packdeps.haskellers.com/reverse/generic-deriving) 4 | [![Haskell Programming Language](https://img.shields.io/badge/language-Haskell-blue.svg)][Haskell.org] 5 | [![BSD3 License](http://img.shields.io/badge/license-BSD3-brightgreen.svg)][tl;dr Legal: BSD3] 6 | [![Build Status](https://github.com/dreixel/generic-deriving/workflows/Haskell-CI/badge.svg)](https://github.com/dreixel/generic-deriving/actions?query=workflow%3AHaskell-CI) 7 | 8 | [Hackage: generic-deriving]: 9 | http://hackage.haskell.org/package/generic-deriving 10 | "generic-deriving package on Hackage" 11 | [Haskell.org]: 12 | http://www.haskell.org 13 | "The Haskell Programming Language" 14 | [tl;dr Legal: BSD3]: 15 | https://tldrlegal.com/license/bsd-3-clause-license-%28revised%29 16 | "BSD 3-Clause License (Revised)" 17 | 18 | This package provides functionality for generalising the deriving mechanism 19 | in Haskell to arbitrary classes. It was first described in the paper: 20 | 21 | * [A generic deriving mechanism for Haskell](http://dreixel.net/research/pdf/gdmh.pdf). 22 | Jose Pedro Magalhaes, Atze Dijkstra, Johan Jeuring, and Andres Loeh. Haskell'10. 23 | 24 | The current implementation integrates with the new GHC Generics. See 25 | http://www.haskell.org/haskellwiki/GHC.Generics for more information. 26 | Template Haskell code is provided for supporting older GHCs. 27 | 28 | This library is organized as follows: 29 | 30 | * `Generics.Deriving.Base` defines the core functionality for GHC generics, 31 | including the `Generic(1)` classes and representation data types. 32 | On modern versions of GHC, this simply re-exports `GHC.Generics` from 33 | `base`. On older versions of GHC, this module backports parts of 34 | `GHC.Generics` that were not included at the time, including `Generic(1)` 35 | instances. 36 | 37 | * `Generics.Deriving.TH` implements Template Haskell functionality for 38 | deriving instances of `Generic(1)`. 39 | 40 | * Educational code: in order to provide examples of how to define and use 41 | `GHC.Generics`-based defaults, this library offers a number of modules 42 | which define examples of type classes along with default implementations 43 | for the classes' methods. Currently, the following modules are provided: 44 | 45 | * `Generics.Deriving.Copoint` 46 | 47 | * `Generics.Deriving.ConNames` 48 | 49 | * `Generics.Deriving.Enum` 50 | 51 | * `Generics.Deriving.Eq` 52 | 53 | * `Generics.Deriving.Foldable` 54 | 55 | * `Generics.Deriving.Functor` 56 | 57 | * `Generics.Deriving.Monoid` 58 | 59 | * `Generics.Deriving.Semigroup` 60 | 61 | * `Generics.Deriving.Show` 62 | 63 | * `Generics.Deriving.Traversable` 64 | 65 | * `Generics.Deriving.Uniplate` 66 | 67 | It is worth emphasizing that these modules are primarly intended for 68 | educational purposes. Many of the classes in these modules resemble other 69 | commonly used classes—for example, `GShow` from `Generics.Deriving.Show` 70 | resembles `Show` from `base`—but in general, the classes that 71 | `generic-deriving` defines are not drop-in replacements. Moreover, the 72 | generic defaults that `generic-deriving` provide often make simplifying 73 | assumptions that may violate expectations of how these classes might work 74 | elsewhere. For example, the generic default for `GShow` does not behave 75 | exactly like `deriving Show` would. 76 | 77 | If you are seeking `GHC.Generics`-based defaults for type classes in 78 | `base`, consider using the 79 | [`generic-data`](http://hackage.haskell.org/package/generic-data) library. 80 | 81 | * `Generics.Deriving.Default` provides newtypes that allow leveraging the 82 | generic defaults in this library using the `DerivingVia` GHC language 83 | extension. 84 | 85 | * `Generics.Deriving` re-exports `Generics.Deriving.Base`, 86 | `Generics.Deriving.Default`, and a selection of educational modules. 87 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Distribution.Simple 4 | 5 | main :: IO () 6 | main = defaultMain 7 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | distribution: jammy 2 | no-tests-no-benchmarks: False 3 | unconstrained: False 4 | local-ghc-options: -Werror 5 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | -------------------------------------------------------------------------------- /generic-deriving.cabal: -------------------------------------------------------------------------------- 1 | name: generic-deriving 2 | version: 1.14.6 3 | synopsis: Generic programming library for generalised deriving. 4 | description: 5 | 6 | This package provides functionality for generalising the deriving mechanism 7 | in Haskell to arbitrary classes. It was first described in the paper: 8 | . 9 | * /A generic deriving mechanism for Haskell/. 10 | Jose Pedro Magalhaes, Atze Dijkstra, Johan Jeuring, and Andres Loeh. 11 | Haskell'10. 12 | . 13 | The current implementation integrates with the new GHC Generics. See 14 | for more information. 15 | Template Haskell code is provided for supporting older GHCs. 16 | . 17 | This library is organized as follows: 18 | . 19 | * "Generics.Deriving.Base" defines the core functionality for GHC generics, 20 | including the @Generic(1)@ classes and representation data types. 21 | On modern versions of GHC, this simply re-exports "GHC.Generics" from 22 | @base@. On older versions of GHC, this module backports parts of 23 | "GHC.Generics" that were not included at the time, including @Generic(1)@ 24 | instances. 25 | . 26 | * "Generics.Deriving.TH" implements Template Haskell functionality for 27 | deriving instances of @Generic(1)@. 28 | . 29 | * Educational code: in order to provide examples of how to define and use 30 | "GHC.Generics"-based defaults, this library offers a number of modules 31 | which define examples of type classes along with default implementations 32 | for the classes' methods. Currently, the following modules are provided: 33 | "Generics.Deriving.Copoint", "Generics.Deriving.ConNames", 34 | "Generics.Deriving.Enum", "Generics.Deriving.Eq", 35 | "Generics.Deriving.Foldable", "Generics.Deriving.Functor", 36 | "Generics.Deriving.Monoid", "Generics.Deriving.Semigroup", 37 | "Generics.Deriving.Show", "Generics.Deriving.Traversable", 38 | and "Generics.Deriving.Uniplate". 39 | . 40 | It is worth emphasizing that these modules are primarly intended for 41 | educational purposes. Many of the classes in these modules resemble other 42 | commonly used classes—for example, @GShow@ from "Generics.Deriving.Show" 43 | resembles @Show@ from @base@—but in general, the classes that 44 | @generic-deriving@ defines are not drop-in replacements. Moreover, the 45 | generic defaults that @generic-deriving@ provide often make simplifying 46 | assumptions that may violate expectations of how these classes might work 47 | elsewhere. For example, the generic default for @GShow@ does not behave 48 | exactly like @deriving Show@ would. 49 | . 50 | If you are seeking "GHC.Generics"-based defaults for type classes in 51 | @base@, consider using the 52 | @@ library. 53 | . 54 | * "Generics.Deriving.Default" provides newtypes that allow leveraging the 55 | generic defaults in this library using the @DerivingVia@ GHC language 56 | extension. 57 | . 58 | * "Generics.Deriving" re-exports "Generics.Deriving.Base", 59 | "Generics.Deriving.Default", and a selection of educational modules. 60 | 61 | homepage: https://github.com/dreixel/generic-deriving 62 | bug-reports: https://github.com/dreixel/generic-deriving/issues 63 | category: Generics 64 | copyright: 2011-2013 Universiteit Utrecht, University of Oxford 65 | license: BSD3 66 | license-file: LICENSE 67 | author: José Pedro Magalhães 68 | maintainer: generics@haskell.org 69 | stability: experimental 70 | build-type: Simple 71 | cabal-version: >= 1.10 72 | tested-with: 73 | GHC == 8.0.2 74 | , GHC == 8.2.2 75 | , GHC == 8.4.4 76 | , GHC == 8.6.5 77 | , GHC == 8.8.4 78 | , GHC == 8.10.7 79 | , GHC == 9.0.2 80 | , GHC == 9.2.8 81 | , GHC == 9.4.8 82 | , GHC == 9.6.6 83 | , GHC == 9.8.4 84 | , GHC == 9.10.1 85 | , GHC == 9.12.1 86 | 87 | extra-source-files: CHANGELOG.md 88 | , README.md 89 | 90 | source-repository head 91 | type: git 92 | location: https://github.com/dreixel/generic-deriving 93 | 94 | library 95 | hs-source-dirs: src 96 | exposed-modules: Generics.Deriving 97 | Generics.Deriving.Base 98 | Generics.Deriving.Instances 99 | Generics.Deriving.Copoint 100 | Generics.Deriving.ConNames 101 | Generics.Deriving.Default 102 | Generics.Deriving.Enum 103 | Generics.Deriving.Eq 104 | Generics.Deriving.Foldable 105 | Generics.Deriving.Functor 106 | Generics.Deriving.Monoid 107 | Generics.Deriving.Semigroup 108 | Generics.Deriving.Show 109 | Generics.Deriving.Traversable 110 | Generics.Deriving.Uniplate 111 | 112 | Generics.Deriving.TH 113 | 114 | other-modules: Generics.Deriving.Monoid.Internal 115 | Generics.Deriving.Semigroup.Internal 116 | Generics.Deriving.TH.Internal 117 | Generics.Deriving.TH.Post4_9 118 | Paths_generic_deriving 119 | 120 | build-depends: base >= 4.9 && < 5 121 | , containers >= 0.1 && < 0.9 122 | , ghc-prim < 1 123 | , template-haskell >= 2.11 && < 2.24 124 | -- TODO: Eventually, we should bump the lower version 125 | -- bounds to >=0.6 so that we can remove some CPP in 126 | -- Generics.Deriving.TH.Internal. 127 | , th-abstraction >= 0.4 && < 0.8 128 | 129 | default-language: Haskell2010 130 | ghc-options: -Wall 131 | 132 | test-suite spec 133 | type: exitcode-stdio-1.0 134 | main-is: Spec.hs 135 | other-modules: DefaultSpec 136 | EmptyCaseSpec 137 | ExampleSpec 138 | T68Spec 139 | T80Spec 140 | T82Spec 141 | TypeInTypeSpec 142 | build-depends: base 143 | , generic-deriving 144 | , hspec >= 2 && < 3 145 | , template-haskell 146 | build-tool-depends: hspec-discover:hspec-discover 147 | hs-source-dirs: tests 148 | default-language: Haskell2010 149 | ghc-options: -Wall -threaded -rtsopts 150 | if impl(ghc >= 8.6) 151 | ghc-options: -Wno-star-is-type 152 | -------------------------------------------------------------------------------- /misc/Tuples.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | import Data.List (intersperse) 5 | import System.Environment (getArgs) 6 | 7 | 8 | -------------------------------------------------------------------------------- 9 | -- Tuples 10 | -------------------------------------------------------------------------------- 11 | 12 | u, tab, newline, sp :: ShowS 13 | u = showChar '_' 14 | tab = showString " " 15 | newline = showChar '\n' 16 | sp = showChar ' ' 17 | vars :: [ShowS] 18 | vars = map ((showChar 'x' .) . shows) [1..] 19 | paren :: ShowS -> ShowS 20 | paren x = showChar '(' . x . showChar ')' 21 | concatS :: [ShowS] -> ShowS 22 | concatS = foldr (.) id 23 | 24 | tuple :: Int -> ShowS 25 | tuple m = showChar '(' . showString (replicate (m-1) ',') . showChar ')' 26 | 27 | unlinesS :: [ShowS] -> ShowS 28 | unlinesS = foldr1 (\a b -> a . newline . b) 29 | 30 | createDataDecls :: Int -> ShowS 31 | createDataDecls m = let n = shows m 32 | s = showString "data Tuple" 33 | in s . n . u . newline . s . n . showChar 'C' . u 34 | 35 | dataInstance :: Int -> ShowS 36 | dataInstance m = let n = shows m 37 | l1 = showString "instance Datatype Tuple" 38 | . n . u . showString " where" 39 | l2 = tab . showString "datatypeName _ = \"" 40 | . tuple m . showChar '"' 41 | l3 = tab . showString "moduleName _ = \"Prelude\"" 42 | in unlinesS [l1, l2, l3] 43 | 44 | conInstance :: Int -> ShowS 45 | conInstance m = let n = shows m 46 | in showString "instance Constructor Tuple" . n . u 47 | . showString " where conName _ = \"" . tuple m . showChar '"' 48 | 49 | -- x is 0 or 1 50 | pairPat, repName, rep, repInst, funs :: Int -> Int -> ShowS 51 | pairPat x m = tuple m . sp . 52 | (concatS $ intersperse sp (take (m - x) vars)) 53 | 54 | repName x m = showString "Rep" . shows x . showString "Tuple" . shows m . u 55 | 56 | rep x m = let n = shows m 57 | v = take (m - x) vars 58 | vs = concatS $ intersperse sp v 59 | recs = concatS $ intersperse (showString " :*: ") $ 60 | map (showString "Rec0 " .) v 61 | last = showString $ if (x == 1) then " :*: Par1" else "" 62 | body = recs . last 63 | in showString "type " . repName x m . sp . vs 64 | . showString " = D1 Tuple" . n . showString "_ (C1 Tuple" . n 65 | . showString "C_ (S1 NoSelector (" . body . showString ")))" 66 | 67 | repInst x m = let n = shows m 68 | y = shows x 69 | vs = concatS $ intersperse sp (take (m - x) vars) 70 | in showString "instance Representable" . y . sp 71 | . paren (pairPat x m) . showString " (" . repName x m . sp 72 | . vs . showString ") where" 73 | . newline . funs x m 74 | 75 | funs x m = 76 | let v = take (m - x) vars 77 | recs = concatS $ intersperse (showString " :*: ") $ 78 | map (showString "K1 " .) v 79 | last = if (x == 1) then showString " :*: Par1 " . (vars !! (m-x)) 80 | else showString "" 81 | eq = showChar '=' 82 | body = paren (showString "M1 (M1 (M1 (" . recs . last . showString ")))") 83 | pat = paren (pairPat 0 m) 84 | in tab . concatS (intersperse sp [showString "from" . shows x, pat, eq, body]) 85 | . newline . 86 | tab . concatS (intersperse sp [showString "to" . shows x, body, eq, pat]) 87 | 88 | 89 | gen :: Int -> ShowS 90 | gen m = concatS (intersperse (newline . newline) 91 | [ createDataDecls m, dataInstance m, conInstance m 92 | , rep 0 m, repInst 0 m, rep 1 m, repInst 1 m]) 93 | 94 | main :: IO () 95 | main = do let r :: [String] -> Int 96 | r (n:_) = read n 97 | r _ = error "Integer argument missing" 98 | com = showString "\n\n" 99 | . concatS (map showChar (replicate 80 '-')) 100 | . showString "\n\n" 101 | a <- getArgs 102 | (putStr . ($ "")) $ concatS $ 103 | intersperse com [ gen m | m <- [2..(r a)]] 104 | -------------------------------------------------------------------------------- /src/Generics/Deriving.hs: -------------------------------------------------------------------------------- 1 | 2 | module Generics.Deriving ( 3 | 4 | module Generics.Deriving.Base, 5 | module Generics.Deriving.Copoint, 6 | module Generics.Deriving.ConNames, 7 | module Generics.Deriving.Default, 8 | module Generics.Deriving.Enum, 9 | module Generics.Deriving.Eq, 10 | module Generics.Deriving.Functor, 11 | module Generics.Deriving.Show, 12 | module Generics.Deriving.Uniplate 13 | 14 | ) where 15 | 16 | import Generics.Deriving.Base 17 | import Generics.Deriving.Copoint 18 | import Generics.Deriving.ConNames 19 | import Generics.Deriving.Default 20 | import Generics.Deriving.Enum 21 | import Generics.Deriving.Eq 22 | import Generics.Deriving.Functor 23 | import Generics.Deriving.Show 24 | import Generics.Deriving.Uniplate 25 | -------------------------------------------------------------------------------- /src/Generics/Deriving/Base.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | module Generics.Deriving.Base (module GHC.Generics) where 4 | 5 | import GHC.Generics 6 | 7 | import Generics.Deriving.Instances () 8 | -------------------------------------------------------------------------------- /src/Generics/Deriving/ConNames.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE PolyKinds #-} 4 | {-# LANGUAGE Safe #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | {-# LANGUAGE TypeSynonymInstances #-} 8 | 9 | {- | 10 | Module : Generics.Deriving.ConNames 11 | Copyright : (c) 2012 University of Oxford 12 | License : BSD3 13 | 14 | Maintainer : generics@haskell.org 15 | Stability : experimental 16 | Portability : non-portable 17 | 18 | Summary: Return the name of all the constructors of a type. 19 | -} 20 | 21 | module Generics.Deriving.ConNames ( 22 | 23 | -- * Functionality for retrieving the names of the possible contructors 24 | -- of a type or the constructor name of a given value 25 | ConNames(..), conNames, conNameOf 26 | 27 | ) where 28 | 29 | import Generics.Deriving.Base 30 | 31 | 32 | class ConNames f where 33 | gconNames :: f a -> [String] 34 | gconNameOf :: f a -> String 35 | 36 | instance (ConNames f, ConNames g) => ConNames (f :+: g) where 37 | gconNames (_ :: (f :+: g) a) = gconNames (undefined :: f a) ++ 38 | gconNames (undefined :: g a) 39 | 40 | gconNameOf (L1 x) = gconNameOf x 41 | gconNameOf (R1 x) = gconNameOf x 42 | 43 | instance (ConNames f) => ConNames (D1 c f) where 44 | gconNames (_ :: (D1 c f) a) = gconNames (undefined :: f a) 45 | 46 | gconNameOf (M1 x) = gconNameOf x 47 | 48 | instance (Constructor c) => ConNames (C1 c f) where 49 | gconNames x = [conName x] 50 | 51 | gconNameOf x = conName x 52 | 53 | 54 | -- We should never need any other instances. 55 | 56 | 57 | -- | Return the name of all the constructors of the type of the given term. 58 | conNames :: (Generic a, ConNames (Rep a)) => a -> [String] 59 | conNames x = gconNames (undefined `asTypeOf` (from x)) 60 | 61 | -- | Return the name of the constructor of the given term 62 | conNameOf :: (ConNames (Rep a), Generic a) => a -> String 63 | conNameOf x = gconNameOf (from x) 64 | -------------------------------------------------------------------------------- /src/Generics/Deriving/Copoint.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | {-# LANGUAGE Safe #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | module Generics.Deriving.Copoint ( 9 | -- * GCopoint class 10 | GCopoint(..) 11 | 12 | -- * Default method 13 | , gcopointdefault 14 | 15 | -- * Internal class 16 | , GCopoint'(..) 17 | 18 | ) where 19 | 20 | import Control.Applicative (WrappedMonad) 21 | 22 | import Data.Functor.Identity (Identity) 23 | import qualified Data.Functor.Sum as Functor (Sum) 24 | import Data.Monoid (Alt, Dual) 25 | import qualified Data.Monoid as Monoid (Sum) 26 | import Data.Ord (Down) 27 | import Data.Semigroup (Arg, First, Last, Max, Min, WrappedMonoid) 28 | 29 | import Generics.Deriving.Base 30 | 31 | -------------------------------------------------------------------------------- 32 | -- Generic copoint 33 | -------------------------------------------------------------------------------- 34 | 35 | -- General copoint may return 'Nothing' 36 | 37 | class GCopoint' t where 38 | gcopoint' :: t a -> Maybe a 39 | 40 | instance GCopoint' V1 where 41 | gcopoint' _ = Nothing 42 | 43 | instance GCopoint' U1 where 44 | gcopoint' U1 = Nothing 45 | 46 | instance GCopoint' Par1 where 47 | gcopoint' (Par1 a) = Just a 48 | 49 | instance GCopoint' (K1 i c) where 50 | gcopoint' _ = Nothing 51 | 52 | instance GCopoint' f => GCopoint' (M1 i c f) where 53 | gcopoint' (M1 a) = gcopoint' a 54 | 55 | instance (GCopoint' f, GCopoint' g) => GCopoint' (f :+: g) where 56 | gcopoint' (L1 a) = gcopoint' a 57 | gcopoint' (R1 a) = gcopoint' a 58 | 59 | -- Favours left "hole" for copoint 60 | instance (GCopoint' f, GCopoint' g) => GCopoint' (f :*: g) where 61 | gcopoint' (a :*: b) = case (gcopoint' a) of 62 | Just x -> Just x 63 | Nothing -> gcopoint' b 64 | 65 | instance (GCopoint f) => GCopoint' (Rec1 f) where 66 | gcopoint' (Rec1 a) = Just $ gcopoint a 67 | 68 | instance (GCopoint f, GCopoint' g) => GCopoint' (f :.: g) where 69 | gcopoint' (Comp1 x) = gcopoint' . gcopoint $ x 70 | 71 | class GCopoint d where 72 | gcopoint :: d a -> a 73 | default gcopoint :: (Generic1 d, GCopoint' (Rep1 d)) 74 | => (d a -> a) 75 | gcopoint = gcopointdefault 76 | 77 | gcopointdefault :: (Generic1 d, GCopoint' (Rep1 d)) 78 | => d a -> a 79 | gcopointdefault x = case (gcopoint' . from1 $ x) of 80 | Just x' -> x' 81 | Nothing -> error "Data type is not copointed" 82 | 83 | -- instance (Generic1 d, GCopoint' (Rep1 d)) => GCopoint d 84 | 85 | -- Base types instances 86 | instance GCopoint ((,) a) where 87 | gcopoint = gcopointdefault 88 | 89 | instance GCopoint ((,,) a b) where 90 | gcopoint = gcopointdefault 91 | 92 | instance GCopoint ((,,,) a b c) where 93 | gcopoint = gcopointdefault 94 | 95 | instance GCopoint ((,,,,) a b c d) where 96 | gcopoint = gcopointdefault 97 | 98 | instance GCopoint ((,,,,,) a b c d e) where 99 | gcopoint = gcopointdefault 100 | 101 | instance GCopoint ((,,,,,,) a b c d e f) where 102 | gcopoint = gcopointdefault 103 | 104 | instance GCopoint f => GCopoint (Alt f) where 105 | gcopoint = gcopointdefault 106 | 107 | instance GCopoint (Arg a) where 108 | gcopoint = gcopointdefault 109 | 110 | instance GCopoint Down where 111 | gcopoint = gcopointdefault 112 | 113 | instance GCopoint Dual where 114 | gcopoint = gcopointdefault 115 | 116 | instance GCopoint First where 117 | gcopoint = gcopointdefault 118 | 119 | instance GCopoint Identity where 120 | gcopoint = gcopointdefault 121 | 122 | instance GCopoint Last where 123 | gcopoint = gcopointdefault 124 | 125 | instance GCopoint Max where 126 | gcopoint = gcopointdefault 127 | 128 | instance GCopoint Min where 129 | gcopoint = gcopointdefault 130 | 131 | instance (GCopoint f, GCopoint g) => GCopoint (Functor.Sum f g) where 132 | gcopoint = gcopointdefault 133 | 134 | instance GCopoint Monoid.Sum where 135 | gcopoint = gcopointdefault 136 | 137 | instance GCopoint m => GCopoint (WrappedMonad m) where 138 | gcopoint = gcopointdefault 139 | 140 | instance GCopoint WrappedMonoid where 141 | gcopoint = gcopointdefault 142 | -------------------------------------------------------------------------------- /src/Generics/Deriving/Default.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Generics.Deriving.Default 3 | -- Description : Default implementations of generic classes 4 | -- License : BSD-3-Clause 5 | -- 6 | -- Maintainer : generics@haskell.org 7 | -- Stability : experimental 8 | -- Portability : non-portable 9 | -- 10 | -- GHC 8.6 introduced the 11 | -- @@ 12 | -- language extension, which means a typeclass instance can be derived from 13 | -- an existing instance for an isomorphic type. Any newtype is isomorphic 14 | -- to the underlying type. By implementing a typeclass once for the newtype, 15 | -- it is possible to derive any typeclass for any type with a 'Generic' instance. 16 | -- 17 | -- For a number of classes, there are sensible default instantiations. In 18 | -- older GHCs, these can be supplied in the class definition, using the 19 | -- @@ 20 | -- extension. However, only one default can be provided! With 21 | -- @@ 22 | -- it is now possible to choose from many 23 | -- default instantiations. 24 | -- 25 | -- This package contains a number of such classes. This module demonstrates 26 | -- how one might create a family of newtypes ('Default', 'Default1') for 27 | -- which such instances are defined. 28 | -- 29 | -- One might then use 30 | -- @@ 31 | -- as follows. The implementations of the data types are elided here (they 32 | -- are irrelevant). For most cases, either the deriving clause with the 33 | -- data type definition or the standalone clause will work (for some types 34 | -- it is necessary to supply the context explicitly using the latter form). 35 | -- See the source of this module for the implementations of instances for 36 | -- the 'Default' family of newtypes and the source of the test suite for 37 | -- some types which derive instances via these wrappers. 38 | 39 | {-# LANGUAGE DefaultSignatures #-} 40 | {-# LANGUAGE FlexibleContexts #-} 41 | {-# LANGUAGE Safe #-} 42 | {-# LANGUAGE UndecidableInstances #-} 43 | 44 | module Generics.Deriving.Default 45 | ( -- * Kind @*@ (aka @Type@) 46 | 47 | -- $default 48 | 49 | Default(..) 50 | 51 | , -- * Kind @* -> *@ (aka @Type -> Type@) 52 | 53 | -- $default1 54 | 55 | Default1(..) 56 | 57 | -- * Other kinds 58 | 59 | -- $other-kinds 60 | ) where 61 | 62 | import Control.Monad (liftM) 63 | 64 | import Generics.Deriving.Base 65 | import Generics.Deriving.Copoint 66 | import Generics.Deriving.Enum 67 | import Generics.Deriving.Eq 68 | import Generics.Deriving.Foldable 69 | import Generics.Deriving.Functor 70 | import Generics.Deriving.Monoid 71 | import Generics.Deriving.Semigroup 72 | import Generics.Deriving.Show 73 | import Generics.Deriving.Traversable 74 | import Generics.Deriving.Uniplate 75 | 76 | -- $default 77 | -- 78 | -- For classes which take an argument of kind 'Data.Kind.Type', use 79 | -- 'Default'. An example of this class from @base@ would be 'Eq', or 80 | -- 'Generic'. 81 | -- 82 | -- These examples use 'GShow' and 'GEq'; they are interchangeable. 83 | -- 84 | -- @ 85 | -- data MyType = … 86 | -- deriving ('Generic') 87 | -- deriving ('GEq') via ('Default' MyType) 88 | -- 89 | -- deriving via ('Default' MyType) instance 'GShow' MyType 90 | -- @ 91 | -- 92 | -- Instances may be parameterized by type variables. 93 | -- 94 | -- @ 95 | -- data MyType1 a = … 96 | -- deriving ('Generic') 97 | -- deriving ('GShow') via ('Default' (MyType1 a)) 98 | -- 99 | -- deriving via 'Default' (MyType1 a) instance 'GEq' a => 'GEq' (MyType1 a) 100 | -- @ 101 | -- 102 | -- These types both require instances for 'Generic'. This is because the 103 | -- implementations of 'geq' and 'gshowsPrec' for @'Default' b@ have a @'Generic' 104 | -- b@ constraint, i.e. the type corresponding to @b@ require a 'Generic' 105 | -- instance. For these two types, that means instances for @'Generic' MyType@ 106 | -- and @'Generic' (MyType1 a)@ respectively. 107 | -- 108 | -- It also means the 'Generic' instance is not needed when there is already 109 | -- a generic instance for the type used to derive the relevant instances. 110 | -- For an example, see the documentation of the 'GShow' instance for 111 | -- 'Default', below. 112 | 113 | -- | This newtype wrapper can be used to derive default instances for 114 | -- classes taking an argument of kind 'Data.Kind.Type'. 115 | newtype Default a = Default { unDefault :: a } 116 | 117 | -- $default1 118 | -- 119 | -- For classes which take an argument of kind @'Data.Kind.Type' -> 120 | -- 'Data.Kind.Type'@, use 'Default1'. An example of this class from @base@ 121 | -- would be 'Data.Functor.Classes.Eq1', or 'Generic1'. 122 | -- 123 | -- Unlike for @MyType1@, there can be no implementation of these classes for @MyType :: 'Data.Kind.Type'@. 124 | -- 125 | -- @ 126 | -- data MyType1 a = … 127 | -- deriving ('Generic1') 128 | -- deriving ('GFunctor') via ('Default1' MyType1) 129 | -- 130 | -- deriving via ('Default1' MyType1) instance 'GFoldable' MyType1 131 | -- @ 132 | -- 133 | -- Note that these instances require a @'Generic1' MyType1@ constraint as 134 | -- 'gmap' and 'gfoldMap' have @'Generic1' a@ constraints on the 135 | -- implementations for @'Default1' a@. 136 | 137 | -- | This newtype wrapper can be used to derive default instances for 138 | -- classes taking an argument of kind @'Data.Kind.Type' -> 'Data.Kind.Type'@. 139 | newtype Default1 f a = Default1 { unDefault1 :: f a } 140 | 141 | -- $other-kinds 142 | -- 143 | -- These principles extend to classes taking arguments of other kinds. 144 | 145 | -------------------------------------------------------------------------------- 146 | -- Eq 147 | -------------------------------------------------------------------------------- 148 | 149 | instance (Generic a, GEq' (Rep a)) => GEq (Default a) where 150 | -- geq :: Default a -> Default a -> Bool 151 | Default x `geq` Default y = x `geqdefault` y 152 | 153 | -------------------------------------------------------------------------------- 154 | -- Enum 155 | -------------------------------------------------------------------------------- 156 | 157 | -- | The 'Enum' class in @base@ is slightly different; it comprises 'toEnum' and 158 | -- 'fromEnum'. "Generics.Deriving.Enum" provides functions 'toEnumDefault' 159 | -- and 'fromEnumDefault'. 160 | instance (Generic a, GEq a, Enum' (Rep a)) => GEnum (Default a) where 161 | -- genum :: [Default a] 162 | genum = Default . to <$> enum' 163 | 164 | -------------------------------------------------------------------------------- 165 | -- Show 166 | -------------------------------------------------------------------------------- 167 | 168 | -- | For example, with this type: 169 | -- 170 | -- @ 171 | -- newtype TestShow = TestShow 'Bool' 172 | -- deriving ('GShow') via ('Default' 'Bool') 173 | -- @ 174 | -- 175 | -- 'gshow' for @TestShow@ would produce the same string as `gshow` for 176 | -- 'Bool'. 177 | -- 178 | -- In this example, @TestShow@ requires no 'Generic' instance, as the 179 | -- constraint on 'gshowsPrec' from @'Default' 'Bool'@ is @'Generic' 'Bool'@. 180 | -- 181 | -- In general, when using a newtype wrapper, the instance can be derived 182 | -- via the wrapped type, as here (via @'Default' 'Bool'@ rather than @'Default' 183 | -- TestShow@). 184 | instance (Generic a, GShow' (Rep a)) => GShow (Default a) where 185 | -- gshowsPrec :: Int -> Default a -> ShowS 186 | gshowsPrec n (Default x) = gshowsPrecdefault n x 187 | 188 | -------------------------------------------------------------------------------- 189 | -- Semigroup 190 | -------------------------------------------------------------------------------- 191 | 192 | -- | Semigroups often have many sensible implementations of 193 | -- 'Data.Semigroup.<>' / 'gsappend', and therefore no sensible default. 194 | -- Indeed, there is no 'GSemigroup'' instance for representations of sum 195 | -- types. 196 | -- 197 | -- In other cases, one may wish to use the existing wrapper newtypes in 198 | -- @base@, such as the following (using 'Data.Semigroup.First'): 199 | -- 200 | -- @ 201 | -- newtype FirstSemigroup = FirstSemigroup 'Bool' 202 | -- deriving stock ('Eq', 'Show') 203 | -- deriving ('GSemigroup') via ('Data.Semigroup.First' 'Bool') 204 | -- @ 205 | -- 206 | instance (Generic a, GSemigroup' (Rep a)) => GSemigroup (Default a) where 207 | -- gsappend :: Default a -> Default a -> Default a 208 | Default x `gsappend` Default y = Default $ x `gsappenddefault` y 209 | 210 | -------------------------------------------------------------------------------- 211 | -- Monoid 212 | -------------------------------------------------------------------------------- 213 | 214 | instance (Generic a, GMonoid' (Rep a)) => GMonoid (Default a) where 215 | -- gmempty :: Default a 216 | gmempty = Default gmemptydefault 217 | 218 | -- gmappend :: Default a -> Default a -> Default a 219 | Default x `gmappend` Default y = Default $ x `gmappenddefault` y 220 | 221 | -------------------------------------------------------------------------------- 222 | -- Uniplate 223 | -------------------------------------------------------------------------------- 224 | 225 | instance (Generic a, Uniplate' (Rep a) a, Context' (Rep a) a) => Uniplate (Default a) where 226 | 227 | -- children :: Default a -> [Default a] 228 | -- context :: Default a -> [Default a] -> Default a 229 | -- descend :: (Default a -> Default a) -> Default a -> Default a 230 | -- descendM :: Monad m => (Default a -> m (Default a)) -> Default a -> m (Default a) 231 | -- transform :: (Default a -> Default a) -> Default a -> Default a 232 | -- transformM :: Monad m => (Default a -> m (Default a)) -> Default a -> m (Default a) 233 | 234 | children (Default x) = Default <$> childrendefault x 235 | context (Default x) ys = Default $ contextdefault x (unDefault <$> ys) 236 | descend f (Default x) = Default $ descenddefault (unDefault . f . Default) x 237 | descendM f (Default x) = liftM Default $ descendMdefault (liftM unDefault . f . Default) x 238 | transform f (Default x) = Default $ transformdefault (unDefault . f . Default) x 239 | transformM f (Default x) = liftM Default $ transformMdefault (liftM unDefault . f . Default) x 240 | 241 | -------------------------------------------------------------------------------- 242 | -- Functor 243 | -------------------------------------------------------------------------------- 244 | 245 | instance (Generic1 f, GFunctor' (Rep1 f)) => GFunctor (Default1 f) where 246 | -- gmap :: (a -> b) -> (Default1 f) a -> (Default1 f) b 247 | gmap f (Default1 fx) = Default1 $ gmapdefault f fx 248 | 249 | -------------------------------------------------- 250 | -- Copoint 251 | -------------------------------------------------- 252 | 253 | instance (Generic1 f, GCopoint' (Rep1 f)) => GCopoint (Default1 f) where 254 | -- gcopoint :: Default1 f a -> a 255 | gcopoint = gcopointdefault . unDefault1 256 | 257 | -------------------------------------------------- 258 | -- Foldable 259 | -------------------------------------------------- 260 | 261 | instance (Generic1 t, GFoldable' (Rep1 t)) => GFoldable (Default1 t) where 262 | -- gfoldMap :: Monoid m => (a -> m) -> Default1 t a -> m 263 | gfoldMap f (Default1 tx) = gfoldMapdefault f tx 264 | 265 | -------------------------------------------------- 266 | -- Traversable 267 | -------------------------------------------------- 268 | 269 | instance (Generic1 t, GFunctor' (Rep1 t), GFoldable' (Rep1 t), GTraversable' (Rep1 t)) => GTraversable (Default1 t) where 270 | -- gtraverse :: Applicative f => (a -> f b) -> Default1 t a -> f (Default1 t b) 271 | gtraverse f (Default1 fx) = Default1 <$> gtraversedefault f fx 272 | -------------------------------------------------------------------------------- /src/Generics/Deriving/Enum.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DefaultSignatures #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE KindSignatures #-} 6 | {-# LANGUAGE PolyKinds #-} 7 | {-# LANGUAGE Trustworthy #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | {-# LANGUAGE TypeSynonymInstances #-} 10 | 11 | #include "HsBaseConfig.h" 12 | 13 | module Generics.Deriving.Enum ( 14 | 15 | -- * Generic enum class 16 | GEnum(..) 17 | 18 | -- * Default definitions for GEnum 19 | , genumDefault, toEnumDefault, fromEnumDefault 20 | 21 | -- * Internal enum class 22 | , Enum'(..) 23 | 24 | -- * Generic Ix class 25 | , GIx(..) 26 | 27 | -- * Default definitions for GIx 28 | , rangeDefault, indexDefault, inRangeDefault 29 | 30 | ) where 31 | 32 | import Control.Applicative (Const, ZipList) 33 | 34 | import Data.Coerce (coerce) 35 | import Data.Complex (Complex) 36 | import Data.Functor.Identity (Identity) 37 | import Data.Int 38 | import Data.List.NonEmpty (NonEmpty) 39 | import Data.Maybe (listToMaybe) 40 | import Data.Monoid (All, Alt, Any, Dual, Product, Sum) 41 | import qualified Data.Monoid as Monoid (First, Last) 42 | import Data.Proxy (Proxy) 43 | import qualified Data.Semigroup as Semigroup (First, Last) 44 | import Data.Semigroup (Arg, Max, Min, WrappedMonoid) 45 | import Data.Word 46 | 47 | import Foreign.C.Types 48 | import Foreign.Ptr 49 | 50 | import Generics.Deriving.Base 51 | import Generics.Deriving.Eq 52 | 53 | import Numeric.Natural (Natural) 54 | 55 | import System.Exit (ExitCode) 56 | import System.Posix.Types 57 | 58 | ----------------------------------------------------------------------------- 59 | -- Utility functions for Enum' 60 | ----------------------------------------------------------------------------- 61 | 62 | infixr 5 ||| 63 | 64 | -- | Interleave elements from two lists. Similar to (++), but swap left and 65 | -- right arguments on every recursive application. 66 | -- 67 | -- From Mark Jones' talk at AFP2008 68 | (|||) :: [a] -> [a] -> [a] 69 | [] ||| ys = ys 70 | (x:xs) ||| ys = x : ys ||| xs 71 | 72 | -- | Diagonalization of nested lists. Ensure that some elements from every 73 | -- sublist will be included. Handles infinite sublists. 74 | -- 75 | -- From Mark Jones' talk at AFP2008 76 | diag :: [[a]] -> [a] 77 | diag = concat . foldr skew [] . map (map (\x -> [x])) 78 | 79 | skew :: [[a]] -> [[a]] -> [[a]] 80 | skew [] ys = ys 81 | skew (x:xs) ys = x : combine (++) xs ys 82 | 83 | combine :: (a -> a -> a) -> [a] -> [a] -> [a] 84 | combine _ xs [] = xs 85 | combine _ [] ys = ys 86 | combine f (x:xs) (y:ys) = f x y : combine f xs ys 87 | 88 | findIndex :: (a -> Bool) -> [a] -> Maybe Int 89 | findIndex p xs = let l = [ i | (y,i) <- zip xs [(0::Int)..], p y] 90 | in listToMaybe l 91 | 92 | -------------------------------------------------------------------------------- 93 | -- Generic enum 94 | -------------------------------------------------------------------------------- 95 | 96 | class Enum' f where 97 | enum' :: [f a] 98 | 99 | instance Enum' U1 where 100 | enum' = [U1] 101 | 102 | instance (GEnum c) => Enum' (K1 i c) where 103 | enum' = map K1 genum 104 | 105 | instance (Enum' f) => Enum' (M1 i c f) where 106 | enum' = map M1 enum' 107 | 108 | instance (Enum' f, Enum' g) => Enum' (f :+: g) where 109 | enum' = map L1 enum' ||| map R1 enum' 110 | 111 | instance (Enum' f, Enum' g) => Enum' (f :*: g) where 112 | enum' = diag [ [ x :*: y | y <- enum' ] | x <- enum' ] 113 | 114 | genumDefault :: (Generic a, Enum' (Rep a)) => [a] 115 | genumDefault = map to enum' 116 | 117 | toEnumDefault :: (Generic a, Enum' (Rep a)) => Int -> a 118 | toEnumDefault i = let l = enum' 119 | in if (length l > i) 120 | then to (l !! i) 121 | else error "toEnum: invalid index" 122 | 123 | fromEnumDefault :: (GEq a, Generic a, Enum' (Rep a)) 124 | => a -> Int 125 | fromEnumDefault x = case findIndex (geq x) (map to enum') of 126 | Nothing -> error "fromEnum: no corresponding index" 127 | Just i -> i 128 | 129 | 130 | class GEnum a where 131 | genum :: [a] 132 | 133 | default genum :: (Generic a, Enum' (Rep a)) => [a] 134 | genum = genumDefault 135 | 136 | genumNumUnbounded :: Num a => [a] 137 | genumNumUnbounded = pos 0 ||| neg 0 where 138 | pos n = n : pos (n + 1) 139 | neg n = (n-1) : neg (n - 1) 140 | 141 | genumNumSigned :: (Bounded a, Enum a, Num a) => [a] 142 | genumNumSigned = [0 .. maxBound] ||| [-1, -2 .. minBound] 143 | 144 | genumNumUnsigned :: (Enum a, Num a) => [a] 145 | genumNumUnsigned = [0 ..] 146 | 147 | -- Base types instances 148 | instance GEnum () where 149 | genum = genumDefault 150 | 151 | instance (GEnum a, GEnum b) => GEnum (a, b) where 152 | genum = genumDefault 153 | 154 | instance (GEnum a, GEnum b, GEnum c) => GEnum (a, b, c) where 155 | genum = genumDefault 156 | 157 | instance (GEnum a, GEnum b, GEnum c, GEnum d) => GEnum (a, b, c, d) where 158 | genum = genumDefault 159 | 160 | instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e) => GEnum (a, b, c, d, e) where 161 | genum = genumDefault 162 | 163 | instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e, GEnum f) 164 | => GEnum (a, b, c, d, e, f) where 165 | genum = genumDefault 166 | 167 | instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e, GEnum f, GEnum g) 168 | => GEnum (a, b, c, d, e, f, g) where 169 | genum = genumDefault 170 | 171 | instance GEnum a => GEnum [a] where 172 | genum = genumDefault 173 | 174 | instance (GEnum (f p), GEnum (g p)) => GEnum ((f :+: g) p) where 175 | genum = genumDefault 176 | 177 | instance (GEnum (f p), GEnum (g p)) => GEnum ((f :*: g) p) where 178 | genum = genumDefault 179 | 180 | instance GEnum (f (g p)) => GEnum ((f :.: g) p) where 181 | genum = genumDefault 182 | 183 | instance GEnum All where 184 | genum = genumDefault 185 | 186 | instance GEnum (f a) => GEnum (Alt f a) where 187 | genum = genumDefault 188 | 189 | instance GEnum Any where 190 | genum = genumDefault 191 | 192 | instance (GEnum a, GEnum b) => GEnum (Arg a b) where 193 | genum = genumDefault 194 | 195 | instance GEnum Associativity where 196 | genum = genumDefault 197 | 198 | instance GEnum Bool where 199 | genum = genumDefault 200 | 201 | #if defined(HTYPE_CC_T) 202 | instance GEnum CCc where 203 | genum = coerce (genum :: [HTYPE_CC_T]) 204 | #endif 205 | 206 | instance GEnum CChar where 207 | genum = coerce (genum :: [HTYPE_CHAR]) 208 | 209 | instance GEnum CClock where 210 | genum = coerce (genum :: [HTYPE_CLOCK_T]) 211 | 212 | #if defined(HTYPE_DEV_T) 213 | instance GEnum CDev where 214 | genum = coerce (genum :: [HTYPE_DEV_T]) 215 | #endif 216 | 217 | instance GEnum CDouble where 218 | genum = coerce (genum :: [HTYPE_DOUBLE]) 219 | 220 | instance GEnum CFloat where 221 | genum = coerce (genum :: [HTYPE_FLOAT]) 222 | 223 | #if defined(HTYPE_GID_T) 224 | instance GEnum CGid where 225 | genum = coerce (genum :: [HTYPE_GID_T]) 226 | #endif 227 | 228 | #if defined(HTYPE_INO_T) 229 | instance GEnum CIno where 230 | genum = coerce (genum :: [HTYPE_INO_T]) 231 | #endif 232 | 233 | instance GEnum CInt where 234 | genum = coerce (genum :: [HTYPE_INT]) 235 | 236 | instance GEnum CIntMax where 237 | genum = coerce (genum :: [HTYPE_INTMAX_T]) 238 | 239 | instance GEnum CIntPtr where 240 | genum = coerce (genum :: [HTYPE_INTPTR_T]) 241 | 242 | instance GEnum CLLong where 243 | genum = coerce (genum :: [HTYPE_LONG_LONG]) 244 | 245 | instance GEnum CLong where 246 | genum = coerce (genum :: [HTYPE_LONG]) 247 | 248 | #if defined(HTYPE_MODE_T) 249 | instance GEnum CMode where 250 | genum = coerce (genum :: [HTYPE_MODE_T]) 251 | #endif 252 | 253 | #if defined(HTYPE_NLINK_T) 254 | instance GEnum CNlink where 255 | genum = coerce (genum :: [HTYPE_NLINK_T]) 256 | #endif 257 | 258 | #if defined(HTYPE_OFF_T) 259 | instance GEnum COff where 260 | genum = coerce (genum :: [HTYPE_OFF_T]) 261 | #endif 262 | 263 | instance GEnum a => GEnum (Complex a) where 264 | genum = genumDefault 265 | 266 | instance GEnum a => GEnum (Const a b) where 267 | genum = genumDefault 268 | 269 | #if defined(HTYPE_PID_T) 270 | instance GEnum CPid where 271 | genum = coerce (genum :: [HTYPE_PID_T]) 272 | #endif 273 | 274 | instance GEnum CPtrdiff where 275 | genum = coerce (genum :: [HTYPE_PTRDIFF_T]) 276 | 277 | #if defined(HTYPE_RLIM_T) 278 | instance GEnum CRLim where 279 | genum = coerce (genum :: [HTYPE_RLIM_T]) 280 | #endif 281 | 282 | instance GEnum CSChar where 283 | genum = coerce (genum :: [HTYPE_SIGNED_CHAR]) 284 | 285 | #if defined(HTYPE_SPEED_T) 286 | instance GEnum CSpeed where 287 | genum = coerce (genum :: [HTYPE_SPEED_T]) 288 | #endif 289 | 290 | instance GEnum CSUSeconds where 291 | genum = coerce (genum :: [HTYPE_SUSECONDS_T]) 292 | 293 | instance GEnum CShort where 294 | genum = coerce (genum :: [HTYPE_SHORT]) 295 | 296 | instance GEnum CSigAtomic where 297 | #if defined(HTYPE_SIG_ATOMIC_T) 298 | genum = coerce (genum :: [HTYPE_SIG_ATOMIC_T]) 299 | #else 300 | genum = coerce (genum :: [Int32]) 301 | #endif 302 | 303 | instance GEnum CSize where 304 | genum = coerce (genum :: [HTYPE_SIZE_T]) 305 | 306 | #if defined(HTYPE_SSIZE_T) 307 | instance GEnum CSsize where 308 | genum = coerce (genum :: [HTYPE_SSIZE_T]) 309 | #endif 310 | 311 | #if defined(HTYPE_TCFLAG_T) 312 | instance GEnum CTcflag where 313 | genum = coerce (genum :: [HTYPE_TCFLAG_T]) 314 | #endif 315 | 316 | instance GEnum CTime where 317 | genum = coerce (genum :: [HTYPE_TIME_T]) 318 | 319 | instance GEnum CUChar where 320 | genum = coerce (genum :: [HTYPE_UNSIGNED_CHAR]) 321 | 322 | #if defined(HTYPE_UID_T) 323 | instance GEnum CUid where 324 | genum = coerce (genum :: [HTYPE_UID_T]) 325 | #endif 326 | 327 | instance GEnum CUInt where 328 | genum = coerce (genum :: [HTYPE_UNSIGNED_INT]) 329 | 330 | instance GEnum CUIntMax where 331 | genum = coerce (genum :: [HTYPE_UINTMAX_T]) 332 | 333 | instance GEnum CUIntPtr where 334 | genum = coerce (genum :: [HTYPE_UINTPTR_T]) 335 | 336 | instance GEnum CULLong where 337 | genum = coerce (genum :: [HTYPE_UNSIGNED_LONG_LONG]) 338 | 339 | instance GEnum CULong where 340 | genum = coerce (genum :: [HTYPE_UNSIGNED_LONG]) 341 | 342 | instance GEnum CUSeconds where 343 | genum = coerce (genum :: [HTYPE_USECONDS_T]) 344 | 345 | instance GEnum CUShort where 346 | genum = coerce (genum :: [HTYPE_UNSIGNED_SHORT]) 347 | 348 | instance GEnum CWchar where 349 | genum = coerce (genum :: [HTYPE_WCHAR_T]) 350 | 351 | instance GEnum Double where 352 | genum = genumNumUnbounded 353 | 354 | instance GEnum a => GEnum (Dual a) where 355 | genum = genumDefault 356 | 357 | instance (GEnum a, GEnum b) => GEnum (Either a b) where 358 | genum = genumDefault 359 | 360 | instance GEnum ExitCode where 361 | genum = genumDefault 362 | 363 | instance GEnum Fd where 364 | genum = coerce (genum :: [CInt]) 365 | 366 | instance GEnum a => GEnum (Monoid.First a) where 367 | genum = genumDefault 368 | 369 | instance GEnum a => GEnum (Semigroup.First a) where 370 | genum = genumDefault 371 | 372 | instance GEnum Fixity where 373 | genum = genumDefault 374 | 375 | instance GEnum Float where 376 | genum = genumNumUnbounded 377 | 378 | instance GEnum a => GEnum (Identity a) where 379 | genum = genumDefault 380 | 381 | instance GEnum Int where 382 | genum = genumNumSigned 383 | 384 | instance GEnum Int8 where 385 | genum = genumNumSigned 386 | 387 | instance GEnum Int16 where 388 | genum = genumNumSigned 389 | 390 | instance GEnum Int32 where 391 | genum = genumNumSigned 392 | 393 | instance GEnum Int64 where 394 | genum = genumNumSigned 395 | 396 | instance GEnum Integer where 397 | genum = genumNumUnbounded 398 | 399 | instance GEnum IntPtr where 400 | genum = genumNumSigned 401 | 402 | instance GEnum c => GEnum (K1 i c p) where 403 | genum = genumDefault 404 | 405 | instance GEnum a => GEnum (Monoid.Last a) where 406 | genum = genumDefault 407 | 408 | instance GEnum a => GEnum (Semigroup.Last a) where 409 | genum = genumDefault 410 | 411 | instance GEnum (f p) => GEnum (M1 i c f p) where 412 | genum = genumDefault 413 | 414 | instance GEnum a => GEnum (Max a) where 415 | genum = genumDefault 416 | 417 | instance GEnum a => GEnum (Maybe a) where 418 | genum = genumDefault 419 | 420 | instance GEnum a => GEnum (Min a) where 421 | genum = genumDefault 422 | 423 | instance GEnum Natural where 424 | genum = genumNumUnsigned 425 | 426 | instance GEnum a => GEnum (NonEmpty a) where 427 | genum = genumDefault 428 | 429 | instance GEnum Ordering where 430 | genum = genumDefault 431 | 432 | instance GEnum p => GEnum (Par1 p) where 433 | genum = genumDefault 434 | 435 | instance GEnum a => GEnum (Product a) where 436 | genum = genumDefault 437 | 438 | instance GEnum (Proxy s) where 439 | genum = genumDefault 440 | 441 | instance GEnum (f p) => GEnum (Rec1 f p) where 442 | genum = genumDefault 443 | 444 | instance GEnum a => GEnum (Sum a) where 445 | genum = genumDefault 446 | 447 | instance GEnum (U1 p) where 448 | genum = genumDefault 449 | 450 | instance GEnum Word where 451 | genum = genumNumUnsigned 452 | 453 | instance GEnum Word8 where 454 | genum = genumNumUnsigned 455 | 456 | instance GEnum Word16 where 457 | genum = genumNumUnsigned 458 | 459 | instance GEnum Word32 where 460 | genum = genumNumUnsigned 461 | 462 | instance GEnum Word64 where 463 | genum = genumNumUnsigned 464 | 465 | instance GEnum WordPtr where 466 | genum = genumNumUnsigned 467 | 468 | instance GEnum m => GEnum (WrappedMonoid m) where 469 | genum = genumDefault 470 | 471 | instance GEnum a => GEnum (ZipList a) where 472 | genum = genumDefault 473 | 474 | #if MIN_VERSION_base(4,10,0) 475 | instance GEnum CBool where 476 | genum = coerce (genum :: [HTYPE_BOOL]) 477 | 478 | # if defined(HTYPE_BLKSIZE_T) 479 | instance GEnum CBlkSize where 480 | genum = coerce (genum :: [HTYPE_BLKSIZE_T]) 481 | # endif 482 | 483 | # if defined(HTYPE_BLKCNT_T) 484 | instance GEnum CBlkCnt where 485 | genum = coerce (genum :: [HTYPE_BLKCNT_T]) 486 | # endif 487 | 488 | # if defined(HTYPE_CLOCKID_T) 489 | instance GEnum CClockId where 490 | genum = coerce (genum :: [HTYPE_CLOCKID_T]) 491 | # endif 492 | 493 | # if defined(HTYPE_FSBLKCNT_T) 494 | instance GEnum CFsBlkCnt where 495 | genum = coerce (genum :: [HTYPE_FSBLKCNT_T]) 496 | # endif 497 | 498 | # if defined(HTYPE_FSFILCNT_T) 499 | instance GEnum CFsFilCnt where 500 | genum = coerce (genum :: [HTYPE_FSFILCNT_T]) 501 | # endif 502 | 503 | # if defined(HTYPE_ID_T) 504 | instance GEnum CId where 505 | genum = coerce (genum :: [HTYPE_ID_T]) 506 | # endif 507 | 508 | # if defined(HTYPE_KEY_T) 509 | instance GEnum CKey where 510 | genum = coerce (genum :: [HTYPE_KEY_T]) 511 | # endif 512 | #endif 513 | 514 | -------------------------------------------------------------------------------- 515 | -- Generic Ix 516 | -------------------------------------------------------------------------------- 517 | 518 | -- Minimal complete instance: 'range', 'index' and 'inRange'. 519 | class (Ord a) => GIx a where 520 | -- | The list of values in the subrange defined by a bounding pair. 521 | range :: (a,a) -> [a] 522 | -- | The position of a subscript in the subrange. 523 | index :: (a,a) -> a -> Int 524 | -- | Returns 'True' the given subscript lies in the range defined 525 | -- the bounding pair. 526 | inRange :: (a,a) -> a -> Bool 527 | 528 | default range :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> [a] 529 | range = rangeDefault 530 | 531 | default index :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> a -> Int 532 | index = indexDefault 533 | 534 | default inRange :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> a -> Bool 535 | inRange = inRangeDefault 536 | 537 | rangeDefault :: (GEq a, Generic a, Enum' (Rep a)) 538 | => (a,a) -> [a] 539 | rangeDefault = t (map to enum') where 540 | t l (x,y) = 541 | case (findIndex (geq x) l, findIndex (geq y) l) of 542 | (Nothing, _) -> error "rangeDefault: no corresponding index" 543 | (_, Nothing) -> error "rangeDefault: no corresponding index" 544 | (Just i, Just j) -> take (j-i) (drop i l) 545 | 546 | indexDefault :: (GEq a, Generic a, Enum' (Rep a)) 547 | => (a,a) -> a -> Int 548 | indexDefault = t (map to enum') where 549 | t l (x,y) z = 550 | case (findIndex (geq x) l, findIndex (geq y) l) of 551 | (Nothing, _) -> error "indexDefault: no corresponding index" 552 | (_, Nothing) -> error "indexDefault: no corresponding index" 553 | (Just i, Just j) -> case findIndex (geq z) (take (j-i) (drop i l)) of 554 | Nothing -> error "indexDefault: index out of range" 555 | Just k -> k 556 | 557 | inRangeDefault :: (GEq a, Generic a, Enum' (Rep a)) 558 | => (a,a) -> a -> Bool 559 | inRangeDefault = t (map to enum') where 560 | t l (x,y) z = 561 | case (findIndex (geq x) l, findIndex (geq y) l) of 562 | (Nothing, _) -> error "indexDefault: no corresponding index" 563 | (_, Nothing) -> error "indexDefault: no corresponding index" 564 | (Just i, Just j) -> maybe False (const True) 565 | (findIndex (geq z) (take (j-i) (drop i l))) 566 | 567 | rangeEnum :: Enum a => (a, a) -> [a] 568 | rangeEnum (m,n) = [m..n] 569 | 570 | indexIntegral :: Integral a => (a, a) -> a -> Int 571 | indexIntegral (m,_n) i = fromIntegral (i - m) 572 | 573 | inRangeOrd :: Ord a => (a, a) -> a -> Bool 574 | inRangeOrd (m,n) i = m <= i && i <= n 575 | 576 | -- Base types instances 577 | instance GIx () where 578 | range = rangeDefault 579 | index = indexDefault 580 | inRange = inRangeDefault 581 | 582 | instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b) => GIx (a, b) where 583 | range = rangeDefault 584 | index = indexDefault 585 | inRange = inRangeDefault 586 | 587 | instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c) 588 | => GIx (a, b, c) where 589 | range = rangeDefault 590 | index = indexDefault 591 | inRange = inRangeDefault 592 | 593 | instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c, 594 | GEq d, GEnum d, GIx d) 595 | => GIx (a, b, c, d) where 596 | range = rangeDefault 597 | index = indexDefault 598 | inRange = inRangeDefault 599 | 600 | instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c, 601 | GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e) 602 | => GIx (a, b, c, d, e) where 603 | range = rangeDefault 604 | index = indexDefault 605 | inRange = inRangeDefault 606 | 607 | instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c, 608 | GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e, GEq f, GEnum f, GIx f) 609 | => GIx (a, b, c, d, e, f) where 610 | range = rangeDefault 611 | index = indexDefault 612 | inRange = inRangeDefault 613 | 614 | instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c, 615 | GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e, GEq f, GEnum f, GIx f, 616 | GEq g, GEnum g, GIx g) 617 | => GIx (a, b, c, d, e, f, g) where 618 | range = rangeDefault 619 | index = indexDefault 620 | inRange = inRangeDefault 621 | 622 | instance (GEq a, GEnum a, GIx a) => GIx [a] where 623 | range = rangeDefault 624 | index = indexDefault 625 | inRange = inRangeDefault 626 | 627 | instance GIx All where 628 | range = rangeDefault 629 | index = indexDefault 630 | inRange = inRangeDefault 631 | 632 | instance (GEq (f a), GEnum (f a), GIx (f a)) => GIx (Alt f a) where 633 | range = rangeDefault 634 | index = indexDefault 635 | inRange = inRangeDefault 636 | 637 | instance GIx Any where 638 | range = rangeDefault 639 | index = indexDefault 640 | inRange = inRangeDefault 641 | 642 | instance (GEq a, GEnum a, GIx a, GEnum b) => GIx (Arg a b) where 643 | range = rangeDefault 644 | index = indexDefault 645 | inRange = inRangeDefault 646 | 647 | instance GIx Associativity where 648 | range = rangeDefault 649 | index = indexDefault 650 | inRange = inRangeDefault 651 | 652 | instance GIx Bool where 653 | range = rangeDefault 654 | index = indexDefault 655 | inRange = inRangeDefault 656 | 657 | instance GIx CChar where 658 | range = rangeEnum 659 | index = indexIntegral 660 | inRange = inRangeOrd 661 | 662 | #if defined(HTYPE_GID_T) 663 | instance GIx CGid where 664 | range = rangeEnum 665 | index = indexIntegral 666 | inRange = inRangeOrd 667 | #endif 668 | 669 | #if defined(HTYPE_INO_T) 670 | instance GIx CIno where 671 | range = rangeEnum 672 | index = indexIntegral 673 | inRange = inRangeOrd 674 | #endif 675 | 676 | instance GIx CInt where 677 | range = rangeEnum 678 | index = indexIntegral 679 | inRange = inRangeOrd 680 | 681 | instance GIx CIntMax where 682 | range = rangeEnum 683 | index = indexIntegral 684 | inRange = inRangeOrd 685 | 686 | instance GIx CIntPtr where 687 | range = rangeEnum 688 | index = indexIntegral 689 | inRange = inRangeOrd 690 | 691 | instance GIx CLLong where 692 | range = rangeEnum 693 | index = indexIntegral 694 | inRange = inRangeOrd 695 | 696 | instance GIx CLong where 697 | range = rangeEnum 698 | index = indexIntegral 699 | inRange = inRangeOrd 700 | 701 | #if defined(HTYPE_MODE_T) 702 | instance GIx CMode where 703 | range = rangeEnum 704 | index = indexIntegral 705 | inRange = inRangeOrd 706 | #endif 707 | 708 | #if defined(HTYPE_NLINK_T) 709 | instance GIx CNlink where 710 | range = rangeEnum 711 | index = indexIntegral 712 | inRange = inRangeOrd 713 | #endif 714 | 715 | #if defined(HTYPE_OFF_T) 716 | instance GIx COff where 717 | range = rangeEnum 718 | index = indexIntegral 719 | inRange = inRangeOrd 720 | #endif 721 | 722 | #if defined(HTYPE_PID_T) 723 | instance GIx CPid where 724 | range = rangeEnum 725 | index = indexIntegral 726 | inRange = inRangeOrd 727 | #endif 728 | 729 | instance GIx CPtrdiff where 730 | range = rangeEnum 731 | index = indexIntegral 732 | inRange = inRangeOrd 733 | 734 | #if defined(HTYPE_RLIM_T) 735 | instance GIx CRLim where 736 | range = rangeEnum 737 | index = indexIntegral 738 | inRange = inRangeOrd 739 | #endif 740 | 741 | instance GIx CSChar where 742 | range = rangeEnum 743 | index = indexIntegral 744 | inRange = inRangeOrd 745 | 746 | instance GIx CShort where 747 | range = rangeEnum 748 | index = indexIntegral 749 | inRange = inRangeOrd 750 | 751 | instance GIx CSigAtomic where 752 | range = rangeEnum 753 | index = indexIntegral 754 | inRange = inRangeOrd 755 | 756 | instance GIx CSize where 757 | range = rangeEnum 758 | index = indexIntegral 759 | inRange = inRangeOrd 760 | 761 | #if defined(HTYPE_SSIZE_T) 762 | instance GIx CSsize where 763 | range = rangeEnum 764 | index = indexIntegral 765 | inRange = inRangeOrd 766 | #endif 767 | 768 | #if defined(HTYPE_TCFLAG_T) 769 | instance GIx CTcflag where 770 | range = rangeEnum 771 | index = indexIntegral 772 | inRange = inRangeOrd 773 | #endif 774 | 775 | instance GIx CUChar where 776 | range = rangeEnum 777 | index = indexIntegral 778 | inRange = inRangeOrd 779 | 780 | #if defined(HTYPE_UID_T) 781 | instance GIx CUid where 782 | range = rangeEnum 783 | index = indexIntegral 784 | inRange = inRangeOrd 785 | #endif 786 | 787 | instance GIx CUInt where 788 | range = rangeEnum 789 | index = indexIntegral 790 | inRange = inRangeOrd 791 | 792 | instance GIx CUIntMax where 793 | range = rangeEnum 794 | index = indexIntegral 795 | inRange = inRangeOrd 796 | 797 | instance GIx CUIntPtr where 798 | range = rangeEnum 799 | index = indexIntegral 800 | inRange = inRangeOrd 801 | 802 | instance GIx CULLong where 803 | range = rangeEnum 804 | index = indexIntegral 805 | inRange = inRangeOrd 806 | 807 | instance GIx CULong where 808 | range = rangeEnum 809 | index = indexIntegral 810 | inRange = inRangeOrd 811 | 812 | instance GIx CUShort where 813 | range = rangeEnum 814 | index = indexIntegral 815 | inRange = inRangeOrd 816 | 817 | instance GIx CWchar where 818 | range = rangeEnum 819 | index = indexIntegral 820 | inRange = inRangeOrd 821 | 822 | instance (GEq a, GEnum a, GIx a) => GIx (Dual a) where 823 | range = rangeDefault 824 | index = indexDefault 825 | inRange = inRangeDefault 826 | 827 | instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b) => GIx (Either a b) where 828 | range = rangeDefault 829 | index = indexDefault 830 | inRange = inRangeDefault 831 | 832 | instance GIx ExitCode where 833 | range = rangeDefault 834 | index = indexDefault 835 | inRange = inRangeDefault 836 | 837 | instance GIx Fd where 838 | range = rangeEnum 839 | index = indexIntegral 840 | inRange = inRangeOrd 841 | 842 | instance (GEq a, GEnum a, GIx a) => GIx (Monoid.First a) where 843 | range = rangeDefault 844 | index = indexDefault 845 | inRange = inRangeDefault 846 | 847 | instance (GEq a, GEnum a, GIx a) => GIx (Semigroup.First a) where 848 | range = rangeDefault 849 | index = indexDefault 850 | inRange = inRangeDefault 851 | 852 | instance GIx Fixity where 853 | range = rangeDefault 854 | index = indexDefault 855 | inRange = inRangeDefault 856 | 857 | instance (GEq a, GEnum a, GIx a) => GIx (Identity a) where 858 | range = rangeDefault 859 | index = indexDefault 860 | inRange = inRangeDefault 861 | 862 | instance GIx Int where 863 | range = rangeEnum 864 | index = indexIntegral 865 | inRange = inRangeOrd 866 | 867 | instance GIx Int8 where 868 | range = rangeEnum 869 | index = indexIntegral 870 | inRange = inRangeOrd 871 | 872 | instance GIx Int16 where 873 | range = rangeEnum 874 | index = indexIntegral 875 | inRange = inRangeOrd 876 | 877 | instance GIx Int32 where 878 | range = rangeEnum 879 | index = indexIntegral 880 | inRange = inRangeOrd 881 | 882 | instance GIx Int64 where 883 | range = rangeEnum 884 | index = indexIntegral 885 | inRange = inRangeOrd 886 | 887 | instance GIx Integer where 888 | range = rangeEnum 889 | index = indexIntegral 890 | inRange = inRangeOrd 891 | 892 | instance GIx IntPtr where 893 | range = rangeEnum 894 | index = indexIntegral 895 | inRange = inRangeOrd 896 | 897 | instance (GEq a, GEnum a, GIx a) => GIx (Monoid.Last a) where 898 | range = rangeDefault 899 | index = indexDefault 900 | inRange = inRangeDefault 901 | 902 | instance (GEq a, GEnum a, GIx a) => GIx (Semigroup.Last a) where 903 | range = rangeDefault 904 | index = indexDefault 905 | inRange = inRangeDefault 906 | 907 | instance (GEq a, GEnum a, GIx a) => GIx (Max a) where 908 | range = rangeDefault 909 | index = indexDefault 910 | inRange = inRangeDefault 911 | 912 | instance (GEq a, GEnum a, GIx a) => GIx (Maybe a) where 913 | range = rangeDefault 914 | index = indexDefault 915 | inRange = inRangeDefault 916 | 917 | instance (GEq a, GEnum a, GIx a) => GIx (Min a) where 918 | range = rangeDefault 919 | index = indexDefault 920 | inRange = inRangeDefault 921 | 922 | instance GIx Natural where 923 | range = rangeEnum 924 | index = indexIntegral 925 | inRange = inRangeOrd 926 | 927 | instance (GEq a, GEnum a, GIx a) => GIx (NonEmpty a) where 928 | range = rangeDefault 929 | index = indexDefault 930 | inRange = inRangeDefault 931 | 932 | instance GIx Ordering where 933 | range = rangeDefault 934 | index = indexDefault 935 | inRange = inRangeDefault 936 | 937 | instance (GEq a, GEnum a, GIx a) => GIx (Product a) where 938 | range = rangeDefault 939 | index = indexDefault 940 | inRange = inRangeDefault 941 | 942 | instance GIx (Proxy s) where 943 | range = rangeDefault 944 | index = indexDefault 945 | inRange = inRangeDefault 946 | 947 | instance (GEq a, GEnum a, GIx a) => GIx (Sum a) where 948 | range = rangeDefault 949 | index = indexDefault 950 | inRange = inRangeDefault 951 | 952 | instance GIx Word where 953 | range = rangeEnum 954 | index = indexIntegral 955 | inRange = inRangeOrd 956 | 957 | instance GIx Word8 where 958 | range = rangeEnum 959 | index = indexIntegral 960 | inRange = inRangeOrd 961 | 962 | instance GIx Word16 where 963 | range = rangeEnum 964 | index = indexIntegral 965 | inRange = inRangeOrd 966 | 967 | instance GIx Word32 where 968 | range = rangeEnum 969 | index = indexIntegral 970 | inRange = inRangeOrd 971 | 972 | instance GIx Word64 where 973 | range = rangeEnum 974 | index = indexIntegral 975 | inRange = inRangeOrd 976 | 977 | instance GIx WordPtr where 978 | range = rangeEnum 979 | index = indexIntegral 980 | inRange = inRangeOrd 981 | 982 | instance (GEq m, GEnum m, GIx m) => GIx (WrappedMonoid m) where 983 | range = rangeDefault 984 | index = indexDefault 985 | inRange = inRangeDefault 986 | 987 | #if MIN_VERSION_base(4,10,0) 988 | instance GIx CBool where 989 | range = rangeEnum 990 | index = indexIntegral 991 | inRange = inRangeOrd 992 | 993 | # if defined(HTYPE_BLKSIZE_T) 994 | instance GIx CBlkSize where 995 | range = rangeEnum 996 | index = indexIntegral 997 | inRange = inRangeOrd 998 | # endif 999 | 1000 | # if defined(HTYPE_BLKCNT_T) 1001 | instance GIx CBlkCnt where 1002 | range = rangeEnum 1003 | index = indexIntegral 1004 | inRange = inRangeOrd 1005 | # endif 1006 | 1007 | # if defined(HTYPE_CLOCKID_T) 1008 | instance GIx CClockId where 1009 | range = rangeEnum 1010 | index = indexIntegral 1011 | inRange = inRangeOrd 1012 | # endif 1013 | 1014 | # if defined(HTYPE_FSBLKCNT_T) 1015 | instance GIx CFsBlkCnt where 1016 | range = rangeEnum 1017 | index = indexIntegral 1018 | inRange = inRangeOrd 1019 | # endif 1020 | 1021 | # if defined(HTYPE_FSFILCNT_T) 1022 | instance GIx CFsFilCnt where 1023 | range = rangeEnum 1024 | index = indexIntegral 1025 | inRange = inRangeOrd 1026 | # endif 1027 | 1028 | # if defined(HTYPE_ID_T) 1029 | instance GIx CId where 1030 | range = rangeEnum 1031 | index = indexIntegral 1032 | inRange = inRangeOrd 1033 | # endif 1034 | 1035 | # if defined(HTYPE_KEY_T) 1036 | instance GIx CKey where 1037 | range = rangeEnum 1038 | index = indexIntegral 1039 | inRange = inRangeOrd 1040 | # endif 1041 | #endif 1042 | -------------------------------------------------------------------------------- /src/Generics/Deriving/Eq.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DefaultSignatures #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE KindSignatures #-} 6 | {-# LANGUAGE PolyKinds #-} 7 | {-# LANGUAGE Trustworthy #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | {-# LANGUAGE TypeSynonymInstances #-} 11 | {-# LANGUAGE MagicHash #-} 12 | 13 | #include "HsBaseConfig.h" 14 | 15 | module Generics.Deriving.Eq ( 16 | -- * Generic Eq class 17 | GEq(..) 18 | 19 | -- * Default definition 20 | , geqdefault 21 | 22 | -- * Internal Eq class 23 | , GEq'(..) 24 | 25 | ) where 26 | 27 | import Control.Applicative (Const, ZipList) 28 | 29 | import Data.Char (GeneralCategory) 30 | import Data.Complex (Complex) 31 | import Data.Functor.Identity (Identity) 32 | import Data.Int 33 | import Data.List.NonEmpty (NonEmpty) 34 | import qualified Data.Monoid as Monoid (First, Last) 35 | import Data.Monoid (All, Alt, Any, Dual, Product, Sum) 36 | import Data.Proxy (Proxy) 37 | import qualified Data.Semigroup as Semigroup (First, Last) 38 | import Data.Semigroup (Arg(..), Max, Min, WrappedMonoid) 39 | import Data.Version (Version) 40 | import Data.Void (Void) 41 | import Data.Word 42 | 43 | import Foreign.C.Error 44 | import Foreign.C.Types 45 | import Foreign.ForeignPtr (ForeignPtr) 46 | import Foreign.Ptr 47 | import Foreign.StablePtr (StablePtr) 48 | 49 | import Generics.Deriving.Base 50 | 51 | import GHC.Exts hiding (Any) 52 | 53 | import Numeric.Natural (Natural) 54 | 55 | import System.Exit (ExitCode) 56 | import System.IO (BufferMode, Handle, HandlePosn, IOMode, SeekMode) 57 | import System.IO.Error (IOErrorType) 58 | import System.Posix.Types 59 | 60 | -------------------------------------------------------------------------------- 61 | -- Generic show 62 | -------------------------------------------------------------------------------- 63 | 64 | class GEq' f where 65 | geq' :: f a -> f a -> Bool 66 | 67 | instance GEq' V1 where 68 | geq' _ _ = True 69 | 70 | instance GEq' U1 where 71 | geq' _ _ = True 72 | 73 | instance (GEq c) => GEq' (K1 i c) where 74 | geq' (K1 a) (K1 b) = geq a b 75 | 76 | -- No instances for P or Rec because geq is only applicable to types of kind * 77 | 78 | instance (GEq' a) => GEq' (M1 i c a) where 79 | geq' (M1 a) (M1 b) = geq' a b 80 | 81 | instance (GEq' a, GEq' b) => GEq' (a :+: b) where 82 | geq' (L1 a) (L1 b) = geq' a b 83 | geq' (R1 a) (R1 b) = geq' a b 84 | geq' _ _ = False 85 | 86 | instance (GEq' a, GEq' b) => GEq' (a :*: b) where 87 | geq' (a1 :*: b1) (a2 :*: b2) = geq' a1 a2 && geq' b1 b2 88 | 89 | -- Unboxed types 90 | instance GEq' UAddr where 91 | geq' (UAddr a1) (UAddr a2) = isTrue# (eqAddr# a1 a2) 92 | instance GEq' UChar where 93 | geq' (UChar c1) (UChar c2) = isTrue# (eqChar# c1 c2) 94 | instance GEq' UDouble where 95 | geq' (UDouble d1) (UDouble d2) = isTrue# (d1 ==## d2) 96 | instance GEq' UFloat where 97 | geq' (UFloat f1) (UFloat f2) = isTrue# (eqFloat# f1 f2) 98 | instance GEq' UInt where 99 | geq' (UInt i1) (UInt i2) = isTrue# (i1 ==# i2) 100 | instance GEq' UWord where 101 | geq' (UWord w1) (UWord w2) = isTrue# (eqWord# w1 w2) 102 | 103 | 104 | class GEq a where 105 | geq :: a -> a -> Bool 106 | 107 | default geq :: (Generic a, GEq' (Rep a)) => a -> a -> Bool 108 | geq = geqdefault 109 | 110 | geqdefault :: (Generic a, GEq' (Rep a)) => a -> a -> Bool 111 | geqdefault x y = geq' (from x) (from y) 112 | 113 | -- Base types instances 114 | instance GEq () where 115 | geq = geqdefault 116 | 117 | instance (GEq a, GEq b) => GEq (a, b) where 118 | geq = geqdefault 119 | 120 | instance (GEq a, GEq b, GEq c) => GEq (a, b, c) where 121 | geq = geqdefault 122 | 123 | instance (GEq a, GEq b, GEq c, GEq d) => GEq (a, b, c, d) where 124 | geq = geqdefault 125 | 126 | instance (GEq a, GEq b, GEq c, GEq d, GEq e) => GEq (a, b, c, d, e) where 127 | geq = geqdefault 128 | 129 | instance (GEq a, GEq b, GEq c, GEq d, GEq e, GEq f) 130 | => GEq (a, b, c, d, e, f) where 131 | geq = geqdefault 132 | 133 | instance (GEq a, GEq b, GEq c, GEq d, GEq e, GEq f, GEq g) 134 | => GEq (a, b, c, d, e, f, g) where 135 | geq = geqdefault 136 | 137 | instance GEq a => GEq [a] where 138 | geq = geqdefault 139 | 140 | instance (GEq (f p), GEq (g p)) => GEq ((f :+: g) p) where 141 | geq = geqdefault 142 | 143 | instance (GEq (f p), GEq (g p)) => GEq ((f :*: g) p) where 144 | geq = geqdefault 145 | 146 | instance GEq (f (g p)) => GEq ((f :.: g) p) where 147 | geq = geqdefault 148 | 149 | instance GEq All where 150 | geq = geqdefault 151 | 152 | instance GEq (f a) => GEq (Alt f a) where 153 | geq = geqdefault 154 | 155 | instance GEq Any where 156 | geq = geqdefault 157 | 158 | instance GEq a => GEq (Arg a b) where 159 | geq (Arg a _) (Arg b _) = geq a b 160 | 161 | instance GEq Associativity where 162 | geq = geqdefault 163 | 164 | instance GEq Bool where 165 | geq = geqdefault 166 | 167 | instance GEq BufferMode where 168 | geq = (==) 169 | 170 | #if defined(HTYPE_CC_T) 171 | instance GEq CCc where 172 | geq = (==) 173 | #endif 174 | 175 | instance GEq CChar where 176 | geq = (==) 177 | 178 | instance GEq CClock where 179 | geq = (==) 180 | 181 | #if defined(HTYPE_DEV_T) 182 | instance GEq CDev where 183 | geq = (==) 184 | #endif 185 | 186 | instance GEq CDouble where 187 | geq = (==) 188 | 189 | instance GEq CFloat where 190 | geq = (==) 191 | 192 | #if defined(HTYPE_GID_T) 193 | instance GEq CGid where 194 | geq = (==) 195 | #endif 196 | 197 | instance GEq Char where 198 | geq = (==) 199 | 200 | #if defined(HTYPE_INO_T) 201 | instance GEq CIno where 202 | geq = (==) 203 | #endif 204 | 205 | instance GEq CInt where 206 | geq = (==) 207 | 208 | instance GEq CIntMax where 209 | geq = (==) 210 | 211 | instance GEq CIntPtr where 212 | geq = (==) 213 | 214 | instance GEq CLLong where 215 | geq = (==) 216 | 217 | instance GEq CLong where 218 | geq = (==) 219 | 220 | #if defined(HTYPE_MODE_T) 221 | instance GEq CMode where 222 | geq = (==) 223 | #endif 224 | 225 | #if defined(HTYPE_NLINK_T) 226 | instance GEq CNlink where 227 | geq = (==) 228 | #endif 229 | 230 | #if defined(HTYPE_OFF_T) 231 | instance GEq COff where 232 | geq = (==) 233 | #endif 234 | 235 | instance GEq a => GEq (Complex a) where 236 | geq = geqdefault 237 | 238 | instance GEq a => GEq (Const a b) where 239 | geq = geqdefault 240 | 241 | #if defined(HTYPE_PID_T) 242 | instance GEq CPid where 243 | geq = (==) 244 | #endif 245 | 246 | instance GEq CPtrdiff where 247 | geq = (==) 248 | 249 | #if defined(HTYPE_RLIM_T) 250 | instance GEq CRLim where 251 | geq = (==) 252 | #endif 253 | 254 | instance GEq CSChar where 255 | geq = (==) 256 | 257 | #if defined(HTYPE_SPEED_T) 258 | instance GEq CSpeed where 259 | geq = (==) 260 | #endif 261 | 262 | instance GEq CSUSeconds where 263 | geq = (==) 264 | 265 | instance GEq CShort where 266 | geq = (==) 267 | 268 | instance GEq CSigAtomic where 269 | geq = (==) 270 | 271 | instance GEq CSize where 272 | geq = (==) 273 | 274 | #if defined(HTYPE_SSIZE_T) 275 | instance GEq CSsize where 276 | geq = (==) 277 | #endif 278 | 279 | #if defined(HTYPE_TCFLAG_T) 280 | instance GEq CTcflag where 281 | geq = (==) 282 | #endif 283 | 284 | instance GEq CTime where 285 | geq = (==) 286 | 287 | instance GEq CUChar where 288 | geq = (==) 289 | 290 | #if defined(HTYPE_UID_T) 291 | instance GEq CUid where 292 | geq = (==) 293 | #endif 294 | 295 | instance GEq CUInt where 296 | geq = (==) 297 | 298 | instance GEq CUIntMax where 299 | geq = (==) 300 | 301 | instance GEq CUIntPtr where 302 | geq = (==) 303 | 304 | instance GEq CULLong where 305 | geq = (==) 306 | 307 | instance GEq CULong where 308 | geq = (==) 309 | 310 | instance GEq CUSeconds where 311 | geq = (==) 312 | 313 | instance GEq CUShort where 314 | geq = (==) 315 | 316 | instance GEq CWchar where 317 | geq = (==) 318 | 319 | instance GEq DecidedStrictness where 320 | geq = geqdefault 321 | 322 | instance GEq Double where 323 | geq = (==) 324 | 325 | instance GEq a => GEq (Down a) where 326 | geq = geqdefault 327 | 328 | instance GEq a => GEq (Dual a) where 329 | geq = geqdefault 330 | 331 | instance (GEq a, GEq b) => GEq (Either a b) where 332 | geq = geqdefault 333 | 334 | instance GEq Errno where 335 | geq = (==) 336 | 337 | instance GEq ExitCode where 338 | geq = geqdefault 339 | 340 | instance GEq Fd where 341 | geq = (==) 342 | 343 | instance GEq a => GEq (Monoid.First a) where 344 | geq = geqdefault 345 | 346 | instance GEq a => GEq (Semigroup.First a) where 347 | geq = geqdefault 348 | 349 | instance GEq Fixity where 350 | geq = geqdefault 351 | 352 | instance GEq Float where 353 | geq = (==) 354 | 355 | instance GEq (ForeignPtr a) where 356 | geq = (==) 357 | 358 | instance GEq (FunPtr a) where 359 | geq = (==) 360 | 361 | instance GEq GeneralCategory where 362 | geq = (==) 363 | 364 | instance GEq Handle where 365 | geq = (==) 366 | 367 | instance GEq HandlePosn where 368 | geq = (==) 369 | 370 | instance GEq a => GEq (Identity a) where 371 | geq = geqdefault 372 | 373 | instance GEq Int where 374 | geq = (==) 375 | 376 | instance GEq Int8 where 377 | geq = (==) 378 | 379 | instance GEq Int16 where 380 | geq = (==) 381 | 382 | instance GEq Int32 where 383 | geq = (==) 384 | 385 | instance GEq Int64 where 386 | geq = (==) 387 | 388 | instance GEq Integer where 389 | geq = (==) 390 | 391 | instance GEq IntPtr where 392 | geq = (==) 393 | 394 | instance GEq IOError where 395 | geq = (==) 396 | 397 | instance GEq IOErrorType where 398 | geq = (==) 399 | 400 | instance GEq IOMode where 401 | geq = (==) 402 | 403 | instance GEq c => GEq (K1 i c p) where 404 | geq = geqdefault 405 | 406 | instance GEq a => GEq (Monoid.Last a) where 407 | geq = geqdefault 408 | 409 | instance GEq a => GEq (Semigroup.Last a) where 410 | geq = geqdefault 411 | 412 | instance GEq (f p) => GEq (M1 i c f p) where 413 | geq = geqdefault 414 | 415 | instance GEq a => GEq (Maybe a) where 416 | geq = geqdefault 417 | 418 | instance GEq a => GEq (Max a) where 419 | geq = geqdefault 420 | 421 | instance GEq a => GEq (Min a) where 422 | geq = geqdefault 423 | 424 | instance GEq Natural where 425 | geq = (==) 426 | 427 | instance GEq a => GEq (NonEmpty a) where 428 | geq = geqdefault 429 | 430 | instance GEq Ordering where 431 | geq = geqdefault 432 | 433 | instance GEq p => GEq (Par1 p) where 434 | geq = geqdefault 435 | 436 | instance GEq a => GEq (Product a) where 437 | geq = geqdefault 438 | 439 | instance GEq (Proxy s) where 440 | geq = geqdefault 441 | 442 | instance GEq (Ptr a) where 443 | geq = (==) 444 | 445 | instance GEq (f p) => GEq (Rec1 f p) where 446 | geq = geqdefault 447 | 448 | instance GEq SeekMode where 449 | geq = (==) 450 | 451 | instance GEq (StablePtr a) where 452 | geq = (==) 453 | 454 | instance GEq SourceStrictness where 455 | geq = geqdefault 456 | 457 | instance GEq SourceUnpackedness where 458 | geq = geqdefault 459 | 460 | instance GEq a => GEq (Sum a) where 461 | geq = geqdefault 462 | 463 | instance GEq (U1 p) where 464 | geq = geqdefault 465 | 466 | instance GEq (UAddr p) where 467 | geq = geqdefault 468 | 469 | instance GEq (UChar p) where 470 | geq = geqdefault 471 | 472 | instance GEq (UDouble p) where 473 | geq = geqdefault 474 | 475 | instance GEq (UFloat p) where 476 | geq = geqdefault 477 | 478 | instance GEq (UInt p) where 479 | geq = geqdefault 480 | 481 | instance GEq (UWord p) where 482 | geq = geqdefault 483 | 484 | instance GEq Version where 485 | geq = (==) 486 | 487 | instance GEq Void where 488 | geq = (==) 489 | 490 | instance GEq Word where 491 | geq = (==) 492 | 493 | instance GEq Word8 where 494 | geq = (==) 495 | 496 | instance GEq Word16 where 497 | geq = (==) 498 | 499 | instance GEq Word32 where 500 | geq = (==) 501 | 502 | instance GEq Word64 where 503 | geq = (==) 504 | 505 | instance GEq WordPtr where 506 | geq = (==) 507 | 508 | instance GEq m => GEq (WrappedMonoid m) where 509 | geq = geqdefault 510 | 511 | instance GEq a => GEq (ZipList a) where 512 | geq = geqdefault 513 | 514 | #if MIN_VERSION_base(4,10,0) 515 | instance GEq CBool where 516 | geq = (==) 517 | 518 | # if defined(HTYPE_BLKSIZE_T) 519 | instance GEq CBlkSize where 520 | geq = (==) 521 | # endif 522 | 523 | # if defined(HTYPE_BLKCNT_T) 524 | instance GEq CBlkCnt where 525 | geq = (==) 526 | # endif 527 | 528 | # if defined(HTYPE_CLOCKID_T) 529 | instance GEq CClockId where 530 | geq = (==) 531 | # endif 532 | 533 | # if defined(HTYPE_FSBLKCNT_T) 534 | instance GEq CFsBlkCnt where 535 | geq = (==) 536 | # endif 537 | 538 | # if defined(HTYPE_FSFILCNT_T) 539 | instance GEq CFsFilCnt where 540 | geq = (==) 541 | # endif 542 | 543 | # if defined(HTYPE_ID_T) 544 | instance GEq CId where 545 | geq = (==) 546 | # endif 547 | 548 | # if defined(HTYPE_KEY_T) 549 | instance GEq CKey where 550 | geq = (==) 551 | # endif 552 | 553 | # if defined(HTYPE_TIMER_T) 554 | instance GEq CTimer where 555 | geq = (==) 556 | # endif 557 | #endif 558 | -------------------------------------------------------------------------------- /src/Generics/Deriving/Foldable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | {-# LANGUAGE Safe #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | {-# LANGUAGE TypeSynonymInstances #-} 8 | 9 | module Generics.Deriving.Foldable ( 10 | -- * Generic Foldable class 11 | GFoldable(..) 12 | 13 | -- * Default method 14 | , gfoldMapdefault 15 | 16 | -- * Derived functions 17 | , gtoList 18 | , gconcat 19 | , gconcatMap 20 | , gand 21 | , gor 22 | , gany 23 | , gall 24 | , gsum 25 | , gproduct 26 | , gmaximum 27 | , gmaximumBy 28 | , gminimum 29 | , gminimumBy 30 | , gelem 31 | , gnotElem 32 | , gfind 33 | 34 | -- * Internal Foldable class 35 | , GFoldable'(..) 36 | ) where 37 | 38 | import Control.Applicative (Const, ZipList) 39 | 40 | import Data.Complex (Complex) 41 | import Data.Functor.Identity (Identity) 42 | import qualified Data.Functor.Product as Functor (Product) 43 | import qualified Data.Functor.Sum as Functor (Sum) 44 | import Data.List.NonEmpty (NonEmpty) 45 | import Data.Maybe 46 | import qualified Data.Monoid as Monoid (First, Last, Product(..), Sum(..)) 47 | import Data.Monoid (All(..), Any(..), Dual(..), Endo(..)) 48 | import Data.Ord (Down) 49 | import Data.Proxy (Proxy) 50 | import qualified Data.Semigroup as Semigroup (First, Last) 51 | import Data.Semigroup (Arg, Max, Min, WrappedMonoid) 52 | 53 | import Generics.Deriving.Base 54 | 55 | -------------------------------------------------------------------------------- 56 | -- Generic fold 57 | -------------------------------------------------------------------------------- 58 | 59 | class GFoldable' t where 60 | gfoldMap' :: Monoid m => (a -> m) -> t a -> m 61 | 62 | instance GFoldable' V1 where 63 | gfoldMap' _ _ = mempty 64 | 65 | instance GFoldable' U1 where 66 | gfoldMap' _ U1 = mempty 67 | 68 | instance GFoldable' Par1 where 69 | gfoldMap' f (Par1 a) = f a 70 | 71 | instance GFoldable' (K1 i c) where 72 | gfoldMap' _ (K1 _) = mempty 73 | 74 | instance (GFoldable f) => GFoldable' (Rec1 f) where 75 | gfoldMap' f (Rec1 a) = gfoldMap f a 76 | 77 | instance (GFoldable' f) => GFoldable' (M1 i c f) where 78 | gfoldMap' f (M1 a) = gfoldMap' f a 79 | 80 | instance (GFoldable' f, GFoldable' g) => GFoldable' (f :+: g) where 81 | gfoldMap' f (L1 a) = gfoldMap' f a 82 | gfoldMap' f (R1 a) = gfoldMap' f a 83 | 84 | instance (GFoldable' f, GFoldable' g) => GFoldable' (f :*: g) where 85 | gfoldMap' f (a :*: b) = mappend (gfoldMap' f a) (gfoldMap' f b) 86 | 87 | instance (GFoldable f, GFoldable' g) => GFoldable' (f :.: g) where 88 | gfoldMap' f (Comp1 x) = gfoldMap (gfoldMap' f) x 89 | 90 | instance GFoldable' UAddr where 91 | gfoldMap' _ (UAddr _) = mempty 92 | 93 | instance GFoldable' UChar where 94 | gfoldMap' _ (UChar _) = mempty 95 | 96 | instance GFoldable' UDouble where 97 | gfoldMap' _ (UDouble _) = mempty 98 | 99 | instance GFoldable' UFloat where 100 | gfoldMap' _ (UFloat _) = mempty 101 | 102 | instance GFoldable' UInt where 103 | gfoldMap' _ (UInt _) = mempty 104 | 105 | instance GFoldable' UWord where 106 | gfoldMap' _ (UWord _) = mempty 107 | 108 | class GFoldable t where 109 | gfoldMap :: Monoid m => (a -> m) -> t a -> m 110 | default gfoldMap :: (Generic1 t, GFoldable' (Rep1 t), Monoid m) 111 | => (a -> m) -> t a -> m 112 | gfoldMap = gfoldMapdefault 113 | 114 | gfold :: Monoid m => t m -> m 115 | gfold = gfoldMap id 116 | 117 | gfoldr :: (a -> b -> b) -> b -> t a -> b 118 | gfoldr f z t = appEndo (gfoldMap (Endo . f) t) z 119 | 120 | gfoldr' :: (a -> b -> b) -> b -> t a -> b 121 | gfoldr' f z0 xs = gfoldl f' id xs z0 122 | where f' k x z = k $! f x z 123 | 124 | gfoldl :: (a -> b -> a) -> a -> t b -> a 125 | gfoldl f z t = appEndo (getDual (gfoldMap (Dual . Endo . flip f) t)) z 126 | 127 | gfoldl' :: (a -> b -> a) -> a -> t b -> a 128 | gfoldl' f z0 xs = gfoldr f' id xs z0 129 | where f' x k z = k $! f z x 130 | 131 | gfoldr1 :: (a -> a -> a) -> t a -> a 132 | gfoldr1 f xs = fromMaybe (error "gfoldr1: empty structure") 133 | (gfoldr mf Nothing xs) 134 | where 135 | mf x Nothing = Just x 136 | mf x (Just y) = Just (f x y) 137 | 138 | gfoldl1 :: (a -> a -> a) -> t a -> a 139 | gfoldl1 f xs = fromMaybe (error "foldl1: empty structure") 140 | (gfoldl mf Nothing xs) 141 | where 142 | mf Nothing y = Just y 143 | mf (Just x) y = Just (f x y) 144 | 145 | gfoldMapdefault :: (Generic1 t, GFoldable' (Rep1 t), Monoid m) 146 | => (a -> m) -> t a -> m 147 | gfoldMapdefault f x = gfoldMap' f (from1 x) 148 | 149 | -- Base types instances 150 | instance GFoldable ((,) a) where 151 | gfoldMap = gfoldMapdefault 152 | 153 | instance GFoldable [] where 154 | gfoldMap = gfoldMapdefault 155 | 156 | instance GFoldable (Arg a) where 157 | gfoldMap = gfoldMapdefault 158 | 159 | instance GFoldable Complex where 160 | gfoldMap = gfoldMapdefault 161 | 162 | instance GFoldable (Const m) where 163 | gfoldMap = gfoldMapdefault 164 | 165 | instance GFoldable Down where 166 | gfoldMap = gfoldMapdefault 167 | 168 | instance GFoldable Dual where 169 | gfoldMap = gfoldMapdefault 170 | 171 | instance GFoldable (Either a) where 172 | gfoldMap = gfoldMapdefault 173 | 174 | instance GFoldable Monoid.First where 175 | gfoldMap = gfoldMapdefault 176 | 177 | instance GFoldable (Semigroup.First) where 178 | gfoldMap = gfoldMapdefault 179 | 180 | instance GFoldable Identity where 181 | gfoldMap = gfoldMapdefault 182 | 183 | instance GFoldable Monoid.Last where 184 | gfoldMap = gfoldMapdefault 185 | 186 | instance GFoldable Semigroup.Last where 187 | gfoldMap = gfoldMapdefault 188 | 189 | instance GFoldable Max where 190 | gfoldMap = gfoldMapdefault 191 | 192 | instance GFoldable Maybe where 193 | gfoldMap = gfoldMapdefault 194 | 195 | instance GFoldable Min where 196 | gfoldMap = gfoldMapdefault 197 | 198 | instance GFoldable NonEmpty where 199 | gfoldMap = gfoldMapdefault 200 | 201 | instance GFoldable Monoid.Product where 202 | gfoldMap = gfoldMapdefault 203 | 204 | instance (GFoldable f, GFoldable g) => GFoldable (Functor.Product f g) where 205 | gfoldMap = gfoldMapdefault 206 | 207 | instance GFoldable Proxy where 208 | gfoldMap = gfoldMapdefault 209 | 210 | instance GFoldable Monoid.Sum where 211 | gfoldMap = gfoldMapdefault 212 | 213 | instance (GFoldable f, GFoldable g) => GFoldable (Functor.Sum f g) where 214 | gfoldMap = gfoldMapdefault 215 | 216 | instance GFoldable WrappedMonoid where 217 | gfoldMap = gfoldMapdefault 218 | 219 | instance GFoldable ZipList where 220 | gfoldMap = gfoldMapdefault 221 | 222 | gtoList :: GFoldable t => t a -> [a] 223 | gtoList = gfoldr (:) [] 224 | 225 | gconcat :: GFoldable t => t [a] -> [a] 226 | gconcat = gfold 227 | 228 | gconcatMap :: GFoldable t => (a -> [b]) -> t a -> [b] 229 | gconcatMap = gfoldMap 230 | 231 | gand :: GFoldable t => t Bool -> Bool 232 | gand = getAll . gfoldMap All 233 | 234 | gor :: GFoldable t => t Bool -> Bool 235 | gor = getAny . gfoldMap Any 236 | 237 | gany :: GFoldable t => (a -> Bool) -> t a -> Bool 238 | gany p = getAny . gfoldMap (Any . p) 239 | 240 | gall :: GFoldable t => (a -> Bool) -> t a -> Bool 241 | gall p = getAll . gfoldMap (All . p) 242 | 243 | gsum :: (GFoldable t, Num a) => t a -> a 244 | gsum = Monoid.getSum . gfoldMap Monoid.Sum 245 | 246 | gproduct :: (GFoldable t, Num a) => t a -> a 247 | gproduct = Monoid.getProduct . gfoldMap Monoid.Product 248 | 249 | gmaximum :: (GFoldable t, Ord a) => t a -> a 250 | gmaximum = gfoldr1 max 251 | 252 | gmaximumBy :: GFoldable t => (a -> a -> Ordering) -> t a -> a 253 | gmaximumBy cmp = gfoldr1 max' 254 | where max' x y = case cmp x y of 255 | GT -> x 256 | _ -> y 257 | 258 | gminimum :: (GFoldable t, Ord a) => t a -> a 259 | gminimum = gfoldr1 min 260 | 261 | gminimumBy :: GFoldable t => (a -> a -> Ordering) -> t a -> a 262 | gminimumBy cmp = gfoldr1 min' 263 | where min' x y = case cmp x y of 264 | GT -> y 265 | _ -> x 266 | 267 | gelem :: (GFoldable t, Eq a) => a -> t a -> Bool 268 | gelem = gany . (==) 269 | 270 | gnotElem :: (GFoldable t, Eq a) => a -> t a -> Bool 271 | gnotElem x = not . gelem x 272 | 273 | gfind :: GFoldable t => (a -> Bool) -> t a -> Maybe a 274 | gfind p = listToMaybe . gconcatMap (\ x -> if p x then [x] else []) 275 | -------------------------------------------------------------------------------- /src/Generics/Deriving/Functor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DefaultSignatures #-} 3 | {-# LANGUAGE EmptyCase #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE PolyKinds #-} 7 | {-# LANGUAGE Safe #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | {-# LANGUAGE TypeSynonymInstances #-} 10 | 11 | module Generics.Deriving.Functor ( 12 | -- * Generic Functor class 13 | GFunctor(..) 14 | 15 | -- * Default method 16 | , gmapdefault 17 | 18 | -- * Internal Functor class 19 | , GFunctor'(..) 20 | 21 | ) where 22 | 23 | import Control.Applicative (Const, ZipList) 24 | 25 | import Data.Complex (Complex) 26 | import Data.Functor.Identity (Identity) 27 | import qualified Data.Functor.Product as Functor (Product) 28 | import qualified Data.Functor.Sum as Functor (Sum) 29 | import Data.List.NonEmpty (NonEmpty) 30 | import qualified Data.Monoid as Monoid (First, Last, Product, Sum) 31 | import Data.Monoid (Alt, Dual) 32 | import Data.Ord (Down) 33 | import Data.Proxy (Proxy) 34 | import qualified Data.Semigroup as Semigroup (First, Last) 35 | import Data.Semigroup (Arg, Max, Min, WrappedMonoid) 36 | 37 | import Generics.Deriving.Base 38 | 39 | -------------------------------------------------------------------------------- 40 | -- Generic fmap 41 | -------------------------------------------------------------------------------- 42 | 43 | class GFunctor' f where 44 | gmap' :: (a -> b) -> f a -> f b 45 | 46 | instance GFunctor' V1 where 47 | gmap' _ x = case x of {} 48 | 49 | instance GFunctor' U1 where 50 | gmap' _ U1 = U1 51 | 52 | instance GFunctor' Par1 where 53 | gmap' f (Par1 a) = Par1 (f a) 54 | 55 | instance GFunctor' (K1 i c) where 56 | gmap' _ (K1 a) = K1 a 57 | 58 | instance (GFunctor f) => GFunctor' (Rec1 f) where 59 | gmap' f (Rec1 a) = Rec1 (gmap f a) 60 | 61 | instance (GFunctor' f) => GFunctor' (M1 i c f) where 62 | gmap' f (M1 a) = M1 (gmap' f a) 63 | 64 | instance (GFunctor' f, GFunctor' g) => GFunctor' (f :+: g) where 65 | gmap' f (L1 a) = L1 (gmap' f a) 66 | gmap' f (R1 a) = R1 (gmap' f a) 67 | 68 | instance (GFunctor' f, GFunctor' g) => GFunctor' (f :*: g) where 69 | gmap' f (a :*: b) = gmap' f a :*: gmap' f b 70 | 71 | instance (GFunctor f, GFunctor' g) => GFunctor' (f :.: g) where 72 | gmap' f (Comp1 x) = Comp1 (gmap (gmap' f) x) 73 | 74 | instance GFunctor' UAddr where 75 | gmap' _ (UAddr a) = UAddr a 76 | 77 | instance GFunctor' UChar where 78 | gmap' _ (UChar c) = UChar c 79 | 80 | instance GFunctor' UDouble where 81 | gmap' _ (UDouble d) = UDouble d 82 | 83 | instance GFunctor' UFloat where 84 | gmap' _ (UFloat f) = UFloat f 85 | 86 | instance GFunctor' UInt where 87 | gmap' _ (UInt i) = UInt i 88 | 89 | instance GFunctor' UWord where 90 | gmap' _ (UWord w) = UWord w 91 | 92 | class GFunctor f where 93 | gmap :: (a -> b) -> f a -> f b 94 | default gmap :: (Generic1 f, GFunctor' (Rep1 f)) 95 | => (a -> b) -> f a -> f b 96 | gmap = gmapdefault 97 | 98 | gmapdefault :: (Generic1 f, GFunctor' (Rep1 f)) 99 | => (a -> b) -> f a -> f b 100 | gmapdefault f = to1 . gmap' f . from1 101 | 102 | -- Base types instances 103 | instance GFunctor ((->) r) where 104 | gmap = fmap 105 | 106 | instance GFunctor ((,) a) where 107 | gmap = gmapdefault 108 | 109 | instance GFunctor [] where 110 | gmap = gmapdefault 111 | 112 | instance GFunctor f => GFunctor (Alt f) where 113 | gmap = gmapdefault 114 | 115 | instance GFunctor (Arg a) where 116 | gmap = gmapdefault 117 | 118 | instance GFunctor Complex where 119 | gmap = gmapdefault 120 | 121 | instance GFunctor (Const m) where 122 | gmap = gmapdefault 123 | 124 | instance GFunctor Down where 125 | gmap = gmapdefault 126 | 127 | instance GFunctor Dual where 128 | gmap = gmapdefault 129 | 130 | instance GFunctor (Either a) where 131 | gmap = gmapdefault 132 | 133 | instance GFunctor Monoid.First where 134 | gmap = gmapdefault 135 | 136 | instance GFunctor (Semigroup.First) where 137 | gmap = gmapdefault 138 | 139 | instance GFunctor Identity where 140 | gmap = gmapdefault 141 | 142 | instance GFunctor IO where 143 | gmap = fmap 144 | 145 | instance GFunctor Monoid.Last where 146 | gmap = gmapdefault 147 | 148 | instance GFunctor Semigroup.Last where 149 | gmap = gmapdefault 150 | 151 | instance GFunctor Max where 152 | gmap = gmapdefault 153 | 154 | instance GFunctor Maybe where 155 | gmap = gmapdefault 156 | 157 | instance GFunctor Min where 158 | gmap = gmapdefault 159 | 160 | instance GFunctor NonEmpty where 161 | gmap = gmapdefault 162 | 163 | instance GFunctor Monoid.Product where 164 | gmap = gmapdefault 165 | 166 | instance (GFunctor f, GFunctor g) => GFunctor (Functor.Product f g) where 167 | gmap = gmapdefault 168 | 169 | instance GFunctor Proxy where 170 | gmap = gmapdefault 171 | 172 | instance GFunctor Monoid.Sum where 173 | gmap = gmapdefault 174 | 175 | instance (GFunctor f, GFunctor g) => GFunctor (Functor.Sum f g) where 176 | gmap = gmapdefault 177 | 178 | instance GFunctor WrappedMonoid where 179 | gmap = gmapdefault 180 | 181 | instance GFunctor ZipList where 182 | gmap = gmapdefault 183 | -------------------------------------------------------------------------------- /src/Generics/Deriving/Instances.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE EmptyDataDecls #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE PolyKinds #-} 8 | {-# LANGUAGE Safe #-} 9 | {-# LANGUAGE StandaloneDeriving #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | {-# LANGUAGE TypeSynonymInstances #-} 13 | 14 | {-# OPTIONS_GHC -Wno-orphans #-} 15 | 16 | module Generics.Deriving.Instances ( 17 | -- Only instances from GHC.Generics 18 | -- and the Generic1 instances 19 | #if !(MIN_VERSION_base(4,16,0)) 20 | Rep0Tuple8 21 | , Rep0Tuple9 22 | , Rep0Tuple10 23 | , Rep0Tuple11 24 | , Rep0Tuple12 25 | , Rep0Tuple13 26 | , Rep0Tuple14 27 | , Rep0Tuple15 28 | , Rep1Tuple8 29 | , Rep1Tuple9 30 | , Rep1Tuple10 31 | , Rep1Tuple11 32 | , Rep1Tuple12 33 | , Rep1Tuple13 34 | , Rep1Tuple14 35 | , Rep1Tuple15 36 | #endif 37 | #if !(MIN_VERSION_base(4,14,0)) 38 | , Rep0Kleisli 39 | , Rep1Kleisli 40 | #endif 41 | #if !(MIN_VERSION_base(4,12,0)) 42 | , Rep0Down 43 | , Rep1Down 44 | #endif 45 | ) where 46 | 47 | #if !(MIN_VERSION_base(4,12,0)) 48 | import Data.Ord (Down(..)) 49 | #endif 50 | 51 | #if !(MIN_VERSION_base(4,14,0)) 52 | import Control.Arrow (Kleisli(..)) 53 | #endif 54 | 55 | #if !(MIN_VERSION_base(4,16,0)) 56 | import GHC.Generics 57 | #endif 58 | 59 | #if !(MIN_VERSION_base(4,16,0)) 60 | type Rep0Tuple8 a b c d e f g h = Rep (a, b, c, d, e, f, g, h) 61 | type Rep0Tuple9 a b c d e f g h i = Rep (a, b, c, d, e, f, g, h, i) 62 | type Rep0Tuple10 a b c d e f g h i j = Rep (a, b, c, d, e, f, g, h, i, j) 63 | type Rep0Tuple11 a b c d e f g h i j k = Rep (a, b, c, d, e, f, g, h, i, j, k) 64 | type Rep0Tuple12 a b c d e f g h i j k l = Rep (a, b, c, d, e, f, g, h, i, j, k, l) 65 | type Rep0Tuple13 a b c d e f g h i j k l m = Rep (a, b, c, d, e, f, g, h, i, j, k, l, m) 66 | type Rep0Tuple14 a b c d e f g h i j k l m n = Rep (a, b, c, d, e, f, g, h, i, j, k, l, m, n) 67 | type Rep0Tuple15 a b c d e f g h i j k l m n o = Rep (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) 68 | type Rep1Tuple8 a b c d e f g = Rep1 ((,,,,,,,) a b c d e f g) 69 | type Rep1Tuple9 a b c d e f g h = Rep1 ((,,,,,,,,) a b c d e f g h) 70 | type Rep1Tuple10 a b c d e f g h i = Rep1 ((,,,,,,,,,) a b c d e f g h i) 71 | type Rep1Tuple11 a b c d e f g h i j = Rep1 ((,,,,,,,,,,) a b c d e f g h i j) 72 | type Rep1Tuple12 a b c d e f g h i j k = Rep1 ((,,,,,,,,,,,) a b c d e f g h i j k) 73 | type Rep1Tuple13 a b c d e f g h i j k l = Rep1 ((,,,,,,,,,,,,) a b c d e f g h i j k l) 74 | type Rep1Tuple14 a b c d e f g h i j k l m = Rep1 ((,,,,,,,,,,,,,) a b c d e f g h i j k l m) 75 | type Rep1Tuple15 a b c d e f g h i j k l m n = Rep1 ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n) 76 | deriving instance Generic (a, b, c, d, e, f, g, h) 77 | deriving instance Generic (a, b, c, d, e, f, g, h, i) 78 | deriving instance Generic (a, b, c, d, e, f, g, h, i, j) 79 | deriving instance Generic (a, b, c, d, e, f, g, h, i, j, k) 80 | deriving instance Generic (a, b, c, d, e, f, g, h, i, j, k, l) 81 | deriving instance Generic (a, b, c, d, e, f, g, h, i, j, k, l, m) 82 | deriving instance Generic (a, b, c, d, e, f, g, h, i, j, k, l, m, n) 83 | deriving instance Generic (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) 84 | deriving instance Generic1 ((,,,,,,,) a b c d e f g) 85 | deriving instance Generic1 ((,,,,,,,,) a b c d e f g h) 86 | deriving instance Generic1 ((,,,,,,,,,) a b c d e f g h i) 87 | deriving instance Generic1 ((,,,,,,,,,,) a b c d e f g h i j) 88 | deriving instance Generic1 ((,,,,,,,,,,,) a b c d e f g h i j k) 89 | deriving instance Generic1 ((,,,,,,,,,,,,) a b c d e f g h i j k l) 90 | deriving instance Generic1 ((,,,,,,,,,,,,,) a b c d e f g h i j k l m) 91 | deriving instance Generic1 ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n) 92 | #endif 93 | 94 | #if !(MIN_VERSION_base(4,14,0)) 95 | type Rep0Kleisli m a b = Rep (Kleisli m a b) 96 | type Rep1Kleisli m a = Rep1 (Kleisli m a) 97 | deriving instance Generic (Kleisli m a b) 98 | deriving instance Generic1 (Kleisli m a) 99 | #endif 100 | 101 | #if !(MIN_VERSION_base(4,12,0)) 102 | type Rep0Down a = Rep (Down a) 103 | type Rep1Down = Rep1 Down 104 | deriving instance Generic (Down a) 105 | deriving instance Generic1 Down 106 | #endif 107 | -------------------------------------------------------------------------------- /src/Generics/Deriving/Monoid.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | {-# OPTIONS_GHC -Wno-orphans #-} 3 | 4 | module Generics.Deriving.Monoid (module Generics.Deriving.Monoid.Internal) where 5 | 6 | import Data.Semigroup (WrappedMonoid) 7 | 8 | import Generics.Deriving.Monoid.Internal 9 | import Generics.Deriving.Semigroup (GSemigroup(..)) 10 | 11 | instance GSemigroup a => GMonoid (Maybe a) where 12 | gmempty = Nothing 13 | gmappend = gsappend 14 | 15 | instance GMonoid m => GMonoid (WrappedMonoid m) where 16 | gmempty = gmemptydefault 17 | gmappend = gmappenddefault 18 | -------------------------------------------------------------------------------- /src/Generics/Deriving/Monoid/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | {-# LANGUAGE Safe #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | module Generics.Deriving.Monoid.Internal ( 9 | 10 | -- * Introduction 11 | {- | This module provides two main features: 12 | 13 | 1. 'GMonoid', a generic version of the 'Monoid' type class, including instances 14 | of the types from "Data.Monoid" 15 | 16 | 2. Default generic definitions for the 'Monoid' methods 'mempty' and 'mappend' 17 | 18 | The generic defaults only work for types without alternatives (i.e. they have 19 | only one constructor). We cannot in general know how to deal with different 20 | constructors. 21 | -} 22 | 23 | -- * GMonoid type class 24 | GMonoid(..), 25 | 26 | -- * Default definitions 27 | -- ** GMonoid 28 | gmemptydefault, 29 | gmappenddefault, 30 | 31 | -- * Internal auxiliary class for GMonoid 32 | GMonoid'(..), 33 | 34 | -- ** Monoid 35 | {- | These functions can be used in a 'Monoid' instance. For example: 36 | 37 | @ 38 | -- LANGUAGE DeriveGeneric 39 | 40 | import Generics.Deriving.Base (Generic) 41 | import Generics.Deriving.Monoid 42 | 43 | data T a = C a (Maybe a) deriving Generic 44 | 45 | instance Monoid a => Monoid (T a) where 46 | mempty = memptydefault 47 | mappend = mappenddefault 48 | @ 49 | -} 50 | memptydefault, 51 | mappenddefault, 52 | 53 | -- * Internal auxiliary class for Monoid 54 | Monoid'(..), 55 | 56 | -- * The Monoid module 57 | -- | This is exported for convenient access to the various wrapper types. 58 | module Data.Monoid, 59 | 60 | ) where 61 | 62 | -------------------------------------------------------------------------------- 63 | 64 | import Control.Applicative 65 | import Data.Functor.Identity (Identity) 66 | import Data.Monoid 67 | import Data.Ord (Down) 68 | import Data.Proxy (Proxy) 69 | import Generics.Deriving.Base 70 | import Generics.Deriving.Semigroup.Internal 71 | 72 | -------------------------------------------------------------------------------- 73 | 74 | class GSemigroup' f => GMonoid' f where 75 | gmempty' :: f x 76 | gmappend' :: f x -> f x -> f x 77 | 78 | instance GMonoid' U1 where 79 | gmempty' = U1 80 | gmappend' U1 U1 = U1 81 | 82 | instance GMonoid a => GMonoid' (K1 i a) where 83 | gmempty' = K1 gmempty 84 | gmappend' (K1 x) (K1 y) = K1 (x `gmappend` y) 85 | 86 | instance GMonoid' f => GMonoid' (M1 i c f) where 87 | gmempty' = M1 gmempty' 88 | gmappend' (M1 x) (M1 y) = M1 (x `gmappend'` y) 89 | 90 | instance (GMonoid' f, GMonoid' h) => GMonoid' (f :*: h) where 91 | gmempty' = gmempty' :*: gmempty' 92 | gmappend' (x1 :*: y1) (x2 :*: y2) = gmappend' x1 x2 :*: gmappend' y1 y2 93 | 94 | -------------------------------------------------------------------------------- 95 | 96 | gmemptydefault :: (Generic a, GMonoid' (Rep a)) => a 97 | gmemptydefault = to gmempty' 98 | 99 | gmappenddefault :: (Generic a, GMonoid' (Rep a)) => a -> a -> a 100 | gmappenddefault x y = to (gmappend' (from x) (from y)) 101 | 102 | -------------------------------------------------------------------------------- 103 | 104 | class Monoid' f where 105 | mempty' :: f x 106 | mappend' :: f x -> f x -> f x 107 | 108 | instance Monoid' U1 where 109 | mempty' = U1 110 | mappend' U1 U1 = U1 111 | 112 | instance Monoid a => Monoid' (K1 i a) where 113 | mempty' = K1 mempty 114 | mappend' (K1 x) (K1 y) = K1 (x `mappend` y) 115 | 116 | instance Monoid' f => Monoid' (M1 i c f) where 117 | mempty' = M1 mempty' 118 | mappend' (M1 x) (M1 y) = M1 (x `mappend'` y) 119 | 120 | instance (Monoid' f, Monoid' h) => Monoid' (f :*: h) where 121 | mempty' = mempty' :*: mempty' 122 | mappend' (x1 :*: y1) (x2 :*: y2) = mappend' x1 x2 :*: mappend' y1 y2 123 | 124 | -------------------------------------------------------------------------------- 125 | 126 | memptydefault :: (Generic a, Monoid' (Rep a)) => a 127 | memptydefault = to mempty' 128 | 129 | mappenddefault :: (Generic a, Monoid' (Rep a)) => a -> a -> a 130 | mappenddefault x y = to (mappend' (from x) (from y)) 131 | 132 | -------------------------------------------------------------------------------- 133 | 134 | class GSemigroup a => GMonoid a where 135 | 136 | -- | Generic 'mempty' 137 | gmempty :: a 138 | 139 | -- | Generic 'mappend' 140 | gmappend :: a -> a -> a 141 | 142 | -- | Generic 'mconcat' 143 | gmconcat :: [a] -> a 144 | gmconcat = foldr gmappend gmempty 145 | 146 | default gmempty :: (Generic a, GMonoid' (Rep a)) => a 147 | gmempty = to gmempty' 148 | 149 | default gmappend :: (Generic a, GMonoid' (Rep a)) => a -> a -> a 150 | gmappend x y = to (gmappend' (from x) (from y)) 151 | 152 | -------------------------------------------------------------------------------- 153 | 154 | -- Instances that reuse Monoid 155 | instance GMonoid Ordering where 156 | gmempty = mempty 157 | gmappend = mappend 158 | instance GMonoid () where 159 | gmempty = mempty 160 | gmappend = mappend 161 | instance GMonoid Any where 162 | gmempty = mempty 163 | gmappend = mappend 164 | instance GMonoid All where 165 | gmempty = mempty 166 | gmappend = mappend 167 | instance GMonoid (First a) where 168 | gmempty = mempty 169 | gmappend = mappend 170 | instance GMonoid (Last a) where 171 | gmempty = mempty 172 | gmappend = mappend 173 | instance Num a => GMonoid (Sum a) where 174 | gmempty = mempty 175 | gmappend = mappend 176 | instance Num a => GMonoid (Product a) where 177 | gmempty = mempty 178 | gmappend = mappend 179 | instance GMonoid [a] where 180 | gmempty = mempty 181 | gmappend = mappend 182 | instance GMonoid (Endo a) where 183 | gmempty = mempty 184 | gmappend = mappend 185 | instance Alternative f => GMonoid (Alt f a) where 186 | gmempty = mempty 187 | gmappend = mappend 188 | 189 | -- Handwritten instances 190 | instance GMonoid a => GMonoid (Dual a) where 191 | gmempty = Dual gmempty 192 | gmappend (Dual x) (Dual y) = Dual (gmappend y x) 193 | instance GMonoid b => GMonoid (a -> b) where 194 | gmempty _ = gmempty 195 | gmappend f g x = gmappend (f x) (g x) 196 | instance GMonoid a => GMonoid (Const a b) where 197 | gmempty = gmemptydefault 198 | gmappend = gmappenddefault 199 | instance GMonoid a => GMonoid (Down a) where 200 | gmempty = gmemptydefault 201 | gmappend = gmappenddefault 202 | 203 | instance GMonoid (Proxy s) where 204 | gmempty = memptydefault 205 | gmappend = mappenddefault 206 | 207 | instance GMonoid a => GMonoid (Identity a) where 208 | gmempty = gmemptydefault 209 | gmappend = gmappenddefault 210 | 211 | -- Tuple instances 212 | instance (GMonoid a,GMonoid b) => GMonoid (a,b) where 213 | gmempty = (gmempty,gmempty) 214 | gmappend (a1,b1) (a2,b2) = 215 | (gmappend a1 a2,gmappend b1 b2) 216 | instance (GMonoid a,GMonoid b,GMonoid c) => GMonoid (a,b,c) where 217 | gmempty = (gmempty,gmempty,gmempty) 218 | gmappend (a1,b1,c1) (a2,b2,c2) = 219 | (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2) 220 | instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d) => GMonoid (a,b,c,d) where 221 | gmempty = (gmempty,gmempty,gmempty,gmempty) 222 | gmappend (a1,b1,c1,d1) (a2,b2,c2,d2) = 223 | (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2) 224 | instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e) => GMonoid (a,b,c,d,e) where 225 | gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty) 226 | gmappend (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2) = 227 | (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2) 228 | instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e,GMonoid f) => GMonoid (a,b,c,d,e,f) where 229 | gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty,gmempty) 230 | gmappend (a1,b1,c1,d1,e1,f1) (a2,b2,c2,d2,e2,f2) = 231 | (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2,gmappend f1 f2) 232 | instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e,GMonoid f,GMonoid g) => GMonoid (a,b,c,d,e,f,g) where 233 | gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty,gmempty,gmempty) 234 | gmappend (a1,b1,c1,d1,e1,f1,g1) (a2,b2,c2,d2,e2,f2,g2) = 235 | (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2,gmappend f1 f2,gmappend g1 g2) 236 | instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e,GMonoid f,GMonoid g,GMonoid h) => GMonoid (a,b,c,d,e,f,g,h) where 237 | gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty,gmempty,gmempty,gmempty) 238 | gmappend (a1,b1,c1,d1,e1,f1,g1,h1) (a2,b2,c2,d2,e2,f2,g2,h2) = 239 | (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2,gmappend f1 f2,gmappend g1 g2,gmappend h1 h2) 240 | -------------------------------------------------------------------------------- /src/Generics/Deriving/Semigroup.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | {-# OPTIONS_GHC -Wno-orphans #-} 3 | 4 | module Generics.Deriving.Semigroup (module Generics.Deriving.Semigroup.Internal) where 5 | 6 | import Data.Semigroup (WrappedMonoid(..)) 7 | 8 | import Generics.Deriving.Monoid.Internal (GMonoid(..)) 9 | import Generics.Deriving.Semigroup.Internal 10 | 11 | instance GMonoid m => GSemigroup (WrappedMonoid m) where 12 | gsappend (WrapMonoid a) (WrapMonoid b) = WrapMonoid (gmappend a b) 13 | -------------------------------------------------------------------------------- /src/Generics/Deriving/Semigroup/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | {-# LANGUAGE Safe #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | module Generics.Deriving.Semigroup.Internal ( 9 | -- * Generic semigroup class 10 | GSemigroup(..) 11 | 12 | -- * Default definition 13 | , gsappenddefault 14 | 15 | -- * Internal semigroup class 16 | , GSemigroup'(..) 17 | 18 | ) where 19 | 20 | import Control.Applicative 21 | import Data.Functor.Identity (Identity) 22 | import Data.List.NonEmpty (NonEmpty(..)) 23 | import Data.Monoid as Monoid hiding ((<>)) 24 | import Data.Ord (Down) 25 | import Data.Proxy (Proxy) 26 | import Data.Semigroup as Semigroup 27 | import Data.Void (Void) 28 | import Generics.Deriving.Base 29 | 30 | ------------------------------------------------------------------------------- 31 | 32 | infixr 6 `gsappend'` 33 | class GSemigroup' f where 34 | gsappend' :: f x -> f x -> f x 35 | 36 | instance GSemigroup' U1 where 37 | gsappend' U1 U1 = U1 38 | 39 | instance GSemigroup a => GSemigroup' (K1 i a) where 40 | gsappend' (K1 x) (K1 y) = K1 (gsappend x y) 41 | 42 | instance GSemigroup' f => GSemigroup' (M1 i c f) where 43 | gsappend' (M1 x) (M1 y) = M1 (gsappend' x y) 44 | 45 | instance (GSemigroup' f, GSemigroup' g) => GSemigroup' (f :*: g) where 46 | gsappend' (x1 :*: y1) (x2 :*: y2) = gsappend' x1 x2 :*: gsappend' y1 y2 47 | 48 | ------------------------------------------------------------------------------- 49 | 50 | infixr 6 `gsappend` 51 | class GSemigroup a where 52 | gsappend :: a -> a -> a 53 | default gsappend :: (Generic a, GSemigroup' (Rep a)) => a -> a -> a 54 | gsappend = gsappenddefault 55 | 56 | gstimes :: Integral b => b -> a -> a 57 | gstimes y0 x0 58 | | y0 <= 0 = error "gstimes: positive multiplier expected" 59 | | otherwise = f x0 y0 60 | where 61 | f x y 62 | | even y = f (gsappend x x) (y `quot` 2) 63 | | y == 1 = x 64 | | otherwise = g (gsappend x x) (pred y `quot` 2) x 65 | g x y z 66 | | even y = g (gsappend x x) (y `quot` 2) z 67 | | y == 1 = gsappend x z 68 | | otherwise = g (gsappend x x) (pred y `quot` 2) (gsappend x z) 69 | 70 | gsconcat :: NonEmpty a -> a 71 | gsconcat (a :| as) = go a as where 72 | go b (c:cs) = gsappend b (go c cs) 73 | go b [] = b 74 | 75 | infixr 6 `gsappenddefault` 76 | gsappenddefault :: (Generic a, GSemigroup' (Rep a)) => a -> a -> a 77 | gsappenddefault x y = to (gsappend' (from x) (from y)) 78 | 79 | ------------------------------------------------------------------------------- 80 | 81 | -- Instances that reuse Monoid 82 | instance GSemigroup Ordering where 83 | gsappend = mappend 84 | instance GSemigroup () where 85 | gsappend = mappend 86 | instance GSemigroup Any where 87 | gsappend = mappend 88 | instance GSemigroup All where 89 | gsappend = mappend 90 | instance GSemigroup (Monoid.First a) where 91 | gsappend = mappend 92 | instance GSemigroup (Monoid.Last a) where 93 | gsappend = mappend 94 | instance Num a => GSemigroup (Sum a) where 95 | gsappend = mappend 96 | instance Num a => GSemigroup (Product a) where 97 | gsappend = mappend 98 | instance GSemigroup [a] where 99 | gsappend = mappend 100 | instance GSemigroup (Endo a) where 101 | gsappend = mappend 102 | instance Alternative f => GSemigroup (Alt f a) where 103 | gsappend = mappend 104 | 105 | -- Handwritten instances 106 | instance GSemigroup a => GSemigroup (Dual a) where 107 | gsappend (Dual x) (Dual y) = Dual (gsappend y x) 108 | instance GSemigroup a => GSemigroup (Maybe a) where 109 | gsappend Nothing x = x 110 | gsappend x Nothing = x 111 | gsappend (Just x) (Just y) = Just (gsappend x y) 112 | instance GSemigroup b => GSemigroup (a -> b) where 113 | gsappend f g x = gsappend (f x) (g x) 114 | instance GSemigroup a => GSemigroup (Const a b) where 115 | gsappend = gsappenddefault 116 | instance GSemigroup a => GSemigroup (Down a) where 117 | gsappend = gsappenddefault 118 | instance GSemigroup (Either a b) where 119 | gsappend Left{} b = b 120 | gsappend a _ = a 121 | 122 | instance GSemigroup (Proxy s) where 123 | gsappend = gsappenddefault 124 | 125 | instance GSemigroup a => GSemigroup (Identity a) where 126 | gsappend = gsappenddefault 127 | 128 | instance GSemigroup Void where 129 | gsappend a _ = a 130 | 131 | instance GSemigroup (Semigroup.First a) where 132 | gsappend = (<>) 133 | 134 | instance GSemigroup (Semigroup.Last a) where 135 | gsappend = (<>) 136 | 137 | instance Ord a => GSemigroup (Max a) where 138 | gsappend = (<>) 139 | 140 | instance Ord a => GSemigroup (Min a) where 141 | gsappend = (<>) 142 | 143 | instance GSemigroup (NonEmpty a) where 144 | gsappend = (<>) 145 | 146 | -- Tuple instances 147 | instance (GSemigroup a,GSemigroup b) => GSemigroup (a,b) where 148 | gsappend (a1,b1) (a2,b2) = 149 | (gsappend a1 a2,gsappend b1 b2) 150 | instance (GSemigroup a,GSemigroup b,GSemigroup c) => GSemigroup (a,b,c) where 151 | gsappend (a1,b1,c1) (a2,b2,c2) = 152 | (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2) 153 | instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d) => GSemigroup (a,b,c,d) where 154 | gsappend (a1,b1,c1,d1) (a2,b2,c2,d2) = 155 | (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2) 156 | instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d,GSemigroup e) => GSemigroup (a,b,c,d,e) where 157 | gsappend (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2) = 158 | (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2,gsappend e1 e2) 159 | instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d,GSemigroup e,GSemigroup f) => GSemigroup (a,b,c,d,e,f) where 160 | gsappend (a1,b1,c1,d1,e1,f1) (a2,b2,c2,d2,e2,f2) = 161 | (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2,gsappend e1 e2,gsappend f1 f2) 162 | instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d,GSemigroup e,GSemigroup f,GSemigroup g) => GSemigroup (a,b,c,d,e,f,g) where 163 | gsappend (a1,b1,c1,d1,e1,f1,g1) (a2,b2,c2,d2,e2,f2,g2) = 164 | (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2,gsappend e1 e2,gsappend f1 f2,gsappend g1 g2) 165 | instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d,GSemigroup e,GSemigroup f,GSemigroup g,GSemigroup h) => GSemigroup (a,b,c,d,e,f,g,h) where 166 | gsappend (a1,b1,c1,d1,e1,f1,g1,h1) (a2,b2,c2,d2,e2,f2,g2,h2) = 167 | (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2,gsappend e1 e2,gsappend f1 f2,gsappend g1 g2,gsappend h1 h2) 168 | -------------------------------------------------------------------------------- /src/Generics/Deriving/Show.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE DefaultSignatures #-} 4 | {-# LANGUAGE EmptyCase #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE MagicHash #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE Trustworthy #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE TypeSynonymInstances #-} 12 | 13 | module Generics.Deriving.Show ( 14 | -- * Generic show class 15 | GShow(..) 16 | 17 | -- * Default definition 18 | , gshowsPrecdefault 19 | 20 | -- * Internal show class 21 | , GShow'(..) 22 | 23 | ) where 24 | 25 | import Control.Applicative (Const, ZipList) 26 | 27 | import Data.Char (GeneralCategory) 28 | import Data.Complex (Complex) 29 | import Data.Functor.Identity (Identity) 30 | import Data.Int 31 | import Data.List.NonEmpty (NonEmpty) 32 | import Data.Monoid (All, Alt, Any, Dual, Product, Sum) 33 | import qualified Data.Monoid as Monoid (First, Last) 34 | import Data.Proxy (Proxy) 35 | import qualified Data.Semigroup as Semigroup (First, Last) 36 | import Data.Semigroup (Arg, Max, Min, WrappedMonoid) 37 | import Data.Version (Version) 38 | import Data.Void (Void) 39 | import Data.Word 40 | 41 | import Foreign.C.Types 42 | import Foreign.ForeignPtr (ForeignPtr) 43 | import Foreign.Ptr 44 | 45 | import Generics.Deriving.Base 46 | 47 | import GHC.Exts hiding (Any) 48 | 49 | import Numeric.Natural (Natural) 50 | 51 | import System.Exit (ExitCode) 52 | import System.IO (BufferMode, Handle, HandlePosn, IOMode, SeekMode) 53 | import System.IO.Error (IOErrorType) 54 | import System.Posix.Types 55 | 56 | -------------------------------------------------------------------------------- 57 | -- Generic show 58 | -------------------------------------------------------------------------------- 59 | 60 | intersperse :: a -> [a] -> [a] 61 | intersperse _ [] = [] 62 | intersperse _ [h] = [h] 63 | intersperse x (h:t) = h : x : (intersperse x t) 64 | 65 | appPrec :: Int 66 | appPrec = 2 67 | 68 | data Type = Rec | Tup | Pref | Inf String 69 | 70 | class GShow' f where 71 | gshowsPrec' :: Type -> Int -> f a -> ShowS 72 | isNullary :: f a -> Bool 73 | isNullary = error "generic show (isNullary): unnecessary case" 74 | 75 | instance GShow' V1 where 76 | gshowsPrec' _ _ x = case x of {} 77 | 78 | instance GShow' U1 where 79 | gshowsPrec' _ _ U1 = id 80 | isNullary _ = True 81 | 82 | instance (GShow c) => GShow' (K1 i c) where 83 | gshowsPrec' _ n (K1 a) = gshowsPrec n a 84 | isNullary _ = False 85 | 86 | -- No instances for P or Rec because gshow is only applicable to types of kind * 87 | 88 | instance (GShow' a, Constructor c) => GShow' (M1 C c a) where 89 | gshowsPrec' _ n c@(M1 x) = 90 | case fixity of 91 | Prefix -> showParen (n > appPrec && not (isNullary x)) 92 | ( showString (conName c) 93 | . if (isNullary x) then id else showChar ' ' 94 | . showBraces t (gshowsPrec' t appPrec x)) 95 | Infix _ m -> showParen (n > m) (showBraces t (gshowsPrec' t m x)) 96 | where fixity = conFixity c 97 | t = if (conIsRecord c) then Rec else 98 | case (conIsTuple c) of 99 | True -> Tup 100 | False -> case fixity of 101 | Prefix -> Pref 102 | Infix _ _ -> Inf (show (conName c)) 103 | showBraces :: Type -> ShowS -> ShowS 104 | showBraces Rec p = showChar '{' . p . showChar '}' 105 | showBraces Tup p = showChar '(' . p . showChar ')' 106 | showBraces Pref p = p 107 | showBraces (Inf _) p = p 108 | 109 | conIsTuple :: C1 c f p -> Bool 110 | conIsTuple y = tupleName (conName y) where 111 | tupleName ('(':',':_) = True 112 | tupleName _ = False 113 | 114 | instance (Selector s, GShow' a) => GShow' (M1 S s a) where 115 | gshowsPrec' t n s@(M1 x) | selName s == "" = --showParen (n > appPrec) 116 | (gshowsPrec' t n x) 117 | | otherwise = showString (selName s) 118 | . showString " = " 119 | . gshowsPrec' t 0 x 120 | isNullary (M1 x) = isNullary x 121 | 122 | instance (GShow' a) => GShow' (M1 D d a) where 123 | gshowsPrec' t n (M1 x) = gshowsPrec' t n x 124 | 125 | instance (GShow' a, GShow' b) => GShow' (a :+: b) where 126 | gshowsPrec' t n (L1 x) = gshowsPrec' t n x 127 | gshowsPrec' t n (R1 x) = gshowsPrec' t n x 128 | 129 | instance (GShow' a, GShow' b) => GShow' (a :*: b) where 130 | gshowsPrec' t@Rec n (a :*: b) = 131 | gshowsPrec' t n a . showString ", " . gshowsPrec' t n b 132 | gshowsPrec' t@(Inf s) n (a :*: b) = 133 | gshowsPrec' t n a . showString s . gshowsPrec' t n b 134 | gshowsPrec' t@Tup n (a :*: b) = 135 | gshowsPrec' t n a . showChar ',' . gshowsPrec' t n b 136 | gshowsPrec' t@Pref n (a :*: b) = 137 | gshowsPrec' t (n+1) a . showChar ' ' . gshowsPrec' t (n+1) b 138 | 139 | -- If we have a product then it is not a nullary constructor 140 | isNullary _ = False 141 | 142 | -- Unboxed types 143 | instance GShow' UChar where 144 | gshowsPrec' _ _ (UChar c) = showsPrec 0 (C# c) . showChar '#' 145 | instance GShow' UDouble where 146 | gshowsPrec' _ _ (UDouble d) = showsPrec 0 (D# d) . showString "##" 147 | instance GShow' UFloat where 148 | gshowsPrec' _ _ (UFloat f) = showsPrec 0 (F# f) . showChar '#' 149 | instance GShow' UInt where 150 | gshowsPrec' _ _ (UInt i) = showsPrec 0 (I# i) . showChar '#' 151 | instance GShow' UWord where 152 | gshowsPrec' _ _ (UWord w) = showsPrec 0 (W# w) . showString "##" 153 | 154 | 155 | class GShow a where 156 | gshowsPrec :: Int -> a -> ShowS 157 | default gshowsPrec :: (Generic a, GShow' (Rep a)) 158 | => Int -> a -> ShowS 159 | gshowsPrec = gshowsPrecdefault 160 | 161 | gshows :: a -> ShowS 162 | gshows = gshowsPrec 0 163 | 164 | gshow :: a -> String 165 | gshow x = gshows x "" 166 | 167 | gshowList :: [a] -> ShowS 168 | gshowList l = showChar '[' 169 | . foldr (.) id 170 | (intersperse (showChar ',') (map (gshowsPrec 0) l)) 171 | . showChar ']' 172 | 173 | gshowsPrecdefault :: (Generic a, GShow' (Rep a)) 174 | => Int -> a -> ShowS 175 | gshowsPrecdefault n = gshowsPrec' Pref n . from 176 | 177 | 178 | -- Base types instances 179 | -- Base types instances 180 | instance GShow () where 181 | gshowsPrec = gshowsPrecdefault 182 | 183 | instance (GShow a, GShow b) => GShow (a, b) where 184 | gshowsPrec = gshowsPrecdefault 185 | 186 | instance (GShow a, GShow b, GShow c) => GShow (a, b, c) where 187 | gshowsPrec = gshowsPrecdefault 188 | 189 | instance (GShow a, GShow b, GShow c, GShow d) => GShow (a, b, c, d) where 190 | gshowsPrec = gshowsPrecdefault 191 | 192 | instance (GShow a, GShow b, GShow c, GShow d, GShow e) => GShow (a, b, c, d, e) where 193 | gshowsPrec = gshowsPrecdefault 194 | 195 | instance (GShow a, GShow b, GShow c, GShow d, GShow e, GShow f) 196 | => GShow (a, b, c, d, e, f) where 197 | gshowsPrec = gshowsPrecdefault 198 | 199 | instance (GShow a, GShow b, GShow c, GShow d, GShow e, GShow f, GShow g) 200 | => GShow (a, b, c, d, e, f, g) where 201 | gshowsPrec = gshowsPrecdefault 202 | 203 | instance GShow a => GShow [a] where 204 | gshowsPrec _ = gshowList 205 | 206 | instance (GShow (f p), GShow (g p)) => GShow ((f :+: g) p) where 207 | gshowsPrec = gshowsPrecdefault 208 | 209 | instance (GShow (f p), GShow (g p)) => GShow ((f :*: g) p) where 210 | gshowsPrec = gshowsPrecdefault 211 | 212 | instance GShow (f (g p)) => GShow ((f :.: g) p) where 213 | gshowsPrec = gshowsPrecdefault 214 | 215 | instance GShow All where 216 | gshowsPrec = gshowsPrecdefault 217 | 218 | instance GShow (f a) => GShow (Alt f a) where 219 | gshowsPrec = gshowsPrecdefault 220 | 221 | instance GShow Any where 222 | gshowsPrec = gshowsPrecdefault 223 | 224 | instance (GShow a, GShow b) => GShow (Arg a b) where 225 | gshowsPrec = gshowsPrecdefault 226 | 227 | instance GShow Associativity where 228 | gshowsPrec = gshowsPrecdefault 229 | 230 | instance GShow Bool where 231 | gshowsPrec = gshowsPrecdefault 232 | 233 | instance GShow BufferMode where 234 | gshowsPrec = showsPrec 235 | 236 | #if defined(HTYPE_CC_T) 237 | instance GShow CCc where 238 | gshowsPrec = showsPrec 239 | #endif 240 | 241 | instance GShow CChar where 242 | gshowsPrec = showsPrec 243 | 244 | instance GShow CClock where 245 | gshowsPrec = showsPrec 246 | 247 | #if defined(HTYPE_DEV_T) 248 | instance GShow CDev where 249 | gshowsPrec = showsPrec 250 | #endif 251 | 252 | instance GShow CDouble where 253 | gshowsPrec = showsPrec 254 | 255 | instance GShow CFloat where 256 | gshowsPrec = showsPrec 257 | 258 | #if defined(HTYPE_GID_T) 259 | instance GShow CGid where 260 | gshowsPrec = showsPrec 261 | #endif 262 | 263 | instance GShow Char where 264 | gshowsPrec = showsPrec 265 | gshowList = showList 266 | 267 | #if defined(HTYPE_INO_T) 268 | instance GShow CIno where 269 | gshowsPrec = showsPrec 270 | #endif 271 | 272 | instance GShow CInt where 273 | gshowsPrec = showsPrec 274 | 275 | instance GShow CIntMax where 276 | gshowsPrec = showsPrec 277 | 278 | instance GShow CIntPtr where 279 | gshowsPrec = showsPrec 280 | 281 | instance GShow CLLong where 282 | gshowsPrec = showsPrec 283 | 284 | instance GShow CLong where 285 | gshowsPrec = showsPrec 286 | 287 | #if defined(HTYPE_MODE_T) 288 | instance GShow CMode where 289 | gshowsPrec = showsPrec 290 | #endif 291 | 292 | #if defined(HTYPE_NLINK_T) 293 | instance GShow CNlink where 294 | gshowsPrec = showsPrec 295 | #endif 296 | 297 | #if defined(HTYPE_OFF_T) 298 | instance GShow COff where 299 | gshowsPrec = showsPrec 300 | #endif 301 | 302 | instance GShow a => GShow (Complex a) where 303 | gshowsPrec = gshowsPrecdefault 304 | 305 | instance GShow a => GShow (Const a b) where 306 | gshowsPrec = gshowsPrecdefault 307 | 308 | #if defined(HTYPE_PID_T) 309 | instance GShow CPid where 310 | gshowsPrec = showsPrec 311 | #endif 312 | 313 | instance GShow CPtrdiff where 314 | gshowsPrec = showsPrec 315 | 316 | #if defined(HTYPE_RLIM_T) 317 | instance GShow CRLim where 318 | gshowsPrec = showsPrec 319 | #endif 320 | 321 | instance GShow CSChar where 322 | gshowsPrec = showsPrec 323 | 324 | #if defined(HTYPE_SPEED_T) 325 | instance GShow CSpeed where 326 | gshowsPrec = showsPrec 327 | #endif 328 | 329 | instance GShow CSUSeconds where 330 | gshowsPrec = showsPrec 331 | 332 | instance GShow CShort where 333 | gshowsPrec = showsPrec 334 | 335 | instance GShow CSigAtomic where 336 | gshowsPrec = showsPrec 337 | 338 | instance GShow CSize where 339 | gshowsPrec = showsPrec 340 | 341 | #if defined(HTYPE_SSIZE_T) 342 | instance GShow CSsize where 343 | gshowsPrec = showsPrec 344 | #endif 345 | 346 | #if defined(HTYPE_TCFLAG_T) 347 | instance GShow CTcflag where 348 | gshowsPrec = showsPrec 349 | #endif 350 | 351 | instance GShow CTime where 352 | gshowsPrec = showsPrec 353 | 354 | instance GShow CUChar where 355 | gshowsPrec = showsPrec 356 | 357 | #if defined(HTYPE_UID_T) 358 | instance GShow CUid where 359 | gshowsPrec = showsPrec 360 | #endif 361 | 362 | instance GShow CUInt where 363 | gshowsPrec = showsPrec 364 | 365 | instance GShow CUIntMax where 366 | gshowsPrec = showsPrec 367 | 368 | instance GShow CUIntPtr where 369 | gshowsPrec = showsPrec 370 | 371 | instance GShow CULLong where 372 | gshowsPrec = showsPrec 373 | 374 | instance GShow CULong where 375 | gshowsPrec = showsPrec 376 | 377 | instance GShow CUSeconds where 378 | gshowsPrec = showsPrec 379 | 380 | instance GShow CUShort where 381 | gshowsPrec = showsPrec 382 | 383 | instance GShow CWchar where 384 | gshowsPrec = showsPrec 385 | 386 | instance GShow Double where 387 | gshowsPrec = showsPrec 388 | 389 | instance GShow a => GShow (Down a) where 390 | gshowsPrec = gshowsPrecdefault 391 | 392 | instance GShow a => GShow (Dual a) where 393 | gshowsPrec = gshowsPrecdefault 394 | 395 | instance (GShow a, GShow b) => GShow (Either a b) where 396 | gshowsPrec = gshowsPrecdefault 397 | 398 | instance GShow ExitCode where 399 | gshowsPrec = gshowsPrecdefault 400 | 401 | instance GShow Fd where 402 | gshowsPrec = showsPrec 403 | 404 | instance GShow a => GShow (Monoid.First a) where 405 | gshowsPrec = gshowsPrecdefault 406 | 407 | instance GShow a => GShow (Semigroup.First a) where 408 | gshowsPrec = gshowsPrecdefault 409 | 410 | instance GShow Fixity where 411 | gshowsPrec = gshowsPrecdefault 412 | 413 | instance GShow Float where 414 | gshowsPrec = showsPrec 415 | 416 | instance GShow (ForeignPtr a) where 417 | gshowsPrec = showsPrec 418 | 419 | instance GShow (FunPtr a) where 420 | gshowsPrec = showsPrec 421 | 422 | instance GShow GeneralCategory where 423 | gshowsPrec = showsPrec 424 | 425 | instance GShow Handle where 426 | gshowsPrec = showsPrec 427 | 428 | instance GShow HandlePosn where 429 | gshowsPrec = showsPrec 430 | 431 | instance GShow a => GShow (Identity a) where 432 | gshowsPrec = gshowsPrecdefault 433 | 434 | instance GShow Int where 435 | gshowsPrec = showsPrec 436 | 437 | instance GShow Int8 where 438 | gshowsPrec = showsPrec 439 | 440 | instance GShow Int16 where 441 | gshowsPrec = showsPrec 442 | 443 | instance GShow Int32 where 444 | gshowsPrec = showsPrec 445 | 446 | instance GShow Int64 where 447 | gshowsPrec = showsPrec 448 | 449 | instance GShow Integer where 450 | gshowsPrec = showsPrec 451 | 452 | instance GShow IntPtr where 453 | gshowsPrec = showsPrec 454 | 455 | instance GShow IOError where 456 | gshowsPrec = showsPrec 457 | 458 | instance GShow IOErrorType where 459 | gshowsPrec = showsPrec 460 | 461 | instance GShow IOMode where 462 | gshowsPrec = showsPrec 463 | 464 | instance GShow c => GShow (K1 i c p) where 465 | gshowsPrec = gshowsPrecdefault 466 | 467 | instance GShow a => GShow (Monoid.Last a) where 468 | gshowsPrec = gshowsPrecdefault 469 | 470 | instance GShow a => GShow (Semigroup.Last a) where 471 | gshowsPrec = gshowsPrecdefault 472 | 473 | instance GShow (f p) => GShow (M1 i c f p) where 474 | gshowsPrec = gshowsPrecdefault 475 | 476 | instance GShow a => GShow (Max a) where 477 | gshowsPrec = gshowsPrecdefault 478 | 479 | instance GShow a => GShow (Maybe a) where 480 | gshowsPrec = gshowsPrecdefault 481 | 482 | instance GShow a => GShow (Min a) where 483 | gshowsPrec = gshowsPrecdefault 484 | 485 | instance GShow Natural where 486 | gshowsPrec = showsPrec 487 | 488 | instance GShow a => GShow (NonEmpty a) where 489 | gshowsPrec = gshowsPrecdefault 490 | 491 | instance GShow Ordering where 492 | gshowsPrec = gshowsPrecdefault 493 | 494 | instance GShow p => GShow (Par1 p) where 495 | gshowsPrec = gshowsPrecdefault 496 | 497 | instance GShow a => GShow (Product a) where 498 | gshowsPrec = gshowsPrecdefault 499 | 500 | instance GShow (Proxy s) where 501 | gshowsPrec = gshowsPrecdefault 502 | 503 | instance GShow (Ptr a) where 504 | gshowsPrec = showsPrec 505 | 506 | instance GShow (f p) => GShow (Rec1 f p) where 507 | gshowsPrec = gshowsPrecdefault 508 | 509 | instance GShow SeekMode where 510 | gshowsPrec = showsPrec 511 | 512 | instance GShow a => GShow (Sum a) where 513 | gshowsPrec = gshowsPrecdefault 514 | 515 | instance GShow (U1 p) where 516 | gshowsPrec = gshowsPrecdefault 517 | 518 | instance GShow (UChar p) where 519 | gshowsPrec = gshowsPrecdefault 520 | 521 | instance GShow (UDouble p) where 522 | gshowsPrec = gshowsPrecdefault 523 | 524 | instance GShow (UFloat p) where 525 | gshowsPrec = gshowsPrecdefault 526 | 527 | instance GShow (UInt p) where 528 | gshowsPrec = gshowsPrecdefault 529 | 530 | instance GShow (UWord p) where 531 | gshowsPrec = gshowsPrecdefault 532 | 533 | instance GShow Version where 534 | gshowsPrec = gshowsPrecdefault 535 | 536 | instance GShow Void where 537 | gshowsPrec = showsPrec 538 | 539 | instance GShow Word where 540 | gshowsPrec = showsPrec 541 | 542 | instance GShow Word8 where 543 | gshowsPrec = showsPrec 544 | 545 | instance GShow Word16 where 546 | gshowsPrec = showsPrec 547 | 548 | instance GShow Word32 where 549 | gshowsPrec = showsPrec 550 | 551 | instance GShow Word64 where 552 | gshowsPrec = showsPrec 553 | 554 | instance GShow WordPtr where 555 | gshowsPrec = showsPrec 556 | 557 | instance GShow m => GShow (WrappedMonoid m) where 558 | gshowsPrec = gshowsPrecdefault 559 | 560 | instance GShow a => GShow (ZipList a) where 561 | gshowsPrec = gshowsPrecdefault 562 | 563 | #if MIN_VERSION_base(4,10,0) 564 | instance GShow CBool where 565 | gshowsPrec = showsPrec 566 | 567 | # if defined(HTYPE_BLKSIZE_T) 568 | instance GShow CBlkSize where 569 | gshowsPrec = showsPrec 570 | # endif 571 | 572 | # if defined(HTYPE_BLKCNT_T) 573 | instance GShow CBlkCnt where 574 | gshowsPrec = showsPrec 575 | # endif 576 | 577 | # if defined(HTYPE_CLOCKID_T) 578 | instance GShow CClockId where 579 | gshowsPrec = showsPrec 580 | # endif 581 | 582 | # if defined(HTYPE_FSBLKCNT_T) 583 | instance GShow CFsBlkCnt where 584 | gshowsPrec = showsPrec 585 | # endif 586 | 587 | # if defined(HTYPE_FSFILCNT_T) 588 | instance GShow CFsFilCnt where 589 | gshowsPrec = showsPrec 590 | # endif 591 | 592 | # if defined(HTYPE_ID_T) 593 | instance GShow CId where 594 | gshowsPrec = showsPrec 595 | # endif 596 | 597 | # if defined(HTYPE_KEY_T) 598 | instance GShow CKey where 599 | gshowsPrec = showsPrec 600 | # endif 601 | 602 | # if defined(HTYPE_TIMER_T) 603 | instance GShow CTimer where 604 | gshowsPrec = showsPrec 605 | # endif 606 | #endif 607 | -------------------------------------------------------------------------------- /src/Generics/Deriving/TH/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE MagicHash #-} 4 | {-# LANGUAGE TemplateHaskellQuotes #-} 5 | 6 | {- | 7 | Module : Generics.Deriving.TH.Internal 8 | Copyright : (c) 2008--2009 Universiteit Utrecht 9 | License : BSD3 10 | 11 | Maintainer : generics@haskell.org 12 | Stability : experimental 13 | Portability : non-portable 14 | 15 | Template Haskell-related utilities. 16 | -} 17 | 18 | module Generics.Deriving.TH.Internal where 19 | 20 | import Control.Monad (unless) 21 | 22 | import Data.Char (isAlphaNum, ord) 23 | import Data.Foldable (foldr') 24 | import qualified Data.List as List 25 | import qualified Data.Map as Map 26 | import Data.Map as Map (Map) 27 | import Data.Maybe (mapMaybe) 28 | import qualified Data.Set as Set 29 | import Data.Set (Set) 30 | 31 | import qualified Generics.Deriving as GD 32 | import Generics.Deriving hiding 33 | ( DecidedStrictness(..), Fixity(Infix) 34 | , SourceStrictness(..), SourceUnpackedness(..) 35 | , datatypeName 36 | ) 37 | 38 | import GHC.Exts (Addr#, Char#, Double#, Float#, Int#, Word#) 39 | 40 | import Language.Haskell.TH.Datatype as Datatype 41 | import Language.Haskell.TH.Datatype.TyVarBndr 42 | import Language.Haskell.TH.Lib 43 | import Language.Haskell.TH.Ppr (pprint) 44 | import Language.Haskell.TH.Syntax 45 | 46 | ------------------------------------------------------------------------------- 47 | -- Expanding type synonyms 48 | ------------------------------------------------------------------------------- 49 | 50 | type TypeSubst = Map Name Type 51 | 52 | applySubstitutionKind :: Map Name Kind -> Type -> Type 53 | applySubstitutionKind = applySubstitution 54 | 55 | substNameWithKind :: Name -> Kind -> Type -> Type 56 | substNameWithKind n k = applySubstitutionKind (Map.singleton n k) 57 | 58 | substNamesWithKindStar :: [Name] -> Type -> Type 59 | substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns 60 | 61 | ------------------------------------------------------------------------------- 62 | -- StarKindStatus 63 | ------------------------------------------------------------------------------- 64 | 65 | -- | Whether a type is of kind @*@, a kind variable, or some other kind. The 66 | -- kind variable case is given special treatment solely to support GHC 8.0 and 67 | -- earlier, in which Generic1 was not poly-kinded. In order to support deriving 68 | -- Generic1 instances on these versions of GHC, we must substitute such kinds 69 | -- with @*@ to ensure that the resulting instance is well kinded. 70 | -- See @Note [Generic1 is polykinded in base-4.10]@ in "Generics.Deriving.TH". 71 | data StarKindStatus = KindStar 72 | | IsKindVar Name 73 | | OtherKind 74 | deriving Eq 75 | 76 | -- | Does a Type have kind * or k (for some kind variable k)? 77 | canRealizeKindStar :: Type -> StarKindStatus 78 | canRealizeKindStar t 79 | | hasKindStar t = KindStar 80 | | otherwise = case t of 81 | SigT _ (VarT k) -> IsKindVar k 82 | _ -> OtherKind 83 | 84 | -- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists. 85 | -- Otherwise, returns 'Nothing'. 86 | starKindStatusToName :: StarKindStatus -> Maybe Name 87 | starKindStatusToName (IsKindVar n) = Just n 88 | starKindStatusToName _ = Nothing 89 | 90 | -- | Concat together all of the StarKindStatuses that are IsKindVar and extract 91 | -- the kind variables' Names out. 92 | catKindVarNames :: [StarKindStatus] -> [Name] 93 | catKindVarNames = mapMaybe starKindStatusToName 94 | 95 | ------------------------------------------------------------------------------- 96 | -- Assorted utilities 97 | ------------------------------------------------------------------------------- 98 | 99 | -- | Returns True if a Type has kind *. 100 | hasKindStar :: Type -> Bool 101 | hasKindStar VarT{} = True 102 | hasKindStar (SigT _ StarT) = True 103 | hasKindStar _ = False 104 | 105 | -- | Converts a VarT or a SigT into Just the corresponding TyVarBndr. 106 | -- Converts other Types to Nothing. 107 | typeToTyVarBndr :: Type -> Maybe TyVarBndrUnit 108 | typeToTyVarBndr (VarT n) = Just (plainTV n) 109 | typeToTyVarBndr (SigT (VarT n) k) = Just (kindedTV n k) 110 | typeToTyVarBndr _ = Nothing 111 | 112 | -- | If a Type is a SigT, returns its kind signature. Otherwise, return *. 113 | typeKind :: Type -> Kind 114 | typeKind (SigT _ k) = k 115 | typeKind _ = starK 116 | 117 | -- | Turns 118 | -- 119 | -- @ 120 | -- [a, b] c 121 | -- @ 122 | -- 123 | -- into 124 | -- 125 | -- @ 126 | -- a -> b -> c 127 | -- @ 128 | makeFunType :: [Type] -> Type -> Type 129 | makeFunType argTys resTy = foldr' (AppT . AppT ArrowT) resTy argTys 130 | 131 | -- | Turns 132 | -- 133 | -- @ 134 | -- [k1, k2] k3 135 | -- @ 136 | -- 137 | -- into 138 | -- 139 | -- @ 140 | -- k1 -> k2 -> k3 141 | -- @ 142 | makeFunKind :: [Kind] -> Kind -> Kind 143 | makeFunKind = makeFunType 144 | 145 | -- | Remove any outer `SigT` and `ParensT` constructors, and turn 146 | -- an outermost `InfixT` constructor into plain applications. 147 | dustOff :: Type -> Type 148 | dustOff (SigT ty _) = dustOff ty 149 | dustOff (ParensT ty) = dustOff ty 150 | dustOff (InfixT ty1 n ty2) = ConT n `AppT` ty1 `AppT` ty2 151 | dustOff ty = ty 152 | 153 | -- | Checks whether a type is an unsaturated type family 154 | -- application. 155 | isUnsaturatedType :: Type -> Q Bool 156 | isUnsaturatedType = go 0 . dustOff 157 | where 158 | -- Expects its argument to be dusted 159 | go :: Int -> Type -> Q Bool 160 | go d t = case t of 161 | ConT tcName -> check d tcName 162 | AppT f _ -> go (d + 1) (dustOff f) 163 | _ -> return False 164 | 165 | check :: Int -> Name -> Q Bool 166 | check d tcName = do 167 | mbinders <- getTypeFamilyBinders tcName 168 | return $ case mbinders of 169 | Just bndrs -> length bndrs > d 170 | Nothing -> False 171 | 172 | -- | Given a name, check if that name is a type family. If 173 | -- so, return a list of its binders. 174 | getTypeFamilyBinders :: Name -> Q (Maybe [TyVarBndrVis]) 175 | getTypeFamilyBinders tcName = do 176 | info <- reify tcName 177 | return $ case info of 178 | FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _ 179 | -> Just bndrs 180 | FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _ 181 | -> Just bndrs 182 | _ -> Nothing 183 | 184 | -- | True if the type does not mention the Name 185 | ground :: Type -> Name -> Bool 186 | ground ty name = name `notElem` freeVariables ty 187 | 188 | -- | Construct a type via curried application. 189 | applyTyToTys :: Type -> [Type] -> Type 190 | applyTyToTys = List.foldl' AppT 191 | 192 | -- | Apply a type constructor name to type variable binders. 193 | applyTyToTvbs :: Name -> [TyVarBndr_ flag] -> Type 194 | applyTyToTvbs = List.foldl' (\a -> AppT a . tyVarBndrToType) . ConT 195 | 196 | -- | Split a type signature by the arrows on its spine. For example, this: 197 | -- 198 | -- @ 199 | -- forall a b. (a -> b) -> Char -> () 200 | -- @ 201 | -- 202 | -- would split to this: 203 | -- 204 | -- @ 205 | -- ([a, b], [a -> b, Char, ()]) 206 | -- @ 207 | uncurryTy :: Type -> ([TyVarBndrSpec], [Type]) 208 | uncurryTy (AppT (AppT ArrowT t1) t2) = 209 | let (tvbs, tys) = uncurryTy t2 210 | in (tvbs, t1:tys) 211 | uncurryTy (SigT t _) = uncurryTy t 212 | uncurryTy (ForallT tvbs _ t) = 213 | let (tvbs', tys) = uncurryTy t 214 | in (tvbs ++ tvbs', tys) 215 | uncurryTy t = ([], [t]) 216 | 217 | -- | Like uncurryType, except on a kind level. 218 | uncurryKind :: Kind -> ([TyVarBndrSpec], [Kind]) 219 | uncurryKind = uncurryTy 220 | 221 | tyVarBndrToType :: TyVarBndr_ flag -> Type 222 | tyVarBndrToType = elimTV VarT (\n k -> SigT (VarT n) k) 223 | 224 | -- | Generate a list of fresh names with a common prefix, and numbered suffixes. 225 | newNameList :: String -> Int -> Q [Name] 226 | newNameList prefix n = mapM (newName . (prefix ++) . show) [1..n] 227 | 228 | -- | Checks to see if the last types in a data family instance can be safely eta- 229 | -- reduced (i.e., dropped), given the other types. This checks for three conditions: 230 | -- 231 | -- (1) All of the dropped types are type variables 232 | -- (2) All of the dropped types are distinct 233 | -- (3) None of the remaining types mention any of the dropped types 234 | canEtaReduce :: [Type] -> [Type] -> Bool 235 | canEtaReduce remaining dropped = 236 | all isTyVar dropped 237 | -- Make sure not to pass something of type [Type], since Type 238 | -- didn't have an Ord instance until template-haskell-2.10.0.0 239 | && allDistinct droppedNames 240 | && not (any (`mentionsName` droppedNames) remaining) 241 | where 242 | droppedNames :: [Name] 243 | droppedNames = map varTToName dropped 244 | 245 | -- | Extract the Name from a type variable. If the argument Type is not a 246 | -- type variable, throw an error. 247 | varTToName :: Type -> Name 248 | varTToName (VarT n) = n 249 | varTToName (SigT t _) = varTToName t 250 | varTToName _ = error "Not a type variable!" 251 | 252 | -- | Is the given type a variable? 253 | isTyVar :: Type -> Bool 254 | isTyVar VarT{} = True 255 | isTyVar (SigT t _) = isTyVar t 256 | isTyVar _ = False 257 | 258 | -- | Is the given kind a variable? 259 | isKindVar :: Kind -> Bool 260 | isKindVar = isTyVar 261 | 262 | -- | Returns 'True' is a 'Type' contains no type variables. 263 | isTypeMonomorphic :: Type -> Bool 264 | isTypeMonomorphic = go 265 | where 266 | go :: Type -> Bool 267 | go (AppT t1 t2) = go t1 && go t2 268 | go (SigT t k) = go t && go k 269 | go VarT{} = False 270 | go _ = True 271 | 272 | -- | Peel off a kind signature from a Type (if it has one). 273 | unSigT :: Type -> Type 274 | unSigT (SigT t _) = t 275 | unSigT t = t 276 | 277 | -- | Peel off a kind signature from a TyVarBndr (if it has one). 278 | unKindedTV :: TyVarBndrUnit -> TyVarBndrUnit 279 | unKindedTV tvb = elimTV (\_ -> tvb) (\n _ -> plainTV n) tvb 280 | 281 | -- | Does the given type mention any of the Names in the list? 282 | mentionsName :: Type -> [Name] -> Bool 283 | mentionsName = go 284 | where 285 | go :: Type -> [Name] -> Bool 286 | go (AppT t1 t2) names = go t1 names || go t2 names 287 | go (SigT t k) names = go t names || go k names 288 | go (VarT n) names = n `elem` names 289 | go _ _ = False 290 | 291 | -- | Are all of the items in a list (which have an ordering) distinct? 292 | -- 293 | -- This uses Set (as opposed to nub) for better asymptotic time complexity. 294 | allDistinct :: Ord a => [a] -> Bool 295 | allDistinct = allDistinct' Set.empty 296 | where 297 | allDistinct' :: Ord a => Set a -> [a] -> Bool 298 | allDistinct' uniqs (x:xs) 299 | | x `Set.member` uniqs = False 300 | | otherwise = allDistinct' (Set.insert x uniqs) xs 301 | allDistinct' _ _ = True 302 | 303 | fst3 :: (a, b, c) -> a 304 | fst3 (a, _, _) = a 305 | 306 | snd3 :: (a, b, c) -> b 307 | snd3 (_, b, _) = b 308 | 309 | trd3 :: (a, b, c) -> c 310 | trd3 (_, _, c) = c 311 | 312 | shrink :: (a, b, c) -> (b, c) 313 | shrink (_, b, c) = (b, c) 314 | 315 | foldBal :: (a -> a -> a) -> a -> [a] -> a 316 | {-# INLINE foldBal #-} -- inlined to produce specialised code for each op 317 | foldBal op0 x0 xs0 = fold_bal op0 x0 (length xs0) xs0 318 | where 319 | fold_bal op x !n xs = case xs of 320 | [] -> x 321 | [a] -> a 322 | _ -> let !nl = n `div` 2 323 | !nr = n - nl 324 | (l,r) = splitAt nl xs 325 | in fold_bal op x nl l 326 | `op` fold_bal op x nr r 327 | 328 | isNewtypeVariant :: DatatypeVariant_ -> Bool 329 | isNewtypeVariant Datatype_ = False 330 | isNewtypeVariant Newtype_ = True 331 | isNewtypeVariant (DataInstance_ {}) = False 332 | isNewtypeVariant (NewtypeInstance_ {}) = True 333 | 334 | -- | Indicates whether Generic or Generic1 is being derived. 335 | data GenericClass = Generic | Generic1 deriving Enum 336 | 337 | -- | Records information about the type variables of a data type with a 338 | -- 'Generic' or 'Generic1' instance. 339 | data GenericTvbs 340 | -- | Information about a data type with a 'Generic' instance. 341 | = Gen0 342 | { gen0Tvbs :: [TyVarBndrUnit] 343 | -- ^ All of the type variable arguments to the data type. 344 | } 345 | -- | Information about a data type with a 'Generic1' instance. 346 | | Gen1 347 | { gen1InitTvbs :: [TyVarBndrUnit] 348 | -- ^ All of the type variable arguments to the data type except the 349 | -- last one. In a @'Generic1' (T a_1 ... a_(n-1))@ instance, the 350 | -- 'gen1InitTvbs' would be @[a_1, ..., a_(n-1)]@. 351 | , gen1LastTvbName :: Name 352 | -- ^ The name of the last type variable argument to the data type. 353 | -- In a @'Generic1' (T a_1 ... a_(n-1))@ instance, the 354 | -- 'gen1LastTvbName' name would be @a_n@. 355 | , gen1LastTvbKindVar :: Maybe Name 356 | -- ^ If the 'gen1LastTvbName' has kind @k@, where @k@ is some kind 357 | -- variable, then the 'gen1LastTvbKindVar' is @'Just' k@. Otherwise, 358 | -- the 'gen1LastTvbKindVar' is 'Nothing'. 359 | } 360 | 361 | -- | Compute 'GenericTvbs' from a 'GenericClass' and the type variable 362 | -- arguments to a data type. 363 | mkGenericTvbs :: GenericClass -> [Type] -> GenericTvbs 364 | mkGenericTvbs gClass tySynVars = 365 | case gClass of 366 | Generic -> Gen0{gen0Tvbs = freeVariablesWellScoped tySynVars} 367 | Generic1 -> Gen1{ gen1InitTvbs = freeVariablesWellScoped initArgs 368 | , gen1LastTvbName = varTToName lastArg 369 | , gen1LastTvbKindVar = mbLastArgKindName 370 | } 371 | where 372 | -- Everything below is only used for Generic1. 373 | initArgs :: [Type] 374 | initArgs = init tySynVars 375 | 376 | lastArg :: Type 377 | lastArg = last tySynVars 378 | 379 | mbLastArgKindName :: Maybe Name 380 | mbLastArgKindName = starKindStatusToName 381 | $ canRealizeKindStar lastArg 382 | 383 | -- | Return the type variable arguments to a data type that appear in a 384 | -- 'Generic' or 'Generic1' instance. For a 'Generic' instance, this consists of 385 | -- all the type variable arguments. For a 'Generic1' instance, this consists of 386 | -- all the type variable arguments except for the last one. 387 | genericInitTvbs :: GenericTvbs -> [TyVarBndrUnit] 388 | genericInitTvbs (Gen0{gen0Tvbs = tvbs}) = tvbs 389 | genericInitTvbs (Gen1{gen1InitTvbs = tvbs}) = tvbs 390 | 391 | -- | A version of 'DatatypeVariant' in which the data family instance 392 | -- constructors come equipped with the 'ConstructorInfo' of the first 393 | -- constructor in the family instance (for 'Name' generation purposes). 394 | data DatatypeVariant_ 395 | = Datatype_ 396 | | Newtype_ 397 | | DataInstance_ ConstructorInfo 398 | | NewtypeInstance_ ConstructorInfo 399 | 400 | showsDatatypeVariant :: DatatypeVariant_ -> ShowS 401 | showsDatatypeVariant variant = (++ '_':label) 402 | where 403 | dataPlain :: String 404 | dataPlain = "Plain" 405 | 406 | dataFamily :: ConstructorInfo -> String 407 | dataFamily con = "Family_" ++ sanitizeName (nameBase $ constructorName con) 408 | 409 | label :: String 410 | label = case variant of 411 | Datatype_ -> dataPlain 412 | Newtype_ -> dataPlain 413 | DataInstance_ con -> dataFamily con 414 | NewtypeInstance_ con -> dataFamily con 415 | 416 | showNameQual :: Name -> String 417 | showNameQual = sanitizeName . showQual 418 | where 419 | showQual (Name _ (NameQ m)) = modString m 420 | showQual (Name _ (NameG _ pkg m)) = pkgString pkg ++ ":" ++ modString m 421 | showQual _ = "" 422 | 423 | -- | Credit to Víctor López Juan for this trick 424 | sanitizeName :: String -> String 425 | sanitizeName nb = 'N':( 426 | nb >>= \x -> case x of 427 | c | isAlphaNum c || c == '\''-> [c] 428 | '_' -> "__" 429 | c -> "_" ++ show (ord c)) 430 | 431 | -- | One of the last type variables cannot be eta-reduced (see the canEtaReduce 432 | -- function for the criteria it would have to meet). 433 | etaReductionError :: Type -> Q a 434 | etaReductionError instanceType = fail $ 435 | "Cannot eta-reduce to an instance of form \n\tinstance (...) => " 436 | ++ pprint instanceType 437 | 438 | -- | Either the given data type doesn't have enough type variables, or one of 439 | -- the type variables to be eta-reduced cannot realize kind *. 440 | derivingKindError :: Name -> Q a 441 | derivingKindError tyConName = fail 442 | . showString "Cannot derive well-kinded instance of form ‘Generic1 " 443 | . showParen True 444 | ( showString (nameBase tyConName) 445 | . showString " ..." 446 | ) 447 | . showString "‘\n\tClass Generic1 expects an argument of kind " 448 | #if MIN_VERSION_base(4,10,0) 449 | . showString "k -> *" 450 | #else 451 | . showString "* -> *" 452 | #endif 453 | $ "" 454 | 455 | -- | The data type mentions the last type variable in a place other 456 | -- than the last position of a data type in a constructor's field. 457 | outOfPlaceTyVarError :: Q a 458 | outOfPlaceTyVarError = fail 459 | . showString "Constructor must only use its last type variable as" 460 | . showString " the last argument of a data type" 461 | $ "" 462 | 463 | -- | The data type mentions the last type variable in a type family 464 | -- application. 465 | typeFamilyApplicationError :: Q a 466 | typeFamilyApplicationError = fail 467 | . showString "Constructor must not apply its last type variable" 468 | . showString " to an unsaturated type family" 469 | $ "" 470 | 471 | -- | We cannot define implementations for @from(1)@ or @to(1)@ at the term level 472 | -- for @type data@ declarations, which only exist at the type level. 473 | typeDataError :: Name -> Q a 474 | typeDataError dataName = fail 475 | . showString "Cannot derive instance for ‘" 476 | . showString (nameBase dataName) 477 | . showString "‘, which is a ‘type data‘ declaration" 478 | $ "" 479 | 480 | -- | Cannot have a constructor argument of form (forall a1 ... an. ) 481 | -- when deriving Generic(1) 482 | rankNError :: Q a 483 | rankNError = fail "Cannot have polymorphic arguments" 484 | 485 | -- | Boilerplate for top level splices. 486 | -- 487 | -- The given Name must meet one of two criteria: 488 | -- 489 | -- 1. It must be the name of a type constructor of a plain data type or newtype. 490 | -- 2. It must be the name of a data family instance or newtype instance constructor. 491 | -- 492 | -- Any other value will result in an exception. 493 | reifyDataInfo :: Name 494 | -> Q (Either String (Name, [Type], [ConstructorInfo], DatatypeVariant_)) 495 | reifyDataInfo name = do 496 | return $ Left $ ns ++ " Could not reify " ++ nameBase name 497 | `recover` 498 | do DatatypeInfo { datatypeContext = ctxt 499 | , datatypeName = parentName 500 | , datatypeInstTypes = tys 501 | , datatypeVariant = variant 502 | , datatypeCons = cons 503 | } <- reifyDatatype name 504 | variant_ <- 505 | case variant of 506 | Datatype -> return Datatype_ 507 | Newtype -> return Newtype_ 508 | DataInstance -> return $ DataInstance_ $ headDataFamInstCon parentName cons 509 | NewtypeInstance -> return $ NewtypeInstance_ $ headDataFamInstCon parentName cons 510 | #if MIN_VERSION_th_abstraction(0,5,0) 511 | Datatype.TypeData -> typeDataError parentName 512 | #endif 513 | checkDataContext parentName ctxt $ Right (parentName, tys, cons, variant_) 514 | where 515 | ns :: String 516 | ns = "Generics.Deriving.TH.reifyDataInfo: " 517 | 518 | -- This isn't total, but the API requires that the data family instance have 519 | -- at least one constructor anyways, so this will always succeed. 520 | headDataFamInstCon :: Name -> [ConstructorInfo] -> ConstructorInfo 521 | headDataFamInstCon dataFamName cons = 522 | case cons of 523 | con:_ -> con 524 | [] -> error $ "reified data family instance without a data constructor: " 525 | ++ nameBase dataFamName 526 | 527 | -- | One cannot derive Generic(1) instance for anything that uses DatatypeContexts, 528 | -- so check to make sure the Cxt field of a datatype is null. 529 | checkDataContext :: Name -> Cxt -> a -> Q a 530 | checkDataContext _ [] x = return x 531 | checkDataContext dataName _ _ = fail $ 532 | nameBase dataName ++ " must not have a datatype context" 533 | 534 | -- | Deriving Generic(1) doesn't work with ExistentialQuantification or GADTs. 535 | checkExistentialContext :: Name -> [TyVarBndrUnit] -> Cxt -> Q () 536 | checkExistentialContext constrName vars ctxt = 537 | unless (null vars && null ctxt) $ fail $ 538 | nameBase constrName ++ " must be a vanilla data constructor" 539 | 540 | #if !(MIN_VERSION_template_haskell(2,21,0)) && !(MIN_VERSION_th_abstraction(0,6,0)) 541 | type TyVarBndrVis = TyVarBndrUnit 542 | 543 | bndrReq :: () 544 | bndrReq = () 545 | #endif 546 | 547 | ------------------------------------------------------------------------------- 548 | -- Quoted names 549 | ------------------------------------------------------------------------------- 550 | 551 | comp1DataName :: Name 552 | comp1DataName = 'Comp1 553 | 554 | infixDataName :: Name 555 | infixDataName = 'GD.Infix 556 | 557 | k1DataName :: Name 558 | k1DataName = 'K1 559 | 560 | l1DataName :: Name 561 | l1DataName = 'L1 562 | 563 | leftAssociativeDataName :: Name 564 | leftAssociativeDataName = 'LeftAssociative 565 | 566 | m1DataName :: Name 567 | m1DataName = 'M1 568 | 569 | notAssociativeDataName :: Name 570 | notAssociativeDataName = 'NotAssociative 571 | 572 | par1DataName :: Name 573 | par1DataName = 'Par1 574 | 575 | prefixDataName :: Name 576 | prefixDataName = 'Prefix 577 | 578 | productDataName :: Name 579 | productDataName = '(:*:) 580 | 581 | r1DataName :: Name 582 | r1DataName = 'R1 583 | 584 | rec1DataName :: Name 585 | rec1DataName = 'Rec1 586 | 587 | rightAssociativeDataName :: Name 588 | rightAssociativeDataName = 'RightAssociative 589 | 590 | u1DataName :: Name 591 | u1DataName = 'U1 592 | 593 | uAddrDataName :: Name 594 | uAddrDataName = 'UAddr 595 | 596 | uCharDataName :: Name 597 | uCharDataName = 'UChar 598 | 599 | uDoubleDataName :: Name 600 | uDoubleDataName = 'UDouble 601 | 602 | uFloatDataName :: Name 603 | uFloatDataName = 'UFloat 604 | 605 | uIntDataName :: Name 606 | uIntDataName = 'UInt 607 | 608 | uWordDataName :: Name 609 | uWordDataName = 'UWord 610 | 611 | c1TypeName :: Name 612 | c1TypeName = ''C1 613 | 614 | composeTypeName :: Name 615 | composeTypeName = ''(:.:) 616 | 617 | constructorTypeName :: Name 618 | constructorTypeName = ''Constructor 619 | 620 | d1TypeName :: Name 621 | d1TypeName = ''D1 622 | 623 | genericTypeName :: Name 624 | genericTypeName = ''Generic 625 | 626 | generic1TypeName :: Name 627 | generic1TypeName = ''Generic1 628 | 629 | datatypeTypeName :: Name 630 | datatypeTypeName = ''Datatype 631 | 632 | par1TypeName :: Name 633 | par1TypeName = ''Par1 634 | 635 | productTypeName :: Name 636 | productTypeName = ''(:*:) 637 | 638 | rec0TypeName :: Name 639 | rec0TypeName = ''Rec0 640 | 641 | rec1TypeName :: Name 642 | rec1TypeName = ''Rec1 643 | 644 | repTypeName :: Name 645 | repTypeName = ''Rep 646 | 647 | rep1TypeName :: Name 648 | rep1TypeName = ''Rep1 649 | 650 | s1TypeName :: Name 651 | s1TypeName = ''S1 652 | 653 | selectorTypeName :: Name 654 | selectorTypeName = ''Selector 655 | 656 | sumTypeName :: Name 657 | sumTypeName = ''(:+:) 658 | 659 | u1TypeName :: Name 660 | u1TypeName = ''U1 661 | 662 | uAddrTypeName :: Name 663 | uAddrTypeName = ''UAddr 664 | 665 | uCharTypeName :: Name 666 | uCharTypeName = ''UChar 667 | 668 | uDoubleTypeName :: Name 669 | uDoubleTypeName = ''UDouble 670 | 671 | uFloatTypeName :: Name 672 | uFloatTypeName = ''UFloat 673 | 674 | uIntTypeName :: Name 675 | uIntTypeName = ''UInt 676 | 677 | uWordTypeName :: Name 678 | uWordTypeName = ''UWord 679 | 680 | v1TypeName :: Name 681 | v1TypeName = ''V1 682 | 683 | conFixityValName :: Name 684 | conFixityValName = 'conFixity 685 | 686 | conIsRecordValName :: Name 687 | conIsRecordValName = 'conIsRecord 688 | 689 | conNameValName :: Name 690 | conNameValName = 'GD.conName 691 | 692 | datatypeNameValName :: Name 693 | datatypeNameValName = 'GD.datatypeName 694 | 695 | isNewtypeValName :: Name 696 | isNewtypeValName = 'isNewtype 697 | 698 | fromValName :: Name 699 | fromValName = 'from 700 | 701 | from1ValName :: Name 702 | from1ValName = 'from1 703 | 704 | moduleNameValName :: Name 705 | moduleNameValName = 'moduleName 706 | 707 | selNameValName :: Name 708 | selNameValName = 'selName 709 | 710 | seqValName :: Name 711 | seqValName = 'seq 712 | 713 | toValName :: Name 714 | toValName = 'to 715 | 716 | to1ValName :: Name 717 | to1ValName = 'to1 718 | 719 | uAddrHashValName :: Name 720 | uAddrHashValName = 'uAddr# 721 | 722 | uCharHashValName :: Name 723 | uCharHashValName = 'uChar# 724 | 725 | uDoubleHashValName :: Name 726 | uDoubleHashValName = 'uDouble# 727 | 728 | uFloatHashValName :: Name 729 | uFloatHashValName = 'uFloat# 730 | 731 | uIntHashValName :: Name 732 | uIntHashValName = 'uInt# 733 | 734 | uWordHashValName :: Name 735 | uWordHashValName = 'uWord# 736 | 737 | unComp1ValName :: Name 738 | unComp1ValName = 'unComp1 739 | 740 | unK1ValName :: Name 741 | unK1ValName = 'unK1 742 | 743 | unPar1ValName :: Name 744 | unPar1ValName = 'unPar1 745 | 746 | unRec1ValName :: Name 747 | unRec1ValName = 'unRec1 748 | 749 | trueDataName, falseDataName :: Name 750 | trueDataName = 'True 751 | falseDataName = 'False 752 | 753 | nothingDataName, justDataName :: Name 754 | nothingDataName = 'Nothing 755 | justDataName = 'Just 756 | 757 | addrHashTypeName :: Name 758 | addrHashTypeName = ''Addr# 759 | 760 | charHashTypeName :: Name 761 | charHashTypeName = ''Char# 762 | 763 | doubleHashTypeName :: Name 764 | doubleHashTypeName = ''Double# 765 | 766 | floatHashTypeName :: Name 767 | floatHashTypeName = ''Float# 768 | 769 | intHashTypeName :: Name 770 | intHashTypeName = ''Int# 771 | 772 | wordHashTypeName :: Name 773 | wordHashTypeName = ''Word# 774 | 775 | composeValName :: Name 776 | composeValName = '(.) 777 | 778 | errorValName :: Name 779 | errorValName = 'error 780 | 781 | fmapValName :: Name 782 | fmapValName = 'fmap 783 | 784 | undefinedValName :: Name 785 | undefinedValName = 'undefined 786 | 787 | decidedLazyDataName :: Name 788 | decidedLazyDataName = 'GD.DecidedLazy 789 | 790 | decidedStrictDataName :: Name 791 | decidedStrictDataName = 'GD.DecidedStrict 792 | 793 | decidedUnpackDataName :: Name 794 | decidedUnpackDataName = 'GD.DecidedUnpack 795 | 796 | infixIDataName :: Name 797 | infixIDataName = 'InfixI 798 | 799 | metaConsDataName :: Name 800 | metaConsDataName = 'MetaCons 801 | 802 | metaDataDataName :: Name 803 | metaDataDataName = 'MetaData 804 | 805 | metaSelDataName :: Name 806 | metaSelDataName = 'MetaSel 807 | 808 | noSourceStrictnessDataName :: Name 809 | noSourceStrictnessDataName = 'GD.NoSourceStrictness 810 | 811 | noSourceUnpackednessDataName :: Name 812 | noSourceUnpackednessDataName = 'GD.NoSourceUnpackedness 813 | 814 | prefixIDataName :: Name 815 | prefixIDataName = 'PrefixI 816 | 817 | sourceLazyDataName :: Name 818 | sourceLazyDataName = 'GD.SourceLazy 819 | 820 | sourceNoUnpackDataName :: Name 821 | sourceNoUnpackDataName = 'GD.SourceNoUnpack 822 | 823 | sourceStrictDataName :: Name 824 | sourceStrictDataName = 'GD.SourceStrict 825 | 826 | sourceUnpackDataName :: Name 827 | sourceUnpackDataName = 'GD.SourceUnpack 828 | 829 | packageNameValName :: Name 830 | packageNameValName = 'packageName 831 | -------------------------------------------------------------------------------- /src/Generics/Deriving/TH/Post4_9.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module : Generics.Deriving.TH.Post4_9 3 | Copyright : (c) 2008--2009 Universiteit Utrecht 4 | License : BSD3 5 | 6 | Maintainer : generics@haskell.org 7 | Stability : experimental 8 | Portability : non-portable 9 | 10 | Template Haskell machinery for the type-literal-based variant of GHC 11 | generics introduced in @base-4.9@. 12 | -} 13 | 14 | module Generics.Deriving.TH.Post4_9 ( 15 | deriveMeta 16 | , deriveData 17 | , deriveConstructors 18 | , deriveSelectors 19 | , mkMetaDataType 20 | , mkMetaConsType 21 | , mkMetaSelType 22 | , SelStrictInfo(..) 23 | , reifySelStrictInfo 24 | ) where 25 | 26 | import Data.Maybe (fromMaybe) 27 | 28 | import Generics.Deriving.TH.Internal 29 | 30 | import Language.Haskell.TH.Datatype as THAbs 31 | import Language.Haskell.TH.Lib 32 | import Language.Haskell.TH.Syntax 33 | 34 | mkMetaDataType :: DatatypeVariant_ -> Name -> Q Type 35 | mkMetaDataType dv n = 36 | promotedT metaDataDataName 37 | `appT` litT (strTyLit (nameBase n)) 38 | `appT` litT (strTyLit m) 39 | `appT` litT (strTyLit pkg) 40 | `appT` promoteBool (isNewtypeVariant dv) 41 | where 42 | m, pkg :: String 43 | m = fromMaybe (error "Cannot fetch module name!") (nameModule n) 44 | pkg = fromMaybe (error "Cannot fetch package name!") (namePackage n) 45 | 46 | mkMetaConsType :: DatatypeVariant_ -> Name -> Name -> Bool -> Bool -> Q Type 47 | mkMetaConsType _ _ n conIsRecord conIsInfix = do 48 | mbFi <- reifyFixity n 49 | promotedT metaConsDataName 50 | `appT` litT (strTyLit (nameBase n)) 51 | `appT` fixityIPromotedType mbFi conIsInfix 52 | `appT` promoteBool conIsRecord 53 | 54 | promoteBool :: Bool -> Q Type 55 | promoteBool True = promotedT trueDataName 56 | promoteBool False = promotedT falseDataName 57 | 58 | fixityIPromotedType :: Maybe Fixity -> Bool -> Q Type 59 | fixityIPromotedType mbFi True = 60 | promotedT infixIDataName 61 | `appT` promoteAssociativity a 62 | `appT` litT (numTyLit (toInteger n)) 63 | where 64 | Fixity n a = fromMaybe defaultFixity mbFi 65 | fixityIPromotedType _ False = promotedT prefixIDataName 66 | 67 | promoteAssociativity :: FixityDirection -> Q Type 68 | promoteAssociativity InfixL = promotedT leftAssociativeDataName 69 | promoteAssociativity InfixR = promotedT rightAssociativeDataName 70 | promoteAssociativity InfixN = promotedT notAssociativeDataName 71 | 72 | mkMetaSelType :: DatatypeVariant_ -> Name -> Name -> Maybe Name 73 | -> SelStrictInfo -> Q Type 74 | mkMetaSelType _ _ _ mbF (SelStrictInfo su ss ds) = 75 | let mbSelNameT = case mbF of 76 | Just f -> promotedT justDataName `appT` litT (strTyLit (nameBase f)) 77 | Nothing -> promotedT nothingDataName 78 | in promotedT metaSelDataName 79 | `appT` mbSelNameT 80 | `appT` promoteUnpackedness su 81 | `appT` promoteStrictness ss 82 | `appT` promoteDecidedStrictness ds 83 | 84 | data SelStrictInfo = SelStrictInfo Unpackedness Strictness DecidedStrictness 85 | 86 | promoteUnpackedness :: Unpackedness -> Q Type 87 | promoteUnpackedness UnspecifiedUnpackedness = promotedT noSourceUnpackednessDataName 88 | promoteUnpackedness NoUnpack = promotedT sourceNoUnpackDataName 89 | promoteUnpackedness Unpack = promotedT sourceUnpackDataName 90 | 91 | promoteStrictness :: Strictness -> Q Type 92 | promoteStrictness UnspecifiedStrictness = promotedT noSourceStrictnessDataName 93 | promoteStrictness Lazy = promotedT sourceLazyDataName 94 | promoteStrictness THAbs.Strict = promotedT sourceStrictDataName 95 | 96 | promoteDecidedStrictness :: DecidedStrictness -> Q Type 97 | promoteDecidedStrictness DecidedLazy = promotedT decidedLazyDataName 98 | promoteDecidedStrictness DecidedStrict = promotedT decidedStrictDataName 99 | promoteDecidedStrictness DecidedUnpack = promotedT decidedUnpackDataName 100 | 101 | reifySelStrictInfo :: Name -> [FieldStrictness] -> Q [SelStrictInfo] 102 | reifySelStrictInfo conName fs = do 103 | dcdStrs <- reifyConStrictness conName 104 | let srcUnpks = map fieldUnpackedness fs 105 | srcStrs = map fieldStrictness fs 106 | return $ zipWith3 SelStrictInfo srcUnpks srcStrs dcdStrs 107 | 108 | -- | Given the type and the name (as string) for the type to derive, 109 | -- generate the 'Data' instance, the 'Constructor' instances, and the 'Selector' 110 | -- instances. 111 | -- 112 | -- On GHC 7.11 and up, this functionality is no longer used in GHC generics, 113 | -- so this function generates no declarations. 114 | deriveMeta :: Name -> Q [Dec] 115 | deriveMeta _ = return [] 116 | 117 | -- | Given a datatype name, derive a datatype and instance of class 'Datatype'. 118 | -- 119 | -- On GHC 7.11 and up, this functionality is no longer used in GHC generics, 120 | -- so this function generates no declarations. 121 | deriveData :: Name -> Q [Dec] 122 | deriveData _ = return [] 123 | 124 | -- | Given a datatype name, derive datatypes and 125 | -- instances of class 'Constructor'. 126 | -- 127 | -- On GHC 7.11 and up, this functionality is no longer used in GHC generics, 128 | -- so this function generates no declarations. 129 | deriveConstructors :: Name -> Q [Dec] 130 | deriveConstructors _ = return [] 131 | 132 | -- | Given a datatype name, derive datatypes and instances of class 'Selector'. 133 | -- 134 | -- On GHC 7.11 and up, this functionality is no longer used in GHC generics, 135 | -- so this function generates no declarations. 136 | deriveSelectors :: Name -> Q [Dec] 137 | deriveSelectors _ = return [] 138 | -------------------------------------------------------------------------------- /src/Generics/Deriving/Traversable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DefaultSignatures #-} 3 | {-# LANGUAGE EmptyCase #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE PolyKinds #-} 7 | {-# LANGUAGE Safe #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | {-# LANGUAGE TypeSynonymInstances #-} 10 | 11 | module Generics.Deriving.Traversable ( 12 | -- * Generic Traversable class 13 | GTraversable(..) 14 | 15 | -- * Default method 16 | , gtraversedefault 17 | 18 | -- * Internal Traversable class 19 | , GTraversable'(..) 20 | 21 | ) where 22 | 23 | import Control.Applicative (Const, WrappedMonad(..), ZipList) 24 | 25 | import Data.Complex (Complex) 26 | import Data.Functor.Identity (Identity) 27 | import qualified Data.Functor.Product as Functor (Product) 28 | import qualified Data.Functor.Sum as Functor (Sum) 29 | import Data.List.NonEmpty (NonEmpty) 30 | import qualified Data.Monoid as Monoid (First, Last, Product, Sum) 31 | import Data.Monoid (Dual) 32 | import Data.Ord (Down) 33 | import Data.Proxy (Proxy) 34 | import qualified Data.Semigroup as Semigroup (First, Last) 35 | import Data.Semigroup (Arg, Max, Min, WrappedMonoid) 36 | 37 | import Generics.Deriving.Base 38 | import Generics.Deriving.Foldable 39 | import Generics.Deriving.Functor 40 | 41 | -------------------------------------------------------------------------------- 42 | -- Generic traverse 43 | -------------------------------------------------------------------------------- 44 | 45 | class GTraversable' t where 46 | gtraverse' :: Applicative f => (a -> f b) -> t a -> f (t b) 47 | 48 | instance GTraversable' V1 where 49 | gtraverse' _ x = pure $ case x of {} 50 | 51 | instance GTraversable' U1 where 52 | gtraverse' _ U1 = pure U1 53 | 54 | instance GTraversable' Par1 where 55 | gtraverse' f (Par1 a) = Par1 <$> f a 56 | 57 | instance GTraversable' (K1 i c) where 58 | gtraverse' _ (K1 a) = pure (K1 a) 59 | 60 | instance (GTraversable f) => GTraversable' (Rec1 f) where 61 | gtraverse' f (Rec1 a) = Rec1 <$> gtraverse f a 62 | 63 | instance (GTraversable' f) => GTraversable' (M1 i c f) where 64 | gtraverse' f (M1 a) = M1 <$> gtraverse' f a 65 | 66 | instance (GTraversable' f, GTraversable' g) => GTraversable' (f :+: g) where 67 | gtraverse' f (L1 a) = L1 <$> gtraverse' f a 68 | gtraverse' f (R1 a) = R1 <$> gtraverse' f a 69 | 70 | instance (GTraversable' f, GTraversable' g) => GTraversable' (f :*: g) where 71 | gtraverse' f (a :*: b) = (:*:) <$> gtraverse' f a <*> gtraverse' f b 72 | 73 | instance (GTraversable f, GTraversable' g) => GTraversable' (f :.: g) where 74 | gtraverse' f (Comp1 x) = Comp1 <$> gtraverse (gtraverse' f) x 75 | 76 | instance GTraversable' UAddr where 77 | gtraverse' _ (UAddr a) = pure (UAddr a) 78 | 79 | instance GTraversable' UChar where 80 | gtraverse' _ (UChar c) = pure (UChar c) 81 | 82 | instance GTraversable' UDouble where 83 | gtraverse' _ (UDouble d) = pure (UDouble d) 84 | 85 | instance GTraversable' UFloat where 86 | gtraverse' _ (UFloat f) = pure (UFloat f) 87 | 88 | instance GTraversable' UInt where 89 | gtraverse' _ (UInt i) = pure (UInt i) 90 | 91 | instance GTraversable' UWord where 92 | gtraverse' _ (UWord w) = pure (UWord w) 93 | 94 | class (GFunctor t, GFoldable t) => GTraversable t where 95 | gtraverse :: Applicative f => (a -> f b) -> t a -> f (t b) 96 | default gtraverse :: (Generic1 t, GTraversable' (Rep1 t), Applicative f) 97 | => (a -> f b) -> t a -> f (t b) 98 | gtraverse = gtraversedefault 99 | 100 | gsequenceA :: Applicative f => t (f a) -> f (t a) 101 | gsequenceA = gtraverse id 102 | 103 | gmapM :: Monad m => (a -> m b) -> t a -> m (t b) 104 | gmapM f = unwrapMonad . gtraverse (WrapMonad . f) 105 | 106 | gsequence :: Monad m => t (m a) -> m (t a) 107 | gsequence = gmapM id 108 | 109 | gtraversedefault :: (Generic1 t, GTraversable' (Rep1 t), Applicative f) 110 | => (a -> f b) -> t a -> f (t b) 111 | gtraversedefault f x = to1 <$> gtraverse' f (from1 x) 112 | 113 | -- Base types instances 114 | instance GTraversable ((,) a) where 115 | gtraverse = gtraversedefault 116 | 117 | instance GTraversable [] where 118 | gtraverse = gtraversedefault 119 | 120 | instance GTraversable (Arg a) where 121 | gtraverse = gtraversedefault 122 | 123 | instance GTraversable Complex where 124 | gtraverse = gtraversedefault 125 | 126 | instance GTraversable (Const m) where 127 | gtraverse = gtraversedefault 128 | 129 | instance GTraversable Down where 130 | gtraverse = gtraversedefault 131 | 132 | instance GTraversable Dual where 133 | gtraverse = gtraversedefault 134 | 135 | instance GTraversable (Either a) where 136 | gtraverse = gtraversedefault 137 | 138 | instance GTraversable Monoid.First where 139 | gtraverse = gtraversedefault 140 | 141 | instance GTraversable (Semigroup.First) where 142 | gtraverse = gtraversedefault 143 | 144 | instance GTraversable Identity where 145 | gtraverse = gtraversedefault 146 | 147 | instance GTraversable Monoid.Last where 148 | gtraverse = gtraversedefault 149 | 150 | instance GTraversable Semigroup.Last where 151 | gtraverse = gtraversedefault 152 | 153 | instance GTraversable Max where 154 | gtraverse = gtraversedefault 155 | 156 | instance GTraversable Maybe where 157 | gtraverse = gtraversedefault 158 | 159 | instance GTraversable Min where 160 | gtraverse = gtraversedefault 161 | 162 | instance GTraversable NonEmpty where 163 | gtraverse = gtraversedefault 164 | 165 | instance GTraversable Monoid.Product where 166 | gtraverse = gtraversedefault 167 | 168 | instance (GTraversable f, GTraversable g) => GTraversable (Functor.Product f g) where 169 | gtraverse = gtraversedefault 170 | 171 | instance GTraversable Proxy where 172 | gtraverse = gtraversedefault 173 | 174 | instance GTraversable Monoid.Sum where 175 | gtraverse = gtraversedefault 176 | 177 | instance (GTraversable f, GTraversable g) => GTraversable (Functor.Sum f g) where 178 | gtraverse = gtraversedefault 179 | 180 | instance GTraversable WrappedMonoid where 181 | gtraverse = gtraversedefault 182 | 183 | instance GTraversable ZipList where 184 | gtraverse = gtraversedefault 185 | -------------------------------------------------------------------------------- /src/Generics/Deriving/Uniplate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE Trustworthy #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE TypeSynonymInstances #-} 9 | 10 | {- | 11 | Module : Generics.Deriving.Uniplate 12 | Copyright : 2011-2012 Universiteit Utrecht, University of Oxford 13 | License : BSD3 14 | 15 | Maintainer : generics@haskell.org 16 | Stability : experimental 17 | Portability : non-portable 18 | 19 | Summary: Functions inspired by the Uniplate generic programming library, 20 | mostly implemented by Sean Leather. 21 | -} 22 | 23 | module Generics.Deriving.Uniplate ( 24 | -- * Generic Uniplate class 25 | Uniplate(..) 26 | 27 | -- * Derived functions 28 | , uniplate 29 | , universe 30 | , rewrite 31 | , rewriteM 32 | , contexts 33 | , holes 34 | , para 35 | 36 | -- * Default definitions 37 | , childrendefault 38 | , contextdefault 39 | , descenddefault 40 | , descendMdefault 41 | , transformdefault 42 | , transformMdefault 43 | 44 | -- * Internal Uniplate class 45 | , Uniplate'(..) 46 | 47 | -- * Internal Context class 48 | , Context'(..) 49 | ) where 50 | 51 | 52 | import Generics.Deriving.Base 53 | 54 | import Control.Monad (liftM, liftM2) 55 | import GHC.Exts (build) 56 | 57 | -------------------------------------------------------------------------------- 58 | -- Generic Uniplate 59 | -------------------------------------------------------------------------------- 60 | 61 | class Uniplate' f b where 62 | children' :: f a -> [b] 63 | descend' :: (b -> b) -> f a -> f a 64 | descendM' :: Monad m => (b -> m b) -> f a -> m (f a) 65 | transform' :: (b -> b) -> f a -> f a 66 | transformM' :: Monad m => (b -> m b) -> f a -> m (f a) 67 | 68 | instance Uniplate' U1 a where 69 | children' U1 = [] 70 | descend' _ U1 = U1 71 | descendM' _ U1 = return U1 72 | transform' _ U1 = U1 73 | transformM' _ U1 = return U1 74 | 75 | instance {-# OVERLAPPING #-} (Uniplate a) => Uniplate' (K1 i a) a where 76 | children' (K1 a) = [a] 77 | descend' f (K1 a) = K1 (f a) 78 | descendM' f (K1 a) = liftM K1 (f a) 79 | transform' f (K1 a) = K1 (transform f a) 80 | transformM' f (K1 a) = liftM K1 (transformM f a) 81 | 82 | instance {-# OVERLAPPABLE #-} Uniplate' (K1 i a) b where 83 | children' (K1 _) = [] 84 | descend' _ (K1 a) = K1 a 85 | descendM' _ (K1 a) = return (K1 a) 86 | transform' _ (K1 a) = K1 a 87 | transformM' _ (K1 a) = return (K1 a) 88 | 89 | instance (Uniplate' f b) => Uniplate' (M1 i c f) b where 90 | children' (M1 a) = children' a 91 | descend' f (M1 a) = M1 (descend' f a) 92 | descendM' f (M1 a) = liftM M1 (descendM' f a) 93 | transform' f (M1 a) = M1 (transform' f a) 94 | transformM' f (M1 a) = liftM M1 (transformM' f a) 95 | 96 | instance (Uniplate' f b, Uniplate' g b) => Uniplate' (f :+: g) b where 97 | children' (L1 a) = children' a 98 | children' (R1 a) = children' a 99 | descend' f (L1 a) = L1 (descend' f a) 100 | descend' f (R1 a) = R1 (descend' f a) 101 | descendM' f (L1 a) = liftM L1 (descendM' f a) 102 | descendM' f (R1 a) = liftM R1 (descendM' f a) 103 | transform' f (L1 a) = L1 (transform' f a) 104 | transform' f (R1 a) = R1 (transform' f a) 105 | transformM' f (L1 a) = liftM L1 (transformM' f a) 106 | transformM' f (R1 a) = liftM R1 (transformM' f a) 107 | 108 | instance (Uniplate' f b, Uniplate' g b) => Uniplate' (f :*: g) b where 109 | children' (a :*: b) = children' a ++ children' b 110 | descend' f (a :*: b) = descend' f a :*: descend' f b 111 | descendM' f (a :*: b) = liftM2 (:*:) (descendM' f a) (descendM' f b) 112 | transform' f (a :*: b) = transform' f a :*: transform' f b 113 | transformM' f (a :*: b) = liftM2 (:*:) (transformM' f a) (transformM' f b) 114 | 115 | 116 | -- Context' is a separate class from Uniplate' since it uses special product 117 | -- instances, but the context function still appears in Uniplate. 118 | class Context' f b where 119 | context' :: f a -> [b] -> f a 120 | 121 | instance Context' U1 b where 122 | context' U1 _ = U1 123 | 124 | instance {-# OVERLAPPING #-} Context' (K1 i a) a where 125 | context' _ [] = error "Generics.Deriving.Uniplate.context: empty list" 126 | context' (K1 _) (c:_) = K1 c 127 | 128 | instance {-# OVERLAPPABLE #-} Context' (K1 i a) b where 129 | context' (K1 a) _ = K1 a 130 | 131 | instance (Context' f b) => Context' (M1 i c f) b where 132 | context' (M1 a) cs = M1 (context' a cs) 133 | 134 | instance (Context' f b, Context' g b) => Context' (f :+: g) b where 135 | context' (L1 a) cs = L1 (context' a cs) 136 | context' (R1 a) cs = R1 (context' a cs) 137 | 138 | instance {-# OVERLAPPING #-} (Context' g a) => Context' (M1 i c (K1 j a) :*: g) a where 139 | context' _ [] = error "Generics.Deriving.Uniplate.context: empty list" 140 | context' (M1 (K1 _) :*: b) (c:cs) = M1 (K1 c) :*: context' b cs 141 | 142 | instance {-# OVERLAPPABLE #-} (Context' g b) => Context' (f :*: g) b where 143 | context' (a :*: b) cs = a :*: context' b cs 144 | 145 | 146 | class Uniplate a where 147 | children :: a -> [a] 148 | default children :: (Generic a, Uniplate' (Rep a) a) => a -> [a] 149 | children = childrendefault 150 | 151 | context :: a -> [a] -> a 152 | default context :: (Generic a, Context' (Rep a) a) => a -> [a] -> a 153 | context = contextdefault 154 | 155 | descend :: (a -> a) -> a -> a 156 | default descend :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a 157 | descend = descenddefault 158 | 159 | descendM :: Monad m => (a -> m a) -> a -> m a 160 | default descendM :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a 161 | descendM = descendMdefault 162 | 163 | transform :: (a -> a) -> a -> a 164 | default transform :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a 165 | transform = transformdefault 166 | 167 | transformM :: Monad m => (a -> m a) -> a -> m a 168 | default transformM :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a 169 | transformM = transformMdefault 170 | 171 | childrendefault :: (Generic a, Uniplate' (Rep a) a) => a -> [a] 172 | childrendefault = children' . from 173 | 174 | contextdefault :: (Generic a, Context' (Rep a) a) => a -> [a] -> a 175 | contextdefault x cs = to (context' (from x) cs) 176 | 177 | descenddefault :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a 178 | descenddefault f = to . descend' f . from 179 | 180 | descendMdefault :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a 181 | descendMdefault f = liftM to . descendM' f . from 182 | 183 | transformdefault :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a 184 | transformdefault f = f . to . transform' f . from 185 | 186 | transformMdefault :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a 187 | transformMdefault f = liftM to . transformM' f . from 188 | 189 | 190 | -- Derived functions (mostly copied from Neil Michell's code) 191 | 192 | uniplate :: Uniplate a => a -> ([a], [a] -> a) 193 | uniplate a = (children a, context a) 194 | 195 | universe :: Uniplate a => a -> [a] 196 | universe a = build (go a) 197 | where 198 | go x cons nil = cons x $ foldr ($) nil $ map (\c -> go c cons) $ children x 199 | 200 | rewrite :: Uniplate a => (a -> Maybe a) -> a -> a 201 | rewrite f = transform g 202 | where 203 | g x = maybe x (rewrite f) (f x) 204 | 205 | rewriteM :: (Monad m, Uniplate a) => (a -> m (Maybe a)) -> a -> m a 206 | rewriteM f = transformM g 207 | where 208 | g x = f x >>= maybe (return x) (rewriteM f) 209 | 210 | contexts :: Uniplate a => a -> [(a, a -> a)] 211 | contexts a = (a, id) : f (holes a) 212 | where 213 | f xs = [ (ch2, ctx1 . ctx2) 214 | | (ch1, ctx1) <- xs 215 | , (ch2, ctx2) <- contexts ch1] 216 | 217 | holes :: Uniplate a => a -> [(a, a -> a)] 218 | holes a = uncurry f (uniplate a) 219 | where 220 | f [] _ = [] 221 | f (x:xs) gen = (x, gen . (:xs)) : f xs (gen . (x:)) 222 | 223 | para :: Uniplate a => (a -> [r] -> r) -> a -> r 224 | para f x = f x $ map (para f) $ children x 225 | 226 | 227 | -- Base types instances 228 | instance Uniplate Bool where 229 | children _ = [] 230 | context x _ = x 231 | descend _ = id 232 | descendM _ = return 233 | transform = id 234 | transformM _ = return 235 | instance Uniplate Char where 236 | children _ = [] 237 | context x _ = x 238 | descend _ = id 239 | descendM _ = return 240 | transform = id 241 | transformM _ = return 242 | instance Uniplate Double where 243 | children _ = [] 244 | context x _ = x 245 | descend _ = id 246 | descendM _ = return 247 | transform = id 248 | transformM _ = return 249 | instance Uniplate Float where 250 | children _ = [] 251 | context x _ = x 252 | descend _ = id 253 | descendM _ = return 254 | transform = id 255 | transformM _ = return 256 | instance Uniplate Int where 257 | children _ = [] 258 | context x _ = x 259 | descend _ = id 260 | descendM _ = return 261 | transform = id 262 | transformM _ = return 263 | instance Uniplate () where 264 | children _ = [] 265 | context x _ = x 266 | descend _ = id 267 | descendM _ = return 268 | transform = id 269 | transformM _ = return 270 | 271 | -- Tuple instances 272 | instance Uniplate (b,c) where 273 | children _ = [] 274 | context x _ = x 275 | descend _ = id 276 | descendM _ = return 277 | transform = id 278 | transformM _ = return 279 | instance Uniplate (b,c,d) where 280 | children _ = [] 281 | context x _ = x 282 | descend _ = id 283 | descendM _ = return 284 | transform = id 285 | transformM _ = return 286 | instance Uniplate (b,c,d,e) where 287 | children _ = [] 288 | context x _ = x 289 | descend _ = id 290 | descendM _ = return 291 | transform = id 292 | transformM _ = return 293 | instance Uniplate (b,c,d,e,f) where 294 | children _ = [] 295 | context x _ = x 296 | descend _ = id 297 | descendM _ = return 298 | transform = id 299 | transformM _ = return 300 | instance Uniplate (b,c,d,e,f,g) where 301 | children _ = [] 302 | context x _ = x 303 | descend _ = id 304 | descendM _ = return 305 | transform = id 306 | transformM _ = return 307 | instance Uniplate (b,c,d,e,f,g,h) where 308 | children _ = [] 309 | context x _ = x 310 | descend _ = id 311 | descendM _ = return 312 | transform = id 313 | transformM _ = return 314 | 315 | -- Parameterized type instances 316 | instance Uniplate (Maybe a) where 317 | children _ = [] 318 | context x _ = x 319 | descend _ = id 320 | descendM _ = return 321 | transform = id 322 | transformM _ = return 323 | instance Uniplate (Either a b) where 324 | children _ = [] 325 | context x _ = x 326 | descend _ = id 327 | descendM _ = return 328 | transform = id 329 | transformM _ = return 330 | 331 | instance Uniplate [a] where 332 | children [] = [] 333 | children (_:t) = [t] 334 | context _ [] = error "Generics.Deriving.Uniplate.context: empty list" 335 | context [] _ = [] 336 | context (h:_) (t:_) = h:t 337 | descend _ [] = [] 338 | descend f (h:t) = h:f t 339 | descendM _ [] = return [] 340 | descendM f (h:t) = f t >>= \t' -> return (h:t') 341 | transform f [] = f [] 342 | transform f (h:t) = f (h:transform f t) 343 | transformM f [] = f [] 344 | transformM f (h:t) = transformM f t >>= \t' -> f (h:t') 345 | 346 | -------------------------------------------------------------------------------- /tests/DefaultSpec.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : DefaultSpec 3 | -- Description : Ensure that deriving via (Default a) newtype works 4 | -- License : BSD-3-Clause 5 | -- 6 | -- Maintainer : generics@haskell.org 7 | -- Stability : experimental 8 | -- Portability : non-portable 9 | -- 10 | -- Tests DerivingVia on GHC versions 8.6 and above. There are no tests on 11 | -- versions below. 12 | -- 13 | -- The test check a miscellany of properties of the derived type classes. 14 | -- (Testing all the required properties is beyond the scope of this module.) 15 | {-# LANGUAGE CPP #-} 16 | #if __GLASGOW_HASKELL__ >= 806 17 | {-# LANGUAGE DeriveFunctor #-} 18 | {-# LANGUAGE DeriveGeneric #-} 19 | {-# LANGUAGE DerivingVia #-} 20 | {-# LANGUAGE ScopedTypeVariables #-} 21 | {-# LANGUAGE StandaloneDeriving #-} 22 | #endif 23 | 24 | module DefaultSpec where 25 | 26 | import Test.Hspec 27 | 28 | #if __GLASGOW_HASKELL__ >= 806 29 | import Test.Hspec.QuickCheck 30 | 31 | import Data.Semigroup (First(..)) 32 | import Data.Foldable (sequenceA_) 33 | import Generics.Deriving hiding (universe) 34 | import Generics.Deriving.Default () 35 | import Generics.Deriving.Foldable (GFoldable(..)) 36 | import Generics.Deriving.Semigroup (GSemigroup(..)) 37 | #endif 38 | 39 | spec :: Spec 40 | spec = do 41 | describe "DerivingVia Default" $ do 42 | 43 | #if __GLASGOW_HASKELL__ >= 806 44 | it "GEq is commutative for derivingVia (Default MyType)" . sequenceA_ $ 45 | let commutative :: GEq a => a -> a -> Expectation 46 | commutative x y = x `geq` y `shouldBe` y `geq` x 47 | 48 | universe :: [MyType] 49 | universe = MyType <$> [False, True] 50 | 51 | in commutative <$> universe <*> universe 52 | 53 | it "GShow for MyType is like Show for Bool with derivingVia (Default MyType) but prefixed with 'MyType '" $ do 54 | gshowsPrec 0 (MyType False) "" `shouldBe` "MyType " <> showsPrec 0 False "" 55 | gshowsPrec 0 (MyType True) "" `shouldBe` "MyType " <> showsPrec 0 True "" 56 | 57 | it "GEq is commutative for parameterized derivingVia (Default (MyType1 Bool))" . sequenceA_ $ 58 | let commutative :: GEq a => a -> a -> Expectation 59 | commutative x y = x `geq` y `shouldBe` y `geq` x 60 | 61 | universe :: [MyType1 Bool] 62 | universe = MyType1 <$> [False, True] 63 | 64 | in commutative <$> universe <*> universe 65 | 66 | it "GShow for MyType1 Bool is like Show for Bool with derivingVia (Default (MyType1 Bool)) but prefixed with 'MyType1 '" $ do 67 | gshowsPrec 0 (MyType1 False) "" `shouldBe` "MyType1 " <> showsPrec 0 False "" 68 | gshowsPrec 0 (MyType1 True) "" `shouldBe` "MyType1 " <> showsPrec 0 True "" 69 | 70 | it "GEq is commutative for derivingVia (Default Bool)" . sequenceA_ $ 71 | let commutative :: GEq a => a -> a -> Expectation 72 | commutative x y = x `geq` y `shouldBe` y `geq` x 73 | 74 | universe :: [TestEq] 75 | universe = TestEq <$> [False, True] 76 | 77 | in commutative <$> universe <*> universe 78 | 79 | it "GENum is correct for derivingVia (Default Bool)" $ 80 | genum `shouldBe` [TestEnum False, TestEnum True] 81 | 82 | it "GShow for TestShow is the same as Show for Bool with derivingVia (Default Bool)" $ do 83 | gshowsPrec 0 (TestShow False) "" `shouldBe` showsPrec 0 False "" 84 | gshowsPrec 0 (TestShow True) "" `shouldBe` showsPrec 0 True "" 85 | 86 | it "GSemigroup is like First when instantiated with derivingVia (First Bool)" . sequenceA_ $ 87 | let first' :: (Eq a, Show a, GSemigroup a) => a -> a -> Expectation 88 | first' x y = x `gsappend` y `shouldBe` x 89 | 90 | universe :: [FirstSemigroup] 91 | universe = FirstSemigroup <$> [False, True] 92 | 93 | in first' <$> universe <*> universe 94 | 95 | prop "GFoldable with derivingVia (Default1 Option) acts like mconcat with Maybe (First Bool)" $ \(xs :: [Maybe Bool]) -> 96 | let ys :: [Maybe (First Bool)] 97 | -- Note that there is no Arbitrary instance for this type 98 | ys = fmap First <$> xs 99 | 100 | unTestFoldable :: TestFoldable a -> Maybe a 101 | unTestFoldable (TestFoldable x) = x 102 | 103 | in gfoldMap unTestFoldable (TestFoldable <$> ys) `shouldBe` mconcat ys 104 | 105 | it "GFunctor for TestFunctor Bool is as Functor for Maybe Bool" . sequenceA_ $ 106 | let universe :: [Maybe Bool] 107 | universe = [Nothing, Just False, Just True] 108 | 109 | functor_prop :: Maybe Bool -> Expectation 110 | functor_prop x = gmap not (TestFunctor x) `shouldBe` TestFunctor (not <$> x) 111 | 112 | in functor_prop <$> universe 113 | 114 | #endif 115 | return () 116 | 117 | #if __GLASGOW_HASKELL__ >= 806 118 | 119 | -- These types all implement instances using `DerivingVia`: most via 120 | -- `Default` (one uses `First`). 121 | 122 | newtype TestEq = TestEq Bool 123 | deriving (GEq) via (Default Bool) 124 | newtype TestEnum = TestEnum Bool 125 | deriving stock (Eq, Show) 126 | deriving (GEnum) via (Default Bool) 127 | newtype TestShow = TestShow Bool 128 | deriving (GShow) via (Default Bool) 129 | 130 | newtype FirstSemigroup = FirstSemigroup Bool 131 | deriving stock (Eq, Show) 132 | deriving (GSemigroup) via (First Bool) 133 | 134 | newtype TestFoldable a = TestFoldable (Maybe a) 135 | deriving (GFoldable) via (Default1 Maybe) 136 | 137 | newtype TestFunctor a = TestFunctor (Maybe a) 138 | deriving stock (Eq, Show, Functor) 139 | deriving (GFunctor) via (Default1 Maybe) 140 | 141 | newtype TestHigherEq a = TestHigherEq (Maybe a) 142 | deriving stock (Generic) 143 | deriving (GEq) via (Default (TestHigherEq a)) 144 | 145 | -- These types correspond to the hypothetical examples in the module 146 | -- documentation. 147 | 148 | data MyType = MyType Bool 149 | deriving (Generic) 150 | deriving (GEq) via (Default MyType) 151 | 152 | deriving via (Default MyType) instance GShow MyType 153 | 154 | data MyType1 a = MyType1 a 155 | deriving (Generic, Generic1) 156 | deriving (GEq) via (Default (MyType1 a)) 157 | deriving (GFunctor) via (Default1 MyType1) 158 | 159 | deriving via Default (MyType1 a) instance GShow a => GShow (MyType1 a) 160 | deriving via (Default1 MyType1) instance GFoldable MyType1 161 | #endif 162 | -------------------------------------------------------------------------------- /tests/EmptyCaseSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE EmptyCase #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | 7 | module EmptyCaseSpec (main, spec) where 8 | 9 | import Generics.Deriving.TH 10 | import Test.Hspec 11 | 12 | data Empty a 13 | $(deriveAll0And1Options defaultOptions{emptyCaseOptions = True} 14 | ''Empty) 15 | 16 | main :: IO () 17 | main = hspec spec 18 | 19 | spec :: Spec 20 | spec = return () 21 | -------------------------------------------------------------------------------- /tests/ExampleSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE EmptyDataDecls #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE KindSignatures #-} 8 | {-# LANGUAGE MagicHash #-} 9 | {-# LANGUAGE PolyKinds #-} 10 | {-# LANGUAGE StandaloneDeriving #-} 11 | {-# LANGUAGE TemplateHaskell #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE TypeOperators #-} 14 | {-# LANGUAGE UndecidableInstances #-} 15 | 16 | {-# OPTIONS_GHC -Wno-orphans #-} 17 | 18 | module ExampleSpec (main, spec) where 19 | 20 | import Generics.Deriving 21 | import Generics.Deriving.TH 22 | 23 | import GHC.Exts (Addr#, Char#, Double#, Float#, Int#, Word#) 24 | 25 | import Prelude hiding (Either(..)) 26 | 27 | import Test.Hspec (Spec, describe, hspec, it, parallel, shouldBe) 28 | 29 | import qualified Text.Read.Lex (Lexeme) 30 | 31 | ------------------------------------------------------------------------------- 32 | -- Example: Haskell's lists and Maybe 33 | ------------------------------------------------------------------------------- 34 | 35 | hList:: [Int] 36 | hList = [1..10] 37 | 38 | maybe1, maybe2 :: Maybe (Maybe Char) 39 | maybe1 = Nothing 40 | maybe2 = Just (Just 'p') 41 | 42 | double :: [Int] -> [Int] 43 | double [] = [] 44 | double (x:xs) = x:x:xs 45 | 46 | ------------------------------------------------------------------------------- 47 | -- Example: trees of integers (kind *) 48 | ------------------------------------------------------------------------------- 49 | 50 | data Tree = Empty | Branch Int Tree Tree 51 | 52 | $(deriveAll0 ''Tree) 53 | 54 | instance GShow Tree where 55 | gshowsPrec = gshowsPrecdefault 56 | 57 | instance Uniplate Tree where 58 | children = childrendefault 59 | context = contextdefault 60 | descend = descenddefault 61 | descendM = descendMdefault 62 | transform = transformdefault 63 | transformM = transformMdefault 64 | 65 | instance GEnum Tree where 66 | genum = genumDefault 67 | 68 | upgradeTree :: Tree -> Tree 69 | upgradeTree Empty = Branch 0 Empty Empty 70 | upgradeTree (Branch n l r) = Branch (succ n) l r 71 | 72 | tree :: Tree 73 | tree = Branch 2 Empty (Branch 1 Empty Empty) 74 | 75 | ------------------------------------------------------------------------------- 76 | -- Example: lists (kind * -> *) 77 | ------------------------------------------------------------------------------- 78 | 79 | data List a = Nil | Cons a (List a) 80 | 81 | $(deriveAll0And1 ''List) 82 | 83 | instance GFunctor List where 84 | gmap = gmapdefault 85 | 86 | instance (GShow a) => GShow (List a) where 87 | gshowsPrec = gshowsPrecdefault 88 | 89 | instance (Uniplate a) => Uniplate (List a) where 90 | children = childrendefault 91 | context = contextdefault 92 | descend = descenddefault 93 | descendM = descendMdefault 94 | transform = transformdefault 95 | transformM = transformMdefault 96 | 97 | list :: List Char 98 | list = Cons 'p' (Cons 'q' Nil) 99 | 100 | listlist :: List (List Char) 101 | listlist = Cons list (Cons Nil Nil) -- ["pq",""] 102 | 103 | ------------------------------------------------------------------------------- 104 | -- Example: Type composition 105 | ------------------------------------------------------------------------------- 106 | 107 | data Rose a = Rose [a] [Rose a] 108 | 109 | $(deriveAll0And1 ''Rose) 110 | 111 | instance (GShow a) => GShow (Rose a) where 112 | gshowsPrec = gshowsPrecdefault 113 | 114 | instance GFunctor Rose where 115 | gmap = gmapdefault 116 | 117 | -- Example usage 118 | rose1 :: Rose Int 119 | rose1 = Rose [1,2] [Rose [3,4] [], Rose [5] []] 120 | 121 | ------------------------------------------------------------------------------- 122 | -- Example: Higher-order kinded datatype, type composition 123 | ------------------------------------------------------------------------------- 124 | 125 | data GRose f a = GRose (f a) (f (GRose f a)) 126 | deriving instance Functor f => Functor (GRose f) 127 | 128 | $(deriveMeta ''GRose) 129 | $(deriveRepresentable0 ''GRose) 130 | $(deriveRep1 ''GRose) 131 | instance Functor f => Generic1 (GRose f) where 132 | type Rep1 (GRose f) = $(makeRep1 ''GRose) f 133 | from1 = $(makeFrom1 ''GRose) 134 | to1 = $(makeTo1 ''GRose) 135 | 136 | instance (GShow (f a), GShow (f (GRose f a))) => GShow (GRose f a) where 137 | gshowsPrec = gshowsPrecdefault 138 | 139 | instance (Functor f, GFunctor f) => GFunctor (GRose f) where 140 | gmap = gmapdefault 141 | 142 | grose1 :: GRose [] Int 143 | grose1 = GRose [1,2] [GRose [3] [], GRose [] []] 144 | 145 | ------------------------------------------------------------------------------- 146 | -- Example: Two parameters, nested on other parameter 147 | ------------------------------------------------------------------------------- 148 | 149 | data Either a b = Left (Either [a] b) | Right b 150 | 151 | $(deriveAll0And1 ''Either) 152 | 153 | instance (GShow a, GShow b) => GShow (Either a b) where 154 | gshowsPrec = gshowsPrecdefault 155 | 156 | instance GFunctor (Either a) where 157 | gmap = gmapdefault 158 | 159 | either1 :: Either Int Char 160 | either1 = Left either2 161 | 162 | either2 :: Either [Int] Char 163 | either2 = Right 'p' 164 | 165 | ------------------------------------------------------------------------------- 166 | -- Example: Nested datatype, record selectors 167 | ------------------------------------------------------------------------------- 168 | 169 | data Nested a = Leaf | Nested { value :: a, rec :: Nested [a] } 170 | deriving Functor 171 | 172 | $(deriveAll0And1 ''Nested) 173 | 174 | instance (GShow a) => GShow (Nested a) where 175 | gshowsPrec = gshowsPrecdefault 176 | 177 | instance GFunctor Nested where 178 | gmap = gmapdefault 179 | 180 | nested :: Nested Int 181 | nested = Nested { value = 1, rec = Nested [2] (Nested [[3],[4,5],[]] Leaf) } 182 | 183 | ------------------------------------------------------------------------------- 184 | -- Example: Nested datatype Bush (minimal) 185 | ------------------------------------------------------------------------------- 186 | 187 | data Bush a = BushNil | BushCons a (Bush (Bush a)) deriving Functor 188 | 189 | $(deriveAll0And1 ''Bush) 190 | 191 | instance GFunctor Bush where 192 | gmap = gmapdefault 193 | 194 | instance (GShow a) => GShow (Bush a) where 195 | gshowsPrec = gshowsPrecdefault 196 | 197 | bush1 :: Bush Int 198 | bush1 = BushCons 0 (BushCons (BushCons 1 BushNil) BushNil) 199 | 200 | ------------------------------------------------------------------------------- 201 | -- Example: Double type composition (minimal) 202 | ------------------------------------------------------------------------------- 203 | 204 | data Weird a = Weird [[[a]]] deriving Show 205 | 206 | $(deriveAll0And1 ''Weird) 207 | 208 | instance GFunctor Weird where 209 | gmap = gmapdefault 210 | 211 | -------------------------------------------------------------------------------- 212 | -- Temporary tests for TH generation 213 | -------------------------------------------------------------------------------- 214 | 215 | data Empty a 216 | 217 | data (:/:) f a = MyType1Nil 218 | | MyType1Cons { _myType1Rec :: (f :/: a), _myType2Rec :: MyType2 } 219 | | MyType1Cons2 (f :/: a) Int a (f a) 220 | | (f :/: a) :/: MyType2 221 | 222 | infixr 5 :!@!: 223 | data GADTSyntax a b where 224 | GADTPrefix :: d -> c -> GADTSyntax c d 225 | (:!@!:) :: e -> f -> GADTSyntax e f 226 | 227 | data MyType2 = MyType2 Float ([] :/: Int) 228 | data PlainHash a = Hash a Addr# Char# Double# Float# Int# Word# 229 | 230 | -- Test to see if generated names are unique 231 | data Lexeme = Lexeme 232 | 233 | data family MyType3 (a :: v) (b :: w) (c :: x) (d :: y) (e :: z) 234 | newtype instance MyType3 (f p) (f p) f p (q :: *) = MyType3Newtype q 235 | data instance MyType3 Bool () f p q = MyType3True | MyType3False 236 | data instance MyType3 Int () f p (q :: *) = MyType3Hash q Addr# Char# Double# Float# Int# Word# 237 | 238 | $(deriveAll0And1 ''Empty) 239 | $(deriveAll0And1 ''(:/:)) 240 | $(deriveAll0And1 ''GADTSyntax) 241 | $(deriveAll0 ''MyType2) 242 | $(deriveAll0And1 ''PlainHash) 243 | $(deriveAll0 ''ExampleSpec.Lexeme) 244 | $(deriveAll0 ''Text.Read.Lex.Lexeme) 245 | 246 | $(deriveAll0And1 'MyType3Newtype) 247 | $(deriveAll0And1 'MyType3False) 248 | $(deriveAll0And1 'MyType3Hash) 249 | 250 | ------------------------------------------------------------------------------- 251 | -- Unit tests 252 | ------------------------------------------------------------------------------- 253 | 254 | main :: IO () 255 | main = hspec spec 256 | 257 | spec :: Spec 258 | spec = parallel $ do 259 | describe "[] and Maybe tests" $ do 260 | it "gshow hList" $ 261 | gshow hList `shouldBe` 262 | "[1,2,3,4,5,6,7,8,9,10]" 263 | 264 | it "gshow (children maybe2)" $ 265 | gshow (children maybe2) `shouldBe` 266 | "[]" 267 | 268 | it "gshow (transform (const \"abc\") [])" $ 269 | gshow (transform (const "abc") []) `shouldBe` 270 | "\"abc\"" 271 | 272 | it "gshow (transform double hList)" $ 273 | gshow (transform double hList) `shouldBe` 274 | "[1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8,9,9,10,10]" 275 | 276 | it "gshow (geq hList hList)" $ 277 | gshow (geq hList hList) `shouldBe` 278 | "True" 279 | 280 | it "gshow (geq maybe1 maybe2)" $ 281 | gshow (geq maybe1 maybe2) `shouldBe` 282 | "False" 283 | 284 | it "gshow (take 5 genum)" $ 285 | gshow (take 5 (genum :: [Maybe Int])) `shouldBe` 286 | "[Nothing,Just 0,Just -1,Just 1,Just -2]" 287 | 288 | it "gshow (take 15 genum)" $ 289 | gshow (take 15 (genum :: [[Int]])) `shouldBe` 290 | "[[],[0],[0,0],[-1],[0,0,0],[-1,0],[1],[0,-1],[-1,0,0],[1,0],[-2],[0,0,0,0],[-1,-1],[1,0,0],[-2,0]]" 291 | 292 | it "gshow (range ([0], [1]))" $ 293 | gshow (range ([0], [1::Int])) `shouldBe` 294 | "[[0],[0,0],[-1],[0,0,0],[-1,0]]" 295 | 296 | it "gshow (inRange ([0], [3,5]) hList)" $ 297 | gshow (inRange ([0], [3,5::Int]) hList) `shouldBe` 298 | "False" 299 | 300 | describe "Tests for Tree" $ do 301 | it "gshow tree" $ 302 | gshow tree `shouldBe` 303 | "Branch 2 Empty (Branch 1 Empty Empty)" 304 | 305 | it "gshow (children tree)" $ 306 | gshow (children tree) `shouldBe` 307 | "[Empty,Branch 1 Empty Empty]" 308 | 309 | it "gshow (descend (descend (\\_ -> Branch 0 Empty Empty)) tree)" $ 310 | gshow (descend (descend (\_ -> Branch 0 Empty Empty)) tree) `shouldBe` 311 | "Branch 2 Empty (Branch 1 (Branch 0 Empty Empty) (Branch 0 Empty Empty))" 312 | 313 | it "gshow (context tree [Branch 1 Empty Empty,Empty])" $ 314 | gshow (context tree [Branch 1 Empty Empty,Empty]) `shouldBe` 315 | "Branch 2 (Branch 1 Empty Empty) Empty" 316 | 317 | it "gshow (transform upgradeTree tree)" $ 318 | gshow (transform upgradeTree tree) `shouldBe` 319 | "Branch 3 (Branch 0 Empty Empty) (Branch 2 (Branch 0 Empty Empty) (Branch 0 Empty Empty))" 320 | 321 | it "gshow (take 10 genum)" $ do 322 | gshow (take 10 (genum :: [Tree])) `shouldBe` 323 | "[Empty,Branch 0 Empty Empty,Branch 0 Empty (Branch 0 Empty Empty),Branch -1 Empty Empty,Branch 0 (Branch 0 Empty Empty) Empty,Branch -1 Empty (Branch 0 Empty Empty),Branch 1 Empty Empty,Branch 0 Empty (Branch 0 Empty (Branch 0 Empty Empty)),Branch -1 (Branch 0 Empty Empty) Empty,Branch 1 Empty (Branch 0 Empty Empty)]" 324 | 325 | describe "Tests for List" $ do 326 | it "gshow (gmap fromEnum list)" $ 327 | gshow (gmap fromEnum list) `shouldBe` 328 | "Cons 112 (Cons 113 Nil)" 329 | 330 | it "gshow (gmap gshow listlist)" $ 331 | gshow (gmap gshow listlist) `shouldBe` 332 | "Cons \"Cons 'p' (Cons 'q' Nil)\" (Cons \"Nil\" Nil)" 333 | 334 | it "gshow list" $ 335 | gshow list `shouldBe` 336 | "Cons 'p' (Cons 'q' Nil)" 337 | 338 | it "gshow listlist" $ 339 | gshow listlist `shouldBe` 340 | "Cons (Cons 'p' (Cons 'q' Nil)) (Cons Nil Nil)" 341 | 342 | it "gshow (children list)" $ 343 | gshow (children list) `shouldBe` 344 | "[Cons 'q' Nil]" 345 | 346 | it "gshow (children listlist)" $ 347 | gshow (children listlist) `shouldBe` 348 | "[Cons Nil Nil]" 349 | 350 | describe "Tests for Rose" $ do 351 | it "gshow rose1" $ 352 | gshow rose1 `shouldBe` 353 | "Rose [1,2] [Rose [3,4] [],Rose [5] []]" 354 | 355 | it "gshow (gmap gshow rose1)" $ 356 | gshow (gmap gshow rose1) `shouldBe` 357 | "Rose [\"1\",\"2\"] [Rose [\"3\",\"4\"] [],Rose [\"5\"] []]" 358 | 359 | describe "Tests for GRose" $ do 360 | it "gshow grose1" $ 361 | gshow grose1 `shouldBe` 362 | "GRose [1,2] [GRose [3] [],GRose [] []]" 363 | 364 | it "gshow (gmap gshow grose1)" $ 365 | gshow (gmap gshow grose1) `shouldBe` 366 | "GRose [\"1\",\"2\"] [GRose [\"3\"] [],GRose [] []]" 367 | 368 | describe "Tests for Either" $ do 369 | it "gshow either1" $ 370 | gshow either1 `shouldBe` 371 | "Left Right 'p'" 372 | 373 | it "gshow (gmap gshow either1)" $ 374 | gshow (gmap gshow either1) `shouldBe` 375 | "Left Right \"'p'\"" 376 | 377 | describe "Tests for Nested" $ do 378 | it "gshow nested" $ 379 | gshow nested `shouldBe` 380 | "Nested {value = 1, rec = Nested {value = [2], rec = Nested {value = [[3],[4,5],[]], rec = Leaf}}}" 381 | 382 | it "gshow (gmap gshow nested)" $ 383 | gshow (gmap gshow nested) `shouldBe` 384 | "Nested {value = \"1\", rec = Nested {value = [\"2\"], rec = Nested {value = [[\"3\"],[\"4\",\"5\"],[]], rec = Leaf}}}" 385 | 386 | describe "Tests for Bush" $ do 387 | it "gshow bush1" $ 388 | gshow bush1 `shouldBe` 389 | "BushCons 0 (BushCons (BushCons 1 BushNil) BushNil)" 390 | 391 | it "gshow (gmap gshow bush1)" $ 392 | gshow (gmap gshow bush1) `shouldBe` 393 | "BushCons \"0\" (BushCons (BushCons \"1\" BushNil) BushNil)" 394 | -------------------------------------------------------------------------------- /tests/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /tests/T68Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | module T68Spec (main, spec) where 6 | 7 | import Generics.Deriving.TH 8 | import Test.Hspec 9 | 10 | main :: IO () 11 | main = hspec spec 12 | 13 | spec :: Spec 14 | spec = return () 15 | 16 | type family F68 :: * -> * 17 | type instance F68 = Maybe 18 | data T68 a = MkT68 (F68 a) 19 | $(deriveAll1 ''T68) 20 | -------------------------------------------------------------------------------- /tests/T80Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE PolyKinds #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | 6 | module T80Spec (main, spec) where 7 | 8 | import Generics.Deriving.TH 9 | import Test.Hspec 10 | 11 | main :: IO () 12 | main = hspec spec 13 | 14 | spec :: Spec 15 | spec = return () 16 | 17 | newtype T f a b = MkT (f a b) 18 | $(deriveAll1 ''T) 19 | -------------------------------------------------------------------------------- /tests/T82Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE PolyKinds #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | 7 | #if __GLASGOW_HASKELL__ < 806 8 | {-# LANGUAGE TypeInType #-} 9 | #endif 10 | 11 | module T82Spec (main, spec) where 12 | 13 | import Test.Hspec 14 | 15 | #if MIN_VERSION_base(4,10,0) 16 | import Generics.Deriving.TH 17 | import GHC.Exts (RuntimeRep, TYPE) 18 | 19 | data Code m (a :: TYPE (r :: RuntimeRep)) = Code 20 | $(deriveAll0And1 ''Code) 21 | #endif 22 | 23 | main :: IO () 24 | main = hspec spec 25 | 26 | spec :: Spec 27 | spec = return () 28 | -------------------------------------------------------------------------------- /tests/TypeInTypeSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | 8 | #if __GLASGOW_HASKELL__ < 806 9 | {-# LANGUAGE TypeInType #-} 10 | #endif 11 | 12 | module TypeInTypeSpec (main, spec) where 13 | 14 | import Data.Proxy (Proxy(..)) 15 | import Generics.Deriving.TH 16 | import Test.Hspec 17 | 18 | #if MIN_VERSION_base(4,10,0) 19 | import Generics.Deriving (Generic1(..)) 20 | #endif 21 | 22 | data TyCon x (a :: x) (b :: k) = TyCon k x (Proxy a) (TyCon x a b) 23 | $(deriveAll0And1 ''TyCon) 24 | 25 | data family TyFam x (a :: x) (b :: k) 26 | data instance TyFam x (a :: x) (b :: k) = TyFam k x (Proxy a) (TyFam x a b) 27 | $(deriveAll0And1 'TyFam) 28 | 29 | #if MIN_VERSION_base(4,10,0) 30 | gen1PolyKinds :: Generic1 f => f 'True -> Rep1 f 'True 31 | gen1PolyKinds = from1 32 | #endif 33 | 34 | main :: IO () 35 | main = hspec spec 36 | 37 | spec :: Spec 38 | spec = parallel $ do 39 | #if MIN_VERSION_base(4,10,0) 40 | describe "TyCon Bool 'False 'True" $ 41 | it "has an appropriately kinded Generic1 instance" $ 42 | let rep :: Rep1 (TyCon Bool 'False) 'True 43 | rep = gen1PolyKinds $ let x = TyCon True False Proxy x in x 44 | in seq rep () `shouldBe` () 45 | describe "TyFam Bool 'False 'True" $ 46 | it "has an appropriately kinded Generic1 instance" $ 47 | let rep :: Rep1 (TyFam Bool 'False) 'True 48 | rep = gen1PolyKinds $ let x = TyFam True False Proxy x in x 49 | in seq rep () `shouldBe` () 50 | #else 51 | return () 52 | #endif 53 | --------------------------------------------------------------------------------