├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── cabal.project ├── cbits └── wrap-rust-haskell-ffi.c ├── demo-annotated └── Main.hs ├── foreign-rust.cabal ├── src ├── Data │ ├── Annotated.hs │ ├── Structured.hs │ └── Structured │ │ └── TH.hs └── Foreign │ └── Rust │ ├── External │ ├── Bincode.hs │ └── JSON.hs │ ├── Failure.hs │ ├── Marshall │ ├── External.hs │ ├── Fixed.hs │ ├── Util.hs │ └── Variable.hs │ ├── SafeConv.hs │ └── Serialisation │ ├── JSON.hs │ ├── Raw.hs │ └── Raw │ ├── Base16.hs │ ├── Base58.hs │ ├── Base64.hs │ └── Decimal.hs └── test ├── Main.hs └── Test ├── Serialisation ├── JSON.hs ├── Raw │ ├── Base16.hs │ ├── Base58.hs │ ├── Base64.hs │ └── Decimal.hs └── Types.hs └── Util └── TH.hs /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' '--no-cabal-check' 'cabal.project' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.15.20230312 12 | # 13 | # REGENDATA ("0.15.20230312",["github","--no-cabal-check","cabal.project"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | linux: 21 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 22 | runs-on: ubuntu-20.04 23 | timeout-minutes: 24 | 60 25 | container: 26 | image: buildpack-deps:bionic 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-9.4.4 32 | compilerKind: ghc 33 | compilerVersion: 9.4.4 34 | setup-method: ghcup 35 | allow-failure: false 36 | - compiler: ghc-9.2.7 37 | compilerKind: ghc 38 | compilerVersion: 9.2.7 39 | setup-method: ghcup 40 | allow-failure: false 41 | - compiler: ghc-9.0.2 42 | compilerKind: ghc 43 | compilerVersion: 9.0.2 44 | setup-method: ghcup 45 | allow-failure: false 46 | - compiler: ghc-8.10.7 47 | compilerKind: ghc 48 | compilerVersion: 8.10.7 49 | setup-method: ghcup 50 | allow-failure: false 51 | - compiler: ghc-8.8.4 52 | compilerKind: ghc 53 | compilerVersion: 8.8.4 54 | setup-method: hvr-ppa 55 | allow-failure: false 56 | - compiler: ghc-8.6.5 57 | compilerKind: ghc 58 | compilerVersion: 8.6.5 59 | setup-method: hvr-ppa 60 | allow-failure: false 61 | fail-fast: false 62 | steps: 63 | - name: apt 64 | run: | 65 | apt-get update 66 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 67 | if [ "${{ matrix.setup-method }}" = ghcup ]; then 68 | mkdir -p "$HOME/.ghcup/bin" 69 | curl -sL https://downloads.haskell.org/ghcup/0.1.18.0/x86_64-linux-ghcup-0.1.18.0 > "$HOME/.ghcup/bin/ghcup" 70 | chmod a+x "$HOME/.ghcup/bin/ghcup" 71 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 72 | "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 73 | else 74 | apt-add-repository -y 'ppa:hvr/ghc' 75 | apt-get update 76 | apt-get install -y "$HCNAME" 77 | mkdir -p "$HOME/.ghcup/bin" 78 | curl -sL https://downloads.haskell.org/ghcup/0.1.18.0/x86_64-linux-ghcup-0.1.18.0 > "$HOME/.ghcup/bin/ghcup" 79 | chmod a+x "$HOME/.ghcup/bin/ghcup" 80 | "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 81 | fi 82 | env: 83 | HCKIND: ${{ matrix.compilerKind }} 84 | HCNAME: ${{ matrix.compiler }} 85 | HCVER: ${{ matrix.compilerVersion }} 86 | - name: Set PATH and environment variables 87 | run: | 88 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 89 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 90 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 91 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 92 | HCDIR=/opt/$HCKIND/$HCVER 93 | if [ "${{ matrix.setup-method }}" = ghcup ]; then 94 | HC=$HOME/.ghcup/bin/$HCKIND-$HCVER 95 | echo "HC=$HC" >> "$GITHUB_ENV" 96 | echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV" 97 | echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV" 98 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" 99 | else 100 | HC=$HCDIR/bin/$HCKIND 101 | echo "HC=$HC" >> "$GITHUB_ENV" 102 | echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV" 103 | echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV" 104 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" 105 | fi 106 | 107 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 108 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 109 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 110 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 111 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 112 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 113 | echo "GHCJSARITH=0" >> "$GITHUB_ENV" 114 | env: 115 | HCKIND: ${{ matrix.compilerKind }} 116 | HCNAME: ${{ matrix.compiler }} 117 | HCVER: ${{ matrix.compilerVersion }} 118 | - name: env 119 | run: | 120 | env 121 | - name: write cabal config 122 | run: | 123 | mkdir -p $CABAL_DIR 124 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 157 | echo 'de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz' | sha256sum -c - 158 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 159 | rm -f cabal-plan.xz 160 | chmod a+x $HOME/.cabal/bin/cabal-plan 161 | cabal-plan --version 162 | - name: checkout 163 | uses: actions/checkout@v3 164 | with: 165 | path: source 166 | - name: initial cabal.project for sdist 167 | run: | 168 | touch cabal.project 169 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 170 | cat cabal.project 171 | - name: sdist 172 | run: | 173 | mkdir -p sdist 174 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 175 | - name: unpack 176 | run: | 177 | mkdir -p unpacked 178 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 179 | - name: generate cabal.project 180 | run: | 181 | PKGDIR_foreign_rust="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/foreign-rust-[0-9.]*')" 182 | echo "PKGDIR_foreign_rust=${PKGDIR_foreign_rust}" >> "$GITHUB_ENV" 183 | rm -f cabal.project cabal.project.local 184 | touch cabal.project 185 | touch cabal.project.local 186 | echo "packages: ${PKGDIR_foreign_rust}" >> cabal.project 187 | echo "package foreign-rust" >> cabal.project 188 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 189 | cat >> cabal.project <> cabal.project.local 192 | cat cabal.project 193 | cat cabal.project.local 194 | - name: dump install plan 195 | run: | 196 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 197 | cabal-plan 198 | - name: restore cache 199 | uses: actions/cache/restore@v3 200 | with: 201 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 202 | path: ~/.cabal/store 203 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 204 | - name: install dependencies 205 | run: | 206 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 207 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 208 | - name: build w/o tests 209 | run: | 210 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 211 | - name: build 212 | run: | 213 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 214 | - name: tests 215 | run: | 216 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 217 | - name: haddock 218 | run: | 219 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 220 | - name: unconstrained build 221 | run: | 222 | rm -f cabal.project.local 223 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 224 | - name: save cache 225 | uses: actions/cache/save@v3 226 | if: always() 227 | with: 228 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 229 | path: ~/.cabal/store 230 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .envrc 2 | dist-newstyle 3 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for foreign-rust 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2023 BeFunctional 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | 3 | package foreign-rust 4 | tests: true 5 | -------------------------------------------------------------------------------- /cbits/wrap-rust-haskell-ffi.c: -------------------------------------------------------------------------------- 1 | // Forward-declare the Rust-exported function 2 | void haskell_ffi_external_free(void* vec); 3 | 4 | // Wrapper around the Rust function that takes an additional (unused) argument, 5 | // which makes it match the Haskell `FinalizerEnvPtr` type. The wrapper also 6 | // avoids linker errors when the Rust library is not available (of course, 7 | // the Rust library must be linked into the final application). 8 | void haskell_ffi_external_free_env(void* vec, void* ptr) { 9 | haskell_ffi_external_free(vec); 10 | } -------------------------------------------------------------------------------- /demo-annotated/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | import Data.Annotated 4 | import Data.Kind 5 | import GHC.TypeLits 6 | 7 | import qualified GHC.Generics as GHC 8 | import qualified Generics.SOP as SOP 9 | 10 | import qualified Data.Structured as Structured 11 | import qualified Data.Structured.TH as Structured 12 | 13 | {------------------------------------------------------------------------------- 14 | Demonstration of annotations 15 | -------------------------------------------------------------------------------} 16 | 17 | -- 18 | -- Suppose we have some data type that is opaque Haskell-side (just some bytes), 19 | -- 20 | 21 | data Keypair = Keypair 22 | deriving stock (Show, GHC.Generic) 23 | deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) 24 | deriving anyclass (Structured.Show) 25 | deriving CanAnnotate via PairWithAnnotation Keypair 26 | 27 | -- 28 | -- Perhaps we can inspect this datatype using an FFI 29 | -- 30 | 31 | data Pubkey = Pubkey 32 | deriving stock (Show, GHC.Generic) 33 | deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) 34 | deriving anyclass (Structured.Show) 35 | 36 | data Secret = Secret 37 | deriving stock (Show, GHC.Generic) 38 | deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) 39 | deriving anyclass (Structured.Show) 40 | 41 | keypairPubkey :: Keypair -> Pubkey 42 | keypairPubkey Keypair = Pubkey 43 | 44 | keypairSecret :: Keypair -> Secret 45 | keypairSecret Keypair = Secret 46 | 47 | -- 48 | -- When we show a Keypair, we'd like to annotate it with these derived values 49 | -- 50 | 51 | data KeypairAnnotation = KeypairAnnotation { 52 | pubkey :: Pubkey 53 | , secret :: Secret 54 | } 55 | deriving stock (Show, GHC.Generic) 56 | deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) 57 | deriving anyclass (Structured.Show) 58 | 59 | type instance Annotation Keypair = KeypairAnnotation 60 | 61 | instance ComputeAnnotation Keypair where 62 | computeAnnotation kp = KeypairAnnotation { 63 | pubkey = keypairPubkey kp 64 | , secret = keypairSecret kp 65 | } 66 | 67 | {------------------------------------------------------------------------------- 68 | Generics 69 | -------------------------------------------------------------------------------} 70 | 71 | data RecordA = RecordA { 72 | recA_field1 :: Bool 73 | , recA_field2 :: Int 74 | } 75 | deriving stock (GHC.Generic) 76 | deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) 77 | deriving anyclass (Structured.Show) 78 | 79 | -- A type, perhaps externally defined, with only standard Show instance 80 | data SomeOtherType = SomeOtherType String 81 | deriving (Show) 82 | 83 | data RecordB = RecordB { 84 | recB :: SomeOtherType 85 | } 86 | deriving stock (GHC.Generic) 87 | deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) 88 | 89 | instance Structured.Show RecordB where 90 | toValue = Structured.gtoValueAfter Structured.FromPreludeShow 91 | 92 | {------------------------------------------------------------------------------- 93 | Demonstrate TH support (crucically, with support for GADTs) 94 | -------------------------------------------------------------------------------} 95 | 96 | data SimpleEnum = SimpleEnumA | SimpleEnumB 97 | 98 | Structured.deriveInstance 'SimpleEnumA [t| 99 | forall. Structured.Show SimpleEnum 100 | |] 101 | 102 | data SimpleStruct a = SimpleStruct a Int 103 | 104 | Structured.deriveInstance 'SimpleStruct [t| 105 | forall a. Structured.Show a => Structured.Show (SimpleStruct a) 106 | |] 107 | 108 | data SomeGADT :: Symbol -> Type where 109 | Foo :: SomeGADT "foo" 110 | Bar :: SomeGADT "bar" 111 | 112 | Structured.deriveInstance 'Foo [t| 113 | forall k. Structured.Show (SomeGADT k) 114 | |] 115 | 116 | class Foo a where 117 | data SomeAssocType a :: Type 118 | 119 | instance Foo Int where 120 | data SomeAssocType Int = SomeInt Int 121 | 122 | Structured.deriveInstance 'SomeInt [t| 123 | forall. Structured.Show (SomeAssocType Int) 124 | |] 125 | 126 | data SomeRecord = SomeRecord { 127 | field1 :: Int 128 | , field2 :: Bool 129 | } 130 | 131 | Structured.deriveInstance 'SomeRecord [t| 132 | forall. Structured.Show SomeRecord 133 | |] 134 | 135 | {------------------------------------------------------------------------------- 136 | Main 137 | -------------------------------------------------------------------------------} 138 | 139 | main :: IO () 140 | main = do 141 | -- Annotations 142 | Structured.print . annotate $ 143 | [(Just Keypair, True)] 144 | Structured.print . dropAnnotation @[(Maybe Keypair, Bool)] . annotate $ 145 | [(Just Keypair, True)] 146 | -- Generics 147 | Structured.print $ RecordA { recA_field1 = True, recA_field2 = 5 } 148 | Structured.print $ RecordB { recB = SomeOtherType "hi" } 149 | -- TH 150 | Structured.print $ SimpleEnumA 151 | Structured.print $ SimpleStruct True 5 152 | Structured.print $ Foo 153 | Structured.print $ SomeInt 5 154 | Structured.print $ SomeRecord { field1 = 1, field2 = True } -------------------------------------------------------------------------------- /foreign-rust.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: foreign-rust 3 | version: 0.1.0 4 | license: BSD-3-Clause 5 | license-file: LICENSE 6 | author: Edsko de Vries 7 | maintainer: edsko@well-typed.com 8 | category: Development 9 | build-type: Simple 10 | extra-doc-files: CHANGELOG.md 11 | tested-with: GHC==8.6.5 12 | , GHC==8.8.4 13 | , GHC==8.10.7 14 | , GHC==9.0.2 15 | , GHC==9.2.7 16 | , GHC==9.4.4 17 | 18 | common lang 19 | build-depends: 20 | base >= 4.12 21 | default-language: 22 | Haskell2010 23 | ghc-options: 24 | -Wall 25 | -Wredundant-constraints 26 | if impl(ghc >= 8.10) 27 | ghc-options: 28 | -Wunused-packages 29 | default-extensions: 30 | DataKinds 31 | DefaultSignatures 32 | DeriveAnyClass 33 | DeriveGeneric 34 | DerivingStrategies 35 | DerivingVia 36 | FlexibleContexts 37 | FlexibleInstances 38 | GADTs 39 | GeneralizedNewtypeDeriving 40 | LambdaCase 41 | MultiParamTypeClasses 42 | PolyKinds 43 | RankNTypes 44 | ScopedTypeVariables 45 | StandaloneDeriving 46 | TupleSections 47 | TypeApplications 48 | TypeFamilies 49 | TypeOperators 50 | UndecidableInstances 51 | ViewPatterns 52 | 53 | library 54 | import: 55 | lang 56 | exposed-modules: 57 | Foreign.Rust.External.JSON 58 | Foreign.Rust.External.Bincode 59 | Foreign.Rust.Failure 60 | Foreign.Rust.Marshall.External 61 | Foreign.Rust.Marshall.Fixed 62 | Foreign.Rust.Marshall.Variable 63 | Foreign.Rust.SafeConv 64 | Foreign.Rust.Serialisation.JSON 65 | Foreign.Rust.Serialisation.Raw 66 | Foreign.Rust.Serialisation.Raw.Base16 67 | Foreign.Rust.Serialisation.Raw.Base58 68 | Foreign.Rust.Serialisation.Raw.Base64 69 | Foreign.Rust.Serialisation.Raw.Decimal 70 | 71 | Data.Annotated 72 | Data.Structured 73 | Data.Structured.TH 74 | other-modules: 75 | Foreign.Rust.Marshall.Util 76 | hs-source-dirs: 77 | src 78 | build-depends: 79 | , aeson 80 | , base16-bytestring 81 | , base58-bytestring 82 | , base64-bytestring 83 | , binary 84 | , borsh >= 0.3 85 | , bytestring 86 | , containers 87 | , data-default 88 | , generics-sop 89 | , OneTuple 90 | , sop-core 91 | , template-haskell 92 | , text 93 | , th-abstraction 94 | , vector 95 | , wide-word 96 | c-sources: 97 | cbits/wrap-rust-haskell-ffi.c 98 | 99 | test-suite test-foreign-rust 100 | import: 101 | lang 102 | type: 103 | exitcode-stdio-1.0 104 | main-is: 105 | Main.hs 106 | other-modules: 107 | Test.Serialisation.JSON 108 | Test.Serialisation.Raw.Base16 109 | Test.Serialisation.Raw.Base58 110 | Test.Serialisation.Raw.Base64 111 | Test.Serialisation.Raw.Decimal 112 | Test.Serialisation.Types 113 | Test.Util.TH 114 | hs-source-dirs: 115 | test 116 | build-depends: 117 | , aeson 118 | , foreign-rust 119 | , haskell-src-exts 120 | , tasty 121 | , tasty-hunit 122 | , template-haskell 123 | 124 | test-suite demo-annotated 125 | import: 126 | lang 127 | type: 128 | exitcode-stdio-1.0 129 | main-is: 130 | Main.hs 131 | hs-source-dirs: 132 | demo-annotated 133 | build-depends: 134 | , generics-sop 135 | , foreign-rust 136 | -------------------------------------------------------------------------------- /src/Data/Annotated.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE UndecidableSuperClasses #-} 3 | module Data.Annotated ( 4 | -- * Definition 5 | CanAnnotate(..) 6 | -- * Deriving-via support 7 | -- ** Computing annotations 8 | , Annotation 9 | , PairWithAnnotation(..) 10 | , ComputeAnnotation(..) 11 | , WithAnnotation(..) 12 | -- ** Other combinators 13 | , NoAnnotation(..) 14 | , AnnotateFoldable(..) 15 | , AnnotateGenericallyAs(..) 16 | ) where 17 | 18 | import Data.Functor.Identity 19 | import Data.Int 20 | import Data.Kind 21 | import Data.Map (Map) 22 | import Data.Proxy 23 | import Data.SOP (SOP) 24 | import Data.Tuple.Solo 25 | import Data.WideWord 26 | import Data.Word 27 | 28 | import qualified Data.Aeson as Aeson 29 | import qualified Data.SOP.Constraint as SOP 30 | import qualified Generics.SOP as SOP 31 | import qualified GHC.Generics as GHC 32 | 33 | import qualified Data.Structured as Structured 34 | 35 | {------------------------------------------------------------------------------- 36 | Definition 37 | -------------------------------------------------------------------------------} 38 | 39 | class CanAnnotate a where 40 | type Annotated a :: Type 41 | 42 | -- | Annotate value 43 | annotate :: a -> Annotated a 44 | 45 | -- | Drop annotation 46 | -- 47 | -- NOTE: 'Annotated' is a non-injective type family. You might need to supply 48 | -- a type argument to 'dropAnnotation' if the resulting type is not clear 49 | -- from context. 50 | dropAnnotation :: Annotated a -> a 51 | 52 | {------------------------------------------------------------------------------- 53 | Deriving via support: computing annotations 54 | -------------------------------------------------------------------------------} 55 | 56 | -- | Annotation of a value 57 | -- 58 | -- Unlike 'Annotated', 'Annotation' is not always defined: not all types /have/ 59 | -- annotations (for example, @Annotated a@ might just be @a@). 60 | type family Annotation a :: Type 61 | 62 | -- | Deriving via support: computing annotations 63 | -- 64 | -- If you need to compute an annotation and do not need to worry about 65 | -- annotating any nested values, you define a 'CanAnnotate' instance for some 66 | -- type @A@ with annotation @B@ as follows: 67 | -- 68 | -- > data A = .. 69 | -- > deriving CanAnnotate via PairWithAnnotation A 70 | newtype PairWithAnnotation a = PairWithAnnotation a 71 | 72 | class ComputeAnnotation a where 73 | computeAnnotation :: a -> Annotation a 74 | 75 | instance ComputeAnnotation a => CanAnnotate (PairWithAnnotation a) where 76 | type Annotated (PairWithAnnotation a) = WithAnnotation a (Annotation a) 77 | annotate (PairWithAnnotation x) = WithAnnotation { 78 | value = x 79 | , annotation = computeAnnotation x 80 | } 81 | dropAnnotation = PairWithAnnotation . value 82 | 83 | data WithAnnotation a b = WithAnnotation { 84 | value :: a 85 | , annotation :: b 86 | } 87 | deriving stock (Show, GHC.Generic) 88 | deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) 89 | deriving anyclass (Structured.Show) 90 | 91 | {------------------------------------------------------------------------------- 92 | Deriving via: default instance for foldable containers 93 | -------------------------------------------------------------------------------} 94 | 95 | -- | Deriving via: default instance for foldable containers 96 | -- 97 | -- We annotate the values in the containers, and give the container length as 98 | -- its own annotation. 99 | -- 100 | -- Example: 101 | -- 102 | -- > deriving 103 | -- > via AnnotateFoldable [] a 104 | -- > instance CanAnnotate a => CanAnnotate [a] 105 | newtype AnnotateFoldable f a = AnnotateFoldable (f a) 106 | 107 | newtype Length = Length Int 108 | deriving stock (Show, GHC.Generic) 109 | deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) 110 | deriving anyclass (Structured.Show) 111 | 112 | type instance Annotation (AnnotateFoldable f a) = Length 113 | 114 | instance ( Functor f 115 | , Foldable f 116 | , CanAnnotate a 117 | ) => CanAnnotate (AnnotateFoldable f a) where 118 | type Annotated (AnnotateFoldable f a) = WithAnnotation (f (Annotated a)) Length 119 | annotate (AnnotateFoldable xs) = WithAnnotation { 120 | value = annotate <$> xs 121 | , annotation = Length $ length xs 122 | } 123 | dropAnnotation = AnnotateFoldable . fmap dropAnnotation . value 124 | 125 | {------------------------------------------------------------------------------- 126 | Deriving-via: no annotation 127 | -------------------------------------------------------------------------------} 128 | 129 | -- | Deriving via: no annotation 130 | -- 131 | -- Example: 132 | -- 133 | -- > data A = .. 134 | -- > deriving CanAnnotate via NoAnnotation A 135 | newtype NoAnnotation a = NoAnnotation a 136 | 137 | type instance Annotation (NoAnnotation a) = () 138 | 139 | instance CanAnnotate (NoAnnotation a) where 140 | type Annotated (NoAnnotation a) = a 141 | annotate (NoAnnotation x) = x 142 | dropAnnotation = NoAnnotation 143 | 144 | {------------------------------------------------------------------------------- 145 | generics-sop auxiliary: reasoning about AllZip and AllZip2 146 | -------------------------------------------------------------------------------} 147 | 148 | class c y x => Inv (c :: l -> k -> Constraint) (x :: k) (y :: l) 149 | instance c y x => Inv (c :: l -> k -> Constraint) (x :: k) (y :: l) 150 | 151 | data Dict2 (c :: k -> k -> Constraint) (x :: k) (y :: k) where 152 | Dict2 :: c x y => Dict2 c x y 153 | 154 | invZip :: forall k c (xs :: [k]) (ys :: [k]). 155 | SOP.AllZip c xs ys 156 | => Proxy c 157 | -> Proxy ys 158 | -> Proxy xs 159 | -> Dict2 (SOP.AllZip (Inv c)) ys xs 160 | invZip _ _ _ = go SOP.shape SOP.shape 161 | where 162 | go :: forall xs' ys'. 163 | SOP.AllZip c xs' ys' 164 | => SOP.Shape xs' -> SOP.Shape ys' -> Dict2 (SOP.AllZip (Inv c)) ys' xs' 165 | go SOP.ShapeNil SOP.ShapeNil = Dict2 166 | go (SOP.ShapeCons xs) (SOP.ShapeCons ys) = 167 | case go xs ys of 168 | Dict2 -> Dict2 169 | 170 | zipImplies :: forall k c d (xs :: [k]) (ys :: [k]). 171 | SOP.AllZip c xs ys 172 | => Proxy c 173 | -> Proxy d 174 | -> Proxy xs 175 | -> Proxy ys 176 | -> (forall x y. c x y => Proxy x -> Proxy y -> Dict2 d x y) 177 | -> Dict2 (SOP.AllZip d) xs ys 178 | zipImplies _ _ _ _ f = go SOP.shape SOP.shape 179 | where 180 | go :: forall xs' ys'. 181 | SOP.AllZip c xs' ys' 182 | => SOP.Shape xs' -> SOP.Shape ys' -> Dict2 (SOP.AllZip d) xs' ys' 183 | go SOP.ShapeNil SOP.ShapeNil = Dict2 184 | go (SOP.ShapeCons xs) (SOP.ShapeCons ys) = 185 | case (f (Proxy @(SOP.Head xs')) (Proxy @(SOP.Head ys')), go xs ys) of 186 | (Dict2, Dict2) -> Dict2 187 | 188 | invAllZip :: forall k (c :: k -> k -> Constraint) (xss :: [[k]]) (yss :: [[k]]). 189 | SOP.AllZip (Inv (SOP.AllZip c)) xss yss 190 | => Proxy c 191 | -> Proxy xss 192 | -> Proxy yss 193 | -> Dict2 (SOP.AllZip (SOP.AllZip (Inv c))) xss yss 194 | invAllZip pc pxss pyss = 195 | zipImplies 196 | (Proxy @(Inv (SOP.AllZip c))) 197 | (Proxy @(SOP.AllZip (Inv c))) 198 | pxss 199 | pyss 200 | (invZip pc) 201 | 202 | invZip2 :: forall k c (xss :: [[k]]) (yss :: [[k]]). 203 | SOP.AllZip2 c xss yss 204 | => Proxy c 205 | -> Proxy yss 206 | -> Proxy xss 207 | -> Dict2 (SOP.AllZip2 (Inv c)) yss xss 208 | invZip2 pc pyss pxss = 209 | case invZip (Proxy @(SOP.AllZip c)) pyss pxss of 210 | Dict2 -> case invAllZip pc pyss pxss of 211 | Dict2 -> Dict2 212 | 213 | htransInv_SOP :: forall k c f g (xss :: [[k]]) (yss :: [[k]]). 214 | SOP.AllZip2 c yss xss 215 | => Proxy c 216 | -> (forall x y. c y x => f x -> g y) 217 | -> SOP f xss 218 | -> SOP g yss 219 | htransInv_SOP pc f = 220 | case invZip2 pc (Proxy @xss) (Proxy @yss) of 221 | Dict2 -> SOP.htrans (Proxy @(Inv c)) f 222 | 223 | {------------------------------------------------------------------------------- 224 | Internal auxiliary: two-parameter wrapper around 'CanAnnotate' 225 | 226 | We use this for a generic @htrans@. 227 | -------------------------------------------------------------------------------} 228 | 229 | class Annotate' a b where 230 | annotate' :: a -> b 231 | dropAnnotation' :: b -> a 232 | 233 | instance (CanAnnotate a, b ~ Annotated a) => Annotate' a b where 234 | annotate' = annotate 235 | dropAnnotation' = dropAnnotation 236 | 237 | {------------------------------------------------------------------------------- 238 | Deriving via: generics 239 | -------------------------------------------------------------------------------} 240 | 241 | -- | Deriving via: annotate generically 242 | -- 243 | -- This combinator can be used to define 'CanAnnotate' instance that just 244 | -- walk over the structure of the argument, without adding any annotations 245 | -- of their own. 246 | -- 247 | -- Example: 248 | -- 249 | -- > deriving 250 | -- > via AnnotateGenericallyAs (Maybe (Annotated a)) (Maybe a) 251 | -- > instance CanAnnotate a => CanAnnotate (Maybe a) 252 | newtype AnnotateGenericallyAs b a = AnnotateGenericallyAs a 253 | 254 | type instance Annotation (AnnotateGenericallyAs b a) = () 255 | 256 | instance ( SOP.Generic a 257 | , SOP.Generic b 258 | , SOP.AllZip2 Annotate' (SOP.Code a) (SOP.Code b) 259 | ) => CanAnnotate (AnnotateGenericallyAs b a) where 260 | 261 | type Annotated (AnnotateGenericallyAs b a) = b 262 | 263 | annotate (AnnotateGenericallyAs x) = 264 | SOP.to 265 | . SOP.htrans (Proxy @Annotate') (SOP.mapII annotate') 266 | . SOP.from 267 | $ x 268 | 269 | dropAnnotation = 270 | AnnotateGenericallyAs 271 | . SOP.to 272 | . htransInv_SOP (Proxy @Annotate') (SOP.mapII dropAnnotation') 273 | . SOP.from 274 | 275 | {------------------------------------------------------------------------------- 276 | Standard instances: no annotation 277 | -------------------------------------------------------------------------------} 278 | 279 | deriving via NoAnnotation Bool instance CanAnnotate Bool 280 | deriving via NoAnnotation Aeson.Value instance CanAnnotate Aeson.Value 281 | 282 | deriving via NoAnnotation Integer instance CanAnnotate Integer 283 | 284 | deriving via NoAnnotation Int instance CanAnnotate Int 285 | deriving via NoAnnotation Int8 instance CanAnnotate Int8 286 | deriving via NoAnnotation Int16 instance CanAnnotate Int16 287 | deriving via NoAnnotation Int32 instance CanAnnotate Int32 288 | deriving via NoAnnotation Int64 instance CanAnnotate Int64 289 | deriving via NoAnnotation Int128 instance CanAnnotate Int128 290 | 291 | deriving via NoAnnotation Word instance CanAnnotate Word 292 | deriving via NoAnnotation Word8 instance CanAnnotate Word8 293 | deriving via NoAnnotation Word16 instance CanAnnotate Word16 294 | deriving via NoAnnotation Word32 instance CanAnnotate Word32 295 | deriving via NoAnnotation Word64 instance CanAnnotate Word64 296 | deriving via NoAnnotation Word128 instance CanAnnotate Word128 297 | 298 | deriving via NoAnnotation Float instance CanAnnotate Float 299 | deriving via NoAnnotation Double instance CanAnnotate Double 300 | 301 | {------------------------------------------------------------------------------- 302 | Standard instances: foldable 303 | -------------------------------------------------------------------------------} 304 | 305 | deriving 306 | via AnnotateFoldable [] a 307 | instance CanAnnotate a => CanAnnotate [a] 308 | 309 | deriving 310 | via AnnotateFoldable (Map k) a 311 | instance CanAnnotate a => CanAnnotate (Map k a) 312 | 313 | {------------------------------------------------------------------------------- 314 | Standard instances: generic 315 | -------------------------------------------------------------------------------} 316 | 317 | deriving 318 | via AnnotateGenericallyAs (Maybe (Annotated a)) (Maybe a) 319 | instance CanAnnotate a => CanAnnotate (Maybe a) 320 | 321 | deriving 322 | via AnnotateGenericallyAs (Either (Annotated a) (Annotated b)) (Either a b) 323 | instance (CanAnnotate a, CanAnnotate b) => CanAnnotate (Either a b) 324 | 325 | deriving 326 | via AnnotateGenericallyAs (Identity (Annotated a)) (Identity a) 327 | instance CanAnnotate a => CanAnnotate (Identity a) 328 | 329 | {------------------------------------------------------------------------------- 330 | Standard instances: tuples 331 | 332 | These instances also use 'AnnotateGenericallyAs'. 333 | -------------------------------------------------------------------------------} 334 | 335 | -- 0 336 | deriving 337 | via NoAnnotation () 338 | instance CanAnnotate () 339 | 340 | -- 1 ('Solo' does not support SOP generics) 341 | instance CanAnnotate a => CanAnnotate (Solo a) where 342 | type Annotated (Solo a) = Solo (Annotated a) 343 | annotate (Solo x) = Solo (annotate x) 344 | dropAnnotation (Solo x) = Solo (dropAnnotation x) 345 | 346 | -- 2 347 | deriving 348 | via AnnotateGenericallyAs 349 | ( Annotated a 350 | , Annotated b 351 | ) 352 | (a, b) 353 | instance ( CanAnnotate a 354 | , CanAnnotate b 355 | ) => CanAnnotate (a, b) 356 | 357 | -- 3 358 | deriving 359 | via AnnotateGenericallyAs 360 | ( Annotated a 361 | , Annotated b 362 | , Annotated c 363 | ) 364 | (a, b, c) 365 | instance ( CanAnnotate a 366 | , CanAnnotate b 367 | , CanAnnotate c 368 | ) => CanAnnotate (a, b, c) 369 | 370 | -- 4 371 | deriving 372 | via AnnotateGenericallyAs 373 | ( Annotated a 374 | , Annotated b 375 | , Annotated c 376 | , Annotated d 377 | ) 378 | (a, b, c, d) 379 | instance ( CanAnnotate a 380 | , CanAnnotate b 381 | , CanAnnotate c 382 | , CanAnnotate d 383 | ) => CanAnnotate (a, b, c, d) 384 | 385 | -- 5 386 | deriving 387 | via AnnotateGenericallyAs 388 | ( Annotated a 389 | , Annotated b 390 | , Annotated c 391 | , Annotated d 392 | , Annotated e 393 | ) 394 | (a, b, c, d, e) 395 | instance ( CanAnnotate a 396 | , CanAnnotate b 397 | , CanAnnotate c 398 | , CanAnnotate d 399 | , CanAnnotate e 400 | ) => CanAnnotate (a, b, c, d, e) 401 | 402 | -- 6 403 | deriving 404 | via AnnotateGenericallyAs 405 | ( Annotated a 406 | , Annotated b 407 | , Annotated c 408 | , Annotated d 409 | , Annotated e 410 | , Annotated f 411 | ) 412 | (a, b, c, d, e, f) 413 | instance ( CanAnnotate a 414 | , CanAnnotate b 415 | , CanAnnotate c 416 | , CanAnnotate d 417 | , CanAnnotate e 418 | , CanAnnotate f 419 | ) => CanAnnotate (a, b, c, d, e, f) 420 | 421 | -- 7 422 | deriving 423 | via AnnotateGenericallyAs 424 | ( Annotated a 425 | , Annotated b 426 | , Annotated c 427 | , Annotated d 428 | , Annotated e 429 | , Annotated f 430 | , Annotated g 431 | ) 432 | (a, b, c, d, e, f, g) 433 | instance ( CanAnnotate a 434 | , CanAnnotate b 435 | , CanAnnotate c 436 | , CanAnnotate d 437 | , CanAnnotate e 438 | , CanAnnotate f 439 | , CanAnnotate g 440 | ) => CanAnnotate (a, b, c, d, e, f, g) 441 | 442 | -- 8 443 | deriving 444 | via AnnotateGenericallyAs 445 | ( Annotated a 446 | , Annotated b 447 | , Annotated c 448 | , Annotated d 449 | , Annotated e 450 | , Annotated f 451 | , Annotated g 452 | , Annotated h 453 | ) 454 | (a, b, c, d, e, f, g, h) 455 | instance ( CanAnnotate a 456 | , CanAnnotate b 457 | , CanAnnotate c 458 | , CanAnnotate d 459 | , CanAnnotate e 460 | , CanAnnotate f 461 | , CanAnnotate g 462 | , CanAnnotate h 463 | ) => CanAnnotate (a, b, c, d, e, f, g, h) 464 | 465 | -- 9 466 | deriving 467 | via AnnotateGenericallyAs 468 | ( Annotated a 469 | , Annotated b 470 | , Annotated c 471 | , Annotated d 472 | , Annotated e 473 | , Annotated f 474 | , Annotated g 475 | , Annotated h 476 | , Annotated i 477 | ) 478 | (a, b, c, d, e, f, g, h, i) 479 | instance ( CanAnnotate a 480 | , CanAnnotate b 481 | , CanAnnotate c 482 | , CanAnnotate d 483 | , CanAnnotate e 484 | , CanAnnotate f 485 | , CanAnnotate g 486 | , CanAnnotate h 487 | , CanAnnotate i 488 | ) => CanAnnotate (a, b, c, d, e, f, g, h, i) 489 | -------------------------------------------------------------------------------- /src/Data/Structured.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | 4 | -- | Pretty-print value in a way that is valid Haskell 5 | -- 6 | -- Intended for qualified import 7 | -- 8 | -- > import qualified Data.Structured as Structured 9 | module Data.Structured ( 10 | Show(..) 11 | , show 12 | , showsPrec 13 | , print 14 | -- * Structured values 15 | , Value(..) 16 | -- * Generics 17 | , gtoValue 18 | , gtoValueAfter 19 | , sopToValue 20 | , sopToValueAfter 21 | -- * Deriving-via support 22 | , ToPreludeShow(..) 23 | , FromPreludeShow(..) 24 | ) where 25 | 26 | import Prelude hiding (Show(..), print) 27 | import qualified Prelude 28 | 29 | import Control.Monad 30 | import Data.Bifunctor 31 | import Data.ByteString.Short (ShortByteString) 32 | import Data.Default 33 | import Data.Functor.Identity 34 | import Data.Int 35 | import Data.List (intersperse) 36 | import Data.List.NonEmpty (NonEmpty(..)) 37 | import Data.SOP 38 | import Data.SOP.Dict 39 | import Data.String 40 | import Data.Text (Text) 41 | import Data.Text.Lazy.Builder (Builder) 42 | import Data.Tuple.Solo 43 | import Data.Typeable 44 | import Data.WideWord 45 | import Data.Word 46 | import GHC.Show (appPrec) 47 | 48 | import qualified Data.Aeson as Aeson 49 | import qualified Data.Aeson.KeyMap as Aeson.KeyMap 50 | import qualified Data.Aeson.Text as Aeson 51 | import qualified Data.ByteString as Strict 52 | import qualified Data.ByteString.Lazy as Lazy 53 | import qualified Data.List.NonEmpty as NE 54 | import qualified Data.Text as Text 55 | import qualified Data.Text.Lazy as Lazy 56 | import qualified Data.Text.Lazy as Text.Lazy 57 | import qualified Data.Text.Lazy.Builder as B 58 | import qualified Data.Vector as Vector 59 | import qualified Generics.SOP as SOP 60 | 61 | {------------------------------------------------------------------------------- 62 | Main API 63 | -------------------------------------------------------------------------------} 64 | 65 | -- | Pretty-print value in a way that is valid Haskell 66 | -- 67 | -- This is similar to what @pretty-show@ offers, but @pretty-show@ does not 68 | -- guarantee valid Haskell (for example, strings are shown without quotes). 69 | class Show a where 70 | -- | Generate structured value 71 | -- 72 | -- Typically instances are derived using generics: 73 | -- 74 | -- > data MyType = .. 75 | -- > deriving stock (GHC.Generic) 76 | -- > deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) 77 | -- > deriving anyclass (Structured.Show) 78 | -- 79 | -- If you want to tweak the generic instance, see 'gtoValueAfter'. 80 | toValue :: a -> Value 81 | 82 | default toValue :: 83 | (SOP.HasDatatypeInfo a, All2 Show (SOP.Code a)) 84 | => a -> Value 85 | toValue = gtoValue 86 | 87 | show :: Show a => a -> String 88 | show = render False . toValue 89 | 90 | showsPrec :: Show a => Int -> a -> ShowS 91 | showsPrec p = showString . render (p > appPrec) . toValue 92 | 93 | print :: Show a => a -> IO () 94 | print = putStrLn . show 95 | 96 | {------------------------------------------------------------------------------- 97 | Value 98 | -------------------------------------------------------------------------------} 99 | 100 | -- | Structured value 101 | data Value where 102 | -- | Constructor (or smart constructor) application 103 | -- 104 | -- We allow for some type applications, too. 105 | Constr :: Text -> [TypeRep] -> [Value] -> Value 106 | 107 | -- | Record 108 | Record :: Text -> [(String, Value)] -> Value 109 | 110 | -- | List 111 | List :: [Value] -> Value 112 | 113 | -- | Tuple 114 | Tuple :: [Value] -> Value 115 | 116 | -- | Anything String-like 117 | -- 118 | -- Precondition: the 'Show' and 'IsString' instances must be compatible. 119 | String :: forall a. (Prelude.Show a, IsString a) => a -> Value 120 | 121 | -- | Integral numbers 122 | -- 123 | -- These are shown assuming @NumericUnderscores@. 124 | Integral :: forall a. (Prelude.Show a, Integral a) => a -> Value 125 | 126 | -- | Floating point numbers 127 | Floating :: Double -> Value 128 | 129 | -- | Quasi-quote 130 | -- 131 | -- We separate out the quasi-quoter from the quoted string proper. 132 | -- The lines of the quasi-quoted string are listed separately. 133 | QuasiQ :: Text -> NonEmpty Builder -> Value 134 | 135 | -- | JSON value 136 | -- 137 | -- We define this as an explicit constructor, in case we ever want to 138 | -- generate structured JSON logs from these values. 139 | -- 140 | -- The pretty-printer uses the @aesonQQ@ quasi-quoter. 141 | JSON :: Aeson.Value -> Value 142 | 143 | -- | Value shown using the Prelude's show 144 | PreludeShow :: Prelude.Show a => a -> Value 145 | 146 | deriving instance Prelude.Show Value 147 | 148 | {------------------------------------------------------------------------------- 149 | Deriving-via support 150 | -------------------------------------------------------------------------------} 151 | 152 | -- | Derive 'Prelude.Show' through 'Show' 153 | -- 154 | -- You might not want to do always do this; in some circumstances it may be 155 | -- useful to have a non-pretty-printed 'Show' instance alongside 'Show'. 156 | newtype ToPreludeShow a = ToPreludeShow a 157 | 158 | -- | Derive 'Show' through 'Prelude.Show' 159 | -- 160 | -- NOTE: This should be used sparingly. When 'Show x' is derived using 161 | -- 'Prelude.Show x', the result should still be a law-abiding instance (generate 162 | -- valid Haskell code), assuming that the 'Prelude.Show' instance is 163 | -- law-abiding; however, it will limit the ability to generate structured 164 | -- values in different formats, such as JSON. 165 | newtype FromPreludeShow a = FromPreludeShow a 166 | 167 | instance Show a => Prelude.Show (ToPreludeShow a) where 168 | showsPrec p (ToPreludeShow x) = showsPrec p x 169 | 170 | instance Prelude.Show a => Show (FromPreludeShow a) where 171 | toValue (FromPreludeShow x) = PreludeShow x 172 | 173 | {------------------------------------------------------------------------------- 174 | Generics 175 | -------------------------------------------------------------------------------} 176 | 177 | -- | Newtype which is transparent for the purposes of 'Show' 178 | -- 179 | -- This is only used internally in 'sopToValue'. 180 | newtype Transparent a = Transparent a 181 | deriving newtype Show 182 | 183 | gtoValue :: forall a. 184 | (SOP.HasDatatypeInfo a, All2 Show (SOP.Code a)) 185 | => a -> Value 186 | gtoValue x = sopToValue (SOP.from x) (SOP.datatypeInfo (Proxy @a)) 187 | 188 | -- | Generic derivation of 'toValue' 189 | -- 190 | -- The standard generics instance will depend on 'Show' for all nested values. 191 | -- This is usually the right choice, but occassionally you will want to show 192 | -- nested values in a different manner; in this case, you can use 193 | -- 'gtoValueAfter'. Example: 194 | -- 195 | -- > instance Structured.Show RecordB where 196 | -- > toValue = Structured.gtoValueAfter Structured.FromPreludeShow 197 | -- 198 | -- (However, 'FromPreludeShow' should be used sparingly; see discussion there.) 199 | gtoValueAfter :: forall f a. 200 | (SOP.HasDatatypeInfo a, All2 (Compose Show f) (SOP.Code a)) 201 | => (forall x. x -> f x) 202 | -> a -> Value 203 | gtoValueAfter f x = sopToValueAfter f (SOP.from x) (SOP.datatypeInfo (Proxy @a)) 204 | 205 | sopToValue :: forall xss. 206 | All2 Show xss 207 | => SOP I xss -> SOP.DatatypeInfo xss -> Value 208 | sopToValue = 209 | case aux of Dict -> sopToValueAfter Transparent 210 | where 211 | aux :: Dict (All2 (Compose Show Transparent)) xss 212 | aux = all_POP $ hcpure (Proxy @Show) Dict 213 | 214 | sopToValueAfter :: forall f xss. 215 | All2 (Compose Show f) xss 216 | => (forall x. x -> f x) 217 | -> SOP I xss -> SOP.DatatypeInfo xss -> Value 218 | sopToValueAfter f (SOP xss) info = hcollapse $ 219 | hczipWith (Proxy @(All (Compose Show f))) aux (SOP.constructorInfo info) xss 220 | where 221 | aux :: 222 | All (Compose Show f) xs 223 | => SOP.ConstructorInfo xs -> NP I xs -> K Value xs 224 | aux (SOP.Constructor name) xs = K $ auxSimple name xs 225 | aux (SOP.Record name fields) xs = K $ auxRecord name fields xs 226 | aux (SOP.Infix _ _ _) _ = error "sopToValue: TODO: infix" 227 | 228 | auxSimple :: 229 | All (Compose Show f) xs 230 | => String -> NP I xs -> Value 231 | auxSimple constr xs = Constr (Text.pack constr) [] $ hcollapse $ 232 | hcmap (Proxy @(Compose Show f)) (mapIK (toValue . f)) xs 233 | 234 | auxRecord :: 235 | All (Compose Show f) xs 236 | => SOP.ConstructorName -> NP SOP.FieldInfo xs -> NP I xs -> Value 237 | auxRecord constr fields xs = Record (Text.pack constr) $ hcollapse $ 238 | hczipWith (Proxy @(Compose Show f)) auxRecordField fields xs 239 | 240 | auxRecordField :: 241 | Show (f x) 242 | => SOP.FieldInfo x -> I x -> K (String, Value) x 243 | auxRecordField field (I x) = K (SOP.fieldName field, toValue (f x)) 244 | 245 | {------------------------------------------------------------------------------- 246 | Standard instances 247 | -------------------------------------------------------------------------------} 248 | 249 | instance Show Word where toValue = Integral 250 | instance Show Word8 where toValue = Integral 251 | instance Show Word16 where toValue = Integral 252 | instance Show Word32 where toValue = Integral 253 | instance Show Word64 where toValue = Integral 254 | instance Show Word128 where toValue = Integral 255 | 256 | instance Show Int where toValue = Integral 257 | instance Show Int8 where toValue = Integral 258 | instance Show Int16 where toValue = Integral 259 | instance Show Int32 where toValue = Integral 260 | instance Show Int64 where toValue = Integral 261 | instance Show Int128 where toValue = Integral 262 | 263 | instance Show Integer where toValue = Integral 264 | 265 | instance Show Float where toValue = Floating . realToFrac 266 | instance Show Double where toValue = Floating 267 | 268 | instance {-# OVERLAPPABLE #-} Show a => Show [a] where 269 | toValue = List . map toValue 270 | 271 | instance Show Aeson.Value where 272 | toValue = JSON 273 | 274 | instance Typeable a => Show (Proxy (a :: k)) where 275 | toValue p = Constr "Proxy" [typeRep p] [] 276 | 277 | {------------------------------------------------------------------------------- 278 | String-like types 279 | -------------------------------------------------------------------------------} 280 | 281 | instance {-# OVERLAPPING #-} Show String where 282 | toValue = String 283 | 284 | instance Show Strict.ByteString where toValue = String 285 | instance Show Lazy.ByteString where toValue = String 286 | instance Show ShortByteString where toValue = String 287 | instance Show Text where toValue = String 288 | instance Show Lazy.Text where toValue = String 289 | 290 | {------------------------------------------------------------------------------- 291 | Tuples 292 | -------------------------------------------------------------------------------} 293 | 294 | -- 0 295 | instance Show () 296 | 297 | -- 1 (Solo does not support SOP generics) 298 | instance Show a => Show (Solo a) where 299 | toValue (Solo x) = Constr "Solo" [] [toValue x] 300 | 301 | -- 2 302 | instance ( Show a 303 | , Show b 304 | ) => Show (a, b) where 305 | toValue (a, b) = Tuple [ 306 | toValue a 307 | , toValue b 308 | ] 309 | 310 | -- 3 311 | instance ( Show a 312 | , Show b 313 | , Show c 314 | ) => Show (a, b, c) where 315 | toValue (a, b, c) = Tuple [ 316 | toValue a 317 | , toValue b 318 | , toValue c 319 | ] 320 | 321 | -- 4 322 | instance ( Show a 323 | , Show b 324 | , Show c 325 | , Show d 326 | ) => Show (a, b, c, d) where 327 | toValue (a, b, c, d) = Tuple [ 328 | toValue a 329 | , toValue b 330 | , toValue c 331 | , toValue d 332 | ] 333 | 334 | -- 5 335 | instance ( Show a 336 | , Show b 337 | , Show c 338 | , Show d 339 | , Show e 340 | ) => Show (a, b, c, d, e) where 341 | toValue (a, b, c, d, e) = Tuple [ 342 | toValue a 343 | , toValue b 344 | , toValue c 345 | , toValue d 346 | , toValue e 347 | ] 348 | 349 | -- 6 350 | instance ( Show a 351 | , Show b 352 | , Show c 353 | , Show d 354 | , Show e 355 | , Show f 356 | ) => Show (a, b, c, d, e, f) where 357 | toValue (a, b, c, d, e, f) = Tuple [ 358 | toValue a 359 | , toValue b 360 | , toValue c 361 | , toValue d 362 | , toValue e 363 | , toValue f 364 | ] 365 | 366 | -- 7 367 | instance ( Show a 368 | , Show b 369 | , Show c 370 | , Show d 371 | , Show e 372 | , Show f 373 | , Show g 374 | ) => Show (a, b, c, d, e, f, g) where 375 | toValue (a, b, c, d, e, f, g) = Tuple [ 376 | toValue a 377 | , toValue b 378 | , toValue c 379 | , toValue d 380 | , toValue e 381 | , toValue f 382 | , toValue g 383 | ] 384 | 385 | -- 8 386 | instance ( Show a 387 | , Show b 388 | , Show c 389 | , Show d 390 | , Show e 391 | , Show f 392 | , Show g 393 | , Show h 394 | ) => Show (a, b, c, d, e, f, g, h) where 395 | toValue (a, b, c, d, e, f, g, h) = Tuple [ 396 | toValue a 397 | , toValue b 398 | , toValue c 399 | , toValue d 400 | , toValue e 401 | , toValue f 402 | , toValue g 403 | , toValue h 404 | ] 405 | 406 | -- 9 407 | instance ( Show a 408 | , Show b 409 | , Show c 410 | , Show d 411 | , Show e 412 | , Show f 413 | , Show g 414 | , Show h 415 | , Show i 416 | ) => Show (a, b, c, d, e, f, g, h, i) where 417 | toValue (a, b, c, d, e, f, g, h, i) = Tuple [ 418 | toValue a 419 | , toValue b 420 | , toValue c 421 | , toValue d 422 | , toValue e 423 | , toValue f 424 | , toValue g 425 | , toValue h 426 | , toValue i 427 | ] 428 | 429 | {------------------------------------------------------------------------------- 430 | Instances that rely on generics 431 | -------------------------------------------------------------------------------} 432 | 433 | instance Show Bool 434 | 435 | instance Show a => Show (Maybe a) 436 | 437 | instance (Show a, Show b) => Show (Either a b) 438 | 439 | instance Show a => Show (Identity a) 440 | 441 | {------------------------------------------------------------------------------- 442 | Rendering proper 443 | -------------------------------------------------------------------------------} 444 | 445 | render :: 446 | Bool -- ^ Are we in a context that may require brackets? 447 | -> Value -> String 448 | render = \contextNeedsBrackets -> 449 | Text.Lazy.unpack 450 | . B.toLazyText 451 | . intercalate "\n" 452 | . NE.toList 453 | . go contextNeedsBrackets 454 | where 455 | go :: Bool -> Value -> NonEmpty Builder 456 | go contextneedsBrackets val = 457 | bracketIf (contextneedsBrackets && requiresBrackets val) $ 458 | case val of 459 | Integral x -> simple $ addNumericUnderscores (Prelude.show x) 460 | Floating x -> simple $ Prelude.show x 461 | String x -> simple $ Prelude.show x 462 | Constr c ts xs -> renderComposite (compositeConstr c ts) $ 463 | map (go True) xs 464 | List xs -> renderComposite compositeList $ 465 | map (go False) xs 466 | Tuple xs -> renderComposite compositeTuple $ 467 | map (go False) xs 468 | Record r xs -> renderComposite (compositeHaskellRecord r) $ 469 | map (uncurry goField . second (go False)) xs 470 | QuasiQ qq str -> renderComposite (compositeQuasiQ qq) [str] 471 | JSON json -> go contextneedsBrackets $ QuasiQ "aesonQQ" $ 472 | renderJSON json 473 | PreludeShow x -> NE.fromList . map B.fromString $ 474 | lines (Prelude.showsPrec appPrec x "") 475 | 476 | simple :: String -> NonEmpty Builder 477 | simple = pure . B.fromString 478 | 479 | goField :: String -> NonEmpty Builder -> NonEmpty Builder 480 | goField field (firstLine :| rest) = 481 | (B.fromString field <> " = " <> firstLine) 482 | :| indent rest 483 | 484 | bracketIf :: Bool -> NonEmpty Builder -> NonEmpty Builder 485 | bracketIf False = id 486 | bracketIf True = \case 487 | oneLine :| [] -> ("(" <> oneLine <> ")") :| [] 488 | firstLine :| rest -> ("( " <> firstLine) :| concat [ 489 | indent rest 490 | , [")"] 491 | ] 492 | 493 | renderJSON :: Aeson.Value -> NonEmpty Builder 494 | renderJSON = go 495 | where 496 | go :: Aeson.Value -> NonEmpty Builder 497 | go (Aeson.Object xs) = renderComposite compositeJsonRecord $ 498 | map (uncurry goField . second go) $ 499 | Aeson.KeyMap.toList xs 500 | go (Aeson.Array xs) = renderComposite compositeList $ 501 | map go $ 502 | Vector.toList xs 503 | go val = Aeson.encodeToTextBuilder val :| [] 504 | 505 | goField :: Aeson.KeyMap.Key -> NonEmpty Builder -> NonEmpty Builder 506 | goField key (firstLine :| rest) = 507 | B.fromString (Prelude.show key) <> ": " <> firstLine 508 | :| map (" " <>) rest 509 | 510 | -- | Does this value require brackets when shown? 511 | -- 512 | -- Of course, these brackets will only be necessary if the context demands them. 513 | requiresBrackets :: Value -> Bool 514 | requiresBrackets = \case 515 | Constr _ ts xs -> not (null ts) || not (null xs) 516 | _otherwise -> False 517 | 518 | {------------------------------------------------------------------------------- 519 | Internal: rendering composite values 520 | -------------------------------------------------------------------------------} 521 | 522 | data Composite = Composite { 523 | -- | Header (e.g. record name, type applications, ..) 524 | compositeHeader :: Maybe Text 525 | 526 | -- | Prefix (e.g. @{@ or @(@) 527 | , compositePrefix :: Maybe Text 528 | 529 | -- | Suffix (e.g, @}@ or @)@) 530 | , compositeSuffix :: Maybe Text 531 | 532 | -- | Element separator (e.g. @,@) 533 | , compositeSeparator :: Char 534 | 535 | -- | Should elements be shown on one line? 536 | -- 537 | -- By default, this is true only if there is only a single element, 538 | -- and that element is itself only one line. 539 | , compositeOneLine :: [NonEmpty Builder] -> Maybe [Builder] 540 | } 541 | 542 | instance Default Composite where 543 | def = Composite { 544 | compositeHeader = Nothing 545 | , compositePrefix = Nothing 546 | , compositeSuffix = Nothing 547 | , compositeSeparator = ',' 548 | , compositeOneLine = \case 549 | [firstLine :| []] -> Just [firstLine] 550 | _otherwise -> Nothing 551 | } 552 | 553 | compositeList :: Composite 554 | compositeList = def { 555 | compositePrefix = Just "[" 556 | , compositeSuffix = Just "]" 557 | , compositeOneLine = \rs -> do 558 | xs <- mapM isOneLine rs 559 | 560 | let argLengths :: [Int64] 561 | argLengths = map (Text.Lazy.length . B.toLazyText) xs 562 | guard $ or [ 563 | sum argLengths < 80 564 | , all (<= 5) argLengths 565 | ] 566 | 567 | return xs 568 | } 569 | where 570 | isOneLine :: NonEmpty a -> Maybe a 571 | isOneLine (firstLine :| []) = Just firstLine 572 | isOneLine _otherwise = Nothing 573 | 574 | compositeTuple :: Composite 575 | compositeTuple = def { 576 | compositePrefix = Just "(" 577 | , compositeSuffix = Just ")" 578 | } 579 | 580 | compositeConstr :: Text -> [TypeRep] -> Composite 581 | compositeConstr c ts = def { 582 | compositeSeparator = ' ' 583 | , compositeHeader = Just $ intercalate " " $ c : map typeApp ts 584 | } 585 | where 586 | -- We are careful to insert brackets around the typerep if needed 587 | typeApp :: TypeRep -> Text 588 | typeApp typ = "@" <> Text.pack (Prelude.showsPrec appPrec typ []) 589 | 590 | compositeHaskellRecord :: Text -> Composite 591 | compositeHaskellRecord r = def { 592 | compositeHeader = Just $ r 593 | , compositePrefix = Just $ "{" 594 | , compositeSuffix = Just $ "}" 595 | , compositeOneLine = const Nothing 596 | } 597 | 598 | compositeJsonRecord :: Composite 599 | compositeJsonRecord = def { 600 | compositePrefix = Just $ "{" 601 | , compositeSuffix = Just $ "}" 602 | , compositeOneLine = const Nothing 603 | } 604 | 605 | compositeQuasiQ :: Text -> Composite 606 | compositeQuasiQ qq = def { 607 | compositePrefix = Just $ "[" <> qq <> "|" 608 | , compositeSuffix = Just $ "|]" 609 | } 610 | 611 | -- | Render composite value 612 | renderComposite :: Composite -> [NonEmpty Builder] -> NonEmpty Builder 613 | renderComposite Composite{..} = 614 | go 615 | where 616 | go :: [NonEmpty Builder] -> NonEmpty Builder 617 | go rs 618 | | Just xs <- compositeOneLine rs 619 | = pure $ mconcat [ 620 | prefix 621 | , intercalate (B.singleton compositeSeparator) xs 622 | , maybe mempty B.fromText compositeSuffix 623 | ] 624 | 625 | | otherwise 626 | = prefix 627 | :| concat [ 628 | concatMap NE.toList $ sepElemsBy compositeSeparator rs 629 | , [B.fromText suffix | Just suffix <- [compositeSuffix]] 630 | ] 631 | 632 | prefix :: Builder 633 | prefix = mconcat [ 634 | maybe mempty (\hdr -> B.fromText hdr <> " ") compositeHeader 635 | , maybe mempty B.fromText compositePrefix 636 | ] 637 | 638 | sepElemsBy :: Char -> [NonEmpty Builder] -> [NonEmpty Builder] 639 | sepElemsBy sep = zipWith aux (True : repeat False) 640 | where 641 | aux :: Bool -> NonEmpty Builder -> NonEmpty Builder 642 | aux firstEntry (firstLine :| rest) = 643 | ( if firstEntry 644 | then (B.singleton ' ' <> B.singleton ' ' <> firstLine) 645 | else (B.singleton sep <> B.singleton ' ' <> firstLine) 646 | ) 647 | :| indent rest 648 | 649 | {------------------------------------------------------------------------------- 650 | Rendering auxiliary 651 | -------------------------------------------------------------------------------} 652 | 653 | indent :: [Builder] -> [Builder] 654 | indent = map (B.fromText " " <>) 655 | 656 | addNumericUnderscores :: String -> String 657 | addNumericUnderscores = 658 | reverse 659 | . aux 660 | . reverse 661 | where 662 | aux :: String -> String 663 | aux str = 664 | case splitAt 3 str of 665 | (_ , [] ) -> str 666 | (firstThree , rest) -> firstThree ++ "_" ++ aux rest 667 | 668 | -- | Generation of @intercalate@ from the Prelude 669 | intercalate :: Monoid a => a -> [a] -> a 670 | intercalate x = mconcat . intersperse x -------------------------------------------------------------------------------- /src/Data/Structured/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Data.Structured.TH ( 4 | deriveInstance 5 | ) where 6 | 7 | import qualified Data.Structured as Structured 8 | import qualified Data.Text as Text 9 | 10 | import Language.Haskell.TH 11 | import Language.Haskell.TH.Datatype 12 | 13 | -- | Derive 'Show' instance 14 | -- 15 | -- Normally TH is not required, and you can rely on generics instead. However, 16 | -- in some cases TH is the only option; for example, this is the case when 17 | -- deriving a 'Show' instance for a GADT. 18 | -- 19 | -- Example usage: 20 | -- 21 | -- > Structured.deriveInstance 'ConstrOfMyType [t| 22 | -- > forall a. Structured.Show a => Structured.Show (MyType a) 23 | -- > |] 24 | -- 25 | -- All type variables must be explicitly quantified (use an empty forall if 26 | -- there are none), and any required constraints must be explicitly listed. In 27 | -- addition, one of the constructors of @MyType@ must be listed (this is used to 28 | -- resolve the datatype, ensuring that it works with regular datatypes as well 29 | -- as associated datatypes). 30 | deriveInstance :: Name -> Q Type -> Q [Dec] 31 | deriveInstance constr header = do 32 | info <- reifyDatatype constr 33 | (ctxt, rhs) <- parseHeader =<< header 34 | (:[]) <$> 35 | instanceD 36 | (return ctxt) 37 | (return rhs) 38 | [ funD 'Structured.toValue $ map caseFor (datatypeCons info) 39 | ] 40 | 41 | -- | Parse instance header 42 | parseHeader :: Type -> Q (Cxt, Type) 43 | parseHeader = \case 44 | ForallT _bndrs ctxt rhs@(AppT (ConT nameShow) _) 45 | | nameShow == ''Structured.Show 46 | -> return (ctxt, rhs) 47 | _otherwise -> 48 | fail $ "Invalid header" 49 | 50 | -- | Case for one of the constructors 51 | caseFor :: ConstructorInfo -> Q Clause 52 | caseFor ConstructorInfo{ 53 | constructorName = con 54 | , constructorFields = fields 55 | , constructorVariant = variant 56 | } = do 57 | args <- mapM (const $ newName "x") fields 58 | clause 59 | [conP con (map varP args)] 60 | ( normalB $ 61 | case variant of 62 | RecordConstructor fieldNames -> record fieldNames args 63 | _otherwise -> constr args 64 | ) 65 | [] 66 | where 67 | -- Regular (non-record) constructor 68 | constr :: [Name] -> ExpQ 69 | constr args = appsE [ 70 | conE 'Structured.Constr 71 | , varE 'Text.pack 72 | `appE` 73 | litE (StringL (nameBase con)) 74 | , listE [] -- We do not support any type applications 75 | , listE $ 76 | map 77 | (\x -> varE 'Structured.toValue `appE` varE x) 78 | args 79 | ] 80 | 81 | record :: [Name] -> [Name] -> ExpQ 82 | record fieldNames args = appsE [ 83 | conE 'Structured.Record 84 | , varE 'Text.pack 85 | `appE` 86 | litE (StringL (nameBase con)) 87 | , listE $ 88 | zipWith 89 | (\f x -> tupE [ 90 | litE (StringL (nameBase f)) 91 | , varE 'Structured.toValue `appE` varE x 92 | ] 93 | ) 94 | fieldNames 95 | args 96 | ] 97 | -------------------------------------------------------------------------------- /src/Foreign/Rust/External/Bincode.hs: -------------------------------------------------------------------------------- 1 | -- | External (Rust-side) Bincode serialisation/deserialisation 2 | -- 3 | -- Intended for qualified import. 4 | -- 5 | -- > import qualified Foreign.Rust.External.Bincode as External 6 | module Foreign.Rust.External.Bincode ( 7 | -- * Serialisation 8 | Bincode(..) 9 | , ToBincode(..) 10 | , FromBincode(..) 11 | ) where 12 | 13 | import Codec.Borsh 14 | 15 | import qualified Data.ByteString.Lazy as Lazy 16 | 17 | import Foreign.Rust.Serialisation.Raw 18 | 19 | {------------------------------------------------------------------------------- 20 | Serialisation 21 | -------------------------------------------------------------------------------} 22 | 23 | newtype Bincode = Bincode Lazy.ByteString 24 | deriving stock (Eq) 25 | deriving newtype (BorshSize, ToBorsh, FromBorsh) 26 | deriving newtype (IsRaw) 27 | 28 | -- | Types with an external Bincode serialiser (typically, in Rust) 29 | class ToBincode a where 30 | toBincode :: a -> Bincode 31 | 32 | -- | Types with an external Bincode deserialiser (typically, in Rust) 33 | class FromBincode a where 34 | fromBincode :: Bincode -> Either String a -------------------------------------------------------------------------------- /src/Foreign/Rust/External/JSON.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- | External (Rust-side) JSON serialisation/deserialisation 4 | -- 5 | -- Intended for qualified import. 6 | -- 7 | -- > import Foreign.Rust.External.JSON (UseExternalJSON, ShowAsJSON) 8 | -- > import qualified Foreign.Rust.External.JSON as External 9 | module Foreign.Rust.External.JSON ( 10 | -- * Serialisation 11 | JSON(..) 12 | , ToJSON(..) 13 | , FromJSON(..) 14 | -- * Deriving-via: derive Aeson instances using external (de)serialiser 15 | , UseExternalJSON(..) 16 | ) where 17 | 18 | import Codec.Borsh 19 | import Foreign.Rust.Failure 20 | import GHC.Stack 21 | 22 | import qualified Data.Aeson as Aeson 23 | import qualified Data.Aeson.Encoding as Aeson (unsafeToEncoding) 24 | import qualified Data.Aeson.Types as Aeson (parseFail) 25 | import qualified Data.Binary.Builder as Binary 26 | import qualified Data.ByteString.Lazy as Lazy (ByteString) 27 | import qualified Data.ByteString.Lazy.Char8 as Lazy.Char8 28 | 29 | {------------------------------------------------------------------------------- 30 | Serialisation 31 | -------------------------------------------------------------------------------} 32 | 33 | -- | Serialised JSON 34 | newtype JSON = JSON Lazy.ByteString 35 | deriving stock (Eq) 36 | deriving newtype (BorshSize, ToBorsh, FromBorsh) 37 | 38 | instance Show JSON where 39 | show (JSON bs) = Lazy.Char8.unpack bs 40 | 41 | -- | Types with a Rust-side JSON renderer 42 | class ToJSON a where 43 | toJSON :: a -> JSON 44 | 45 | -- | Types with a Rust-side JSON parser 46 | class FromJSON a where 47 | fromJSON :: HasCallStack => JSON -> Either Failure a 48 | 49 | {------------------------------------------------------------------------------- 50 | Deriving-via: derive Aeson instances using external (de)serialiser 51 | -------------------------------------------------------------------------------} 52 | 53 | newtype UseExternalJSON a = UseExternalJSON a 54 | 55 | instance ToJSON a => Aeson.ToJSON (UseExternalJSON a) where 56 | toJSON (UseExternalJSON x) = 57 | reparse (toJSON x) 58 | where 59 | -- We get serialised JSON from the external renderer, and then need to 60 | -- re-parse that to a 'Value'. If this fails, however, it would mean that 61 | -- the Rust-side generated invalid JSON. 62 | reparse :: JSON -> Aeson.Value 63 | reparse (JSON bs) = 64 | case Aeson.eitherDecode bs of 65 | Left err -> error err 66 | Right val -> val 67 | 68 | -- This relies on 'toJSON' generating valid JSON 69 | toEncoding (UseExternalJSON x) = 70 | case toJSON x of 71 | JSON bs -> Aeson.unsafeToEncoding $ Binary.fromLazyByteString bs 72 | 73 | instance FromJSON a => Aeson.FromJSON (UseExternalJSON a) where 74 | parseJSON val = 75 | case fromJSON (JSON (Aeson.encode val)) of 76 | Left failure -> Aeson.parseFail (show failure) 77 | Right tx -> return $ UseExternalJSON tx 78 | 79 | -------------------------------------------------------------------------------- /src/Foreign/Rust/Failure.hs: -------------------------------------------------------------------------------- 1 | module Foreign.Rust.Failure ( 2 | Failure -- Opaque 3 | , failureMessage 4 | , mkFailure 5 | , throwFailure 6 | , throwFailureIO 7 | ) where 8 | 9 | import Control.Exception 10 | import Data.Text (Text) 11 | import GHC.Stack 12 | 13 | -- | Failure reported by a Rust function 14 | -- 15 | -- TODO: For some cases we might be able to attach a Rust callstack, too. 16 | data Failure = Failure { 17 | failureMessage :: Text 18 | , failureCallstackHaskell :: PrettyCallStack 19 | } 20 | deriving stock (Show) 21 | deriving anyclass (Exception) 22 | 23 | mkFailure :: HasCallStack => Text -> Failure 24 | mkFailure e = Failure e (PrettyCallStack callStack) 25 | 26 | newtype PrettyCallStack = PrettyCallStack CallStack 27 | 28 | instance Show PrettyCallStack where 29 | show (PrettyCallStack stack) = prettyCallStack stack 30 | 31 | throwFailure :: Either Failure a -> a 32 | throwFailure (Left err) = throw err 33 | throwFailure (Right a) = a 34 | 35 | throwFailureIO :: Either Failure a -> IO a 36 | throwFailureIO (Left err) = throwIO err 37 | throwFailureIO (Right a) = return a -------------------------------------------------------------------------------- /src/Foreign/Rust/Marshall/External.hs: -------------------------------------------------------------------------------- 1 | -- | Marshall from a Rust-side allocated buffer 2 | -- 3 | -- Intended for unqualified import. 4 | module Foreign.Rust.Marshall.External ( 5 | fromExternalBorsh 6 | ) where 7 | 8 | import Codec.Borsh 9 | import Data.Typeable 10 | import Data.Word 11 | import Foreign.C 12 | import Foreign.Ptr 13 | 14 | import qualified Data.ByteString.Internal as Strict 15 | 16 | import Foreign.Rust.Marshall.Util 17 | import Foreign.ForeignPtr 18 | 19 | data ExternalBuffer 20 | 21 | {------------------------------------------------------------------------------- 22 | Foreign imports 23 | 24 | Although 'externalPtr' and 'externalLen' are morally pure, we make 25 | them live in IO to make reasoning about order of operations easier in 26 | 'fromExternalBorsh'. 27 | 28 | These C functions are defined in the companion Rust @haskell-ffi@ library. 29 | -------------------------------------------------------------------------------} 30 | 31 | foreign import ccall unsafe "haskell_ffi_external_ptr" 32 | externalPtr 33 | :: Ptr ExternalBuffer -> IO (Ptr Word8) 34 | 35 | foreign import ccall unsafe "haskell_ffi_external_len" 36 | externalLen 37 | :: Ptr ExternalBuffer -> IO CSize 38 | 39 | foreign import ccall unsafe "&haskell_ffi_external_free_env" 40 | externalFree 41 | :: FinalizerEnvPtr ExternalBuffer Word8 42 | 43 | {------------------------------------------------------------------------------- 44 | Internal auxiliary 45 | -------------------------------------------------------------------------------} 46 | 47 | -- | Cast pointer 48 | -- 49 | -- For ease of integration with c2hs, 'fromExternalBorsh' takes a @Ptr ()@ as 50 | -- input instead of the more accurate @Ptr ExternalBuffer@. 51 | castToExternal :: Ptr () -> Ptr ExternalBuffer 52 | castToExternal = castPtr 53 | 54 | {------------------------------------------------------------------------------- 55 | Public API 56 | -------------------------------------------------------------------------------} 57 | 58 | -- | Output marshaller for values stored in Rust-allocated buffer 59 | -- 60 | -- Should be used together with the Rust function @marshall_to_haskell_external@ 61 | -- (from @haskell-ffi@). 62 | fromExternalBorsh :: (FromBorsh a, Typeable a) => Ptr () -> IO a 63 | fromExternalBorsh (castToExternal -> vec) = do 64 | ptr <- externalPtr vec 65 | len <- fromIntegral <$> externalLen vec 66 | fptr <- newForeignPtrEnv externalFree vec ptr 67 | 68 | let bs :: Strict.ByteString 69 | bs = Strict.fromForeignPtr fptr 0 len 70 | 71 | return $ deserialiseStrictOrPanic bs 72 | 73 | -------------------------------------------------------------------------------- /src/Foreign/Rust/Marshall/Fixed.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-redundant-constraints #-} 2 | 3 | -- | Marshalling to and from Rust, using Borsh 4 | -- 5 | -- This module deals with types with fixed sized encodings. 6 | -- See also "Foreign.Rust.Marshall.Variable". 7 | module Foreign.Rust.Marshall.Fixed ( 8 | -- * Haskell to Rust 9 | toBorshFixed 10 | -- * Rust to Haskell 11 | , allocFixedBuffer 12 | , allocMaxBuffer 13 | , fromBorsh 14 | ) where 15 | 16 | import Codec.Borsh 17 | import Data.Proxy 18 | import Data.Typeable (Typeable) 19 | import Foreign 20 | import Foreign.C.Types 21 | 22 | import qualified Data.ByteString as Strict 23 | 24 | import Foreign.Rust.Marshall.Util 25 | 26 | {------------------------------------------------------------------------------- 27 | Haskell to Rust 28 | -------------------------------------------------------------------------------} 29 | 30 | toBorshFixed :: 31 | (ToBorsh a, StaticBorshSize a ~ 'HasKnownSize) 32 | => a -> ((Ptr CUChar, CULong) -> IO r) -> IO r 33 | toBorshFixed a k = 34 | Strict.useAsCStringLen (serialiseStrict a) (k . castFromSignedLen) 35 | 36 | {------------------------------------------------------------------------------- 37 | Rust to Haskell: exact size known 38 | -------------------------------------------------------------------------------} 39 | 40 | allocFixedBuffer :: forall a. 41 | (BorshSize a, StaticBorshSize a ~ 'HasKnownSize) 42 | => ((Ptr CUChar, CULong) -> IO a) -> IO a 43 | allocFixedBuffer k = 44 | case borshSize (Proxy @a) of 45 | SizeKnown n -> 46 | allocaBytes (cast n) $ \ptr -> k (ptr, fromIntegral n) 47 | where 48 | cast :: Word32 -> Int 49 | cast = fromIntegral 50 | 51 | allocMaxBuffer :: forall a. 52 | ( BorshSize a 53 | , StaticBorshSize a ~ 'HasVariableSize 54 | , BorshMaxSize a 55 | ) 56 | => ((Ptr CUChar, CULong) -> IO a) -> IO a 57 | allocMaxBuffer k = 58 | let n = borshMaxSize (Proxy @a) 59 | in allocaBytes (cast n) $ \ptr -> k (ptr, fromIntegral n) 60 | where 61 | cast :: Word32 -> Int 62 | cast = fromIntegral 63 | 64 | fromBorsh :: (FromBorsh a, Typeable a) => Ptr CUChar -> CULong -> IO a 65 | fromBorsh ptr len = 66 | deserialiseStrictOrPanic <$> 67 | Strict.packCStringLen (castToSigned ptr, fromIntegral len) 68 | 69 | -------------------------------------------------------------------------------- /src/Foreign/Rust/Marshall/Util.hs: -------------------------------------------------------------------------------- 1 | module Foreign.Rust.Marshall.Util ( 2 | -- * Borsh 3 | serialiseStrict 4 | , deserialiseStrictOrPanic 5 | , deserialiseLazyOrPanic 6 | -- * Casting 7 | , castFromSigned 8 | , castToSigned 9 | , castFromSignedLen 10 | ) where 11 | 12 | import Codec.Borsh 13 | import Data.Typeable 14 | import Foreign 15 | import Foreign.C 16 | import GHC.Stack 17 | 18 | import qualified Data.ByteString as Strict 19 | import qualified Data.ByteString.Lazy as Lazy 20 | 21 | {------------------------------------------------------------------------------- 22 | Borsh 23 | -------------------------------------------------------------------------------} 24 | 25 | serialiseStrict :: ToBorsh a => a -> Strict.ByteString 26 | serialiseStrict = Lazy.toStrict . serialiseBorsh 27 | 28 | deserialiseStrictOrPanic :: 29 | (HasCallStack, FromBorsh a, Typeable a) 30 | => Strict.ByteString -> a 31 | deserialiseStrictOrPanic = deserialiseLazyOrPanic . Lazy.fromStrict 32 | 33 | deserialiseLazyOrPanic :: forall a. 34 | (HasCallStack, FromBorsh a, Typeable a) 35 | => Lazy.ByteString -> a 36 | deserialiseLazyOrPanic bs = 37 | case deserialiseBorsh bs of 38 | Right a -> a 39 | Left err -> error $ concat [ 40 | "deserialiseLazyOrPanic for " ++ show (typeOf (Proxy @a)) ++ ": " 41 | , show err ++ "\n" 42 | , "buffer: " ++ show (Lazy.unpack bs) 43 | , " (" ++ show (Lazy.length bs) ++ ")" 44 | ] 45 | 46 | {------------------------------------------------------------------------------- 47 | Casting 48 | -------------------------------------------------------------------------------} 49 | 50 | castFromSigned :: Ptr CChar -> Ptr CUChar 51 | castFromSigned = castPtr 52 | 53 | castToSigned :: Ptr CUChar -> Ptr CChar 54 | castToSigned = castPtr 55 | 56 | castFromSignedLen :: (Ptr CChar, Int) -> (Ptr CUChar, CULong) 57 | castFromSignedLen (ptr, len) = (castFromSigned ptr, fromIntegral len) 58 | 59 | -------------------------------------------------------------------------------- /src/Foreign/Rust/Marshall/Variable.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-redundant-constraints #-} 2 | 3 | -- | Marshalling to and from Rust, using Borsh 4 | -- 5 | -- This module deals with types with variable sized encodings. 6 | -- See also "Foreign.Rust.Marshall.Fixed". 7 | module Foreign.Rust.Marshall.Variable ( 8 | -- * Haskell to Rust 9 | toBorshVar 10 | -- * Rust to Haskell 11 | , Buffer -- opaque 12 | , getVarBuffer 13 | , withBorshVarBuffer 14 | , withBorshBufferOfInitSize 15 | -- ** Pure variants 16 | , withPureBorshVarBuffer 17 | ) where 18 | 19 | import Codec.Borsh 20 | import Data.Typeable 21 | import Foreign 22 | import Foreign.C.Types 23 | import System.IO.Unsafe (unsafePerformIO) 24 | 25 | import qualified Data.ByteString as Strict 26 | 27 | import Foreign.Rust.Marshall.Util 28 | 29 | {------------------------------------------------------------------------------- 30 | Haskell to Rust 31 | -------------------------------------------------------------------------------} 32 | 33 | toBorshVar :: 34 | (ToBorsh a, StaticBorshSize a ~ 'HasVariableSize) 35 | => a -> ((Ptr CUChar, CULong) -> IO r) -> IO r 36 | toBorshVar a k = 37 | Strict.useAsCStringLen (serialiseStrict a) (k . castFromSignedLen) 38 | 39 | {------------------------------------------------------------------------------- 40 | Rust to Haskell 41 | -------------------------------------------------------------------------------} 42 | 43 | -- | Buffer containing value of (phantom) type @a@ 44 | data Buffer a = Buffer (Ptr CUChar) (Ptr CULong) 45 | 46 | getVarBuffer :: Buffer a -> (Ptr CUChar, Ptr CULong) 47 | getVarBuffer (Buffer buf ptrSize) = (buf, ptrSize) 48 | 49 | -- | Provide buffer for foreign call 50 | -- 51 | -- We start with an initial buffer of 1 kB. If that suffices, we copy the 52 | -- (appropriate part of) the buffer to a ByteString and we're done. If not, 53 | -- the foreign call will tell us what the required buffer size is, so we 54 | -- try again with a larger buffer. 55 | -- 56 | -- We allocate these buffers on the Haskell heap ('allocaBytes'), not the C 57 | -- heap ('malloc'). This ensures that these buffers are visible to Haskell 58 | -- profiling tools, and also appears to be more reliable on OSX. A slight 59 | -- downside is that it doesn't give us a way to /change/ the size of a buffer, 60 | -- but that's not an essential feature. 61 | withBorshVarBuffer :: forall a. 62 | ( FromBorsh a 63 | , StaticBorshSize a ~ 'HasVariableSize 64 | , Typeable a 65 | ) 66 | => (Buffer a -> IO ()) -> IO a 67 | withBorshVarBuffer = withBorshBufferOfInitSize 1024 68 | 69 | {------------------------------------------------------------------------------- 70 | Pure variants 71 | -------------------------------------------------------------------------------} 72 | 73 | withPureBorshVarBuffer :: forall a. 74 | ( FromBorsh a 75 | , StaticBorshSize a ~ 'HasVariableSize 76 | , Typeable a 77 | ) 78 | => (Buffer a -> IO ()) -> a 79 | withPureBorshVarBuffer = unsafePerformIO . withBorshVarBuffer 80 | 81 | {------------------------------------------------------------------------------- 82 | Generalization 83 | -------------------------------------------------------------------------------} 84 | 85 | -- | Variation on 'withBorshVarBuffer' with user-specified initial buffer size 86 | withBorshBufferOfInitSize :: forall a. 87 | ( FromBorsh a 88 | , StaticBorshSize a ~ 'HasVariableSize 89 | , Typeable a 90 | ) 91 | => CULong -> (Buffer a -> IO ()) -> IO a 92 | withBorshBufferOfInitSize initBufSize f = do 93 | mFirstAttempt <- allocaBytes (culongToInt initBufSize) $ \buf -> do 94 | (bigEnough, reqSz) <- callWithSize buf initBufSize 95 | if bigEnough then 96 | Right . deserialiseStrictOrPanic <$> 97 | Strict.packCStringLen (castPtr buf, culongToInt reqSz) 98 | else 99 | return $ Left reqSz 100 | case mFirstAttempt of 101 | Right r -> 102 | return r 103 | Left reqSz -> do 104 | allocaBytes (culongToInt reqSz) $ \buf -> do 105 | (bigEnough, reqSz') <- callWithSize buf reqSz 106 | if bigEnough && reqSz == reqSz' then 107 | deserialiseStrictOrPanic <$> 108 | Strict.packCStringLen (castPtr buf, culongToInt reqSz) 109 | else 110 | fail $ concat [ 111 | "withBorshVarBuffer: unexpected change in required buffer size. " 112 | , "was " ++ show reqSz ++ ", " 113 | , "now " ++ show reqSz' ++ "." 114 | ] 115 | where 116 | -- Call the function with the current buffer size 117 | -- Returns whether or not the buffer was big enough, and the required size 118 | callWithSize :: Ptr CUChar -> CULong -> IO (Bool, CULong) 119 | callWithSize buf providedSize = alloca $ \ptrBufSize -> do 120 | poke ptrBufSize providedSize 121 | f $ Buffer buf ptrBufSize 122 | requiredSize <- peek ptrBufSize 123 | return (requiredSize <= providedSize, requiredSize) 124 | 125 | -- Buffer allocations should not take a signed 'Int' as argument 🙄 126 | culongToInt :: CULong -> Int 127 | culongToInt = fromIntegral 128 | -------------------------------------------------------------------------------- /src/Foreign/Rust/SafeConv.hs: -------------------------------------------------------------------------------- 1 | module Foreign.Rust.SafeConv ( 2 | SafeConv(..) 3 | ) where 4 | 5 | import Data.Word 6 | import Foreign.C.Types 7 | 8 | class SafeConv a b where 9 | safeConvFrom :: a -> b 10 | safeConvTo :: b -> a 11 | 12 | instance SafeConv CULong Word64 where 13 | safeConvFrom = fromIntegral 14 | safeConvTo = fromIntegral 15 | 16 | instance SafeConv CULLong Word64 where 17 | safeConvFrom = fromIntegral 18 | safeConvTo = fromIntegral 19 | -------------------------------------------------------------------------------- /src/Foreign/Rust/Serialisation/JSON.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- | Serialise opaque types using JSON 4 | -- 5 | -- See "Foreign.Rust.Serialisation.Raw" for detailed discussion. 6 | module Foreign.Rust.Serialisation.JSON ( 7 | -- * Deriving-via support 8 | AsJSON(..) 9 | -- * Show instance 10 | , asJSON 11 | ) where 12 | 13 | import Data.Annotated 14 | import Data.Aeson (FromJSON(..)) 15 | import Data.Typeable 16 | 17 | import qualified Data.Aeson.Types as Aeson 18 | import qualified Data.Structured as Structured 19 | 20 | {------------------------------------------------------------------------------- 21 | Deriving-via combinator 22 | -------------------------------------------------------------------------------} 23 | 24 | -- | Serialise using JSON 25 | -- 26 | -- The 'Show' instance will produce something like 27 | -- 28 | -- > asJSON @UsesJSON 29 | -- > [aesonQQ| 30 | -- > { 31 | -- > "a": null 32 | -- > , "b": [1,2,3] 33 | -- > } 34 | -- > |] 35 | -- 36 | -- This depends on 'asJSON' (defined in this module), @QuasiQuotes@ and 37 | -- "Data.Aeson.QQ.Simple". 38 | -- 39 | -- NOTE: 'Annotated' instance is only useful when using 'AsBase64' directly 40 | -- (rather than using deriving-via). 41 | newtype AsJSON a = AsJSON { unwrapAsJSON :: a } 42 | deriving newtype CanAnnotate 43 | 44 | {------------------------------------------------------------------------------- 45 | Show 46 | -------------------------------------------------------------------------------} 47 | 48 | deriving 49 | via Structured.ToPreludeShow (AsJSON a) 50 | instance (Typeable a, Aeson.ToJSON a) => Show (AsJSON a) 51 | 52 | instance (Typeable a, Aeson.ToJSON a) => Structured.Show (AsJSON a) where 53 | toValue (AsJSON x) = 54 | Structured.Constr "asJSON" [typeRep (Proxy @a)] [ 55 | Structured.JSON (Aeson.toJSON x) 56 | ] 57 | 58 | asJSON :: forall a. FromJSON a => Aeson.Value -> a 59 | asJSON = either error id . Aeson.parseEither Aeson.parseJSON 60 | -------------------------------------------------------------------------------- /src/Foreign/Rust/Serialisation/Raw.hs: -------------------------------------------------------------------------------- 1 | -- | Dealing with types that are represented in raw form Haskell side 2 | module Foreign.Rust.Serialisation.Raw ( 3 | IsRaw(..) 4 | ) where 5 | 6 | import Data.FixedSizeArray (FixedSizeArray) 7 | import Data.Proxy 8 | import Data.Word 9 | import GHC.TypeLits 10 | 11 | import qualified Data.ByteString as Strict 12 | import qualified Data.ByteString.Lazy as Lazy 13 | import qualified Data.FixedSizeArray as FSA 14 | import qualified Data.Vector.Generic as Vector 15 | 16 | {------------------------------------------------------------------------------- 17 | Abstract over raw representation 18 | -------------------------------------------------------------------------------} 19 | 20 | -- | Datatype that is represented as raw bytes Haskell-side 21 | -- 22 | -- Sometimes when dealing with Rust-side values we represent them as opaque 23 | -- values Haskell side: essentially just a list of bytes. However, we typically 24 | -- still want to be able to display, serialise and deserialise such values. 25 | -- 26 | -- 'IsRaw' abstracts over how exactly those raw bytes stored; in the following 27 | -- modules we then provide deriving-via combinators for specific encodings: 28 | -- 29 | -- * Foreign.Rust.Serialisation.Raw.Base16 (base-16, hexadecimal, hexdump) 30 | -- * Foreign.Rust.Serialisation.Raw.Base58 (base-58, bitcoin format) 31 | -- * Foreign.Rust.Serialisation.Raw.Base64 (base-64) 32 | -- * Foreign.Rust.Serialisation.Raw.Decimal (list of decimal values) 33 | -- 34 | -- All of these modules provide combinators to derive 35 | -- 36 | -- * 'Prelude.Show' and 'Data.Structured.Show' (law-abiding in the sense of 37 | -- generating valid Haskell) 38 | -- * 'FromJSON' and 'ToJSON' 39 | -- 40 | -- All of these modules show the raw bytes, they just differ in /how/ they show 41 | -- those raw bytes. If you want a more human-readable format, consider using 42 | -- "Foreign.Rust.Serialisation.JSON". 43 | class IsRaw a where 44 | {-# MINIMAL (toRaw | toBytes), (fromRaw | fromBytes) #-} 45 | 46 | -- rawSize 47 | 48 | rawSize :: a -> Word32 49 | rawSize = fromIntegral . Lazy.length . toRaw 50 | 51 | -- toRaw 52 | 53 | toRaw :: a -> Lazy.ByteString 54 | toRaw = Lazy.pack . toBytes 55 | 56 | toBytes :: a -> [Word8] 57 | toBytes = Lazy.unpack . toRaw 58 | 59 | -- fromRaw 60 | 61 | fromRaw :: Lazy.ByteString -> Either String a 62 | fromRaw = fromBytes . Lazy.unpack 63 | 64 | fromBytes :: [Word8] -> Either String a 65 | fromBytes = fromRaw . Lazy.pack 66 | 67 | 68 | {------------------------------------------------------------------------------- 69 | ByteString 70 | -------------------------------------------------------------------------------} 71 | 72 | instance IsRaw Lazy.ByteString where 73 | rawSize = fromIntegral . Lazy.length 74 | toRaw = id 75 | fromRaw = Right 76 | 77 | instance IsRaw Strict.ByteString where 78 | rawSize = fromIntegral . Strict.length 79 | toRaw = Lazy.fromStrict 80 | fromRaw = Right . Lazy.toStrict 81 | 82 | {------------------------------------------------------------------------------- 83 | [Word8] 84 | -------------------------------------------------------------------------------} 85 | 86 | instance IsRaw [Word8] where 87 | rawSize = fromIntegral . length 88 | toBytes = id 89 | fromBytes = Right 90 | 91 | {------------------------------------------------------------------------------- 92 | FixedSizeArray 93 | -------------------------------------------------------------------------------} 94 | 95 | instance KnownNat n => IsRaw (FixedSizeArray n Word8) where 96 | rawSize = const $ fromIntegral $ natVal (Proxy @n) 97 | toBytes = Vector.toList 98 | fromBytes = \xs -> 99 | let expectedSize, actualSize :: Int 100 | expectedSize = fromIntegral $ natVal (Proxy @n) 101 | actualSize = length xs 102 | in if actualSize == expectedSize 103 | then Right $ FSA.fromList xs 104 | else Left $ "Expected " ++ show expectedSize ++ "bytes, " 105 | ++ "but got " ++ show actualSize ++ ": " 106 | ++ show xs 107 | 108 | -------------------------------------------------------------------------------- /src/Foreign/Rust/Serialisation/Raw/Base16.hs: -------------------------------------------------------------------------------- 1 | -- | Base-16 encoding (hexdump) 2 | -- 3 | -- See "Foreign.Rust.Serialisation.Raw" for discussion. 4 | module Foreign.Rust.Serialisation.Raw.Base16 ( 5 | -- * Deriving-via support 6 | AsBase16(..) 7 | ) where 8 | 9 | import Control.Monad 10 | import Data.Aeson (ToJSON(..), FromJSON(..), withText) 11 | import Data.Annotated 12 | import Data.String 13 | 14 | import qualified Data.Aeson.Types as Aeson 15 | import qualified Data.ByteString.Base16.Lazy as Base16 16 | import qualified Data.ByteString.Lazy as Lazy 17 | import qualified Data.ByteString.Lazy.Char8 as Char8 18 | import qualified Data.Structured as Structured 19 | import qualified Data.Text as Text 20 | 21 | import Foreign.Rust.Serialisation.Raw 22 | 23 | {------------------------------------------------------------------------------- 24 | Deriving-via combinator 25 | -------------------------------------------------------------------------------} 26 | 27 | -- | Show values in base-16 (hexadecimal/hexdump) 28 | -- 29 | -- The 'Show' instance will produce something like 30 | -- 31 | -- > "01020304" 32 | -- 33 | -- This depends on @OverloadedStrings@. 34 | -- 35 | -- NOTE: 'Annotated' instance is only useful when using 'AsBase16' directly 36 | -- (rather than using deriving-via). 37 | newtype AsBase16 a = AsBase16 { unwrapAsBase16 ::a } 38 | deriving newtype CanAnnotate 39 | 40 | {------------------------------------------------------------------------------- 41 | JSON 42 | -------------------------------------------------------------------------------} 43 | 44 | instance IsRaw a => ToJSON (AsBase16 a) where 45 | toJSON = toJSON . encode . unwrapAsBase16 46 | 47 | instance IsRaw a => FromJSON (AsBase16 a) where 48 | parseJSON = either Aeson.parseFail (return . AsBase16) . decode <=< parseJSON 49 | 50 | {------------------------------------------------------------------------------- 51 | Show 52 | -------------------------------------------------------------------------------} 53 | 54 | instance IsRaw a => Show (AsBase16 a) where 55 | show = show . encode . unwrapAsBase16 56 | 57 | instance IsRaw a => Structured.Show (AsBase16 a) where 58 | toValue = Structured.toValue . encode . unwrapAsBase16 59 | 60 | instance IsRaw a => IsString (AsBase16 a) where 61 | fromString = either error AsBase16 . decode . fromString 62 | 63 | {------------------------------------------------------------------------------- 64 | Auxiliary: base-16 encoded value 65 | -------------------------------------------------------------------------------} 66 | 67 | newtype Base16 = Base16 { getBase16 :: Lazy.ByteString } 68 | deriving newtype (Show, IsString) 69 | 70 | instance ToJSON Base16 where 71 | toJSON = Aeson.String . Text.pack . Char8.unpack . getBase16 72 | 73 | instance FromJSON Base16 where 74 | parseJSON = withText "Base16" $ return . Base16 . Char8.pack . Text.unpack 75 | 76 | instance Structured.Show Base16 where 77 | toValue = Structured.String 78 | 79 | encode :: IsRaw a => a -> Base16 80 | encode = Base16 . Base16.encode . toRaw 81 | 82 | decode :: IsRaw a => Base16 -> Either String a 83 | decode = fromRaw <=< Base16.decode . getBase16 84 | -------------------------------------------------------------------------------- /src/Foreign/Rust/Serialisation/Raw/Base58.hs: -------------------------------------------------------------------------------- 1 | -- | Base-58 encoding 2 | -- 3 | -- See "Foreign.Rust.Serialisation.Raw" for discussion. 4 | module Foreign.Rust.Serialisation.Raw.Base58 ( 5 | -- * Deriving-via support 6 | AsBase58(..) 7 | ) where 8 | 9 | import Control.Monad 10 | import Data.Aeson (ToJSON(..), FromJSON(..), withText) 11 | import Data.Annotated 12 | import Data.String 13 | 14 | import qualified Data.Aeson.Types as Aeson 15 | import qualified Data.ByteString as Strict 16 | import qualified Data.ByteString.Base58 as Base58 17 | import qualified Data.ByteString.Char8 as Char8 18 | import qualified Data.ByteString.Lazy as Lazy 19 | import qualified Data.Structured as Structured 20 | import qualified Data.Text as Text 21 | 22 | import Foreign.Rust.Serialisation.Raw 23 | 24 | {------------------------------------------------------------------------------- 25 | Deriving-via combinator 26 | -------------------------------------------------------------------------------} 27 | 28 | -- | Serialise using base-58 29 | -- 30 | -- The 'Show' instance will produce something like 31 | -- 32 | -- > "2VfUX" 33 | -- 34 | -- This depends on @OverloadedStrings@. 35 | -- 36 | -- NOTE: 'Annotated' instance is only useful when using 'AsBase58' directly 37 | -- (rather than using deriving-via). 38 | newtype AsBase58 a = AsBase58 { unwrapAsBase58 :: a } 39 | deriving newtype CanAnnotate 40 | 41 | {------------------------------------------------------------------------------- 42 | JSON 43 | -------------------------------------------------------------------------------} 44 | 45 | instance IsRaw a => ToJSON (AsBase58 a) where 46 | toJSON = toJSON . encode . unwrapAsBase58 47 | 48 | instance IsRaw a => FromJSON (AsBase58 a) where 49 | parseJSON = either Aeson.parseFail (return . AsBase58) . decode <=< parseJSON 50 | 51 | {------------------------------------------------------------------------------- 52 | Show 53 | -------------------------------------------------------------------------------} 54 | 55 | instance IsRaw a => Show (AsBase58 a) where 56 | show = show . encode . unwrapAsBase58 57 | 58 | instance IsRaw a => Structured.Show (AsBase58 a) where 59 | toValue = Structured.toValue . encode . unwrapAsBase58 60 | 61 | instance IsRaw a => IsString (AsBase58 a) where 62 | fromString = either error AsBase58 . decode . fromString 63 | 64 | {------------------------------------------------------------------------------- 65 | Auxiliary: base-58 encoded value 66 | -------------------------------------------------------------------------------} 67 | 68 | -- | Base58-encoded value 69 | -- 70 | -- NOTE: base-58 is a relatively expensive encoding; in particular, unlike 71 | -- base-64, base-58 does not make it very easy to process chunks of data 72 | -- separately. Ideally, it should therefore only be used for a small pieces of 73 | -- data. For this reason, we use a strict bytestring here. 74 | newtype Base58 = Base58 { getBase58 :: Strict.ByteString } 75 | deriving newtype (Show, IsString) 76 | 77 | instance ToJSON Base58 where 78 | toJSON = Aeson.String . Text.pack . Char8.unpack . getBase58 79 | 80 | instance FromJSON Base58 where 81 | parseJSON = withText "Base58" $ return . Base58 . Char8.pack . Text.unpack 82 | 83 | instance Structured.Show Base58 where 84 | toValue = Structured.String 85 | 86 | encode :: IsRaw a => a -> Base58 87 | encode = Base58 . encodeBitcoin . Lazy.toStrict . toRaw 88 | 89 | decode :: IsRaw a => Base58 -> Either String a 90 | decode = fromRaw <=< fmap Lazy.fromStrict . decodeBitcoin . getBase58 91 | 92 | {------------------------------------------------------------------------------- 93 | Internal auxiliary 94 | -------------------------------------------------------------------------------} 95 | 96 | encodeBitcoin :: Strict.ByteString -> Strict.ByteString 97 | encodeBitcoin = Base58.encodeBase58 Base58.bitcoinAlphabet 98 | 99 | decodeBitcoin :: Strict.ByteString -> Either String Strict.ByteString 100 | decodeBitcoin = 101 | maybe (Left "invalid Base58 encoding") Right 102 | . Base58.decodeBase58 Base58.bitcoinAlphabet 103 | -------------------------------------------------------------------------------- /src/Foreign/Rust/Serialisation/Raw/Base64.hs: -------------------------------------------------------------------------------- 1 | -- | Base-64 encoding 2 | -- 3 | -- See "Foreign.Rust.Serialisation.Raw" for discussion. 4 | module Foreign.Rust.Serialisation.Raw.Base64 ( 5 | -- * Deriving-via support 6 | AsBase64(..) 7 | ) where 8 | 9 | import Control.Monad 10 | import Data.Aeson (ToJSON(..), FromJSON(..), withText) 11 | import Data.Annotated 12 | import Data.String 13 | 14 | import qualified Data.Aeson.Types as Aeson 15 | import qualified Data.ByteString.Base64.Lazy as Base64 16 | import qualified Data.ByteString.Lazy as Lazy 17 | import qualified Data.ByteString.Lazy.Char8 as Char8 18 | import qualified Data.Structured as Structured 19 | import qualified Data.Text as Text 20 | 21 | import Foreign.Rust.Serialisation.Raw 22 | 23 | {------------------------------------------------------------------------------- 24 | Deriving-via combinator 25 | -------------------------------------------------------------------------------} 26 | 27 | -- | Serialise using base-64 28 | -- 29 | -- The 'Show' instance will produce something like 30 | -- 31 | -- > "AQIDBA==" 32 | -- 33 | -- This depends on @OverloadedStrings@. 34 | -- 35 | -- NOTE: 'Annotated' instance is only useful when using 'AsBase64' directly 36 | -- (rather than using deriving-via). 37 | newtype AsBase64 a = AsBase64 { unwrapAsBase64 :: a } 38 | deriving newtype CanAnnotate 39 | 40 | {------------------------------------------------------------------------------- 41 | JSON 42 | -------------------------------------------------------------------------------} 43 | 44 | instance IsRaw a => ToJSON (AsBase64 a) where 45 | toJSON = toJSON . encode . unwrapAsBase64 46 | 47 | instance IsRaw a => FromJSON (AsBase64 a) where 48 | parseJSON = either Aeson.parseFail (return . AsBase64) . decode <=< parseJSON 49 | 50 | {------------------------------------------------------------------------------- 51 | Show 52 | -------------------------------------------------------------------------------} 53 | 54 | instance IsRaw a => Show (AsBase64 a) where 55 | show = show . encode . unwrapAsBase64 56 | 57 | instance IsRaw a => Structured.Show (AsBase64 a) where 58 | toValue = Structured.toValue . encode . unwrapAsBase64 59 | 60 | instance IsRaw a => IsString (AsBase64 a) where 61 | fromString = either error AsBase64 . decode . fromString 62 | 63 | {------------------------------------------------------------------------------- 64 | Auxiliary: base-64 encoded value 65 | -------------------------------------------------------------------------------} 66 | 67 | newtype Base64 = Base64 { getBase64 :: Lazy.ByteString } 68 | deriving newtype (Show, IsString) 69 | 70 | instance ToJSON Base64 where 71 | toJSON = Aeson.String . Text.pack . Char8.unpack . getBase64 72 | 73 | instance FromJSON Base64 where 74 | parseJSON = withText "Base64" $ return . Base64 . Char8.pack . Text.unpack 75 | 76 | instance Structured.Show Base64 where 77 | toValue = Structured.String 78 | 79 | encode :: IsRaw a => a -> Base64 80 | encode = Base64 . Base64.encode . toRaw 81 | 82 | decode :: IsRaw a => Base64 -> Either String a 83 | decode = fromRaw <=< Base64.decode . getBase64 84 | -------------------------------------------------------------------------------- /src/Foreign/Rust/Serialisation/Raw/Decimal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- | List of decimal values 4 | -- 5 | -- See "Foreign.Rust.Serialisation.Raw" for discussion. 6 | module Foreign.Rust.Serialisation.Raw.Decimal ( 7 | -- * Deriving-via support 8 | AsDecimal(..) 9 | -- * Show instance 10 | , asDecimal 11 | ) where 12 | 13 | import Control.Monad 14 | import Data.Aeson 15 | import Data.Aeson.Types 16 | import Data.Typeable 17 | import Data.Word 18 | 19 | import qualified Data.Structured as Structured 20 | 21 | import Foreign.Rust.Serialisation.Raw 22 | 23 | {------------------------------------------------------------------------------- 24 | Deriving-via combinator 25 | -------------------------------------------------------------------------------} 26 | 27 | -- | Serialise to list of decimal values 28 | -- 29 | -- The 'Show' instance will produce something like 30 | -- 31 | -- > asDecimal @MyType [1,2,3,4] 32 | -- 33 | -- This depends on 'asDecimal' (defined in this module). 34 | newtype AsDecimal a = AsDecimal { unwrapAsDecimal :: a } 35 | 36 | {------------------------------------------------------------------------------- 37 | JSON 38 | -------------------------------------------------------------------------------} 39 | 40 | instance IsRaw a => ToJSON (AsDecimal a) where 41 | toJSON = toJSON . toBytes . unwrapAsDecimal 42 | 43 | instance IsRaw a => FromJSON (AsDecimal a) where 44 | parseJSON = either parseFail (return . AsDecimal) . fromBytes <=< parseJSON 45 | 46 | {------------------------------------------------------------------------------- 47 | Show 48 | -------------------------------------------------------------------------------} 49 | 50 | deriving 51 | via Structured.ToPreludeShow (AsDecimal a) 52 | instance (Typeable a, IsRaw a) => Show (AsDecimal a) 53 | 54 | instance (Typeable a, IsRaw a) => Structured.Show (AsDecimal a) where 55 | toValue (AsDecimal x) = 56 | Structured.Constr "asDecimal" [typeRep (Proxy @a)] [ 57 | Structured.toValue (toBytes x) 58 | ] 59 | 60 | asDecimal :: IsRaw a => [Word8] -> a 61 | asDecimal = either error id . fromBytes -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Test.Tasty 4 | 5 | import qualified Test.Serialisation.JSON 6 | import qualified Test.Serialisation.Raw.Base16 7 | import qualified Test.Serialisation.Raw.Base58 8 | import qualified Test.Serialisation.Raw.Base64 9 | import qualified Test.Serialisation.Raw.Decimal 10 | 11 | main :: IO () 12 | main = defaultMain $ testGroup "foreign-rust" [ 13 | Test.Serialisation.JSON.tests 14 | , Test.Serialisation.Raw.Base16.tests 15 | , Test.Serialisation.Raw.Base58.tests 16 | , Test.Serialisation.Raw.Base64.tests 17 | , Test.Serialisation.Raw.Decimal.tests 18 | ] -------------------------------------------------------------------------------- /test/Test/Serialisation/JSON.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Test.Serialisation.JSON (tests) where 4 | 5 | import Test.Tasty 6 | import Test.Tasty.HUnit 7 | 8 | import Test.Serialisation.Types 9 | import Test.Util.TH 10 | 11 | import Foreign.Rust.Serialisation.JSON (asJSON) 12 | 13 | tests :: TestTree 14 | tests = testGroup "Test.Serialisation.JSON" [ 15 | testCase "show" test_show 16 | , testCase "structured" test_structured 17 | ] 18 | 19 | test_show :: Assertion 20 | test_show = 21 | assertEqual "" exampleUsesJSON $ 22 | $(reparseShow exampleUsesJSON) 23 | 24 | test_structured :: Assertion 25 | test_structured = 26 | assertEqual "" exampleUsesJSON $ 27 | $(reparseStructured exampleUsesJSON) 28 | -------------------------------------------------------------------------------- /test/Test/Serialisation/Raw/Base16.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Test.Serialisation.Raw.Base16 (tests) where 4 | 5 | import Test.Tasty 6 | import Test.Tasty.HUnit 7 | 8 | import qualified Data.Aeson as Aeson 9 | 10 | import Test.Serialisation.Types 11 | import Test.Util.TH 12 | 13 | tests :: TestTree 14 | tests = testGroup "Test.Serialisation.Raw.Base16" [ 15 | testCase "show" test_show 16 | , testCase "structured" test_structured 17 | , testCase "json" test_json 18 | ] 19 | 20 | test_show :: Assertion 21 | test_show = 22 | assertEqual "" exampleUsesBase16 $ 23 | $(reparseShow exampleUsesBase16) 24 | 25 | test_structured :: Assertion 26 | test_structured = 27 | assertEqual "" exampleUsesBase16 $ 28 | $(reparseStructured exampleUsesBase16) 29 | 30 | test_json :: Assertion 31 | test_json = 32 | assertEqual "" (Right exampleUsesBase16) $ 33 | Aeson.eitherDecode $ Aeson.encode exampleUsesBase16 -------------------------------------------------------------------------------- /test/Test/Serialisation/Raw/Base58.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Test.Serialisation.Raw.Base58 (tests) where 4 | 5 | import Test.Tasty 6 | import Test.Tasty.HUnit 7 | 8 | import qualified Data.Aeson as Aeson 9 | 10 | import Test.Serialisation.Types 11 | import Test.Util.TH 12 | 13 | tests :: TestTree 14 | tests = testGroup "Test.Serialisation.Raw.Base58" [ 15 | testCase "show" test_show 16 | , testCase "structured" test_structured 17 | , testCase "json" test_json 18 | ] 19 | 20 | test_show :: Assertion 21 | test_show = 22 | assertEqual "" exampleUsesBase58 $ 23 | $(reparseShow exampleUsesBase58) 24 | 25 | test_structured :: Assertion 26 | test_structured = 27 | assertEqual "" exampleUsesBase58 $ 28 | $(reparseStructured exampleUsesBase58) 29 | 30 | test_json :: Assertion 31 | test_json = 32 | assertEqual "" (Right exampleUsesBase58) $ 33 | Aeson.eitherDecode $ Aeson.encode exampleUsesBase58 -------------------------------------------------------------------------------- /test/Test/Serialisation/Raw/Base64.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Test.Serialisation.Raw.Base64 (tests) where 4 | 5 | import Test.Tasty 6 | import Test.Tasty.HUnit 7 | 8 | import qualified Data.Aeson as Aeson 9 | 10 | import Test.Serialisation.Types 11 | import Test.Util.TH 12 | 13 | tests :: TestTree 14 | tests = testGroup "Test.Serialisation.Raw.Base64" [ 15 | testCase "show" test_show 16 | , testCase "structured" test_structured 17 | , testCase "json" test_json 18 | ] 19 | 20 | test_show :: Assertion 21 | test_show = 22 | assertEqual "" exampleUsesBase64 $ 23 | $(reparseShow exampleUsesBase64) 24 | 25 | test_structured :: Assertion 26 | test_structured = 27 | assertEqual "" exampleUsesBase64 $ 28 | $(reparseStructured exampleUsesBase64) 29 | 30 | test_json :: Assertion 31 | test_json = 32 | assertEqual "" (Right exampleUsesBase64) $ 33 | Aeson.eitherDecode $ Aeson.encode exampleUsesBase64 -------------------------------------------------------------------------------- /test/Test/Serialisation/Raw/Decimal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Test.Serialisation.Raw.Decimal (tests) where 4 | 5 | import Test.Tasty 6 | import Test.Tasty.HUnit 7 | 8 | import qualified Data.Aeson as Aeson 9 | 10 | import Test.Serialisation.Types 11 | import Test.Util.TH 12 | 13 | import Foreign.Rust.Serialisation.Raw.Decimal (asDecimal) 14 | 15 | tests :: TestTree 16 | tests = testGroup "Test.Serialisation.Raw.Decimal" [ 17 | testCase "show" test_show 18 | , testCase "structured" test_structured 19 | , testCase "json" test_json 20 | ] 21 | 22 | test_show :: Assertion 23 | test_show = 24 | assertEqual "" exampleUsesDecimal $ 25 | $(reparseShow exampleUsesDecimal) 26 | 27 | test_structured :: Assertion 28 | test_structured = 29 | assertEqual "" exampleUsesDecimal $ 30 | $(reparseStructured exampleUsesDecimal) 31 | 32 | test_json :: Assertion 33 | test_json = 34 | assertEqual "" (Right exampleUsesDecimal) $ 35 | Aeson.eitherDecode $ Aeson.encode exampleUsesDecimal -------------------------------------------------------------------------------- /test/Test/Serialisation/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | 3 | -- | Example types 4 | -- 5 | -- Defined as separate module to avoid TH stage restrictions 6 | module Test.Serialisation.Types ( 7 | UsesDecimal(..) 8 | , exampleUsesDecimal 9 | , UsesBase16(..) 10 | , exampleUsesBase16 11 | , UsesBase58(..) 12 | , exampleUsesBase58 13 | , UsesBase64(..) 14 | , exampleUsesBase64 15 | , UsesJSON(..) 16 | , exampleUsesJSON 17 | ) where 18 | 19 | import Data.Aeson 20 | import Data.Aeson.QQ.Simple 21 | import Data.String 22 | import Data.Word 23 | 24 | import qualified Data.Structured as Structured 25 | 26 | import Foreign.Rust.Serialisation.JSON 27 | import Foreign.Rust.Serialisation.Raw 28 | import Foreign.Rust.Serialisation.Raw.Base16 29 | import Foreign.Rust.Serialisation.Raw.Base58 30 | import Foreign.Rust.Serialisation.Raw.Base64 31 | import Foreign.Rust.Serialisation.Raw.Decimal 32 | 33 | {------------------------------------------------------------------------------- 34 | AsDecimal 35 | -------------------------------------------------------------------------------} 36 | 37 | newtype UsesDecimal = UsesDecimal [Word8] 38 | deriving stock (Eq) 39 | deriving newtype (IsRaw) 40 | deriving (Show, Structured.Show) via AsDecimal UsesDecimal 41 | deriving (FromJSON, ToJSON) via AsDecimal UsesDecimal 42 | 43 | exampleUsesDecimal :: UsesDecimal 44 | exampleUsesDecimal = UsesDecimal [1, 2, 3, 4] 45 | 46 | {------------------------------------------------------------------------------- 47 | AsBase16 48 | -------------------------------------------------------------------------------} 49 | 50 | newtype UsesBase16 = UsesBase16 [Word8] 51 | deriving stock (Eq) 52 | deriving newtype (IsRaw) 53 | deriving (Show, Structured.Show, IsString) via AsBase16 UsesBase16 54 | deriving (FromJSON, ToJSON) via AsBase16 UsesBase16 55 | 56 | exampleUsesBase16 :: UsesBase16 57 | exampleUsesBase16 = UsesBase16 [1, 2, 3, 4] 58 | 59 | {------------------------------------------------------------------------------- 60 | AsBase58 61 | -------------------------------------------------------------------------------} 62 | 63 | newtype UsesBase58 = UsesBase58 [Word8] 64 | deriving stock (Eq) 65 | deriving newtype (IsRaw) 66 | deriving (Show, Structured.Show, IsString) via AsBase58 UsesBase58 67 | deriving (FromJSON, ToJSON) via AsBase58 UsesBase58 68 | 69 | exampleUsesBase58 :: UsesBase58 70 | exampleUsesBase58 = UsesBase58 [1, 2, 3, 4] 71 | 72 | {------------------------------------------------------------------------------- 73 | AsBase64 74 | -------------------------------------------------------------------------------} 75 | 76 | newtype UsesBase64 = UsesBase64 [Word8] 77 | deriving stock (Eq) 78 | deriving newtype (IsRaw) 79 | deriving (Show, Structured.Show, IsString) via AsBase64 UsesBase64 80 | deriving (FromJSON, ToJSON) via AsBase64 UsesBase64 81 | 82 | exampleUsesBase64 :: UsesBase64 83 | exampleUsesBase64 = UsesBase64 [1, 2, 3, 4] 84 | 85 | {------------------------------------------------------------------------------- 86 | AsJSON 87 | -------------------------------------------------------------------------------} 88 | 89 | newtype UsesJSON = UsesJSON Value 90 | deriving stock (Eq) 91 | deriving newtype (ToJSON, FromJSON) 92 | deriving (Show, Structured.Show) via AsJSON UsesJSON 93 | 94 | exampleUsesJSON :: UsesJSON 95 | exampleUsesJSON = UsesJSON [aesonQQ| 96 | { "a": null 97 | , "b": [1, 2, 3] 98 | } 99 | |] 100 | -------------------------------------------------------------------------------- /test/Test/Util/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Test.Util.TH ( 4 | reparseShow 5 | , reparseStructured 6 | ) where 7 | 8 | import Data.String (fromString) 9 | 10 | import qualified Data.Structured as Structured 11 | import qualified Language.Haskell.TH as TH 12 | import qualified Language.Haskell.Exts as Exts 13 | import Language.Haskell.TH (Q) 14 | import Language.Haskell.TH.Quote 15 | import Data.Aeson.QQ.Simple 16 | 17 | {------------------------------------------------------------------------------- 18 | Parse expressions 19 | -------------------------------------------------------------------------------} 20 | 21 | parseExp :: String -> Q TH.Exp 22 | parseExp = 23 | toExp 24 | . Exts.fromParseResult 25 | . Exts.parseExpWithMode parseMode 26 | where 27 | parseMode :: Exts.ParseMode 28 | parseMode = Exts.defaultParseMode { 29 | Exts.extensions = [ 30 | Exts.EnableExtension Exts.OverloadedStrings 31 | , Exts.EnableExtension Exts.TypeApplications 32 | , Exts.EnableExtension Exts.QuasiQuotes 33 | ] 34 | } 35 | 36 | reparseShow :: Show a => a -> Q TH.Exp 37 | reparseShow = parseExp . show 38 | 39 | reparseStructured :: Structured.Show a => a -> Q TH.Exp 40 | reparseStructured = parseExp . Structured.show 41 | 42 | {------------------------------------------------------------------------------- 43 | Translate haskell-src-exts @Exp@ to TH @Exp@ 44 | 45 | There is a package for this (@haskell-src-meta@), but it does not support 46 | overloaded string nor quasi-quotes, which makes it rather useless for our 47 | purposes. We only need to support a tiny handful of expressions, so we just 48 | define it ourselves. 49 | -------------------------------------------------------------------------------} 50 | 51 | toExp :: Exts.Exp Exts.SrcSpanInfo -> Q TH.Exp 52 | toExp = \case 53 | 54 | -- Standard instances 55 | -- (These would presumably be similar in haskell-src-meta) 56 | 57 | Exts.Var _ (Exts.UnQual _ (Exts.Ident _ n)) -> 58 | pure $ TH.VarE $ TH.mkName n 59 | Exts.App _ e (Exts.TypeApp _ (Exts.TyCon _ (Exts.UnQual _ (Exts.Ident _ n)))) -> 60 | TH.AppTypeE <$> toExp e <*> pure (TH.ConT (TH.mkName n)) 61 | Exts.App _ e1 e2 -> 62 | TH.AppE <$> toExp e1 <*> toExp e2 63 | Exts.List _ es -> 64 | TH.ListE <$> mapM toExp es 65 | Exts.Lit _ (Exts.Int _ x _) -> 66 | pure $ TH.LitE (TH.IntegerL x) 67 | 68 | -- Overloaded strings 69 | 70 | Exts.Lit _ (Exts.String _ x _) -> 71 | pure $ TH.AppE (TH.VarE 'fromString) (TH.LitE (TH.StringL x)) 72 | 73 | -- Quasi-quotes 74 | 75 | Exts.QuasiQuote _ "aesonQQ" str -> 76 | quoteExp aesonQQ str 77 | 78 | -- Anything else is urecognized 79 | 80 | e -> fail $ "toExp: unrecognized expression " ++ show e 81 | 82 | --------------------------------------------------------------------------------