Initial push

.github/workflows/haskell-ci.yml

@@ -0,0 +1,233 @@
+# This GitHub workflow config has been generated by a script via
+#
+#   haskell-ci 'github' 'cabal.project'
+#
+# To regenerate the script (for example after adjusting tested-with) run
+#
+#   haskell-ci regenerate
+#
+# For more information, see https://github.com/haskell-CI/haskell-ci
+#
+# version: 0.15.20230312
+#
+# REGENDATA ("0.15.20230312",["github","cabal.project"])
+#
+name: Haskell-CI
+on:
+  - push
+  - pull_request
+jobs:
+  linux:
+    name: Haskell-CI - Linux - ${{ matrix.compiler }}
+    runs-on: ubuntu-20.04
+    timeout-minutes:
+      60
+    container:
+      image: buildpack-deps:bionic
+    continue-on-error: ${{ matrix.allow-failure }}
+    strategy:
+      matrix:
+        include:
+          - compiler: ghc-9.4.4
+            compilerKind: ghc
+            compilerVersion: 9.4.4
+            setup-method: ghcup
+            allow-failure: false
+          - compiler: ghc-9.2.7
+            compilerKind: ghc
+            compilerVersion: 9.2.7
+            setup-method: ghcup
+            allow-failure: false
+          - compiler: ghc-9.0.2
+            compilerKind: ghc
+            compilerVersion: 9.0.2
+            setup-method: ghcup
+            allow-failure: false
+          - compiler: ghc-8.10.7
+            compilerKind: ghc
+            compilerVersion: 8.10.7
+            setup-method: ghcup
+            allow-failure: false
+          - compiler: ghc-8.8.4
+            compilerKind: ghc
+            compilerVersion: 8.8.4
+            setup-method: hvr-ppa
+            allow-failure: false
+          - compiler: ghc-8.6.5
+            compilerKind: ghc
+            compilerVersion: 8.6.5
+            setup-method: hvr-ppa
+            allow-failure: false
+      fail-fast: false
+    steps:
+      - name: apt
+        run: |
+          apt-get update
+          apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5
+          if [ "${{ matrix.setup-method }}" = ghcup ]; then
+            mkdir -p "$HOME/.ghcup/bin"
+            curl -sL https://downloads.haskell.org/ghcup/0.1.18.0/x86_64-linux-ghcup-0.1.18.0 > "$HOME/.ghcup/bin/ghcup"
+            chmod a+x "$HOME/.ghcup/bin/ghcup"
+            "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false)
+            "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
+          else
+            apt-add-repository -y 'ppa:hvr/ghc'
+            apt-get update
+            apt-get install -y "$HCNAME"
+            mkdir -p "$HOME/.ghcup/bin"
+            curl -sL https://downloads.haskell.org/ghcup/0.1.18.0/x86_64-linux-ghcup-0.1.18.0 > "$HOME/.ghcup/bin/ghcup"
+            chmod a+x "$HOME/.ghcup/bin/ghcup"
+            "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
+          fi
+        env:
+          HCKIND: ${{ matrix.compilerKind }}
+          HCNAME: ${{ matrix.compiler }}
+          HCVER: ${{ matrix.compilerVersion }}
+      - name: Set PATH and environment variables
+        run: |
+          echo "$HOME/.cabal/bin" >> $GITHUB_PATH
+          echo "LANG=C.UTF-8" >> "$GITHUB_ENV"
+          echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV"
+          echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV"
+          HCDIR=/opt/$HCKIND/$HCVER
+          if [ "${{ matrix.setup-method }}" = ghcup ]; then
+            HC=$HOME/.ghcup/bin/$HCKIND-$HCVER
+            echo "HC=$HC" >> "$GITHUB_ENV"
+            echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV"
+            echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV"
+            echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV"
+          else
+            HC=$HCDIR/bin/$HCKIND
+            echo "HC=$HC" >> "$GITHUB_ENV"
+            echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV"
+            echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV"
+            echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV"
+          fi
+
+          HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')
+          echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"
+          echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"
+          echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV"
+          echo "HEADHACKAGE=false" >> "$GITHUB_ENV"
+          echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV"
+          echo "GHCJSARITH=0" >> "$GITHUB_ENV"
+        env:
+          HCKIND: ${{ matrix.compilerKind }}
+          HCNAME: ${{ matrix.compiler }}
+          HCVER: ${{ matrix.compilerVersion }}
+      - name: env
+        run: |
+          env
+      - name: write cabal config
+        run: |
+          mkdir -p $CABAL_DIR
+          cat >> $CABAL_CONFIG <<EOF
+          remote-build-reporting: anonymous
+          write-ghc-environment-files: never
+          remote-repo-cache: $CABAL_DIR/packages
+          logs-dir:          $CABAL_DIR/logs
+          world-file:        $CABAL_DIR/world
+          extra-prog-path:   $CABAL_DIR/bin
+          symlink-bindir:    $CABAL_DIR/bin
+          installdir:        $CABAL_DIR/bin
+          build-summary:     $CABAL_DIR/logs/build.log
+          store-dir:         $CABAL_DIR/store
+          install-dirs user
+            prefix: $CABAL_DIR
+          repository hackage.haskell.org
+            url: http://hackage.haskell.org/
+          EOF
+          cat >> $CABAL_CONFIG <<EOF
+          program-default-options
+            ghc-options: $GHCJOBS +RTS -M3G -RTS
+          EOF
+          cat $CABAL_CONFIG
+      - name: versions
+        run: |
+          $HC --version || true
+          $HC --print-project-git-commit-id || true
+          $CABAL --version || true
+      - name: update cabal index
+        run: |
+          $CABAL v2-update -v
+      - name: install cabal-plan
+        run: |
+          mkdir -p $HOME/.cabal/bin
+          curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.6.2.0/cabal-plan-0.6.2.0-x86_64-linux.xz > cabal-plan.xz
+          echo 'de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc  cabal-plan.xz' | sha256sum -c -
+          xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan
+          rm -f cabal-plan.xz
+          chmod a+x $HOME/.cabal/bin/cabal-plan
+          cabal-plan --version
+      - name: checkout
+        uses: actions/checkout@v3
+        with:
+          path: source
+      - name: initial cabal.project for sdist
+        run: |
+          touch cabal.project
+          echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project
+          cat cabal.project
+      - name: sdist
+        run: |
+          mkdir -p sdist
+          $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist
+      - name: unpack
+        run: |
+          mkdir -p unpacked
+          find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \;
+      - name: generate cabal.project
+        run: |
+          PKGDIR_foreign_rust="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/foreign-rust-[0-9.]*')"
+          echo "PKGDIR_foreign_rust=${PKGDIR_foreign_rust}" >> "$GITHUB_ENV"
+          rm -f cabal.project cabal.project.local
+          touch cabal.project
+          touch cabal.project.local
+          echo "packages: ${PKGDIR_foreign_rust}" >> cabal.project
+          echo "package foreign-rust" >> cabal.project
+          echo "    ghc-options: -Werror=missing-methods" >> cabal.project
+          cat >> cabal.project <<EOF
+          EOF
+          $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(foreign-rust)$/; }' >> cabal.project.local
+          cat cabal.project
+          cat cabal.project.local
+      - name: dump install plan
+        run: |
+          $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all
+          cabal-plan
+      - name: restore cache
+        uses: actions/cache/restore@v3
+        with:
+          key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }}
+          path: ~/.cabal/store
+          restore-keys: ${{ runner.os }}-${{ matrix.compiler }}-
+      - name: install dependencies
+        run: |
+          $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all
+          $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all
+      - name: build w/o tests
+        run: |
+          $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all
+      - name: build
+        run: |
+          $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always
+      - name: tests
+        run: |
+          $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct
+      - name: cabal check
+        run: |
+          cd ${PKGDIR_foreign_rust} || false
+          ${CABAL} -vnormal check
+      - name: haddock
+        run: |
+          $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all
+      - name: unconstrained build
+        run: |
+          rm -f cabal.project.local
+          $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all
+      - name: save cache
+        uses: actions/cache/save@v3
+        if: always()
+        with:
+          key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }}
+          path: ~/.cabal/store

.gitignore

@@ -0,0 +1,2 @@
+.envrc
+dist-newstyle

CHANGELOG.md

@@ -0,0 +1,5 @@
+# Revision history for foreign-rust
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

cabal.project

@@ -0,0 +1,4 @@
+packages: .
+
+package foreign-rust
+  tests: true

demo-annotated/Main.hs

@@ -0,0 +1,151 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+import Data.Annotated
+import Data.Kind
+import GHC.TypeLits
+
+import qualified GHC.Generics as GHC
+import qualified Generics.SOP as SOP
+
+import qualified Data.Structured    as Structured
+import qualified Data.Structured.TH as Structured
+
+{-------------------------------------------------------------------------------
+  Demonstration of annotations
+-------------------------------------------------------------------------------}
+
+--
+-- Suppose we have some data type that is opaque Haskell-side (just some bytes),
+--
+
+data Keypair = Keypair
+  deriving stock (Show, GHC.Generic)
+  deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
+  deriving anyclass (Structured.Show)
+  deriving CanAnnotate via PairWithAnnotation Keypair
+
+--
+-- Perhaps we can inspect this datatype using an FFI
+--
+
+data Pubkey = Pubkey
+  deriving stock (Show, GHC.Generic)
+  deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
+  deriving anyclass (Structured.Show)
+
+data Secret = Secret
+  deriving stock (Show, GHC.Generic)
+  deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
+  deriving anyclass (Structured.Show)
+
+keypairPubkey :: Keypair -> Pubkey
+keypairPubkey Keypair = Pubkey
+
+keypairSecret :: Keypair -> Secret
+keypairSecret Keypair = Secret
+
+--
+-- When we show a Keypair, we'd like to annotate it with these derived values
+--
+
+data KeypairAnnotation = KeypairAnnotation {
+      pubkey :: Pubkey
+    , secret :: Secret
+    }
+  deriving stock (Show, GHC.Generic)
+  deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
+  deriving anyclass (Structured.Show)
+
+type instance Annotation Keypair = KeypairAnnotation
+
+instance ComputeAnnotation Keypair where
+  computeAnnotation kp = KeypairAnnotation {
+        pubkey = keypairPubkey kp
+      , secret = keypairSecret kp
+      }
+
+{-------------------------------------------------------------------------------
+  Generics
+-------------------------------------------------------------------------------}
+
+data RecordA = RecordA {
+      recA_field1 :: Bool
+    , recA_field2 :: Int
+    }
+  deriving stock (GHC.Generic)
+  deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
+  deriving anyclass (Structured.Show)
+
+-- A type, perhaps externally defined, with only standard Show instance
+data SomeOtherType = SomeOtherType String
+  deriving (Show)
+
+data RecordB = RecordB {
+      recB :: SomeOtherType
+    }
+  deriving stock (GHC.Generic)
+  deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
+
+instance Structured.Show RecordB where
+  toValue = Structured.gtoValueAfter Structured.FromPreludeShow
+
+{-------------------------------------------------------------------------------
+  Demonstrate TH support (crucically, with support for GADTs)
+-------------------------------------------------------------------------------}
+
+data SimpleEnum = SimpleEnumA | SimpleEnumB
+
+Structured.deriveInstance 'SimpleEnumA [t|
+     forall. Structured.Show SimpleEnum
+  |]
+
+data SimpleStruct a = SimpleStruct a Int
+
+Structured.deriveInstance 'SimpleStruct [t|
+    forall a. Structured.Show a => Structured.Show (SimpleStruct a)
+  |]
+
+data SomeGADT :: Symbol -> Type where
+  Foo :: SomeGADT "foo"
+  Bar :: SomeGADT "bar"
+
+Structured.deriveInstance 'Foo [t|
+    forall k. Structured.Show (SomeGADT k)
+  |]
+
+class Foo a where
+  data SomeAssocType a :: Type
+
+instance Foo Int where
+  data SomeAssocType Int = SomeInt Int
+
+Structured.deriveInstance 'SomeInt [t|
+    forall. Structured.Show (SomeAssocType Int)
+  |]
+
+data SomeRecord = SomeRecord {
+      field1 :: Int
+    , field2 :: Bool
+    }
+
+Structured.deriveInstance 'SomeRecord [t|
+    forall. Structured.Show SomeRecord
+  |]
+
+{-------------------------------------------------------------------------------
+  Main
+-------------------------------------------------------------------------------}
+
+main :: IO ()
+main = do
+    -- Annotations
+    Structured.print . annotate $ [(Just Keypair, True)]
+    -- Generics
+    Structured.print $ RecordA { recA_field1 = True, recA_field2 = 5 }
+    Structured.print $ RecordB { recB = SomeOtherType "hi" }
+    -- TH
+    Structured.print $ SimpleEnumA
+    Structured.print $ SimpleStruct True 5
+    Structured.print $ Foo
+    Structured.print $ SomeInt 5
+    Structured.print $ SomeRecord { field1 = 1, field2 = True }

