├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── records-sop.cabal ├── src └── Generics │ └── SOP │ ├── Record.hs │ └── Record │ └── SubTyping.hs ├── stack.yaml ├── stack.yaml.lock └── tests └── Examples.hs /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'records-sop.cabal' 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.16.5 12 | # 13 | # REGENDATA ("0.16.5",["github","records-sop.cabal"]) 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-20.04 23 | timeout-minutes: 24 | 60 25 | container: 26 | image: buildpack-deps:bionic 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-9.6.2 32 | compilerKind: ghc 33 | compilerVersion: 9.6.2 34 | setup-method: ghcup 35 | allow-failure: false 36 | - compiler: ghc-9.4.5 37 | compilerKind: ghc 38 | compilerVersion: 9.4.5 39 | setup-method: ghcup 40 | allow-failure: false 41 | - compiler: ghc-9.2.8 42 | compilerKind: ghc 43 | compilerVersion: 9.2.8 44 | setup-method: ghcup 45 | allow-failure: false 46 | - compiler: ghc-9.0.2 47 | compilerKind: ghc 48 | compilerVersion: 9.0.2 49 | setup-method: ghcup 50 | allow-failure: false 51 | - compiler: ghc-8.10.7 52 | compilerKind: ghc 53 | compilerVersion: 8.10.7 54 | setup-method: ghcup 55 | allow-failure: false 56 | - compiler: ghc-8.8.4 57 | compilerKind: ghc 58 | compilerVersion: 8.8.4 59 | setup-method: hvr-ppa 60 | allow-failure: false 61 | - compiler: ghc-8.6.5 62 | compilerKind: ghc 63 | compilerVersion: 8.6.5 64 | setup-method: hvr-ppa 65 | allow-failure: false 66 | - compiler: ghc-8.4.4 67 | compilerKind: ghc 68 | compilerVersion: 8.4.4 69 | setup-method: hvr-ppa 70 | allow-failure: false 71 | - compiler: ghc-8.2.2 72 | compilerKind: ghc 73 | compilerVersion: 8.2.2 74 | setup-method: hvr-ppa 75 | allow-failure: false 76 | - compiler: ghc-8.0.2 77 | compilerKind: ghc 78 | compilerVersion: 8.0.2 79 | setup-method: hvr-ppa 80 | allow-failure: false 81 | fail-fast: false 82 | steps: 83 | - name: apt 84 | run: | 85 | apt-get update 86 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 87 | if [ "${{ matrix.setup-method }}" = ghcup ]; then 88 | mkdir -p "$HOME/.ghcup/bin" 89 | curl -sL https://downloads.haskell.org/ghcup/0.1.19.2/x86_64-linux-ghcup-0.1.19.2 > "$HOME/.ghcup/bin/ghcup" 90 | chmod a+x "$HOME/.ghcup/bin/ghcup" 91 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 92 | "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 93 | else 94 | apt-add-repository -y 'ppa:hvr/ghc' 95 | apt-get update 96 | apt-get install -y "$HCNAME" 97 | mkdir -p "$HOME/.ghcup/bin" 98 | curl -sL https://downloads.haskell.org/ghcup/0.1.19.2/x86_64-linux-ghcup-0.1.19.2 > "$HOME/.ghcup/bin/ghcup" 99 | chmod a+x "$HOME/.ghcup/bin/ghcup" 100 | "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 101 | fi 102 | env: 103 | HCKIND: ${{ matrix.compilerKind }} 104 | HCNAME: ${{ matrix.compiler }} 105 | HCVER: ${{ matrix.compilerVersion }} 106 | - name: Set PATH and environment variables 107 | run: | 108 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 109 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 110 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 111 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 112 | HCDIR=/opt/$HCKIND/$HCVER 113 | if [ "${{ matrix.setup-method }}" = ghcup ]; then 114 | HC=$HOME/.ghcup/bin/$HCKIND-$HCVER 115 | echo "HC=$HC" >> "$GITHUB_ENV" 116 | echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV" 117 | echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV" 118 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" 119 | else 120 | HC=$HCDIR/bin/$HCKIND 121 | echo "HC=$HC" >> "$GITHUB_ENV" 122 | echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV" 123 | echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV" 124 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" 125 | fi 126 | 127 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 128 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 129 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 130 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 131 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 132 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 133 | echo "GHCJSARITH=0" >> "$GITHUB_ENV" 134 | env: 135 | HCKIND: ${{ matrix.compilerKind }} 136 | HCNAME: ${{ matrix.compiler }} 137 | HCVER: ${{ matrix.compilerVersion }} 138 | - name: env 139 | run: | 140 | env 141 | - name: write cabal config 142 | run: | 143 | mkdir -p $CABAL_DIR 144 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 177 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 178 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 179 | rm -f cabal-plan.xz 180 | chmod a+x $HOME/.cabal/bin/cabal-plan 181 | cabal-plan --version 182 | - name: checkout 183 | uses: actions/checkout@v3 184 | with: 185 | path: source 186 | - name: initial cabal.project for sdist 187 | run: | 188 | touch cabal.project 189 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 190 | cat cabal.project 191 | - name: sdist 192 | run: | 193 | mkdir -p sdist 194 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 195 | - name: unpack 196 | run: | 197 | mkdir -p unpacked 198 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 199 | - name: generate cabal.project 200 | run: | 201 | PKGDIR_records_sop="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/records-sop-[0-9.]*')" 202 | echo "PKGDIR_records_sop=${PKGDIR_records_sop}" >> "$GITHUB_ENV" 203 | rm -f cabal.project cabal.project.local 204 | touch cabal.project 205 | touch cabal.project.local 206 | echo "packages: ${PKGDIR_records_sop}" >> cabal.project 207 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package records-sop" >> cabal.project ; fi 208 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi 209 | cat >> cabal.project <> cabal.project.local 212 | cat cabal.project 213 | cat cabal.project.local 214 | - name: dump install plan 215 | run: | 216 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 217 | cabal-plan 218 | - name: restore cache 219 | uses: actions/cache/restore@v3 220 | with: 221 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 222 | path: ~/.cabal/store 223 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 224 | - name: install dependencies 225 | run: | 226 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 227 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 228 | - name: build w/o tests 229 | run: | 230 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 231 | - name: build 232 | run: | 233 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 234 | - name: tests 235 | run: | 236 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 237 | - name: cabal check 238 | run: | 239 | cd ${PKGDIR_records_sop} || false 240 | ${CABAL} -vnormal check 241 | - name: haddock 242 | run: | 243 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 244 | - name: unconstrained build 245 | run: | 246 | rm -f cabal.project.local 247 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 248 | - name: save cache 249 | uses: actions/cache/save@v3 250 | if: always() 251 | with: 252 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 253 | path: ~/.cabal/store 254 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | dist-newstyle/ 3 | .stack-work/ 4 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # 0.1.1.0 (2020-04-09) 2 | 3 | * Export `get` and add `getField`. 4 | 5 | # 0.1.0.3 (2019-05-09) 6 | 7 | * Compatibility with `generics-sop-0.5`. 8 | 9 | # 0.1.0.2 (2018-10-20) 10 | 11 | * Relax version bound on generics-sop and add an 12 | extra LANGUAGE pragma for compatibility. 13 | 14 | # 0.1.0.1 (2018-09-01) 15 | 16 | * Relax version bound for hspec and fix a warning in 17 | the test suite. 18 | 19 | # 0.1.0.0 (2017-05-01) 20 | 21 | * Initial release. Everything is still rather experimental. 22 | Feedback on any aspect of the library is welcome. 23 | 24 | Currently, the general utilities are in 25 | `Generics.SOP.Record`, and the subtyping functionality is 26 | in `Generics.SOP.Record.SubTyping`. 27 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017, Andres Löh 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | 1. Redistributions of source code must retain the above copyright notice, 8 | this 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 the copyright holder nor the names of its contributors 15 | may be used to endorse or promote products derived from this software 16 | without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 19 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /records-sop.cabal: -------------------------------------------------------------------------------- 1 | name: records-sop 2 | version: 0.1.1.1 3 | author: Andres Löh 4 | maintainer: andres@well-typed.com 5 | license: BSD3 6 | license-file: LICENSE 7 | cabal-version: >= 1.10 8 | build-type: Simple 9 | tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.8, GHC == 9.4.5, GHC == 9.6.2 10 | category: Generics 11 | synopsis: Record subtyping and record utilities with generics-sop 12 | description: 13 | This library provides utilities for working with labelled 14 | single-constructor record types via generics-sop. 15 | . 16 | It also provides functions to safely cast between record 17 | types if the target type has a subset of the fields (with 18 | the same names) of the source type. 19 | extra-source-files: CHANGELOG.md 20 | 21 | source-repository head 22 | type: git 23 | location: https://github.com/kosmikus/records-sop 24 | 25 | library 26 | hs-source-dirs: 27 | src 28 | ghc-options: 29 | -Wall 30 | exposed-modules: 31 | Generics.SOP.Record, 32 | Generics.SOP.Record.SubTyping 33 | build-depends: 34 | base >= 4.9 && < 5.0, 35 | deepseq >= 1.3 && < 1.5, 36 | generics-sop >= 0.3 && < 0.6, 37 | ghc-prim >= 0.5 && < 0.11 38 | default-language: 39 | Haskell2010 40 | 41 | test-suite examples 42 | type: 43 | exitcode-stdio-1.0 44 | hs-source-dirs: 45 | tests 46 | ghc-options: 47 | -Wall 48 | main-is: 49 | Examples.hs 50 | build-depends: 51 | base >= 4.9 && < 5.0, 52 | deepseq >= 1.4 && < 1.5, 53 | hspec >= 2.2 && < 2.11, 54 | generics-sop >= 0.3 && < 0.6, 55 | records-sop, 56 | should-not-typecheck >= 2.1 && < 2.2 57 | default-language: 58 | Haskell2010 59 | -------------------------------------------------------------------------------- /src/Generics/SOP/Record.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | #if MIN_VERSION_base(4,12,0) 12 | {-# LANGUAGE DataKinds #-} 13 | {-# LANGUAGE PolyKinds #-} 14 | #else 15 | {-# LANGUAGE TypeInType #-} 16 | #endif 17 | {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} 18 | {-# OPTIONS_GHC -Wno-redundant-constraints #-} 19 | module Generics.SOP.Record 20 | ( -- * A suitable representation for single-constructor records 21 | FieldLabel 22 | , RecordCode 23 | , Record 24 | , RecordRep 25 | -- * Computing the record code 26 | , RecordCodeOf 27 | , IsRecord 28 | , ValidRecordCode 29 | , ExtractTypesFromRecordCode 30 | , ExtractLabelsFromRecordCode 31 | , RecombineRecordCode 32 | -- * Conversion between a type and its record representation. 33 | , toRecord 34 | , fromRecord 35 | -- * Utilities 36 | , P(..) 37 | , Snd 38 | ) 39 | where 40 | 41 | import Control.DeepSeq 42 | import Generics.SOP.BasicFunctors 43 | import Generics.SOP.NP 44 | import Generics.SOP.NS 45 | import Generics.SOP.Universe 46 | import Generics.SOP.Sing 47 | import Generics.SOP.Type.Metadata 48 | import qualified GHC.Generics as GHC 49 | import GHC.TypeLits 50 | import GHC.Types 51 | import Unsafe.Coerce 52 | 53 | -------------------------------------------------------------------------- 54 | -- A suitable representation for single-constructor records. 55 | -------------------------------------------------------------------------- 56 | 57 | -- | On the type-level, we represent fiel labels using symbols. 58 | type FieldLabel = Symbol 59 | 60 | -- | The record code deviates from the normal SOP code in two 61 | -- ways: 62 | -- 63 | -- - There is only one list, because we require that there is 64 | -- only a single constructor. 65 | -- 66 | -- - In addition to the types of the fields, we store the labels 67 | -- of the fields. 68 | -- 69 | type RecordCode = [(FieldLabel, Type)] 70 | 71 | -- | The record representation of a type is a record indexed 72 | -- by the record code. 73 | -- 74 | type RecordRep (a :: Type) = Record (RecordCodeOf a) 75 | 76 | -- | The representation of a record is just a product indexed by 77 | -- a record code, containing elements of the types indicated 78 | -- by the code. 79 | -- 80 | -- Note that the representation is deliberately chosen such that 81 | -- it has the same run-time representation as the product part 82 | -- of the normal SOP representation. 83 | -- 84 | type Record (r :: RecordCode) = NP P r 85 | 86 | -------------------------------------------------------------------------- 87 | -- Computing the record code 88 | -------------------------------------------------------------------------- 89 | 90 | -- | This type-level function takes the type-level metadata provided 91 | -- by generics-sop as well as the normal generics-sop code, and transforms 92 | -- them into the record code. 93 | -- 94 | -- Arguably, the record code is more usable than the representation 95 | -- directly on offer by generics-sop. So it's worth asking whether 96 | -- this representation should be included in generics-sop ... 97 | -- 98 | -- The function will only reduce if the argument type actually is a 99 | -- record, meaning it must have exactly one constructor, and that 100 | -- constructor must have field labels attached to it. 101 | -- 102 | type RecordCodeOf a = ToRecordCode_Datatype a (DatatypeInfoOf a) (Code a) 103 | 104 | -- | Helper for 'RecordCodeOf', handling the datatype level. Both 105 | -- datatypes and newtypes are acceptable. Newtypes are just handled 106 | -- as one-constructor datatypes for this purpose. 107 | -- 108 | type family 109 | ToRecordCode_Datatype (a :: Type) (d :: DatatypeInfo) (c :: [[Type]]) :: RecordCode where 110 | #if MIN_VERSION_generics_sop(0,5,0) 111 | ToRecordCode_Datatype a (ADT _ _ cis _) c = ToRecordCode_Constructor a cis c 112 | #else 113 | ToRecordCode_Datatype a (ADT _ _ cis) c = ToRecordCode_Constructor a cis c 114 | #endif 115 | ToRecordCode_Datatype a (Newtype _ _ ci) c = ToRecordCode_Constructor a '[ ci ] c 116 | 117 | -- | Helper for 'RecordCodeOf', handling the constructor level. Only 118 | -- single-constructor types are acceptable, and the constructor must 119 | -- contain field labels. 120 | -- 121 | -- As an exception, we accept an empty record, even though it does 122 | -- not explicitly define any field labels. 123 | -- 124 | type family 125 | ToRecordCode_Constructor (a :: Type) (cis :: [ConstructorInfo]) (c :: [[Type]]) :: RecordCode where 126 | ToRecordCode_Constructor a '[ 'Record _ fis ] '[ ts ] = ToRecordCode_Field fis ts 127 | ToRecordCode_Constructor a '[ 'Constructor _ ] '[ '[] ] = '[] 128 | ToRecordCode_Constructor a '[] _ = 129 | TypeError 130 | ( Text "The type `" :<>: ShowType a :<>: Text "' is not a record type." 131 | :$$: Text "It has no constructors." 132 | ) 133 | ToRecordCode_Constructor a ( _ : _ : _ ) _ = 134 | TypeError 135 | ( Text "The type `" :<>: ShowType a :<>: Text "' is not a record type." 136 | :$$: Text "It has more than one constructor." 137 | ) 138 | ToRecordCode_Constructor a '[ _ ] _ = 139 | TypeError 140 | ( Text "The type `" :<>: ShowType a :<>: Text "' is not a record type." 141 | :$$: Text "It has no labelled fields." 142 | ) 143 | 144 | -- | Helper for 'RecordCodeOf', handling the field level. At this point, 145 | -- we simply zip the list of field names and the list of types. 146 | -- 147 | type family ToRecordCode_Field (fis :: [FieldInfo]) (c :: [Type]) :: RecordCode where 148 | ToRecordCode_Field '[] '[] = '[] 149 | ToRecordCode_Field ( 'FieldInfo l : fis ) ( t : ts ) = '(l, t) : ToRecordCode_Field fis ts 150 | 151 | -- * Relating the record code and the original code. 152 | 153 | -- | The constraint @IsRecord a r@ states that the type 'a' is a record type 154 | -- (i.e., has exactly one constructor and field labels) and that 'r' is the 155 | -- record code associated with 'a'. 156 | -- 157 | type IsRecord (a :: Type) (r :: RecordCode) = 158 | IsRecord' a r (GetSingleton (Code a)) 159 | 160 | -- | The constraint @IsRecord' a r xs@ states that 'a' is a record type 161 | -- with record code 'r', and that the types contained in 'r' correspond 162 | -- to the list 'xs'. 163 | -- 164 | -- If the record code computation is correct, then the record code of a 165 | -- type is strongly related to the original generics-sop code. Extracting 166 | -- the types out of 'r' should correspond to 'xs'. Recombining the 167 | -- labels from 'r' with 'xs' should yield 'r' exactly. These sanity 168 | -- properties are captured by 'ValidRecordCode'. 169 | -- 170 | type IsRecord' (a :: Type) (r :: RecordCode) (xs :: [Type]) = 171 | ( Generic a, Code a ~ '[ xs ] 172 | , RecordCodeOf a ~ r, ValidRecordCode r xs 173 | ) 174 | 175 | -- | Relates a recordcode 'r' and a list of types 'xs', stating that 176 | -- 'xs' is indeed the list of types contained in 'r'. 177 | -- 178 | type ValidRecordCode (r :: RecordCode) (xs :: [Type]) = 179 | ( ExtractTypesFromRecordCode r ~ xs 180 | , RecombineRecordCode (ExtractLabelsFromRecordCode r) xs ~ r 181 | ) 182 | 183 | -- | Extracts all the types from a record code. 184 | type family ExtractTypesFromRecordCode (r :: RecordCode) :: [Type] where 185 | ExtractTypesFromRecordCode '[] = '[] 186 | ExtractTypesFromRecordCode ( '(_, a) : r ) = a : ExtractTypesFromRecordCode r 187 | 188 | -- | Extracts all the field labels from a record code. 189 | type family ExtractLabelsFromRecordCode (r :: RecordCode) :: [FieldLabel] where 190 | ExtractLabelsFromRecordCode '[] = '[] 191 | ExtractLabelsFromRecordCode ( '(l, _) : r ) = l : ExtractLabelsFromRecordCode r 192 | 193 | -- | Given a list of labels and types, recombines them into a record code. 194 | -- 195 | -- An important aspect of this function is that it is defined by induction 196 | -- on the list of types, and forces the list of field labels to be at least 197 | -- as long. 198 | -- 199 | type family RecombineRecordCode (ls :: [FieldLabel]) (ts :: [Type]) :: RecordCode where 200 | RecombineRecordCode _ '[] = '[] 201 | RecombineRecordCode ls (t : ts) = '(Head ls, t) : RecombineRecordCode (Tail ls) ts 202 | 203 | -------------------------------------------------------------------------- 204 | -- Conversion between a type and its record representation. 205 | -------------------------------------------------------------------------- 206 | 207 | -- | Convert a value into its record representation. 208 | toRecord :: (IsRecord a _r) => a -> RecordRep a 209 | toRecord = unsafeToRecord_NP . unZ . unSOP . from 210 | 211 | -- | Convert an n-ary product into the corresponding record 212 | -- representation. This is a no-op, and more efficiently 213 | -- implented using 'unsafeToRecord_NP'. It is included here 214 | -- to demonstrate that it actually is type-correct and also 215 | -- to make it more obvious that it is indeed a no-op. 216 | -- 217 | _toRecord_NP :: (ValidRecordCode r xs) => NP I xs -> Record r 218 | _toRecord_NP Nil = Nil 219 | _toRecord_NP (I x :* xs) = P x :* _toRecord_NP xs 220 | 221 | -- | Fast version of 'toRecord_NP'. Not actually unsafe as 222 | -- long as the internal representations of 'NP' and 'Record' 223 | -- are not changed. 224 | -- 225 | unsafeToRecord_NP :: (ValidRecordCode r xs) => NP I xs -> Record r 226 | unsafeToRecord_NP = unsafeCoerce 227 | 228 | -- | Convert a record representation back into a value. 229 | fromRecord :: forall a r . (IsRecord a r) => RecordRep a -> a 230 | fromRecord = fromRecord' 231 | where 232 | fromRecord' :: forall xs . (IsRecord' a r xs) => RecordRep a -> a -- extra type signature should not be necessary, see GHC #21515 233 | fromRecord' = to . SOP . Z . unsafeFromRecord_NP 234 | 235 | -- | Convert a record representation into an n-ary product. This is a no-op, 236 | -- and more efficiently implemented using 'unsafeFromRecord_NP'. 237 | -- 238 | -- It is also noteworthy that we let the resulting list drive the computation. 239 | -- This is compatible with the definition of 'RecombineRecordCode' based on 240 | -- the list of types. 241 | -- 242 | _fromRecord_NP :: forall r xs . (ValidRecordCode r xs, SListI xs) => Record r -> NP I xs 243 | _fromRecord_NP = case sList :: SList xs of 244 | SNil -> const Nil 245 | SCons -> \ r -> case r of 246 | P x :* xs -> I x :* _fromRecord_NP xs 247 | 248 | -- | Fast version of 'fromRecord_NP'. Not actually unsafe as 249 | -- long as the internal representation of 'NP' and 'Record' 250 | -- are not changed. 251 | -- 252 | unsafeFromRecord_NP :: forall r xs . (ValidRecordCode r xs, SListI xs) => Record r -> NP I xs 253 | unsafeFromRecord_NP = unsafeCoerce 254 | 255 | -------------------------------------------------------------------------- 256 | -- Utilities 257 | -------------------------------------------------------------------------- 258 | 259 | -- | Projection of the second component of a type-level pair, 260 | -- wrapped in a newtype. 261 | -- 262 | newtype P (p :: (a, Type)) = P (Snd p) 263 | deriving (GHC.Generic) 264 | 265 | deriving instance Eq a => Eq (P '(l, a)) 266 | deriving instance Ord a => Ord (P '(l, a)) 267 | deriving instance Show a => Show (P '(l, a)) 268 | 269 | instance NFData a => NFData (P '(l, a)) where 270 | rnf (P x) = rnf x 271 | 272 | -- | Type-level variant of 'snd'. 273 | type family Snd (p :: (a, b)) :: b where 274 | Snd '(a, b) = b 275 | 276 | -- | Type-level variant of 'head'. 277 | type family Head (xs :: [k]) :: k where 278 | Head (x : xs) = x 279 | 280 | -- | Type-level variant of 'tail'. 281 | type family Tail (xs :: [k]) :: [k] where 282 | Tail (x : xs) = xs 283 | 284 | -- | Partial type-level function that extracts the only element 285 | -- from a singleton type-level list. 286 | -- 287 | type family GetSingleton (xs :: [k]) :: k where 288 | GetSingleton '[ x ] = x 289 | -------------------------------------------------------------------------------- /src/Generics/SOP/Record/SubTyping.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | #if MIN_VERSION_base(4,12,0) 12 | {-# LANGUAGE DataKinds #-} 13 | {-# LANGUAGE PolyKinds #-} 14 | #else 15 | {-# LANGUAGE TypeInType #-} 16 | #endif 17 | {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} 18 | module Generics.SOP.Record.SubTyping 19 | ( cast 20 | , IsSubTypeOf 21 | , IsElemOf 22 | , get 23 | , getField 24 | ) 25 | where 26 | 27 | import Data.Type.Equality 28 | import Generics.SOP.NP 29 | import GHC.Types 30 | 31 | import Generics.SOP.Record 32 | 33 | -- | Cast one record type to another if there is a subtype relationship 34 | -- between them. Currently, only width subtyping is considered, which means 35 | -- that we can forget and reorder fields. 36 | -- 37 | cast :: (IsRecord a ra, IsRecord b rb, IsSubTypeOf ra rb) => a -> b 38 | cast = fromRecord . castRecord . toRecord 39 | 40 | -- | Extract a record field based on the symbolic name of a field. 41 | -- Requires an explicit type application for the field name. 42 | -- 43 | getField :: forall s a b ra . (IsRecord a ra, IsElemOf s b ra) => a -> b 44 | getField = get @s . toRecord 45 | 46 | -- | Class that checks whether one record code is convertible into another. 47 | -- 48 | -- Conversion works if the first record contains at least the labels of the 49 | -- second record, and if the types of the corresponding fields match exactly. 50 | -- 51 | class IsSubTypeOf (r1 :: RecordCode) (r2 :: RecordCode) where 52 | -- | Perform a safe cast between two records. 53 | castRecord :: Record r1 -> Record r2 54 | 55 | instance IsSubTypeOf r1 '[] where 56 | castRecord _ = Nil 57 | 58 | instance (IsSubTypeOf r1 r2, IsElemOf s2 a2 r1) => IsSubTypeOf r1 ( '(s2, a2) : r2 ) where 59 | castRecord r = P (get @s2 r) :* castRecord r 60 | 61 | -- | Class that checks whether a field of a particular type is contained 62 | -- in a record. 63 | -- 64 | class IsElemOf (s :: Symbol) (a :: Type) (r :: RecordCode) where 65 | -- | Perform an extraction of a given field. Field name has to be passed 66 | -- via type application. 67 | -- 68 | get :: Record r -> a 69 | 70 | -- | Helper class. Isn't strictly needed, but allows us to avoid 71 | -- overlapping instances for the 'IsElemOf' class. 72 | -- 73 | class IsElemOf' (b :: Bool) 74 | (s1 :: FieldLabel) (a1 :: Type) 75 | (s2 :: FieldLabel) (a2 :: Type) 76 | (r :: RecordCode) 77 | where 78 | get' :: Record ( '(s2, a2) : r ) -> a1 79 | 80 | instance 81 | IsElemOf' (SameFieldLabel s1 s2) s1 a1 s2 a2 r => 82 | IsElemOf s1 a1 ( '(s2, a2) : r ) 83 | where 84 | get = get' @(SameFieldLabel s1 s2) @s1 85 | 86 | instance (a1 ~ a2) => IsElemOf' True s a1 s a2 r where 87 | get' (P a :* _) = a 88 | 89 | instance IsElemOf s1 a1 r => IsElemOf' False s1 a1 s2 a2 r where 90 | get' (_ :* r) = get @s1 r 91 | 92 | -- | Decide the equality of two field labels. 93 | -- 94 | -- Just a special case of polymorphic type equality. 95 | -- 96 | type family 97 | SameFieldLabel (s1 :: FieldLabel) (s2 :: FieldLabel) :: Bool where 98 | SameFieldLabel s1 s2 = s1 == s2 99 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-20.18 2 | packages: 3 | - '.' 4 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | sha256: 9fa4bece7acfac1fc7930c5d6e24606004b09e80aa0e52e9f68b148201008db9 10 | size: 649606 11 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/18.yaml 12 | original: lts-20.18 13 | -------------------------------------------------------------------------------- /tests/Examples.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | CPP 3 | , DataKinds 4 | , DeriveGeneric 5 | , DuplicateRecordFields 6 | , TypeApplications 7 | #-} 8 | {-# OPTIONS_GHC -fdefer-type-errors -Wno-deferred-type-errors #-} 9 | module Main where 10 | 11 | import Control.DeepSeq 12 | import qualified GHC.Generics as GHC 13 | import Test.Hspec 14 | import Test.ShouldNotTypecheck 15 | 16 | import Generics.SOP 17 | import Generics.SOP.Record.SubTyping 18 | 19 | data X = MkX {} 20 | deriving (Eq, Show, GHC.Generic) 21 | 22 | instance Generic X 23 | instance HasDatatypeInfo X 24 | instance NFData X 25 | 26 | data A = MkA { anInt :: Int, aBool :: Bool } 27 | deriving (Eq, Show, GHC.Generic) 28 | 29 | instance Generic A 30 | instance HasDatatypeInfo A 31 | instance NFData A 32 | 33 | data B = MkB { anInt :: Int, aBool :: Bool, aChar :: Char } 34 | deriving (Eq, Show, GHC.Generic) 35 | 36 | instance Generic B 37 | instance HasDatatypeInfo B 38 | instance NFData B 39 | 40 | -- Permutation. 41 | data C = MkC { aBool :: Bool, aChar :: Char, anInt :: Int } 42 | deriving (Eq, Show, GHC.Generic) 43 | 44 | instance Generic C 45 | instance HasDatatypeInfo C 46 | instance NFData C 47 | 48 | #if __GLASGOW_HASKELL__ < 902 49 | -- Duplicate label within a single record (works prior to ghc-9.2). 50 | data D = MkD { anInt :: Int, anInt :: Int } 51 | deriving (Eq, Show, GHC.Generic) 52 | 53 | instance Generic D 54 | instance HasDatatypeInfo D 55 | instance NFData D 56 | #endif 57 | 58 | -- Wrong type. 59 | data E = MkE { anInt :: Int, aBool :: Bool, aChar :: () } 60 | deriving (Eq, Show, GHC.Generic) 61 | 62 | instance Generic E 63 | instance HasDatatypeInfo E 64 | instance NFData E 65 | 66 | -- No field labels. 67 | data F = MkF Int Bool Char 68 | deriving (Eq, Show, GHC.Generic) 69 | 70 | instance Generic F 71 | instance HasDatatypeInfo F 72 | instance NFData F 73 | 74 | -- Two constructors. 75 | data G = MkG { anInt :: Int, aBool :: Bool, aChar :: Char } 76 | | OtherG 77 | deriving (Eq, Show, GHC.Generic) 78 | 79 | instance Generic G 80 | instance HasDatatypeInfo G 81 | instance NFData G 82 | 83 | a :: A 84 | a = MkA 3 True 85 | 86 | b :: B 87 | b = MkB 3 True 'x' 88 | 89 | c :: C 90 | c = MkC True 'x' 3 91 | 92 | #if __GLASGOW_HASKELL__ < 902 93 | d :: D 94 | d = MkD 3 3 95 | 96 | d' :: D 97 | d' = MkD 3 4 98 | #endif 99 | 100 | e :: E 101 | e = MkE 3 True () 102 | 103 | f :: F 104 | f = MkF 3 True 'x' 105 | 106 | g :: G 107 | g = MkG 3 True 'x' 108 | 109 | x :: X 110 | x = MkX {} 111 | 112 | main :: IO () 113 | main = hspec $ 114 | describe "cast" $ do 115 | it "successfully casts X to X" $ 116 | (cast x :: X) `shouldBe` x 117 | it "successfully casts A to A" $ 118 | (cast a :: A) `shouldBe` a 119 | it "successfully casts A to X" $ 120 | (cast a :: X) `shouldBe` x 121 | it "successfully casts B to B" $ 122 | (cast b :: B) `shouldBe` b 123 | it "successfully casts B to X" $ 124 | (cast b :: X) `shouldBe` x 125 | it "successfully casts B to A" $ 126 | (cast b :: A) `shouldBe` a 127 | it "successfully casts B to C" $ 128 | (cast b :: C) `shouldBe` c 129 | #if __GLASGOW_HASKELL__ < 902 130 | it "successfully casts A to D" $ 131 | (cast a :: D) `shouldBe` d 132 | it "successfully casts B to D" $ 133 | (cast b :: D) `shouldBe` d 134 | it "successfully casts C to D" $ 135 | (cast c :: D) `shouldBe` d 136 | it "successfully casts D to D" $ 137 | (cast d :: D) `shouldBe` d 138 | it "prefers the first element when casting D to D" $ 139 | (cast d' :: D) `shouldBe` d 140 | it "successfully casts E to D" $ 141 | (cast e :: D) `shouldBe` d 142 | it "successfully casts D to X" $ 143 | (cast d :: X) `shouldBe` x 144 | #endif 145 | it "successfully casts C to X" $ 146 | (cast c :: X) `shouldBe` x 147 | it "successfully casts C to A" $ 148 | (cast c :: A) `shouldBe` a 149 | it "successfully casts C to B" $ 150 | (cast c :: B) `shouldBe` b 151 | it "successfully casts E to E" $ 152 | (cast e :: E) `shouldBe` e 153 | it "successfully casts E to X" $ 154 | (cast e :: X) `shouldBe` x 155 | it "successfully casts E to A" $ 156 | (cast e :: A) `shouldBe` a 157 | it "correctly fails to cast A to B" $ 158 | shouldNotTypecheck (cast a :: B) 159 | it "correctly fails to cast A to C" $ 160 | shouldNotTypecheck (cast a :: C) 161 | #if __GLASGOW_HASKELL__ < 902 162 | it "correctly fails to cast D to A" $ 163 | shouldNotTypecheck (cast d :: A) 164 | it "correctly fails to cast D to B" $ 165 | shouldNotTypecheck (cast d :: B) 166 | it "correctly fails to cast D to C" $ 167 | shouldNotTypecheck (cast d :: C) 168 | #endif 169 | it "correctly fails to cast E to B" $ 170 | shouldNotTypecheck (cast e :: B) 171 | it "correctly fails to cast E to C" $ 172 | shouldNotTypecheck (cast e :: C) 173 | -- The following two produce type errors as expected. 174 | -- Unfortunately, user-defined type errors in combination 175 | -- with shouldNotTypeCheck seems to trigger an internal 176 | -- error ... (see GHC bug #12104) [fixed in 8.2] 177 | #if __GLASGOW_HASKELL__ >= 802 178 | it "fails to cast F to anything (even X)" $ 179 | shouldNotTypecheck (cast f :: X) 180 | it "fails to cast G to anything (even X)" $ 181 | shouldNotTypecheck (cast g :: X) 182 | #endif 183 | it "successfully extracts anInt from A" $ 184 | getField @"anInt" a `shouldBe` 3 185 | it "successfully extracts aBool from A" $ 186 | getField @"aBool" a `shouldBe` True 187 | it "correctly fails to extract aChar from A" $ 188 | shouldNotTypecheck (getField @"aChar" a) 189 | it "successfully extracts anInt from B" $ 190 | getField @"anInt" b `shouldBe` 3 191 | it "successfully extracts aBool from B" $ 192 | getField @"aBool" b `shouldBe` True 193 | it "successfully extracts aChar from B" $ 194 | getField @"aChar" b `shouldBe` 'x' 195 | it "successfully extracts anInt from C" $ 196 | getField @"anInt" c `shouldBe` 3 197 | it "successfully extracts aBool from C" $ 198 | getField @"aBool" c `shouldBe` True 199 | it "successfully extracts aChar from C" $ 200 | getField @"aChar" c `shouldBe` 'x' 201 | #if __GLASGOW_HASKELL__ < 902 202 | it "successfully extracts the first anInt from D" $ 203 | getField @"anInt" d' `shouldBe` 3 204 | #endif 205 | --------------------------------------------------------------------------------