├── .github └── workflows │ └── ci.yml ├── .gitignore ├── CHANGELOG.md ├── CONTRIBUTING.md ├── LICENSE ├── NOTICE ├── README.md ├── Setup.hs ├── benchmarks └── perf │ └── Main.hs ├── examples ├── Examples.lhs ├── OverridingTypeClassInstances.hs ├── OverridingTypeClassInstances.md ├── RowCSV.hs ├── RowCSV.md ├── TypeSurgery.lhs ├── TypeSurgery.md ├── TypedErrors.lhs └── TypedErrors.md ├── index.md ├── row-types.cabal ├── row-types.cabal.3 ├── src ├── Data │ ├── Row.hs │ └── Row │ │ ├── Dictionaries.hs │ │ ├── Internal.hs │ │ ├── Records.hs │ │ ├── Switch.hs │ │ └── Variants.hs ├── aeson │ └── Data │ │ └── Row │ │ └── Aeson.hs └── barbies │ └── Data │ └── Row │ └── Barbies.hs ├── stack.yaml ├── stack.yaml.lock └── tests ├── DiffPerformance.hs ├── Main.hs ├── MergePerformance.hs └── UnionPerformance.hs /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | # Trigger the workflow on push or pull request, but only for the master branch 4 | on: 5 | pull_request: 6 | push: 7 | branches: [master] 8 | 9 | jobs: 10 | cabal: 11 | runs-on: ${{ matrix.os }} 12 | strategy: 13 | matrix: 14 | ghc: ['8.6', '8.8', '8.10', 'latest'] 15 | # cabal: ['latest'] 16 | os: [ubuntu-latest, macOS-latest, windows-latest] 17 | exclude: 18 | - os: macOS-latest 19 | ghc: 8.8 20 | - os: macOS-latest 21 | ghc: 8.6 22 | - os: windows-latest 23 | ghc: 8.8 24 | - os: windows-latest 25 | ghc: 8.6 26 | name: ${{ matrix.os }} / ghc ${{ matrix.ghc }} 27 | steps: 28 | - uses: actions/checkout@v2 29 | - name: Setup Haskell 30 | uses: haskell/actions/setup@v1 31 | with: 32 | ghc-version: ${{ matrix.ghc }} 33 | # cabal-version: ${{ matrix.cabal }} -- Omitted, but defaults to 'latest' 34 | - name: Build 35 | run: | 36 | cabal configure --enable-tests --enable-benchmarks --test-show-details=direct 37 | cabal build all --disable-optimization 38 | - name: Test 39 | run: | 40 | cabal test all 41 | 42 | stack: 43 | name: stack 44 | runs-on: ubuntu-latest 45 | steps: 46 | - uses: actions/checkout@v2 47 | - uses: haskell/actions/setup@v1 48 | with: 49 | # ghc-version: 'latest'. Omitted, but defaults to 'latest' 50 | # cabal-version: 'latest'. Omitted, but defaults to 'latest' 51 | enable-stack: true 52 | # stack-version: 'latest'. Omitted, but defaults to 'latest' 53 | - name: Build 54 | run: | 55 | stack build --system-ghc --test --bench --fast --no-run-tests --no-run-benchmarks 56 | - name: Test 57 | run: | 58 | stack test --system-ghc 59 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # OS X nonsense 2 | .DS_Store 3 | 4 | # GHC compile artifacts 5 | *.o 6 | *.hi 7 | *.chi 8 | *.chs.h 9 | *.dyn_o 10 | *.dyn_hi 11 | 12 | # Build/sandbox files 13 | dist 14 | dist-newstyle 15 | cabal-dev 16 | .cabal-sandbox/ 17 | cabal.sandbox.config 18 | .hsenv 19 | .stack-work/ 20 | build/ 21 | .ghc* 22 | setup-config 23 | 24 | # Generated docs 25 | doc/html 26 | 27 | # Emacs autogenerated 28 | *~ 29 | \#* 30 | .#* 31 | TAGS 32 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## 1.0.1.2 [2021-09-10] 2 | - Update Stack to use GHC 8.10.7 3 | - Fix a few warnings 4 | - Minor updates to support GHC 9.0.1 5 | 6 | 7 | ## 1.0.1.1 [2021-09-09] 8 | - Improved type checking performance on Diff and Merge ([Thanks ak3n!](https://github.com/target/row-types/pull/77)) 9 | 10 | 11 | ## 1.0.1.0 [2021-05-06] 12 | - Fixed a critical bug in certain values in `Dictionaries` that could cause segfaults. 13 | - Reimplemented and simplified `Subset`. 14 | - Adjusted basic type families to better handle simple cases (affected families are `.\`, `Extend`, `.+`, `.\/`, `.//`). 15 | - Export `mapSingleA` in `Data.Row.Variants`. 16 | - Improved kind polymorphism and simplify a few constraints ([Thanks Strake!](https://github.com/target/row-types/pull/73)). 17 | - Improved type checking performance ([Thanks UlfNorell!](https://github.com/target/row-types/pull/71)) 18 | 19 | 20 | ## 1.0.0.0 [2020-09-12] 21 | This release has many breaking changes, specifically to `metamorph` and some functions related to `Variant`, hence the major version bump to `1.0`. However, users that only use basic features of records may not notice a difference. 22 | 23 | - Removed `metamorph'` and `biMetamorph'` in favor of generalizing `metamorph` over choice of bifunctor. 24 | - Removed "unsafe" functions (`unsafeRemove` and `unsafeInjectFront` from `Records` and `unsafeMarkVar` and `unsafeInjectFront` from `Variants`). 25 | - Removed `Switch` class, reimplementing the `switch` function using `BiForall`. 26 | - Swap the order of the result of calling `trial`, `multiTrial`, and `split`. 27 | - Added new functions to `Records`: `lazyRemove`, `curryRec`, `(.$)`, `zipTransform`, `zipTransform'`, `traverse`, `traverseMap`, `distribute`, and `coerceRec`. 28 | - Added new functions to `Variants`: `fromLabelsMap`, `traverse`, `traverseMap`, and `coerceVar`. 29 | - Added `Dictionaries` module, full of axioms that are helpful for using `metamorph`. Moved axioms from `Internal` to `Dictionaries` (in some cases, the type variable order has changed). 30 | - Added `ApSingle` type family as well as `eraseSingle`, `mapSingle`, and `eraseZipSingle` (thanks Jordan Woehr!). 31 | - Improved error messages. 32 | 33 | Note: GHC 8.4 and earlier are no longer officially supported in row-types 1.0.0.0. 34 | 35 | 36 | ## 0.4.0.0 [2020-05-20] 37 | - Renamed `toNative` to `toNativeGeneral` and `toNativeExact` to `toNative` for records and likewise for `fromNative` for variants. 38 | - Added a type family `NativeRow` which, when given any generic type that can go through `fromNative`, is equal to the row-type of the resulting record/variant. Note that `NativeRow` is defined separately (and differently!) for records vs variants, so it is exported at the `Data.Row.Records`/`Variants` level but not at `Data.Row`. 39 | - Added `coerceRec` and `coerceVar` to coerce the row-types of records and variants respectively. 40 | - Exposed `BiForall` in `Data.Row`, `Data.Row.Records`, and `Data.Row.Variants` 41 | - (Internal) Rewrote internal `Generic` code to use an associated type family instead of a standalone one. 42 | 43 | Note: GHC 8.2 and earlier are no longer officially supported in row-types 0.4.0.0. 44 | 45 | ## 0.3.1.0 [2020-01-29] 46 | - Added "native" classes as exports for `Records` and `Variants` (e.g., `ToNative`, `FromNative`) 47 | - Added more example hs files. 48 | 49 | ## 0.3.0.0 [2019-05-28] 50 | - Added `HasField` and `AsConstructor` instances (from generic-lens) for `Rec` and `Var` respectively. 51 | - Added record-overwrite function `.//`. 52 | - Added `Generic` instances for Rec and Var. 53 | - Added mapHas entailment connecting `Map f r .! l` to `r .! l`. 54 | - Changed `Forall2` to `BiForall`. 55 | - Added `BiConstraint` type class for use with `BiForall`. 56 | - Added `Ap` type family that functions as `ap` over rows using zipping. 57 | - Added `mapF` to map a function over a record with an `Ap` row. 58 | - Added `toDynamicMap` and `fromDynamicMap` as functions to convert between `Rec`s and `HashMap Text Dynamic`s. 59 | - Added `toNativeExact` to convert a `Rec` to a native Haskell type without losing any fields. 60 | - Added `toNative`, `fromNative`, and `fromNativeExact` for `Var`s. 61 | - Added `unSingleton` for `Var`s. 62 | - Removed `unSingleton` from `Data.Row` export list. 63 | - Tightened the type signatures of `focus` (for both `Rec` and `Var`) to improve type inference when using `focus` in lens-like situations. 64 | 65 | ## 0.2.3.1 [2018-07-11] 66 | - Fix a bug in the `Show` instance for `Rec`. 67 | 68 | ## 0.2.3.0 [2018-07-02] 69 | - Update the `Show` instance for `Rec` to render valid code. 70 | - Add `toNative` and `fromNative` functions for records to easily convert between Haskell records and row-types records. 71 | - Make type families in `Data.Row.Internal` polykinded ([Thanks James Yu!](https://github.com/target/row-types/pull/20)) 72 | 73 | ## 0.2.1.0 [2018-03-20] 74 | - Bug Fix: The type of `update` for both `Rec` and `Var` now enforce the newly inserted type is correct. 75 | - New: Add `restrict` and `split` for `Var`s. 76 | - Removed `restrict` from `Data.Row` export list. 77 | - New: Added support for universally quantified rows: `mapForall` and `uniqueMap`. 78 | - Added very simple test suite. 79 | 80 | ## 0.2.0.0 [2018-02-12] 81 | - Initial Release 82 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing to reuse 2 | 3 | ### Issues 4 | 5 | Feel free to submit bugs or feature requests as issues. 6 | 7 | ### Pull Requests 8 | 9 | These rules must be followed for any contributions to be merged into master. 10 | 11 | 1. Fork this repo 12 | 2. Make any desired changes 13 | 3. Validate that your changes meet your desired use case 14 | 4. Ensure documentation has been updated 15 | 5. Open a pull request 16 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017 Target Brands, Inc. 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 4 | 5 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 8 | -------------------------------------------------------------------------------- /NOTICE: -------------------------------------------------------------------------------- 1 | This software package includes open source components, each of which is subject to its respective license as listed below: 2 | 3 | ------------------------------------------------------------------------------- 4 | - CTRex (commit 5cf771e3c6650351b2aad08d5bd8e94a87ec326d) https://github.com/atzeus/CTRex/blob/master/LICENSE 5 | 6 | Copyright (c) 2015, Atze van der Ploeg 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 10 | 11 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 12 | 13 | 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 14 | 15 | 3. Neither the name of the Atze van der Ploeg nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 16 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Row-Types 2 | ======= 3 | 4 | [![Build Status](https://github.com/target/row-types/actions/workflows/.github/workflows/ci.yml/badge.svg)](https://github.com/target/row-types/) 5 | [![Hackage](https://img.shields.io/hackage/v/row-types.svg)](https://hackage.haskell.org/package/row-types) 6 | 7 | Row-types is a library of open records and variants for Haskell using closed 8 | type families and type literals (among other things...). 9 | See [examples/Examples.lhs](https://raw.githubusercontent.com/target/row-types/master/examples/Examples.lhs) 10 | for a literate Haskell file that functions as an overview of how this library can be used, 11 | and check out [the website](https://target.github.io/row-types/) for further examples. 12 | 13 | Available on [Hackage](https://hackage.haskell.org/package/row-types). 14 | 15 | This work is a branch from CTRex [1,2] with other inspiration from data-diverse [3]. 16 | My thanks to the authors and contributors of those libraries! 17 | 18 | 19 | [1] https://wiki.haskell.org/CTRex \ 20 | [2] https://hackage.haskell.org/package/CTRex/docs/Data-OpenRecords.html \ 21 | [3] https://hackage.haskell.org/package/data-diverse 22 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /benchmarks/perf/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Gauge.Main 4 | 5 | import Data.String 6 | 7 | import Data.Row.Records 8 | 9 | type FourRecord a = 10 | "i0" .== a .+ "i1" .== a .+ "i2" .== a .+ "i3" .== a 11 | 12 | type ElevenRecord a = 13 | "i0" .== a .+ "i1" .== a .+ "i2" .== a .+ "i3" .== a 14 | .+ "i10" .== a .+ "i11" .== a .+ "i12" .== a .+ "i13" .== a 15 | .+ "i20" .== a .+ "i21" .== a .+ "i22" .== a 16 | 17 | type SixteenRecord a = 18 | "i0" .== a .+ "i1" .== a .+ "i2" .== a .+ "i3" .== a 19 | .+ "i10" .== a .+ "i11" .== a .+ "i12" .== a .+ "i13" .== a 20 | .+ "i20" .== a .+ "i21" .== a .+ "i22" .== a .+ "i23" .== a 21 | .+ "i30" .== a .+ "i31" .== a .+ "i32" .== a .+ "i33" .== a 22 | 23 | -- type SixtyFourRecord a = 24 | -- "i0" .== a .+ "i1" .== a .+ "i2" .== a .+ "i3" .== a 25 | -- .+ "i10" .== a .+ "i11" .== a .+ "i12" .== a .+ "i13" .== a 26 | -- .+ "i20" .== a .+ "i21" .== a .+ "i22" .== a .+ "i23" .== a 27 | -- .+ "i30" .== a .+ "i31" .== a .+ "i32" .== a .+ "i33" .== a 28 | -- .+ "i100" .== a .+ "i101" .== a .+ "i102" .== a .+ "i103" .== a 29 | -- .+ "i110" .== a .+ "i111" .== a .+ "i112" .== a .+ "i113" .== a 30 | -- .+ "i120" .== a .+ "i121" .== a .+ "i122" .== a .+ "i123" .== a 31 | -- .+ "i130" .== a .+ "i131" .== a .+ "i132" .== a .+ "i133" .== a 32 | -- .+ "i200" .== a .+ "i201" .== a .+ "i202" .== a .+ "i203" .== a 33 | -- .+ "i210" .== a .+ "i211" .== a .+ "i212" .== a .+ "i213" .== a 34 | -- .+ "i220" .== a .+ "i221" .== a .+ "i222" .== a .+ "i223" .== a 35 | -- .+ "i230" .== a .+ "i231" .== a .+ "i232" .== a .+ "i233" .== a 36 | -- .+ "i300" .== a .+ "i301" .== a .+ "i302" .== a .+ "i303" .== a 37 | -- .+ "i310" .== a .+ "i311" .== a .+ "i312" .== a .+ "i313" .== a 38 | -- .+ "i320" .== a .+ "i321" .== a .+ "i322" .== a .+ "i323" .== a 39 | -- .+ "i330" .== a .+ "i331" .== a .+ "i332" .== a .+ "i333" .== a 40 | 41 | -- my64Record :: Rec (SixtyFourRecord Double) 42 | -- my64Record = 43 | -- #i0 .== 0 .+ #i1 .== 0 .+ #i2 .== 0 .+ #i3 .== 0 44 | -- .+ #i10 .== 0 .+ #i11 .== 0 .+ #i12 .== 0 .+ #i13 .== 0 45 | -- .+ #i20 .== 0 .+ #i21 .== 0 .+ #i22 .== 0 .+ #i23 .== 0 46 | -- .+ #i30 .== 0 .+ #i31 .== 0 .+ #i32 .== 0 .+ #i33 .== 0 47 | -- .+ #i100 .== 0 .+ #i101 .== 0 .+ #i102 .== 0 .+ #i103 .== 0 48 | -- .+ #i110 .== 0 .+ #i111 .== 0 .+ #i112 .== 0 .+ #i113 .== 0 49 | -- .+ #i120 .== 0 .+ #i121 .== 0 .+ #i122 .== 0 .+ #i123 .== 0 50 | -- .+ #i130 .== 0 .+ #i131 .== 0 .+ #i132 .== 0 .+ #i133 .== 0 51 | -- .+ #i200 .== 0 .+ #i201 .== 0 .+ #i202 .== 0 .+ #i203 .== 0 52 | -- .+ #i210 .== 0 .+ #i211 .== 0 .+ #i212 .== 0 .+ #i213 .== 0 53 | -- .+ #i220 .== 0 .+ #i221 .== 0 .+ #i222 .== 0 .+ #i223 .== 0 54 | -- .+ #i230 .== 0 .+ #i231 .== 0 .+ #i232 .== 0 .+ #i233 .== 0 55 | -- .+ #i300 .== 0 .+ #i301 .== 0 .+ #i302 .== 0 .+ #i303 .== 0 56 | -- .+ #i310 .== 0 .+ #i311 .== 0 .+ #i312 .== 0 .+ #i313 .== 0 57 | -- .+ #i320 .== 0 .+ #i321 .== 0 .+ #i322 .== 0 .+ #i323 .== 0 58 | -- .+ #i330 .== 0 .+ #i331 .== 0 .+ #i332 .== 0 .+ #i333 .== 0 59 | 60 | main :: IO () 61 | main = 62 | defaultMain 63 | [ bgroup "Record Construction" 64 | [ bench "simple 1" $ nf (#a .==) () 65 | , bench "simple 4" $ nf id $ #a .== () .+ #b .== () .+ #c .== () .+ #d .== () 66 | , bench "reverse 4" $ nf id $ #d .== () .+ #c .== () .+ #b .== () .+ #a .== () 67 | , bench "default 4" $ nf id $ default' @Num @(FourRecord Double) 0 68 | , bench "recordFromLabels 4" $ nf id $ fromLabels @IsString @(FourRecord String) (fromString . show) 69 | , bench "default 11" $ nf id $ default' @Num @(ElevenRecord Double) 0 70 | , bench "recordFromLabels 11" $ nf id $ fromLabels @IsString @(ElevenRecord String) (fromString . show) 71 | , bench "default 16" $ nf id $ default' @Num @(SixteenRecord Double) 0 72 | , bench "recordFromLabels 16" $ nf id $ fromLabels @IsString @(SixteenRecord String) (fromString . show) 73 | -- , bench "simple 64" $ nf id $ my64Record 74 | -- , bench "default 64" $ nf id $ default' @Num @(SixtyFourRecord Double) 0 75 | -- , bench "recordFromLabels 64" $ nf id $ fromLabels @IsString @(SixtyFourRecord String) (fromString . show) 76 | ] 77 | , bgroup "Record Append" 78 | [ bench "append 3 3" $ nf (uncurry (.+)) (#a .== () .+ #b .== () .+ #c .== (), #d .== () .+ #e .== () .+ #f .== ()) 79 | , bench "append 5 1" $ nf (uncurry (.+)) (#a .== () .+ #b .== () .+ #c .== () .+ #d .== () .+ #e .== (), #f .== ()) 80 | , bench "append 1 5" $ nf (uncurry (.+)) (#a .== (), #b .== () .+ #c .== () .+ #d .== () .+ #e .== () .+ #f .== ()) 81 | ] 82 | , bgroup "Record Access" 83 | [ bench "get 2 of 4" $ nf (.! #i1) $ default' @Num @(FourRecord Double) 0 84 | , bench "get 7 of 11" $ nf (.! #i1) $ default' @Num @(ElevenRecord Double) 0 85 | , bench "get 4 of 16" $ nf (.! #i10) $ default' @Num @(SixteenRecord Double) 0 86 | , bench "get 16 of 16" $ nf (.! #i33) $ default' @Num @(SixteenRecord Double) 0 87 | -- , bench "get 4 of 64" $ nf (.! #i10) $ default' @Num @(SixtyFourRecord Double) 1 88 | -- , bench "get 45 of 64" $ nf (.! #i230) $ default' @Num @(SixtyFourRecord Double) 2 89 | -- , bench "get 63 of 64" $ nf (.! #i332) $ default' @Num @(SixtyFourRecord Double) 3 90 | ] 91 | , bgroup "Record Metamorphosis" 92 | [ bench "erase 4" $ nf (erase @Show show) $ #a .== () .+ #b .== () .+ #c .== () .+ #d .== () 93 | -- , bench "erase 64" $ nf (erase @Show show) $ my64Record 94 | ] 95 | ] 96 | -------------------------------------------------------------------------------- /examples/Examples.lhs: -------------------------------------------------------------------------------- 1 | > {-# LANGUAGE AllowAmbiguousTypes #-} 2 | > {-# LANGUAGE DataKinds #-} 3 | > {-# LANGUAGE DeriveGeneric #-} 4 | > {-# LANGUAGE FlexibleContexts #-} 5 | > {-# LANGUAGE OverloadedLabels #-} 6 | > {-# LANGUAGE PartialTypeSignatures #-} 7 | > {-# LANGUAGE ScopedTypeVariables #-} 8 | > {-# LANGUAGE TypeOperators #-} 9 | > {-# LANGUAGE ViewPatterns #-} 10 | > module Examples where 11 | > 12 | > import Data.Row 13 | > import qualified Data.Row.Records as Rec 14 | > import qualified Data.Row.Variants as Var 15 | 16 | In this example file, we will explore how to create and use records and variants. 17 | 18 | -------------------------------------------------------------------------------- 19 | LABELS 20 | -------------------------------------------------------------------------------- 21 | 22 | To begin, we will briefly discuss creating labels -- their use will follow. 23 | 24 | The most basic way to create a label is through construction with a type signature: 25 | 26 | x = Label :: Label "x" 27 | 28 | With the above definition, x is a label for the field x. Using type applications, 29 | this can be shortened to: 30 | 31 | x = Label @"x" 32 | 33 | And with OverloadedLabels, one can just write: 34 | 35 | #x 36 | 37 | We will use the OverloadedLabels notation in these examples. 38 | 39 | -------------------------------------------------------------------------------- 40 | LENS 41 | -------------------------------------------------------------------------------- 42 | 43 | Records and variants play nicely with the lens library if we additionally import 44 | Data.Generics.Labels from the generic-lens library. Each overloaded 45 | label is also a Lens for a record and a prism for variants. Thus, .! can be 46 | replaced with ^. and trial' can be made infix with ^?. Additionally, update 47 | can be made infix: 48 | 49 | update #x v r === r & #x .~ v 50 | 51 | And because of the power of lens, it's easy to make modifications rather than 52 | just update: 53 | 54 | update #x (f (r .! #x)) r === r & #x %~ f 55 | 56 | Lens is not included with row-types by default, but using it can make row-types 57 | much friendlier. For this example module, we'll include a couple of handy lens 58 | operations: 59 | 60 | > import Data.Generics.Labels () 61 | > import Data.Generics.Internal.VL.Lens 62 | > 63 | > infixl 6 & 64 | > (&) :: a -> (a -> b) -> b 65 | > (&) = flip ($) 66 | > (%~) = over 67 | 68 | -------------------------------------------------------------------------------- 69 | RECORDS 70 | -------------------------------------------------------------------------------- 71 | 72 | With some labels defined, let's begin with records. To start, let's create a 73 | record representing the Cartesian coordinates of the origin. To do this, 74 | we use the .== operator to initialize values in a record, and we separate each 75 | initialized value with the .+ operator.Notice that the value level code uses the 76 | same operators as the type level code. 77 | 78 | > origin :: Rec ("x" .== Double .+ "y" .== Double ) 79 | > origin = #x .== 0 .+ #y .== 0 80 | 81 | Note that, although we wrote the type explicitly, GHC has no problem inferring 82 | it exactly. 83 | 84 | If we show this at the repl, we see: 85 | λ> origin 86 | #x .== 0.0 .+ #y .== 0.0 87 | 88 | Of course, as an extensible record, the order that we build it shouldn't matter, 89 | and indeed, it doesn't. Consider the following variation: 90 | 91 | > origin' :: Rec ("y" .== Double .+ "x" .== Double) 92 | > origin' = #y .== 0 .+ #x .== 0 93 | 94 | If we show this at the repl, we see: 95 | 96 | λ> origin' 97 | #x .== 0.0 .+ #y .== 0.0 98 | 99 | Indeed, the two values are indistinguishable: 100 | 101 | λ> origin == origin' 102 | True 103 | 104 | Now, let's expand upon our record. Why stop at two dimensions when we can make 105 | a record in three dimensions. 106 | 107 | > origin3D = #z .== 0.0 .+ origin 108 | 109 | Once again, the type is inferred for us, and the record is exactly as expected. 110 | 111 | In fact, we can do this generally. The following function takes a name and a 112 | record and adds the "name" field to that record with the given name. 113 | 114 | > named :: a -> Rec r -> Rec ("name" .== a .+ r) 115 | > named s r = #name .== s .+ r 116 | 117 | Note that we require that the record we are naming must not have a "name" field 118 | already. Overlapping labels within a single record/variant is strictly forbidden. 119 | 120 | Let's say we want to get the values out of the record. Simple selection is achieved 121 | with the .! operator, like so: 122 | 123 | λ> origin .! #x 124 | 0.0 125 | 126 | and we can use this to write whatever we want. Here is a function for calculating 127 | Euclidean distance from the origin to a point: 128 | 129 | > distance :: (Floating t, r .! "y" ≈ t, r .! "x" ≈ t) => Rec r -> t 130 | > distance p = sqrt $ p .! #x * p .! #x + p .! #y * p .! #y 131 | 132 | Once again, the type of distance is entirely inferrable, but we write it here for 133 | convenience. This works exactly as expected: 134 | 135 | λ> distance origin 136 | 0.0 137 | λ> distance origin3D 138 | 0.0 139 | λ> distance (named "2D" origin) 140 | 0.0 141 | 142 | Of course, that wasn't very interesting when our only points are at the origin 143 | already. We could make new records representing new points, but instead, let's 144 | write a function to move the points we have: 145 | 146 | > move :: (Num (r .! "x"), Num (r .! "y")) 147 | > => Rec r -> r .! "x" -> r .! "y" -> Rec r 148 | > move p dx dy = Rec.update #x (p .! #x + dx) $ 149 | > Rec.update #y (p .! #y + dy) p 150 | 151 | Here, we're using the Rec.update operator to update the value at the label x by 152 | adding dx to it, and then we do the same for y. 153 | We can see it work in practice: 154 | 155 | λ> move origin 3 4 156 | #x .== 3.0 .+ #y .== 4.0 157 | λ> distance (move origin 3 4) 158 | 5.0 159 | λ> distance (move (named "2D" origin3D) 5 12) 160 | 13.0 161 | 162 | Or, with lenses, we could write move as: 163 | 164 | > moveLensy p dx dy = p & #x %~ (+ dx) & #y %~ (+ dy) 165 | 166 | So far, we created an origin point in 2d and then one in 3d, but what if we are 167 | adventurous mathematicians who want to have points in a space with some arbitrary 168 | number of dimensions. We could write out each of the 0s necessary, but there's 169 | an easier way to initialize a record: 170 | 171 | > origin4 :: Rec ("x" .== Double .+ "y" .== Double .+ "z" .== Double .+ "w" .== Double) 172 | > origin4 = Rec.default' @Num 0 173 | 174 | Finally, we have come to a case where GHC cannot infer the type signature, and how 175 | could it! The type is providing crucial information about the shape of the record. 176 | Regardless, with the type provided, it works exactly as expected: 177 | 178 | λ> origin4 179 | #w .== 0.0 .+ #x .== 0.0 .+ #y .== 0.0 .+ #z .== 0.0 180 | 181 | While we have added names or further fields, we can also choose to forget 182 | information in a record. To remove a particular label, one can use the .- 183 | operator, like so: 184 | 185 | > unName :: HasType "name" a r => Rec r -> Rec (r .- "name") 186 | > unName r = r .- #name 187 | 188 | For larger changes, it is easier to use the restrict function. The following 189 | function will take a record that contains both an x and y coordinate and remove 190 | the rest of the fields from it. 191 | 192 | > get2D :: (r ≈ "x" .== Double .+ "y" .== Double, Disjoint r rest) 193 | > => Rec (r .+ rest) 194 | > -> Rec r 195 | > get2D r = Rec.restrict r 196 | 197 | GHC is a little finicky about the type operators and constraints -- indeed, some 198 | slight modifications to the signature can easily cause type checking to fail. 199 | However, a type signature is not necessary when 200 | using type applications, and the function can instead be written as: 201 | 202 | > get2D' r = Rec.restrict @("x" .== Double .+ "y" .== Double) r 203 | 204 | with no trouble. Yet another altnerative is to match directly on the values desired 205 | using the :== and :+ record patterns: 206 | 207 | > get2D'' :: (r ≈ "x" .== Double .+ "y" .== Double, Disjoint r rest) 208 | > => Rec (r .+ rest) 209 | > -> Rec r 210 | > get2D'' ((Label :: Label "x") :== n1 :+ (Label :: Label "y") :== n2 :+ _) 211 | > = #x .== n1 .+ #y .== n2 212 | 213 | (Note that overloaded labels cannot be used in the patterns, so the notation is 214 | unfortunately bloated by types. Also, the type operators are left associated, 215 | so the "_" must go on the right, and the type signature is unforunately necessary.) 216 | 217 | All three of the get2D functions behave the same. 218 | 219 | -------------------------------------------------------------------------------- 220 | VARIANTS 221 | -------------------------------------------------------------------------------- 222 | Let's move on from records to variants. In many ways, variants are quite similar, 223 | as might be expected given that variants are dual to records. The types look 224 | almost the same, and some of the operators are shared as well. However, 225 | construction and destruction are obviously different. 226 | 227 | Creating a variant can be done with IsJust: 228 | 229 | > v,v' :: Var ("y" .== String .+ "x" .== Integer) 230 | > v = IsJust #x 1 231 | > v' = IsJust #y "Foo" 232 | 233 | Here, the type is necessary to specify what concrete type the variant is (when 234 | using AllowAmbiguousTypes, the type is not always needed, but it would be needed 235 | to e.g. show the variant). In the simple case of a variant of just one type, 236 | the simpler singleton function can be used: 237 | 238 | > v2 = Var.singleton #x 1 239 | 240 | Now, the type can be easily derived by GHC. We can show variants as easily as 241 | records: 242 | 243 | λ> v 244 | {x=1} 245 | λ> v' 246 | {y="Foo"} 247 | λ> v2 248 | {x=1} 249 | 250 | Once created, a variant can be expanded by using type applications and the 251 | diversify function. 252 | 253 | > v3 = diversify @("y" .== String) v2 254 | > v4 = diversify @("y" .== String .+ "z" .== Double) v2 255 | 256 | λ> :t v4 257 | v4 :: Var ('R '["x" ':-> Integer, "y" ':-> String, "z" ':-> Double]) 258 | λ> v == v3 259 | True 260 | 261 | The diversify function makes use of the .\/ type class, pronounced min-join. 262 | The min-join of two row-types is the minimum row-type that contains all the 263 | bindings of the two constituent ones. This allows use to write a function to 264 | join two lists of variants: 265 | 266 | > joinVarLists :: forall x y. (WellBehaved (x .\/ y), x .\/ y ≈ y .\/ x) 267 | > => [Var x] -> [Var y] -> [Var (x .\/ y)] 268 | > joinVarLists xs ys = map (diversify @y) xs ++ map (diversify @x) ys 269 | 270 | Unfortunately, GHC cannot deduce that the min-join of x and y is the same as the 271 | min-join of y and x, so we must add that to the constraints. However, any concrete 272 | types x and y that we construct will have this property, so it is easy to dispatch 273 | when we go to use this function. 274 | 275 | Taking a step back, it's worth looking closer at the equality tests we did earlier 276 | on variants. Indeed, one may ask how equality works on variants at all. 277 | For instance, v2 and v3 both look the same when you show them, and they 278 | both have the same value inside, but can we test them for equality? Indeed, we can't, 279 | precisely because their types are different: it is a type error to even try to 280 | check whether they're equal: 281 | 282 | λ> v2 == v3 283 | error: 284 | • Couldn't match type ‘'["y" ':-> [Char]]’ with ‘'[]’ 285 | Expected type: Var ('R '["x" ':-> Integer]) 286 | Actual type: Var ('R '["x" ':-> Integer] .+ ("y" .== String)) 287 | • In the second argument of ‘(==)’, namely ‘v3’ 288 | In the expression: v2 == v3 289 | In an equation for ‘it’: it = v2 == v3 290 | 291 | This may look a little scary, but it's actually a pretty useful message. Essentially, 292 | it's expecting a variant that can only be an Integer at label "x", but it found one 293 | that could also be a String at label "y". So, comparing v2 and v3 is not allowed, 294 | but since v3 now has the same labels as v1, that comparison is fine: 295 | 296 | λ> v == v3 297 | True 298 | λ> v == IsJust #x 3 299 | False 300 | λ> v == v' 301 | False 302 | λ> v == IsJust #y "fail" 303 | False 304 | 305 | (Also note here that using IsJust without a type signature is fine because the correct 306 | type can be easily inferred due to v's type.) 307 | 308 | What can you do with a variant? The only way to really use one is to get the value 309 | out, and to do that, you must trial it: 310 | 311 | λ> trial v #x 312 | Right 1 313 | λ> trial v #y 314 | Left {x=1} 315 | λ> trial v' #x 316 | Left {y="Foo"} 317 | λ> trial v' #y 318 | Right "Foo" 319 | 320 | If trialing at a label l succeeds, then it provides a Right value of the value at l. 321 | If not, it provides a Left value of the variant with this label removed---since the 322 | trial failed, we now can be sure that the value is not from l. 323 | 324 | -------------------------------------------------------------------------------- 325 | Note on lenses: 326 | The generic-lens library distinguishes labels that are meant to be lens from labels 327 | meant to be prisms by whether the front of the label is an underscore followed by 328 | an uppercase letter. This makes a lot of sense for data constructors, which is what 329 | generic-lens's prisms were designed for, but it's a little restrictive for variants. 330 | The result is that we can only use the lensy notation if the labels in our variants 331 | are uppercase. Consider the following: 332 | 333 | > vUpper :: Var ("Y" .== String .+ "X" .== Integer) 334 | > vUpper = IsJust (Label @"X") 1 335 | 336 | λ> v ^? #_X 337 | Left 1 338 | 339 | The row-types library does not generally assert that variants need labels that 340 | start with uppercase letters while records need labels that start with lowercase 341 | letters---in fact, the `switch` function described below will only work if the 342 | labels in a record and variant are exactly the same---but GHC is limited in that 343 | the # syntax only works for lowercase labels. Therefore, to make uppercase labels 344 | like in the `vUpper` example above, one must use the syntax `Label @"X"` instead 345 | of simply `#X`. See the proposal in https://github.com/ghc-proposals/ghc-proposals/pull/170 346 | for more information. 347 | -------------------------------------------------------------------------------- 348 | 349 | For ease of use in view patterns, Variants also exposes the view function. 350 | (If using lens, this can be replaced with preview.) With it, we can write a 351 | function like this: 352 | 353 | > myShow :: (r .! "y" ≈ String, Show (r .! "x")) => Var r -> String 354 | > myShow (Var.view #x -> Just n) = "Showable of "++show n 355 | > myShow (Var.view #y -> Just s) = "String of "++s 356 | > myShow _ = "Unknown" 357 | 358 | λ> myShow v 359 | "Showable of 1" 360 | λ> myShow v' 361 | "String of Foo" 362 | λ> myShow (just #z 3 :: Var ("y" .== String .+ "x" .== Integer .+ "z" .== Double)) 363 | "Unknown" 364 | 365 | This can also be achieved with the IsJust pattern synonym in much the same way: 366 | 367 | > myShow' :: (WellBehaved r, r .! "y" ≈ String, Show (r .! "x")) => Var r -> String 368 | > myShow' (IsJust (Label :: Label "x") n) = "Showable of "++show n 369 | > myShow' (IsJust (Label :: Label "y") s) = "String of "++s 370 | > myShow' _ = "Unknown" 371 | 372 | In either case, the type signature is once again totally derivable. 373 | 374 | There are three minor annoyances with this. First, it's annoying to have to write 375 | out the Label types in the pattern. This is actually a requested issue on GHC 376 | (see https://gitlab.haskell.org/ghc/ghc/issues/13116 and 377 | https://github.com/ghc-proposals/ghc-proposals/pull/80 for more information). 378 | Second, it's fairly common to want to define 379 | a function like myShow to be exhaustive in the variant's cases, but to do this, 380 | you must manually provide a type signature: 381 | 382 | > myShowRestricted :: Var ("y" .== String .+ "x" .== Integer) -> String 383 | > myShowRestricted (Var.view #x -> Just n) = "Integer of "++show n 384 | > myShowRestricted (Var.view #y -> Just s) = "String of "++s 385 | > myShowRestricted _ = error "Unreachable" 386 | 387 | The final blemish can be seen in this restricted version of myShow. Even though 388 | we know from the type that we've covered all the posibilities of the variant, GHC 389 | will generate a "non-exhaustive pattern match" warning without the final line. 390 | (This is true for the pattern synonym version too.) 391 | 392 | One way to avoid this problem is to use switch. The switch operator takes a variant 393 | and a record such that for each label that the variant has, the record has a function 394 | at that label that consumes the value the variant has and produces a value in a 395 | common type. Essentially, switch "applies" the variant to the record to produce 396 | an output value. 397 | 398 | > --myShowRestricted' :: Var ("y" .== String .+ "x" .== Integer) -> String 399 | > myShowRestricted' v = switch v $ 400 | > #x .== (\n -> "Integer of "++show n) 401 | > .+ #y .== (\s -> "String of "++s) 402 | 403 | This version of myShow needs neither a type signature (it is inferred exactly) nor 404 | a default "unreachable" case. However, we no longer have the benefit of Haskell's 405 | standard pattern matching. 406 | 407 | 408 | A more powerful version of trial is multiTrial, which tests for multiple labels 409 | at once. With this, you can wholesale change the type of the variant to any (valid) 410 | variant type you would like. Of course, there needs to be a recourse if the variant 411 | you provide is not expressible in the type you want, so multiTrial returns an Either 412 | of the type you want or a Variant of the leftovers. Consider the examples: 413 | 414 | λ> :t multiTrial @("x" .== Double .+ "y" .== String) v 415 | multiTrial @("x" .== Double .+ "y" .== String) v 416 | :: Either 417 | (Var ('R '["x" ':-> Integer])) 418 | (Var ('R '["x" ':-> Double, "y" ':-> String])) 419 | λ> multiTrial @("x" .== Double .+ "y" .== String) v 420 | Left {x=1} 421 | 422 | λ> :t multiTrial @("x" .== Double .+ "y" .== String) v' 423 | multiTrial @("x" .== Double .+ "y" .== String) v' 424 | :: Either 425 | (Var ('R '["x" ':-> Integer])) 426 | (Var ('R '["x" ':-> Double, "y" ':-> String])) 427 | λ> multiTrial @("x" .== Double .+ "y" .== String) v' 428 | Right {y="Foo"} 429 | 430 | Thus, multiTrial can be used not only to arbitrarily split apart a variant, but 431 | also to change unused label associations (in this case, we changed the variant 432 | from one where "x" is an Integer to one where it's a Double). We can even use 433 | it to combine dispatching of two different variants at once: 434 | 435 | > also :: Disjoint xs ys 436 | > => (Var xs -> a) 437 | > -> (Var ys -> a) 438 | > -> Var (xs .+ ys) -> a 439 | > also f1 f2 e = case multiTrial e of 440 | > Left e' -> f1 e' 441 | > Right e' -> f2 e' 442 | 443 | The above also function takes two functions f1 and f2 that can each independently 444 | be used on variants with rows xs and ys respectively. Using multiTrial, we can 445 | split the input variant (which is the join of xs and ys) and easily apply f1 or 446 | f2 as appropriate. 447 | -------------------------------------------------------------------------------- /examples/OverridingTypeClassInstances.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingStrategies #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE OverloadedLabels #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE Rank2Types #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | module OverridingTypeClassInstances where 11 | 12 | -- Note that `Data.Row.Aeson` is not exported my the row-types library and 13 | -- currently lives in the src\aeson directory. You must put it in an 14 | -- appropriate place and make sure to have `aeson` in your environment in order 15 | -- to use this module. 16 | 17 | import Data.Aeson (ToJSON(..), encode) 18 | import Data.Coerce 19 | import Data.Row 20 | import Data.Row.Aeson () 21 | import qualified Data.Row.Records as Rec 22 | import Data.Text (Text) 23 | import qualified Data.Text as Text 24 | import GHC.Generics (Generic) 25 | 26 | 27 | newtype CharArray = CharArray { unCharArray :: String } 28 | instance ToJSON CharArray where 29 | toJSON = toJSON . map (:[]) . unCharArray 30 | 31 | newtype Uptext = Uptext { unUptext :: Text } 32 | instance ToJSON Uptext where 33 | toJSON = toJSON . Text.toUpper . unUptext 34 | 35 | 36 | data MyRec = MyRec 37 | { foo :: Int 38 | , bar :: String 39 | , baz :: Text 40 | } deriving stock (Show, Eq, Generic) 41 | 42 | v = MyRec 3 "french" "hens" 43 | 44 | newtype Override a (mods :: Row *) = Override {unOverride :: a} 45 | 46 | -- | A version of 'Override' that accepts first the value and then the mods type. 47 | override :: a -> (forall mods. Override a mods) 48 | override = Override 49 | 50 | x = override v @Empty 51 | y = override v @("bar" .== CharArray .+ "baz" .== Uptext) 52 | 53 | main = putStrLn $ show $ encode y 54 | 55 | instance 56 | ( ρ ≈ Rec.NativeRow t 57 | , ρ' ≈ mods .// ρ 58 | , BiForall ρ ρ' Coercible 59 | , Rec.FromNative t 60 | , Forall ρ' ToJSON 61 | ) => ToJSON (Override t mods) where 62 | toJSON = toJSON . Rec.coerceRec @ρ @ρ' . Rec.fromNative . unOverride 63 | -------------------------------------------------------------------------------- /examples/OverridingTypeClassInstances.md: -------------------------------------------------------------------------------- 1 | # Overriding Type Class Instances 2 | 3 | _April 2020_ 4 | 5 | _by Daniel Winograd-Cort_ 6 | 7 | 8 | I read a post by Cary Robbins titled 9 | [Overriding Type Class Instances](http://caryrobbins.com/dev/overriding-type-class-instances-2/) 10 | that describes a clever way to derive custom type class instances for types using 11 | some type-level programming tricks and the `DerivingVia` extension. It struck me 12 | that row-types should be able to do nearly the same thing almost for free, and I 13 | took it as a challenge to see if I could make it work. It required a minor change 14 | to the library (the addition of a specialized `coerce` function for records), but 15 | otherwise it was quite straightforward. 16 | 17 | ## Example 18 | 19 |
20 | 21 | Extensions and imports for this Literate Haskell file 22 | 23 | ```haskell 24 | {-# LANGUAGE DerivingVia #-} 25 | {-# LANGUAGE OverloadedLabels #-} 26 | {-# LANGUAGE OverloadedStrings #-} 27 | module OverridingTypeClassInstances where 28 | 29 | -- Note that `Data.Row.Aeson` is not exported my the row-types library and 30 | -- currently lives in the src\aeson directory. You must put it in an 31 | -- appropriate place and make sure to have `aeson` in your environment in order 32 | -- to use this module. 33 | 34 | import Data.Aeson (ToJSON(..)) 35 | import Data.Char (ord, toUpper) 36 | import Data.Coerce 37 | import Data.Row 38 | import Data.Row.Aeson () 39 | import qualified Data.Row.Records as Rec 40 | import Data.Text (Text) 41 | import qualified Data.Text as Text 42 | import GHC.Generics (Generic) 43 | 44 | newtype Uptext = Uptext { unUptext :: Text } 45 | 46 | instance ToJSON Uptext where 47 | toJSON = toJSON . Text.toUpper . unUptext 48 | 49 | newtype CharArray = CharArray { unCharArray :: String } 50 | 51 | instance ToJSON CharArray where 52 | toJSON = toJSON . map (:[]) . unCharArray 53 | ``` 54 |
55 | 56 | Cary's result looks like the following: 57 | 58 | ```haskell 59 | data MyRec = MyRec 60 | { foo :: Int 61 | , bar :: String 62 | , baz :: Text 63 | } deriving stock (Show, Eq, Generic) 64 | deriving (ToJSON) 65 | via Override MyRec 66 | '[ String `As` CharArray 67 | , "baz" `As` Uptext 68 | ] 69 | ``` 70 | 71 | The idea here is that the `MyRec` data type can have a `ToJSON` instance where 72 | all `String` fields are encoded using the `ToJSON` functionality of the `CharArray` 73 | type class and the `baz` field is encoded using the `ToJSON` of `Uptext`. The 74 | rest of Cary's post describes how he accomplishes this. 75 | 76 | With row-types, it's currently not possible to do a wholesale modification based 77 | on types, but we certainly have machinery for modifying individual fields. Thus 78 | instead, I propose a slightly different syntax, this time based on row-types 79 | operators: 80 | 81 | ```haskell 82 | data MyRec = MyRec 83 | { foo :: Int 84 | , bar :: String 85 | , baz :: Text 86 | } deriving stock (Show, Eq, Generic) 87 | deriving (ToJSON) 88 | via Override MyRec ( 89 | "bar" .== CharArray 90 | .+ "baz" .== Uptext) 91 | ``` 92 | 93 | ## Details 94 | 95 | The `Override` type is actually very simple: 96 | 97 | ```haskell 98 | newtype Override t (mods :: Row *) = Override { unOverride :: t } 99 | ``` 100 | 101 | A value of type `Override t mods` is a value of type `t` that will have certain 102 | fields overridden according to `mods`. The key is in how we define the `ToJSON` 103 | instance for `Override`: 104 | 105 | ```haskell 106 | instance 107 | ( ρ ≈ Rec.NativeRow t 108 | , ρ' ≈ mods .// ρ 109 | , BiForall ρ ρ' Coercible 110 | , Rec.FromNative t 111 | , Forall ρ' ToJSON 112 | ) => ToJSON (Override t mods) where 113 | toJSON = toJSON . Rec.coerceRec @ρ @ρ' . Rec.fromNative . unOverride 114 | ``` 115 | This may look a little intimidating, so let's take it piece by piece. I'll 116 | start with `unOverride` and work through the composed functions, calling out 117 | elements of the context as they become relevant and necessary. 118 | 119 | - `unOverride` is the simplest component. We must unwrap the `Override` newtype. 120 | 121 | - `Rec.fromNative` is a convenient function for converting a native Haskell data 122 | type value into a row-types record. It produces a record with exactly the same 123 | fields and types as the given record. For instance, when called on a value of 124 | type `MyRec`, it will produce a value of type 125 | `Rec ("foo" .== Int .+ "bar" .== String .+ "baz" .== Text)`. In order to do this, 126 | we need the constraint `Rec.FromNative t`, and it additionally provides a type 127 | synonym `Rec.NativeRow t` which will be equal to the row-type produced. You can 128 | see that in the instance's context above, we bind the type variable `ρ` to this type. 129 | 130 | - `Rec.coerceRec @ρ @ρ'` is a record coercion turning a record with row-type `ρ` 131 | to one of of type `ρ'`. This will only succeed if all of the types in `ρ` match 132 | up and are coercible with all the types in `ρ'`, a fact that is captured by the 133 | constraint `BiForall ρ ρ' Coercible`. What is `ρ'`? It is precisely `ρ`, but 134 | overwritten with any row bindings in `mods` (this is captured in `ρ' ≈ mods .// ρ`). 135 | For example, 136 | `("bar" .== CharArray) .// ("foo" .== Int .+ "bar" .== String .+ "baz" .== Text)` 137 | becomes `("foo" .== Int .+ "bar" .== CharArray .+ "baz" .== Text)`. 138 | 139 | - `toJSON` is the `toJSON` function specialized to records with type `ρ'`, and 140 | it requires the constraint `Forall ρ' ToJSON`, indicating that every field in 141 | `ρ'` must have its own `ToJSON` instance. 142 | 143 | Phew! What does that all mean? It means we can take a value of type `t`, convert 144 | it to a row-types record, coerce any internal types to newtypes with `ToJSON` instances 145 | we prefer, and then produce the JSON of the result all in one go. And it works! 146 | It's true that the instance definition is a little hairy, but thankfully we don't 147 | need to mess around with any `Generic` code. 148 | 149 | ## Exploring Overrides 150 | 151 | Cary defines an `override` shorthand and then proceeds to demo 152 | some examples. I'll do the same. 153 | 154 | ```haskell 155 | -- | A version of 'Override' that accepts first the value and then the mods type. 156 | override :: a -> (forall mods. Override a mods) 157 | override = Override 158 | ``` 159 | 160 | Now we can write statements in GHCi like: 161 | 162 | ``` 163 | > v = MyRec 3 "foo" "text" 164 | > encode $ override v @Empty 165 | {"foo":3,"baz":"text","bar":"foo"} 166 | 167 | > encode $ override v @("bar" .== CharArray .+ "baz" .== Uptext) 168 | {"foo":3,"baz":"TEXT","bar":["f","o","o"]} 169 | ``` 170 | 171 | We also get pretty good type errors when we do things wrong. For instance, if 172 | we try to override the same field more than once: 173 | 174 | ``` 175 | > encode $ override v @("bar" .== CharArray .+ "bar" .== String) 176 | :4:1: error: 177 | • The label "bar" has conflicting assignments. 178 | Its type is both CharArray and String. 179 | • In the expression: 180 | encode $ override v @("bar" .== CharArray .+ "bar" .== String) 181 | In an equation for ‘it’: 182 | it 183 | = encode $ override v @("bar" .== CharArray .+ "bar" .== IntChar) 184 | ``` 185 | 186 | Alternatively, if you try to coerce to a type that's not coercible, you'll get 187 | a good error: 188 | 189 | ``` 190 | > encode $ override v @("bar" .== Int) 191 | :5:1: error: 192 | • Couldn't match representation of type ‘[Char]’ with that of ‘Int’ 193 | arising from a use of ‘encode’ 194 | • In the expression: encode $ override v @("bar" .== Int) 195 | In an equation for ‘it’: it = encode $ override v @("bar" .== Int) 196 | ``` 197 | 198 | ## Achievements and Limitations 199 | 200 | With a simple `newtype` and a one-line `ToJSON` instance (the implementation of 201 | the instance is a simple one line, although I'll admit the context takes a few 202 | more), we've been able to recreate most of the expressiveness of 203 | `generic-override`. Of course, `generic-override` has one feature that we 204 | don't: namely, being able to override all fields of a particular type in one go. 205 | I can definitely see the use for this feature—for instance, making sure _all_ 206 | `Text` fields are encoded in a consistent, perhaps more concise, way—but I don't 207 | see a way to do it elegantly with row-types at this time.[1](#myfootnote1) 208 | 209 | But we do gain for what we've given up. Without needing a `ValidateOverride` 210 | type class, we have clear restrictions (and informative error messages) that 211 | prevent us from duplicate overriding. Additionally, we of course have all the 212 | other benefits of row-types. 213 | 214 | --- 215 | 216 | 1: If/When GHC adopts the ability to use simple, unsaturated 217 | type families, this will become possible. For instance, one could write something like 218 | ```haskell 219 | type family ToUptext t where 220 | ToUptext Text = Uptext 221 | ToUptext x = x 222 | ``` 223 | and then make the override modifications: `Rec.Map ToUptext (Rec.NativeRow MyRec)`. 224 | This in itself is still slightly ugly, but unsaturated type families give us the 225 | ability to write more higher-order type functions, such as a row-types `Filter`. 226 | From there, it's a brief hop to a type-level function `FieldsOfTo MyRec Text Uptext` 227 | which would produce a row-type containing all of the fields of `MyRec` that had 228 | the type `Text`, now with the type `Uptext`. Just `.+` that with any other 229 | type modifications you want to make, and you're all set. 230 | -------------------------------------------------------------------------------- /examples/RowCSV.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE OverloadedLabels #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE PartialTypeSignatures #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | module RowCSV where 11 | 12 | import GHC.Generics (Generic) 13 | 14 | import Data.Text (Text) 15 | import qualified Data.Text as T 16 | import qualified Data.List as L 17 | import Text.Read (readMaybe) 18 | 19 | import Data.Row 20 | import qualified Data.Row.Records as Rec 21 | 22 | 23 | data PL = PL 24 | { name :: Text 25 | , year :: Int 26 | , person :: Text 27 | } deriving (Eq, Ord, Show, Generic) 28 | 29 | 30 | type PLRow = "name" .== Text .+ "year" .== Int .+ "person" .== Text 31 | 32 | 33 | pls :: [PL] 34 | pls = 35 | [ PL "Haskell" 1990 "Simon" 36 | , PL "Scala" 2004 "Martin" 37 | , PL "Idris" 2009 "Edwin" 38 | , PL "Perl" 1987 "Larry" 39 | ] 40 | 41 | 42 | rowPLs :: [Rec PLRow] 43 | rowPLs = Rec.fromNative <$> pls 44 | 45 | 46 | input :: Text 47 | input = T.unlines 48 | [ "year,name,types,person,website" 49 | , "1987,Perl,no,Larry" 50 | , "1990,Haskell,nice,Simon,https://www.haskell.org/" 51 | , "2004,Scala,weird,Martin,https://www.scala-lang.org/" 52 | , "2009,Idris,fancy,Edwin,https://www.idris-lang.org/" 53 | ] 54 | 55 | 56 | class ToField a where toField :: a -> Text 57 | instance ToField Text where toField = id 58 | instance ToField Int where toField = T.pack . show 59 | 60 | 61 | recToCSV :: forall ρ. Forall ρ ToField => [Rec ρ] -> Text 62 | recToCSV rs = T.unlines $ map (T.intercalate ",") 63 | $ Rec.labels @ρ @ToField 64 | : map (Rec.erase @ToField toField) rs 65 | 66 | 67 | toCSV :: forall ρ t. (Rec.FromNative t, Rec.NativeRow t ≈ ρ, Forall ρ ToField) => [t] -> Text 68 | toCSV = recToCSV @ρ . fmap Rec.fromNative 69 | 70 | 71 | class FromField a where fromField :: Text -> Either String a 72 | instance FromField Text where fromField = Right 73 | instance FromField Int where 74 | fromField t = 75 | maybe (Left $ "Invalid Int: " ++ show t) Right $ readMaybe $ T.unpack t 76 | 77 | 78 | recFromCSV :: forall ρ. (AllUniqueLabels ρ, Forall ρ FromField) 79 | => Text -> Either String [Rec ρ] 80 | recFromCSV s = case map (T.splitOn ",") (T.lines s) of 81 | [] -> Left "No Input" 82 | header:vals -> traverse makeRecord vals 83 | where 84 | makeRecord s = Rec.fromLabelsA @FromField @(Either String) @ρ (makeField s) 85 | makeField :: (KnownSymbol l, FromField a) => [Text] -> Label l -> Either String a 86 | makeField val l = 87 | maybe (Left $ "Missing field " ++ show l) fromField $ 88 | L.lookup (T.pack $ show l) (zip header val) 89 | 90 | 91 | fromCSV :: forall t ρ. (Rec.ToNative t, ρ ≈ Rec.NativeRow t, AllUniqueLabels ρ, Forall ρ FromField) 92 | => Text -> Either String [t] 93 | fromCSV = fmap (fmap Rec.toNative) . recFromCSV @ρ 94 | 95 | 96 | main = case fromCSV @PL input of 97 | Left err -> putStrLn $ "ERROR: " ++ err 98 | Right xs -> mapM_ print xs 99 | -------------------------------------------------------------------------------- /examples/RowCSV.md: -------------------------------------------------------------------------------- 1 | # Row types for CSV library 2 | _July 2019_ 3 | 4 | _by Daniel Winograd-Cort_ 5 | 6 | ## Introduction 7 | 8 | Oleg Grenrus wrote a recent post titled 9 | ["Fancy types for CSV library"](http://oleg.fi/gists/posts/2019-07-15-fancy-types-for-cassava.html). 10 | In it, he shows how to use vectors and other _fancy types_ to make CSV encoding 11 | and decoding more type safe (as compared to `cassava`). It's a clever idea that 12 | uses an ordered vector of encoded fields (with length at the type level) as an 13 | intermediate data type. Thus, for encoding, one encodes their chosen data types 14 | into these vectors and then encodes the vectors into csv text. For decoding, 15 | one decodes the csv text into vectors and then decodes those vectors into the 16 | data types. Some trouble arises during decoding---perhaps the order of values 17 | in the csv input is different from the order in the data type, or perhaps there 18 | are missing fields in the csv input---and Oleg describes some nice tricks to 19 | deal with these problems. 20 | 21 | At the end of the article, Oleg writes: 22 | 23 | > One valid question to ask, is whether row-types would simplify something here. 24 | > Not really. 25 | > 26 | > For example vinyl's Rec type is essentially the same as NP. Even if there were 27 | > anonymous records in Haskell, so toRecord could be implemented directly using 28 | > a built-in function, it would remove only a single problem from many. At it's 29 | > not much, as toRecord is generically derivable. 30 | 31 | I disagree with this conclusion, and in this post, I'll show how simple the 32 | whole process of csv encoding and decoding can be with the row-types library. 33 | In fact, not only is the code short and clear, but it has even more type safety 34 | than Oleg's version. 35 | 36 | ## Example 37 | 38 |
39 | 40 | Extensions and imports for this Literate Haskell file 41 | 42 | ```haskell 43 | {-# LANGUAGE DataKinds #-} 44 | {-# LANGUAGE DeriveAnyClass #-} 45 | {-# LANGUAGE DeriveGeneric #-} 46 | {-# LANGUAGE FlexibleContexts #-} 47 | {-# LANGUAGE OverloadedLabels #-} 48 | {-# LANGUAGE OverloadedStrings #-} 49 | {-# LANGUAGE PartialTypeSignatures #-} 50 | {-# LANGUAGE ScopedTypeVariables #-} 51 | {-# LANGUAGE TypeOperators #-} 52 | module RowCSV where 53 | 54 | import GHC.Generics (Generic) 55 | 56 | import Data.Text (Text) 57 | import qualified Data.Text as T 58 | import qualified Data.Text.IO as T 59 | import qualified Data.List as L 60 | import Text.Read (readMaybe) 61 | 62 | import Data.Row 63 | import qualified Data.Row.Records as Rec 64 | ``` 65 |
66 | 67 | I'll start with the same data that Oleg uses: 68 | 69 | ```haskell 70 | data PL = PL 71 | { name :: Text 72 | , year :: Int 73 | , person :: Text 74 | } deriving (Eq, Ord, Show, Generic) 75 | 76 | pls :: [PL] 77 | pls = 78 | [ PL "Haskell" 1990 "Simon" 79 | , PL "Scala" 2004 "Martin" 80 | , PL "Idris" 2009 "Edwin" 81 | , PL "Perl" 1987 "Larry" 82 | ] 83 | 84 | input :: Text 85 | input = T.unlines 86 | [ "year,name,types,person,website" 87 | , "1987,Perl,no,Larry" 88 | , "1990,Haskell,nice,Simon,https://www.haskell.org/" 89 | , "2004,Scala,weird,Martin,https://www.scala-lang.org/" 90 | , "2009,Idris,fancy,Edwin,https://www.idris-lang.org/" 91 | ] 92 | ``` 93 | 94 | Here we have a simple record of programming language information. We have a 95 | list of a few languages, and we also have a sample CSV input. Note that the CSV 96 | input has extra fields, and it even has a missing website fields for one of the 97 | entries. We will see that since the `PL` type doesn't have a `website` field, it 98 | won't matter that the CSV data is missing that field. 99 | 100 | ## Encoding to CSV 101 | 102 | I'm going to follow Oleg's plan pretty closely, but instead of using vectors of 103 | `Text` as the intermediate value, I'll be using an extensible row-types record. 104 | It's very easy to convert the `PL` type into an row-types record: use the 105 | built-in `fromNative`. For instance: 106 | 107 | ``` 108 | *Main> :t Rec.fromNative <$> pls 109 | Rec.fromNative <$> pls 110 | :: [Rec ("name" .== Text .+ "person" .== Text .+ "year" .== Int)] 111 | *Main> Rec.fromNative <$> pls 112 | [#name .== "Haskell" .+ #person .== "Simon" .+ #year .== 1990,#name .== "Scala" .+ #person .== "Martin" .+ #year .== 2004,#name .== "Idris" .+ #person .== "Edwin" .+ #year .== 2009,#name .== "Perl" .+ #person .== "Larry" .+ #year .== 1987] 113 | ``` 114 | 115 | The ordering in row-types comes down to lexicographical ordering by field name, 116 | which is why it's different here than in `PL`, but it's not something we need to 117 | worry about because row-types are automatically normalized. 118 | 119 | For the individual fields, let's use the same `ToField` class that Oleg uses: 120 | 121 | ```haskell 122 | class ToField a where toField :: a -> Text 123 | instance ToField Text where toField = id 124 | instance ToField Int where toField = T.pack . show 125 | ``` 126 | 127 | And now, because we're using row-types as our intermediate data type, we are 128 | ready to produce CSV data: 129 | 130 | ```haskell 131 | recToCSV :: forall ρ. Forall ρ ToField => [Rec ρ] -> Text 132 | recToCSV rs = T.unlines $ map (T.intercalate ",") 133 | $ Rec.labels @ρ @ToField 134 | : map (Rec.erase @ToField toField) rs 135 | ``` 136 | 137 | Let's walk through this line by line. The first line is the type signature, 138 | where we demand that each field of the row-type `ρ` have a `ToField` instance. 139 | The second line should look pretty familiar: we stick commas between fields and 140 | turn a list of `Text`s into a `Text`. In the third line, we create the CSV 141 | header; the function `labels` returns the field names of a row type, and it only 142 | needs type arguments to work. The last line is where the individual records are 143 | encoded. The `erase` function is applied to each record in the input list; 144 | `erase` erases the field name information and maps the given function over the 145 | values, returning a simple list of results. 146 | 147 | Lastly, we can make a general `toCSV` function by composing `fromNative` and `recToCSV`: 148 | 149 | ```haskell 150 | toCSV :: forall ρ t. (Rec.FromNative t, Rec.NativeRow t ≈ ρ, Forall ρ ToField) => [t] -> Text 151 | toCSV = recToCSV @ρ . fmap Rec.fromNative 152 | ``` 153 | 154 | We can do a sanity check with: 155 | 156 | ``` 157 | *Main> T.putStr $ toCSV pls 158 | name,year,person 159 | Haskell,1990,Simon 160 | Scala,2004,Martin 161 | Idris,2009,Edwin 162 | Perl,1987,Larry 163 | ``` 164 | 165 | ## Decoding from CSV 166 | 167 | Once again, we'll use the same field conversion functions as Oleg: 168 | 169 | ```haskell 170 | class FromField a where fromField :: Text -> Either String a 171 | instance FromField Text where fromField = Right 172 | instance FromField Int where 173 | fromField t = 174 | maybe (Left $ "Invalid Int: " ++ show t) Right $ readMaybe $ T.unpack t 175 | ``` 176 | 177 | And with just this class, we're immediately ready to parse the csv data: 178 | 179 | ```haskell 180 | recFromCSV :: forall ρ. (AllUniqueLabels ρ, Forall ρ FromField) => Text -> Either String [Rec ρ] 181 | recFromCSV s = case map (T.splitOn ",") (T.lines s) of 182 | [] -> Left "No Input" 183 | header:vals -> traverse makeRecord vals 184 | where 185 | makeRecord s = Rec.fromLabelsA @FromField @(Either String) @ρ (makeField s) 186 | makeField :: (KnownSymbol l, FromField a) => [Text] -> Label l -> Either String a 187 | makeField val l = 188 | maybe (Left $ "Missing field " ++ show l) fromField $ 189 | L.lookup (T.pack $ show l) (zip header val) 190 | ``` 191 | Let's walk through this one line by line too. In the type signature, we're 192 | demanding that the extensible record that we're parsing have unique labels for 193 | every field---it wouldn't make sense to have two different fields with the same 194 | name---and that each field has a `FromField` instance. The second line is just 195 | dealing with commas and lines, and the third line is dealing with bad input. On 196 | the fourth line, we separate the header from the rest of the lines. We then 197 | `traverse` each of the lines with the inner function `makeRecord`. 198 | The sixth line defines `makeRecord`, which uses the `fromLabelsA` (`A` 199 | for Applicative) function to construct a row-type record based on its field 200 | names. This in turn uses the `makeField` function, which takes the csv line and 201 | the label and returns either a `Left` error message if parsing fails or a 202 | `Right` value if it succeeds. Parsing is simply looking up the field name 203 | (`T.pack $ show l`) in the line and calling `fromField` on it. 204 | 205 | Of course, we could probably do something smarter here than doing a lookup in a 206 | linked list---using a `Map` comes to mind---but we're going for simplicity over 207 | efficiency for now. 208 | 209 | Lastly, we can convert a value of type `Rec ρ` to a native Haskell data type 210 | with the row-types built-in `toNative`. This lets us write a general `fromCSV` 211 | function: 212 | 213 | ```haskell 214 | fromCSV :: forall t ρ. 215 | (Rec.ToNative t, ρ ≈ Rec.NativeRow t, AllUniqueLabels ρ, Forall ρ FromField) 216 | => Text -> Either String [t] 217 | fromCSV = fmap (fmap Rec.toNative) . recFromCSV @ρ 218 | ``` 219 | 220 | We can do a sanity check with: 221 | 222 | ``` 223 | main :: IO () 224 | main = case fromCSV @PL input of 225 | Left err -> putStrLn $ "ERROR: " ++ err 226 | Right xs -> mapM_ print xs 227 | 228 | *Main> main 229 | PL {name = "Perl", year = 1987, person = "Larry"} 230 | PL {name = "Haskell", year = 1990, person = "Simon"} 231 | PL {name = "Scala", year = 2004, person = "Martin"} 232 | PL {name = "Idris", year = 2009, person = "Edwin"} 233 | ``` 234 | 235 | ## The Difficult Part 236 | 237 | There isn't one! Notice that our first implementation of `recFromCSV` was 238 | perfectly able to handle data with missing fields and reordered columns, and it 239 | didn't require any extra work on our part. 240 | 241 | ## Conclusions and Extensions 242 | 243 | Oleg claims that row-types would not simplify anything in CSV encoding and 244 | decoding, but I must disagree. Not only did the row-types library give us free 245 | `fromNative` and `toNative` functions and heterogeneous type safety, but it 246 | handled all of the difficult cases of missing data and reordered columns for 247 | free as well. 248 | 249 | Furthermore, if one thinks of the row-type record as an intermediate data type 250 | as described in the introduction, then we can extend this CSV parsing to 251 | incorporate the ideas of [type surgery](TypeSurgery.html) as well. Instead of 252 | needing a `FromField` class, one could very simply lift the `Text` from the CSV 253 | into structured row-types records and then do surgery on them from there. 254 | -------------------------------------------------------------------------------- /examples/TypeSurgery.lhs: -------------------------------------------------------------------------------- 1 | \documentclass[11pt, letterpaper]{article} 2 | 3 | \usepackage[margin=1in]{geometry} 4 | \usepackage{hyperref} 5 | 6 | %include polycode.fmt 7 | %format ≈ = "\ensuremath{\approx}" 8 | %format *> = "\mathop{*\!\!\!>}" 9 | %format # = "~\texttt{\#}" 10 | %format @ = "~@" 11 | 12 | %format .+ = "\mathbin{\color{BlueViolet}{.\!+}}" 13 | %format .! = "\mathbin{\color{BlueViolet}{.!}}" 14 | %format .- = "\mathbin{\color{BlueViolet}{.\!-}}" 15 | %format .== = "\mathbin{\color{BlueViolet}{.\!\!=\joinrel=}}" 16 | 17 | \usepackage[dvipsnames]{xcolor} 18 | \newcommand{\id}[1]{\textsf{\textsl{#1}}} 19 | \renewcommand{\Varid}[1]{\textcolor{Sepia}{\id{#1}}} 20 | \renewcommand{\Conid}[1]{\textcolor{OliveGreen}{\id{#1}}} 21 | %subst keyword a = "\textcolor{BlueViolet}{\textbf{" a "}}" 22 | 23 | \title{Type Surgery} 24 | \author{Daniel Winograd-Cort} 25 | \date{April 2019} 26 | 27 | \begin{document} 28 | 29 | \maketitle 30 | 31 | \section{Type Surgery} 32 | 33 | I read about the idea of ``data type surgery'' on 34 | \href{https://blog.poisson.chat/posts/2018-11-26-type-surgery.html} 35 | {Lysxia's blog post of the same name}. I'll quote from the blog: 36 | 37 | \begin{quote} 38 | The general motivation is to improve the applicability of various generic definitions, 39 | such as aeson’s generic instances for |ToJSON| and |FromJSON|. Such a library often 40 | offers several options to customize the generic implementations, but it can still 41 | happen that none of them quite fit your external requirements and you have to resort 42 | to manual implementations, even with only small mismatches with the generic 43 | implementations. Surgeries are a new way to adapt generic implementations to such 44 | conditions outside of your control. 45 | \end{quote} 46 | 47 | As it turns out, one can gain the same powers from the row-types package 48 | (something Lysxia hinted at in a footnote in the original blog). Today, I'm going 49 | to demonstrate how to use row-types to do type surgery. 50 | 51 | \iffalse 52 | \begin{code} 53 | {-# LANGUAGE AllowAmbiguousTypes #-} 54 | {-# LANGUAGE DataKinds #-} 55 | {-# LANGUAGE DeriveAnyClass #-} 56 | {-# LANGUAGE DeriveGeneric #-} 57 | {-# LANGUAGE OverloadedLabels #-} 58 | {-# LANGUAGE PartialTypeSignatures #-} 59 | {-# LANGUAGE ScopedTypeVariables #-} 60 | {-# LANGUAGE TypeOperators #-} 61 | module TypeSurgery where 62 | 63 | import Data.Row 64 | import qualified Data.Row.Records as Rec 65 | 66 | import Data.Aeson 67 | import Data.Aeson.Types (Parser) 68 | import Data.Coerce (coerce) 69 | import Data.Functor.Identity (Identity(..)) 70 | 71 | import GHC.Generics 72 | 73 | -- Convenient lens functions (rather than importing Lens) 74 | over :: ((a -> Identity b) -> s -> Identity t) -> (a -> b) -> s -> t 75 | over = coerce 76 | 77 | \end{code} 78 | \fi 79 | 80 | \subsection{Example} 81 | 82 | I'll use the same example given in Lysxia's blog: 83 | 84 | \begin{code} 85 | data RecToy = RecToy 86 | { iden :: Int 87 | , header1 :: Int 88 | , header2 :: Int 89 | , payload :: String 90 | } deriving (Eq, Show, Generic, ToJSON) 91 | \end{code} 92 | 93 | 94 | Here we have a toy record for which we'd like to generate a |FromJSON| instance, 95 | but we have a condition: the |payload| field is allowed to be optional in the 96 | JSON (i.e., a missing field should be parsed as the empty string |""|). Aeson's 97 | generic instances work fine with optional fields \emph{so long as they are |Maybe| 98 | fields}, so there seems to be no easy solution. We could make an alternate 99 | |RecToy'| whose |payload| field is a |Maybe String| and then convert it, but that's 100 | a lot of boilerplate. We could also write our own |FromJSON| instance manually, 101 | but that's tedious. 102 | 103 | So, let's do some surgery! 104 | 105 | \subsection{generic-data-surgery} 106 | Lyxsia describes the following solution using the generic-data-surgery library: 107 | 108 | \begin{spec} 109 | instance FromJSON RecToy where 110 | parseJSON :: Value -> Parser RecToy 111 | parseJSON 112 | = fmap ( fromOR 113 | . modifyRField @"payload" defString 114 | . toOR') 115 | . genericParseJSON defaultOptions{omitNothingFields=True} 116 | 117 | defString :: Maybe String -> String 118 | defString = maybe "" id 119 | \end{spec} 120 | 121 | The key part here is the surgery going on in: 122 | \begin{spec} 123 | fromOR . modifyRField @"payload" defString . toOR' 124 | \end{spec} 125 | Let's break this down: 126 | \begin{itemize} 127 | \item First, we head into the ``operating room'' with |toOR'|. 128 | \item Then, we modify the record field named |payload| by applying the |defString| 129 | function to it. 130 | \item Finally, we exit the ``operating room'' with |fromOR|. 131 | \end{itemize} 132 | 133 | Behind the scenes at the type level, the |genericParseJSON| is being done on a 134 | synthetic type that looks just like |RecToy| but where the |payload| field has 135 | the type |Maybe String|. This synthetic type is lifted into the ``operating room'', 136 | which is essentially lifting it into a manipulatable type and then ``operated on'', 137 | where the |payload| field is converted from type |Maybe String| to |String| using 138 | the |defString| function. Finally, |fromOR| converts this manipulatable type 139 | to |RecToy|, and parsing is complete. 140 | 141 | \subsection{row-types Solution} 142 | For a simple case like this, we can do almost the same thing with row-types. 143 | The main difference is that what generic-data-surgery calls an operating room, 144 | we simply call a row-types record (or variant). Indeed, instead of going to and 145 | from the OR, we go to and from the native type using |Rec.toNative| and 146 | |Rec.fromNative|. Specifically: 147 | \begin{itemize} 148 | \item In place of |toOR'|, we call |Rec.fromNative| to convert from a native Haskell 149 | type to a row-types record. 150 | \item In place of |modifyRField @"payload" defString|, we do a lensy operation 151 | to change the record. In this case, we could write 152 | |over (Rec.focus #payload) defString|. 153 | \item Finally, we convert back to a Haskell native type with |Rec.toNative|. 154 | \end{itemize} 155 | The full code looks like: 156 | \begin{code} 157 | instance FromJSON RecToy where 158 | parseJSON :: Value -> Parser RecToy 159 | parseJSON 160 | = fmap ( Rec.toNative 161 | . over (Rec.focus #payload) defString) 162 | . genericParseJSON defaultOptions{omitNothingFields=True} 163 | 164 | defString :: Maybe String -> String 165 | defString = maybe "" id 166 | \end{code} 167 | 168 | \subsection{Limitations} 169 | The row-types library is limited compared to generic-data-surgery in two specific 170 | ways: there are no conversion functions between full sum-of-products Haskell 171 | data types and variants of records, and there is no support for unnamed fields. 172 | The first limitation is simply because such a feature has never seemed necessary 173 | to row-types, and it could be added with a little generics programming. 174 | 175 | The second is a more fundamental limitation. Names are critical to the concept 176 | of the row-types library, as every field in a record and every possibility in a 177 | variant must be named. Therefore, it is simply impossible to convert a native 178 | record that has no field names into a row-types record (without a lot of defaulting). 179 | 180 | \end{document} 181 | -------------------------------------------------------------------------------- /examples/TypeSurgery.md: -------------------------------------------------------------------------------- 1 | # Type Surgery 2 | _April 2019_ 3 | 4 | _by Daniel Winograd-Cort_ 5 | 6 | ## Type Surgery 7 | 8 | I read about the idea of "data type surgery" on 9 | [Lysxia's blog post of the same name](https://blog.poisson.chat/posts/2018-11-26-type-surgery.html). 10 | I'll quote from the blog: 11 | 12 | > The general motivation is to improve the applicability of various generic definitions, 13 | > such as aeson’s generic instances for `ToJSON` and `FromJSON`. Such a library often 14 | > offers several options to customize the generic implementations, but it can still 15 | > happen that none of them quite fit your external requirements and you have to resort 16 | > to manual implementations, even with only small mismatches with the generic 17 | > implementations. Surgeries are a new way to adapt generic implementations to such 18 | > conditions outside of your control. 19 | 20 | As it turns out, one can gain the same powers from the row-types package 21 | (something Lysxia hinted at in a footnote in the original blog). Today, I'm going 22 | to demonstrate how to use row-types to do type surgery. 23 | 24 | ## Example 25 | 26 |
27 | 28 | Extensions and imports for this Literate Haskell file 29 | 30 | ```haskell 31 | {-# LANGUAGE AllowAmbiguousTypes #-} 32 | {-# LANGUAGE DataKinds #-} 33 | {-# LANGUAGE DeriveAnyClass #-} 34 | {-# LANGUAGE DeriveGeneric #-} 35 | {-# LANGUAGE OverloadedLabels #-} 36 | {-# LANGUAGE PartialTypeSignatures #-} 37 | {-# LANGUAGE ScopedTypeVariables #-} 38 | {-# LANGUAGE TypeOperators #-} 39 | module TypeSurgery where 40 | 41 | import qualified Data.Row.Records as Rec 42 | 43 | import Data.Aeson 44 | import Data.Coerce (coerce) 45 | import Data.Functor.Identity (Identity(..)) 46 | 47 | import GHC.Generics 48 | 49 | -- Convenient lens functions (rather than importing Lens) 50 | over :: ((a -> Identity b) -> s -> Identity t) -> (a -> b) -> s -> t 51 | over = coerce 52 | ``` 53 |
54 | 55 | I'll use the same example given in Lysxia's blog: 56 | 57 | ```haskell 58 | data RecToy = RecToy 59 | { iden :: Int 60 | , header1 :: Int 61 | , header2 :: Int 62 | , payload :: String 63 | } deriving (Eq, Show, Generic) 64 | ``` 65 | 66 | Here we have a toy record for which we'd like to generate a `FromJSON` instance, 67 | but we have a condition: the `payload` field is allowed to be optional in the 68 | JSON (i.e., a missing field should be parsed as the empty string `""`). Aeson's 69 | generic instances work fine with optional fields _so long as they are `Maybe` 70 | fields_, so there seems to be no easy solution. We could make an alternate 71 | `RecToy'` whose `payload` field is a `Maybe String` and then convert it, but that's 72 | a lot of boilerplate. We could also write our own `FromJSON` instance manually, 73 | but that's tedious. 74 | 75 | So, let's do some surgery! 76 | 77 | ## generic-data-surgery 78 | Lyxsia describes the following solution using the generic-data-surgery library: 79 | 80 | ```haskell 81 | instance FromJSON RecToy where 82 | parseJSON :: Value -> Parser RecToy 83 | parseJSON 84 | = fmap ( fromOR 85 | . modifyRField @"payload" defString 86 | . toOR') 87 | . genericParseJSON defaultOptions{omitNothingFields=True} 88 | 89 | defString :: Maybe String -> String 90 | defString = maybe "" id 91 | ``` 92 | 93 | The key part here is the surgery going on in: 94 | 95 | ```haskell 96 | fromOR . modifyRField @"payload" defString . toOR' 97 | ``` 98 | 99 | Let's break this down: 100 | 101 | - First, we head into the "operating room" with `toOR'`. 102 | 103 | - Then, we modify the record field named `payload` by applying the `defString` 104 | function to it. 105 | 106 | - Finally, we exit the "operating room" with `fromOR`. 107 | 108 | Behind the scenes at the type level, the `genericParseJSON` is being done on a 109 | synthetic type that looks just like `RecToy` but where the `payload` field has 110 | the type `Maybe String`. This synthetic type is lifted into the "operating room", 111 | which is essentially lifting it into a manipulatable type and then "operated on", 112 | where the `payload` field is converted from type `Maybe String` to `String` using 113 | the `defString` function. Finally, `fromOR` converts this manipulatable type 114 | to `RecToy`, and parsing is complete. 115 | 116 | ## row-types Solution 117 | For a simple case like this, we can do almost the same thing with row-types. 118 | The main difference is that what generic-data-surgery calls an operating room, 119 | we simply call a row-types record (or variant). Indeed, instead of going to and 120 | from the OR, we can go to and from the native type using `Rec.toNative` and 121 | `Rec.fromNative`. Specifically: 122 | 123 | - Because row-types records are generic themselves, we don't actually need an operation 124 | like `toOR'`. The result of `genericParseJSON` will be inferred as the 125 | appropriate row-types record directly, and we can start with the expression 126 | to modify it. 127 | 128 | - In place of `modifyRField @"payload" defString`, we do a lensy operation 129 | to change the record. In this case, we could write 130 | `over (Rec.focus #payload) defString`. 131 | 132 | - Finally, we convert back to a Haskell native type with `Rec.toNative`. 133 | 134 | The full code looks like: 135 | ```haskell 136 | instance FromJSON RecToy where 137 | parseJSON :: Value -> Parser RecToy 138 | parseJSON 139 | = fmap ( Rec.toNative 140 | . over (Rec.focus #payload) defString) 141 | . genericParseJSON defaultOptions{omitNothingFields=True} 142 | ``` 143 | 144 | ## Limitations 145 | The row-types library is limited compared to generic-data-surgery in two specific 146 | ways: there are no conversion functions between full sum-of-products Haskell 147 | data types and variants of records, and there is no support for unnamed fields. 148 | The first limitation is simply because such a feature has never seemed necessary 149 | to row-types, and it could be added with a little generics programming. 150 | 151 | The second is a more fundamental limitation. Names are critical to the concept 152 | of the row-types library, as every field in a record and every possibility in a 153 | variant must be named. Therefore, it is simply impossible to convert a native 154 | record that has no field names into a row-types record (without a lot of defaulting). 155 | -------------------------------------------------------------------------------- /examples/TypedErrors.lhs: -------------------------------------------------------------------------------- 1 | \documentclass[11pt, letterpaper]{article} 2 | 3 | \usepackage[margin=1in]{geometry} 4 | \usepackage{hyperref} 5 | 6 | %include polycode.fmt 7 | %format . = "." 8 | %format ≈ = "\ensuremath{\approx}" 9 | %format *> = "\mathop{*\!\!\!>}" 10 | %format # = "~\texttt{\#}" 11 | 12 | %format .+ = "\mathbin{\color{BlueViolet}{.\!+}}" 13 | %format .! = "\mathbin{\color{BlueViolet}{.!}}" 14 | %format .- = "\mathbin{\color{BlueViolet}{.\!-}}" 15 | %format .== = "\mathbin{\color{BlueViolet}{.\!\!=\joinrel=}}" 16 | 17 | \usepackage[dvipsnames]{xcolor} 18 | \newcommand{\id}[1]{\textsf{\textsl{#1}}} 19 | \renewcommand{\Varid}[1]{\textcolor{Sepia}{\id{#1}}} 20 | \renewcommand{\Conid}[1]{\textcolor{OliveGreen}{\id{#1}}} 21 | %subst keyword a = "\textcolor{BlueViolet}{\textbf{" a "}}" 22 | 23 | 24 | \title{Typed Errors} 25 | \author{Daniel Winograd-Cort} 26 | \date{April 2019} 27 | 28 | \begin{document} 29 | 30 | \maketitle 31 | 32 | \section{Typed Errors} 33 | 34 | I read a post by Matt Parsons called 35 | \href{https://www.parsonsmatt.org/2018/11/03/trouble_with_typed_errors.html} 36 | {The Trouble with Typed Errors} that talks about the difficulties we face in Haskell 37 | from not having open variant types. Matt says 38 | "Haskell doesn’t have open variants, and the attempts to mock them end up quite 39 | clumsy to use in practice." 40 | But, I disagree. I think row-types handles the typed error case quite nicely. 41 | 42 | \subsection{Imports} 43 | 44 | As this is a Literate Haskell file, let's get the imports and pragmas out of the 45 | way first... 46 | 47 | \begin{code} 48 | {-# LANGUAGE AllowAmbiguousTypes #-} 49 | {-# LANGUAGE DataKinds #-} 50 | {-# LANGUAGE OverloadedLabels #-} 51 | {-# LANGUAGE ScopedTypeVariables #-} 52 | {-# LANGUAGE TypeOperators #-} 53 | module TypedErrors where 54 | 55 | import Data.Row 56 | \end{code} 57 | 58 | \subsection{Example} 59 | 60 | I'll try to set up the situation similar to how Matt sets it up in his blog. 61 | Let's start with two functions, |foo| and |bar|, that may each fail. 62 | 63 | \begin{spec} 64 | data FooErr = FooErr Int 65 | deriving (Show) 66 | 67 | data BarErr = BarErr String 68 | deriving (Show) 69 | 70 | foo :: Either FooErr Int 71 | foo = Left (FooErr 3) 72 | 73 | bar :: Either BarErr Int 74 | bar = Left (BarErr "Oops") 75 | 76 | \end{spec} 77 | 78 | Of course, the problem with this code is that there's no good way to deal with 79 | these two errors together. Matt explains in his blog the various problems, but 80 | in short: 81 | \begin{itemize} 82 | \item As is, |foo| and |bar| aren't in the same monad (because they have different 83 | error types!), so we cannot use do notation. 84 | \item If we group the errors into something like |Either FooErr BarErr|, then not 85 | only must we be very diligent about |Left|s and |Right|s (especially if we add 86 | more error types), but we run into issues because |Either FooErr BarErr| $\neq$ 87 | |Either BarErr FooErr|. 88 | \item If we combine the errors into one monolithic error type, we lose static 89 | guarantees about exactly which errors a function may produce and exactly which 90 | we are handling when we write error handlers. 91 | \end{itemize} 92 | 93 | \section{A row-types solution} 94 | \subsection{Generating Errors} 95 | 96 | With row-types, we have open variants easily available to us, which means we can 97 | do the following: 98 | 99 | \begin{code} 100 | foo :: (AllUniqueLabels r, r .! "fooErr" ≈ Int) => Either (Var r) Int 101 | foo = Left (IsJust #fooErr 3) 102 | 103 | bar :: (AllUniqueLabels r, r .! "barErr" ≈ String) => Either (Var r) Int 104 | bar = Left (IsJust #barErr "Oops") 105 | 106 | baz :: (AllUniqueLabels r, r .! "bazErr" ≈ Bool) => Either (Var r) Int 107 | baz = Left (IsJust #bazErr True) 108 | 109 | 110 | foobarbaz 111 | :: ( AllUniqueLabels r 112 | , r .! "fooErr" ≈ Int 113 | , r .! "barErr" ≈ String 114 | , r .! "bazErr" ≈ Bool) 115 | => Either (Var r) Int 116 | foobarbaz = bar *> foo *> bar *> baz 117 | \end{code} 118 | 119 | In |foo|, we create error data with the expression |IsJust #fooErr 3|. This 120 | creates a new row-types variant at the label |"fooErr"| with the value |3|. 121 | The context indicates that the error type may have other possibilities: 122 | specifically, |AllUniqueLabels r| is some boilerplate that guarantees that no 123 | two possibilities have the same name, and |r .! "fooErr" ≈ Int| declares that 124 | the |fooErr| possibility has a payload of type |Int|. 125 | 126 | We can do the same for |bar|/|barErr| and |baz|/|bazErr|, and then if we want to 127 | compose them together, we can easily do so as in |foobarbaz|. 128 | Furthermore, although we provide the type signatures here, GHC will infer them 129 | just fine (with |NoMonomorphismRestriction|). 130 | 131 | \subsection{Handling Errors} 132 | We can handle these errors in multiple ways. 133 | 134 | First off, it's easy enough to |show| our value (so long as the data in the errors 135 | is |Show|able): 136 | 137 | \begin{code} 138 | printFoobarbaz :: String 139 | printFoobarbaz = show specificFoobarbaz 140 | where specificFoobarbaz :: Either (Var ( "fooErr" .== Int 141 | .+ "barErr" .== String 142 | .+ "bazErr" .== Bool)) Int 143 | specificFoobarbaz = foobarbaz 144 | \end{code} 145 | 146 | All row-types variants implement an obvious |Show| instance, but do note that to |show| 147 | |foobarbaz|, we must specify its type. This is because |foobarbaz| is defined 148 | polymorphically over any variant that has appropriate entries for |fooErr|, |barErr|, 149 | and |bazErr|, but to |show| it, we must pick a concrete type to use for the |Show| 150 | instance. In this case, we pick the minimum variant. 151 | 152 | We can also deal with a single error at a time using the |trial| function. This 153 | function lets us pluck a particular possibility out of a variant, allowing us 154 | to handle that possibility or be left with the leftovers of the variant. In the 155 | following case, we handle the |fooErr| possibility, using the |Int| value it 156 | contains as our return value. If |foobarbaz| is not a |fooErr|, then we're left 157 | with a |Left| error value that cannot be a |fooErr|. 158 | 159 | \begin{code} 160 | handleFoo :: forall r. 161 | ( AllUniqueLabels r 162 | , r .! "fooErr" ≈ Int 163 | , r .! "barErr" ≈ String 164 | , r .! "bazErr" ≈ Bool) 165 | => Either (Var (r .- "fooErr")) Int 166 | handleFoo = 167 | case foobarbaz of 168 | Left err -> case trial @_ @r err #fooErr of 169 | Left i -> Right i 170 | Right other -> Left other 171 | Right i -> Right i 172 | \end{code} 173 | 174 | The type signature of |handleFoo| is a little disappointing but necessary because 175 | we're keeping our variant type entirely polymorphic. However, if we were willing 176 | to monomorphize our error to a concrete type, the constraints (and the type 177 | applications on |trial|) would no longer be necessary. This is a tradeoff that 178 | one needs to make based on the situation. 179 | 180 | Finally, we have the option of handling all errors at once using |switch|. 181 | 182 | \begin{code} 183 | handleAll :: String 184 | handleAll = 185 | case foobarbaz of 186 | Left err -> switch err $ 187 | #fooErr .== (\n -> "FooErr of " ++ show n) 188 | .+ #barErr .== (\s -> "BarErr of " ++ s) 189 | .+ #bazErr .== (\b -> "BazErr of " ++ show b) 190 | Right i -> "Got the result " <> show i 191 | \end{code} 192 | 193 | Specifically, |switch| allows us to define a case for every possibility of a 194 | variant, allowing us to reduce the variant to an ordinary result. In this case, 195 | type annotations are not needed because the variant must match exactly the form 196 | of the |switch|'s cases. Because we have exactly 3 cases, one for each of our 197 | errors, GHC monomorphizes the error component of |foobarbaz| to 198 | |Var ("fooErr" .== Int .+ "barErr" .== String .+ "bazErr" .== Bool)| automatically. 199 | 200 | 201 | \subsection{Achievements and Limitations} 202 | 203 | Using variants, we are able to create and handle typed errors without dealing with 204 | weird nesting of |Either|s and without losing any static guarantees. Furthermore, 205 | variant typed errors can be easily defined with constraints (as we did here with 206 | the constraints like |r .! "fooErr" ≈ Int|) with minimal boilerplate: no extra 207 | data declarations necessary! And, once monomorphized, two variants with the same 208 | possibilities always share the same type, regardless of the order that the 209 | possibilities are described in the type. I also didn't discuss |diversify|, 210 | which allows one to expand the possibilities in a variant, which, for typed 211 | errors, allows one to use a limited (perhaps already monomorphized) error type 212 | in a more general setting. 213 | 214 | However, there are downsides to variants typed errors. A little bit of boilerplate 215 | does remain in the form of the |AllUniqueLabels| constraint, which just about always 216 | needs to be used. Also, GHC has trouble inferring all the types and constraints 217 | when we want to remain as polymorphic as possible, which means writing out some 218 | annoying types and occasionally using type annotations (as seen in |handleFoo| 219 | above). Lastly, the |switch| expression seems a lot like an ordinary Haskell 220 | |case| expression, but it isn't, which means the user is forced to learn what 221 | amounts to a special syntax just for dispatching the errors. 222 | 223 | There are specific considerations for any project, but I think row-types variants 224 | are a great choice for typed errors. 225 | 226 | \end{document} 227 | -------------------------------------------------------------------------------- /examples/TypedErrors.md: -------------------------------------------------------------------------------- 1 | # Typed Errors 2 | 3 | _April 2019_ 4 | 5 | _by Daniel Winograd-Cort_ 6 | 7 | 8 | I read a post by Matt Parsons called 9 | [The Trouble with Typed Errors](https://www.parsonsmatt.org/2018/11/03/trouble_with_typed_errors.html) 10 | that talks about the difficulties we face in Haskell 11 | from not having open variant types. Matt says: 12 | 13 | > Haskell doesn’t have open variants, and the attempts to mock them end up quite 14 | > clumsy to use in practice. 15 | 16 | But, I disagree. I think row-types handles the typed error case quite nicely. 17 | 18 | ## Imports 19 | 20 | As this is a Literate Haskell file, let's get the imports and pragmas out of the 21 | way first... 22 | 23 | ```haskell 24 | {-# LANGUAGE AllowAmbiguousTypes #-} 25 | {-# LANGUAGE DataKinds #-} 26 | {-# LANGUAGE OverloadedLabels #-} 27 | {-# LANGUAGE ScopedTypeVariables #-} 28 | {-# LANGUAGE TypeOperators #-} 29 | module TypedErrors where 30 | 31 | import Data.Row 32 | ``` 33 | 34 | ## Example 35 | 36 | I'll try to set up the situation similar to how Matt sets it up in his blog. 37 | Let's start with two functions, `foo` and `bar`, that may each fail. 38 | 39 | ```haskell 40 | data FooErr = FooErr Int 41 | deriving (Show) 42 | 43 | data BarErr = BarErr String 44 | deriving (Show) 45 | 46 | foo :: Either FooErr Int 47 | foo = Left (FooErr 3) 48 | 49 | bar :: Either BarErr Int 50 | bar = Left (BarErr "Oops") 51 | ``` 52 | 53 | Of course, the problem with this code is that there's no good way to deal with 54 | these two errors together. Matt explains in his blog the various problems, but 55 | in short: 56 | 57 | - As is, `foo` and `bar` aren't in the same monad (because they have different 58 | error types!), so we cannot use do notation. 59 | 60 | - If we group the errors into something like `Either FooErr BarErr`, then not 61 | only must we be very diligent about `Left`s and `Right`s (especially if we add 62 | more error types), but we run into issues because `Either FooErr BarErr` ≠ 63 | `Either BarErr FooErr`. 64 | 65 | - If we combine the errors into one monolithic error type, we lose static 66 | guarantees about exactly which errors a function may produce and exactly which 67 | we are handling when we write error handlers. 68 | 69 | ## A row-types solution 70 | 71 | ### Generating Errors 72 | 73 | With row-types, we have open variants easily available to us, which means we can 74 | do the following: 75 | 76 | ```haskell 77 | foo :: (AllUniqueLabels r, r .! "fooErr" ≈ Int) => Either (Var r) Int 78 | foo = Left (IsJust #fooErr 3) 79 | 80 | bar :: (AllUniqueLabels r, r .! "barErr" ≈ String) => Either (Var r) Int 81 | bar = Left (IsJust #barErr "Oops") 82 | 83 | baz :: (AllUniqueLabels r, r .! "bazErr" ≈ Bool) => Either (Var r) Int 84 | baz = Left (IsJust #bazErr True) 85 | 86 | 87 | foobarbaz 88 | :: ( AllUniqueLabels r 89 | , r .! "fooErr" ≈ Int 90 | , r .! "barErr" ≈ String 91 | , r .! "bazErr" ≈ Bool) 92 | => Either (Var r) Int 93 | foobarbaz = bar *> foo *> bar *> baz 94 | ``` 95 | 96 | In `foo`, we create error data with the expression `IsJust #fooErr 3`. This 97 | creates a new row-types variant at the label `"fooErr"` with the value `3`. 98 | The context indicates that the error type may have other possibilities: 99 | specifically, `AllUniqueLabels r` is some boilerplate that guarantees that no 100 | two possibilities have the same name, and `r .! "fooErr" ≈ Int` declares that 101 | the `fooErr` possibility has a payload of type `Int`. 102 | 103 | We can do the same for `bar`/`barErr` and `baz`/`bazErr`, and then if we want to 104 | compose them together, we can easily do so as in `foobarbaz`. 105 | Furthermore, although we provide the type signatures here, GHC will infer them 106 | just fine (with `NoMonomorphismRestriction`). 107 | 108 | ### Handling Errors 109 | We can handle these errors in multiple ways. 110 | 111 | First off, it's easy enough to `show` our value (so long as the data in the errors 112 | is `Show`able): 113 | 114 | ```haskell 115 | printFoobarbaz :: String 116 | printFoobarbaz = show specificFoobarbaz 117 | where specificFoobarbaz :: Either (Var ("fooErr" .== Int 118 | .+ "barErr" .== String 119 | .+ "bazErr" .== Bool)) Int 120 | specificFoobarbaz = foobarbaz 121 | ``` 122 | 123 | All row-types variants implement an obvious `Show` instance, but do note that to `show` 124 | `foobarbaz`, we must specify its type. This is because `foobarbaz` is defined 125 | polymorphically over any variant that has appropriate entries for `fooErr`, `barErr`, 126 | and `bazErr`, but to `show` it, we must pick a concrete type to use for the `Show` 127 | instance. In this case, we pick the minimum variant. 128 | 129 | We can also deal with a single error at a time using the `trial` function. This 130 | function lets us pluck a particular possibility out of a variant, allowing us 131 | to handle that possibility or be left with the leftovers of the variant. In the 132 | following case, we handle the `fooErr` possibility, using the `Int` value it 133 | contains as our return value. If `foobarbaz` is not a `fooErr`, then we're left 134 | with a `Left` error value that cannot be a `fooErr`. 135 | 136 | ```haskell 137 | handleFoo :: forall r. 138 | ( AllUniqueLabels r 139 | , r .! "fooErr" ≈ Int 140 | , r .! "barErr" ≈ String 141 | , r .! "bazErr" ≈ Bool) 142 | => Either (Var (r .- "fooErr")) Int 143 | handleFoo = 144 | case foobarbaz of 145 | Left err -> case trial @_ @r err #fooErr of 146 | Left i -> Right i 147 | Right other -> Left other 148 | Right i -> Right i 149 | ``` 150 | 151 | The type signature of `handleFoo` is a little disappointing but necessary because 152 | we're keeping our variant type entirely polymorphic. However, if we were willing 153 | to monomorphize our error to a concrete type, the constraints (and the type 154 | applications on `trial`) would no longer be necessary. This is a tradeoff that 155 | one needs to make based on the situation. 156 | 157 | Finally, we have the option of handling all errors at once using `switch`. 158 | 159 | ```haskell 160 | handleAll :: String 161 | handleAll = 162 | case foobarbaz of 163 | Left err -> switch err $ 164 | #fooErr .== (\n -> "FooErr of " ++ show n) 165 | .+ #barErr .== (\s -> "BarErr of " ++ s) 166 | .+ #bazErr .== (\b -> "BazErr of " ++ show b) 167 | Right i -> "Got the result " <> show i 168 | ``` 169 | 170 | Specifically, `switch` allows us to define a case for every possibility of a 171 | variant, allowing us to reduce the variant to an ordinary result. In this case, 172 | type annotations are not needed because the variant must match exactly the form 173 | of the `switch`'s cases. Because we have exactly 3 cases, one for each of our 174 | errors, GHC monomorphizes the error component of `foobarbaz` to 175 | `Var ("fooErr" .== Int .+ "barErr" .== String .+ "bazErr" .== Bool)` automatically. 176 | 177 | 178 | ## Achievements and Limitations 179 | 180 | Using variants, we are able to create and handle typed errors without dealing with 181 | weird nesting of `Either`s and without losing any static guarantees. Furthermore, 182 | variant typed errors can be easily defined with constraints (as we did here with 183 | the constraints like `r .! "fooErr" ≈ Int`) with minimal boilerplate: no extra 184 | data declarations necessary! And, once monomorphized, two variants with the same 185 | possibilities always share the same type, regardless of the order that the 186 | possibilities are described in the type. I also didn't discuss `diversify`, 187 | which allows one to expand the possibilities in a variant, which, for typed 188 | errors, allows one to use a limited (perhaps already monomorphized) error type 189 | in a more general setting. 190 | 191 | However, there are downsides to variants typed errors. A little bit of boilerplate 192 | does remain in the form of the `AllUniqueLabels` constraint, which just about always 193 | needs to be used. Also, GHC has trouble inferring all the types and constraints 194 | when we want to remain as polymorphic as possible, which means writing out some 195 | annoying types and occasionally using type annotations (as seen in `handleFoo` 196 | above). Lastly, the `switch` expression seems a lot like an ordinary Haskell 197 | `case` expression, but it isn't, which means the user is forced to learn what 198 | amounts to a special syntax just for dispatching the errors. 199 | 200 | There are specific considerations for any project, but I think row-types variants 201 | are a great choice for typed errors. 202 | -------------------------------------------------------------------------------- /index.md: -------------------------------------------------------------------------------- 1 | Row-Types 2 | ======= 3 | 4 | [![Build Status](https://api.travis-ci.org/target/row-types.svg?branch=master)](https://travis-ci.org/target/row-types/branches) 5 | [![Hackage](https://img.shields.io/hackage/v/row-types.svg)](https://hackage.haskell.org/package/row-types) 6 | 7 | Row-types is a library of open records and variants for Haskell using closed 8 | type families and type literals (among other things...). 9 | See [examples/Examples.lhs](https://raw.githubusercontent.com/target/row-types/master/examples/Examples.lhs) 10 | for a literate Haskell file that functions as an overview of how this library can be used. 11 | 12 | Also, check out these posts about cool things you can do with row-types: 13 | 14 | - [Row types for CSV library](examples/RowCSV.html) 15 | - [Type Surgery](examples/TypeSurgery.html) 16 | - [Typed Errors Done Better](examples/TypedErrors.html) 17 | - [Overriding Type Class Instances](examples/OverridingTypeClassInstances.html) 18 | 19 | 20 | Available on [Hackage](https://hackage.haskell.org/package/row-types).\ 21 | Source available on [GitHub](https://github.com/target/row-types/). 22 | -------------------------------------------------------------------------------- /row-types.cabal: -------------------------------------------------------------------------------- 1 | Name: row-types 2 | Version: 1.0.1.2 3 | License: MIT 4 | License-file: LICENSE 5 | Author: Daniel Winograd-Cort, Matthew Farkas-Dyck 6 | Maintainer: dwincort@gmail.com 7 | homepage: https://github.com/target/row-types 8 | Build-Type: Simple 9 | Cabal-Version: >=1.10 10 | Tested-With: GHC == 8.6.5, GHC == 8.8.3, GHC == 8.10.7, GHC == 9.0.1 11 | Category: Data, Data Structures 12 | Synopsis: Open Records and Variants 13 | Description: 14 | This package uses closed type families and type literals to implement open 15 | records and variants. 16 | The core is based off of the 17 | package, but it also includes polymorphic variants and a number of 18 | additional functions. That said, it is not a proper superset of CTRex as it 19 | specifically forbids records from having more than one element of the same 20 | label. 21 | 22 | extra-source-files: 23 | examples/Examples.lhs 24 | README.md 25 | CHANGELOG.md 26 | LICENSE 27 | NOTICE 28 | 29 | Library 30 | Build-Depends: 31 | base >= 2 && < 6, 32 | constraints >= 0.11, 33 | deepseq >= 1.4, 34 | hashable >= 1.2, 35 | unordered-containers >= 0.2, 36 | generic-lens >= 1.0.0.0, 37 | profunctors >= 5.0, 38 | text 39 | Exposed-modules: 40 | Data.Row 41 | , Data.Row.Internal 42 | , Data.Row.Dictionaries 43 | , Data.Row.Records 44 | , Data.Row.Variants 45 | , Data.Row.Switch 46 | hs-source-dirs: 47 | src 48 | ghc-options: -W 49 | default-language: Haskell2010 50 | default-extensions: 51 | DataKinds 52 | , ExplicitForAll 53 | , GADTs 54 | , OverloadedLabels 55 | , TypeApplications 56 | , TypeOperators 57 | 58 | benchmark perf 59 | type: exitcode-stdio-1.0 60 | main-is: Main.hs 61 | hs-source-dirs: 62 | benchmarks/perf 63 | ghc-options: -W 64 | build-depends: base >= 2 && < 6 65 | , row-types 66 | , deepseq >= 1.4 67 | , gauge >= 0.2.0 68 | default-language: Haskell2010 69 | default-extensions: AllowAmbiguousTypes, 70 | DataKinds, 71 | OverloadedLabels, 72 | RankNTypes, 73 | ScopedTypeVariables, 74 | TypeApplications, 75 | TypeFamilies, 76 | TypeOperators 77 | 78 | test-suite test 79 | type: exitcode-stdio-1.0 80 | main-is: Main.hs 81 | hs-source-dirs: tests, examples 82 | ghc-options: -W +RTS -M1G -RTS 83 | other-modules: Examples, 84 | DiffPerformance, 85 | MergePerformance, 86 | UnionPerformance 87 | build-depends: base >= 2 && < 6 88 | , generic-lens >= 1.1.0.0 89 | , row-types 90 | default-language: Haskell2010 91 | default-extensions: AllowAmbiguousTypes, 92 | DataKinds, 93 | FlexibleContexts, 94 | OverloadedLabels, 95 | PatternSynonyms, 96 | RankNTypes, 97 | ScopedTypeVariables, 98 | TypeApplications, 99 | TypeFamilies, 100 | TypeOperators, 101 | ViewPatterns 102 | 103 | 104 | source-repository head 105 | type: git 106 | location: https://github.com/target/row-types/ 107 | -------------------------------------------------------------------------------- /row-types.cabal.3: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | 3 | Name: row-types 4 | Version: 1.0.1.2 5 | License: MIT 6 | License-file: LICENSE 7 | Author: Daniel Winograd-Cort, Matthew Farkas-Dyck 8 | Maintainer: dwincort@gmail.com 9 | homepage: https://github.com/target/row-types 10 | Build-Type: Simple 11 | Tested-With: GHC == 8.6.5, GHC == 8.8.3, GHC == 8.10.7, GHC == 9.0.1 12 | Category: Data, Data Structures 13 | Synopsis: Open Records and Variants 14 | Description: 15 | This package uses closed type families and type literals to implement open 16 | records and variants. 17 | The core is based off of the 18 | package, but it also includes polymorphic variants and a number of 19 | additional functions. That said, it is not a proper superset of CTRex as it 20 | specifically forbids records from having more than one element of the same 21 | label. 22 | 23 | extra-source-files: 24 | examples/Examples.lhs 25 | README.md 26 | CHANGELOG.md 27 | LICENSE 28 | NOTICE 29 | 30 | 31 | common common-settings 32 | ghc-options: -Wall -Wno-name-shadowing -Wno-type-defaults -Wno-unticked-promoted-constructors 33 | default-extensions: 34 | AllowAmbiguousTypes, 35 | ConstraintKinds, 36 | DataKinds, 37 | EmptyCase, 38 | EmptyDataDecls, 39 | FlexibleContexts, 40 | FlexibleInstances, 41 | GADTs, 42 | InstanceSigs, 43 | KindSignatures, 44 | LambdaCase, 45 | MultiParamTypeClasses, 46 | OverloadedLabels, 47 | PatternGuards, 48 | PatternSynonyms, 49 | PolyKinds, 50 | RankNTypes, 51 | ScopedTypeVariables, 52 | TypeApplications, 53 | TypeFamilies, 54 | TypeOperators, 55 | TupleSections, 56 | ViewPatterns, 57 | UndecidableInstances 58 | 59 | 60 | library 61 | import: common-settings 62 | Build-Depends: 63 | base >= 2 && < 6, 64 | constraints, 65 | deepseq >= 1.4, 66 | generic-lens >= 1.0.0.0, 67 | hashable >= 1.2, 68 | profunctors >= 5.0, 69 | text, 70 | unordered-containers >= 0.2 71 | Exposed-modules: 72 | Data.Row, 73 | Data.Row.Dictionaries, 74 | Data.Row.Internal, 75 | Data.Row.Records, 76 | Data.Row.Variants, 77 | Data.Row.Switch 78 | hs-source-dirs: 79 | src 80 | 81 | 82 | library row-types-aeson 83 | import: common-settings 84 | visibility: public 85 | Build-Depends: 86 | aeson, 87 | base >= 2 && < 6, 88 | row-types, 89 | text 90 | Exposed-modules: 91 | Data.Row.Aeson 92 | hs-source-dirs: 93 | src/aeson 94 | 95 | 96 | library row-types-barbies 97 | import: common-settings 98 | visibility: public 99 | Build-Depends: 100 | barbies, 101 | base >= 2 && < 6, 102 | row-types, 103 | text 104 | Exposed-modules: 105 | Data.Row.Barbies 106 | hs-source-dirs: 107 | src/barbies 108 | 109 | 110 | benchmark perf 111 | import: common-settings 112 | type: exitcode-stdio-1.0 113 | main-is: Main.hs 114 | hs-source-dirs: 115 | benchmarks/perf 116 | build-depends: 117 | base >= 2 && < 6, 118 | row-types, 119 | deepseq >= 1.4, 120 | criterion >= 1.1 121 | 122 | 123 | test-suite test 124 | import: common-settings 125 | type: exitcode-stdio-1.0 126 | main-is: Main.hs 127 | hs-source-dirs: tests, examples 128 | other-modules: Examples 129 | build-depends: 130 | base >= 2 && < 6, 131 | generic-lens >= 1.1.0.0, 132 | row-types 133 | 134 | 135 | source-repository head 136 | type: git 137 | location: https://github.com/target/row-types/ 138 | -------------------------------------------------------------------------------- /src/Data/Row.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Data.Row 6 | -- 7 | -- This module includes a set of common functions for Records and Variants. 8 | -- It includes: 9 | -- 10 | -- * Common constructors, destructors, and querying functions 11 | -- 12 | -- It specifically excludes: 13 | -- 14 | -- * Functions that have the same name for Records and Variants (e.g. 'focus', 15 | -- 'update', 'fromLabels', etc.) 16 | -- 17 | -- * Common clashes with the standard Prelude or other modules (e.g. 'map', 18 | -- 'sequence', 'zip', 'Map', etc.) 19 | -- 20 | -- If these particular functions are needed, they should be brought in qualified 21 | -- from one of the Data.Row.*** modules directly. 22 | -- 23 | ----------------------------------------------------------------------------- 24 | 25 | 26 | module Data.Row 27 | ( 28 | -- * Types and constraints 29 | Label(..) 30 | , KnownSymbol, AllUniqueLabels, WellBehaved 31 | , Var, Rec, Row, Empty, type (≈) 32 | , HasType, Subset, Lacks, type (.\), type (.+) 33 | , type (.\/), type (.\\), type (.//) 34 | , BiForall, Forall, FreeForall, FreeBiForall 35 | , switch, caseon 36 | -- * Record Construction 37 | , empty 38 | , type (.==), (.==), pattern (:==) 39 | -- ** Restriction 40 | , type (.-), (.-) 41 | -- ** Query 42 | , type (.!), (.!) 43 | -- ** Union 44 | , (.+), Disjoint, pattern (:+) 45 | , (.//) 46 | -- * Variant construction 47 | , pattern IsJust 48 | -- ** Expansion 49 | , diversify 50 | -- ** Destruction 51 | , impossible, trial, trial', multiTrial 52 | -- * Labels 53 | , labels 54 | ) 55 | where 56 | 57 | import Data.Row.Dictionaries 58 | import Data.Row.Variants 59 | import Data.Row.Records 60 | import Data.Row.Switch 61 | -------------------------------------------------------------------------------- /src/Data/Row/Dictionaries.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE PolyKinds #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# LANGUAGE TypeOperators #-} 13 | ----------------------------------------------------------------------------- 14 | -- | 15 | -- Module : Data.Row.Dictionaries 16 | -- 17 | -- This module exports various dictionaries that help the type-checker when 18 | -- dealing with row-types. 19 | -- 20 | -- For the various axioms, type variables are consistently in the following order: 21 | -- 22 | -- * Any types that do not belong later. 23 | -- 24 | -- * Labels 25 | -- 26 | -- * Row-types 27 | -- 28 | -- * If applicable, the type in the row-type at the given label goes after 29 | -- each row-type 30 | -- 31 | -- * Constraints 32 | ----------------------------------------------------------------------------- 33 | 34 | 35 | module Data.Row.Dictionaries 36 | ( -- * Axioms 37 | uniqueMap, uniqueAp, uniqueApSingle, uniqueZip 38 | , extendHas, mapHas, apHas, apSingleHas 39 | , mapExtendSwap, apExtendSwap, apSingleExtendSwap, zipExtendSwap 40 | , mapMinJoin, apSingleMinJoin 41 | , FreeForall 42 | , FreeBiForall 43 | , freeForall 44 | , mapForall 45 | , apSingleForall 46 | , subsetJoin, subsetJoin', subsetRestrict, subsetTrans 47 | , mapDifference, apSingleDifference 48 | -- ** Helper Types 49 | , IsA(..) 50 | , As(..) 51 | , ActsOn(..) 52 | , As'(..) 53 | -- * Re-exports 54 | , Dict(..), (:-)(..), HasDict(..), (\\), withDict 55 | , Unconstrained, Unconstrained1, Unconstrained2 56 | 57 | ) 58 | where 59 | 60 | import Data.Constraint 61 | import Data.Functor.Const 62 | import Data.Proxy 63 | import qualified Unsafe.Coerce as UNSAFE 64 | import GHC.TypeLits 65 | 66 | import Data.Row.Internal 67 | 68 | 69 | 70 | -- | This data type is used to for its ability to existentially bind a type 71 | -- variable. Particularly, it says that for the type 'a', there exists a 't' 72 | -- such that @a ~ f t@ and @c t@ holds. 73 | data As c f a where 74 | As :: forall c f a t. (a ~ f t, c t) => As c f a 75 | 76 | -- | A class to capture the idea of 'As' so that it can be partially applied in 77 | -- a context. 78 | class IsA c f a where 79 | as :: As c f a 80 | 81 | instance c a => IsA c f (f a) where 82 | as = As 83 | 84 | -- | Like 'As', but here we know the underlying value is some 'f' applied to the 85 | -- given type 'a'. 86 | data As' c t a where 87 | As' :: forall c f a t. (a ~ f t, c f) => As' c t a 88 | 89 | -- | A class to capture the idea of 'As'' so that it can be partially applied in 90 | -- a context. 91 | class ActsOn c t a where 92 | actsOn :: As' c t a 93 | 94 | instance c f => ActsOn c t (f t) where 95 | actsOn = As' 96 | 97 | -- | An internal type used by the 'metamorph' in 'mapForall'. 98 | newtype MapForall c f (r :: Row k) = MapForall { unMapForall :: Dict (Forall (Map f r) (IsA c f)) } 99 | 100 | -- | An internal type used by the 'metamorph' in 'apSingleForall'. 101 | newtype ApSingleForall c a (fs :: Row (k -> k')) = ApSingleForall 102 | { unApSingleForall :: Dict (Forall (ApSingle fs a) (ActsOn c a)) } 103 | 104 | -- | This allows us to derive a @Forall (Map f r) ..@ from a @Forall r ..@. 105 | mapForall :: forall f ρ c. Forall ρ c :- Forall (Map f ρ) (IsA c f) 106 | mapForall = Sub $ unMapForall $ metamorph @_ @ρ @c @Const @Proxy @(MapForall c f) @Proxy Proxy empty uncons cons $ Proxy 107 | where empty _ = MapForall Dict 108 | uncons _ _ = Const Proxy 109 | cons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ, FrontExtends ℓ τ ρ, AllUniqueLabels (Extend ℓ τ ρ)) 110 | => Label ℓ -> Const (MapForall c f ρ) (Proxy τ) 111 | -> MapForall c f (Extend ℓ τ ρ) 112 | cons _ (Const (MapForall Dict)) = case frontExtendsDict @ℓ @τ @ρ of 113 | FrontExtendsDict Dict -> MapForall Dict 114 | \\ mapExtendSwap @f @ℓ @τ @ρ 115 | \\ uniqueMap @f @(Extend ℓ τ ρ) 116 | 117 | -- | This allows us to derive a @Forall (ApSingle f r) ..@ from a @Forall f ..@. 118 | apSingleForall :: forall a fs c. Forall fs c :- Forall (ApSingle fs a) (ActsOn c a) 119 | apSingleForall = Sub $ unApSingleForall $ metamorph @_ @fs @c @Const @Proxy @(ApSingleForall c a) @Proxy Proxy empty uncons cons $ Proxy 120 | where empty _ = ApSingleForall Dict 121 | uncons _ _ = Const Proxy 122 | cons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ, FrontExtends ℓ τ ρ, AllUniqueLabels (Extend ℓ τ ρ)) 123 | => Label ℓ -> Const (ApSingleForall c a ρ) (Proxy τ) 124 | -> ApSingleForall c a (Extend ℓ τ ρ) 125 | cons _ (Const (ApSingleForall Dict)) = case frontExtendsDict @ℓ @τ @ρ of 126 | FrontExtendsDict Dict -> ApSingleForall Dict 127 | \\ apSingleExtendSwap @a @ℓ @τ @ρ 128 | \\ uniqueApSingle @a @(Extend ℓ τ ρ) 129 | 130 | -- | Allow any 'Forall' over a row-type, be usable for 'Unconstrained1'. 131 | freeForall :: forall r c. Forall r c :- Forall r Unconstrained1 132 | freeForall = Sub $ UNSAFE.unsafeCoerce @(Dict (Forall r c)) Dict 133 | 134 | -- | `FreeForall` can be used when a `Forall` constraint is necessary but there 135 | -- is no particular constraint we care about. 136 | type FreeForall r = Forall r Unconstrained1 137 | 138 | -- | `FreeForall` can be used when a `BiForall` constraint is necessary but 139 | -- there is no particular constraint we care about. 140 | type FreeBiForall r1 r2 = BiForall r1 r2 Unconstrained2 141 | 142 | -- | If we know that 'r' has been extended with @l .== t@, then we know that this 143 | -- extension at the label 'l' must be 't'. 144 | extendHas :: forall l t r. Dict (Extend l t r .! l ≈ t) 145 | extendHas = UNSAFE.unsafeCoerce $ Dict @Unconstrained 146 | 147 | -- | This allows us to derive @Map f r .! l ≈ f t@ from @r .! l ≈ t@ 148 | mapHas :: forall f l t r. (r .! l ≈ t) :- (Map f r .! l ≈ f t, Map f r .- l ≈ Map f (r .- l)) 149 | mapHas = Sub $ UNSAFE.unsafeCoerce $ Dict @(Unconstrained, Unconstrained) 150 | 151 | -- | This allows us to derive @Ap ϕ ρ .! l ≈ f t@ from @ϕ .! l ≈ f@ and @ρ .! l ≈ t@ 152 | apHas :: forall l f ϕ t ρ. (ϕ .! l ≈ f, ρ .! l ≈ t) :- (Ap ϕ ρ .! l ≈ f t, Ap ϕ ρ .- l ≈ Ap (ϕ .- l) (ρ .- l)) 153 | apHas = Sub $ UNSAFE.unsafeCoerce $ Dict @(Unconstrained, Unconstrained) 154 | 155 | -- | This allows us to derive @ApSingle r x .! l ≈ f x@ from @r .! l ≈ f@ 156 | apSingleHas :: forall x l f r. (r .! l ≈ f) :- (ApSingle r x .! l ≈ f x, ApSingle r x .- l ≈ ApSingle (r .- l) x) 157 | apSingleHas = Sub $ UNSAFE.unsafeCoerce $ Dict @(Unconstrained, Unconstrained) 158 | 159 | -- | Proof that the 'Map' type family preserves labels and their ordering. 160 | mapExtendSwap :: forall f ℓ τ r. Dict (Extend ℓ (f τ) (Map f r) ≈ Map f (Extend ℓ τ r)) 161 | mapExtendSwap = UNSAFE.unsafeCoerce $ Dict @Unconstrained 162 | 163 | -- | Proof that the 'Ap' type family preserves labels and their ordering. 164 | apExtendSwap :: forall ℓ f fs τ r. Dict (Extend ℓ (f τ) (Ap fs r) ≈ Ap (Extend ℓ f fs) (Extend ℓ τ r)) 165 | apExtendSwap = UNSAFE.unsafeCoerce $ Dict @Unconstrained 166 | 167 | -- | Proof that the 'ApSingle' type family preserves labels and their ordering. 168 | apSingleExtendSwap :: forall τ ℓ f r. Dict (Extend ℓ (f τ) (ApSingle r τ) ≈ ApSingle (Extend ℓ f r) τ) 169 | apSingleExtendSwap = UNSAFE.unsafeCoerce $ Dict @Unconstrained 170 | 171 | -- | Proof that the 'Ap' type family preserves labels and their ordering. 172 | zipExtendSwap :: forall ℓ τ1 r1 τ2 r2. Dict (Extend ℓ (τ1, τ2) (Zip r1 r2) ≈ Zip (Extend ℓ τ1 r1) (Extend ℓ τ2 r2)) 173 | zipExtendSwap = UNSAFE.unsafeCoerce $ Dict @Unconstrained 174 | 175 | -- | Map preserves uniqueness of labels. 176 | uniqueMap :: forall f r. Dict (AllUniqueLabels (Map f r) ≈ AllUniqueLabels r) 177 | uniqueMap = UNSAFE.unsafeCoerce $ Dict @Unconstrained 178 | 179 | -- | Ap preserves uniqueness of labels. 180 | uniqueAp :: forall fs r. Dict (AllUniqueLabels (Ap fs r) ≈ AllUniqueLabels r) 181 | uniqueAp = UNSAFE.unsafeCoerce $ Dict @Unconstrained 182 | 183 | -- | ApSingle preserves uniqueness of labels. 184 | uniqueApSingle :: forall x r. Dict (AllUniqueLabels (ApSingle r x) ≈ AllUniqueLabels r) 185 | uniqueApSingle = UNSAFE.unsafeCoerce $ Dict @Unconstrained 186 | 187 | -- | Zip preserves uniqueness of labels. 188 | uniqueZip :: forall r1 r2. Dict (AllUniqueLabels (Zip r1 r2) ≈ (AllUniqueLabels r1, AllUniqueLabels r2)) 189 | uniqueZip = UNSAFE.unsafeCoerce $ Dict @(Unconstrained, Unconstrained) 190 | 191 | -- | Map distributes over MinJoin 192 | mapMinJoin :: forall f r r'. Dict (Map f r .\/ Map f r' ≈ Map f (r .\/ r')) 193 | mapMinJoin = UNSAFE.unsafeCoerce $ Dict @Unconstrained 194 | 195 | -- | ApSingle distributes over MinJoin 196 | apSingleMinJoin :: forall r r' x. Dict (ApSingle r x .\/ ApSingle r' x ≈ ApSingle (r .\/ r') x) 197 | apSingleMinJoin = UNSAFE.unsafeCoerce $ Dict @Unconstrained 198 | 199 | -- | Two rows are subsets of a third if and only if their disjoint union is a 200 | -- subset of that third. 201 | subsetJoin :: forall r1 r2 s. Dict ((Subset r1 s, Subset r2 s) ≈ (Subset (r1 .+ r2) s)) 202 | subsetJoin = UNSAFE.unsafeCoerce $ Dict @Unconstrained 203 | 204 | -- | If two rows are each subsets of a third, their join is a subset of the third 205 | subsetJoin' :: forall r1 r2 s. Dict ((Subset r1 s, Subset r2 s) ≈ (Subset (r1 .// r2) s)) 206 | subsetJoin' = UNSAFE.unsafeCoerce $ Dict @Unconstrained 207 | 208 | -- | If a row is a subset of another, then its restriction is also a subset of the other 209 | subsetRestrict :: forall r s l. (Subset r s) :- (Subset (r .- l) s) 210 | subsetRestrict = Sub $ UNSAFE.unsafeCoerce $ Dict @Unconstrained 211 | 212 | -- | Subset is transitive 213 | subsetTrans :: forall r1 r2 r3. (Subset r1 r2, Subset r2 r3) :- (Subset r1 r3) 214 | subsetTrans = Sub $ UNSAFE.unsafeCoerce $ Dict @Unconstrained 215 | 216 | -- | Map distributes over Difference 217 | mapDifference :: forall f r r'. Dict (Map f r .\\ Map f r' ≈ Map f (r .\\ r')) 218 | mapDifference = UNSAFE.unsafeCoerce $ Dict @Unconstrained 219 | 220 | -- | ApSingle distributes over Difference 221 | apSingleDifference :: forall r r' x. Dict (ApSingle r x .\\ ApSingle r' x ≈ ApSingle (r .\\ r') x) 222 | apSingleDifference = UNSAFE.unsafeCoerce $ Dict @Unconstrained 223 | 224 | -- differenceForall :: forall r r' c. Forall r c :- Forall (r .\\ r') c 225 | -------------------------------------------------------------------------------- /src/Data/Row/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE AllowAmbiguousTypes #-} 3 | {-# LANGUAGE ConstraintKinds #-} 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE GADTs #-} 8 | {-# LANGUAGE InstanceSigs #-} 9 | {-# LANGUAGE MultiParamTypeClasses #-} 10 | {-# LANGUAGE PolyKinds #-} 11 | {-# LANGUAGE RankNTypes #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | {-# LANGUAGE TypeOperators #-} 15 | {-# LANGUAGE UndecidableInstances #-} 16 | {-# LANGUAGE UndecidableSuperClasses #-} 17 | ----------------------------------------------------------------------------- 18 | -- | 19 | -- Module : Data.Row.Internal 20 | -- 21 | -- This module implements the internals of open records and variants. 22 | -- 23 | ----------------------------------------------------------------------------- 24 | 25 | 26 | module Data.Row.Internal 27 | ( 28 | -- * Rows 29 | Row(..) 30 | , Label(..) 31 | , KnownSymbol 32 | , LT(..) 33 | , Empty 34 | , HideType(..) 35 | -- * Row Operations 36 | , Extend, Modify, Rename 37 | , type (.==), type (.!), type (.-), type (.\\) 38 | -- $merges 39 | , type (.+), type (.\/), type (.//) 40 | -- * Row Constraints 41 | , Lacks, type (.\), HasType 42 | , Forall(..) 43 | , BiForall(..) 44 | , BiConstraint 45 | , Unconstrained 46 | , Unconstrained1 47 | , Unconstrained2 48 | , FrontExtends(..) 49 | , FrontExtendsDict(..) 50 | , WellBehaved, AllUniqueLabels 51 | , Ap, ApSingle, Zip, Map, Subset, Disjoint 52 | -- * Helper functions 53 | , Labels, labels, labels' 54 | , show' 55 | , toKey 56 | , type (≈) 57 | ) 58 | where 59 | 60 | import Data.Bifunctor (Bifunctor(..)) 61 | import Data.Constraint 62 | import Data.Functor.Const 63 | import Data.Proxy 64 | import Data.String (IsString (fromString)) 65 | import Data.Text (Text) 66 | import qualified Data.Text as Text 67 | import Data.Type.Equality (type (==)) 68 | 69 | import GHC.OverloadedLabels 70 | import GHC.TypeLits 71 | import qualified GHC.TypeLits as TL 72 | 73 | 74 | 75 | 76 | {-------------------------------------------------------------------- 77 | Rows 78 | --------------------------------------------------------------------} 79 | -- | The kind of rows. This type is only used as a datakind. A row is a typelevel entity telling us 80 | -- which symbols are associated with which types. 81 | newtype Row a = R [LT a] 82 | -- ^ A row is a list of symbol-to-type pairs that should always be sorted 83 | -- lexically by the symbol. 84 | -- The constructor is exported here (because this is an internal module) but 85 | -- should not be exported elsewhere. 86 | 87 | -- | The kind of elements of rows. Each element is a label and its associated type. 88 | data LT a = Symbol :-> a 89 | 90 | 91 | -- | A label 92 | data Label (s :: Symbol) = Label 93 | deriving (Eq) 94 | 95 | instance KnownSymbol s => Show (Label s) where 96 | show = symbolVal 97 | 98 | instance x ≈ y => IsLabel x (Label y) where 99 | #if __GLASGOW_HASKELL__ >= 802 100 | fromLabel = Label 101 | #else 102 | fromLabel _ = Label 103 | #endif 104 | 105 | -- | A helper function for showing labels 106 | show' :: (IsString s, Show a) => a -> s 107 | show' = fromString . show 108 | 109 | -- | A helper function to turn a Label directly into 'Text'. 110 | toKey :: forall s. KnownSymbol s => Label s -> Text 111 | toKey = Text.pack . symbolVal 112 | 113 | -- | Type level version of 'empty' 114 | type Empty = R '[] 115 | 116 | -- | Elements stored in a Row type are usually hidden. 117 | data HideType where 118 | HideType :: a -> HideType 119 | 120 | 121 | 122 | {-------------------------------------------------------------------- 123 | Row operations 124 | --------------------------------------------------------------------} 125 | 126 | infixl 4 .\ {- This comment needed to appease CPP -} 127 | -- | Does the row lack (i.e. it does not have) the specified label? 128 | type family (r :: Row k) .\ (l :: Symbol) :: Constraint where 129 | R '[] .\ l = Unconstrained 130 | R r .\ l = LacksR l r r 131 | 132 | -- | Type level Row extension 133 | type family Extend (l :: Symbol) (a :: k) (r :: Row k) :: Row k where 134 | Extend l a (R '[]) = R (l :-> a ': '[]) 135 | Extend l a (R x) = R (Inject (l :-> a) x) 136 | 137 | -- | Type level Row modification 138 | type family Modify (l :: Symbol) (a :: k) (r :: Row k) :: Row k where 139 | Modify l a (R ρ) = R (ModifyR l a ρ) 140 | 141 | -- | Type level row renaming 142 | type family Rename (l :: Symbol) (l' :: Symbol) (r :: Row k) :: Row k where 143 | Rename l l' r = Extend l' (r .! l) (r .- l) 144 | 145 | infixl 5 .! 146 | -- | Type level label fetching 147 | type family (r :: Row k) .! (t :: Symbol) :: k where 148 | R r .! l = Get l r 149 | 150 | infixl 6 .- 151 | -- | Type level Row element removal 152 | type family (r :: Row k) .- (s :: Symbol) :: Row k where 153 | R r .- l = R (Remove l r) 154 | 155 | infixl 6 .\\ {- This comment needed to appease CPP -} 156 | -- | Type level Row difference. That is, @l '.\\' r@ is the row remaining after 157 | -- removing any matching elements of @r@ from @l@. 158 | type family (l :: Row k) .\\ (r :: Row k) :: Row k where 159 | R l .\\ R r = R (Diff l r) 160 | 161 | -- $merges 162 | -- == Various row-type merges 163 | -- The difference between '.+' (read "append"), '.\/' (read "min-join"), and 164 | -- '.\\' (read "const-union") comes down to how duplicates are handled. 165 | -- In '.+', the two given row-types must be entirely unique. Even the same 166 | -- entry in both row-types is forbidden. In '.\/', this final restriction is 167 | -- relaxed, allowing two row-types that have no conflicts to be merged in the 168 | -- logical way. The '.\\' operator is the most liberal, allowing any two row-types 169 | -- to be merged together, and whenever there is a conflict, favoring the left argument. 170 | -- 171 | -- As examples of use: 172 | -- 173 | -- - '.+' is used when appending two records, assuring that those two records are 174 | -- entirely disjoint. 175 | -- 176 | -- - '.\/' is used when diversifying a variant, allowing some extension to the 177 | -- row-type so long as no original types have changed. 178 | -- 179 | -- - './/' is used when doing record overwrite, allowing data in a record to 180 | -- totally overwrite what was previously there. 181 | 182 | infixl 6 .+ 183 | -- | Type level Row append 184 | type family (l :: Row k) .+ (r :: Row k) :: Row k where 185 | x .+ R '[] = x 186 | R '[] .+ y = y 187 | x .+ R '[l :-> a] = Extend l a x 188 | R '[l :-> a] .+ y = Extend l a y 189 | R l .+ R r = R (Merge l r) 190 | 191 | infixl 6 .\/ 192 | -- | The minimum join of the two rows. 193 | type family (l :: Row k) .\/ (r :: Row k) where 194 | x .\/ R '[] = x 195 | R '[] .\/ y = y 196 | R l .\/ R r = R (MinJoinR l r) 197 | 198 | infixl 6 .// 199 | -- | The overwriting union, where the left row overwrites the types of the right 200 | -- row where the labels overlap. 201 | type family (l :: Row k) .// (r :: Row k) where 202 | x .// R '[] = x 203 | R '[] .// y = y 204 | R l .// R r = R (ConstUnionR l r) 205 | 206 | 207 | {-------------------------------------------------------------------- 208 | Syntactic sugar for record operations 209 | --------------------------------------------------------------------} 210 | -- | Alias for '.\'. It is a class rather than an alias, so that 211 | -- it can be partially applied. 212 | class Lacks (l :: Symbol) (r :: Row *) 213 | instance (r .\ l) => Lacks l r 214 | 215 | 216 | -- | Alias for @(r .! l) ≈ a@. It is a class rather than an alias, so that 217 | -- it can be partially applied. 218 | class (r .! l ≈ a) => HasType l a r 219 | instance (r .! l ≈ a) => HasType l a r 220 | 221 | -- | A type level way to create a singleton Row. 222 | infix 7 .== 223 | type (l :: Symbol) .== (a :: k) = Extend l a Empty 224 | 225 | 226 | {-------------------------------------------------------------------- 227 | Constrained record operations 228 | --------------------------------------------------------------------} 229 | 230 | -- | A dictionary of information that proves that extending a row-type @r@ with 231 | -- a label @l@ will necessarily put it to the front of the underlying row-type 232 | -- list. This is quite internal and should not generally be necessary. 233 | data FrontExtendsDict l t r = forall ρ. FrontExtendsDict (Dict (r ~ R ρ, R (l :-> t ': ρ) ≈ Extend l t (R ρ), AllUniqueLabelsR (l :-> t ': ρ))) 234 | 235 | -- | A class wrapper for 'FrontExtendsDict'. 236 | class FrontExtends l t r where 237 | frontExtendsDict :: FrontExtendsDict l t r 238 | 239 | instance (r ~ R ρ, R (l :-> t ': ρ) ≈ Extend l t (R ρ), AllUniqueLabelsR (l :-> t ': ρ)) => FrontExtends l t r where 240 | frontExtendsDict = FrontExtendsDict Dict 241 | 242 | 243 | -- | Any structure over a row in which every element is similarly constrained can 244 | -- be metamorphized into another structure over the same row. 245 | class Forall (r :: Row k) (c :: k -> Constraint) where 246 | -- | A metamorphism is an anamorphism (an unfold) followed by a catamorphism (a fold). 247 | -- The parameter 'p' describes the output of the unfold and the input of the fold. 248 | -- For records, @p = (,)@, because every entry in the row will unfold to a value paired 249 | -- with the rest of the record. 250 | -- For variants, @p = Either@, because there will either be a value or future types to 251 | -- explore. 252 | -- 'Const' can be useful when the types in the row are unnecessary. 253 | metamorph :: forall (p :: * -> * -> *) (f :: Row k -> *) (g :: Row k -> *) (h :: k -> *). Bifunctor p 254 | => Proxy (Proxy h, Proxy p) 255 | -> (f Empty -> g Empty) 256 | -- ^ The way to transform the empty element 257 | -> (forall ℓ τ ρ. (KnownSymbol ℓ, c τ, HasType ℓ τ ρ) 258 | => Label ℓ -> f ρ -> p (f (ρ .- ℓ)) (h τ)) 259 | -- ^ The unfold 260 | -> (forall ℓ τ ρ. (KnownSymbol ℓ, c τ, FrontExtends ℓ τ ρ, AllUniqueLabels (Extend ℓ τ ρ)) 261 | => Label ℓ -> p (g ρ) (h τ) -> g (Extend ℓ τ ρ)) 262 | -- ^ The fold 263 | -> f r -- ^ The input structure 264 | -> g r 265 | 266 | instance Forall (R '[]) c where 267 | {-# INLINE metamorph #-} 268 | metamorph _ empty _ _ = empty 269 | 270 | instance (KnownSymbol ℓ, c τ, Forall ('R ρ) c, FrontExtends ℓ τ ('R ρ), AllUniqueLabels (Extend ℓ τ ('R ρ))) => Forall ('R (ℓ :-> τ ': ρ) :: Row k) c where 271 | {-# INLINE metamorph #-} 272 | metamorph h empty uncons cons = case frontExtendsDict @ℓ @τ @('R ρ) of 273 | FrontExtendsDict Dict -> 274 | cons (Label @ℓ) . first (metamorph @_ @('R ρ) @c h empty uncons cons) . uncons (Label @ℓ) 275 | 276 | 277 | -- | Any structure over two rows in which the elements of each row satisfy some 278 | -- constraints can be metamorphized into another structure over both of the 279 | -- rows. 280 | class BiForall (r1 :: Row k1) (r2 :: Row k2) (c :: k1 -> k2 -> Constraint) where 281 | -- | A metamorphism is an anamorphism (an unfold) followed by a catamorphism (a fold). 282 | biMetamorph :: forall (p :: * -> * -> *) (f :: Row k1 -> Row k2 -> *) (g :: Row k1 -> Row k2 -> *) 283 | (h :: k1 -> k2 -> *). Bifunctor p 284 | => Proxy (Proxy h, Proxy p) 285 | -> (f Empty Empty -> g Empty Empty) 286 | -> (forall ℓ τ1 τ2 ρ1 ρ2. (KnownSymbol ℓ, c τ1 τ2, HasType ℓ τ1 ρ1, HasType ℓ τ2 ρ2) 287 | => Label ℓ -> f ρ1 ρ2 -> p (f (ρ1 .- ℓ) (ρ2 .- ℓ)) (h τ1 τ2)) 288 | -> (forall ℓ τ1 τ2 ρ1 ρ2. (KnownSymbol ℓ, c τ1 τ2, FrontExtends ℓ τ1 ρ1, FrontExtends ℓ τ2 ρ2, AllUniqueLabels (Extend ℓ τ1 ρ1), AllUniqueLabels (Extend ℓ τ2 ρ2)) 289 | => Label ℓ -> p (g ρ1 ρ2) (h τ1 τ2) -> g (Extend ℓ τ1 ρ1) (Extend ℓ τ2 ρ2)) 290 | -> f r1 r2 -> g r1 r2 291 | 292 | 293 | instance BiForall (R '[]) (R '[]) c1 where 294 | {-# INLINE biMetamorph #-} 295 | biMetamorph _ empty _ _ = empty 296 | 297 | instance (KnownSymbol ℓ, c τ1 τ2, BiForall ('R ρ1) ('R ρ2) c, FrontExtends ℓ τ1 ('R ρ1), FrontExtends ℓ τ2 ('R ρ2), AllUniqueLabels (Extend ℓ τ1 ('R ρ1)), AllUniqueLabels (Extend ℓ τ2 ('R ρ2))) 298 | => BiForall ('R (ℓ :-> τ1 ': ρ1)) ('R (ℓ :-> τ2 ': ρ2)) c where 299 | {-# INLINE biMetamorph #-} 300 | biMetamorph h empty uncons cons = case (frontExtendsDict @ℓ @τ1 @('R ρ1), frontExtendsDict @ℓ @τ2 @('R ρ2)) of 301 | (FrontExtendsDict Dict, FrontExtendsDict Dict) -> 302 | cons (Label @ℓ) . first (biMetamorph @_ @_ @('R ρ1) @('R ρ2) @c h empty uncons cons) . uncons (Label @ℓ) 303 | 304 | 305 | -- | A null constraint 306 | class Unconstrained 307 | instance Unconstrained 308 | 309 | -- | A null constraint of one argument 310 | class Unconstrained1 a 311 | instance Unconstrained1 a 312 | 313 | -- | A null constraint of two arguments 314 | class Unconstrained2 a b 315 | instance Unconstrained2 a b 316 | 317 | -- | A pair of constraints 318 | class (c1 x, c2 y) => BiConstraint c1 c2 x y 319 | instance (c1 x, c2 y) => BiConstraint c1 c2 x y 320 | 321 | -- | The labels in a Row. 322 | type family Labels (r :: Row a) where 323 | Labels (R '[]) = '[] 324 | Labels (R (l :-> a ': xs)) = l ': Labels (R xs) 325 | 326 | -- | Return a list of the labels in a row type. 327 | labels :: forall ρ c s. (IsString s, Forall ρ c) => [s] 328 | labels = getConst $ metamorph @_ @ρ @c @Const @(Const ()) @(Const [s]) @Proxy Proxy (const $ Const []) doUncons doCons (Const ()) 329 | where doUncons _ _ = Const $ Const () 330 | doCons l (Const (Const c)) = Const $ show' l : c 331 | 332 | -- | Return a list of the labels in a row type and is specialized to the 'Unconstrained1' constraint. 333 | labels' :: forall ρ s. (IsString s, Forall ρ Unconstrained1) => [s] 334 | labels' = labels @ρ @Unconstrained1 335 | 336 | 337 | {-------------------------------------------------------------------- 338 | Convenient type families and classes 339 | --------------------------------------------------------------------} 340 | 341 | -- | A convenient way to provide common, easy constraints 342 | type WellBehaved ρ = (Forall ρ Unconstrained1, AllUniqueLabels ρ) 343 | 344 | -- | Are all of the labels in this Row unique? 345 | type family AllUniqueLabels (r :: Row k) :: Constraint where 346 | AllUniqueLabels (R r) = AllUniqueLabelsR r 347 | 348 | type family AllUniqueLabelsR (r :: [LT k]) :: Constraint where 349 | AllUniqueLabelsR '[] = Unconstrained 350 | AllUniqueLabelsR '[l :-> a] = Unconstrained 351 | AllUniqueLabelsR (l :-> a ': l :-> b ': _) = TypeError 352 | (TL.Text "The label " :<>: ShowType l :<>: TL.Text " is not unique." 353 | :$$: TL.Text "It is assigned to both " :<>: ShowType a :<>: TL.Text " and " :<>: ShowType b) 354 | AllUniqueLabelsR (l :-> a ': l' :-> b ': r) = AllUniqueLabelsR (l' :-> b ': r) 355 | 356 | -- | Is the first row a subset of the second? 357 | -- Or, does the second row contain every binding that the first one does? 358 | type family Subset (r1 :: Row k) (r2 :: Row k) :: Constraint where 359 | Subset ('R '[]) r = Unconstrained 360 | Subset ('R (l ':-> a ': x)) r = (r .! l ≈ a, Subset ('R x) r) 361 | 362 | -- | A type synonym for disjointness. 363 | type Disjoint l r = ( WellBehaved l 364 | , WellBehaved r 365 | , Subset l (l .+ r) 366 | , Subset r (l .+ r) 367 | , l .+ r .\\ l ≈ r 368 | , l .+ r .\\ r ≈ l) 369 | 370 | -- | Map a type level function over a Row. 371 | type family Map (f :: a -> b) (r :: Row a) :: Row b where 372 | Map f (R r) = R (MapR f r) 373 | 374 | type family MapR (f :: a -> b) (r :: [LT a]) :: [LT b] where 375 | MapR f '[] = '[] 376 | MapR f (l :-> v ': t) = l :-> f v ': MapR f t 377 | 378 | -- | Take two rows with the same labels, and apply the type operator from the 379 | -- first row to the type of the second. 380 | type family Ap (fs :: Row (a -> b)) (r :: Row a) :: Row b where 381 | Ap (R fs) (R r) = R (ApR fs r) 382 | 383 | type family ApR (fs :: [LT (a -> b)]) (r :: [LT a]) :: [LT b] where 384 | ApR '[] '[] = '[] 385 | ApR (l :-> f ': tf) (l :-> v ': tv) = l :-> f v ': ApR tf tv 386 | ApR _ _ = TypeError (TL.Text "Row types with different label sets cannot be App'd together.") 387 | 388 | -- | Take a row of type operators and apply each to the second argument. 389 | type family ApSingle (fs :: Row (a -> b)) (x :: a) :: Row b where 390 | ApSingle (R fs) x = R (ApSingleR fs x) 391 | 392 | type family ApSingleR (fs :: [LT (a -> b)]) (x :: a) :: [LT b] where 393 | ApSingleR '[] _ = '[] 394 | ApSingleR (l ':-> f ': fs) x = l ':-> f x ': ApSingleR fs x 395 | 396 | -- | Zips two rows together to create a Row of the pairs. 397 | -- The two rows must have the same set of labels. 398 | type family Zip (r1 :: Row *) (r2 :: Row *) where 399 | Zip (R r1) (R r2) = R (ZipR r1 r2) 400 | 401 | type family ZipR (r1 :: [LT *]) (r2 :: [LT *]) where 402 | ZipR '[] '[] = '[] 403 | ZipR (l :-> t1 ': r1) (l :-> t2 ': r2) = 404 | l :-> (t1, t2) ': ZipR r1 r2 405 | ZipR (l :-> t1 ': r1) _ = TypeError (TL.Text "Row types with different label sets cannot be zipped" 406 | :$$: TL.Text "For one, the label " :<>: ShowType l :<>: TL.Text " is not in both lists.") 407 | ZipR '[] (l :-> t ': r) = TypeError (TL.Text "Row types with different label sets cannot be zipped" 408 | :$$: TL.Text "For one, the label " :<>: ShowType l :<>: TL.Text " is not in both lists.") 409 | 410 | type family Inject (l :: LT k) (r :: [LT k]) where 411 | Inject (l :-> t) '[] = (l :-> t ': '[]) 412 | Inject (l :-> t) (l :-> t' ': x) = TypeError (TL.Text "Cannot inject a label into a row type that already has that label" 413 | :$$: TL.Text "The label " :<>: ShowType l :<>: TL.Text " was already assigned the type " 414 | :<>: ShowType t' :<>: TL.Text " and is now trying to be assigned the type " 415 | :<>: ShowType t :<>: TL.Text ".") 416 | Inject (l :-> t) (l' :-> t' ': x) = 417 | Ifte (l <=.? l') 418 | (l :-> t ': l' :-> t' ': x) 419 | (l' :-> t' ': Inject (l :-> t) x) 420 | 421 | -- | Type level Row modification helper 422 | type family ModifyR (l :: Symbol) (a :: k) (ρ :: [LT k]) :: [LT k] where 423 | ModifyR l a (l :-> a' ': ρ) = l :-> a ': ρ 424 | ModifyR l a (l' :-> a' ': ρ) = l' :-> a' ': ModifyR l a ρ 425 | ModifyR l a '[] = TypeError (TL.Text "Tried to modify the label " :<>: ShowType l 426 | :<>: TL.Text ", but it does not appear in the row-type.") 427 | 428 | type family Ifte (c :: Bool) (t :: k) (f :: k) where 429 | Ifte True t f = t 430 | Ifte False t f = f 431 | 432 | type family Get (l :: Symbol) (r :: [LT k]) where 433 | Get l '[] = TypeError (TL.Text "No such field: " :<>: ShowType l) 434 | Get l (l :-> t ': x) = t 435 | Get l (l' :-> t ': x) = Get l x 436 | 437 | type family Remove (l :: Symbol) (r :: [LT k]) where 438 | Remove l r = RemoveT l r r 439 | 440 | type family RemoveT (l :: Symbol) (r :: [LT k]) (r_orig :: [LT k]) where 441 | RemoveT l (l :-> t ': x) _ = x 442 | RemoveT l (l' :-> t ': x) r = l' :-> t ': RemoveT l x r 443 | RemoveT l '[] r = TypeError (TL.Text "Cannot remove a label that does not occur in the row type." 444 | :$$: TL.Text "The label " :<>: ShowType l :<>: TL.Text " is not in " 445 | :<>: ShowRowType r) 446 | 447 | type family LacksR (l :: Symbol) (r :: [LT k]) (r_orig :: [LT k]) :: Constraint where 448 | LacksR l '[] _ = Unconstrained 449 | LacksR l (l :-> t ': x) r = TypeError (TL.Text "The label " :<>: ShowType l 450 | :<>: TL.Text " already exists in " :<>: ShowRowType r) 451 | LacksR l (l' :-> _ ': x) r = Ifte (l <=.? l') Unconstrained (LacksR l x r) 452 | 453 | 454 | type family Merge (l :: [LT k]) (r :: [LT k]) where 455 | Merge '[] r = r 456 | Merge l '[] = l 457 | Merge (h :-> a ': tl) (h :-> a ': tr) = 458 | TypeError (TL.Text "The label " :<>: ShowType h :<>: TL.Text " (of type " 459 | :$$: ShowType a :<>: TL.Text ") has duplicate assignments.") 460 | Merge (h :-> a ': tl) (h :-> b ': tr) = 461 | TypeError (TL.Text "The label " :<>: ShowType h :<>: TL.Text " has conflicting assignments." 462 | :$$: TL.Text "Its type is both " :<>: ShowType a :<>: TL.Text " and " :<>: ShowType b :<>: TL.Text ".") 463 | Merge (hl :-> al ': tl) (hr :-> ar ': tr) = 464 | -- Using Ifte here makes GHC blow up on nested unions with many overlapping keys. 465 | MergeCont (CmpSymbol hl hr) hl al tl hr ar tr 466 | 467 | type family MergeCont (cmp :: Ordering) (hl :: Symbol) (al :: k) (tl :: [LT k]) 468 | (hr :: Symbol) (ar :: k) (tr :: [LT k]) where 469 | MergeCont 'LT hl al tl hr ar tr = (hl :-> al ': Merge tl (hr :-> ar ': tr)) 470 | MergeCont _ hl al tl hr ar tr = (hr :-> ar ': Merge (hl :-> al ': tl) tr) 471 | 472 | type family MinJoinR (l :: [LT k]) (r :: [LT k]) where 473 | MinJoinR '[] r = r 474 | MinJoinR l '[] = l 475 | MinJoinR (h :-> a ': tl) (h :-> a ': tr) = 476 | (h :-> a ': MinJoinR tl tr) 477 | MinJoinR (h :-> a ': tl) (h :-> b ': tr) = 478 | TypeError (TL.Text "The label " :<>: ShowType h :<>: TL.Text " has conflicting assignments." 479 | :$$: TL.Text "Its type is both " :<>: ShowType a :<>: TL.Text " and " :<>: ShowType b :<>: TL.Text ".") 480 | MinJoinR (hl :-> al ': tl) (hr :-> ar ': tr) = 481 | -- Using Ifte here makes GHC blow up on nested unions with many overlapping keys. 482 | MinJoinRCase (CmpSymbol hl hr) hl al tl hr ar tr 483 | 484 | type family MinJoinRCase (cmp :: Ordering) (hl :: Symbol) (al :: k) (tl :: [LT k]) 485 | (hr :: Symbol) (ar :: k) (tr :: [LT k]) where 486 | MinJoinRCase 'LT hl al tl hr ar tr = hl :-> al ': MinJoinR tl (hr :-> ar ': tr) 487 | MinJoinRCase _ hl al tl hr ar tr = hr :-> ar ': MinJoinR (hl :-> al ': tl) tr 488 | 489 | type family ConstUnionR (l :: [LT k]) (r :: [LT k]) where 490 | ConstUnionR '[] r = r 491 | ConstUnionR l '[] = l 492 | ConstUnionR (h :-> a ': tl) (h :-> b ': tr) = 493 | (h :-> a ': ConstUnionR tl tr) 494 | ConstUnionR (hl :-> al ': tl) (hr :-> ar ': tr) = 495 | -- Using Ifte here makes GHC blow up on nested unions with many overlapping keys. 496 | ConstUnionRCase (CmpSymbol hl hr) hl al tl hr ar tr 497 | 498 | type family ConstUnionRCase (cmp :: Ordering) (hl :: Symbol) (al :: k) (tl :: [LT k]) 499 | (hr :: Symbol) (ar :: k) (tr :: [LT k]) where 500 | ConstUnionRCase 'LT hl al tl hr ar tr = hl :-> al ': ConstUnionR tl (hr :-> ar ': tr) 501 | ConstUnionRCase _ hl al tl hr ar tr = hr :-> ar ': ConstUnionR (hl :-> al ': tl) tr 502 | 503 | 504 | -- | Returns the left list with all of the elements from the right list removed. 505 | type family Diff (l :: [LT k]) (r :: [LT k]) where 506 | Diff '[] r = '[] 507 | Diff l '[] = l 508 | Diff (l ':-> al ': tl) (l ':-> al ': tr) = Diff tl tr 509 | Diff (hl ':-> al ': tl) (hr ':-> ar ': tr) = 510 | -- Using Ifte here makes GHC blow up on nested unions with many overlapping keys. 511 | DiffCont (CmpSymbol hl hr) hl al tl hr ar tr 512 | 513 | type family DiffCont (cmp :: Ordering) (hl :: Symbol) (al :: k) (tl :: [LT k]) 514 | (hr :: Symbol) (ar :: k) (tr :: [LT k]) where 515 | DiffCont 'LT hl al tl hr ar tr = (hl ':-> al ': Diff tl (hr ':-> ar ': tr)) 516 | DiffCont _ hl al tl hr ar tr = (Diff (hl ':-> al ': tl) tr) 517 | 518 | type family ShowRowType (r :: [LT k]) :: ErrorMessage where 519 |   ShowRowType '[] = TL.Text "Empty" 520 |   ShowRowType '[l ':-> t] = TL.ShowType l TL.:<>: TL.Text " .== " TL.:<>: TL.ShowType t 521 |   ShowRowType ((l ':-> t) ': r) = TL.ShowType l TL.:<>: TL.Text " .== " TL.:<>: TL.ShowType t TL.:<>: TL.Text " .+ " TL.:<>: ShowRowType r 522 | 523 | -- | There doesn't seem to be a (<=.?) :: Symbol -> Symbol -> Bool, 524 | -- so here it is in terms of other ghc-7.8 type functions 525 | type a <=.? b = (CmpSymbol a b == 'LT) 526 | 527 | -- | A lower fixity operator for type equality 528 | infix 4 ≈ 529 | type a ≈ b = a ~ b 530 | -------------------------------------------------------------------------------- /src/Data/Row/Records.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE PatternSynonyms #-} 9 | {-# LANGUAGE PolyKinds #-} 10 | {-# LANGUAGE RankNTypes #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE TypeOperators #-} 14 | {-# LANGUAGE ViewPatterns #-} 15 | {-# LANGUAGE UndecidableInstances #-} 16 | ----------------------------------------------------------------------------- 17 | -- | 18 | -- Module : Data.Row.Records 19 | -- 20 | -- This module implements extensible records using closed type famillies. 21 | -- 22 | -- See Examples.lhs for examples. 23 | -- 24 | -- Lists of (label,type) pairs are kept sorted thereby ensuring 25 | -- that { x = 0, y = 0 } and { y = 0, x = 0 } have the same type. 26 | -- 27 | -- In this way we can implement standard type classes such as Show, Eq, Ord and Bounded 28 | -- for open records, given that all the elements of the open record satify the constraint. 29 | -- 30 | ----------------------------------------------------------------------------- 31 | 32 | 33 | module Data.Row.Records 34 | ( 35 | -- * Types and constraints 36 | Label(..) 37 | , KnownSymbol, AllUniqueLabels, WellBehaved 38 | , Rec, Row, Empty, type (≈) 39 | -- * Construction 40 | , empty 41 | , type (.==), (.==), pattern (:==), unSingleton 42 | , default', defaultA 43 | , fromLabels, fromLabelsA, fromLabelsMapA 44 | -- ** Extension 45 | , extend, Extend, Lacks, type (.\) 46 | -- ** Restriction 47 | , type (.-), (.-) 48 | , lazyRemove 49 | , Subset 50 | , restrict, split 51 | -- ** Modification 52 | , update, focus, multifocus, Modify, rename, Rename 53 | -- * Query 54 | , HasType, type (.!), (.!) 55 | -- * Combine 56 | -- ** Disjoint union 57 | , type (.+), (.+), Disjoint, pattern (:+) 58 | -- ** Overwrite 59 | , type (.//), (.//) 60 | -- * Application with functions 61 | , curryRec 62 | , (.$) 63 | -- * Native Conversion 64 | -- $native 65 | , fromNative, toNative, toNativeGeneral 66 | , FromNative, ToNative, ToNativeGeneral 67 | , NativeRow 68 | -- * Dynamic Conversion 69 | , toDynamicMap, fromDynamicMap 70 | -- * Row operations 71 | -- ** Map 72 | , Map, map, map', mapF 73 | , transform, transform' 74 | , zipTransform, zipTransform' 75 | -- ** Fold 76 | , BiForall, Forall, erase, eraseWithLabels, eraseZip, eraseToHashMap 77 | -- ** Zip 78 | , Zip, zip 79 | -- ** Applicative-like functions 80 | , traverse, traverseMap 81 | , sequence, sequence' 82 | , distribute 83 | -- ** Compose 84 | -- $compose 85 | , compose, uncompose 86 | , compose', uncompose' 87 | -- ** Labels 88 | , labels, labels' 89 | -- ** Coerce 90 | , coerceRec 91 | ) 92 | where 93 | 94 | import Prelude hiding (map, sequence, traverse, zip) 95 | 96 | import Control.DeepSeq (NFData(..), deepseq) 97 | 98 | import Data.Bifunctor (Bifunctor(..)) 99 | import Data.Coerce 100 | import Data.Dynamic 101 | import Data.Functor.Compose 102 | import Data.Functor.Const 103 | import Data.Functor.Identity 104 | import Data.Functor.Product 105 | import Data.Generics.Product.Fields (HasField(..), HasField'(..)) 106 | import Data.Hashable 107 | import Data.HashMap.Lazy (HashMap) 108 | import qualified Data.HashMap.Lazy as M 109 | import qualified Data.List as L 110 | import Data.Monoid (Endo(..), appEndo) 111 | import Data.Proxy 112 | import Data.String (IsString) 113 | import Data.Text (Text) 114 | 115 | import qualified GHC.Generics as G 116 | import GHC.TypeLits 117 | import Unsafe.Coerce 118 | 119 | import Data.Row.Dictionaries 120 | import Data.Row.Internal 121 | 122 | 123 | {-------------------------------------------------------------------- 124 | Open records 125 | --------------------------------------------------------------------} 126 | -- | A record with row r. 127 | newtype Rec (r :: Row *) where 128 | OR :: HashMap Text HideType -> Rec r 129 | 130 | instance Forall r Show => Show (Rec r) where 131 | showsPrec p r = 132 | case eraseWithLabels @Show (showsPrec 7) r of 133 | [] -> 134 | showString "empty" 135 | xs -> 136 | showParen 137 | (p > 6) 138 | (appEndo $ foldMap Endo (L.intersperse (showString " .+ ") (L.map binds xs))) 139 | where 140 | binds (label, value) = 141 | showChar '#' . 142 | showString label . 143 | showString " .== " . 144 | value 145 | 146 | instance Forall r Eq => Eq (Rec r) where 147 | r == r' = and $ eraseZip @Eq (==) r r' 148 | 149 | instance (Forall r Eq, Forall r Ord) => Ord (Rec r) where 150 | compare m m' = cmp $ eraseZip @Ord compare m m' 151 | where cmp l | [] <- l' = EQ 152 | | a : _ <- l' = a 153 | where l' = dropWhile (== EQ) l 154 | 155 | instance (Forall r Bounded, AllUniqueLabels r) => Bounded (Rec r) where 156 | minBound = default' @Bounded minBound 157 | maxBound = default' @Bounded maxBound 158 | 159 | instance Forall r NFData => NFData (Rec r) where 160 | rnf r = getConst $ metamorph @_ @r @NFData @(,) @Rec @(Const ()) @Identity Proxy empty doUncons doCons r 161 | where empty = const $ Const () 162 | doUncons l = second Identity . lazyUncons l 163 | doCons _ (r, x) = deepseq x $ deepseq r $ Const () 164 | 165 | -- | The empty record 166 | empty :: Rec Empty 167 | empty = OR M.empty 168 | 169 | -- | The singleton record 170 | infix 7 .== 171 | (.==) :: KnownSymbol l => Label l -> a -> Rec (l .== a) 172 | l .== a = extend l a empty 173 | 174 | -- | A pattern for the singleton record; can be used to both destruct a record 175 | -- when in a pattern position or construct one in an expression position. 176 | {-# COMPLETE (:==) #-} 177 | infix 7 :== 178 | pattern (:==) :: forall l a. KnownSymbol l => Label l -> a -> Rec (l .== a) 179 | pattern l :== a <- (unSingleton @l @a -> (l, a)) where 180 | (:==) l a = l .== a 181 | 182 | -- | Turns a singleton record into a pair of the label and value. 183 | unSingleton :: forall l a. KnownSymbol l => Rec (l .== a) -> (Label l, a) 184 | unSingleton r = (l, r .! l) where l = Label @l 185 | 186 | {-------------------------------------------------------------------- 187 | Basic record operations 188 | --------------------------------------------------------------------} 189 | 190 | 191 | -- | Record extension. The row may already contain the label, 192 | -- in which case the origin value can be obtained after restriction ('.-') with 193 | -- the label. 194 | extend :: forall a l r. KnownSymbol l => Label l -> a -> Rec r -> Rec (Extend l a r) 195 | extend (toKey -> l) a (OR m) = OR $ M.insert l (HideType a) m 196 | 197 | -- | Update the value associated with the label. 198 | update :: (KnownSymbol l, r .! l ≈ a) => Label l -> a -> Rec r -> Rec r 199 | update (toKey -> l) a (OR m) = OR $ M.adjust f l m where f = const (HideType a) 200 | 201 | -- | Focus on the value associated with the label. 202 | focus :: 203 | ( KnownSymbol l 204 | , r' .! l ≈ b 205 | , r .! l ≈ a 206 | , r' ~ Modify l b r 207 | , r ~ Modify l a r' 208 | , Functor f) 209 | => Label l -> (a -> f b) -> Rec r -> f (Rec r') 210 | focus (toKey -> l) f (OR m) = case m M.! l of 211 | HideType x -> OR . flip (M.insert l) m . HideType <$> f (unsafeCoerce x) 212 | 213 | -- | Focus on a sub-record 214 | multifocus :: forall u v r f. 215 | ( Functor f 216 | , Disjoint u r 217 | , Disjoint v r) 218 | => (Rec u -> f (Rec v)) -> Rec (u .+ r) -> f (Rec (v .+ r)) 219 | multifocus f (u :+ r) = (.+ r) <$> f u 220 | 221 | -- | Rename a label. 222 | rename :: (KnownSymbol l, KnownSymbol l') => Label l -> Label l' -> Rec r -> Rec (Rename l l' r) 223 | rename (toKey -> l) (toKey -> l') (OR m) = OR $ M.insert l' (m M.! l) $ M.delete l m 224 | 225 | -- | Record selection 226 | (.!) :: KnownSymbol l => Rec r -> Label l -> r .! l 227 | OR m .! (toKey -> a) = case m M.! a of 228 | HideType x -> unsafeCoerce x 229 | 230 | infixl 6 .- 231 | -- | Record restriction. Remove the label l from the record. 232 | (.-) :: KnownSymbol l => Rec r -> Label l -> Rec (r .- l) 233 | -- OR m .- _ = OR m 234 | OR m .- (toKey -> a) = OR $ M.delete a m 235 | 236 | -- | Record disjoint union (commutative) 237 | infixl 6 .+ 238 | (.+) :: forall l r. FreeForall l => Rec l -> Rec r -> Rec (l .+ r) 239 | OR l .+ OR r = OR $ M.unionWithKey choose l r 240 | where 241 | choose k lv rv = if k `elem` labels' @l @Text then lv else rv 242 | 243 | -- | Record overwrite. 244 | -- 245 | -- The operation @r .// r'@ creates a new record such that: 246 | -- 247 | -- - Any label that is in both @r@ and @r'@ is in the resulting record with the 248 | -- type and value given by the fields in @r@, 249 | -- 250 | -- - Any label that is only found in @r@ is in the resulting record. 251 | -- 252 | -- - Any label that is only found in @r'@ is in the resulting record. 253 | -- 254 | -- This can be thought of as @r@ "overwriting" @r'@. 255 | infixl 6 .// 256 | (.//) :: Rec r -> Rec r' -> Rec (r .// r') 257 | OR l .// OR r = OR $ M.union l r 258 | 259 | -- | A pattern version of record union, for use in pattern matching. 260 | {-# COMPLETE (:+) #-} 261 | infixl 6 :+ 262 | pattern (:+) :: forall l r. Disjoint l r => Rec l -> Rec r -> Rec (l .+ r) 263 | pattern l :+ r <- (split @l -> (l, r)) where 264 | (:+) l r = l .+ r 265 | 266 | -- | Split a record into two sub-records. 267 | split :: forall s r. (Subset s r, FreeForall s) 268 | => Rec r -> (Rec s, Rec (r .\\ s)) 269 | split (OR m) = (OR $ M.intersection m labelMap, OR $ M.difference m labelMap) 270 | where 271 | labelMap = M.fromList $ L.zip (labels' @s) (repeat ()) 272 | 273 | -- | Arbitrary record restriction. Turn a record into a subset of itself. 274 | restrict :: forall r r'. (FreeForall r, Subset r r') => Rec r' -> Rec r 275 | restrict = fst . split 276 | 277 | -- | Removes a label from the record but does not remove the underlying value. 278 | -- 279 | -- This is faster than regular record removal ('.-'), but it has two downsides: 280 | -- 281 | -- 1. It may incur a performance penalty during a future merge operation ('.+'), and 282 | -- 283 | -- 2. It will keep the reference to the value alive, meaning that it will not get garbage collected. 284 | -- 285 | -- Thus, it's great when one knows ahead of time that no future merges will happen 286 | -- and that the whole record will be GC'd soon, for instance, during the catamorphism 287 | -- function of 'metamorph'. 288 | lazyRemove :: KnownSymbol l => Label l -> Rec r -> Rec (r .- l) 289 | lazyRemove _ (OR m) = OR m 290 | 291 | -- | This is the same as @(lazyRemove l r, r .! l)@. 292 | lazyUncons :: KnownSymbol l => Label l -> Rec r -> (Rec (r .- l), r .! l) 293 | lazyUncons l r = (lazyRemove l r, r .! l) 294 | 295 | -- | Kind of like 'curry' for functions over records. 296 | curryRec :: forall l t r x. KnownSymbol l => Label l -> (Rec (l .== t .+ r) -> x) -> t -> Rec r -> x 297 | curryRec l f t r = f $ (l .== t) .+ r 298 | 299 | infixl 2 .$ 300 | -- | This function allows one to do partial application on a function of a record. 301 | -- Note that this also means that arguments can be supplied in arbitrary order. 302 | -- For instance, if one had a function like 303 | -- 304 | -- > xtheny r = (r .! #x) <> (r .! #y) 305 | -- 306 | -- and a record like 307 | -- 308 | -- > greeting = #x .== "hello " .+ #y .== "world!" 309 | -- 310 | -- Then all of the following would be possible: 311 | -- 312 | -- >>> xtheny greeting 313 | -- "hello world!" 314 | -- 315 | -- >>> xtheny .$ (#x, greeting) .$ (#y, greeting) $ empty 316 | -- "hello world!" 317 | -- 318 | -- >>> xtheny .$ (#y, greeting) .$ (#x, greeting) $ empty 319 | -- "hello world!" 320 | -- 321 | -- >>> xtheny .$ (#y, greeting) .$ (#x, #x .== "Goodbye ") $ empty 322 | -- "Goodbye world!" 323 | (.$) :: (KnownSymbol l, r' .! l ≈ t) => (Rec (l .== t .+ r) -> x) -> (Label l, Rec r') -> Rec r -> x 324 | (.$) f (l, r') r = curryRec l f (r' .! l) r 325 | 326 | {-------------------------------------------------------------------- 327 | Folds and maps 328 | --------------------------------------------------------------------} 329 | -- An easy type synonym for a pair where both elements are the same type. 330 | newtype Pair' a = Pair' { unPair' :: (a,a) } 331 | 332 | -- | A standard fold 333 | erase :: forall c ρ b. Forall ρ c => (forall a. c a => a -> b) -> Rec ρ -> [b] 334 | erase f = fmap (snd @String) . eraseWithLabels @c f 335 | 336 | -- | A fold with labels 337 | eraseWithLabels :: forall c ρ s b. (Forall ρ c, IsString s) => (forall a. c a => a -> b) -> Rec ρ -> [(s,b)] 338 | eraseWithLabels f = getConst . metamorph @_ @ρ @c @(,) @Rec @(Const [(s,b)]) @Identity Proxy doNil doUncons doCons 339 | where doNil _ = Const [] 340 | doUncons l = second Identity . lazyUncons l 341 | doCons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ) 342 | => Label ℓ -> (Const [(s,b)] ρ, Identity τ) -> Const [(s,b)] (Extend ℓ τ ρ) 343 | doCons l (Const c, Identity x) = Const $ (show' l, f x) : c 344 | 345 | -- | A fold over two row type structures at once 346 | eraseZip :: forall c ρ b. Forall ρ c => (forall a. c a => a -> a -> b) -> Rec ρ -> Rec ρ -> [b] 347 | eraseZip f x y = getConst $ metamorph @_ @ρ @c @(,) @(Product Rec Rec) @(Const [b]) @Pair' Proxy (const $ Const []) doUncons doCons (Pair x y) 348 | where doUncons l (Pair r1 r2) = (Pair r1' r2', Pair' (a, b)) 349 | where (r1', a) = lazyUncons l r1 350 | (r2', b) = lazyUncons l r2 351 | doCons :: forall ℓ τ ρ. c τ 352 | => Label ℓ -> (Const [b] ρ, Pair' τ) -> Const [b] (Extend ℓ τ ρ) 353 | doCons _ (Const c, unPair' -> x) = Const $ uncurry f x : c 354 | 355 | -- | Turns a record into a 'HashMap' from values representing the labels to 356 | -- the values of the record. 357 | eraseToHashMap :: forall c r s b. (IsString s, Eq s, Hashable s, Forall r c) => 358 | (forall a . c a => a -> b) -> Rec r -> HashMap s b 359 | eraseToHashMap f r = M.fromList $ eraseWithLabels @c f r 360 | 361 | -- | RMap is used internally as a type level lambda for defining record maps. 362 | newtype RMap f ρ = RMap { unRMap :: Rec (Map f ρ) } 363 | newtype RMap2 f g ρ = RMap2 { unRMap2 :: Rec (Map f (Map g ρ)) } 364 | 365 | -- | A function to map over a record given a constraint. 366 | map :: forall c f r. Forall r c => (forall a. c a => a -> f a) -> Rec r -> Rec (Map f r) 367 | map f = unRMap . metamorph @_ @r @c @(,) @Rec @(RMap f) @f Proxy doNil doUncons doCons 368 | where 369 | doNil _ = RMap empty 370 | doUncons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ, HasType ℓ τ ρ) 371 | => Label ℓ -> Rec ρ -> (Rec (ρ .- ℓ), f τ) 372 | doUncons l = second f . lazyUncons l 373 | doCons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ) 374 | => Label ℓ -> (RMap f ρ, f τ) -> RMap f (Extend ℓ τ ρ) 375 | doCons l (RMap r, v) = RMap (extend l v r) 376 | \\ mapExtendSwap @f @ℓ @τ @ρ 377 | 378 | newtype RFMap (g :: k1 -> k2) (ϕ :: Row (k2 -> *)) (ρ :: Row k1) = RFMap { unRFMap :: Rec (Ap ϕ (Map g ρ)) } 379 | newtype RecAp (ϕ :: Row (k -> *)) (ρ :: Row k) = RecAp (Rec (Ap ϕ ρ)) 380 | newtype App (f :: k -> *) (a :: k) = App (f a) 381 | 382 | -- | A function to map over a Ap record given constraints. 383 | mapF :: forall k c g (ϕ :: Row (k -> *)) (ρ :: Row k). BiForall ϕ ρ c 384 | => (forall h a. (c h a) => h a -> h (g a)) 385 | -> Rec (Ap ϕ ρ) 386 | -> Rec (Ap ϕ (Map g ρ)) 387 | mapF f = unRFMap . biMetamorph @_ @_ @ϕ @ρ @c @(,) @RecAp @(RFMap g) @App Proxy doNil doUncons doCons . RecAp 388 | where 389 | doNil _ = RFMap empty 390 | doUncons :: forall ℓ f τ ϕ ρ. (KnownSymbol ℓ, c f τ, HasType ℓ f ϕ, HasType ℓ τ ρ) 391 | => Label ℓ -> RecAp ϕ ρ -> (RecAp (ϕ .- ℓ) (ρ .- ℓ), App f τ) 392 | doUncons l (RecAp r) = bimap RecAp App $ lazyUncons l r 393 | \\ apHas @ℓ @f @ϕ @τ @ρ 394 | doCons :: forall ℓ f τ ϕ ρ. (KnownSymbol ℓ, c f τ) 395 | => Label ℓ -> (RFMap g ϕ ρ, App f τ) -> RFMap g (Extend ℓ f ϕ) (Extend ℓ τ ρ) 396 | doCons l (RFMap r, App v) = RFMap (extend l (f @f @τ v) r) 397 | \\ mapExtendSwap @g @ℓ @τ @ρ 398 | \\ apExtendSwap @ℓ @f @ϕ @(g τ) @(Map g ρ) 399 | 400 | -- | A function to map over a record given no constraint. 401 | map' :: forall f r. FreeForall r => (forall a. a -> f a) -> Rec r -> Rec (Map f r) 402 | map' f = map @Unconstrained1 f 403 | 404 | -- | Lifts a natural transformation over a record. In other words, it acts as a 405 | -- record transformer to convert a record of @f a@ values to a record of @g a@ 406 | -- values. If no constraint is needed, instantiate the first type argument with 407 | -- 'Unconstrained1' or use 'transform''. 408 | transform :: forall c r f g. Forall r c => (forall a. c a => f a -> g a) -> Rec (Map f r) -> Rec (Map g r) 409 | transform f = unRMap . metamorph @_ @r @c @(,) @(RMap f) @(RMap g) @f Proxy doNil doUncons doCons . RMap 410 | where 411 | doNil _ = RMap empty 412 | doUncons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ, HasType ℓ τ ρ) 413 | => Label ℓ -> RMap f ρ -> (RMap f (ρ .- ℓ), f τ) 414 | doUncons l (RMap r) = first RMap $ lazyUncons l r 415 | \\ mapHas @f @ℓ @τ @ρ 416 | doCons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ) 417 | => Label ℓ -> (RMap g ρ, f τ) -> RMap g (Extend ℓ τ ρ) 418 | doCons l (RMap r, v) = RMap (extend l (f v) r) 419 | \\ mapExtendSwap @g @ℓ @τ @ρ 420 | 421 | -- | A version of 'transform' for when there is no constraint. 422 | transform' :: forall r f g. FreeForall r => (forall a. f a -> g a) -> Rec (Map f r) -> Rec (Map g r) 423 | transform' f = transform @Unconstrained1 @r f 424 | 425 | 426 | data RecMapPair f g ρ = RecMapPair (Rec (Map f ρ)) (Rec (Map g ρ)) 427 | 428 | -- | Zip together two records that are the same up to the type being mapped over them, 429 | -- combining their constituent fields with the given function. 430 | zipTransform :: forall c r f g h . 431 | Forall r c => (forall a. c a => f a -> g a -> h a) -> Rec (Map f r) -> Rec (Map g r) -> Rec (Map h r) 432 | zipTransform f x y = unRMap $ metamorph @_ @r @c @(,) @(RecMapPair f g) @(RMap h) @h Proxy doNil doUncons doCons $ RecMapPair x y 433 | where 434 | doNil _ = RMap empty 435 | doUncons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ, HasType ℓ τ ρ) 436 | => Label ℓ -> RecMapPair f g ρ -> (RecMapPair f g (ρ .- ℓ), h τ) 437 | doUncons l (RecMapPair x y) = (RecMapPair (lazyRemove l x) (lazyRemove l y), f (x .! l) (y .! l)) 438 | \\ mapHas @f @ℓ @τ @ρ 439 | \\ mapHas @g @ℓ @τ @ρ 440 | doCons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ) 441 | => Label ℓ -> (RMap h ρ, h τ) -> RMap h (Extend ℓ τ ρ) 442 | doCons l (RMap r, h) = RMap (extend l h r) 443 | \\ mapExtendSwap @h @ℓ @τ @ρ 444 | 445 | -- | A version of 'zipTransform' for when there is no constraint. 446 | zipTransform' :: forall r f g h . 447 | FreeForall r => (forall a. f a -> g a -> h a) -> Rec (Map f r) -> Rec (Map g r) -> Rec (Map h r) 448 | zipTransform' f = zipTransform @Unconstrained1 @r f 449 | 450 | -- | Traverse a function over a record. Note that the fields of the record will 451 | -- be accessed in lexicographic order by the labels. 452 | traverse :: forall c f r. (Forall r c, Applicative f) => (forall a. c a => a -> f a) -> Rec r -> f (Rec r) 453 | traverse f = sequence' @f @r @c . map @c @f @r f 454 | 455 | -- | Traverse a function over a Mapped record. Note that the fields of the record will 456 | -- be accessed in lexicographic order by the labels. 457 | traverseMap :: forall c f g h r. 458 | (Forall r c, Applicative f) => (forall a. c a => g a -> f (h a)) -> Rec (Map g r) -> f (Rec (Map h r)) 459 | traverseMap f = 460 | sequence' @f @(Map h r) @(IsA c h) . 461 | uncompose' @c @f @h @r . 462 | transform @c @r @g @(Compose f h) (Compose . f) 463 | \\ mapForall @h @r @c 464 | 465 | -- | A version of 'sequence' in which the constraint for 'Forall' can be chosen. 466 | sequence' :: forall f r c. (Forall r c, Applicative f) 467 | => Rec (Map f r) -> f (Rec r) 468 | sequence' = getCompose . metamorph @_ @r @c @(,) @(RMap f) @(Compose f Rec) @f Proxy doNil doUncons doCons . RMap 469 | where 470 | doNil _ = Compose (pure empty) 471 | doUncons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ, HasType ℓ τ ρ) 472 | => Label ℓ -> RMap f ρ -> (RMap f (ρ .- ℓ), f τ) 473 | doUncons l (RMap r) = first RMap $ lazyUncons l r 474 | \\ mapHas @f @ℓ @τ @ρ 475 | doCons l (Compose fr, fv) = Compose $ extend l <$> fv <*> fr 476 | 477 | -- | Applicative sequencing over a record. 478 | sequence :: forall f r. (Applicative f, FreeForall r) 479 | => Rec (Map f r) -> f (Rec r) 480 | sequence = sequence' @_ @_ @Unconstrained1 481 | 482 | -- | This function acts as the inversion of `sequence`, allowing one to move a 483 | -- functor level into a record. 484 | distribute :: forall f r. (FreeForall r, Functor f) => f (Rec r) -> Rec (Map f r) 485 | distribute = unRMap . metamorph @_ @r @Unconstrained1 @(,) @(Compose f Rec) @(RMap f) @f Proxy doNil doUncons doCons . Compose 486 | where 487 | doNil _ = RMap empty 488 | doUncons :: forall ℓ τ ρ. (KnownSymbol ℓ, HasType ℓ τ ρ) 489 | => Label ℓ -> Compose f Rec ρ -> (Compose f Rec (ρ .- ℓ), f τ) 490 | doUncons l (Compose fr) = (Compose $ lazyRemove l <$> fr, (.! l) <$> fr) 491 | doCons :: forall ℓ τ ρ. (KnownSymbol ℓ) 492 | => Label ℓ -> (RMap f ρ, f τ) -> RMap f (Extend ℓ τ ρ) 493 | doCons l (RMap r, fv) = RMap (extend l fv r) 494 | \\ mapExtendSwap @f @ℓ @τ @ρ 495 | 496 | 497 | -- $compose 498 | -- We can easily convert between mapping two functors over the types of a row 499 | -- and mapping the composition of the two functors. The following two functions 500 | -- perform this composition with the gaurantee that: 501 | -- 502 | -- >>> compose . uncompose = id 503 | -- 504 | -- >>> uncompose . compose = id 505 | 506 | -- | A version of 'compose' in which the constraint for 'Forall' can be chosen. 507 | compose' :: forall c f g r . Forall r c 508 | => Rec (Map f (Map g r)) -> Rec (Map (Compose f g) r) 509 | compose' = unRMap . metamorph @_ @r @c @(,) @(RMap2 f g) @(RMap (Compose f g)) @(Compose f g) Proxy doNil doUncons doCons . RMap2 510 | where 511 | doNil _ = RMap empty 512 | doUncons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ, HasType ℓ τ ρ) 513 | => Label ℓ -> RMap2 f g ρ -> (RMap2 f g (ρ .- ℓ), Compose f g τ) 514 | doUncons l (RMap2 r) = bimap RMap2 Compose $ lazyUncons l r 515 | \\ mapHas @f @ℓ @(g τ) @(Map g ρ) 516 | \\ mapHas @g @ℓ @τ @ρ 517 | doCons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ) 518 | => Label ℓ -> (RMap (Compose f g) ρ, Compose f g τ) -> RMap (Compose f g) (Extend ℓ τ ρ) 519 | doCons l (RMap r, v) = RMap $ extend l v r 520 | \\ mapExtendSwap @(Compose f g) @ℓ @τ @ρ 521 | 522 | -- | Convert from a record where two functors have been mapped over the types to 523 | -- one where the composition of the two functors is mapped over the types. 524 | compose :: forall f g r . FreeForall r 525 | => Rec (Map f (Map g r)) -> Rec (Map (Compose f g) r) 526 | compose = compose' @Unconstrained1 @f @g @r 527 | 528 | -- | A version of 'uncompose' in which the constraint for 'Forall' can be chosen. 529 | uncompose' :: forall c f g r . Forall r c 530 | => Rec (Map (Compose f g) r) -> Rec (Map f (Map g r)) 531 | uncompose' = unRMap2 . metamorph @_ @r @c @(,) @(RMap (Compose f g)) @(RMap2 f g) @(Compose f g) Proxy doNil doUncons doCons . RMap 532 | where 533 | doNil _ = RMap2 empty 534 | doUncons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ, HasType ℓ τ ρ) 535 | => Label ℓ -> RMap (Compose f g) ρ -> (RMap (Compose f g) (ρ .- ℓ), Compose f g τ) 536 | doUncons l (RMap r) = first RMap $ lazyUncons l r 537 | \\ mapHas @(Compose f g) @ℓ @τ @ρ 538 | doCons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ) 539 | => Label ℓ -> (RMap2 f g ρ, Compose f g τ) -> RMap2 f g (Extend ℓ τ ρ) 540 | doCons l (RMap2 r, Compose v) = RMap2 $ extend l v r 541 | \\ mapExtendSwap @f @ℓ @(g τ) @(Map g ρ) 542 | \\ mapExtendSwap @g @ℓ @τ @ρ 543 | 544 | -- | Convert from a record where the composition of two functors have been mapped 545 | -- over the types to one where the two functors are mapped individually one at a 546 | -- time over the types. 547 | uncompose :: forall f g r . FreeForall r 548 | => Rec (Map (Compose f g) r) -> Rec (Map f (Map g r)) 549 | uncompose = uncompose' @Unconstrained1 @f @g @r 550 | 551 | 552 | -- | Coerce a record to a coercible representation. The 'BiForall' in the context 553 | -- indicates that the type of every field in @r1@ can be coerced to the type of 554 | -- the corresponding fields in @r2@. 555 | -- 556 | -- Internally, this is implemented just with `unsafeCoerce`, but we provide the 557 | -- following implementation as a proof: 558 | -- 559 | -- > newtype ConstR a b = ConstR (Rec a) 560 | -- > newtype FlipConstR a b = FlipConstR { unFlipConstR :: Rec b } 561 | -- > coerceRec :: forall r1 r2. BiForall r1 r2 Coercible => Rec r1 -> Rec r2 562 | -- > coerceRec = unFlipConstR . biMetamorph @_ @_ @r1 @r2 @Coercible @(,) @ConstR @FlipConstR @Const Proxy doNil doUncons doCons . ConstR 563 | -- > where 564 | -- > doNil _ = FlipConstR empty 565 | -- > doUncons l (ConstR r) = bimap ConstR Const $ lazyUncons l r 566 | -- > doCons :: forall ℓ τ1 τ2 ρ1 ρ2. (KnownSymbol ℓ, Coercible τ1 τ2) 567 | -- > => Label ℓ -> (FlipConstR ρ1 ρ2, Const τ1 τ2) -> FlipConstR (Extend ℓ τ1 ρ1) (Extend ℓ τ2 ρ2) 568 | -- > doCons l (FlipConstR r, Const v) = FlipConstR $ extend l (coerce @τ1 @τ2 v) r 569 | coerceRec :: forall r1 r2. BiForall r1 r2 Coercible => Rec r1 -> Rec r2 570 | coerceRec = unsafeCoerce 571 | 572 | 573 | -- | RZipPair is used internally as a type level lambda for zipping records. 574 | newtype RecPair (ρ1 :: Row *) (ρ2 :: Row *) = RecPair (Rec ρ1, Rec ρ2) 575 | newtype RZipPair (ρ1 :: Row *) (ρ2 :: Row *) = RZipPair { unRZipPair :: Rec (Zip ρ1 ρ2) } 576 | 577 | -- | Zips together two records that have the same set of labels. 578 | zip :: forall r1 r2. FreeBiForall r1 r2 => Rec r1 -> Rec r2 -> Rec (Zip r1 r2) 579 | zip r1 r2 = unRZipPair $ biMetamorph @_ @_ @r1 @r2 @Unconstrained2 @(,) @RecPair @RZipPair @(,) Proxy doNil doUncons doCons $ RecPair (r1, r2) 580 | where 581 | doNil _ = RZipPair empty 582 | doUncons l (RecPair (r1, r2)) = (RecPair (lazyRemove l r1, lazyRemove l r2), (r1 .! l, r2 .! l)) 583 | doCons :: forall ℓ τ1 τ2 ρ1 ρ2. (KnownSymbol ℓ) 584 | => Label ℓ -> (RZipPair ρ1 ρ2, (τ1, τ2)) -> RZipPair (Extend ℓ τ1 ρ1) (Extend ℓ τ2 ρ2) 585 | doCons l (RZipPair r, vs) = RZipPair $ extend l vs r 586 | \\ zipExtendSwap @ℓ @τ1 @ρ1 @τ2 @ρ2 587 | 588 | {-------------------------------------------------------------------- 589 | Record initialization 590 | --------------------------------------------------------------------} 591 | 592 | -- | Initialize a record with a default value at each label. 593 | default' :: forall c ρ. (Forall ρ c, AllUniqueLabels ρ) => (forall a. c a => a) -> Rec ρ 594 | default' v = runIdentity $ defaultA @c $ pure v 595 | 596 | -- | Initialize a record with a default value at each label; works over an 'Applicative'. 597 | defaultA :: forall c f ρ. (Applicative f, Forall ρ c, AllUniqueLabels ρ) 598 | => (forall a. c a => f a) -> f (Rec ρ) 599 | defaultA v = fromLabelsA @c $ pure v 600 | 601 | -- | Initialize a record, where each value is determined by the given function over 602 | -- the label at that value. 603 | fromLabels :: forall c ρ. (Forall ρ c, AllUniqueLabels ρ) 604 | => (forall l a. (KnownSymbol l, c a) => Label l -> a) -> Rec ρ 605 | fromLabels f = runIdentity $ fromLabelsA @c $ (pure .) f 606 | 607 | -- | Initialize a record, where each value is determined by the given function over 608 | -- the label at that value. This function works over an 'Applicative'. 609 | fromLabelsA :: forall c f ρ. (Applicative f, Forall ρ c, AllUniqueLabels ρ) 610 | => (forall l a. (KnownSymbol l, c a) => Label l -> f a) -> f (Rec ρ) 611 | fromLabelsA mk = getCompose $ metamorph @_ @ρ @c @Const @(Const ()) @(Compose f Rec) @Proxy Proxy doNil doUncons doCons (Const ()) 612 | where doNil _ = Compose $ pure empty 613 | doUncons _ _ = Const $ Const () 614 | doCons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ) 615 | => Label ℓ -> Const (Compose f Rec ρ) (Proxy τ) -> Compose f Rec (Extend ℓ τ ρ) 616 | doCons l (Const (Compose r)) = Compose $ extend l <$> mk @ℓ @τ l <*> r 617 | 618 | -- | Initialize a record over a `Map`. 619 | fromLabelsMapA :: forall c f g ρ. (Applicative f, Forall ρ c, AllUniqueLabels ρ) 620 | => (forall l a. (KnownSymbol l, c a) => Label l -> f (g a)) -> f (Rec (Map g ρ)) 621 | fromLabelsMapA f = fromLabelsA @(IsA c g) @f @(Map g ρ) inner 622 | \\ mapForall @g @ρ @c 623 | \\ uniqueMap @g @ρ 624 | where inner :: forall l a. (KnownSymbol l, IsA c g a) => Label l -> f a 625 | inner l = case as @c @g @a of As -> f l 626 | 627 | 628 | {-------------------------------------------------------------------- 629 | Dynamic compatibility 630 | --------------------------------------------------------------------} 631 | 632 | -- | Converts a 'Rec' into a 'HashMap' of 'Dynamic's. 633 | toDynamicMap :: Forall r Typeable => Rec r -> HashMap Text Dynamic 634 | toDynamicMap = eraseToHashMap @Typeable @_ @Text @Dynamic toDyn 635 | 636 | -- | Produces a 'Rec' from a 'HashMap' of 'Dynamic's. 637 | fromDynamicMap :: (AllUniqueLabels r, Forall r Typeable) 638 | => HashMap Text Dynamic -> Maybe (Rec r) 639 | fromDynamicMap m = fromLabelsA @Typeable 640 | $ \ (toKey -> k) -> M.lookup k m >>= fromDynamic 641 | 642 | 643 | {-------------------------------------------------------------------- 644 | Generic instance 645 | --------------------------------------------------------------------} 646 | 647 | -- The generic structure we want Recs to have is not the hidden internal one, 648 | -- but rather one that appears as a Haskell record. Thus, we can't derive 649 | -- Generic automatically. 650 | -- 651 | -- The following Generic instance creates a representation of a Rec that is 652 | -- very similar to a native Haskell record except that the tree of pairs (':*:') 653 | -- that it produces will be extremely unbalanced. I don't think this is a problem. 654 | -- Furthermore, because we don't want Recs to always have a trailing unit on 655 | -- the end, we must have a special case for singleton Recs, which means that 656 | -- we can't use metamorph. 657 | 658 | instance GenericRec r => G.Generic (Rec r) where 659 | type Rep (Rec r) = 660 | G.D1 ('G.MetaData "Rec" "Data.Row.Records" "row-types" 'False) 661 | (G.C1 ('G.MetaCons "Rec" 'G.PrefixI 'True) 662 | (RepRec r)) 663 | from = G.M1 . G.M1 . fromRec 664 | to = toRec . G.unM1 . G.unM1 665 | 666 | class GenericRec r where 667 | type RepRec (r :: Row *) :: * -> * 668 | fromRec :: Rec r -> RepRec r x 669 | toRec :: RepRec r x -> Rec r 670 | 671 | instance GenericRec Empty where 672 | type RepRec (R '[]) = G.U1 673 | fromRec _ = G.U1 674 | toRec _ = empty 675 | 676 | instance KnownSymbol name => GenericRec (R '[name :-> t]) where 677 | type RepRec (R (name :-> t ': '[])) = G.S1 678 | ('G.MetaSel ('Just name) 'G.NoSourceUnpackedness 'G.NoSourceStrictness 'G.DecidedLazy) 679 | (G.Rec0 t) 680 | fromRec (_ :== a) = G.M1 (G.K1 a) 681 | toRec (G.M1 (G.K1 a)) = (Label @name) :== a 682 | 683 | instance 684 | ( r ~ (name' :-> t' ': r'), GenericRec (R r) 685 | , KnownSymbol name, Extend name t ('R r) ≈ 'R (name :-> t ': r) 686 | ) => GenericRec (R (name :-> t ': (name' :-> t' ': r'))) where 687 | type RepRec (R (name :-> t ': (name' :-> t' ': r'))) = (G.S1 688 | ('G.MetaSel ('Just name) 'G.NoSourceUnpackedness 'G.NoSourceStrictness 'G.DecidedLazy) 689 | (G.Rec0 t)) G.:*: RepRec (R (name' :-> t' ': r')) 690 | fromRec r = G.M1 (G.K1 (r .! Label @name)) G.:*: fromRec (lazyRemove @name Label r) 691 | toRec (G.M1 (G.K1 a) G.:*: r) = extend @_ @name @('R (name' :-> t' ': r')) Label a (toRec r) 692 | 693 | {-------------------------------------------------------------------- 694 | Native data type compatibility 695 | --------------------------------------------------------------------} 696 | -- ToNative is shamelessly copied from 697 | -- https://www.athiemann.net/2017/07/02/superrecord.html 698 | 699 | -- $native 700 | -- The 'toNative' and 'fromNative' functions allow one to convert between 701 | -- 'Rec's and regular Haskell data types ("native" types) that have a single constructor and any 702 | -- number of named fields with the same names and types as the 'Rec'. As expected, 703 | -- they compose to form the identity. Alternatively, one may use 'toNativeGeneral', 704 | -- which allows fields to be dropped when a record has excess fields compared 705 | -- to the native type. Because of this, 'toNativeGeneral' requires a type 706 | -- application (although 'fromNative' does not). The only requirement is that 707 | -- the native Haskell data type be an instance of 'Generic'. 708 | -- 709 | -- For example, consider the following simple data type: 710 | -- 711 | -- >>> data Person = Person { name :: String, age :: Int} deriving (Generic, Show) 712 | -- 713 | -- Then, we have the following: 714 | -- 715 | -- >>> toNative @Person $ #name .== "Alice" .+ #age .== 7 .+ #hasDog .== True 716 | -- Person {name = "Alice", age = 7} 717 | -- >>> fromNative $ Person "Bob" 9 718 | -- { age=9, name="Bob" } 719 | 720 | type family NativeRow t where 721 | NativeRow t = NativeRowG (G.Rep t) 722 | 723 | type family NativeRowG t where 724 | NativeRowG (G.M1 G.D m cs) = NativeRowG cs 725 | NativeRowG (G.M1 G.C m cs) = NativeRowG cs 726 | NativeRowG G.U1 = Empty 727 | NativeRowG (l G.:*: r) = NativeRowG l .+ NativeRowG r 728 | NativeRowG (G.M1 G.S ('G.MetaSel ('Just name) p s l) (G.Rec0 t)) = name .== t 729 | 730 | 731 | -- | Conversion helper to turn a Haskell record into a row-types extensible 732 | -- record. Note that the native Haskell type must be an instance of 'Generic'. 733 | class FromNativeG a where 734 | fromNative' :: a x -> Rec (NativeRowG a) 735 | 736 | instance FromNativeG cs => FromNativeG (G.D1 m cs) where 737 | fromNative' (G.M1 xs) = fromNative' xs 738 | 739 | instance FromNativeG cs => FromNativeG (G.C1 m cs) where 740 | fromNative' (G.M1 xs) = fromNative' xs 741 | 742 | instance FromNativeG G.U1 where 743 | fromNative' G.U1 = empty 744 | 745 | instance KnownSymbol name => FromNativeG (G.S1 ('G.MetaSel ('Just name) p s l) (G.Rec0 t)) where 746 | fromNative' (G.M1 (G.K1 x)) = (Label @name) .== x 747 | 748 | instance (FromNativeG l, FromNativeG r, FreeForall (NativeRowG l)) => FromNativeG (l G.:*: r) where 749 | fromNative' (x G.:*: y) = fromNative' @l x .+ fromNative' @r y 750 | 751 | type FromNative t = (G.Generic t, FromNativeG (G.Rep t)) 752 | 753 | -- | Convert a Haskell record to a row-types Rec. 754 | fromNative :: FromNative t => t -> Rec (NativeRow t) 755 | fromNative = fromNative' . G.from 756 | 757 | 758 | -- | Conversion helper to bring a record back into a Haskell type. Note that the 759 | -- native Haskell type must be an instance of 'Generic'. 760 | class ToNativeG a where 761 | toNative' :: Rec (NativeRowG a) -> a x 762 | 763 | instance ToNativeG cs => ToNativeG (G.D1 m cs) where 764 | toNative' xs = G.M1 $ toNative' xs 765 | 766 | instance ToNativeG cs => ToNativeG (G.C1 m cs) where 767 | toNative' xs = G.M1 $ toNative' xs 768 | 769 | instance ToNativeG G.U1 where 770 | toNative' _ = G.U1 771 | 772 | instance (KnownSymbol name) => ToNativeG (G.S1 ('G.MetaSel ('Just name) p s l) (G.Rec0 t)) where 773 | toNative' r = G.M1 $ G.K1 $ r .! (Label @name) 774 | 775 | instance (ToNativeG l, ToNativeG r, Disjoint (NativeRowG l) (NativeRowG r)) 776 | => ToNativeG (l G.:*: r) where 777 | toNative' r = toNative' r1 G.:*: toNative' r2 778 | where 779 | (r1 :: Rec (NativeRowG l)) :+ (r2 :: Rec (NativeRowG r)) = r 780 | 781 | type ToNative t = (G.Generic t, ToNativeG (G.Rep t)) 782 | 783 | -- | Convert a record to an exactly matching native Haskell type. 784 | toNative :: ToNative t => Rec (NativeRow t) -> t 785 | toNative = G.to . toNative' 786 | 787 | 788 | 789 | -- | Conversion helper to bring a record back into a Haskell type. Note that the 790 | -- native Haskell type must be an instance of 'Generic'. 791 | class ToNativeGeneralG a ρ where 792 | toNativeGeneral' :: Rec ρ -> a x 793 | 794 | instance ToNativeGeneralG cs ρ => ToNativeGeneralG (G.D1 m cs) ρ where 795 | toNativeGeneral' xs = G.M1 $ toNativeGeneral' xs 796 | 797 | instance ToNativeGeneralG cs ρ => ToNativeGeneralG (G.C1 m cs) ρ where 798 | toNativeGeneral' xs = G.M1 $ toNativeGeneral' xs 799 | 800 | instance ToNativeGeneralG G.U1 ρ where 801 | toNativeGeneral' _ = G.U1 802 | 803 | instance (KnownSymbol name, ρ .! name ≈ t) 804 | => ToNativeGeneralG (G.S1 ('G.MetaSel ('Just name) p s l) (G.Rec0 t)) ρ where 805 | toNativeGeneral' r = G.M1 $ G.K1 $ r .! (Label @name) 806 | 807 | instance (ToNativeGeneralG l ρ, ToNativeGeneralG r ρ) 808 | => ToNativeGeneralG (l G.:*: r) ρ where 809 | toNativeGeneral' r = toNativeGeneral' r G.:*: toNativeGeneral' r 810 | 811 | type ToNativeGeneral t ρ = (G.Generic t, ToNativeGeneralG (G.Rep t) ρ) 812 | 813 | -- | Convert a record to a native Haskell type. 814 | toNativeGeneral :: ToNativeGeneral t ρ => Rec ρ -> t 815 | toNativeGeneral = G.to . toNativeGeneral' 816 | 817 | 818 | {-------------------------------------------------------------------- 819 | Generic-lens compatibility 820 | --------------------------------------------------------------------} 821 | 822 | -- | Every field in a row-types based record has a 'HasField' instance. 823 | instance {-# OVERLAPPING #-} 824 | ( KnownSymbol name 825 | , r' .! name ≈ b 826 | , r .! name ≈ a 827 | , r' ~ Modify name b r 828 | , r ~ Modify name a r') 829 | => HasField name (Rec r) (Rec r') a b where 830 | field = focus (Label @name) 831 | {-# INLINE field #-} 832 | 833 | instance {-# OVERLAPPING #-} 834 | ( KnownSymbol name 835 | , r .! name ≈ a 836 | , r ~ Modify name a r) 837 | => HasField' name (Rec r) a where 838 | field' = focus (Label @name) 839 | {-# INLINE field' #-} 840 | -------------------------------------------------------------------------------- /src/Data/Row/Switch.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | {-# LANGUAGE FunctionalDependencies #-} 10 | ----------------------------------------------------------------------------- 11 | -- | 12 | -- Module: Data.Row.Switch 13 | -- 14 | -- This module provides the ability to discharge a polymorphic variant using 15 | -- a record that has matching fields. 16 | -- 17 | ----------------------------------------------------------------------------- 18 | 19 | 20 | module Data.Row.Switch 21 | ( AppliesTo(..) 22 | , switch 23 | , caseon 24 | ) 25 | where 26 | 27 | import Data.Proxy 28 | 29 | import Data.Bifunctor (Bifunctor(..)) 30 | import Data.Row.Internal 31 | import Data.Row.Records 32 | import Data.Row.Variants 33 | 34 | -- | A simple class that we use to provide a constraint for function application. 35 | class AppliesTo r f x | r x -> f, f r -> x where 36 | applyTo :: f -> x -> r 37 | instance AppliesTo r (x -> r) x where 38 | applyTo = ($) 39 | 40 | -- | A pair of a record and a variant. 41 | data SwitchData r v = SwitchData (Rec r) (Var v) 42 | 43 | -- | Like 'Const' but for two ignored type arguments. 44 | newtype Const2 x y z = Const2 { getConst2 :: x } 45 | 46 | -- | A 'Var' and a 'Rec' can combine if their rows line up properly. 47 | -- Given a Variant along with a Record of functions from each possible value 48 | -- of the variant to a single output type, apply the correct 49 | -- function to the value in the variant. 50 | switch :: forall v r x. BiForall r v (AppliesTo x) => Var v -> Rec r -> x 51 | switch v r = getConst2 $ biMetamorph @_ @_ @r @v @(AppliesTo x) @Either @SwitchData @(Const2 x) @(Const2 x) 52 | Proxy doNil doUncons doCons $ SwitchData r v 53 | where 54 | doNil (SwitchData _ v) = impossible v 55 | doUncons :: forall ℓ f τ ϕ ρ. (KnownSymbol ℓ, AppliesTo x f τ, HasType ℓ f ϕ, HasType ℓ τ ρ) 56 | => Label ℓ -> SwitchData ϕ ρ -> Either (SwitchData (ϕ .- ℓ) (ρ .- ℓ)) (Const2 x f τ) 57 | doUncons l (SwitchData r v) = bimap (SwitchData $ lazyRemove l r) (Const2 . applyTo (r .! l)) $ trial v l 58 | -- doCons :: forall ℓ f τ ϕ ρ. (KnownSymbol ℓ, AppliesTo x f τ) 59 | -- => Label ℓ -> Either (Const2 x f τ) (Const2 x ϕ ρ) -> Const2 x (Extend ℓ f ϕ) (Extend ℓ τ ρ) 60 | doCons _ (Left (Const2 x)) = Const2 x 61 | doCons _ (Right (Const2 x)) = Const2 x 62 | 63 | -- | The same as 'switch' but with the argument order reversed 64 | caseon :: forall v r x. BiForall r v (AppliesTo x) => Rec r -> Var v -> x 65 | caseon = flip switch 66 | -------------------------------------------------------------------------------- /src/Data/Row/Variants.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE EmptyCase #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE GADTs #-} 8 | {-# LANGUAGE InstanceSigs #-} 9 | {-# LANGUAGE LambdaCase #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE PatternSynonyms #-} 12 | {-# LANGUAGE PolyKinds #-} 13 | {-# LANGUAGE RankNTypes #-} 14 | {-# LANGUAGE ScopedTypeVariables #-} 15 | {-# LANGUAGE TypeFamilies #-} 16 | {-# LANGUAGE TypeOperators #-} 17 | {-# LANGUAGE ViewPatterns #-} 18 | {-# LANGUAGE UndecidableInstances #-} 19 | ----------------------------------------------------------------------------- 20 | -- | 21 | -- Module : Data.Row.Variants 22 | -- 23 | -- This module implements extensible variants using closed type families. 24 | -- 25 | ----------------------------------------------------------------------------- 26 | 27 | 28 | module Data.Row.Variants 29 | ( 30 | -- * Types and constraints 31 | Label(..) 32 | , KnownSymbol, AllUniqueLabels, WellBehaved 33 | , Var, Row, Empty, type (≈) 34 | -- * Construction 35 | , HasType, pattern IsJust, singleton, unSingleton 36 | , fromLabels, fromLabelsMap 37 | -- ** Extension 38 | , type (.\), Lacks, type (.\/), diversify, extend, type (.+) 39 | -- ** Modification 40 | , update, focus, Modify, rename, Rename 41 | -- * Destruction 42 | , impossible, trial, trial', multiTrial, view 43 | , Subset 44 | , restrict, split 45 | -- ** Types for destruction 46 | , type (.!), type (.-), type (.\\), type (.==) 47 | -- * Native Conversion 48 | -- $native 49 | , toNative, fromNative, fromNativeGeneral 50 | , ToNative, FromNative, FromNativeGeneral 51 | , NativeRow 52 | -- * Row operations 53 | -- ** Map 54 | , Map, map, map', transform, transform' 55 | -- ** Fold 56 | , Forall, erase, eraseWithLabels, eraseZipGeneral, eraseZip 57 | -- ** Applicative-like functions 58 | , traverse, traverseMap 59 | , sequence 60 | -- ** Compose 61 | -- $compose 62 | , compose, uncompose 63 | -- ** labels 64 | , labels 65 | -- ** ApSingle functions 66 | , eraseSingle, mapSingle, mapSingleA, eraseZipSingle 67 | -- ** Coerce 68 | , coerceVar 69 | ) 70 | where 71 | 72 | import Prelude hiding (map, sequence, traverse, zip) 73 | 74 | import Control.Applicative 75 | import Control.DeepSeq (NFData(..), deepseq) 76 | 77 | import Data.Bifunctor (Bifunctor(..)) 78 | import Data.Coerce 79 | import Data.Functor.Compose 80 | import Data.Functor.Identity 81 | import Data.Functor.Product 82 | import Data.Generics.Sum.Constructors (AsConstructor(..), AsConstructor'(..)) 83 | import Data.Maybe (fromMaybe) 84 | import Data.Profunctor (Choice(..), Profunctor(..)) 85 | import Data.Proxy 86 | import Data.String (IsString) 87 | import Data.Text (Text) 88 | 89 | import qualified GHC.Generics as G 90 | import GHC.TypeLits 91 | 92 | import Unsafe.Coerce 93 | 94 | import Data.Row.Dictionaries 95 | import Data.Row.Internal 96 | 97 | {-------------------------------------------------------------------- 98 | Polymorphic Variants 99 | --------------------------------------------------------------------} 100 | 101 | -- | The variant type. 102 | data Var (r :: Row *) where 103 | OneOf :: Text -> HideType -> Var r 104 | 105 | instance Forall r Show => Show (Var r) where 106 | show v = (\ (x, y) -> "{" ++ x ++ "=" ++ y ++ "}") $ eraseWithLabels @Show show v 107 | 108 | instance Forall r Eq => Eq (Var r) where 109 | r == r' = fromMaybe False $ eraseZip @Eq (==) r r' 110 | 111 | instance (Forall r Eq, Forall r Ord) => Ord (Var r) where 112 | compare :: Var r -> Var r -> Ordering 113 | compare = eraseZipGeneral @Ord @r @Ordering @Text $ \case 114 | (Left (_, x, y)) -> compare x y 115 | (Right ((s1, _), (s2, _))) -> compare s1 s2 116 | 117 | instance Forall r NFData => NFData (Var r) where 118 | rnf r = getConst $ metamorph @_ @r @NFData @Either @Var @(Const ()) @Identity Proxy empty doUncons doCons r 119 | where empty = const $ Const () 120 | doUncons l = second Identity . flip trial l 121 | doCons _ x = deepseq x $ Const () 122 | 123 | 124 | {-------------------------------------------------------------------- 125 | Basic Operations 126 | --------------------------------------------------------------------} 127 | 128 | -- | A Variant with no options is uninhabited. 129 | impossible :: Var Empty -> a 130 | impossible _ = error "Impossible! Somehow, a variant of nothing was produced." 131 | 132 | -- | A quick constructor to create a singleton variant. 133 | singleton :: KnownSymbol l => Label l -> a -> Var (l .== a) 134 | singleton = IsJust 135 | 136 | -- | A quick destructor for singleton variants. 137 | unSingleton :: forall l a. KnownSymbol l => Var (l .== a) -> (Label l, a) 138 | unSingleton (OneOf _ (HideType x)) = (l, unsafeCoerce x) where l = Label @l 139 | 140 | -- | A pattern for variants; can be used to both destruct a variant 141 | -- when in a pattern position or construct one in an expression position. 142 | pattern IsJust :: forall l r. (AllUniqueLabels r, KnownSymbol l) => Label l -> r .! l -> Var r 143 | pattern IsJust l a <- (isJustHelper @l -> (l, Just a)) where 144 | IsJust (toKey -> l) = OneOf l . HideType 145 | 146 | isJustHelper :: forall l r. KnownSymbol l => Var r -> (Label l, Maybe (r .! l)) 147 | isJustHelper v = (l, view l v) where l = Label @l 148 | 149 | -- | Make the variant arbitrarily more diverse. 150 | diversify :: forall r' r. Var r -> Var (r .\/ r') 151 | diversify = unsafeCoerce -- (OneOf l x) = OneOf l x 152 | 153 | -- | A weaker version of 'diversify', but it's helpful for 'metamorph' as it explicitly 154 | -- uses 'Extend'. 155 | extend :: forall a l r. KnownSymbol l => Label l -> Var r -> Var (Extend l a r) 156 | extend _ = unsafeCoerce 157 | 158 | -- | If the variant exists at the given label, update it to the given value. 159 | -- Otherwise, do nothing. 160 | update :: (KnownSymbol l, r .! l ≈ a) => Label l -> a -> Var r -> Var r 161 | update (toKey -> l') a (OneOf l x) = OneOf l $ if l == l' then HideType a else x 162 | 163 | -- | If the variant exists at the given label, focus on the value associated with it. 164 | -- Otherwise, do nothing. 165 | focus :: forall l r r' a b p f. 166 | ( AllUniqueLabels r 167 | , AllUniqueLabels r' 168 | , KnownSymbol l 169 | , r .! l ≈ a 170 | , r' .! l ≈ b 171 | , r' ≈ (r .- l) .\/ (l .== b) 172 | , Applicative f 173 | , Choice p 174 | ) => Label l -> p a (f b) -> p (Var r) (f (Var r')) 175 | focus (toKey -> l) = 176 | dimap unwrap rewrap . left' 177 | where 178 | unwrap :: Var r -> Either a (Var r') 179 | unwrap (OneOf l' (HideType x)) 180 | | l == l' = Left (unsafeCoerce x) 181 | | otherwise = Right (OneOf l' (HideType x)) 182 | rewrap :: Either (f b) (Var r') -> f (Var r') 183 | rewrap = either (fmap $ OneOf l . HideType) pure 184 | 185 | -- | Rename the given label. 186 | rename :: (KnownSymbol l, KnownSymbol l') => Label l -> Label l' -> Var r -> Var (Rename l l' r) 187 | rename (toKey -> l1) (toKey -> l2) (OneOf l x) = OneOf (if l == l1 then l2 else l) x 188 | 189 | -- | Convert a variant into either the value at the given label or a variant without 190 | -- that label. This is the basic variant destructor. 191 | trial :: KnownSymbol l => Var r -> Label l -> Either (Var (r .- l)) (r .! l) 192 | trial (OneOf l (HideType x)) (toKey -> l') = if l == l' then Right (unsafeCoerce x) else Left (OneOf l (HideType x)) 193 | 194 | -- | A version of 'trial' that ignores the leftover variant. 195 | trial' :: KnownSymbol l => Var r -> Label l -> Maybe (r .! l) 196 | trial' = (either (const Nothing) Just .) . trial 197 | 198 | -- | A trial over multiple types 199 | multiTrial :: forall x y. (AllUniqueLabels x, FreeForall x) => Var y -> Either (Var (y .\\ x)) (Var x) 200 | multiTrial (OneOf l x) = if l `elem` labels @x @Unconstrained1 then Right (OneOf l x) else Left (OneOf l x) 201 | 202 | -- | A convenient function for using view patterns when dispatching variants. 203 | -- For example: 204 | -- 205 | -- @ 206 | -- myShow :: Var ("y" '::= String :| "x" '::= Int :| Empty) -> String 207 | -- myShow (view x -> Just n) = "Int of "++show n 208 | -- myShow (view y -> Just s) = "String of "++s @ 209 | view :: KnownSymbol l => Label l -> Var r -> Maybe (r .! l) 210 | view = flip trial' 211 | 212 | -- | Split a variant into two sub-variants. 213 | split :: forall s r. (WellBehaved s, Subset s r) => Var r -> Either (Var (r .\\ s)) (Var s) 214 | split (OneOf l a) | l `elem` labels @s @Unconstrained1 = Right $ OneOf l a 215 | | otherwise = Left $ OneOf l a 216 | 217 | -- | Arbitrary variant restriction. Turn a variant into a subset of itself. 218 | restrict :: forall r r'. (WellBehaved r, Subset r r') => Var r' -> Maybe (Var r) 219 | restrict = either (pure Nothing) Just . split 220 | 221 | 222 | {-------------------------------------------------------------------- 223 | Folds and maps 224 | --------------------------------------------------------------------} 225 | 226 | -- | A standard fold 227 | erase :: forall c ρ b. Forall ρ c => (forall a. c a => a -> b) -> Var ρ -> b 228 | erase f = snd @String . eraseWithLabels @c f 229 | 230 | -- | A fold with labels 231 | eraseWithLabels :: forall c ρ s b. (Forall ρ c, IsString s) => (forall a. c a => a -> b) -> Var ρ -> (s,b) 232 | eraseWithLabels f = getConst . metamorph @_ @ρ @c @Either @Var @(Const (s,b)) @Identity Proxy impossible doUncons doCons 233 | where doUncons l = second Identity . flip trial l 234 | doCons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ) 235 | => Label ℓ -> Either (Const (s,b) ρ) (Identity τ) -> Const (s,b) (Extend ℓ τ ρ) 236 | doCons _ (Left (Const c)) = Const c 237 | doCons l (Right (Identity x)) = Const (show' l, f x) 238 | 239 | 240 | data ErasedVal c s = forall y. c y => ErasedVal (s, y) 241 | data ErasePair c s ρ = ErasePair (Either (ErasedVal c s) (Var ρ)) (Either (ErasedVal c s) (Var ρ)) 242 | 243 | -- | A fold over two variants at once. A call @eraseZipGeneral f x y@ will return 244 | -- @f (Left (show l, a, b))@ when 'x' and 'y' both have values at the same label 'l' 245 | -- and will return @f (Right ((show l1, a), (show l2, b)))@ when they have values 246 | -- at different labels 'l1' and 'l2' respectively. 247 | eraseZipGeneral 248 | :: forall c ρ b s. (Forall ρ c, IsString s) 249 | => (forall x y. (c x, c y) => Either (s, x, x) ((s, x), (s, y)) -> b) 250 | -> Var ρ -> Var ρ -> b 251 | eraseZipGeneral f x y = getConst $ metamorph @_ @ρ @c @Either @(ErasePair c s) @(Const b) @(Const b) Proxy doNil doUncons doCons (ErasePair (Right x) (Right y)) 252 | where 253 | doNil (ErasePair (Left (ErasedVal a)) (Left (ErasedVal b))) = 254 | Const $ f $ Right (a, b) 255 | doNil (ErasePair (Right x) _) = impossible x 256 | doNil (ErasePair _ (Right y)) = impossible y 257 | doUncons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ, HasType ℓ τ ρ) 258 | => Label ℓ -> ErasePair c s ρ -> Either (ErasePair c s (ρ .- ℓ)) (Const b τ) 259 | doUncons _ (ErasePair (Left (ErasedVal a)) (Left (ErasedVal b))) = 260 | Right $ Const $ f $ Right (a, b) 261 | doUncons l (ErasePair (Right x) (Left eb)) = case (trial x l, eb) of 262 | (Right a, ErasedVal b) -> Right $ Const $ f $ Right ((show' l, a), b) 263 | (Left x', _) -> Left $ ErasePair (Right x') (Left eb) 264 | doUncons l (ErasePair (Left ea) (Right y)) = case (ea, trial y l) of 265 | (ErasedVal a, Right b) -> Right $ Const $ f $ Right (a, (show' l, b)) 266 | (_, Left x') -> Left $ ErasePair (Left ea) (Right x') 267 | doUncons l (ErasePair (Right x) (Right y)) = case (trial x l, trial y l) of 268 | (Right (a :: x), Right b) -> Right $ Const $ f @x @x $ Left (show' l, a, b) 269 | (Right a, Left y') -> Left $ ErasePair (Left $ ErasedVal (show' l, a)) (Right y') 270 | (Left x', Right b) -> Left $ ErasePair (Right x') (Left $ ErasedVal (show' l, b)) 271 | (Left x', Left y') -> Left $ ErasePair (Right x') (Right y') 272 | doCons _ (Left (Const b)) = Const b 273 | doCons _ (Right (Const b)) = Const b 274 | 275 | 276 | -- | A simpler fold over two variants at once 277 | eraseZip :: forall c ρ b. Forall ρ c => (forall a. c a => a -> a -> b) -> Var ρ -> Var ρ -> Maybe b 278 | eraseZip f = eraseZipGeneral @c @ρ @(Maybe b) @Text $ \case 279 | Left (_,x,y) -> Just (f x y) 280 | _ -> Nothing 281 | 282 | 283 | -- | VMap is used internally as a type level lambda for defining variant maps. 284 | newtype VMap f ρ = VMap { unVMap :: Var (Map f ρ) } 285 | newtype VMap2 f g ρ = VMap2 { unVMap2 :: Var (Map f (Map g ρ)) } 286 | 287 | -- | A function to map over a variant given a constraint. 288 | map :: forall c f r. Forall r c => (forall a. c a => a -> f a) -> Var r -> Var (Map f r) 289 | map f = unVMap . metamorph @_ @r @c @Either @Var @(VMap f) @Identity Proxy impossible doUncons doCons 290 | where 291 | doUncons l = second Identity . flip trial l 292 | doCons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ, AllUniqueLabels (Extend ℓ τ ρ)) 293 | => Label ℓ -> Either (VMap f ρ) (Identity τ) -> VMap f (Extend ℓ τ ρ) 294 | doCons l (Left (VMap v)) = VMap $ extend @(f τ) l v 295 | \\ mapExtendSwap @f @ℓ @τ @ρ 296 | doCons l (Right (Identity x)) = VMap $ IsJust l (f x) 297 | \\ mapExtendSwap @f @ℓ @τ @ρ 298 | \\ extendHas @ℓ @(f τ) @(Map f ρ) 299 | \\ uniqueMap @f @(Extend ℓ τ ρ) 300 | 301 | -- | A function to map over a variant given no constraint. 302 | map' :: forall f r. FreeForall r => (forall a. a -> f a) -> Var r -> Var (Map f r) 303 | map' f = map @Unconstrained1 f 304 | 305 | -- | Lifts a natrual transformation over a variant. In other words, it acts as a 306 | -- variant transformer to convert a variant of @f a@ values to a variant of @g a@ 307 | -- values. If no constraint is needed, instantiate the first type argument with 308 | -- 'Unconstrained1'. 309 | transform :: forall c r f g. Forall r c => (forall a. c a => f a -> g a) -> Var (Map f r) -> Var (Map g r) 310 | transform f = unVMap . metamorph @_ @r @c @Either @(VMap f) @(VMap g) @f Proxy doNil doUncons doCons . VMap 311 | where 312 | doNil = impossible . unVMap 313 | doUncons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ, HasType ℓ τ ρ) 314 | => Label ℓ -> VMap f ρ -> Either (VMap f (ρ .- ℓ)) (f τ) 315 | doUncons l = first VMap . flip trial l . unVMap 316 | \\ mapHas @f @ℓ @τ @ρ 317 | doCons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ, AllUniqueLabels (Extend ℓ τ ρ)) 318 | => Label ℓ -> Either (VMap g ρ) (f τ) -> VMap g (Extend ℓ τ ρ) 319 | doCons l (Left (VMap v)) = VMap $ extend @(g τ) l v 320 | \\ mapExtendSwap @g @ℓ @τ @ρ 321 | doCons l (Right x) = VMap $ IsJust l (f x) 322 | \\ mapExtendSwap @g @ℓ @τ @ρ 323 | \\ extendHas @ℓ @(g τ) @(Map g ρ) 324 | \\ uniqueMap @g @(Extend ℓ τ ρ) 325 | 326 | -- | A form of @transformC@ that doesn't have a constraint on @a@ 327 | transform' :: forall r f g . FreeForall r => (forall a. f a -> g a) -> Var (Map f r) -> Var (Map g r) 328 | transform' f = transform @Unconstrained1 @r f 329 | 330 | -- | Traverse a function over a variant. 331 | traverse :: forall c f r. (Forall r c, Functor f) => (forall a. c a => a -> f a) -> Var r -> f (Var r) 332 | traverse f = sequence' @f @r @c . map @c @f @r f 333 | 334 | -- | Traverse a function over a Mapped variant. 335 | traverseMap :: forall c f g h r. 336 | (Forall r c, Functor f) => (forall a. c a => g a -> f (h a)) -> Var (Map g r) -> f (Var (Map h r)) 337 | traverseMap f = 338 | sequence' @f @(Map h r) @(IsA c h) . 339 | uncompose' @c @f @h @r . 340 | transform @c @r @g @(Compose f h) (Compose . f) 341 | \\ mapForall @h @r @c 342 | 343 | -- | Applicative sequencing over a variant with arbitrary constraint. 344 | sequence' :: forall f r c. (Forall r c, Functor f) => Var (Map f r) -> f (Var r) 345 | sequence' = getCompose . metamorph @_ @r @c @Either @(VMap f) @(Compose f Var) @f Proxy doNil doUncons doCons . VMap 346 | where 347 | doNil = impossible . unVMap 348 | doUncons :: forall ℓ τ ρ. (KnownSymbol ℓ, HasType ℓ τ ρ) 349 | => Label ℓ -> VMap f ρ -> Either (VMap f (ρ .- ℓ)) (f τ) 350 | doUncons l = first VMap . flip trial l . unVMap 351 | \\ mapHas @f @ℓ @τ @ρ 352 | doCons :: forall ℓ τ ρ. (KnownSymbol ℓ, AllUniqueLabels (Extend ℓ τ ρ)) 353 | => Label ℓ -> Either (Compose f Var ρ) (f τ) -> Compose f Var (Extend ℓ τ ρ) 354 | doCons l (Left (Compose v)) = Compose $ extend @τ l <$> v 355 | doCons l (Right fx) = Compose $ IsJust l <$> fx 356 | \\ extendHas @ℓ @τ @ρ 357 | 358 | 359 | -- | Applicative sequencing over a variant 360 | sequence :: forall f r. (FreeForall r, Functor f) => Var (Map f r) -> f (Var r) 361 | sequence = sequence' @f @r @Unconstrained1 362 | 363 | -- $compose 364 | -- We can easily convert between mapping two functors over the types of a row 365 | -- and mapping the composition of the two functors. The following two functions 366 | -- perform this composition with the gaurantee that: 367 | -- 368 | -- >>> compose . uncompose = id 369 | -- 370 | -- >>> uncompose . compose = id 371 | 372 | -- | Convert from a variant where two functors have been mapped over the types to 373 | -- one where the composition of the two functors is mapped over the types. 374 | compose :: forall f g r . FreeForall r => Var (Map f (Map g r)) -> Var (Map (Compose f g) r) 375 | compose = unVMap . metamorph @_ @r @Unconstrained1 @Either @(VMap2 f g) @(VMap (Compose f g)) @(Compose f g) Proxy doNil doUncons doCons . VMap2 376 | where 377 | doNil = impossible . unVMap2 378 | doUncons :: forall ℓ τ ρ. (KnownSymbol ℓ, HasType ℓ τ ρ) 379 | => Label ℓ -> VMap2 f g ρ -> Either (VMap2 f g (ρ .- ℓ)) (Compose f g τ) 380 | doUncons l = bimap VMap2 Compose . flip trial l . unVMap2 381 | \\ mapHas @f @ℓ @(g τ) @(Map g ρ) 382 | \\ mapHas @g @ℓ @τ @ρ 383 | doCons :: forall ℓ τ ρ. (KnownSymbol ℓ, AllUniqueLabels (Extend ℓ τ ρ)) 384 | => Label ℓ -> Either (VMap (Compose f g) ρ) (Compose f g τ) -> VMap (Compose f g) (Extend ℓ τ ρ) 385 | doCons l (Left (VMap v)) = VMap $ extend @(Compose f g τ) l v 386 | \\ mapExtendSwap @(Compose f g) @ℓ @τ @ρ 387 | doCons l (Right x) = VMap $ IsJust l x 388 | \\ mapExtendSwap @(Compose f g) @ℓ @τ @ρ 389 | \\ extendHas @ℓ @((Compose f g) τ) @(Map (Compose f g) ρ) 390 | \\ uniqueMap @(Compose f g) @(Extend ℓ τ ρ) 391 | 392 | -- | A version of 'uncompose' that allows an arbitrary constraint. 393 | uncompose' :: forall c f g r . Forall r c => Var (Map (Compose f g) r) -> Var (Map f (Map g r)) 394 | uncompose' = unVMap2 . metamorph @_ @r @c @Either @(VMap (Compose f g)) @(VMap2 f g) @(Compose f g) Proxy doNil doUncons doCons . VMap 395 | where 396 | doNil = impossible . unVMap 397 | doUncons :: forall ℓ τ ρ. (KnownSymbol ℓ, HasType ℓ τ ρ) 398 | => Label ℓ -> VMap (Compose f g) ρ -> Either (VMap (Compose f g) (ρ .- ℓ)) (Compose f g τ) 399 | doUncons l = first VMap . flip trial l . unVMap 400 | \\ mapHas @(Compose f g) @ℓ @τ @ρ 401 | doCons :: forall ℓ τ ρ. (KnownSymbol ℓ, AllUniqueLabels (Extend ℓ τ ρ)) 402 | => Label ℓ -> Either (VMap2 f g ρ) (Compose f g τ) -> VMap2 f g (Extend ℓ τ ρ) 403 | doCons l (Left (VMap2 v)) = VMap2 $ extend @(f (g τ)) l v 404 | \\ mapExtendSwap @f @ℓ @(g τ) @(Map g ρ) 405 | \\ mapExtendSwap @g @ℓ @τ @ρ 406 | doCons l (Right (Compose x)) = VMap2 $ IsJust l x 407 | \\ mapExtendSwap @f @ℓ @(g τ) @(Map g ρ) 408 | \\ mapExtendSwap @g @ℓ @τ @ρ 409 | \\ extendHas @ℓ @(f (g τ)) @(Map f (Map g ρ)) 410 | \\ uniqueMap @f @(Extend ℓ (g τ) (Map g ρ)) 411 | \\ uniqueMap @g @(Extend ℓ τ ρ) 412 | 413 | -- | Convert from a variant where the composition of two functors have been mapped 414 | -- over the types to one where the two functors are mapped individually one at a 415 | -- time over the types. 416 | uncompose :: forall f g r . FreeForall r => Var (Map (Compose f g) r) -> Var (Map f (Map g r)) 417 | uncompose = uncompose' @Unconstrained1 @f @g @r 418 | 419 | -- | Coerce a variant to a coercible representation. The 'BiForall' in the context 420 | -- indicates that the type of any option in @r1@ can be coerced to the type of 421 | -- the corresponding option in @r2@. 422 | -- 423 | -- Internally, this is implemented just with `unsafeCoerce`, but we provide the 424 | -- following implementation as a proof: 425 | -- 426 | -- > newtype ConstV a b = ConstV { unConstV :: Var a } 427 | -- > newtype ConstV a b = FlipConstV { unFlipConstV :: Var b } 428 | -- > coerceVar :: forall r1 r2. BiForall r1 r2 Coercible => Var r1 -> Var r2 429 | -- > coerceVar = unFlipConstV . biMetamorph @_ @_ @r1 @r2 @Coercible @Either @ConstV @FlipConstV @Const Proxy doNil doUncons doCons . ConstV 430 | -- > where 431 | -- > doNil = impossible . unConstV 432 | -- > doUncons l = bimap ConstV Const . flip trial l . unConstV 433 | -- > doCons :: forall ℓ τ1 τ2 ρ1 ρ2. (KnownSymbol ℓ, Coercible τ1 τ2, AllUniqueLabels (Extend ℓ τ2 ρ2)) 434 | -- > => Label ℓ -> Either (FlipConstV ρ1 ρ2) (Const τ1 τ2) 435 | -- > -> FlipConstV (Extend ℓ τ1 ρ1) (Extend ℓ τ2 ρ2) 436 | -- > doCons l (Left (FlipConstV v)) = FlipConstV $ extend @τ2 l v 437 | -- > doCons l (Right (Const x)) = FlipConstV $ IsJust l (coerce @τ1 @τ2 x) 438 | -- > \\ extendHas @ρ2 @ℓ @τ2 439 | coerceVar :: forall r1 r2. BiForall r1 r2 Coercible => Var r1 -> Var r2 440 | coerceVar = unsafeCoerce 441 | 442 | {-------------------------------------------------------------------- 443 | Variant initialization 444 | --------------------------------------------------------------------} 445 | 446 | -- | Initialize a variant from a producer function that accepts labels. If this 447 | -- function returns more than one possibility, then one is chosen arbitrarily to 448 | -- be the value in the variant. 449 | fromLabels :: forall c ρ f. (Alternative f, Forall ρ c, AllUniqueLabels ρ) 450 | => (forall l a. (KnownSymbol l, c a) => Label l -> f a) -> f (Var ρ) 451 | fromLabels mk = getCompose $ metamorph @_ @ρ @c @Const @(Const ()) @(Compose f Var) @Proxy 452 | Proxy doNil doUncons doCons (Const ()) 453 | where doNil _ = Compose $ empty 454 | doUncons _ _ = Const $ Const () 455 | doCons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ, AllUniqueLabels (Extend ℓ τ ρ)) 456 | => Label ℓ -> Const (Compose f Var ρ) (Proxy τ) -> Compose f Var (Extend ℓ τ ρ) 457 | doCons l (Const (Compose v)) = Compose $ IsJust l <$> mk l <|> extend @τ l <$> v 458 | \\ extendHas @ℓ @τ @ρ 459 | 460 | -- | Initialize a variant over a `Map`. 461 | fromLabelsMap :: forall c f g ρ. (Alternative f, Forall ρ c, AllUniqueLabels ρ) 462 | => (forall l a. (KnownSymbol l, c a) => Label l -> f (g a)) -> f (Var (Map g ρ)) 463 | fromLabelsMap f = fromLabels @(IsA c g) @(Map g ρ) @f inner 464 | \\ mapForall @g @ρ @c 465 | \\ uniqueMap @g @ρ 466 | where inner :: forall l a. (KnownSymbol l, IsA c g a) => Label l -> f a 467 | inner l = case as @c @g @a of As -> f l 468 | 469 | {-------------------------------------------------------------------- 470 | Functions for variants of ApSingle 471 | --------------------------------------------------------------------} 472 | 473 | newtype VApS x fs = VApS { unVApS :: Var (ApSingle fs x) } 474 | newtype VApSF x g fs = VApSF { unVApSF :: g (Var (ApSingle fs x)) } 475 | newtype FlipApp (x :: k) (f :: k -> *) = FlipApp (f x) 476 | 477 | -- | A version of 'erase' that works even when the row-type of the variant argument 478 | -- is of the form @ApSingle fs x@. 479 | eraseSingle 480 | :: forall c fs x y 481 | . Forall fs c 482 | => (forall f . (c f) => f x -> y) 483 | -> Var (ApSingle fs x) 484 | -> y 485 | eraseSingle f = erase @(ActsOn c x) @(ApSingle fs x) @y g 486 | \\ apSingleForall @x @fs @c 487 | where 488 | g :: forall a. ActsOn c x a => a -> y 489 | g a = case actsOn @c @x @a of As' -> f a 490 | 491 | -- | Performs a functorial-like map over an 'ApSingle' variant. 492 | -- In other words, it acts as a variant transformer to convert a variant of 493 | -- @f x@ values to a variant of @f y@ values. If no constraint is needed, 494 | -- instantiate the first type argument with 'Unconstrained1'. 495 | mapSingle 496 | :: forall c fs x y 497 | . (Forall fs c) 498 | => (forall f . (c f) => f x -> f y) 499 | -> Var (ApSingle fs x) 500 | -> Var (ApSingle fs y) 501 | mapSingle f = runIdentity . mapSingleA @c @fs @Identity @x @y (pure . f) 502 | 503 | 504 | -- | Like `mapSingle`, but works over a functor. 505 | mapSingleA :: forall c fs g x y. 506 | (Forall fs c, Functor g) => (forall f. c f => f x -> g (f y)) -> Var (ApSingle fs x) -> g (Var (ApSingle fs y)) 507 | mapSingleA f = unVApSF . metamorph @_ @fs @c @Either @(VApS x) @(VApSF y g) @(FlipApp x) 508 | Proxy doNil doUncons doCons . VApS 509 | where 510 | doNil = impossible . unVApS 511 | 512 | doUncons :: forall l f fs 513 | . ( c f, fs .! l ≈ f, KnownSymbol l) 514 | => Label l -> VApS x fs -> Either (VApS x (fs .- l)) (FlipApp x f) 515 | doUncons l = bimap VApS FlipApp 516 | . flip (trial \\ apSingleHas @x @l @f @fs) l 517 | . unVApS 518 | 519 | doCons :: forall l f fs. (KnownSymbol l, c f, AllUniqueLabels (Extend l f fs)) 520 | => Label l 521 | -> Either (VApSF y g fs) (FlipApp x f) 522 | -> VApSF y g (Extend l f fs) 523 | doCons l (Right (FlipApp x)) = VApSF $ IsJust l <$> (f x) 524 | \\ apSingleExtendSwap @y @l @f @fs 525 | \\ extendHas @l @(f y) @(ApSingle fs y) 526 | \\ uniqueApSingle @y @(Extend l f fs) 527 | doCons l (Left (VApSF v)) = VApSF $ extend @(f y) l <$> v 528 | \\ apSingleExtendSwap @y @l @f @fs 529 | 530 | 531 | -- | A version of 'eraseZip' that works even when the row-types of the variant 532 | -- arguments are of the form @ApSingle fs x@. 533 | eraseZipSingle :: forall c fs x y z 534 | . (Forall fs c) 535 | => (forall f. c f => f x -> f y -> z) 536 | -> Var (ApSingle fs x) -> Var (ApSingle fs y) -> Maybe z 537 | eraseZipSingle f x y = getConst $ metamorph @_ @fs @c @Either 538 | @(Product (VApS x) (VApS y)) @(Const (Maybe z)) @(Const (Maybe z)) 539 | Proxy doNil doUncons doCons (Pair (VApS x) (VApS y)) 540 | 541 | where doNil :: Product (VApS x) (VApS y) Empty 542 | -> Const (Maybe z) Empty 543 | doNil (Pair (VApS z) _) = Const (impossible z) 544 | 545 | doUncons :: forall l f ρ 546 | . (KnownSymbol l, c f, ρ .! l ≈ f) 547 | => Label l 548 | -> Product (VApS x) (VApS y) ρ 549 | -> Either (Product (VApS x) (VApS y) (ρ .- l)) 550 | (Const (Maybe z) f) 551 | doUncons l (Pair (VApS r1) (VApS r2)) = 552 | case ( 553 | trial r1 l \\ apSingleHas @x @l @f @ρ, 554 | trial r2 l \\ apSingleHas @y @l @f @ρ 555 | ) of 556 | (Right u, Right v) -> Right $ Const $ Just $ f @f u v 557 | (Left us, Left vs) -> Left (Pair (VApS us) (VApS vs)) 558 | _ -> Right $ Const Nothing 559 | 560 | doCons :: forall k l τ (ρ :: Row k) 561 | . Label l 562 | -> Either (Const (Maybe z) ρ) (Const (Maybe z) τ) 563 | -> Const (Maybe z) (Extend l τ ρ) 564 | doCons _ (Left (Const w)) = Const w 565 | doCons _ (Right (Const w)) = Const w 566 | 567 | {-------------------------------------------------------------------- 568 | Generic instance 569 | --------------------------------------------------------------------} 570 | 571 | -- The generic structure we want Vars to have is not the hidden internal one, 572 | -- but rather one that appears as a Haskell sum type. Thus, we can't derive 573 | -- Generic automatically. 574 | -- 575 | -- The following Generic instance creates a representation of a Var that is 576 | -- very similar to a native Haskell sum type except that the tree of possibilities (':+:') 577 | -- that it produces will be extremely unbalanced. I don't think this is a problem. 578 | -- Furthermore, because we don't want Vars to always have a trailing void option on 579 | -- the end, we must have a special case for singleton Vars, which means that 580 | -- we can't use metamorph. 581 | 582 | instance GenericVar r => G.Generic (Var r) where 583 | type Rep (Var r) = 584 | G.D1 ('G.MetaData "Var" "Data.Row.Variants" "row-types" 'False) (RepVar r) 585 | from = G.M1 . fromVar 586 | to = toVar . G.unM1 587 | 588 | class GenericVar r where 589 | type RepVar (r :: Row *) :: * -> * 590 | fromVar :: Var r -> RepVar r x 591 | toVar :: RepVar r x -> Var r 592 | 593 | instance GenericVar Empty where 594 | type RepVar Empty = G.V1 595 | fromVar = impossible 596 | toVar = \case 597 | 598 | instance KnownSymbol name => GenericVar (R '[name :-> t]) where 599 | type RepVar (R (name :-> t ': '[])) = G.C1 600 | ('G.MetaCons name 'G.PrefixI 'False) 601 | (G.S1 ('G.MetaSel 'Nothing 'G.NoSourceUnpackedness 'G.NoSourceStrictness 'G.DecidedLazy) 602 | (G.Rec0 t)) 603 | fromVar (unSingleton -> (_, a)) = G.M1 (G.M1 (G.K1 a)) 604 | toVar (G.M1 (G.M1 (G.K1 a))) = IsJust (Label @name) a 605 | 606 | instance 607 | ( GenericVar (R (name' :-> t' ': r')) 608 | , KnownSymbol name, Extend name t ('R (name' :-> t' ': r')) ≈ 'R (name :-> t ': (name' :-> t' ': r')) 609 | , AllUniqueLabels (R (name :-> t ': (name' :-> t' ': r'))) 610 | ) => GenericVar (R (name :-> t ': (name' :-> t' ': r'))) where 611 | type RepVar (R (name :-> t ': (name' :-> t' ': r'))) = (G.C1 612 | ('G.MetaCons name 'G.PrefixI 'False) 613 | (G.S1 ('G.MetaSel 'Nothing 'G.NoSourceUnpackedness 'G.NoSourceStrictness 'G.DecidedLazy) 614 | (G.Rec0 t))) G.:+: RepVar (R (name' :-> t' ': r')) 615 | fromVar v = case trial @name v Label of 616 | Left v' -> G.R1 (fromVar v') 617 | Right a -> G.L1 (G.M1 (G.M1 (G.K1 a))) 618 | toVar (G.L1 (G.M1 (G.M1 (G.K1 a)))) = IsJust (Label @name) a 619 | toVar (G.R1 g) = extend @t @name @('R (name' :-> t' ': r')) Label $ toVar g 620 | 621 | {-------------------------------------------------------------------- 622 | Native data type compatibility 623 | --------------------------------------------------------------------} 624 | 625 | -- $native 626 | -- The 'toNative' and 'fromNative' functions allow one to convert between 627 | -- 'Var's and regular Haskell data types ("native" types) that have the same 628 | -- number of constructors such that each constructor has one field and the same 629 | -- name as one of the options of the 'Var', which has the same type as that field. 630 | -- As expected, they compose to form the identity. Alternatively, one may use 631 | -- 'fromNativeGeneral', which allows a variant with excess options to still be 632 | -- transformed to a native type. Because of this, 'fromNativeGeneral' requires a type 633 | -- application (although 'fromNative' does not). The only requirement is that 634 | -- the native Haskell data type be an instance of 'Generic'. 635 | -- 636 | -- For example, consider the following simple data type: 637 | -- 638 | -- >>> data Pet = Dog {age :: Int} | Cat {age :: Int} deriving (Generic, Show) 639 | -- 640 | -- Then, we have the following: 641 | -- 642 | -- >>> toNative $ IsJust (Label @"Dog") 3 :: Pet 643 | -- Dog {age = 3} 644 | -- >>> V.fromNative $ Dog 3 :: Var ("Dog" .== Int .+ "Cat" .== Int) 645 | -- {Dog=3} 646 | 647 | type family NativeRow t where 648 | NativeRow t = NativeRowG (G.Rep t) 649 | 650 | type family NativeRowG t where 651 | NativeRowG (G.M1 G.D m cs) = NativeRowG cs 652 | NativeRowG G.V1 = Empty 653 | NativeRowG (l G.:+: r) = NativeRowG l .+ NativeRowG r 654 | NativeRowG (G.C1 ('G.MetaCons name fixity sels) (G.S1 m (G.Rec0 t))) = name .== t 655 | 656 | 657 | -- | Conversion helper to bring a variant back into a Haskell type. Note that the 658 | -- native Haskell type must be an instance of 'Generic'. 659 | class ToNativeG a where 660 | toNative' :: Var (NativeRowG a) -> a x 661 | 662 | instance ToNativeG cs => ToNativeG (G.D1 m cs) where 663 | toNative' = G.M1 . toNative' 664 | 665 | instance ToNativeG G.V1 where 666 | toNative' = impossible 667 | 668 | instance (KnownSymbol name) 669 | => ToNativeG (G.C1 ('G.MetaCons name fixity sels) 670 | (G.S1 m (G.Rec0 t))) where 671 | toNative' = G.M1 . G.M1 . G.K1 . snd . unSingleton 672 | 673 | instance ( ToNativeG l, ToNativeG r, (NativeRowG l .+ NativeRowG r) .\\ NativeRowG r ≈ NativeRowG l 674 | , AllUniqueLabels (NativeRowG r), FreeForall (NativeRowG r)) 675 | => ToNativeG (l G.:+: r) where 676 | toNative' v = case multiTrial @(NativeRowG r) @(NativeRowG (l G.:+: r)) v of 677 | Left v' -> G.L1 $ toNative' v' 678 | Right v' -> G.R1 $ toNative' v' 679 | 680 | type ToNative t = (G.Generic t, ToNativeG (G.Rep t)) 681 | 682 | -- | Convert a variant to a native Haskell type. 683 | toNative :: ToNative t => Var (NativeRow t) -> t 684 | toNative = G.to . toNative' 685 | 686 | 687 | -- | Conversion helper to turn a Haskell variant into a row-types extensible 688 | -- variant. Note that the native Haskell type must be an instance of 'Generic'. 689 | class FromNativeG a where 690 | fromNative' :: a x -> Var (NativeRowG a) 691 | 692 | instance FromNativeG cs => FromNativeG (G.D1 m cs) where 693 | fromNative' (G.M1 v) = fromNative' v 694 | 695 | instance FromNativeG G.V1 where 696 | fromNative' = \ case 697 | 698 | instance KnownSymbol name 699 | => FromNativeG (G.C1 ('G.MetaCons name fixity sels) 700 | (G.S1 m (G.Rec0 t))) where 701 | fromNative' (G.M1 (G.M1 (G.K1 x))) = IsJust (Label @name) x 702 | 703 | instance (FromNativeG l, FromNativeG r) => FromNativeG (l G.:+: r) where 704 | -- Ideally, we would use 'diversify' here instead of 'unsafeCoerce', but it 705 | -- makes the constraints really hairy. 706 | fromNative' (G.L1 x) = unsafeCoerce $ fromNative' @l x 707 | fromNative' (G.R1 y) = unsafeCoerce $ fromNative' @r y 708 | 709 | type FromNative t = (G.Generic t, FromNativeG (G.Rep t)) 710 | 711 | -- | Convert a Haskell variant to a row-types Var. 712 | fromNative :: FromNative t => t -> Var (NativeRow t) 713 | fromNative = fromNative' . G.from 714 | 715 | 716 | -- | Conversion helper to turn a Haskell variant into a row-types extensible 717 | -- variant. Note that the native Haskell type must be an instance of 'Generic'. 718 | class FromNativeGeneralG a ρ where 719 | fromNativeGeneral' :: a x -> Var ρ 720 | 721 | instance FromNativeGeneralG cs ρ => FromNativeGeneralG (G.D1 m cs) ρ where 722 | fromNativeGeneral' (G.M1 v) = fromNativeGeneral' v 723 | 724 | instance FromNativeGeneralG G.V1 ρ where 725 | fromNativeGeneral' = \ case 726 | 727 | instance (KnownSymbol name, ρ .! name ≈ t, AllUniqueLabels ρ) 728 | => FromNativeGeneralG (G.C1 ('G.MetaCons name fixity sels) 729 | (G.S1 m (G.Rec0 t))) ρ where 730 | fromNativeGeneral' (G.M1 (G.M1 (G.K1 x))) = IsJust (Label @name) x 731 | 732 | instance (FromNativeGeneralG l ρ, FromNativeGeneralG r ρ) 733 | => FromNativeGeneralG (l G.:+: r) ρ where 734 | -- Ideally, we would use 'diversify' here instead of 'unsafeCoerce', but it 735 | -- makes the constraints really hairy. 736 | fromNativeGeneral' (G.L1 x) = unsafeCoerce $ fromNativeGeneral' @l @ρ x 737 | fromNativeGeneral' (G.R1 y) = unsafeCoerce $ fromNativeGeneral' @r @ρ y 738 | 739 | type FromNativeGeneral t ρ = (G.Generic t, FromNativeGeneralG (G.Rep t) ρ) 740 | 741 | -- | Convert a Haskell variant to a row-types Var. 742 | fromNativeGeneral :: FromNativeGeneral t ρ => t -> Var ρ 743 | fromNativeGeneral = fromNativeGeneral' . G.from 744 | 745 | 746 | {-------------------------------------------------------------------- 747 | Generic-lens compatibility 748 | --------------------------------------------------------------------} 749 | 750 | -- | Every possibility of a row-types based variant has an 'AsConstructor' instance. 751 | instance {-# OVERLAPPING #-} 752 | ( AllUniqueLabels r 753 | , AllUniqueLabels r' 754 | , KnownSymbol name 755 | , r .! name ≈ a 756 | , r' .! name ≈ b 757 | , r' ≈ (r .- name) .\/ (name .== b)) 758 | => AsConstructor name (Var r) (Var r') a b where 759 | _Ctor = focus (Label @name) 760 | {-# INLINE _Ctor #-} 761 | 762 | instance {-# OVERLAPPING #-} 763 | ( AllUniqueLabels r 764 | , KnownSymbol name 765 | , r .! name ≈ a 766 | , r ≈ (r .- name) .\/ (name .== a)) 767 | => AsConstructor' name (Var r) a where 768 | _Ctor' = focus (Label @name) 769 | {-# INLINE _Ctor' #-} 770 | -------------------------------------------------------------------------------- /src/aeson/Data/Row/Aeson.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | {-# OPTIONS_GHC -Wno-orphans #-} 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Data.Row.Aeson 9 | -- 10 | -- This module adds orphan Aeson instances for 'Rec' and 'Var'. 11 | -- 12 | ----------------------------------------------------------------------------- 13 | 14 | module Data.Row.Aeson () where 15 | 16 | import Data.Aeson 17 | import Data.Aeson.Encoding (pairStr) 18 | import Data.Aeson.Types (typeMismatch) 19 | import Data.List (intercalate) 20 | import Data.Text (Text) 21 | import qualified Data.Text as Text (pack) 22 | 23 | import Data.Row 24 | import qualified Data.Row.Records as Rec 25 | import qualified Data.Row.Variants as Var 26 | 27 | instance Forall r ToJSON => ToJSON (Rec r) where 28 | toJSON = Object . Rec.eraseToHashMap @ToJSON toJSON 29 | 30 | toEncoding = 31 | pairs . foldMap (uncurry pairStr) . Rec.eraseWithLabels @ToJSON toEncoding 32 | 33 | instance (AllUniqueLabels r, Forall r FromJSON) => FromJSON (Rec r) where 34 | parseJSON (Object o) = do 35 | r <- Rec.fromLabelsA @FromJSON $ \ l -> do x <- o .: (show' l) 36 | x `seq` pure x 37 | r `seq` pure r 38 | 39 | parseJSON v = typeMismatch msg v 40 | where msg = "REC: {" ++ intercalate "," (labels @r @FromJSON) ++ "}" 41 | 42 | instance Forall r ToJSON => ToJSON (Var r) where 43 | toJSON v = object [foo l] 44 | where (l, foo) = Var.eraseWithLabels @ToJSON (\v l -> l .= v) v 45 | 46 | instance (AllUniqueLabels r, Forall r FromJSON) => FromJSON (Var r) where 47 | parseJSON (Object o) = Var.fromLabels @FromJSON $ \ l -> o .: (show' l) 48 | parseJSON v = typeMismatch msg v 49 | where msg = "VAR: {" ++ intercalate "," (labels @r @FromJSON) ++ "}" 50 | 51 | show' :: Show a => a -> Text 52 | show' = Text.pack . show 53 | -------------------------------------------------------------------------------- /src/barbies/Data/Row/Barbies.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE InstanceSigs #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE PolyKinds #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | ----------------------------------------------------------------------------- 14 | -- | 15 | -- Module : Data.Row.Barbie 16 | -- 17 | -- This module adds Barbie instances for 'Rec' and 'Var'. 18 | -- 19 | ----------------------------------------------------------------------------- 20 | 21 | 22 | module Data.Row.Barbies () where 23 | 24 | import Data.Functor.Compose 25 | import Data.Functor.Identity 26 | import Data.Functor.Product 27 | import Data.Row 28 | import Data.Row.Dictionaries 29 | import qualified Data.Row.Records as Rec 30 | import qualified Data.Row.Variants as Var 31 | 32 | import Data.Functor.Barbie (FunctorB(..), TraversableB(..), DistributiveB(..), ApplicativeB(..), ConstraintsB(..)) 33 | import qualified Barbies.Constraints as B 34 | 35 | -- | Barbies requires that the functor be the final argument of the type. So, 36 | -- even though the real type is @Rec (Map f ρ)@, we must wrap it in a newtype 37 | -- wrapper so that 'f' is at the end. 38 | newtype BarbieRec (ρ :: Row *) (f :: * -> *) = BarbieRec { unBarbieRec :: Rec (Rec.Map f ρ) } 39 | newtype BarbieVar (ρ :: Row *) (f :: * -> *) = BarbieVar { unBarbieVar :: Var (Var.Map f ρ) } 40 | 41 | instance FreeForall r => FunctorB (BarbieRec r) where 42 | bmap f = BarbieRec . Rec.transform' @r f . unBarbieRec 43 | 44 | instance FreeForall r => TraversableB (BarbieRec r) where 45 | btraverse :: forall e f g. Applicative e => (forall a. f a -> e (g a)) -> BarbieRec r f -> e (BarbieRec r g) 46 | btraverse f = fmap BarbieRec . Rec.traverseMap @Unconstrained1 @e @f @g @r f . unBarbieRec 47 | 48 | instance FreeForall r => DistributiveB (BarbieRec r) where 49 | bdistribute :: forall f g. Functor f => f (BarbieRec r g) -> BarbieRec r (Compose f g) 50 | bdistribute = BarbieRec . Rec.compose @f @g @r . Rec.distribute @f @(Rec.Map g r) . fmap unBarbieRec 51 | \\ freeForall @(Rec.Map g r) @(IsA Unconstrained1 g) \\ mapForall @g @r @Unconstrained1 52 | 53 | instance (AllUniqueLabels r, FreeForall r) => ApplicativeB (BarbieRec r) where 54 | bpure :: forall f. (forall a. f a) -> BarbieRec r f 55 | bpure fa = BarbieRec $ runIdentity $ Rec.fromLabelsMapA @Unconstrained1 @Identity @f @r (const $ Identity fa) 56 | 57 | bprod :: forall f g. BarbieRec r f -> BarbieRec r g -> BarbieRec r (f `Product` g) 58 | bprod (BarbieRec r1) (BarbieRec r2) = BarbieRec $ Rec.zipTransform @Unconstrained1 @r @f @g @(Product f g) Pair r1 r2 59 | 60 | instance FreeForall r => ConstraintsB (BarbieRec r) where 61 | type AllB c (BarbieRec r) = Forall r c 62 | baddDicts :: forall c f. Forall r c => BarbieRec r f -> BarbieRec r (B.Dict c `Product` f) 63 | baddDicts = BarbieRec . Rec.transform @c @r @f @(B.Dict c `Product` f) (Pair (B.Dict @c)) . unBarbieRec 64 | 65 | 66 | 67 | instance FreeForall r => FunctorB (BarbieVar r) where 68 | bmap f = BarbieVar . Var.transform' @r f . unBarbieVar 69 | 70 | instance FreeForall r => TraversableB (BarbieVar r) where 71 | btraverse :: forall e f g. Applicative e => (forall a. f a -> e (g a)) -> BarbieVar r f -> e (BarbieVar r g) 72 | btraverse f = fmap BarbieVar . Var.traverseMap @Unconstrained1 @e @f @g @r f . unBarbieVar 73 | 74 | instance FreeForall r => ConstraintsB (BarbieVar r) where 75 | type AllB c (BarbieVar r) = Forall r c 76 | baddDicts :: forall c f. Forall r c => BarbieVar r f -> BarbieVar r (B.Dict c `Product` f) 77 | baddDicts = BarbieVar . Var.transform @c @r @f @(B.Dict c `Product` f) (Pair (B.Dict @c)) . unBarbieVar 78 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-18.9 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # subdirs: 29 | # - auto-update 30 | # - wai 31 | packages: 32 | - . 33 | # Dependency packages to be pulled from upstream that are not in the resolver. 34 | # These entries can reference officially published versions as well as 35 | # forks / in-progress versions pinned to a git hash. For example: 36 | # 37 | extra-deps: 38 | # - acme-missiles-0.3 39 | # - git: https://github.com/commercialhaskell/stack.git 40 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 41 | # 42 | # extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | # flags: {} 46 | 47 | # Extra package databases containing global packages 48 | # extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=2.3" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | -------------------------------------------------------------------------------- /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 | size: 586923 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/9.yaml 11 | sha256: 9f9fe35c949414146840a985fb228fd397c504d1781b834bfc9ab935f4d27df6 12 | original: lts-18.9 13 | -------------------------------------------------------------------------------- /tests/DiffPerformance.hs: -------------------------------------------------------------------------------- 1 | module DiffPerformance where 2 | 3 | import Data.Row 4 | 5 | type Key l = l .== () 6 | type Common = Key "z" .\/ Key "x" .\/ Key "y" .\/ Key "m" .\/ Key "n" .\/ Key "q" .\/ Key "v" 7 | type Ext l = Common .\/ Key l 8 | 9 | type A = Ext "a" .\/ Ext "b" .\/ Ext "c" .\/ Ext "d" .\/ Ext "e" .\/ Ext "f" .\/ Ext "g" .\/ Ext "h" .\/ Ext "i" 10 | 11 | type AWithoutCommon = Key "a" .\/ Key "b" .\/ Key "c" .\/ Key "d" .\/ Key "e" .\/ Key "f" .\/ Key "g" .\/ Key "h" .\/ Key "i" 12 | 13 | test :: Rec (A .\\ Common) -> Rec AWithoutCommon 14 | test = id 15 | 16 | -------------------------------------------------------------------------------- /tests/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | import Examples () 5 | import DiffPerformance () 6 | import MergePerformance () 7 | import UnionPerformance () 8 | 9 | main = putStrLn "Test passes if Examples.lhs type-checks." 10 | -------------------------------------------------------------------------------- /tests/MergePerformance.hs: -------------------------------------------------------------------------------- 1 | module MergePerformance where 2 | 3 | import Data.Row 4 | 5 | type Key l = l .== () 6 | type Common = Key "z" .\/ Key "x" .\/ Key "y" .\/ Key "m" .\/ Key "n" .\/ Key "q" .\/ Key "v" 7 | type Ext l = Common .\/ Key l 8 | 9 | type A = Ext "a" .\/ Ext "b" .\/ Ext "c" .\/ Ext "d" .\/ Ext "e" .\/ Ext "f" .\/ Ext "g" .\/ Ext "h" .\/ Ext "i" 10 | 11 | test :: Rec (Common .+ A) -> Rec (Common .+ A) 12 | test = id 13 | 14 | -------------------------------------------------------------------------------- /tests/UnionPerformance.hs: -------------------------------------------------------------------------------- 1 | 2 | -- The old implementation of MinJoinR and ConstUnionR (using Ifte) makes GHC blow up when there are 3 | -- nested unions with many overlapping keys. The test suite checks this file with 1GB max heap, 4 | -- which is plenty for the new implementation, but not nearly enough for the old. 5 | 6 | module UnionPerformance where 7 | 8 | import Data.Row 9 | 10 | type Key l = l .== () 11 | type Common = Key "a" .\/ Key "d" .\/ Key "f" .\/ Key "h" .\/ Key "k" .\/ Key "n" .\/ Key "q" .\/ Key "v" 12 | type Ext l = Common .\/ Key l 13 | 14 | type MinJoin = Ext "b" .\/ Ext "e" .\/ Ext "g" .\/ Ext "j" .\/ Ext "o" .\/ Ext "t" .\/ Ext "w" 15 | type ConstUnion = Ext "b" .// Ext "e" .// Ext "g" .// Ext "j" .// Ext "o" .// Ext "t" .// Ext "w" 16 | 17 | test :: Rec MinJoin -> Rec ConstUnion 18 | test = id 19 | 20 | --------------------------------------------------------------------------------