foreign-rust.cabal

@@ -0,0 +1,131 @@
+cabal-version:      3.0
+name:               foreign-rust
+version:            0.1.0
+license:            BSD-3-Clause
+license-file:       LICENSE
+author:             Edsko de Vries
+maintainer:         edsko@well-typed.com
+category:           Development
+build-type:         Simple
+extra-doc-files:    CHANGELOG.md
+tested-with:        GHC==8.6.5
+                  , GHC==8.8.4
+                  , GHC==8.10.7
+                  , GHC==9.0.2
+                  , GHC==9.2.7
+                  , GHC==9.4.4
+
+common lang
+  build-depends:
+      base >= 4.12
+  default-language:
+      Haskell2010
+  ghc-options:
+      -Wall
+      -Wredundant-constraints
+  if impl(ghc >= 8.10)
+    ghc-options:
+      -Wunused-packages
+  default-extensions:
+      DataKinds
+      DefaultSignatures
+      DeriveAnyClass
+      DeriveGeneric
+      DerivingStrategies
+      DerivingVia
+      FlexibleContexts
+      FlexibleInstances
+      GADTs
+      GeneralizedNewtypeDeriving
+      LambdaCase
+      MultiParamTypeClasses
+      PolyKinds
+      RankNTypes
+      ScopedTypeVariables
+      StandaloneDeriving
+      TupleSections
+      TypeApplications
+      TypeFamilies
+      TypeOperators
+      UndecidableInstances
+
+library
+  import:
+      lang
+  exposed-modules:
+      Foreign.Rust.External.JSON
+      Foreign.Rust.External.Bincode
+      Foreign.Rust.Failure
+      Foreign.Rust.Marshall.Fixed
+      Foreign.Rust.Marshall.Variable
+      Foreign.Rust.SafeConv
+      Foreign.Rust.Serialisation.JSON
+      Foreign.Rust.Serialisation.Raw
+      Foreign.Rust.Serialisation.Raw.Base16
+      Foreign.Rust.Serialisation.Raw.Base58
+      Foreign.Rust.Serialisation.Raw.Base64
+      Foreign.Rust.Serialisation.Raw.Decimal
+
+      Data.Annotated
+      Data.Structured
+      Data.Structured.TH
+  other-modules:
+      Foreign.Rust.Marshall.Util
+  hs-source-dirs:
+      src
+  build-depends:
+    , aeson
+    , base16-bytestring
+    , base58-bytestring
+    , base64-bytestring
+    , binary
+    , borsh >= 0.3
+    , bytestring
+    , containers
+    , data-default
+    , generics-sop
+    , OneTuple
+    , sop-core
+    , template-haskell
+    , text
+    , th-abstraction
+    , vector
+    , wide-word
+
+test-suite test-foreign-rust
+  import:
+      lang
+  type:
+      exitcode-stdio-1.0
+  main-is:
+      Main.hs
+  other-modules:
+      Test.Serialisation.JSON
+      Test.Serialisation.Raw.Base16
+      Test.Serialisation.Raw.Base58
+      Test.Serialisation.Raw.Base64
+      Test.Serialisation.Raw.Decimal
+      Test.Serialisation.Types
+      Test.Util.TH
+  hs-source-dirs:
+      test
+  build-depends:
+    , aeson
+    , foreign-rust
+    , haskell-src-exts
+    , tasty
+    , tasty-hunit
+    , template-haskell
+
+test-suite demo-annotated
+  import:
+      lang
+  type:
+      exitcode-stdio-1.0
+  main-is:
+      Main.hs
+  hs-source-dirs:
+      demo-annotated
+  build-depends:
+    , generics-sop
+    , foreign-rust

src/Data/Annotated.hs

@@ -0,0 +1,380 @@
+module Data.Annotated (
+    -- * Definition
+    CanAnnotate(..)
+    -- * Deriving-via support
+    -- ** Computing annotations
+  , Annotation
+  , PairWithAnnotation(..)
+  , ComputeAnnotation(..)
+  , WithAnnotation(..)
+    -- ** Other combinators
+  , NoAnnotation(..)
+  , AnnotateFoldable(..)
+  , AnnotateGenericallyAs(..)
+  ) where
+
+import Data.Functor.Identity
+import Data.Int
+import Data.Kind
+import Data.Map (Map)
+import Data.Proxy
+import Data.WideWord
+import Data.Word
+
+import qualified Data.Aeson          as Aeson
+import qualified Data.SOP.Constraint as SOP
+import qualified Generics.SOP        as SOP
+import qualified GHC.Generics        as GHC
+
+import qualified Data.Structured as Structured
+import Data.Tuple.Solo
+
+{-------------------------------------------------------------------------------
+  Definition
+-------------------------------------------------------------------------------}
+
+class CanAnnotate a where
+  type Annotated a :: Type
+  annotate :: a -> Annotated a
+
+{-------------------------------------------------------------------------------
+  Deriving via support: computing annotations
+-------------------------------------------------------------------------------}
+
+-- | Annotation of a value
+--
+-- Unlike 'Annotated', 'Annotation' is not always defined: not all types /have/
+-- annotations (for example, @Annotated a@ might just be @a@).
+type family Annotation a :: Type
+
+-- | Deriving via support: computing annotations
+--
+-- If you need to compute an annotation and do not need to worry about
+-- annotating any nested values, you define a 'CanAnnotate' instance for some
+-- type @A@ with annotation @B@ as follows:
+--
+-- > data A = ..
+-- >   deriving CanAnnotate via PairWithAnnotation A
+newtype PairWithAnnotation a = PairWithAnnotation a
+
+class ComputeAnnotation a where
+  computeAnnotation :: a -> Annotation a
+
+instance ComputeAnnotation a => CanAnnotate (PairWithAnnotation a) where
+  type Annotated (PairWithAnnotation a) = WithAnnotation a (Annotation a)
+  annotate (PairWithAnnotation x) = WithAnnotation {
+        value      = x
+      , annotation = computeAnnotation x
+      }
+
+data WithAnnotation a b = WithAnnotation {
+      value      :: a
+    , annotation :: b
+    }
+  deriving stock (Show, GHC.Generic)
+  deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
+  deriving anyclass (Structured.Show)
+
+{-------------------------------------------------------------------------------
+  Deriving via: default instance for foldable containers
+-------------------------------------------------------------------------------}
+
+-- | Deriving via: default instance for foldable containers
+--
+-- We annotate the values in the containers, and give the container length as
+-- its own annotation.
+--
+-- Example:
+--
+-- > deriving
+-- >   via AnnotateFoldable [] a
+-- >   instance CanAnnotate a => CanAnnotate [a]
+newtype AnnotateFoldable f a = AnnotateFoldable (f a)
+
+newtype Length = Length Int
+  deriving stock (Show, GHC.Generic)
+  deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
+  deriving anyclass (Structured.Show)
+
+type instance Annotation (AnnotateFoldable f a) = Length
+
+instance ( Functor f
+         , Foldable f
+         , CanAnnotate a
+         ) => CanAnnotate (AnnotateFoldable f a) where
+  type Annotated (AnnotateFoldable f a) = WithAnnotation (f (Annotated a)) Length
+  annotate (AnnotateFoldable xs) = WithAnnotation {
+        value      = annotate <$> xs
+      , annotation = Length $ length xs
+      }
+
+{-------------------------------------------------------------------------------
+  Deriving-via: no annotation
+-------------------------------------------------------------------------------}
+
+-- | Deriving via: no annotation
+--
+-- Example:
+--
+-- > data A = ..
+-- >   deriving CanAnnotate via NoAnnotation A
+newtype NoAnnotation a = NoAnnotation a
+
+type instance Annotation (NoAnnotation a) = ()
+
+instance CanAnnotate (NoAnnotation a) where
+  type Annotated (NoAnnotation a) = a
+  annotate (NoAnnotation x) = x
+
+{-------------------------------------------------------------------------------
+  Deriving via: generics
+-------------------------------------------------------------------------------}
+
+-- | Deriving via: annotate generically
+--
+-- This combinator can be used to define 'CanAnnotate' instance that just
+-- walk over the structure of the argument, without adding any annotations
+-- of their own.
+--
+-- Example:
+--
+-- > deriving
+-- >   via AnnotateGenericallyAs (Maybe (Annotated a)) (Maybe a)
+-- >   instance CanAnnotate a => CanAnnotate (Maybe a)
+newtype AnnotateGenericallyAs b a = AnnotateGenericallyAs a
+
+-- | Internal auxiliary: two-parameter wrapper around 'CanAnnotate'
+class Annotate' a b where
+  annotate' :: a -> b
+
+instance (CanAnnotate a, b ~ Annotated a) => Annotate' a b where
+  annotate' = annotate
+
+type instance Annotation (AnnotateGenericallyAs b a) = ()
+
+instance ( SOP.Generic a
+         , SOP.Generic b
+         , SOP.SameShapeAs (SOP.Code a) (SOP.Code b)
+         , SOP.SameShapeAs (SOP.Code b) (SOP.Code a)
+         , SOP.AllZip2 Annotate' (SOP.Code a) (SOP.Code b)
+         ) => CanAnnotate (AnnotateGenericallyAs b a) where
+  type Annotated (AnnotateGenericallyAs b a) = b
+  annotate (AnnotateGenericallyAs x) =
+       SOP.to
+     . SOP.htrans (Proxy @Annotate') (SOP.mapII annotate')
+     . SOP.from
+     $ x
+
+{-------------------------------------------------------------------------------
+  Standard instances: no annotation
+-------------------------------------------------------------------------------}
+
+deriving via NoAnnotation Bool        instance CanAnnotate Bool
+deriving via NoAnnotation Aeson.Value instance CanAnnotate Aeson.Value
+
+deriving via NoAnnotation Integer instance CanAnnotate Integer
+
+deriving via NoAnnotation Int     instance CanAnnotate Int
+deriving via NoAnnotation Int8    instance CanAnnotate Int8
+deriving via NoAnnotation Int16   instance CanAnnotate Int16
+deriving via NoAnnotation Int32   instance CanAnnotate Int32
+deriving via NoAnnotation Int64   instance CanAnnotate Int64
+deriving via NoAnnotation Int128  instance CanAnnotate Int128
+
+deriving via NoAnnotation Word    instance CanAnnotate Word
+deriving via NoAnnotation Word8   instance CanAnnotate Word8
+deriving via NoAnnotation Word16  instance CanAnnotate Word16
+deriving via NoAnnotation Word32  instance CanAnnotate Word32
+deriving via NoAnnotation Word64  instance CanAnnotate Word64
+deriving via NoAnnotation Word128 instance CanAnnotate Word128
+
+deriving via NoAnnotation Float   instance CanAnnotate Float
+deriving via NoAnnotation Double  instance CanAnnotate Double
+
+{-------------------------------------------------------------------------------
+  Standard instances: foldable
+-------------------------------------------------------------------------------}
+
+deriving
+  via AnnotateFoldable [] a
+  instance CanAnnotate a => CanAnnotate [a]
+
+deriving
+  via AnnotateFoldable (Map k) a
+  instance CanAnnotate a => CanAnnotate (Map k a)
+
+{-------------------------------------------------------------------------------
+  Standard instances: generic
+-------------------------------------------------------------------------------}
+
+deriving
+  via AnnotateGenericallyAs (Maybe (Annotated a)) (Maybe a)
+  instance CanAnnotate a => CanAnnotate (Maybe a)
+
+deriving
+  via AnnotateGenericallyAs (Either (Annotated a) (Annotated b)) (Either a b)
+  instance (CanAnnotate a, CanAnnotate b) => CanAnnotate (Either a b)
+
+deriving
+  via AnnotateGenericallyAs (Identity (Annotated a)) (Identity a)
+  instance CanAnnotate a => CanAnnotate (Identity a)
+
+{-------------------------------------------------------------------------------
+  Standard instances: tuples
+
+  These instances also use 'AnnotateGenericallyAs'.
+-------------------------------------------------------------------------------}
+
+-- 0
+deriving
+  via NoAnnotation ()
+  instance CanAnnotate ()
+
+-- 1 ('Solo' does not support SOP generics)
+instance CanAnnotate a => CanAnnotate (Solo a) where
+  type Annotated (Solo a) = Solo (Annotated a)
+  annotate (Solo x) = Solo (annotate x)
+
+-- 2
+deriving
+  via AnnotateGenericallyAs
+        ( Annotated a
+        , Annotated b
+        )
+        (a, b)
+  instance ( CanAnnotate a
+           , CanAnnotate b
+           ) => CanAnnotate (a, b)
+
+-- 3
+deriving
+  via AnnotateGenericallyAs
+        ( Annotated a
+        , Annotated b
+        , Annotated c
+        )
+        (a, b, c)
+  instance ( CanAnnotate a
+           , CanAnnotate b
+           , CanAnnotate c
+           ) => CanAnnotate (a, b, c)
+
+-- 4
+deriving
+  via AnnotateGenericallyAs
+        ( Annotated a
+        , Annotated b
+        , Annotated c
+        , Annotated d
+        )
+        (a, b, c, d)
+  instance ( CanAnnotate a
+           , CanAnnotate b
+           , CanAnnotate c
+           , CanAnnotate d
+           ) => CanAnnotate (a, b, c, d)
+
+-- 5
+deriving
+  via AnnotateGenericallyAs
+        ( Annotated a
+        , Annotated b
+        , Annotated c
+        , Annotated d
+        , Annotated e
+        )
+        (a, b, c, d, e)
+  instance ( CanAnnotate a
+           , CanAnnotate b
+           , CanAnnotate c
+           , CanAnnotate d
+           , CanAnnotate e
+           ) => CanAnnotate (a, b, c, d, e)
+
+-- 6
+deriving
+  via AnnotateGenericallyAs
+        ( Annotated a
+        , Annotated b
+        , Annotated c
+        , Annotated d
+        , Annotated e
+        , Annotated f
+        )
+        (a, b, c, d, e, f)
+  instance ( CanAnnotate a
+           , CanAnnotate b
+           , CanAnnotate c
+           , CanAnnotate d
+           , CanAnnotate e
+           , CanAnnotate f
+           ) => CanAnnotate (a, b, c, d, e, f)
+
+-- 7
+deriving
+  via AnnotateGenericallyAs
+        ( Annotated a
+        , Annotated b
+        , Annotated c
+        , Annotated d
+        , Annotated e
+        , Annotated f
+        , Annotated g
+        )
+        (a, b, c, d, e, f, g)
+  instance ( CanAnnotate a
+           , CanAnnotate b
+           , CanAnnotate c
+           , CanAnnotate d
+           , CanAnnotate e
+           , CanAnnotate f
+           , CanAnnotate g
+           ) => CanAnnotate (a, b, c, d, e, f, g)
+
+-- 8
+deriving
+  via AnnotateGenericallyAs
+        ( Annotated a
+        , Annotated b
+        , Annotated c
+        , Annotated d
+        , Annotated e
+        , Annotated f
+        , Annotated g
+        , Annotated h
+        )
+        (a, b, c, d, e, f, g, h)
+  instance ( CanAnnotate a
+           , CanAnnotate b
+           , CanAnnotate c
+           , CanAnnotate d
+           , CanAnnotate e
+           , CanAnnotate f
+           , CanAnnotate g
+           , CanAnnotate h
+           ) => CanAnnotate (a, b, c, d, e, f, g, h)
+
+-- 9
+deriving
+  via AnnotateGenericallyAs
+        ( Annotated a
+        , Annotated b
+        , Annotated c
+        , Annotated d
+        , Annotated e
+        , Annotated f
+        , Annotated g
+        , Annotated h
+        , Annotated i
+        )
+        (a, b, c, d, e, f, g, h, i)
+  instance ( CanAnnotate a
+           , CanAnnotate b
+           , CanAnnotate c
+           , CanAnnotate d
+           , CanAnnotate e
+           , CanAnnotate f
+           , CanAnnotate g
+           , CanAnnotate h
+           , CanAnnotate i
+           ) => CanAnnotate (a, b, c, d, e, f, g, h, i)

