├── .github └── workflows │ └── ci.yaml ├── .gitignore ├── .vscode ├── extensions.json └── settings.json ├── CHANGELOG.md ├── LICENSE ├── README.md ├── bin ├── genrecord └── test ├── flake.lock ├── flake.nix ├── hie.yaml ├── jrec.cabal ├── shell.nix ├── src ├── JRec.hs └── JRec │ ├── Field.hs │ ├── Internal.hs │ └── Tuple.hs └── test ├── JRecShouldNotTypecheckSpec.hs ├── JRecSpec.hs └── Spec.hs /.github/workflows/ci.yaml: -------------------------------------------------------------------------------- 1 | name: "CI" 2 | on: 3 | pull_request: 4 | push: 5 | jobs: 6 | build: 7 | runs-on: ubuntu-latest 8 | steps: 9 | - uses: actions/checkout@v2 10 | - uses: nixbuild/nix-quick-install-action@v21 11 | with: 12 | nix_conf: | 13 | experimental-features = nix-command flakes 14 | - name: Build and test 🔧 15 | run: nix build -j 4 -L 16 | - name: Build and test (GHC 8.8) 🔧 17 | run: nix build -j 4 -L .#jrec-ghc88 18 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.hie 7 | *.chi 8 | *.chs.h 9 | *.dyn_o 10 | *.dyn_hi 11 | .hpc 12 | .hsenv 13 | .cabal-sandbox/ 14 | cabal.sandbox.config 15 | *.prof 16 | *.aux 17 | *.hp 18 | *.eventlog 19 | .stack-work/ 20 | cabal.project.local 21 | cabal.project.local~ 22 | .HTF/ 23 | .ghc.environment.* 24 | 25 | # Nix 26 | result 27 | 28 | -------------------------------------------------------------------------------- /.vscode/extensions.json: -------------------------------------------------------------------------------- 1 | { 2 | // See https://go.microsoft.com/fwlink/?LinkId=827846 3 | // for the documentation about the extensions.json format 4 | "recommendations": [ 5 | "haskell.haskell", 6 | "arrterian.nix-env-selector", 7 | "bbenoist.nix", 8 | "jnoortheen.nix-ide", 9 | "tamasfe.even-better-toml" 10 | ] 11 | } -------------------------------------------------------------------------------- /.vscode/settings.json: -------------------------------------------------------------------------------- 1 | { 2 | "editor.formatOnType": true, 3 | "editor.formatOnSave": true, 4 | "nixEnvSelector.nixFile": "${workspaceRoot}/shell.nix", 5 | "haskell.manageHLS": "PATH" 6 | } -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for rec 2 | 3 | ## Unreleased 4 | 5 | - GHC 9.2 + Aeson 2.0 support 6 | 7 | ## 0.1.0.0 -- YYYY-mm-dd 8 | 9 | * First version. Released on an unsuspecting world. 10 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2020, Juspay Technologies 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | 3. Neither the name of the copyright holder nor the names of its 17 | contributors may be used to endorse or promote products derived from 18 | this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 21 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 24 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 26 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 27 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 28 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # jrec — anonymous records for busy people 2 | 3 | Based on [superrecord](https://hackage.haskell.org/package/superrecord), but simplified. No automatic field reordering. No GHCJS bits inside. Easier to hack on. 4 | 5 | ## Benefits 6 | 7 | * Nice construction syntax: 8 | 9 | ```haskell 10 | Rec (#id := 18853, #orderId := "MG13-233") 11 | ``` 12 | 13 | * Provides `Generic` instances out of the box. Aeson, etc can't believe these aren't normal records! Anything `Generic`-derived just works. 14 | 15 | * Provides `generic-lens` and `generic-optics` instances out of the box. Due to those custom instances, we support polymorphic updates. 16 | 17 | * O(1) field access, O(n) construction. 18 | 19 | * PureScript-style partial records — if you have a `Rec ("foo" := Int ': rest)`, `HasField "foo"` will work just fine. 20 | 21 | ## Developing 22 | 23 | IDE support is available inside `nix-shell`. For example, if you use VS Code, you may launch it as: 24 | 25 | ```bash 26 | nix-shell --run "code ." 27 | ``` 28 | 29 | ### Tests 30 | 31 | Run `bin/test` for fast-reloading tests. When library sources change, the test script will reload instantly and re-run the tests. 32 | 33 | ## TODOs 34 | 35 | * Documentation. 36 | * Expose all internals. 37 | * `-- NOTE: doesn't use 'KeyDoesNotExist'` — fix this. 38 | * `RemoveAccessTo` — can we get rid of it? 39 | 40 | ## Acknowledgement 41 | 42 | * The `JRec.Internal` module is entirely based on the code from [superrecord](https://hackage.haskell.org/package/superrecord). 43 | -------------------------------------------------------------------------------- /bin/genrecord: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env cabal 2 | 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | {- cabal: 6 | build-depends: base, fmt 7 | -} 8 | 9 | import Data.List 10 | import Fmt 11 | 12 | main = do 13 | let n = 62 -- max tuple size 14 | putStrLn 15 | "-- Generated with cabal run -v0 bin/genrecord > src/JRec/Tuple.hs\n\ 16 | \\n\ 17 | \module JRec.Tuple where\n\ 18 | \\n\ 19 | \import qualified JRec.Internal as R\n\ 20 | \import Unsafe.Coerce\n\ 21 | \\n\ 22 | \class RecTuple tuple fields | tuple -> fields, fields -> tuple where\n\ 23 | \ fromTuple :: tuple -> R.Rec fields\n\ 24 | \ toTuple :: R.Rec fields -> tuple\n\ 25 | \\n\ 26 | \" 27 | mapM_ (putStrLn . genInstance) [0 .. n] 28 | 29 | genInstance :: Int -> String 30 | genInstance 0 = 31 | "instance RecTuple () '[] where\n\ 32 | \ fromTuple _ = R.rnil\n\ 33 | \ toTuple _ = ()\n\ 34 | \" 35 | genInstance i = 36 | let fromTuple, toTuple, constraints :: Builder 37 | fromTuple = 38 | format 39 | "fromTuple {} = R.create $ {} R.unsafeRNil {}" 40 | exprTuple 41 | consApps 42 | i 43 | toTuple = 44 | format 45 | "toTuple r = let n = R.FldProxy :: R.FldProxy \"\" in unsafeCoerce {}" 46 | exprGetTuple 47 | constraints = 48 | tupleF $ 49 | [format "n{} ~ n{}'" j j :: Builder | j <- [1 .. i]] 50 | ++ [format "v{} ~ v{}'" j j :: Builder | j <- [1 .. i]] 51 | in format 52 | "instance {} => RecTuple {} {} where\n\ 53 | \ {}\n\ 54 | \ {}\n\ 55 | \" 56 | constraints 57 | typeTuple 58 | typeList 59 | fromTuple 60 | toTuple 61 | where 62 | -- '[n1' R.:= v1', n2' R.:= v2'] 63 | typeList = "'" <> listF [format "n{}' R.:= v{}'" j j :: Builder | j <- [1 .. i]] 64 | -- (n1 R.:= v1, n2 R.:= v2) 65 | typeTuple = tupleF [format "n{} R.:= v{}" j j :: Builder | j <- [1 .. i]] 66 | -- (f1, f2) 67 | exprTuple = tupleF ["f" <> show j | j <- [1 .. i]] 68 | -- [f1, f2] 69 | exprList = listF ["f" <> show j | j <- [1 .. i]] 70 | -- R.unsafeRCons f1 $ R.unsafeRCons f2 $ 71 | consApps = mconcat [format "R.unsafeRCons f{} =<< " j :: Builder | j <- [1 .. i]] 72 | -- (n R.:= R.unsafeGet 0 r, n R.:= R.unsafeGet 1 r) 73 | exprGetTuple = tupleF [format "n R.:= R.unsafeGet {} r" j :: Builder | j <- [0 .. i-1]] 74 | -------------------------------------------------------------------------------- /bin/test: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | set -xe 3 | 4 | # NOTE: ghcid should be run with -W to allow warnings from should-not-typecheck 5 | nix develop -c sh -c "ghcid $* -W -c 'cabal new-repl test:jrec-test' -T \":main $*\"" 6 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-parts": { 4 | "inputs": { 5 | "nixpkgs-lib": "nixpkgs-lib" 6 | }, 7 | "locked": { 8 | "lastModified": 1678379998, 9 | "narHash": "sha256-TZdfNqftHhDuIFwBcN9MUThx5sQXCTeZk9je5byPKRw=", 10 | "owner": "hercules-ci", 11 | "repo": "flake-parts", 12 | "rev": "c13d60b89adea3dc20704c045ec4d50dd964d447", 13 | "type": "github" 14 | }, 15 | "original": { 16 | "owner": "hercules-ci", 17 | "repo": "flake-parts", 18 | "type": "github" 19 | } 20 | }, 21 | "nixpkgs": { 22 | "locked": { 23 | "lastModified": 1678594102, 24 | "narHash": "sha256-OHAHYiMWJFPNxuW/PcOMlSD2tvXnEYC1jxREBADHwwQ=", 25 | "owner": "nixos", 26 | "repo": "nixpkgs", 27 | "rev": "796b4a3c1d903c4b9270cd2548fe46f524eeb886", 28 | "type": "github" 29 | }, 30 | "original": { 31 | "owner": "nixos", 32 | "ref": "nixpkgs-unstable", 33 | "repo": "nixpkgs", 34 | "type": "github" 35 | } 36 | }, 37 | "nixpkgs-ghc88": { 38 | "locked": { 39 | "lastModified": 1596466290, 40 | "narHash": "sha256-V1vrlYfVEdW4iauUc58LCtorSxLLF+X/PhjD5+dQjeQ=", 41 | "owner": "nixos", 42 | "repo": "nixpkgs", 43 | "rev": "76f2e271a2ef9de3734dcc9d366a42d6bfb18e82", 44 | "type": "github" 45 | }, 46 | "original": { 47 | "owner": "nixos", 48 | "ref": "76f2e271a2ef", 49 | "repo": "nixpkgs", 50 | "type": "github" 51 | } 52 | }, 53 | "nixpkgs-lib": { 54 | "locked": { 55 | "dir": "lib", 56 | "lastModified": 1678375444, 57 | "narHash": "sha256-XIgHfGvjFvZQ8hrkfocanCDxMefc/77rXeHvYdzBMc8=", 58 | "owner": "NixOS", 59 | "repo": "nixpkgs", 60 | "rev": "130fa0baaa2b93ec45523fdcde942f6844ee9f6e", 61 | "type": "github" 62 | }, 63 | "original": { 64 | "dir": "lib", 65 | "owner": "NixOS", 66 | "ref": "nixos-unstable", 67 | "repo": "nixpkgs", 68 | "type": "github" 69 | } 70 | }, 71 | "root": { 72 | "inputs": { 73 | "flake-parts": "flake-parts", 74 | "nixpkgs": "nixpkgs", 75 | "nixpkgs-ghc88": "nixpkgs-ghc88" 76 | } 77 | } 78 | }, 79 | "root": "root", 80 | "version": 7 81 | } 82 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | inputs = { 3 | nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable"; 4 | nixpkgs-ghc88.url = "github:nixos/nixpkgs/76f2e271a2ef"; 5 | flake-parts.url = "github:hercules-ci/flake-parts"; 6 | }; 7 | outputs = inputs@{ nixpkgs, flake-parts, ... }: 8 | flake-parts.lib.mkFlake { inherit inputs; } { 9 | systems = nixpkgs.lib.systems.flakeExposed; 10 | perSystem = { self', inputs', pkgs, system, ... }: 11 | let 12 | overlay = self: super: { 13 | jrec = self.callCabal2nix "jrec" ./. { }; 14 | }; 15 | ghcVersions = { 16 | ghc88 = inputs.nixpkgs-ghc88.legacyPackages.${system}.haskellPackages.extend overlay; 17 | ghc92 = pkgs.haskellPackages.extend overlay; 18 | }; 19 | in 20 | { 21 | packages.default = ghcVersions.ghc92.jrec; 22 | devShells.default = ghcVersions.ghc92.shellFor { 23 | packages = p: [ p.jrec ]; 24 | buildInputs = with ghcVersions.ghc92; [ 25 | cabal-install 26 | ghcid 27 | haskell-language-server 28 | ]; 29 | }; 30 | # Expose jrec built with GHC 8.8 so it can be tested in CI. 31 | packages.jrec-ghc88 = ghcVersions.ghc88.jrec; 32 | }; 33 | }; 34 | } 35 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | cabal: 3 | - path: "./src" 4 | component: "lib:jrec" 5 | - path: "./test" 6 | component: "test:jrec-test" 7 | -------------------------------------------------------------------------------- /jrec.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: jrec 3 | version: 0.1.0.1 4 | synopsis: anonymous records for busy people 5 | 6 | -- description: 7 | bug-reports: https://github.com/juspay/jrec/issues 8 | license: BSD-3-Clause 9 | license-file: LICENSE 10 | author: Artyom Kazak 11 | maintainer: artyom.kazak@juspay.in 12 | 13 | -- copyright: 14 | -- category: 15 | build-type: Simple 16 | extra-source-files: 17 | CHANGELOG.md 18 | README.md 19 | 20 | flag with-aeson 21 | description: Enable Aeson instances 22 | -- don't let the solver fiddle with the flag 23 | manual: True 24 | -- with instances by default 25 | default: True 26 | 27 | flag with-generics 28 | description: Enable GHC.Generics instances 29 | -- don't let the solver fiddle with the flag 30 | manual: True 31 | -- with instances by default 32 | default: True 33 | 34 | -- A common stanza to share with tests, so that ghcid (bin/test) will reload 35 | -- instantly when the library sources change (without us having to restart it). 36 | common library-common 37 | default-language: Haskell2010 38 | build-depends: 39 | aeson 40 | , base >=4.13 && <4.17 41 | , constraints 42 | , deepseq 43 | , generic-data 44 | , generic-lens 45 | , generic-optics 46 | , ghc-prim 47 | , optics-core 48 | , lens 49 | , mtl 50 | , text 51 | default-extensions: 52 | BlockArguments 53 | DataKinds 54 | DeriveGeneric 55 | DerivingStrategies 56 | DuplicateRecordFields 57 | FlexibleContexts 58 | FlexibleInstances 59 | FunctionalDependencies 60 | GADTs 61 | InstanceSigs 62 | KindSignatures 63 | LambdaCase 64 | MultiParamTypeClasses 65 | OverloadedLabels 66 | OverloadedStrings 67 | PatternSynonyms 68 | RankNTypes 69 | ScopedTypeVariables 70 | StandaloneDeriving 71 | TupleSections 72 | TypeFamilies 73 | TypeOperators 74 | UndecidableInstances 75 | UnicodeSyntax 76 | ViewPatterns 77 | ConstraintKinds 78 | PackageImports 79 | 80 | library 81 | import: library-common 82 | hs-source-dirs: src 83 | exposed-modules: 84 | JRec 85 | JRec.Internal 86 | other-modules: 87 | JRec.Tuple 88 | JRec.Field 89 | if flag(with-aeson) 90 | cpp-options: -DWITH_AESON 91 | if flag(with-generics) 92 | cpp-options: -DWITH_GENERICS 93 | 94 | test-suite jrec-test 95 | import: library-common 96 | type: exitcode-stdio-1.0 97 | hs-source-dirs: test, src 98 | main-is: Spec.hs 99 | cpp-options: -DWITH_AESON -DWITH_GENERICS 100 | other-modules: 101 | JRecShouldNotTypecheckSpec 102 | JRecSpec 103 | build-depends: 104 | base, 105 | hspec, 106 | QuickCheck, 107 | lens, 108 | should-not-typecheck 109 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | (builtins.getFlake ("git+file://" + toString ./.)).devShells.${builtins.currentSystem}.default 2 | -------------------------------------------------------------------------------- /src/JRec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE PatternSynonyms #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | 6 | module JRec 7 | ( unField, 8 | (:=) (..), 9 | Rec, 10 | pattern Rec, 11 | append, 12 | union, 13 | insert, 14 | insertOrSet, 15 | ) 16 | where 17 | 18 | import Control.Lens (coerced, (&), (.~), (^.)) 19 | import qualified "generic-lens" Data.Generics.Product.Fields as GL 20 | import qualified "generic-optics" Data.Generics.Product.Fields as GO 21 | import qualified "generic-lens" Data.Generics.Wrapped as GL 22 | import qualified "generic-optics" Data.Generics.Wrapped as GO 23 | import Data.Proxy 24 | import GHC.Exts (Any) 25 | import GHC.Generics 26 | import GHC.OverloadedLabels 27 | import GHC.TypeLits 28 | import Generic.Data 29 | import JRec.Field 30 | import JRec.Internal (Rec, (:=) (..)) 31 | import qualified JRec.Internal as R 32 | import JRec.Tuple 33 | import Unsafe.Coerce 34 | 35 | ---------------------------------------------------------------------------- 36 | -- unField 37 | ---------------------------------------------------------------------------- 38 | 39 | unField :: field ~ field' => R.FldProxy field -> (field' R.:= value) -> value 40 | unField _ (_ R.:= value) = value 41 | 42 | ---------------------------------------------------------------------------- 43 | -- Other operations 44 | ---------------------------------------------------------------------------- 45 | 46 | -- Appends records, without removing duplicates. 47 | -- 48 | -- O(n + m) type check complexity. 49 | -- 50 | -- FIXME: See spec for a bug when there are duplicates. 51 | append :: 52 | forall lhs rhs res. 53 | res ~ R.RecAppend lhs rhs => 54 | Rec lhs -> 55 | Rec rhs -> 56 | Rec res 57 | append = R.combine 58 | 59 | -- Merges records, removing duplicates 60 | -- 61 | -- Left-biased. Does not sort. 62 | -- 63 | -- O(n * m) type check complexity. 64 | union :: 65 | forall lhs rhs res. 66 | ( KnownNat (R.RecSize lhs), 67 | KnownNat (R.RecSize rhs), 68 | KnownNat (R.RecSize res), 69 | res ~ R.Union lhs rhs, 70 | R.RecCopy lhs lhs res, 71 | R.RecCopy rhs rhs res 72 | ) => 73 | Rec lhs -> 74 | Rec rhs -> 75 | Rec res 76 | union = R.union 77 | 78 | -- | Insert a field into a record that does not already contain it 79 | -- 80 | -- O(n) type check complexity. 81 | insert :: 82 | forall label value lts res. 83 | ( KnownNat (1 + R.RecSize lts), 84 | KnownNat (R.RecSize lts), 85 | KnownSymbol label, 86 | R.RecCopy lts lts res, 87 | res ~ ((label := value) : lts), 88 | R.RemoveAccessTo label lts ~ lts 89 | ) => 90 | label := value -> 91 | Rec lts -> 92 | Rec res 93 | insert = R.combine . Rec 94 | 95 | -- | Insert a field into a record. Set it if it already exists 96 | -- 97 | -- O(n) type check complexity. 98 | insertOrSet :: 99 | forall label value rhs res. 100 | ( KnownNat (R.RecSize rhs), 101 | KnownNat (R.RecSize res), 102 | KnownNat (R.RecTyIdxH 0 label res), 103 | KnownSymbol label, 104 | value ~ R.RecTy label res, 105 | R.Reverse (R.Insert (label := value) (R.Reverse rhs)) ~ res, 106 | R.RecCopy rhs rhs res 107 | ) => 108 | label := value -> 109 | Rec rhs -> 110 | Rec res 111 | insertOrSet = R.insert 112 | 113 | ---------------------------------------------------------------------------- 114 | -- Generic 115 | ---------------------------------------------------------------------------- 116 | 117 | type Sel name value = S1 ('MetaSel ('Just name) 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedStrict) (Rec0 value) 118 | 119 | type family Sels fields where 120 | Sels '[] = U1 121 | Sels '[name R.:= value] = Sel name value 122 | Sels ((name R.:= value) ': xs) = Sel name value :*: Sels xs 123 | 124 | type RecordRep fields = 125 | D1 126 | ('MetaData "Record" "Rec" "" 'False) 127 | ( C1 128 | ('MetaCons "Record" 'PrefixI 'True) 129 | (Sels fields) 130 | ) 131 | 132 | #ifdef WITH_GENERICS 133 | instance 134 | (R.FromNative (RecordRep fields) fields, R.ToNative (RecordRep fields) fields) => 135 | Generic (Rec fields) 136 | where 137 | type 138 | Rep (Rec fields) = 139 | RecordRep fields 140 | from r = R.toNative' r 141 | to rep = R.fromNative' rep 142 | #endif 143 | 144 | ---------------------------------------------------------------------------- 145 | -- generic-lens 146 | ---------------------------------------------------------------------------- 147 | 148 | instance {-# OVERLAPPING #-} (R.Set field fields a' ~ fields', R.Set field fields' a ~ fields, R.Has field fields a, R.Has field fields' a') => GL.HasField field (Rec fields) (Rec fields') a a' where 149 | field = R.lens (R.FldProxy @field) 150 | 151 | instance {-# OVERLAPPING #-} (R.Set field fields a ~ fields, R.Has field fields a) => GL.HasField' field (Rec fields) a where 152 | field' = R.lens (R.FldProxy @field) 153 | 154 | ---------------------------------------------------------------------------- 155 | -- generic-optics 156 | ---------------------------------------------------------------------------- 157 | 158 | instance {-# OVERLAPPING #-} (R.Set field fields a' ~ fields', R.Set field fields' a ~ fields, R.Has field fields a, R.Has field fields' a') => GO.HasField field (Rec fields) (Rec fields') a a' where 159 | field = R.opticLens (R.FldProxy @field) 160 | 161 | instance {-# OVERLAPPING #-} (R.Set field fields a ~ fields, R.Has field fields a) => GO.HasField' field (Rec fields) a where 162 | field' = R.opticLens (R.FldProxy @field) 163 | 164 | pattern Rec :: 165 | ( RecTuple tuple fields 166 | ) => 167 | tuple -> 168 | Rec fields 169 | pattern Rec a <- 170 | (toTuple -> a) 171 | where 172 | Rec = fromTuple 173 | -------------------------------------------------------------------------------- /src/JRec/Field.hs: -------------------------------------------------------------------------------- 1 | module JRec.Field where 2 | 3 | import qualified "generic-lens" Data.Generics.Labels as GL 4 | import qualified "generic-lens" Data.Generics.Product.Fields as GL 5 | import GHC.TypeLits 6 | 7 | type Field' (s :: Symbol) a b = (GL.HasField' s a b, GL.Field' s a b) 8 | -------------------------------------------------------------------------------- /src/JRec/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE ConstraintKinds #-} 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE ExistentialQuantification #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE FunctionalDependencies #-} 9 | {-# LANGUAGE GADTs #-} 10 | {-# LANGUAGE KindSignatures #-} 11 | {-# LANGUAGE MagicHash #-} 12 | {-# LANGUAGE MultiParamTypeClasses #-} 13 | {-# LANGUAGE PolyKinds #-} 14 | {-# LANGUAGE RankNTypes #-} 15 | {-# LANGUAGE RoleAnnotations #-} 16 | {-# LANGUAGE ScopedTypeVariables #-} 17 | {-# LANGUAGE TypeApplications #-} 18 | {-# LANGUAGE TypeFamilies #-} 19 | {-# LANGUAGE TypeOperators #-} 20 | {-# LANGUAGE UnboxedTuples #-} 21 | {-# LANGUAGE UndecidableInstances #-} 22 | 23 | -- Based on https://github.com/agrafix/superrecord. The original doesn't 24 | -- export a lot of good things, and it was easier to just copy the 25 | -- implementation since we don't need much out of it. 26 | 27 | module JRec.Internal where 28 | 29 | import Control.DeepSeq 30 | import Control.Monad.Reader 31 | import qualified Control.Monad.State as S 32 | import Data.Aeson 33 | import Data.Aeson.Types (Parser) 34 | import Data.Constraint 35 | import Data.List (intercalate) 36 | import Data.Maybe (catMaybes) 37 | import Data.Proxy 38 | import qualified Data.Text as T 39 | import Data.Typeable 40 | import GHC.Base (Any, Int (..)) 41 | import GHC.Generics 42 | import GHC.OverloadedLabels 43 | import GHC.Prim 44 | import GHC.ST (ST (..), runST) 45 | import GHC.TypeLits 46 | import qualified Optics.Lens as OL 47 | import Unsafe.Coerce 48 | import Prelude 49 | #if MIN_VERSION_aeson(2,0,0) 50 | import Data.Aeson.Key (fromText, fromString) 51 | #else 52 | fromText :: a -> a 53 | fromText = id 54 | fromString :: String -> T.Text 55 | fromString = T.pack 56 | #endif 57 | 58 | -- | Field named @l@ labels value of type @t@ adapted from the awesome /labels/ package. 59 | -- Example: @(#name := \"Chris\") :: (\"name\" := String)@ 60 | data label := value = KnownSymbol label => FldProxy label := !value 61 | 62 | deriving instance Typeable (:=) 63 | 64 | deriving instance Typeable (label := value) 65 | 66 | infix 6 := 67 | 68 | instance (Eq value) => Eq (label := value) where 69 | (_ := x) == (_ := y) = x == y 70 | {-# INLINE (==) #-} 71 | 72 | instance (Ord value) => Ord (label := value) where 73 | compare (_ := x) (_ := y) = x `compare` y 74 | {-# INLINE compare #-} 75 | 76 | instance 77 | (Show t) => 78 | Show (l := t) 79 | where 80 | showsPrec p (l := t) = 81 | showParen (p > 10) (showString ("#" ++ symbolVal l ++ " := " ++ show t)) 82 | 83 | unpackAssign :: (label := value) -> value 84 | unpackAssign (_ := value) = value 85 | {-# INLINE unpackAssign #-} 86 | 87 | -- | A proxy witness for a label. Very similar to 'Proxy', but needed to implement 88 | -- a non-orphan 'IsLabel' instance 89 | data FldProxy (t :: Symbol) 90 | = FldProxy 91 | deriving (Show, Read, Eq, Ord, Typeable) 92 | 93 | instance l ~ l' => IsLabel (l :: Symbol) (FldProxy l') where 94 | fromLabel = FldProxy 95 | 96 | -- | Internal record type. When manually writing an explicit type signature for 97 | -- a record, use 'Record' instead. For abstract type signatures 'Rec' will work 98 | -- well. 99 | data Rec (lts :: [*]) = MkRec 100 | { _unRec :: SmallArray# Any -- Note that the values are physically in reverse order 101 | } 102 | 103 | data JSONOptions = JSONOptions 104 | {fieldTransform :: String -> String} 105 | 106 | defaultJSONOptions :: JSONOptions 107 | defaultJSONOptions = JSONOptions {fieldTransform = id} 108 | 109 | type role Rec representational 110 | 111 | instance 112 | ( RecApply lts lts Show 113 | ) => 114 | Show (Rec lts) 115 | where 116 | show rec = "{" ++ formatted ++ "}" 117 | where formatted = intercalate ", " $ map (\(k, v) -> k ++ " = " ++ v) $ showRec rec 118 | 119 | instance RecEq lts lts => Eq (Rec lts) where 120 | (==) (a :: Rec lts) (b :: Rec lts) = recEq a b (Proxy :: Proxy lts) 121 | {-# INLINE (==) #-} 122 | 123 | instance RecOrd lts lts => Ord (Rec lts) where 124 | compare (a :: Rec lts) (b :: Rec lts) = recOrd a b (Proxy :: Proxy lts) 125 | {-# INLINE compare #-} 126 | 127 | #ifdef WITH_AESON 128 | instance 129 | ( RecApply lts lts EncodeField 130 | ) => 131 | ToJSON (Rec lts) 132 | where 133 | toJSON = recToValue defaultJSONOptions 134 | toEncoding = recToEncoding defaultJSONOptions 135 | 136 | instance (RecSize lts ~ s, KnownNat s, RecJsonParse lts) => FromJSON (Rec lts) where 137 | parseJSON = recJsonParser defaultJSONOptions 138 | 139 | #endif 140 | 141 | instance RecNfData lts lts => NFData (Rec lts) where 142 | rnf = recNfData (Proxy :: Proxy lts) 143 | 144 | newtype ForallST a = ForallST {unForallST :: forall s. ST s a} 145 | 146 | -- Hack needed because $! doesn't have the same special treatment $ does to work with ST yet 147 | runST' :: (forall s. ST s a) -> a 148 | runST' !s = runST s 149 | 150 | -- | An empty record 151 | rnil :: Rec '[] 152 | rnil = create (unsafeRNil 0) 153 | {-# INLINE rnil #-} 154 | 155 | create :: (forall s. ST s (Rec xs)) -> Rec xs 156 | create = runST' 157 | 158 | unsafeRNil :: Int -> ST s (Rec '[]) 159 | unsafeRNil (I# n#) = 160 | ST $ \s# -> 161 | case newSmallArray# n# (error "No value") s# of 162 | (# s'#, arr# #) -> 163 | case unsafeFreezeSmallArray# arr# s'# of 164 | (# s''#, a# #) -> (# s''#, MkRec a# #) 165 | {-# INLINE unsafeRNil #-} 166 | 167 | -- | Prepend a record entry to a record 'Rec'. Assumes that the record was created with 168 | -- 'unsafeRNil' and still has enough free slots, mutates the original 'Rec' which should 169 | -- not be reused after 170 | -- 171 | -- NOTE: doesn't use 'KeyDoesNotExist' because we rely on the fact that in 172 | -- euler-ps there were no duplicate keys 173 | unsafeRCons :: 174 | forall l t lts size s. 175 | ( RecSize lts ~ size, 176 | KnownNat size 177 | -- KeyDoesNotExist l lts 178 | ) => 179 | l := t -> 180 | Rec lts -> 181 | ST s (Rec (l := t ': lts)) 182 | unsafeRCons (_ := val) (MkRec vec#) = 183 | ST $ \s# -> 184 | case unsafeThawSmallArray# vec# s# of 185 | (# s'#, arr# #) -> 186 | -- Write the value to be cons'ed at the *end* (hence size#) of the 187 | -- array, because `Rec` stores values in reverse order. 188 | case writeSmallArray# arr# size# (unsafeCoerce# val) s'# of 189 | s''# -> 190 | case unsafeFreezeSmallArray# arr# s''# of 191 | (# s'''#, a# #) -> (# s'''#, MkRec a# #) 192 | where 193 | !(I# size#) = fromIntegral $ natVal' (proxy# :: Proxy# size) 194 | {-# INLINE unsafeRCons #-} 195 | 196 | -- | Get the i-th value as Any unsafely. 197 | -- No boundary check. Also ther caller is responsible for coerceing to correct type. 198 | -- Intented for internal use only. 199 | unsafeGet :: 200 | forall lts. 201 | Int -> 202 | Rec lts -> 203 | Any 204 | unsafeGet (I# index#) (MkRec vec#) = 205 | let size# = sizeofSmallArray# vec# 206 | in case indexSmallArray# vec# (size# -# index# -# 1#) of 207 | (# a# #) -> a# 208 | {-# INLINE unsafeGet #-} 209 | 210 | -- Not in superrecord 211 | recCopy :: forall lts rts. RecCopy lts lts rts => Rec lts -> Rec rts 212 | recCopy r@(MkRec vec#) = 213 | let size# = sizeofSmallArray# vec# 214 | in runST' $ 215 | ST $ \s# -> 216 | case newSmallArray# size# (error "No value") s# of 217 | (# s'#, arr# #) -> 218 | case recCopyInto (Proxy @lts) r (Proxy @rts) arr# s'# of 219 | s''# -> 220 | case unsafeFreezeSmallArray# arr# s''# of 221 | (# s'''#, a# #) -> (# s'''#, MkRec a# #) 222 | {-# INLINE recCopy #-} 223 | 224 | class RecCopy (pts :: [*]) (lts :: [*]) (rts :: [*]) where 225 | recCopyInto :: 226 | Proxy pts -> 227 | Rec lts -> 228 | Proxy rts -> 229 | SmallMutableArray# s Any -> 230 | State# s -> 231 | State# s 232 | 233 | instance RecCopy '[] lts rts where 234 | recCopyInto _ _ _ _ s# = s# 235 | 236 | instance 237 | ( Has l rts t, 238 | Has l lts t, 239 | nts ~ RemoveAccessTo l (l := t ': pts), 240 | RecCopy nts lts rts 241 | ) => 242 | RecCopy (l := t ': pts) lts rts 243 | where 244 | recCopyInto _ lts prxy tgt# s# = 245 | let lbl :: FldProxy l 246 | lbl = FldProxy 247 | val = get lbl lts 248 | !(I# index#) = 249 | fromIntegral (natVal' (proxy# :: Proxy# (RecTyIdxH 0 l rts))) 250 | size# = sizeofSmallMutableArray# tgt# 251 | in case writeSmallArray# tgt# (size# -# index# -# 1#) (unsafeCoerce# val) s# of 252 | s'# -> recCopyInto (Proxy :: Proxy nts) lts prxy tgt# s'# 253 | 254 | type family RecAll (c :: u -> Constraint) (rs :: [u]) :: Constraint where 255 | RecAll c '[] = () 256 | RecAll c (r ': rs) = (c r, RecAll c rs) 257 | 258 | type family KeyDoesNotExist (l :: Symbol) (lts :: [*]) :: Constraint where 259 | KeyDoesNotExist l '[] = 'True ~ 'True 260 | KeyDoesNotExist l (l := t ': lts) = 261 | TypeError 262 | ( 'Text "Duplicate key " ':<>: 'Text l 263 | ) 264 | KeyDoesNotExist q (l := t ': lts) = KeyDoesNotExist q lts 265 | 266 | type family Reverse (xs :: [*]) where 267 | Reverse '[] = '[] 268 | Reverse (x ': xs) = RecAppend (Reverse xs) '[x] 269 | 270 | type family Insert (a :: *) (xs :: [*]) where 271 | Insert x '[] = x ': '[] 272 | Insert (a := v) (a := _ ': xs) = a := v ': xs 273 | Insert a (x ': xs) = x ': Insert a xs 274 | 275 | type family Union xs ys where 276 | Union xs '[] = xs 277 | Union xs (y := t ': ys) = Union (Insert (y := t) xs) ys 278 | 279 | -- TODO: Rename to `Append`, because it just deals with general type list? 280 | type family RecAppend lhs rhs where 281 | RecAppend '[] rhs = rhs 282 | RecAppend (x ': xs) rhs = x ': RecAppend xs rhs 283 | 284 | type family RecSize (lts :: [*]) :: Nat where 285 | RecSize '[] = 0 286 | RecSize (l := t ': lts) = 1 + RecSize lts 287 | 288 | type family RecTyIdxH (i :: Nat) (l :: Symbol) (lts :: [*]) :: Nat where 289 | RecTyIdxH idx l (l := t ': lts) = idx 290 | RecTyIdxH idx m (l := t ': lts) = RecTyIdxH (1 + idx) m lts 291 | RecTyIdxH idx m '[] = 292 | TypeError 293 | ( 'Text "Could not find label " 294 | ':<>: 'Text m 295 | ) 296 | 297 | type family RecTy (l :: Symbol) (lts :: [*]) :: k where 298 | RecTy l (l := t ': lts) = t 299 | RecTy q (l := t ': lts) = RecTy q lts 300 | 301 | -- | Require a record to contain at least the listed labels 302 | type family HasOf (req :: [*]) (lts :: [*]) :: Constraint where 303 | HasOf (l := t ': req) lts = (Has l lts t, HasOf req lts) 304 | HasOf '[] lts = 'True ~ 'True 305 | 306 | -- | Require a record to contain a label 307 | type Has l lts v = 308 | ( RecTy l lts ~ v, 309 | -- KnownNat (RecSize lts), 310 | KnownNat (RecTyIdxH 0 l lts) 311 | ) 312 | 313 | -- | Get an existing record field 314 | get :: 315 | forall l v lts. 316 | ( Has l lts v 317 | ) => 318 | FldProxy l -> 319 | Rec lts -> 320 | v 321 | get _ r = 322 | let !index = fromIntegral (natVal' (proxy# :: Proxy# (RecTyIdxH 0 l lts))) 323 | in unsafeCoerce $ unsafeGet index r 324 | {-# INLINE get #-} 325 | 326 | -- | Alias for 'get' 327 | (&.) :: forall l v lts. (Has l lts v) => Rec lts -> FldProxy l -> v 328 | (&.) = flip get 329 | 330 | infixl 3 &. 331 | 332 | type family Set l lts v where 333 | Set l '[] v = '[] 334 | Set l ((l := u) ': xs) v = (l := v) ': xs 335 | Set l (x ': xs) v = x ': Set l xs v 336 | 337 | -- | Update an existing record field 338 | set :: 339 | forall l v lts v' lts'. 340 | (Has l lts v, Set l lts v' ~ lts') => 341 | FldProxy l -> 342 | v' -> 343 | Rec lts -> 344 | Rec lts' 345 | set _ !val (MkRec vec#) = 346 | let !(I# index#) = fromIntegral (natVal' (proxy# :: Proxy# (RecTyIdxH 0 l lts))) 347 | -- Unlike superrecord - calculating size dynamically instead of statically 348 | size# = sizeofSmallArray# vec# 349 | dynVal :: Any 350 | !dynVal = unsafeCoerce# val 351 | r2 = 352 | runST' $ 353 | ST $ \s# -> 354 | case newSmallArray# size# (error "No value") s# of 355 | (# s'#, arr# #) -> 356 | case copySmallArray# vec# 0# arr# 0# size# s'# of 357 | s''# -> 358 | case writeSmallArray# arr# (size# -# index# -# 1#) dynVal s''# of 359 | s'''# -> 360 | case unsafeFreezeSmallArray# arr# s'''# of 361 | (# s''''#, a# #) -> (# s''''#, MkRec a# #) 362 | in r2 363 | {-# INLINE set #-} 364 | 365 | -- | Update an existing record field 366 | modify :: 367 | forall l v lts v' lts'. 368 | (Has l lts v, Set l lts v' ~ lts') => 369 | FldProxy l -> 370 | (v -> v') -> 371 | Rec lts -> 372 | Rec lts' 373 | modify lbl fun r = set lbl (fun $ get lbl r) r 374 | {-# INLINE modify #-} 375 | 376 | -- | Constructor for field accessor paths 377 | data lbl :& more = FldProxy lbl :& more 378 | 379 | infixr 8 :& 380 | 381 | -- | Constructor for field accessor paths 382 | (&:) :: FldProxy q -> more -> q :& more 383 | (&:) = (:&) 384 | {-# INLINE (&:) #-} 385 | 386 | infixr 8 &: 387 | 388 | -- | Specialized version of (&:) to help writing the last piece of the path w/o 389 | -- confusing the type checker 390 | (&:-) :: FldProxy q -> FldProxy r -> q :& FldProxy r 391 | (&:-) = (:&) 392 | {-# INLINE (&:-) #-} 393 | 394 | infixr 8 &:- 395 | 396 | -- | Helper function to allow to clearing specify unknown 'IsLabel' cases 397 | fld :: FldProxy l -> FldProxy l 398 | fld = id 399 | 400 | type family RecDeepTy (ps :: r) (lts :: [*]) :: * where 401 | RecDeepTy (l :& more) (l := Rec t ': lts) = RecDeepTy more t 402 | RecDeepTy (l :& more) (l := t ': lts) = t 403 | RecDeepTy (l :& more) (q := t ': lts) = RecDeepTy (l :& more) lts 404 | RecDeepTy (FldProxy l) '[l := t] = t 405 | RecDeepTy l '[l := t] = t 406 | 407 | -- | Combine two records 408 | -- 409 | -- NOTE: changed from original superrecord to not require a 'Sort' 410 | combine :: 411 | forall lhs rhs res. 412 | res ~ RecAppend lhs rhs => 413 | Rec lhs -> 414 | Rec rhs -> 415 | Rec res 416 | combine (MkRec arr0#) (MkRec arr1#) = 417 | let !size0# = sizeofSmallArray# arr0# 418 | !size1# = sizeofSmallArray# arr1# 419 | in runST' $ 420 | ST $ \s# -> 421 | case newSmallArray# (size0# +# size1#) (error "No value") s# of 422 | (# s'#, arr# #) -> 423 | case copySmallArray# arr1# 0# arr# 0# size1# s'# of 424 | s''# -> 425 | case copySmallArray# arr0# 0# arr# size1# size0# s''# of 426 | s'''# -> 427 | case unsafeFreezeSmallArray# arr# s'''# of 428 | (# s''''#, a# #) -> (# s''''#, MkRec a# #) 429 | {-# INLINE combine #-} 430 | 431 | -- | Union two records (left-biased) 432 | union :: 433 | forall lhs rhs res. 434 | ( KnownNat (RecSize lhs), 435 | KnownNat (RecSize rhs), 436 | KnownNat (RecSize res), 437 | res ~ Union lhs rhs, 438 | RecCopy lhs lhs res, 439 | RecCopy rhs rhs res 440 | ) => 441 | Rec lhs -> 442 | Rec rhs -> 443 | Rec res 444 | union lts rts = 445 | let !(I# size#) = 446 | fromIntegral $ natVal' (proxy# :: Proxy# (RecSize (Union lhs rhs))) 447 | in runST' $ 448 | ST $ \s# -> 449 | case newSmallArray# size# (error "No value") s# of 450 | (# s'#, arr# #) -> 451 | -- Copy rhs first, so that lhs can override later so as to retain 452 | -- the left-biased semantics of union. 453 | case recCopyInto (Proxy :: Proxy rhs) rts (Proxy :: Proxy res) arr# s'# of 454 | s''# -> 455 | case recCopyInto (Proxy :: Proxy lhs) lts (Proxy :: Proxy res) arr# s''# of 456 | s'''# -> 457 | case unsafeFreezeSmallArray# arr# s'''# of 458 | (# s''''#, a# #) -> (# s''''#, MkRec a# #) 459 | {-# INLINE union #-} 460 | 461 | -- | Insert a field 462 | -- 463 | -- Insert at beginning, unless the field already exists, in which case set it 464 | -- directly. 465 | insert :: 466 | forall l v rhs res. 467 | ( KnownNat (RecSize rhs), 468 | KnownNat (RecSize res), 469 | res ~ Reverse (Insert (l := v) (Reverse rhs)), 470 | RecCopy '[l := v] '[l := v] res, 471 | RecCopy rhs rhs res 472 | ) => 473 | l := v -> 474 | Rec rhs -> 475 | Rec res 476 | insert (l := v) rts = 477 | let !(I# size#) = 478 | fromIntegral $ natVal' (proxy# :: Proxy# (RecSize res)) 479 | in runST' $ do 480 | single <- unsafeRCons (l := v) =<< unsafeRNil 1 481 | ST $ \s# -> 482 | case newSmallArray# size# (error "No value") s# of 483 | (# s'#, arr# #) -> 484 | case recCopyInto (Proxy :: Proxy rhs) rts (Proxy :: Proxy res) arr# s'# of 485 | s''# -> 486 | case recCopyInto (Proxy :: Proxy '[l := v]) single (Proxy :: Proxy res) arr# s''# of 487 | s'''# -> 488 | case unsafeFreezeSmallArray# arr# s'''# of 489 | (# s''''#, a# #) -> (# s''''#, MkRec a# #) 490 | {-# INLINE insert #-} 491 | 492 | -- | Alias for 'combine' 493 | (++:) :: 494 | forall lhs rhs res. 495 | res ~ RecAppend lhs rhs => 496 | Rec lhs -> 497 | Rec rhs -> 498 | Rec res 499 | (++:) = combine 500 | {-# INLINE (++:) #-} 501 | 502 | data RecFields (flds :: [Symbol]) where 503 | RFNil :: RecFields '[] 504 | RFCons :: KnownSymbol f => FldProxy f -> RecFields xs -> RecFields (f ': xs) 505 | 506 | recKeys :: forall t (lts :: [*]). RecKeys lts => t lts -> [String] 507 | recKeys = recKeys' . recFields 508 | 509 | recKeys' :: RecFields lts -> [String] 510 | recKeys' x = 511 | case x of 512 | RFNil -> [] 513 | RFCons q qs -> symbolVal q : recKeys' qs 514 | 515 | -- | Get keys of a record on value and type level 516 | class RecKeys (lts :: [*]) where 517 | type RecKeysT lts :: [Symbol] 518 | recFields :: t lts -> RecFields (RecKeysT lts) 519 | 520 | instance RecKeys '[] where 521 | type RecKeysT '[] = '[] 522 | recFields _ = RFNil 523 | 524 | instance (KnownSymbol l, RecKeys lts) => RecKeys (l := t ': lts) where 525 | type RecKeysT (l := t ': lts) = (l ': RecKeysT lts) 526 | recFields (_ :: f (l := t ': lts)) = 527 | let lbl :: FldProxy l 528 | lbl = FldProxy 529 | more :: Proxy lts 530 | more = Proxy 531 | in (lbl `RFCons` recFields more) 532 | 533 | -- | Apply a function to each key element pair for a record 534 | reflectRec :: 535 | forall c r lts. 536 | (RecApply lts lts c) => 537 | Proxy c -> 538 | (forall a. c a => String -> a -> r) -> 539 | Rec lts -> 540 | [r] 541 | reflectRec _ f r = 542 | reverse $ 543 | recApply (\(Dict :: Dict (c a)) s v xs -> (f s v : xs)) r (Proxy :: Proxy lts) [] 544 | {-# INLINE reflectRec #-} 545 | 546 | -- | Fold over all elements of a record 547 | reflectRecFold :: 548 | forall c r lts. 549 | (RecApply lts lts c) => 550 | Proxy c -> 551 | (forall a. c a => String -> a -> r -> r) -> 552 | Rec lts -> 553 | r -> 554 | r 555 | reflectRecFold _ f r = 556 | recApply (\(Dict :: Dict (c a)) s v x -> f s v x) r (Proxy :: Proxy lts) 557 | {-# INLINE reflectRecFold #-} 558 | 559 | -- | Convert all elements of a record to a 'String' 560 | showRec :: forall lts. (RecApply lts lts Show) => Rec lts -> [(String, String)] 561 | showRec = reflectRec @Show Proxy (\k v -> (k, show v)) 562 | 563 | class ToJSON a => EncodeField a where 564 | encodeField :: a -> Maybe Value 565 | encodeKV :: T.Text -> a -> Series 566 | 567 | instance ToJSON a => EncodeField a where 568 | encodeField = pure . toJSON 569 | encodeKV k v = fromText k .= v 570 | 571 | instance {-# OVERLAPS #-} ToJSON a => EncodeField (Maybe a) where 572 | encodeField = fmap toJSON 573 | encodeKV _ Nothing = mempty 574 | encodeKV k v = fromText k .= v 575 | 576 | recToValue :: forall lts. (RecApply lts lts EncodeField) => JSONOptions -> Rec lts -> Value 577 | recToValue options r = 578 | object $ catMaybes $ reflectRec @EncodeField Proxy (\k v -> (fromString (fieldTransform options k),) <$> encodeField v) r 579 | 580 | recToEncoding :: forall lts. (RecApply lts lts EncodeField) => JSONOptions -> Rec lts -> Encoding 581 | recToEncoding options r = 582 | pairs $ mconcat $ reflectRec @EncodeField Proxy (\k v -> (T.pack (fieldTransform options k) `encodeKV` v)) r 583 | 584 | recJsonParser :: 585 | forall lts s. 586 | (RecSize lts ~ s, KnownNat s, RecJsonParse lts) => 587 | (JSONOptions -> Value -> Parser (Rec lts)) 588 | recJsonParser options = 589 | withObject "Record" $ \o -> 590 | (\(ForallST act) -> create act) <$> recJsonParse options initSize o 591 | where 592 | initSize = fromIntegral $ natVal' (proxy# :: Proxy# s) 593 | 594 | -- | Machinery needed to implement 'reflectRec' 595 | class RecApply (rts :: [*]) (lts :: [*]) c where 596 | recApply :: (forall a. Dict (c a) -> String -> a -> b -> b) -> Rec rts -> Proxy lts -> b -> b 597 | 598 | instance RecApply rts '[] c where 599 | recApply _ _ _ b = b 600 | 601 | instance 602 | ( KnownSymbol l, 603 | RecApply rts (RemoveAccessTo l lts) c, 604 | Has l rts v, 605 | c v 606 | ) => 607 | RecApply rts (l := t ': lts) c 608 | where 609 | recApply f r (_ :: Proxy (l := t ': lts)) b = 610 | let lbl :: FldProxy l 611 | lbl = FldProxy 612 | val = get lbl r 613 | res = f Dict (symbolVal lbl) val b 614 | pNext :: Proxy (RemoveAccessTo l (l := t ': lts)) 615 | pNext = Proxy 616 | in recApply f r pNext res 617 | 618 | -- | Machinery to implement equality 619 | class RecEq (rts :: [*]) (lts :: [*]) where 620 | recEq :: Rec rts -> Rec rts -> Proxy lts -> Bool 621 | 622 | instance RecEq rts '[] where 623 | recEq _ _ _ = True 624 | 625 | instance 626 | ( RecEq rts (RemoveAccessTo l lts), 627 | Has l rts v, 628 | Eq v 629 | ) => 630 | RecEq rts (l := t ': lts) 631 | where 632 | recEq r1 r2 (_ :: Proxy (l := t ': lts)) = 633 | let lbl :: FldProxy l 634 | lbl = FldProxy 635 | val = get lbl r1 636 | val2 = get lbl r2 637 | res = val == val2 638 | pNext :: Proxy (RemoveAccessTo l (l := t ': lts)) 639 | pNext = Proxy 640 | in res && recEq r1 r2 pNext 641 | 642 | -- | Machinery to implement order 643 | class RecEq rts lts => RecOrd (rts :: [*]) (lts :: [*]) where 644 | recOrd :: Rec rts -> Rec rts -> Proxy lts -> Ordering 645 | 646 | instance RecOrd rts '[] where 647 | recOrd _ _ _ = EQ 648 | 649 | instance 650 | ( RecOrd rts (RemoveAccessTo l lts), 651 | Has l rts v, 652 | Ord v 653 | ) => 654 | RecOrd rts (l := t ': lts) 655 | where 656 | recOrd r1 r2 (_ :: Proxy (l := t ': lts)) = 657 | let lbl :: FldProxy l 658 | lbl = FldProxy 659 | val1 = get lbl r1 660 | val2 = get lbl r2 661 | ord = compare val1 val2 662 | pNext :: Proxy (RemoveAccessTo l (l := t ': lts)) 663 | pNext = Proxy 664 | in if ord == EQ then recOrd r1 r2 pNext else ord 665 | 666 | -- TODO: this probably slows typechecking in euler-ps, and should not be needed 667 | type family RemoveAccessTo (l :: Symbol) (lts :: [*]) :: [*] where 668 | RemoveAccessTo l (l := t ': lts) = RemoveAccessTo l lts 669 | RemoveAccessTo q (l := t ': lts) = (l := t ': RemoveAccessTo q lts) 670 | RemoveAccessTo q '[] = '[] 671 | 672 | -- | Machinery to implement parseJSON 673 | class RecJsonParse (lts :: [*]) where 674 | recJsonParse :: JSONOptions -> Int -> Object -> Parser (ForallST (Rec lts)) 675 | 676 | instance RecJsonParse '[] where 677 | recJsonParse _ initSize _ = pure (ForallST (unsafeRNil initSize)) 678 | 679 | class FromJSON a => ParseField a where 680 | parseField :: Object -> T.Text -> Parser a 681 | 682 | instance FromJSON a => ParseField a where 683 | parseField o k = o .: fromText k 684 | 685 | instance {-# OVERLAPS #-} FromJSON a => ParseField (Maybe a) where 686 | parseField o k = o .:? fromText k 687 | 688 | instance 689 | ( KnownSymbol l, 690 | FromJSON t, 691 | ParseField t, 692 | RecJsonParse lts, 693 | RecSize lts ~ s, 694 | KnownNat s, 695 | KeyDoesNotExist l lts 696 | ) => 697 | RecJsonParse (l := t ': lts) 698 | where 699 | recJsonParse options initSize obj = do 700 | let lbl :: FldProxy l 701 | lbl = FldProxy 702 | rest <- recJsonParse options initSize obj 703 | (v :: t) <- obj `parseField` T.pack (fieldTransform options (symbolVal lbl)) 704 | pure $ ForallST (unsafeRCons (lbl := v) =<< unForallST rest) 705 | 706 | -- | Machinery for NFData 707 | class RecNfData (lts :: [*]) (rts :: [*]) where 708 | recNfData :: Proxy lts -> Rec rts -> () 709 | 710 | instance RecNfData '[] rts where 711 | recNfData _ _ = () 712 | 713 | instance 714 | ( Has l rts v, 715 | NFData v, 716 | RecNfData (RemoveAccessTo l lts) rts 717 | ) => 718 | RecNfData (l := t ': lts) rts 719 | where 720 | recNfData (_ :: (Proxy (l := t ': lts))) r = 721 | let !v = get (FldProxy :: FldProxy l) r 722 | pNext :: Proxy (RemoveAccessTo l (l := t ': lts)) 723 | pNext = Proxy 724 | in deepseq v (recNfData pNext r) 725 | 726 | -- | Conversion helper to bring a Haskell type to a record. Note that the 727 | -- native Haskell type must be an instance of 'Generic' 728 | class FromNative a lts | a -> lts where 729 | fromNative' :: a x -> Rec lts 730 | 731 | instance FromNative cs lts => FromNative (D1 m cs) lts where 732 | fromNative' (M1 xs) = fromNative' xs 733 | 734 | instance FromNative cs lts => FromNative (C1 m cs) lts where 735 | fromNative' (M1 xs) = fromNative' xs 736 | 737 | instance FromNative U1 '[] where 738 | fromNative' U1 = rnil 739 | 740 | instance 741 | ( KnownSymbol name 742 | ) => 743 | FromNative (S1 ('MetaSel ('Just name) p s l) (Rec0 t)) '[name := t] 744 | where 745 | fromNative' (M1 (K1 t)) = 746 | create $ 747 | unsafeRCons ((FldProxy :: FldProxy name) := t) =<< unsafeRNil 1 748 | 749 | instance 750 | ( FromNative l lhs, 751 | FromNative r rhs, 752 | lts ~ RecAppend lhs rhs, 753 | RecCopy lhs lhs lts, 754 | RecCopy rhs rhs lts, 755 | KnownNat (RecSize lhs), 756 | KnownNat (RecSize rhs), 757 | KnownNat (RecSize lhs + RecSize rhs) 758 | ) => 759 | FromNative (l :*: r) lts 760 | where 761 | fromNative' (l :*: r) = fromNative' l ++: fromNative' r 762 | 763 | -- | Convert a native Haskell type to a record 764 | fromNative :: (Generic a, FromNative (Rep a) lts) => a -> Rec lts 765 | fromNative = fromNative' . from 766 | {-# INLINE fromNative #-} 767 | 768 | -- | Conversion helper to bring a record back into a Haskell type. Note that the 769 | -- native Haskell type must be an instance of 'Generic' 770 | class ToNative a lts where 771 | toNative' :: Rec lts -> a x 772 | 773 | instance ToNative cs lts => ToNative (D1 m cs) lts where 774 | toNative' xs = M1 $ toNative' xs 775 | 776 | instance ToNative cs lts => ToNative (C1 m cs) lts where 777 | toNative' xs = M1 $ toNative' xs 778 | 779 | instance ToNative U1 '[] where 780 | toNative' r = U1 781 | 782 | instance 783 | (Has name lts t) => 784 | ToNative (S1 ('MetaSel ('Just name) p s l) (Rec0 t)) lts 785 | where 786 | toNative' r = 787 | M1 $ K1 (get (FldProxy :: FldProxy name) r) 788 | 789 | instance 790 | ( ToNative l lts, 791 | ToNative r lts 792 | ) => 793 | ToNative (l :*: r) lts 794 | where 795 | toNative' r = toNative' r :*: toNative' r 796 | 797 | -- | Convert a record to a native Haskell type 798 | toNative :: (Generic a, ToNative (Rep a) lts) => Rec lts -> a 799 | toNative = to . toNative' 800 | {-# INLINE toNative #-} 801 | 802 | type Lens s t a b = forall f. Functor f => (a -> f b) -> (s -> f t) 803 | 804 | -- | Convert a field label to a lens 805 | lens :: 806 | (Has l lts v, Set l lts v' ~ lts') => FldProxy l -> Lens (Rec lts) (Rec lts') v v' 807 | lens lbl f r = 808 | fmap (\v -> set lbl v r) (f (get lbl r)) 809 | {-# INLINE lens #-} 810 | 811 | opticLens :: 812 | (Has l lts v, Set l lts v' ~ lts') => FldProxy l -> OL.Lens (Rec lts) (Rec lts') v v' 813 | opticLens lbl = 814 | OL.lensVL $ lens lbl 815 | {-# INLINE opticLens #-} 816 | 817 | class NoConstraint x 818 | 819 | instance NoConstraint x 820 | 821 | -- | Convert a record into a list of fields. 822 | -- 823 | -- | Not present in original superrecord 824 | getFields :: RecApply fields fields NoConstraint => Rec fields -> [Any] 825 | getFields = 826 | reflectRec @NoConstraint 827 | Proxy 828 | (\_ val -> unsafeCoerce (FldProxy @"" := val)) 829 | -------------------------------------------------------------------------------- /test/JRecShouldNotTypecheckSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fdefer-type-errors #-} 2 | 3 | module JRecShouldNotTypecheckSpec (spec) where 4 | 5 | import Control.Lens ((&), (.~), (^.)) 6 | import JRec 7 | import Test.Hspec 8 | import Test.ShouldNotTypecheck 9 | import GHC.Stack 10 | 11 | spec :: Spec 12 | spec = do 13 | describe "insert" $ do 14 | it "type-check fails if field already exists" $ do 15 | shouldNotTypecheck ((#a := '1') `insert` Rec (#b := '2', #a := '0')) 16 | -------------------------------------------------------------------------------- /test/JRecSpec.hs: -------------------------------------------------------------------------------- 1 | module JRecSpec (spec) where 2 | 3 | import Control.Lens ((&), (.~), (^.)) 4 | import Data.Aeson 5 | import GHC.Stack 6 | import JRec 7 | import Test.Hspec 8 | 9 | data Pair a = Pair !a !a 10 | deriving (Eq, Show) 11 | 12 | spec :: HasCallStack => Spec 13 | spec = do 14 | it "is not crazy" $ do 15 | Pair (Rec (#a := 1)) (Rec (#a := 2)) 16 | `shouldNotBe` Pair (Rec (#a := 1)) (Rec (#a := 1)) 17 | Pair (Rec (#a := 1)) (Rec (#a := 2)) 18 | `shouldNotBe` Pair (Rec (#a := 2)) (Rec (#a := 2)) 19 | it "polymorphic" $ do 20 | (Rec (#u := True, #a := 5, #b := 6, #a := 2) & #u .~ 5) 21 | `shouldBe` Rec (#u := 5, #a := 5, #b := 6, #a := 2) 22 | describe "eq" $ do 23 | -- eq can compare only the first matching field, discarding the rest. 24 | it "fails if first matching field doesn't compare" $ do 25 | Rec (#a := 1, #a := 2) `shouldNotBe` Rec (#a := 0, #a := 2) 26 | it "succeeds if first matching field compares" $ do 27 | Rec (#a := 1, #a := 2) `shouldBe` Rec (#a := 1, #a := 0) 28 | it "ord" $ do 29 | -- Same as eq when there is duplicated keys. 30 | -- Only the first occurence of that key is considered. 31 | compare (Rec (#a := 1, #a := 2)) (Rec (#a := 1, #a := 2)) `shouldBe` EQ 32 | compare (Rec (#a := 1, #a := 2)) (Rec (#a := 1, #a := 3)) `shouldBe` EQ 33 | compare (Rec (#a := 1, #a := 2)) (Rec (#a := 2, #a := 1)) `shouldBe` LT 34 | compare (Rec (#a := 1, #a := 2)) (Rec (#a := 0, #a := 3)) `shouldBe` GT 35 | compare (Rec (#a := 1, #b := 2)) (Rec (#a := 1, #b := 2)) `shouldBe` EQ 36 | compare (Rec (#a := 1, #b := 2)) (Rec (#a := 1, #b := 3)) `shouldBe` LT 37 | compare (Rec (#a := 1, #b := 2)) (Rec (#a := 2, #b := 1)) `shouldBe` LT 38 | compare (Rec (#a := 1, #b := 2)) (Rec (#a := 0, #b := 3)) `shouldBe` GT 39 | compare (Rec (#a := 1, #a := 2, #b := 3)) (Rec (#a := 1, #a := 3, #b := 2)) `shouldBe` GT 40 | it "show" $ do 41 | show (Rec ()) `shouldBe` "{}" 42 | show (Rec (#foo := True)) `shouldBe` "{foo = True}" 43 | show (Rec (#foo := True, #bar := 0)) `shouldBe` "{foo = True, bar = 0}" 44 | it "get" $ do 45 | let getA1 :: Rec ("a" := Int ': rest) -> Int 46 | getA1 = (^. #a) 47 | let getA2 :: Rec ("u" := Bool ': "a" := Int ': rest) -> Int 48 | getA2 = (^. #a) 49 | getA1 (Rec (#a := 5)) `shouldBe` 5 50 | getA1 (Rec (#a := 5, #b := 6)) `shouldBe` 5 51 | getA2 (Rec (#u := True, #a := 5)) `shouldBe` 5 52 | getA2 (Rec (#u := True, #a := 5, #b := 6)) `shouldBe` 5 53 | it "set" $ do 54 | let setA1 :: 55 | Rec ("a" := Int ': rest) -> 56 | Rec ("a" := Int ': rest) 57 | setA1 = (#a .~ 8) 58 | let setA2 :: 59 | Rec ("u" := Bool ': "a" := Int ': rest) -> 60 | Rec ("u" := Bool ': "a" := Int ': rest) 61 | setA2 = (#a .~ 8) 62 | setA1 (Rec (#a := 5)) 63 | `shouldBe` (Rec (#a := 8)) 64 | setA1 (Rec (#a := 5, #b := 6)) 65 | `shouldBe` (Rec (#a := 8, #b := 6)) 66 | setA2 (Rec (#u := True, #a := 5)) 67 | `shouldBe` (Rec (#u := True, #a := 8)) 68 | setA2 (Rec (#u := True, #a := 5, #b := 6)) 69 | `shouldBe` (Rec (#u := True, #a := 8, #b := 6)) 70 | describe "append" $ do 71 | it "simple append" $ do 72 | Rec (#a := 1) `append` Rec (#b := 2) 73 | `shouldBe` Rec (#a := 1, #b := 2) 74 | Rec () `append` Rec (#b := 2) 75 | `shouldBe` Rec (#b := 2) 76 | Rec (#a := 1) `append` Rec () 77 | `shouldBe` Rec (#a := 1) 78 | Rec (#a := 1, #b := 2) `append` Rec (#c := 3) 79 | `shouldBe` Rec (#a := 1, #b := 2, #c := 3) 80 | Rec (#a := 1) `append` Rec (#b := 2, #c := 3) 81 | `shouldBe` Rec (#a := 1, #b := 2, #c := 3) 82 | Rec (#a := 1, #b := 2) `append` Rec (#c := 3, #d := 4) 83 | `shouldBe` Rec (#a := 1, #b := 2, #c := 3, #d := 4) 84 | it "append with duplicates" $ do 85 | let r1 = Rec (#b := 5, #a := 6) 86 | r2 = Rec (#c := 7, #a := 8) 87 | r1 `append` r2 88 | `shouldBe` Rec (#b := 5, #a := 6, #c := 7, #a := 8) 89 | describe "union" $ do 90 | it "simple union" $ do 91 | Rec (#a := 1) `union` Rec (#b := 2) 92 | `shouldBe` Rec (#a := 1, #b := 2) 93 | it "union with duplicates (left-biased)" $ do 94 | let r1 = Rec (#b := 5, #a := 6) 95 | r2 = Rec (#c := 7, #a := 8) 96 | r1 `union` r2 97 | `shouldBe` Rec (#b := 5, #a := 6, #c := 7) 98 | describe "insert" $ do 99 | it "simple insert" $ do 100 | (#a := 1) `insert` Rec (#b := 2, #c := 3) 101 | `shouldBe` Rec (#a := 1, #b := 2, #c := 3) 102 | describe "insertOrSet" $ do 103 | it "distinct" $ do 104 | insertOrSet (#a := 1) (Rec (#b := 2, #c := 3)) 105 | `shouldBe` Rec (#a := 1, #b := 2, #c := 3) 106 | it "overwrite" $ do 107 | insertOrSet (#c := 1) (Rec (#b := 2, #c := 3)) 108 | `shouldBe` Rec (#b := 2, #c := 1) 109 | describe "optional fields" $ do 110 | it "encode" $ do 111 | encode (Rec (#a := (1 :: Int), #b := (Nothing :: Maybe Int))) 112 | `shouldBe` "{\"a\":1}" 113 | it "encode" $ do 114 | encode (Rec (#a := (1 :: Int), #b := (Just 2 :: Maybe Int))) 115 | `shouldBe` "{\"a\":1,\"b\":2}" 116 | it "decode" $ do 117 | decode "{\"a\": 1}" 118 | `shouldBe` Just (Rec (#a := (1 :: Int), #b := (Nothing :: Maybe Int))) 119 | decode "{\"a\": 1, \"b\": null}" 120 | `shouldBe` Just (Rec (#a := (1 :: Int), #b := (Nothing :: Maybe Int))) 121 | decode "{\"a\": 1, \"b\": 2}" 122 | `shouldBe` Just (Rec (#a := (1 :: Int), #b := (Just 2 :: Maybe Int))) 123 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | --------------------------------------------------------------------------------