Initial push
This commit is contained in:
Edsko de Vries
parent
9c54a79def
commit
6c48f2357f
|
|
@ -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
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
.envrc
|
||||
dist-newstyle
|
||||
|
|
@ -0,0 +1,5 @@
|
|||
# Revision history for foreign-rust
|
||||
|
||||
## 0.1.0.0 -- YYYY-mm-dd
|
||||
|
||||
* First version. Released on an unsuspecting world.
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
packages: .
|
||||
|
||||
package foreign-rust
|
||||
tests: true
|
||||
|
|
@ -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 }
|
||||
|
|
@ -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
|
||||
|
|
@ -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)
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
]
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
@ -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)
|
||||
|
|
@ -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)
|
||||
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
]
|
||||
|
|
@ -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)
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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]
|
||||
}
|
||||
|]
|
||||
|
|
@ -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
|
||||
|
||||
Loading…
Reference in New Issue