src/Data/Structured.hs

@@ -0,0 +1,663 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+
+-- | Pretty-print value in a way that is valid Haskell
+--
+-- Intended for qualified import
+--
+-- > import qualified Data.Structured as Structured
+module Data.Structured (
+    Show(..)
+  , show
+  , showsPrec
+  , print
+    -- * Structured values
+  , Value(..)
+    -- * Generics
+  , gtoValue
+  , gtoValueAfter
+  , sopToValue
+  , sopToValueAfter
+    -- * Deriving-via support
+  , ToPreludeShow(..)
+  , FromPreludeShow(..)
+  ) where
+
+import Prelude hiding (Show(..), print)
+import qualified Prelude
+
+import Control.Monad
+import Data.Bifunctor
+import Data.ByteString.Short (ShortByteString)
+import Data.Default
+import Data.Functor.Identity
+import Data.Int
+import Data.List (intersperse)
+import Data.List.NonEmpty (NonEmpty(..))
+import Data.SOP
+import Data.SOP.Dict
+import Data.String
+import Data.Text (Text)
+import Data.Text.Lazy.Builder (Builder)
+import Data.Tuple.Solo
+import Data.Typeable
+import Data.WideWord
+import Data.Word
+import GHC.Show (appPrec)
+
+import qualified Data.Aeson             as Aeson
+import qualified Data.Aeson.KeyMap      as Aeson.KeyMap
+import qualified Data.Aeson.Text        as Aeson
+import qualified Data.ByteString        as Strict
+import qualified Data.ByteString.Lazy   as Lazy
+import qualified Data.List.NonEmpty     as NE
+import qualified Data.Text              as Text
+import qualified Data.Text.Lazy         as Lazy
+import qualified Data.Text.Lazy         as Text.Lazy
+import qualified Data.Text.Lazy.Builder as B
+import qualified Data.Vector            as Vector
+import qualified Generics.SOP           as SOP
+
+{-------------------------------------------------------------------------------
+  Main API
+-------------------------------------------------------------------------------}
+
+-- | Pretty-print value in a way that is valid Haskell
+--
+-- This is similar to what @pretty-show@ offers, but @pretty-show@ does not
+-- guarantee valid Haskell (for example, strings are shown without quotes).
+class Show a where
+  -- | Generate structured value
+  --
+  -- Typically instances are derived using generics:
+  --
+  -- > data MyType = ..
+  -- >   deriving stock (GHC.Generic)
+  -- >   deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
+  -- >   deriving anyclass (Structured.Show)
+  --
+  -- If you want to tweak the generic instance, see 'gtoValueAfter'.
+  toValue :: a -> Value
+
+  default toValue ::
+       (SOP.HasDatatypeInfo a, All2 Show (SOP.Code a))
+    => a -> Value
+  toValue = gtoValue
+
+show :: Show a => a -> String
+show = render False . toValue
+
+showsPrec :: Show a => Int -> a -> ShowS
+showsPrec p = showString . render (p > appPrec) . toValue
+
+print :: Show a => a -> IO ()
+print = putStrLn . show
+
+{-------------------------------------------------------------------------------
+  Value
+-------------------------------------------------------------------------------}
+
+-- | Structured value
+data Value where
+  -- | Constructor (or smart constructor) application
+  --
+  -- We allow for some type applications, too.
+  Constr :: Text -> [TypeRep] -> [Value] -> Value
+
+  -- | Record
+  Record :: Text -> [(String, Value)] -> Value
+
+  -- | List
+  List :: [Value] -> Value
+
+  -- | Tuple
+  Tuple :: [Value] -> Value
+
+  -- | Anything String-like
+  --
+  -- Precondition: the 'Show' and 'IsString' instances must be compatible.
+  String :: forall a. (Prelude.Show a, IsString a) => a -> Value
+
+  -- | Integral numbers
+  --
+  -- These are shown assuming @NumericUnderscores@.
+  Integral :: forall a. (Prelude.Show a, Integral a) => a -> Value
+
+  -- | Quasi-quote
+  --
+  -- We separate out the quasi-quoter from the quoted string proper.
+  -- The lines of the quasi-quoted string are listed separately.
+  QuasiQ :: Text -> NonEmpty Builder -> Value
+
+  -- | JSON value
+  --
+  -- We define this as an explicit constructor, in case we ever want to
+  -- generate structured JSON logs from these values.
+  --
+  -- The pretty-printer uses the @aesonQQ@ quasi-quoter.
+  JSON :: Aeson.Value -> Value
+
+  -- | Value shown using the Prelude's show
+  PreludeShow :: Prelude.Show a => a -> Value
+
+deriving instance Prelude.Show Value
+
+{-------------------------------------------------------------------------------
+  Deriving-via support
+-------------------------------------------------------------------------------}
+
+-- | Derive 'Prelude.Show' through 'Show'
+--
+-- You might not want to do always do this; in some circumstances it may be
+-- useful to have a non-pretty-printed 'Show' instance alongside 'Show'.
+newtype ToPreludeShow a = ToPreludeShow a
+
+-- | Derive 'Show' through 'Prelude.Show'
+--
+-- NOTE: This should be used sparingly. When 'Show x' is derived using
+-- 'Prelude.Show x', the result should still be a law-abiding instance (generate
+-- valid Haskell code), assuming that the 'Prelude.Show' instance is
+-- law-abiding; however, it will limit the ability to generate structured
+-- values in different formats, such as JSON.
+newtype FromPreludeShow a = FromPreludeShow a
+
+instance Show a => Prelude.Show (ToPreludeShow a) where
+  showsPrec p (ToPreludeShow x) = showsPrec p x
+
+instance Prelude.Show a => Show (FromPreludeShow a) where
+  toValue (FromPreludeShow x) = PreludeShow x
+
+{-------------------------------------------------------------------------------
+  Generics
+-------------------------------------------------------------------------------}
+
+-- | Newtype which is transparent for the purposes of 'Show'
+--
+-- This is only used internally in 'sopToValue'.
+newtype Transparent a = Transparent a
+  deriving newtype Show
+
+gtoValue :: forall a.
+     (SOP.HasDatatypeInfo a, All2 Show (SOP.Code a))
+  => a -> Value
+gtoValue x = sopToValue (SOP.from x) (SOP.datatypeInfo (Proxy @a))
+
+-- | Generic derivation of 'toValue'
+--
+-- The standard generics instance will depend on 'Show' for all nested values.
+-- This is usually the right choice, but occassionally you will want to show
+-- nested values in a different manner; in this case, you can use
+-- 'gtoValueAfter'. Example:
+--
+-- > instance Structured.Show RecordB where
+-- >   toValue = Structured.gtoValueAfter Structured.FromPreludeShow
+--
+-- (However, 'FromPreludeShow' should be used sparingly; see discussion there.)
+gtoValueAfter :: forall f a.
+     (SOP.HasDatatypeInfo a, All2 (Compose Show f) (SOP.Code a))
+  => (forall x. x -> f x)
+  -> a -> Value
+gtoValueAfter f x = sopToValueAfter f (SOP.from x) (SOP.datatypeInfo (Proxy @a))
+
+sopToValue :: forall xss.
+     All2 Show xss
+  => SOP I xss -> SOP.DatatypeInfo xss -> Value
+sopToValue =
+    case aux of Dict -> sopToValueAfter Transparent
+  where
+    aux :: Dict (All2 (Compose Show Transparent)) xss
+    aux = all_POP $ hcpure (Proxy @Show) Dict
+
+sopToValueAfter :: forall f xss.
+     All2 (Compose Show f) xss
+  => (forall x. x -> f x)
+  -> SOP I xss -> SOP.DatatypeInfo xss -> Value
+sopToValueAfter f (SOP xss) info = hcollapse $
+    hczipWith (Proxy @(All (Compose Show f))) aux (SOP.constructorInfo info) xss
+  where
+    aux ::
+         All (Compose Show f) xs
+      => SOP.ConstructorInfo xs -> NP I xs -> K Value xs
+    aux (SOP.Constructor name)   xs = K $ auxSimple name xs
+    aux (SOP.Record name fields) xs = K $ auxRecord name fields xs
+    aux (SOP.Infix _ _ _)        _  = error "sopToValue: TODO: infix"
+
+    auxSimple ::
+         All (Compose Show f) xs
+      => String -> NP I xs -> Value
+    auxSimple constr xs = Constr (Text.pack constr) [] $ hcollapse $
+        hcmap (Proxy @(Compose Show f)) (mapIK (toValue . f)) xs
+
+    auxRecord ::
+         All (Compose Show f) xs
+      => SOP.ConstructorName -> NP SOP.FieldInfo xs -> NP I xs -> Value
+    auxRecord constr fields xs = Record (Text.pack constr) $ hcollapse $
+        hczipWith (Proxy @(Compose Show f)) auxRecordField fields xs
+
+    auxRecordField ::
+         Show (f x)
+      => SOP.FieldInfo x -> I x -> K (String, Value) x
+    auxRecordField field (I x) = K (SOP.fieldName field, toValue (f x))
+
+{-------------------------------------------------------------------------------
+  Standard instances
+-------------------------------------------------------------------------------}
+
+instance Show Word    where toValue = Integral
+instance Show Word8   where toValue = Integral
+instance Show Word16  where toValue = Integral
+instance Show Word32  where toValue = Integral
+instance Show Word64  where toValue = Integral
+instance Show Word128 where toValue = Integral
+
+instance Show Int     where toValue = Integral
+instance Show Int8    where toValue = Integral
+instance Show Int16   where toValue = Integral
+instance Show Int32   where toValue = Integral
+instance Show Int64   where toValue = Integral
+instance Show Int128  where toValue = Integral
+
+instance Show Integer where toValue = Integral
+
+instance {-# OVERLAPPABLE #-} Show a => Show [a] where
+  toValue = List . map toValue
+
+instance Show Aeson.Value where
+  toValue = JSON
+
+instance Typeable a => Show (Proxy (a :: k)) where
+  toValue p = Constr "Proxy" [typeRep p] []
+
+{-------------------------------------------------------------------------------
+  String-like types
+-------------------------------------------------------------------------------}
+
+instance {-# OVERLAPPING #-} Show String where
+  toValue = String
+
+instance Show Strict.ByteString where toValue = String
+instance Show Lazy.ByteString   where toValue = String
+instance Show ShortByteString   where toValue = String
+instance Show Text              where toValue = String
+instance Show Lazy.Text         where toValue = String
+
+{-------------------------------------------------------------------------------
+  Tuples
+-------------------------------------------------------------------------------}
+
+-- 0
+instance Show ()
+
+-- 1 (Solo does not support SOP generics)
+instance Show a => Show (Solo a) where
+  toValue (Solo x) = Constr "Solo" [] [toValue x]
+
+-- 2
+instance ( Show a
+         , Show b
+         ) => Show (a, b) where
+  toValue (a, b) = Tuple [
+        toValue a
+      , toValue b
+      ]
+
+-- 3
+instance ( Show a
+         , Show b
+         , Show c
+         ) => Show (a, b, c) where
+  toValue (a, b, c) = Tuple [
+        toValue a
+      , toValue b
+      , toValue c
+      ]
+
+-- 4
+instance ( Show a
+         , Show b
+         , Show c
+         , Show d
+         ) => Show (a, b, c, d) where
+  toValue (a, b, c, d) = Tuple [
+        toValue a
+      , toValue b
+      , toValue c
+      , toValue d
+      ]
+
+-- 5
+instance ( Show a
+         , Show b
+         , Show c
+         , Show d
+         , Show e
+         ) => Show (a, b, c, d, e) where
+  toValue (a, b, c, d, e) = Tuple [
+        toValue a
+      , toValue b
+      , toValue c
+      , toValue d
+      , toValue e
+      ]
+
+-- 6
+instance ( Show a
+         , Show b
+         , Show c
+         , Show d
+         , Show e
+         , Show f
+         ) => Show (a, b, c, d, e, f) where
+  toValue (a, b, c, d, e, f) = Tuple [
+        toValue a
+      , toValue b
+      , toValue c
+      , toValue d
+      , toValue e
+      , toValue f
+      ]
+
+-- 7
+instance ( Show a
+         , Show b
+         , Show c
+         , Show d
+         , Show e
+         , Show f
+         , Show g
+         ) => Show (a, b, c, d, e, f, g) where
+  toValue (a, b, c, d, e, f, g) = Tuple [
+        toValue a
+      , toValue b
+      , toValue c
+      , toValue d
+      , toValue e
+      , toValue f
+      , toValue g
+      ]
+
+-- 8
+instance ( Show a
+         , Show b
+         , Show c
+         , Show d
+         , Show e
+         , Show f
+         , Show g
+         , Show h
+         ) => Show (a, b, c, d, e, f, g, h) where
+  toValue (a, b, c, d, e, f, g, h) = Tuple [
+        toValue a
+      , toValue b
+      , toValue c
+      , toValue d
+      , toValue e
+      , toValue f
+      , toValue g
+      , toValue h
+      ]
+
+-- 9
+instance ( Show a
+         , Show b
+         , Show c
+         , Show d
+         , Show e
+         , Show f
+         , Show g
+         , Show h
+         , Show i
+         ) => Show (a, b, c, d, e, f, g, h, i) where
+  toValue (a, b, c, d, e, f, g, h, i) = Tuple [
+        toValue a
+      , toValue b
+      , toValue c
+      , toValue d
+      , toValue e
+      , toValue f
+      , toValue g
+      , toValue h
+      , toValue i
+      ]
+
+{-------------------------------------------------------------------------------
+  Instances that rely on generics
+-------------------------------------------------------------------------------}
+
+instance Show Bool
+
+instance Show a => Show (Maybe a)
+
+instance (Show a, Show b) => Show (Either a b)
+
+instance Show a => Show (Identity a)
+
+{-------------------------------------------------------------------------------
+  Rendering proper
+-------------------------------------------------------------------------------}
+
+render ::
+     Bool -- ^ Are we in a context that may require brackets?
+  -> Value -> String
+render = \contextNeedsBrackets ->
+      Text.Lazy.unpack
+    . B.toLazyText
+    . intercalate "\n"
+    . NE.toList
+    . go contextNeedsBrackets
+  where
+    go :: Bool -> Value -> NonEmpty Builder
+    go contextneedsBrackets val =
+        bracketIf (contextneedsBrackets && requiresBrackets val) $
+          case val of
+            Integral x     -> simple $ addNumericUnderscores (Prelude.show x)
+            String x       -> simple $ Prelude.show x
+            Constr c ts xs -> renderComposite (compositeConstr c ts) $
+                                map (go True) xs
+            List xs        -> renderComposite compositeList $
+                                map (go False) xs
+            Tuple xs       -> renderComposite compositeTuple $
+                                map (go False) xs
+            Record r xs    -> renderComposite (compositeHaskellRecord r) $
+                                map (uncurry goField . second (go False)) xs
+            QuasiQ qq str  -> renderComposite (compositeQuasiQ qq) [str]
+            JSON json      -> go contextneedsBrackets $ QuasiQ "aesonQQ" $
+                                renderJSON json
+            PreludeShow x  -> NE.fromList . map B.fromString $
+                                lines (Prelude.showsPrec appPrec x "")
+
+    simple :: String -> NonEmpty Builder
+    simple = pure . B.fromString
+
+    goField :: String -> NonEmpty Builder -> NonEmpty Builder
+    goField field (firstLine :| rest) =
+           (B.fromString field <> " = " <> firstLine)
+        :| indent rest
+
+    bracketIf :: Bool -> NonEmpty Builder -> NonEmpty Builder
+    bracketIf False = id
+    bracketIf True  = \case
+        oneLine   :| []   -> ("(" <> oneLine <> ")") :| []
+        firstLine :| rest -> ("( " <> firstLine) :| concat [
+              indent rest
+            , [")"]
+            ]
+
+renderJSON :: Aeson.Value -> NonEmpty Builder
+renderJSON = go
+  where
+    go :: Aeson.Value -> NonEmpty Builder
+    go (Aeson.Object xs) = renderComposite compositeJsonRecord $
+                             map (uncurry goField . second go) $
+                               Aeson.KeyMap.toList xs
+    go (Aeson.Array xs)  = renderComposite compositeList $
+                             map go $
+                               Vector.toList xs
+    go val               = Aeson.encodeToTextBuilder val :| []
+
+    goField :: Aeson.KeyMap.Key -> NonEmpty Builder -> NonEmpty Builder
+    goField key (firstLine :| rest) =
+           B.fromString (Prelude.show key) <> ": " <> firstLine
+        :| map ("  " <>) rest
+
+-- | Does this value require brackets when shown?
+--
+-- Of course, these brackets will only be necessary if the context demands them.
+requiresBrackets :: Value -> Bool
+requiresBrackets = \case
+    Constr _ ts xs -> not (null ts) || not (null xs)
+    _otherwise     -> False
+
+{-------------------------------------------------------------------------------
+  Internal: rendering composite values
+-------------------------------------------------------------------------------}
+
+data Composite = Composite {
+      -- | Header (e.g. record name, type applications, ..)
+      compositeHeader :: Maybe Text
+
+      -- | Prefix (e.g. @{@ or @(@)
+    , compositePrefix :: Maybe Text
+
+      -- | Suffix (e.g, @}@ or @)@)
+    , compositeSuffix :: Maybe Text
+
+      -- | Element separator (e.g. @,@)
+    , compositeSeparator :: Char
+
+      -- | Should elements be shown on one line?
+      --
+      -- By default, this is true only if there is only a single element,
+      -- and that element is itself only one line.
+    , compositeOneLine :: [NonEmpty Builder] -> Maybe [Builder]
+    }
+
+instance Default Composite where
+  def = Composite {
+      compositeHeader    = Nothing
+    , compositePrefix    = Nothing
+    , compositeSuffix    = Nothing
+    , compositeSeparator = ','
+    , compositeOneLine   = \case
+                             [firstLine :| []] -> Just [firstLine]
+                             _otherwise        -> Nothing
+    }
+
+compositeList :: Composite
+compositeList = def {
+      compositePrefix  = Just "["
+    , compositeSuffix  = Just "]"
+    , compositeOneLine = \rs -> do
+        xs <- mapM isOneLine rs
+
+        let argLengths :: [Int64]
+            argLengths = map (Text.Lazy.length . B.toLazyText) xs
+        guard $ or [
+            sum argLengths < 80
+          , all (<= 5) argLengths
+          ]
+
+        return xs
+    }
+  where
+    isOneLine :: NonEmpty a -> Maybe a
+    isOneLine (firstLine :| []) = Just firstLine
+    isOneLine _otherwise        = Nothing
+
+compositeTuple :: Composite
+compositeTuple = def {
+      compositePrefix = Just "("
+    , compositeSuffix = Just ")"
+    }
+
+compositeConstr :: Text -> [TypeRep] -> Composite
+compositeConstr c ts = def {
+      compositeSeparator = ' '
+    , compositeHeader    = Just $ intercalate " " $ c : map typeApp ts
+    }
+  where
+    -- We are careful to insert brackets around the typerep if needed
+    typeApp :: TypeRep -> Text
+    typeApp typ = "@" <> Text.pack (Prelude.showsPrec appPrec typ [])
+
+compositeHaskellRecord :: Text -> Composite
+compositeHaskellRecord r = def {
+      compositeHeader  = Just $ r
+    , compositePrefix  = Just $ "{"
+    , compositeSuffix  = Just $ "}"
+    , compositeOneLine = const Nothing
+    }
+
+compositeJsonRecord :: Composite
+compositeJsonRecord = def {
+      compositePrefix = Just $ "{"
+    , compositeSuffix = Just $ "}"
+    , compositeOneLine = const Nothing
+    }
+
+compositeQuasiQ :: Text -> Composite
+compositeQuasiQ qq = def {
+      compositePrefix  = Just $ "[" <> qq <> "|"
+    , compositeSuffix  = Just $ "|]"
+    }
+
+-- | Render composite value
+renderComposite :: Composite -> [NonEmpty Builder] -> NonEmpty Builder
+renderComposite Composite{..} =
+    go
+  where
+    go :: [NonEmpty Builder] -> NonEmpty Builder
+    go rs
+      | Just xs <- compositeOneLine rs
+      = pure $ mconcat [
+           prefix
+         , intercalate (B.singleton compositeSeparator) xs
+         , maybe mempty B.fromText compositeSuffix
+         ]
+
+      | otherwise
+      =    prefix
+        :| concat [
+               concatMap NE.toList $ sepElemsBy compositeSeparator rs
+             , [B.fromText suffix | Just suffix <- [compositeSuffix]]
+             ]
+
+    prefix :: Builder
+    prefix = mconcat [
+                 maybe mempty (\hdr -> B.fromText hdr <> " ") compositeHeader
+               , maybe mempty B.fromText compositePrefix
+               ]
+
+    sepElemsBy :: Char -> [NonEmpty Builder] -> [NonEmpty Builder]
+    sepElemsBy sep = zipWith aux (True : repeat False)
+      where
+        aux :: Bool -> NonEmpty Builder -> NonEmpty Builder
+        aux firstEntry (firstLine :| rest) =
+               ( if firstEntry
+                   then (B.singleton ' ' <> B.singleton ' ' <> firstLine)
+                   else (B.singleton sep <> B.singleton ' ' <> firstLine)
+               )
+            :| indent rest
+
+{-------------------------------------------------------------------------------
+  Rendering auxiliary
+-------------------------------------------------------------------------------}
+
+indent :: [Builder] -> [Builder]
+indent = map (B.fromText "  " <>)
+
+addNumericUnderscores :: String -> String
+addNumericUnderscores =
+      reverse
+    . aux
+    . reverse
+  where
+    aux :: String -> String
+    aux str =
+        case splitAt 3 str of
+          (_          , []  ) -> str
+          (firstThree , rest) -> firstThree ++ "_" ++ aux rest
+
+-- | Generation of @intercalate@ from the Prelude
+intercalate :: Monoid a => a -> [a] -> a
+intercalate x = mconcat . intersperse x

src/Data/Structured/TH.hs

@@ -0,0 +1,96 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Data.Structured.TH (
+    deriveInstance
+  ) where
+
+import qualified Data.Structured as Structured
+import qualified Data.Text       as Text
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Datatype
+
+-- | Derive 'Show' instance
+--
+-- Normally TH is not required, and you can rely on generics instead. However,
+-- in some cases TH is the only option; for example, this is the case when
+-- deriving a 'Show' instance for a GADT.
+--
+-- Example usage:
+--
+-- > Structured.deriveInstance 'ConstrOfMyType [t|
+-- >     forall a. Structured.Show a => Structured.Show (MyType a)
+-- >   |]
+--
+-- All type variables must be explicitly quantified (use an empty forall if
+-- there are none), and any required constraints must be explicitly listed. In
+-- addition, one of the constructors of @MyType@ must be listed (this is used to
+-- resolve the datatype, ensuring that it works with regular datatypes as well
+-- as associated datatypes).
+deriveInstance :: Name -> Q Type -> Q [Dec]
+deriveInstance constr header = do
+    info        <- reifyDatatype constr
+    (ctxt, rhs) <- parseHeader =<< header
+    (:[]) <$>
+      instanceD
+        (return ctxt)
+        (return rhs)
+        [ funD 'Structured.toValue $ map caseFor (datatypeCons info)
+        ]
+
+-- | Parse instance header
+parseHeader :: Type -> Q (Cxt, Type)
+parseHeader = \case
+      ForallT _bndrs ctxt rhs@(AppT (ConT nameShow) _)
+        | nameShow == ''Structured.Show
+        -> return (ctxt, rhs)
+      _otherwise ->
+        fail $ "Invalid header"
+
+-- | Case for one of the constructors
+caseFor :: ConstructorInfo -> Q Clause
+caseFor ConstructorInfo{
+            constructorName    = con
+          , constructorFields  = fields
+          , constructorVariant = variant
+          } = do
+    args <- mapM (const $ newName "x") fields
+    clause
+         [conP con (map varP args)]
+         ( normalB $
+             case variant of
+               RecordConstructor fieldNames -> record fieldNames args
+               _otherwise                   -> constr            args
+         )
+         []
+  where
+    -- Regular (non-record) constructor
+    constr :: [Name] -> ExpQ
+    constr args = appsE [
+          conE 'Structured.Constr
+        ,   varE 'Text.pack
+          `appE`
+            litE (StringL (nameBase con))
+        , listE [] -- We do not support any type applications
+        , listE $
+            map
+              (\x -> varE 'Structured.toValue `appE` varE x)
+              args
+        ]
+
+    record :: [Name] -> [Name] -> ExpQ
+    record fieldNames args = appsE [
+          conE 'Structured.Record
+        ,   varE 'Text.pack
+          `appE`
+            litE (StringL (nameBase con))
+        , listE $
+            zipWith
+              (\f x -> tupE [
+                  litE (StringL (nameBase f))
+                , varE 'Structured.toValue `appE` varE x
+                ]
+              )
+              fieldNames
+              args
+        ]

src/Foreign/Rust/External/Bincode.hs

@@ -0,0 +1,34 @@
+-- | External (Rust-side) Bincode serialisation/deserialisation
+--
+-- Intended for qualified import.
+--
+-- > import qualified Foreign.Rust.External.Bincode as External
+module Foreign.Rust.External.Bincode (
+    -- * Serialisation
+    Bincode(..)
+  , ToBincode(..)
+  , FromBincode(..)
+  ) where
+
+import Codec.Borsh
+
+import qualified Data.ByteString.Lazy as Lazy
+
+import Foreign.Rust.Serialisation.Raw
+
+{-------------------------------------------------------------------------------
+  Serialisation
+-------------------------------------------------------------------------------}
+
+newtype Bincode = Bincode Lazy.ByteString
+  deriving stock (Eq)
+  deriving newtype (BorshSize, ToBorsh, FromBorsh)
+  deriving newtype (IsRaw)
+
+-- | Types with an external Bincode serialiser (typically, in Rust)
+class ToBincode a where
+  toBincode :: a -> Bincode
+
+-- | Types with an external Bincode deserialiser (typically, in Rust)
+class FromBincode a where
+  fromBincode :: Bincode -> Either String a

src/Foreign/Rust/External/JSON.hs

@@ -0,0 +1,72 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | External (Rust-side) JSON serialisation/deserialisation
+--
+-- Intended for qualified import.
+--
+-- > import Foreign.Rust.External.JSON (UseExternalJSON, ShowAsJSON)
+-- > import qualified Foreign.Rust.External.JSON as External
+module Foreign.Rust.External.JSON (
+    -- * Serialisation
+    JSON(..)
+  , ToJSON(..)
+  , FromJSON(..)
+    -- * Deriving-via: derive Aeson instances using external (de)serialiser
+  , UseExternalJSON(..)
+  ) where
+
+import Codec.Borsh
+
+import qualified Data.Aeson           as Aeson
+import qualified Data.Aeson.Encoding  as Aeson (unsafeToEncoding)
+import qualified Data.Aeson.Types     as Aeson (parseFail)
+import qualified Data.Binary.Builder  as Binary
+import qualified Data.ByteString.Lazy as Lazy (ByteString)
+
+{-------------------------------------------------------------------------------
+  Serialisation
+-------------------------------------------------------------------------------}
+
+-- | Serialised JSON
+newtype JSON = JSON Lazy.ByteString
+  deriving stock (Eq)
+  deriving newtype (BorshSize, ToBorsh, FromBorsh)
+
+-- | Types with an external JSON renderer (typically, in Rust)
+class ToJSON a where
+  toJSON :: a -> JSON
+
+-- | Types with an external JSON parser (typically, in Rust)
+class FromJSON a where
+  fromJSON :: JSON -> Either String a
+
+{-------------------------------------------------------------------------------
+  Deriving-via: derive Aeson instances using external (de)serialiser
+-------------------------------------------------------------------------------}
+
+newtype UseExternalJSON a = UseExternalJSON a
+
+instance ToJSON a => Aeson.ToJSON (UseExternalJSON a) where
+  toJSON (UseExternalJSON x) =
+      reparse (toJSON x)
+    where
+      -- We get serialised JSON from the external renderer, and then need to
+      -- re-parse that to a 'Value'. If this fails, however, it would mean that
+      -- the Rust-side generated invalid JSON.
+      reparse :: JSON -> Aeson.Value
+      reparse (JSON bs) =
+          case Aeson.eitherDecode bs of
+            Left  err -> error err
+            Right val -> val
+
+  -- This relies on 'toJSON' generating valid JSON
+  toEncoding (UseExternalJSON x) =
+      case toJSON x of
+        JSON bs -> Aeson.unsafeToEncoding $ Binary.fromLazyByteString bs
+
+instance FromJSON a => Aeson.FromJSON (UseExternalJSON a) where
+  parseJSON val =
+      case fromJSON (JSON (Aeson.encode val)) of
+        Left failure -> Aeson.parseFail failure
+        Right tx     -> return $ UseExternalJSON tx
+

src/Foreign/Rust/Failure.hs

@@ -0,0 +1,27 @@
+module Foreign.Rust.Failure (
+    Failure -- Opaque
+  , failureMessage
+  , mkFailure
+  ) where
+
+import GHC.Stack
+import Data.Text (Text)
+
+-- | Failure reported by a Rust function
+--
+-- TODO: For some cases we might be able to attach a Rust callstack, too.
+data Failure = Failure {
+      failureMessage :: Text
+    , failureCallstackHaskell :: PrettyCallStack
+    }
+  deriving (Show)
+
+mkFailure :: HasCallStack => Text -> Failure
+mkFailure e = Failure e (PrettyCallStack callStack)
+
+newtype PrettyCallStack = PrettyCallStack CallStack
+
+instance Show PrettyCallStack where
+  show (PrettyCallStack stack) = prettyCallStack stack
+
+

src/Foreign/Rust/Marshall/Fixed.hs

@@ -0,0 +1,55 @@
+{-# OPTIONS_GHC -Wno-redundant-constraints #-}
+
+-- | Marshalling to and from Rust, using Borsh
+--
+-- This module deals with types with fixed sized encodings.
+-- See also "Foreign.Rust.Marshall.Variable".
+module Foreign.Rust.Marshall.Fixed (
+    -- * Haskell to Rust
+    toBorshFixed
+    -- * Rust to Haskell
+  , allocFixedBuffer
+  , fromBorshFixed
+  ) where
+
+import Codec.Borsh
+import Data.Proxy
+import Data.Typeable (Typeable)
+import Foreign
+import Foreign.C.Types
+
+import qualified Data.ByteString as Strict
+
+import Foreign.Rust.Marshall.Util
+
+{-------------------------------------------------------------------------------
+  Haskell to Rust
+-------------------------------------------------------------------------------}
+
+toBorshFixed ::
+     (ToBorsh a, StaticBorshSize a ~ 'HasKnownSize)
+  => a -> ((Ptr CUChar, CULong) -> IO r) -> IO r
+toBorshFixed a k =
+    Strict.useAsCStringLen (serialiseStrict a) (k . castFromSignedLen)
+
+{-------------------------------------------------------------------------------
+  Rust to Haskell
+-------------------------------------------------------------------------------}
+
+allocFixedBuffer :: forall a.
+     (BorshSize a, StaticBorshSize a ~ 'HasKnownSize)
+  => ((Ptr CUChar, CULong) -> IO a) -> IO a
+allocFixedBuffer k =
+    case borshSize (Proxy @a) of
+      SizeKnown n ->
+        allocaBytes (cast n) $ \ptr -> k (ptr, fromIntegral n)
+  where
+    cast :: Word32 -> Int
+    cast = fromIntegral
+
+fromBorshFixed ::
+     (FromBorsh a, StaticBorshSize a ~ 'HasKnownSize, Typeable a)
+  => Ptr CUChar -> CULong -> IO a
+fromBorshFixed ptr len =
+    deserialiseStrictOrPanic <$>
+      Strict.packCStringLen (castToSigned ptr, fromIntegral len)

src/Foreign/Rust/Marshall/Util.hs

@@ -0,0 +1,58 @@
+module Foreign.Rust.Marshall.Util (
+    -- * Borsh
+    serialiseStrict
+  , deserialiseStrictOrPanic
+  , deserialiseLazyOrPanic
+    -- * Casting
+  , castFromSigned
+  , castToSigned
+  , castFromSignedLen
+  ) where
+
+import Codec.Borsh
+import Data.Typeable
+import Foreign
+import Foreign.C
+import GHC.Stack
+
+import qualified Data.ByteString      as Strict
+import qualified Data.ByteString.Lazy as Lazy
+
+{-------------------------------------------------------------------------------
+  Borsh
+-------------------------------------------------------------------------------}
+
+serialiseStrict :: ToBorsh a => a -> Strict.ByteString
+serialiseStrict = Lazy.toStrict . serialiseBorsh
+
+deserialiseStrictOrPanic ::
+      (HasCallStack, FromBorsh a, Typeable a)
+   => Strict.ByteString -> a
+deserialiseStrictOrPanic = deserialiseLazyOrPanic . Lazy.fromStrict
+
+deserialiseLazyOrPanic :: forall a.
+     (HasCallStack, FromBorsh a, Typeable a)
+  => Lazy.ByteString -> a
+deserialiseLazyOrPanic bs =
+    case deserialiseBorsh bs of
+      Right a  -> a
+      Left err -> error $ concat [
+          "deserialiseLazyOrPanic for " ++ show (typeOf (Proxy @a)) ++ ": "
+        , show err ++ "\n"
+        , "buffer: " ++ show (Lazy.unpack bs)
+        , " (" ++ show (Lazy.length bs) ++ ")"
+        ]
+
+{-------------------------------------------------------------------------------
+  Casting
+-------------------------------------------------------------------------------}
+
+castFromSigned :: Ptr CChar -> Ptr CUChar
+castFromSigned = castPtr
+
+castToSigned :: Ptr CUChar -> Ptr CChar
+castToSigned = castPtr
+
+castFromSignedLen :: (Ptr CChar, Int) -> (Ptr CUChar, CULong)
+castFromSignedLen (ptr, len) = (castFromSigned ptr, fromIntegral len)
+

src/Foreign/Rust/Marshall/Variable.hs

@@ -0,0 +1,141 @@
+{-# OPTIONS_GHC -Wno-redundant-constraints #-}
+
+-- | Marshalling to and from Rust, using Borsh
+--
+-- This module deals with types with variable sized encodings.
+-- See also "Foreign.Rust.Marshall.Fixed".
+module Foreign.Rust.Marshall.Variable (
+    -- * Haskell to Rust
+    toBorshVar
+    -- * Rust to Haskell
+  , Buffer -- opaque
+  , getVarBuffer
+  , withBorshVarBuffer
+  , withBorshMaxBuffer
+  , withBorshFailure
+  ) where
+
+import Codec.Borsh
+import Data.Bifunctor
+import Data.Text (Text)
+import Data.Typeable
+import Foreign
+import Foreign.C.Types
+import GHC.Stack
+import System.IO.Unsafe (unsafePerformIO)
+
+import qualified Data.ByteString as Strict
+
+import Foreign.Rust.Marshall.Util
+import Foreign.Rust.Failure
+
+{-------------------------------------------------------------------------------
+  Haskell to Rust
+-------------------------------------------------------------------------------}
+
+toBorshVar ::
+     (ToBorsh a, StaticBorshSize a ~ 'HasVariableSize)
+  => a -> ((Ptr CUChar, CULong) -> IO r) -> IO r
+toBorshVar a k =
+    Strict.useAsCStringLen (serialiseStrict a) (k . castFromSignedLen)
+
+{-------------------------------------------------------------------------------
+  Rust to Haskell
+-------------------------------------------------------------------------------}
+
+-- | Buffer containing value of (phantom) type @a@
+data Buffer a = Buffer (Ptr CUChar) (Ptr CULong)
+
+getVarBuffer :: Buffer a -> (Ptr CUChar, Ptr CULong)
+getVarBuffer (Buffer buf ptrSize) = (buf, ptrSize)
+
+-- | Provide buffer for foreign call
+--
+-- We start with an initial buffer of 1 kB. If that suffices, we copy the
+-- (appropriate part of) the buffer to a ByteString and we're done. If not,
+-- the foreign call will tell us what the required buffer size is, so we
+-- try again with a larger buffer.
+--
+-- We allocate these buffers on the Haskell heap ('allocaBytes'), not the C
+-- heap ('malloc'). This ensures that these buffers are visible to Haskell
+-- profiling tools, and also appears to be more reliable on OSX. A slight
+-- downside is that it doesn't give us a way to /change/ the size of a buffer,
+-- but that's not an essential feature.
+withBorshVarBuffer :: forall a.
+     ( FromBorsh a
+     , StaticBorshSize a ~ 'HasVariableSize
+     , Typeable a
+     )
+  => (Buffer a -> IO ()) -> a
+withBorshVarBuffer = withBorshBufferOfInitSize 1024
+
+withBorshMaxBuffer :: forall a.
+     ( FromBorsh a
+     , StaticBorshSize a ~ 'HasVariableSize
+     , BorshMaxSize a
+     , Typeable a
+     )
+  => (Buffer a -> IO ()) -> a
+withBorshMaxBuffer =
+   withBorshBufferOfInitSize initBufSize
+  where
+    initBufSize :: CULong
+    initBufSize = fromIntegral $ borshMaxSize (Proxy @a)
+
+-- | Wrapper around 'withBorshVarBuffer' with explicit support for failures
+withBorshFailure :: forall a.
+     ( FromBorsh a
+     , StaticBorshSize a ~ 'HasVariableSize
+     , Typeable a
+     , HasCallStack
+     )
+  => (Buffer (Either Text a) -> IO ()) -> Either Failure a
+withBorshFailure = first mkFailure . withBorshVarBuffer
+
+{-------------------------------------------------------------------------------
+  Internal auxiliary
+-------------------------------------------------------------------------------}
+
+-- | Generalization of 'withBorshVarBuffer' and 'withMaxBorshBuffer'
+withBorshBufferOfInitSize :: forall a.
+     ( FromBorsh a
+     , StaticBorshSize a ~ 'HasVariableSize
+     , Typeable a
+     )
+  => CULong -> (Buffer a -> IO ()) -> a
+withBorshBufferOfInitSize initBufSize f = unsafePerformIO $ do
+    mFirstAttempt <- allocaBytes (culongToInt initBufSize) $ \buf -> do
+      (bigEnough, reqSz) <- callWithSize buf initBufSize
+      if bigEnough then
+        Right . deserialiseStrictOrPanic <$>
+          Strict.packCStringLen (castPtr buf, culongToInt reqSz)
+      else
+        return $ Left reqSz
+    case mFirstAttempt of
+      Right r ->
+        return r
+      Left reqSz -> do
+        allocaBytes (culongToInt reqSz) $ \buf -> do
+          (bigEnough, reqSz') <- callWithSize buf reqSz
+          if bigEnough && reqSz == reqSz' then
+            deserialiseStrictOrPanic <$>
+              Strict.packCStringLen (castPtr buf, culongToInt reqSz)
+          else
+            fail $ concat [
+                "withBorshVarBuffer: unexpected change in required buffer size. "
+              , "was " ++ show reqSz  ++ ", "
+              , "now " ++ show reqSz' ++ "."
+              ]
+  where
+    -- Call the function with the current buffer size
+    -- Returns whether or not the buffer was big enough, and the required size
+    callWithSize :: Ptr CUChar -> CULong -> IO (Bool, CULong)
+    callWithSize buf providedSize = alloca $ \ptrBufSize -> do
+        poke ptrBufSize providedSize
+        f $ Buffer buf ptrBufSize
+        requiredSize <- peek ptrBufSize
+        return (requiredSize <= providedSize, requiredSize)
+
+    -- Buffer allocations should not take a signed 'Int' as argument 🙄
+    culongToInt :: CULong -> Int
+    culongToInt = fromIntegral

src/Foreign/Rust/SafeConv.hs

@@ -0,0 +1,18 @@
+module Foreign.Rust.SafeConv (
+    SafeConv(..)
+  ) where
+
+import Data.Word
+import Foreign.C.Types
+
+class SafeConv a b where
+  safeConvFrom :: a -> b
+  safeConvTo   :: b -> a
+
+instance SafeConv CULong Word64 where
+  safeConvFrom = fromIntegral
+  safeConvTo   = fromIntegral
+
+instance SafeConv CULLong Word64 where
+  safeConvFrom = fromIntegral
+  safeConvTo   = fromIntegral

src/Foreign/Rust/Serialisation/JSON.hs

@@ -0,0 +1,59 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Serialise opaque types using JSON
+--
+-- See "Foreign.Rust.Serialisation.Raw" for detailed discussion.
+module Foreign.Rust.Serialisation.JSON (
+    -- * Deriving-via support
+    AsJSON(..)
+    -- * Show instance
+  , asJSON
+  ) where
+
+import Data.Annotated
+import Data.Aeson (FromJSON(..))
+import Data.Typeable
+
+import qualified Data.Aeson.Types as Aeson
+import qualified Data.Structured  as Structured
+
+{-------------------------------------------------------------------------------
+  Deriving-via combinator
+-------------------------------------------------------------------------------}
+
+-- | Serialise using JSON
+--
+-- The 'Show' instance will produce something like
+--
+-- > asJSON @UsesJSON
+-- >   [aesonQQ|
+-- >     {
+-- >       "a": null
+-- >     , "b": [1,2,3]
+-- >     }
+-- >   |]
+--
+-- This depends on 'asJSON' (defined in this module), @QuasiQuotes@ and
+-- "Data.Aeson.QQ.Simple".
+--
+-- NOTE: 'Annotated' instance is only useful when using 'AsBase64' directly
+-- (rather than using deriving-via).
+newtype AsJSON a = AsJSON { unwrapAsJSON :: a }
+  deriving newtype CanAnnotate
+
+{-------------------------------------------------------------------------------
+  Show
+-------------------------------------------------------------------------------}
+
+deriving
+  via Structured.ToPreludeShow (AsJSON a)
+  instance (Typeable a, Aeson.ToJSON a) => Show (AsJSON a)
+
+instance (Typeable a, Aeson.ToJSON a) => Structured.Show (AsJSON a) where
+  toValue (AsJSON x) =
+      Structured.Constr "asJSON" [typeRep (Proxy @a)] [
+          Structured.JSON (Aeson.toJSON x)
+        ]
+
+asJSON :: forall a. FromJSON a => Aeson.Value -> a
+asJSON = either error id . Aeson.parseEither Aeson.parseJSON

src/Foreign/Rust/Serialisation/Raw.hs

@@ -0,0 +1,107 @@
+-- | Dealing with types that are represented in raw form Haskell side
+module Foreign.Rust.Serialisation.Raw (
+    IsRaw(..)
+  ) where
+
+import Data.FixedSizeArray (FixedSizeArray)
+import Data.Proxy
+import Data.Word
+import GHC.TypeLits
+
+import qualified Data.ByteString      as Strict
+import qualified Data.ByteString.Lazy as Lazy
+import qualified Data.FixedSizeArray  as FSA
+import qualified Data.Vector.Generic  as Vector
+
+{-------------------------------------------------------------------------------
+  Abstract over raw representation
+-------------------------------------------------------------------------------}
+
+-- | Datatype that is represented as raw bytes Haskell-side
+--
+-- Sometimes when dealing with Rust-side values we represent them as opaque
+-- values Haskell side: essentially just a list of bytes. However, we typically
+-- still want to be able to display, serialise and deserialise such values.
+--
+-- 'IsRaw' abstracts over how exactly those raw bytes stored; in the following
+-- modules we then provide deriving-via combinators for specific encodings:
+--
+-- * Foreign.Rust.Serialisation.Raw.Base16 (base-16, hexadecimal, hexdump)
+-- * Foreign.Rust.Serialisation.Raw.Base58 (base-58, bitcoin format)
+-- * Foreign.Rust.Serialisation.Raw.Base64 (base-64)
+-- * Foreign.Rust.Serialisation.Raw.Decimal (list of decimal values)
+--
+-- All of these modules provide combinators to derive
+--
+-- * 'Prelude.Show' and 'Data.Structured.Show' (law-abiding in the sense of
+--   generating valid Haskell)
+-- * 'FromJSON' and 'ToJSON'
+--
+-- All of these modules show the raw bytes, they just differ in /how/ they show
+-- those raw bytes. If you want a more human-readable format, consider using
+-- "Foreign.Rust.Serialisation.JSON".
+class IsRaw a where
+  {-# MINIMAL (toRaw | toBytes), (fromRaw | fromBytes) #-}
+
+  -- rawSize
+
+  rawSize :: a -> Word32
+  rawSize = fromIntegral . Lazy.length . toRaw
+
+  -- toRaw
+
+  toRaw :: a -> Lazy.ByteString
+  toRaw = Lazy.pack . toBytes
+
+  toBytes :: a -> [Word8]
+  toBytes = Lazy.unpack . toRaw
+
+  -- fromRaw
+
+  fromRaw :: Lazy.ByteString -> Either String a
+  fromRaw = fromBytes . Lazy.unpack
+
+  fromBytes :: [Word8] -> Either String a
+  fromBytes = fromRaw . Lazy.pack
+
+
+{-------------------------------------------------------------------------------
+  ByteString
+-------------------------------------------------------------------------------}
+
+instance IsRaw Lazy.ByteString where
+  rawSize = fromIntegral . Lazy.length
+  toRaw   = id
+  fromRaw = Right
+
+instance IsRaw Strict.ByteString where
+  rawSize = fromIntegral . Strict.length
+  toRaw   = Lazy.fromStrict
+  fromRaw = Right . Lazy.toStrict
+
+{-------------------------------------------------------------------------------
+  [Word8]
+-------------------------------------------------------------------------------}
+
+instance IsRaw [Word8] where
+  rawSize   = fromIntegral . length
+  toBytes   = id
+  fromBytes = Right
+
+{-------------------------------------------------------------------------------
+  FixedSizeArray
+-------------------------------------------------------------------------------}
+
+instance KnownNat n => IsRaw (FixedSizeArray n Word8) where
+  rawSize   = const $ fromIntegral $ natVal (Proxy @n)
+  toBytes   = Vector.toList
+  fromBytes = \xs ->
+      let expectedSize, actualSize :: Int
+          expectedSize = fromIntegral $ natVal (Proxy @n)
+          actualSize   = length xs
+      in if actualSize == expectedSize
+           then Right $ FSA.fromList xs
+           else Left $ "Expected " ++ show expectedSize ++ "bytes, "
+                    ++ "but got " ++ show actualSize ++ ": "
+                    ++ show xs
+

src/Foreign/Rust/Serialisation/Raw/Base16.hs

@@ -0,0 +1,83 @@
+-- | Base-16 encoding (hexdump)
+--
+-- See "Foreign.Rust.Serialisation.Raw" for discussion.
+module Foreign.Rust.Serialisation.Raw.Base16 (
+    -- * Deriving-via support
+    AsBase16(..)
+  ) where
+
+import Control.Monad
+import Data.Aeson (ToJSON(..), FromJSON(..), withText)
+import Data.Annotated
+import Data.String
+
+import qualified Data.Aeson.Types            as Aeson
+import qualified Data.ByteString.Base16.Lazy as Base16
+import qualified Data.ByteString.Lazy        as Lazy
+import qualified Data.ByteString.Lazy.Char8  as Char8
+import qualified Data.Structured             as Structured
+import qualified Data.Text                   as Text
+
+import Foreign.Rust.Serialisation.Raw
+
+{-------------------------------------------------------------------------------
+  Deriving-via combinator
+-------------------------------------------------------------------------------}
+
+-- | Show values in base-16 (hexadecimal/hexdump)
+--
+-- The 'Show' instance will produce something like
+--
+-- > "01020304"
+--
+-- This depends on @OverloadedStrings@.
+--
+-- NOTE: 'Annotated' instance is only useful when using 'AsBase16' directly
+-- (rather than using deriving-via).
+newtype AsBase16 a = AsBase16 { unwrapAsBase16 ::a }
+  deriving newtype CanAnnotate
+
+{-------------------------------------------------------------------------------
+  JSON
+-------------------------------------------------------------------------------}
+
+instance IsRaw a => ToJSON (AsBase16 a) where
+  toJSON = toJSON  . encode . unwrapAsBase16
+
+instance IsRaw a => FromJSON (AsBase16 a) where
+  parseJSON = either Aeson.parseFail (return . AsBase16) . decode <=< parseJSON
+
+{-------------------------------------------------------------------------------
+  Show
+-------------------------------------------------------------------------------}
+
+instance IsRaw a => Show (AsBase16 a) where
+  show = show . encode . unwrapAsBase16
+
+instance IsRaw a => Structured.Show (AsBase16 a) where
+  toValue = Structured.toValue . encode . unwrapAsBase16
+
+instance IsRaw a => IsString (AsBase16 a) where
+  fromString = either error AsBase16 . decode . fromString
+
+{-------------------------------------------------------------------------------
+  Auxiliary: base-16 encoded value
+-------------------------------------------------------------------------------}
+
+newtype Base16 = Base16 { getBase16 :: Lazy.ByteString }
+  deriving newtype (Show, IsString)
+
+instance ToJSON Base16 where
+  toJSON = Aeson.String . Text.pack . Char8.unpack . getBase16
+
+instance FromJSON Base16 where
+  parseJSON = withText "Base16" $ return . Base16 . Char8.pack . Text.unpack
+
+instance Structured.Show Base16 where
+  toValue = Structured.String
+
+encode :: IsRaw a => a -> Base16
+encode = Base16 . Base16.encode . toRaw
+
+decode :: IsRaw a => Base16 -> Either String a
+decode = fromRaw <=< Base16.decode . getBase16

src/Foreign/Rust/Serialisation/Raw/Base58.hs

@@ -0,0 +1,102 @@
+-- | Base-58 encoding
+--
+-- See "Foreign.Rust.Serialisation.Raw" for discussion.
+module Foreign.Rust.Serialisation.Raw.Base58 (
+    -- * Deriving-via support
+    AsBase58(..)
+  ) where
+
+import Control.Monad
+import Data.Aeson (ToJSON(..), FromJSON(..), withText)
+import Data.Annotated
+import Data.String
+
+import qualified Data.Aeson.Types       as Aeson
+import qualified Data.ByteString        as Strict
+import qualified Data.ByteString.Base58 as Base58
+import qualified Data.ByteString.Char8  as Char8
+import qualified Data.ByteString.Lazy   as Lazy
+import qualified Data.Structured        as Structured
+import qualified Data.Text              as Text
+
+import Foreign.Rust.Serialisation.Raw
+
+{-------------------------------------------------------------------------------
+  Deriving-via combinator
+-------------------------------------------------------------------------------}
+
+-- | Serialise using base-58
+--
+-- The 'Show' instance will produce something like
+--
+-- > "2VfUX"
+--
+-- This depends on @OverloadedStrings@.
+--
+-- NOTE: 'Annotated' instance is only useful when using 'AsBase58' directly
+-- (rather than using deriving-via).
+newtype AsBase58 a = AsBase58 { unwrapAsBase58 :: a }
+  deriving newtype CanAnnotate
+
+{-------------------------------------------------------------------------------
+  JSON
+-------------------------------------------------------------------------------}
+
+instance IsRaw a => ToJSON (AsBase58 a) where
+  toJSON = toJSON  . encode . unwrapAsBase58
+
+instance IsRaw a => FromJSON (AsBase58 a) where
+  parseJSON = either Aeson.parseFail (return . AsBase58) . decode <=< parseJSON
+
+{-------------------------------------------------------------------------------
+  Show
+-------------------------------------------------------------------------------}
+
+instance IsRaw a => Show (AsBase58 a) where
+  show = show . encode . unwrapAsBase58
+
+instance IsRaw a => Structured.Show (AsBase58 a) where
+  toValue = Structured.toValue . encode . unwrapAsBase58
+
+instance IsRaw a => IsString (AsBase58 a) where
+  fromString = either error AsBase58 . decode . fromString
+
+{-------------------------------------------------------------------------------
+  Auxiliary: base-58 encoded value
+-------------------------------------------------------------------------------}
+
+-- | Base58-encoded value
+--
+-- NOTE: base-58 is a relatively expensive encoding; in particular, unlike
+-- base-64, base-58 does not make it very easy to process chunks of data
+-- separately. Ideally, it should therefore only be used for a small pieces of
+-- data. For this reason, we use a strict bytestring here.
+newtype Base58 = Base58 { getBase58 :: Strict.ByteString }
+  deriving newtype (Show, IsString)
+
+instance ToJSON Base58 where
+  toJSON = Aeson.String . Text.pack . Char8.unpack . getBase58
+
+instance FromJSON Base58 where
+  parseJSON = withText "Base58" $ return . Base58 . Char8.pack . Text.unpack
+
+instance Structured.Show Base58 where
+  toValue = Structured.String
+
+encode :: IsRaw a => a -> Base58
+encode = Base58 . encodeBitcoin . Lazy.toStrict . toRaw
+
+decode :: IsRaw a => Base58 -> Either String a
+decode = fromRaw <=< fmap Lazy.fromStrict . decodeBitcoin . getBase58
+
+{-------------------------------------------------------------------------------
+  Internal auxiliary
+-------------------------------------------------------------------------------}
+
+encodeBitcoin :: Strict.ByteString -> Strict.ByteString
+encodeBitcoin = Base58.encodeBase58 Base58.bitcoinAlphabet
+
+decodeBitcoin :: Strict.ByteString -> Either String Strict.ByteString
+decodeBitcoin =
+      maybe (Left "invalid Base58 encoding") Right
+    . Base58.decodeBase58 Base58.bitcoinAlphabet

src/Foreign/Rust/Serialisation/Raw/Base64.hs

@@ -0,0 +1,83 @@
+-- | Base-64 encoding
+--
+-- See "Foreign.Rust.Serialisation.Raw" for discussion.
+module Foreign.Rust.Serialisation.Raw.Base64 (
+    -- * Deriving-via support
+    AsBase64(..)
+  ) where
+
+import Control.Monad
+import Data.Aeson (ToJSON(..), FromJSON(..), withText)
+import Data.Annotated
+import Data.String
+
+import qualified Data.Aeson.Types            as Aeson
+import qualified Data.ByteString.Base64.Lazy as Base64
+import qualified Data.ByteString.Lazy        as Lazy
+import qualified Data.ByteString.Lazy.Char8  as Char8
+import qualified Data.Structured             as Structured
+import qualified Data.Text                   as Text
+
+import Foreign.Rust.Serialisation.Raw
+
+{-------------------------------------------------------------------------------
+  Deriving-via combinator
+-------------------------------------------------------------------------------}
+
+-- | Serialise using base-64
+--
+-- The 'Show' instance will produce something like
+--
+-- > "AQIDBA=="
+--
+-- This depends on @OverloadedStrings@.
+--
+-- NOTE: 'Annotated' instance is only useful when using 'AsBase64' directly
+-- (rather than using deriving-via).
+newtype AsBase64 a = AsBase64 { unwrapAsBase64 :: a }
+  deriving newtype CanAnnotate
+
+{-------------------------------------------------------------------------------
+  JSON
+-------------------------------------------------------------------------------}
+
+instance IsRaw a => ToJSON (AsBase64 a) where
+  toJSON = toJSON  . encode . unwrapAsBase64
+
+instance IsRaw a => FromJSON (AsBase64 a) where
+  parseJSON = either Aeson.parseFail (return . AsBase64) . decode <=< parseJSON
+
+{-------------------------------------------------------------------------------
+  Show
+-------------------------------------------------------------------------------}
+
+instance IsRaw a => Show (AsBase64 a) where
+  show = show . encode . unwrapAsBase64
+
+instance IsRaw a => Structured.Show (AsBase64 a) where
+  toValue = Structured.toValue . encode . unwrapAsBase64
+
+instance IsRaw a => IsString (AsBase64 a) where
+  fromString = either error AsBase64 . decode . fromString
+
+{-------------------------------------------------------------------------------
+  Auxiliary: base-64 encoded value
+-------------------------------------------------------------------------------}
+
+newtype Base64 = Base64 { getBase64 :: Lazy.ByteString }
+  deriving newtype (Show, IsString)
+
+instance ToJSON Base64 where
+  toJSON = Aeson.String . Text.pack . Char8.unpack . getBase64
+
+instance FromJSON Base64 where
+  parseJSON = withText "Base64" $ return . Base64 . Char8.pack . Text.unpack
+
+instance Structured.Show Base64 where
+  toValue = Structured.String
+
+encode :: IsRaw a => a -> Base64
+encode = Base64 . Base64.encode . toRaw
+
+decode :: IsRaw a => Base64 -> Either String a
+decode = fromRaw <=< Base64.decode . getBase64

src/Foreign/Rust/Serialisation/Raw/Decimal.hs

@@ -0,0 +1,61 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | List of decimal values
+--
+-- See "Foreign.Rust.Serialisation.Raw" for discussion.
+module Foreign.Rust.Serialisation.Raw.Decimal (
+    -- * Deriving-via support
+    AsDecimal(..)
+    -- * Show instance
+  , asDecimal
+  ) where
+
+import Control.Monad
+import Data.Aeson
+import Data.Aeson.Types
+import Data.Typeable
+import Data.Word
+
+import qualified Data.Structured as Structured
+
+import Foreign.Rust.Serialisation.Raw
+
+{-------------------------------------------------------------------------------
+  Deriving-via combinator
+-------------------------------------------------------------------------------}
+
+-- | Serialise to list of decimal values
+--
+-- The 'Show' instance will produce something like
+--
+-- > asDecimal @MyType [1,2,3,4]
+--
+-- This depends on 'asDecimal' (defined in this module).
+newtype AsDecimal a = AsDecimal { unwrapAsDecimal :: a }
+
+{-------------------------------------------------------------------------------
+  JSON
+-------------------------------------------------------------------------------}
+
+instance IsRaw a => ToJSON (AsDecimal a) where
+  toJSON = toJSON . toBytes . unwrapAsDecimal
+
+instance IsRaw a => FromJSON (AsDecimal a) where
+  parseJSON = either parseFail (return . AsDecimal) . fromBytes <=< parseJSON
+
+{-------------------------------------------------------------------------------
+  Show
+-------------------------------------------------------------------------------}
+
+deriving
+  via Structured.ToPreludeShow (AsDecimal a)
+  instance (Typeable a, IsRaw a) => Show (AsDecimal a)
+
+instance (Typeable a, IsRaw a) => Structured.Show (AsDecimal a) where
+  toValue (AsDecimal x) =
+      Structured.Constr "asDecimal" [typeRep (Proxy @a)] [
+          Structured.toValue (toBytes x)
+        ]
+
+asDecimal :: IsRaw a => [Word8] -> a
+asDecimal = either error id . fromBytes

test/Main.hs

@@ -0,0 +1,18 @@
+module Main (main) where
+
+import Test.Tasty
+
+import qualified Test.Serialisation.JSON
+import qualified Test.Serialisation.Raw.Base16
+import qualified Test.Serialisation.Raw.Base58
+import qualified Test.Serialisation.Raw.Base64
+import qualified Test.Serialisation.Raw.Decimal
+
+main :: IO ()
+main = defaultMain $ testGroup "foreign-rust" [
+      Test.Serialisation.JSON.tests
+    , Test.Serialisation.Raw.Base16.tests
+    , Test.Serialisation.Raw.Base58.tests
+    , Test.Serialisation.Raw.Base64.tests
+    , Test.Serialisation.Raw.Decimal.tests
+    ]

test/Test/Serialisation/JSON.hs

@@ -0,0 +1,27 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Test.Serialisation.JSON (tests) where
+
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import Test.Serialisation.Types
+import Test.Util.TH
+
+import Foreign.Rust.Serialisation.JSON (asJSON)
+
+tests :: TestTree
+tests = testGroup "Test.Serialisation.JSON" [
+      testCase "show"       test_show
+    , testCase "structured" test_structured
+    ]
+
+test_show :: Assertion
+test_show =
+    assertEqual "" exampleUsesJSON $
+      $(reparseShow exampleUsesJSON)
+
+test_structured :: Assertion
+test_structured =
+    assertEqual "" exampleUsesJSON $
+      $(reparseStructured exampleUsesJSON)

test/Test/Serialisation/Raw/Base16.hs

@@ -0,0 +1,33 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Test.Serialisation.Raw.Base16 (tests) where
+
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import qualified Data.Aeson as Aeson
+
+import Test.Serialisation.Types
+import Test.Util.TH
+
+tests :: TestTree
+tests = testGroup "Test.Serialisation.Raw.Base16" [
+      testCase "show"       test_show
+    , testCase "structured" test_structured
+    , testCase "json"       test_json
+    ]
+
+test_show :: Assertion
+test_show =
+    assertEqual "" exampleUsesBase16 $
+      $(reparseShow exampleUsesBase16)
+
+test_structured :: Assertion
+test_structured =
+    assertEqual "" exampleUsesBase16 $
+      $(reparseStructured exampleUsesBase16)
+
+test_json :: Assertion
+test_json =
+    assertEqual "" (Right exampleUsesBase16) $
+      Aeson.eitherDecode $ Aeson.encode exampleUsesBase16

test/Test/Serialisation/Raw/Base58.hs

@@ -0,0 +1,33 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Test.Serialisation.Raw.Base58 (tests) where
+
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import qualified Data.Aeson as Aeson
+
+import Test.Serialisation.Types
+import Test.Util.TH
+
+tests :: TestTree
+tests = testGroup "Test.Serialisation.Raw.Base58" [
+      testCase "show"       test_show
+    , testCase "structured" test_structured
+    , testCase "json"       test_json
+    ]
+
+test_show :: Assertion
+test_show =
+    assertEqual "" exampleUsesBase58 $
+      $(reparseShow exampleUsesBase58)
+
+test_structured :: Assertion
+test_structured =
+    assertEqual "" exampleUsesBase58 $
+      $(reparseStructured exampleUsesBase58)
+
+test_json :: Assertion
+test_json =
+    assertEqual "" (Right exampleUsesBase58) $
+      Aeson.eitherDecode $ Aeson.encode exampleUsesBase58

test/Test/Serialisation/Raw/Base64.hs

@@ -0,0 +1,33 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Test.Serialisation.Raw.Base64 (tests) where
+
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import qualified Data.Aeson as Aeson
+
+import Test.Serialisation.Types
+import Test.Util.TH
+
+tests :: TestTree
+tests = testGroup "Test.Serialisation.Raw.Base64" [
+      testCase "show"       test_show
+    , testCase "structured" test_structured
+    , testCase "json"       test_json
+    ]
+
+test_show :: Assertion
+test_show =
+    assertEqual "" exampleUsesBase64 $
+      $(reparseShow exampleUsesBase64)
+
+test_structured :: Assertion
+test_structured =
+    assertEqual "" exampleUsesBase64 $
+      $(reparseStructured exampleUsesBase64)
+
+test_json :: Assertion
+test_json =
+    assertEqual "" (Right exampleUsesBase64) $
+      Aeson.eitherDecode $ Aeson.encode exampleUsesBase64

test/Test/Serialisation/Raw/Decimal.hs

@@ -0,0 +1,35 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Test.Serialisation.Raw.Decimal (tests) where
+
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import qualified Data.Aeson as Aeson
+
+import Test.Serialisation.Types
+import Test.Util.TH
+
+import Foreign.Rust.Serialisation.Raw.Decimal (asDecimal)
+
+tests :: TestTree
+tests = testGroup "Test.Serialisation.Raw.Decimal" [
+      testCase "show"       test_show
+    , testCase "structured" test_structured
+    , testCase "json"       test_json
+    ]
+
+test_show :: Assertion
+test_show =
+    assertEqual "" exampleUsesDecimal $
+      $(reparseShow exampleUsesDecimal)
+
+test_structured :: Assertion
+test_structured =
+    assertEqual "" exampleUsesDecimal $
+      $(reparseStructured exampleUsesDecimal)
+
+test_json :: Assertion
+test_json =
+    assertEqual "" (Right exampleUsesDecimal) $
+      Aeson.eitherDecode $ Aeson.encode exampleUsesDecimal

test/Test/Serialisation/Types.hs

@@ -0,0 +1,99 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+-- | Example types
+--
+-- Defined as separate module to avoid TH stage restrictions
+module Test.Serialisation.Types (
+    UsesDecimal(..)
+  , exampleUsesDecimal
+  , UsesBase16(..)
+  , exampleUsesBase16
+  , UsesBase58(..)
+  , exampleUsesBase58
+  , UsesBase64(..)
+  , exampleUsesBase64
+  , UsesJSON(..)
+  , exampleUsesJSON
+  ) where
+
+import Data.Aeson
+import Data.Aeson.QQ.Simple
+import Data.String
+import Data.Word
+
+import qualified Data.Structured as Structured
+
+import Foreign.Rust.Serialisation.JSON
+import Foreign.Rust.Serialisation.Raw
+import Foreign.Rust.Serialisation.Raw.Base16
+import Foreign.Rust.Serialisation.Raw.Base58
+import Foreign.Rust.Serialisation.Raw.Base64
+import Foreign.Rust.Serialisation.Raw.Decimal
+
+{-------------------------------------------------------------------------------
+  AsDecimal
+-------------------------------------------------------------------------------}
+
+newtype UsesDecimal = UsesDecimal [Word8]
+  deriving stock (Eq)
+  deriving newtype (IsRaw)
+  deriving (Show, Structured.Show) via AsDecimal UsesDecimal
+  deriving (FromJSON, ToJSON) via AsDecimal UsesDecimal
+
+exampleUsesDecimal :: UsesDecimal
+exampleUsesDecimal = UsesDecimal [1, 2, 3, 4]
+
+{-------------------------------------------------------------------------------
+  AsBase16
+-------------------------------------------------------------------------------}
+
+newtype UsesBase16 = UsesBase16 [Word8]
+  deriving stock (Eq)
+  deriving newtype (IsRaw)
+  deriving (Show, Structured.Show, IsString) via AsBase16 UsesBase16
+  deriving (FromJSON, ToJSON) via AsBase16 UsesBase16
+
+exampleUsesBase16 :: UsesBase16
+exampleUsesBase16 = UsesBase16 [1, 2, 3, 4]
+
+{-------------------------------------------------------------------------------
+  AsBase58
+-------------------------------------------------------------------------------}
+
+newtype UsesBase58 = UsesBase58 [Word8]
+  deriving stock (Eq)
+  deriving newtype (IsRaw)
+  deriving (Show, Structured.Show, IsString) via AsBase58 UsesBase58
+  deriving (FromJSON, ToJSON) via AsBase58 UsesBase58
+
+exampleUsesBase58 :: UsesBase58
+exampleUsesBase58 = UsesBase58 [1, 2, 3, 4]
+
+{-------------------------------------------------------------------------------
+  AsBase64
+-------------------------------------------------------------------------------}
+
+newtype UsesBase64 = UsesBase64 [Word8]
+  deriving stock (Eq)
+  deriving newtype (IsRaw)
+  deriving (Show, Structured.Show, IsString) via AsBase64 UsesBase64
+  deriving (FromJSON, ToJSON) via AsBase64 UsesBase64
+
+exampleUsesBase64 :: UsesBase64
+exampleUsesBase64 = UsesBase64 [1, 2, 3, 4]
+
+{-------------------------------------------------------------------------------
+  AsJSON
+-------------------------------------------------------------------------------}
+
+newtype UsesJSON = UsesJSON Value
+  deriving stock (Eq)
+  deriving newtype (ToJSON, FromJSON)
+  deriving (Show, Structured.Show) via AsJSON UsesJSON
+
+exampleUsesJSON :: UsesJSON
+exampleUsesJSON = UsesJSON [aesonQQ|
+    { "a": null
+    , "b": [1, 2, 3]
+    }
+  |]

test/Test/Util/TH.hs

@@ -0,0 +1,81 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Test.Util.TH (
+    reparseShow
+  , reparseStructured
+  ) where
+
+import Data.String (fromString)
+
+import qualified Data.Structured       as Structured
+import qualified Language.Haskell.TH   as TH
+import qualified Language.Haskell.Exts as Exts
+import Language.Haskell.TH (Q)
+import Language.Haskell.TH.Quote
+import Data.Aeson.QQ.Simple
+
+{-------------------------------------------------------------------------------
+  Parse expressions
+-------------------------------------------------------------------------------}
+
+parseExp :: String -> Q TH.Exp
+parseExp =
+      toExp
+    . Exts.fromParseResult
+    . Exts.parseExpWithMode parseMode
+  where
+    parseMode :: Exts.ParseMode
+    parseMode = Exts.defaultParseMode {
+          Exts.extensions = [
+              Exts.EnableExtension Exts.OverloadedStrings
+            , Exts.EnableExtension Exts.TypeApplications
+            , Exts.EnableExtension Exts.QuasiQuotes
+            ]
+        }
+
+reparseShow :: Show a => a -> Q TH.Exp
+reparseShow = parseExp . show
+
+reparseStructured :: Structured.Show a => a -> Q TH.Exp
+reparseStructured = parseExp . Structured.show
+
+{-------------------------------------------------------------------------------
+  Translate haskell-src-exts @Exp@ to TH @Exp@
+
+  There is a package for this (@haskell-src-meta@), but it does not support
+  overloaded string nor quasi-quotes, which makes it rather useless for our
+  purposes. We only need to support a tiny handful of expressions, so we just
+  define it ourselves.
+-------------------------------------------------------------------------------}
+
+toExp :: Exts.Exp Exts.SrcSpanInfo -> Q TH.Exp
+toExp = \case
+
+    -- Standard instances
+    -- (These would presumably be similar in haskell-src-meta)
+
+    Exts.Var _ (Exts.UnQual _ (Exts.Ident _ n)) ->
+      pure $ TH.VarE $ TH.mkName n
+    Exts.App _ e (Exts.TypeApp _ (Exts.TyCon _ (Exts.UnQual _ (Exts.Ident _ n)))) ->
+      TH.AppTypeE <$> toExp e <*> pure (TH.ConT (TH.mkName n))
+    Exts.App _ e1 e2 ->
+      TH.AppE <$> toExp e1 <*> toExp e2
+    Exts.List _ es ->
+      TH.ListE <$> mapM toExp es
+    Exts.Lit _ (Exts.Int _ x _) ->
+      pure $ TH.LitE (TH.IntegerL x)
+
+    -- Overloaded strings
+
+    Exts.Lit _ (Exts.String _ x _) ->
+      pure $ TH.AppE (TH.VarE 'fromString) (TH.LitE (TH.StringL x))
+
+    -- Quasi-quotes
+
+    Exts.QuasiQuote _ "aesonQQ" str ->
+      quoteExp aesonQQ str
+
+    -- Anything else is urecognized
+
+    e -> fail $ "toExp: unrecognized expression " ++ show e
+