From 6c48f2357f4317cfb2645acb0ee5128a5a82ab63 Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Fri, 17 Mar 2023 09:46:12 +0100 Subject: [PATCH] Initial push --- .github/workflows/haskell-ci.yml | 233 ++++++ .gitignore | 2 + CHANGELOG.md | 5 + cabal.project | 4 + demo-annotated/Main.hs | 151 ++++ foreign-rust.cabal | 131 ++++ src/Data/Annotated.hs | 380 ++++++++++ src/Data/Structured.hs | 663 ++++++++++++++++++ src/Data/Structured/TH.hs | 96 +++ src/Foreign/Rust/External/Bincode.hs | 34 + src/Foreign/Rust/External/JSON.hs | 72 ++ src/Foreign/Rust/Failure.hs | 27 + src/Foreign/Rust/Marshall/Fixed.hs | 55 ++ src/Foreign/Rust/Marshall/Util.hs | 58 ++ src/Foreign/Rust/Marshall/Variable.hs | 141 ++++ src/Foreign/Rust/SafeConv.hs | 18 + src/Foreign/Rust/Serialisation/JSON.hs | 59 ++ src/Foreign/Rust/Serialisation/Raw.hs | 107 +++ src/Foreign/Rust/Serialisation/Raw/Base16.hs | 83 +++ src/Foreign/Rust/Serialisation/Raw/Base58.hs | 102 +++ src/Foreign/Rust/Serialisation/Raw/Base64.hs | 83 +++ src/Foreign/Rust/Serialisation/Raw/Decimal.hs | 61 ++ test/Main.hs | 18 + test/Test/Serialisation/JSON.hs | 27 + test/Test/Serialisation/Raw/Base16.hs | 33 + test/Test/Serialisation/Raw/Base58.hs | 33 + test/Test/Serialisation/Raw/Base64.hs | 33 + test/Test/Serialisation/Raw/Decimal.hs | 35 + test/Test/Serialisation/Types.hs | 99 +++ test/Test/Util/TH.hs | 81 +++ 30 files changed, 2924 insertions(+) create mode 100644 .github/workflows/haskell-ci.yml create mode 100644 .gitignore create mode 100644 CHANGELOG.md create mode 100644 cabal.project create mode 100644 demo-annotated/Main.hs create mode 100644 foreign-rust.cabal create mode 100644 src/Data/Annotated.hs create mode 100644 src/Data/Structured.hs create mode 100644 src/Data/Structured/TH.hs create mode 100644 src/Foreign/Rust/External/Bincode.hs create mode 100644 src/Foreign/Rust/External/JSON.hs create mode 100644 src/Foreign/Rust/Failure.hs create mode 100644 src/Foreign/Rust/Marshall/Fixed.hs create mode 100644 src/Foreign/Rust/Marshall/Util.hs create mode 100644 src/Foreign/Rust/Marshall/Variable.hs create mode 100644 src/Foreign/Rust/SafeConv.hs create mode 100644 src/Foreign/Rust/Serialisation/JSON.hs create mode 100644 src/Foreign/Rust/Serialisation/Raw.hs create mode 100644 src/Foreign/Rust/Serialisation/Raw/Base16.hs create mode 100644 src/Foreign/Rust/Serialisation/Raw/Base58.hs create mode 100644 src/Foreign/Rust/Serialisation/Raw/Base64.hs create mode 100644 src/Foreign/Rust/Serialisation/Raw/Decimal.hs create mode 100644 test/Main.hs create mode 100644 test/Test/Serialisation/JSON.hs create mode 100644 test/Test/Serialisation/Raw/Base16.hs create mode 100644 test/Test/Serialisation/Raw/Base58.hs create mode 100644 test/Test/Serialisation/Raw/Base64.hs create mode 100644 test/Test/Serialisation/Raw/Decimal.hs create mode 100644 test/Test/Serialisation/Types.hs create mode 100644 test/Test/Util/TH.hs diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml new file mode 100644 index 0000000..aa75ac9 --- /dev/null +++ b/.github/workflows/haskell-ci.yml @@ -0,0 +1,233 @@ +# This GitHub workflow config has been generated by a script via +# +# haskell-ci 'github' 'cabal.project' +# +# To regenerate the script (for example after adjusting tested-with) run +# +# haskell-ci regenerate +# +# For more information, see https://github.com/haskell-CI/haskell-ci +# +# version: 0.15.20230312 +# +# REGENDATA ("0.15.20230312",["github","cabal.project"]) +# +name: Haskell-CI +on: + - push + - pull_request +jobs: + linux: + name: Haskell-CI - Linux - ${{ matrix.compiler }} + runs-on: ubuntu-20.04 + timeout-minutes: + 60 + container: + image: buildpack-deps:bionic + continue-on-error: ${{ matrix.allow-failure }} + strategy: + matrix: + include: + - compiler: ghc-9.4.4 + compilerKind: ghc + compilerVersion: 9.4.4 + setup-method: ghcup + allow-failure: false + - compiler: ghc-9.2.7 + compilerKind: ghc + compilerVersion: 9.2.7 + setup-method: ghcup + allow-failure: false + - compiler: ghc-9.0.2 + compilerKind: ghc + compilerVersion: 9.0.2 + setup-method: ghcup + allow-failure: false + - compiler: ghc-8.10.7 + compilerKind: ghc + compilerVersion: 8.10.7 + setup-method: ghcup + allow-failure: false + - compiler: ghc-8.8.4 + compilerKind: ghc + compilerVersion: 8.8.4 + setup-method: hvr-ppa + allow-failure: false + - compiler: ghc-8.6.5 + compilerKind: ghc + compilerVersion: 8.6.5 + setup-method: hvr-ppa + allow-failure: false + fail-fast: false + steps: + - name: apt + run: | + apt-get update + apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 + if [ "${{ matrix.setup-method }}" = ghcup ]; then + mkdir -p "$HOME/.ghcup/bin" + curl -sL https://downloads.haskell.org/ghcup/0.1.18.0/x86_64-linux-ghcup-0.1.18.0 > "$HOME/.ghcup/bin/ghcup" + chmod a+x "$HOME/.ghcup/bin/ghcup" + "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) + "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) + else + apt-add-repository -y 'ppa:hvr/ghc' + apt-get update + apt-get install -y "$HCNAME" + mkdir -p "$HOME/.ghcup/bin" + curl -sL https://downloads.haskell.org/ghcup/0.1.18.0/x86_64-linux-ghcup-0.1.18.0 > "$HOME/.ghcup/bin/ghcup" + chmod a+x "$HOME/.ghcup/bin/ghcup" + "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) + fi + env: + HCKIND: ${{ matrix.compilerKind }} + HCNAME: ${{ matrix.compiler }} + HCVER: ${{ matrix.compilerVersion }} + - name: Set PATH and environment variables + run: | + echo "$HOME/.cabal/bin" >> $GITHUB_PATH + echo "LANG=C.UTF-8" >> "$GITHUB_ENV" + echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" + echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" + HCDIR=/opt/$HCKIND/$HCVER + if [ "${{ matrix.setup-method }}" = ghcup ]; then + HC=$HOME/.ghcup/bin/$HCKIND-$HCVER + echo "HC=$HC" >> "$GITHUB_ENV" + echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV" + echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV" + echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" + else + HC=$HCDIR/bin/$HCKIND + echo "HC=$HC" >> "$GITHUB_ENV" + echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV" + echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV" + echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" + fi + + HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') + echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" + echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" + echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" + echo "HEADHACKAGE=false" >> "$GITHUB_ENV" + echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" + echo "GHCJSARITH=0" >> "$GITHUB_ENV" + env: + HCKIND: ${{ matrix.compilerKind }} + HCNAME: ${{ matrix.compiler }} + HCVER: ${{ matrix.compilerVersion }} + - name: env + run: | + env + - name: write cabal config + run: | + mkdir -p $CABAL_DIR + cat >> $CABAL_CONFIG <> $CABAL_CONFIG < 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 <> 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 diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..ba9d4e6 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +.envrc +dist-newstyle diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..f98fbc8 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for foreign-rust + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..b5e8848 --- /dev/null +++ b/cabal.project @@ -0,0 +1,4 @@ +packages: . + +package foreign-rust + tests: true diff --git a/demo-annotated/Main.hs b/demo-annotated/Main.hs new file mode 100644 index 0000000..c0b070b --- /dev/null +++ b/demo-annotated/Main.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE TemplateHaskell #-} + +import Data.Annotated +import Data.Kind +import GHC.TypeLits + +import qualified GHC.Generics as GHC +import qualified Generics.SOP as SOP + +import qualified Data.Structured as Structured +import qualified Data.Structured.TH as Structured + +{------------------------------------------------------------------------------- + Demonstration of annotations +-------------------------------------------------------------------------------} + +-- +-- Suppose we have some data type that is opaque Haskell-side (just some bytes), +-- + +data Keypair = Keypair + deriving stock (Show, GHC.Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + deriving anyclass (Structured.Show) + deriving CanAnnotate via PairWithAnnotation Keypair + +-- +-- Perhaps we can inspect this datatype using an FFI +-- + +data Pubkey = Pubkey + deriving stock (Show, GHC.Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + deriving anyclass (Structured.Show) + +data Secret = Secret + deriving stock (Show, GHC.Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + deriving anyclass (Structured.Show) + +keypairPubkey :: Keypair -> Pubkey +keypairPubkey Keypair = Pubkey + +keypairSecret :: Keypair -> Secret +keypairSecret Keypair = Secret + +-- +-- When we show a Keypair, we'd like to annotate it with these derived values +-- + +data KeypairAnnotation = KeypairAnnotation { + pubkey :: Pubkey + , secret :: Secret + } + deriving stock (Show, GHC.Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + deriving anyclass (Structured.Show) + +type instance Annotation Keypair = KeypairAnnotation + +instance ComputeAnnotation Keypair where + computeAnnotation kp = KeypairAnnotation { + pubkey = keypairPubkey kp + , secret = keypairSecret kp + } + +{------------------------------------------------------------------------------- + Generics +-------------------------------------------------------------------------------} + +data RecordA = RecordA { + recA_field1 :: Bool + , recA_field2 :: Int + } + deriving stock (GHC.Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + deriving anyclass (Structured.Show) + +-- A type, perhaps externally defined, with only standard Show instance +data SomeOtherType = SomeOtherType String + deriving (Show) + +data RecordB = RecordB { + recB :: SomeOtherType + } + deriving stock (GHC.Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + +instance Structured.Show RecordB where + toValue = Structured.gtoValueAfter Structured.FromPreludeShow + +{------------------------------------------------------------------------------- + Demonstrate TH support (crucically, with support for GADTs) +-------------------------------------------------------------------------------} + +data SimpleEnum = SimpleEnumA | SimpleEnumB + +Structured.deriveInstance 'SimpleEnumA [t| + forall. Structured.Show SimpleEnum + |] + +data SimpleStruct a = SimpleStruct a Int + +Structured.deriveInstance 'SimpleStruct [t| + forall a. Structured.Show a => Structured.Show (SimpleStruct a) + |] + +data SomeGADT :: Symbol -> Type where + Foo :: SomeGADT "foo" + Bar :: SomeGADT "bar" + +Structured.deriveInstance 'Foo [t| + forall k. Structured.Show (SomeGADT k) + |] + +class Foo a where + data SomeAssocType a :: Type + +instance Foo Int where + data SomeAssocType Int = SomeInt Int + +Structured.deriveInstance 'SomeInt [t| + forall. Structured.Show (SomeAssocType Int) + |] + +data SomeRecord = SomeRecord { + field1 :: Int + , field2 :: Bool + } + +Structured.deriveInstance 'SomeRecord [t| + forall. Structured.Show SomeRecord + |] + +{------------------------------------------------------------------------------- + Main +-------------------------------------------------------------------------------} + +main :: IO () +main = do + -- Annotations + Structured.print . annotate $ [(Just Keypair, True)] + -- Generics + Structured.print $ RecordA { recA_field1 = True, recA_field2 = 5 } + Structured.print $ RecordB { recB = SomeOtherType "hi" } + -- TH + Structured.print $ SimpleEnumA + Structured.print $ SimpleStruct True 5 + Structured.print $ Foo + Structured.print $ SomeInt 5 + Structured.print $ SomeRecord { field1 = 1, field2 = True } \ No newline at end of file diff --git a/foreign-rust.cabal b/foreign-rust.cabal new file mode 100644 index 0000000..a3b15a5 --- /dev/null +++ b/foreign-rust.cabal @@ -0,0 +1,131 @@ +cabal-version: 3.0 +name: foreign-rust +version: 0.1.0 +license: BSD-3-Clause +license-file: LICENSE +author: Edsko de Vries +maintainer: edsko@well-typed.com +category: Development +build-type: Simple +extra-doc-files: CHANGELOG.md +tested-with: GHC==8.6.5 + , GHC==8.8.4 + , GHC==8.10.7 + , GHC==9.0.2 + , GHC==9.2.7 + , GHC==9.4.4 + +common lang + build-depends: + base >= 4.12 + default-language: + Haskell2010 + ghc-options: + -Wall + -Wredundant-constraints + if impl(ghc >= 8.10) + ghc-options: + -Wunused-packages + default-extensions: + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveGeneric + DerivingStrategies + DerivingVia + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + PolyKinds + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + TypeOperators + UndecidableInstances + +library + import: + lang + exposed-modules: + Foreign.Rust.External.JSON + Foreign.Rust.External.Bincode + Foreign.Rust.Failure + Foreign.Rust.Marshall.Fixed + Foreign.Rust.Marshall.Variable + Foreign.Rust.SafeConv + Foreign.Rust.Serialisation.JSON + Foreign.Rust.Serialisation.Raw + Foreign.Rust.Serialisation.Raw.Base16 + Foreign.Rust.Serialisation.Raw.Base58 + Foreign.Rust.Serialisation.Raw.Base64 + Foreign.Rust.Serialisation.Raw.Decimal + + Data.Annotated + Data.Structured + Data.Structured.TH + other-modules: + Foreign.Rust.Marshall.Util + hs-source-dirs: + src + build-depends: + , aeson + , base16-bytestring + , base58-bytestring + , base64-bytestring + , binary + , borsh >= 0.3 + , bytestring + , containers + , data-default + , generics-sop + , OneTuple + , sop-core + , template-haskell + , text + , th-abstraction + , vector + , wide-word + +test-suite test-foreign-rust + import: + lang + type: + exitcode-stdio-1.0 + main-is: + Main.hs + other-modules: + Test.Serialisation.JSON + Test.Serialisation.Raw.Base16 + Test.Serialisation.Raw.Base58 + Test.Serialisation.Raw.Base64 + Test.Serialisation.Raw.Decimal + Test.Serialisation.Types + Test.Util.TH + hs-source-dirs: + test + build-depends: + , aeson + , foreign-rust + , haskell-src-exts + , tasty + , tasty-hunit + , template-haskell + +test-suite demo-annotated + import: + lang + type: + exitcode-stdio-1.0 + main-is: + Main.hs + hs-source-dirs: + demo-annotated + build-depends: + , generics-sop + , foreign-rust diff --git a/src/Data/Annotated.hs b/src/Data/Annotated.hs new file mode 100644 index 0000000..048c27b --- /dev/null +++ b/src/Data/Annotated.hs @@ -0,0 +1,380 @@ +module Data.Annotated ( + -- * Definition + CanAnnotate(..) + -- * Deriving-via support + -- ** Computing annotations + , Annotation + , PairWithAnnotation(..) + , ComputeAnnotation(..) + , WithAnnotation(..) + -- ** Other combinators + , NoAnnotation(..) + , AnnotateFoldable(..) + , AnnotateGenericallyAs(..) + ) where + +import Data.Functor.Identity +import Data.Int +import Data.Kind +import Data.Map (Map) +import Data.Proxy +import Data.WideWord +import Data.Word + +import qualified Data.Aeson as Aeson +import qualified Data.SOP.Constraint as SOP +import qualified Generics.SOP as SOP +import qualified GHC.Generics as GHC + +import qualified Data.Structured as Structured +import Data.Tuple.Solo + +{------------------------------------------------------------------------------- + Definition +-------------------------------------------------------------------------------} + +class CanAnnotate a where + type Annotated a :: Type + annotate :: a -> Annotated a + +{------------------------------------------------------------------------------- + Deriving via support: computing annotations +-------------------------------------------------------------------------------} + +-- | Annotation of a value +-- +-- Unlike 'Annotated', 'Annotation' is not always defined: not all types /have/ +-- annotations (for example, @Annotated a@ might just be @a@). +type family Annotation a :: Type + +-- | Deriving via support: computing annotations +-- +-- If you need to compute an annotation and do not need to worry about +-- annotating any nested values, you define a 'CanAnnotate' instance for some +-- type @A@ with annotation @B@ as follows: +-- +-- > data A = .. +-- > deriving CanAnnotate via PairWithAnnotation A +newtype PairWithAnnotation a = PairWithAnnotation a + +class ComputeAnnotation a where + computeAnnotation :: a -> Annotation a + +instance ComputeAnnotation a => CanAnnotate (PairWithAnnotation a) where + type Annotated (PairWithAnnotation a) = WithAnnotation a (Annotation a) + annotate (PairWithAnnotation x) = WithAnnotation { + value = x + , annotation = computeAnnotation x + } + +data WithAnnotation a b = WithAnnotation { + value :: a + , annotation :: b + } + deriving stock (Show, GHC.Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + deriving anyclass (Structured.Show) + +{------------------------------------------------------------------------------- + Deriving via: default instance for foldable containers +-------------------------------------------------------------------------------} + +-- | Deriving via: default instance for foldable containers +-- +-- We annotate the values in the containers, and give the container length as +-- its own annotation. +-- +-- Example: +-- +-- > deriving +-- > via AnnotateFoldable [] a +-- > instance CanAnnotate a => CanAnnotate [a] +newtype AnnotateFoldable f a = AnnotateFoldable (f a) + +newtype Length = Length Int + deriving stock (Show, GHC.Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + deriving anyclass (Structured.Show) + +type instance Annotation (AnnotateFoldable f a) = Length + +instance ( Functor f + , Foldable f + , CanAnnotate a + ) => CanAnnotate (AnnotateFoldable f a) where + type Annotated (AnnotateFoldable f a) = WithAnnotation (f (Annotated a)) Length + annotate (AnnotateFoldable xs) = WithAnnotation { + value = annotate <$> xs + , annotation = Length $ length xs + } + +{------------------------------------------------------------------------------- + Deriving-via: no annotation +-------------------------------------------------------------------------------} + +-- | Deriving via: no annotation +-- +-- Example: +-- +-- > data A = .. +-- > deriving CanAnnotate via NoAnnotation A +newtype NoAnnotation a = NoAnnotation a + +type instance Annotation (NoAnnotation a) = () + +instance CanAnnotate (NoAnnotation a) where + type Annotated (NoAnnotation a) = a + annotate (NoAnnotation x) = x + +{------------------------------------------------------------------------------- + Deriving via: generics +-------------------------------------------------------------------------------} + +-- | Deriving via: annotate generically +-- +-- This combinator can be used to define 'CanAnnotate' instance that just +-- walk over the structure of the argument, without adding any annotations +-- of their own. +-- +-- Example: +-- +-- > deriving +-- > via AnnotateGenericallyAs (Maybe (Annotated a)) (Maybe a) +-- > instance CanAnnotate a => CanAnnotate (Maybe a) +newtype AnnotateGenericallyAs b a = AnnotateGenericallyAs a + +-- | Internal auxiliary: two-parameter wrapper around 'CanAnnotate' +class Annotate' a b where + annotate' :: a -> b + +instance (CanAnnotate a, b ~ Annotated a) => Annotate' a b where + annotate' = annotate + +type instance Annotation (AnnotateGenericallyAs b a) = () + +instance ( SOP.Generic a + , SOP.Generic b + , SOP.SameShapeAs (SOP.Code a) (SOP.Code b) + , SOP.SameShapeAs (SOP.Code b) (SOP.Code a) + , SOP.AllZip2 Annotate' (SOP.Code a) (SOP.Code b) + ) => CanAnnotate (AnnotateGenericallyAs b a) where + type Annotated (AnnotateGenericallyAs b a) = b + annotate (AnnotateGenericallyAs x) = + SOP.to + . SOP.htrans (Proxy @Annotate') (SOP.mapII annotate') + . SOP.from + $ x + +{------------------------------------------------------------------------------- + Standard instances: no annotation +-------------------------------------------------------------------------------} + +deriving via NoAnnotation Bool instance CanAnnotate Bool +deriving via NoAnnotation Aeson.Value instance CanAnnotate Aeson.Value + +deriving via NoAnnotation Integer instance CanAnnotate Integer + +deriving via NoAnnotation Int instance CanAnnotate Int +deriving via NoAnnotation Int8 instance CanAnnotate Int8 +deriving via NoAnnotation Int16 instance CanAnnotate Int16 +deriving via NoAnnotation Int32 instance CanAnnotate Int32 +deriving via NoAnnotation Int64 instance CanAnnotate Int64 +deriving via NoAnnotation Int128 instance CanAnnotate Int128 + +deriving via NoAnnotation Word instance CanAnnotate Word +deriving via NoAnnotation Word8 instance CanAnnotate Word8 +deriving via NoAnnotation Word16 instance CanAnnotate Word16 +deriving via NoAnnotation Word32 instance CanAnnotate Word32 +deriving via NoAnnotation Word64 instance CanAnnotate Word64 +deriving via NoAnnotation Word128 instance CanAnnotate Word128 + +deriving via NoAnnotation Float instance CanAnnotate Float +deriving via NoAnnotation Double instance CanAnnotate Double + +{------------------------------------------------------------------------------- + Standard instances: foldable +-------------------------------------------------------------------------------} + +deriving + via AnnotateFoldable [] a + instance CanAnnotate a => CanAnnotate [a] + +deriving + via AnnotateFoldable (Map k) a + instance CanAnnotate a => CanAnnotate (Map k a) + +{------------------------------------------------------------------------------- + Standard instances: generic +-------------------------------------------------------------------------------} + +deriving + via AnnotateGenericallyAs (Maybe (Annotated a)) (Maybe a) + instance CanAnnotate a => CanAnnotate (Maybe a) + +deriving + via AnnotateGenericallyAs (Either (Annotated a) (Annotated b)) (Either a b) + instance (CanAnnotate a, CanAnnotate b) => CanAnnotate (Either a b) + +deriving + via AnnotateGenericallyAs (Identity (Annotated a)) (Identity a) + instance CanAnnotate a => CanAnnotate (Identity a) + +{------------------------------------------------------------------------------- + Standard instances: tuples + + These instances also use 'AnnotateGenericallyAs'. +-------------------------------------------------------------------------------} + +-- 0 +deriving + via NoAnnotation () + instance CanAnnotate () + +-- 1 ('Solo' does not support SOP generics) +instance CanAnnotate a => CanAnnotate (Solo a) where + type Annotated (Solo a) = Solo (Annotated a) + annotate (Solo x) = Solo (annotate x) + +-- 2 +deriving + via AnnotateGenericallyAs + ( Annotated a + , Annotated b + ) + (a, b) + instance ( CanAnnotate a + , CanAnnotate b + ) => CanAnnotate (a, b) + +-- 3 +deriving + via AnnotateGenericallyAs + ( Annotated a + , Annotated b + , Annotated c + ) + (a, b, c) + instance ( CanAnnotate a + , CanAnnotate b + , CanAnnotate c + ) => CanAnnotate (a, b, c) + +-- 4 +deriving + via AnnotateGenericallyAs + ( Annotated a + , Annotated b + , Annotated c + , Annotated d + ) + (a, b, c, d) + instance ( CanAnnotate a + , CanAnnotate b + , CanAnnotate c + , CanAnnotate d + ) => CanAnnotate (a, b, c, d) + +-- 5 +deriving + via AnnotateGenericallyAs + ( Annotated a + , Annotated b + , Annotated c + , Annotated d + , Annotated e + ) + (a, b, c, d, e) + instance ( CanAnnotate a + , CanAnnotate b + , CanAnnotate c + , CanAnnotate d + , CanAnnotate e + ) => CanAnnotate (a, b, c, d, e) + +-- 6 +deriving + via AnnotateGenericallyAs + ( Annotated a + , Annotated b + , Annotated c + , Annotated d + , Annotated e + , Annotated f + ) + (a, b, c, d, e, f) + instance ( CanAnnotate a + , CanAnnotate b + , CanAnnotate c + , CanAnnotate d + , CanAnnotate e + , CanAnnotate f + ) => CanAnnotate (a, b, c, d, e, f) + +-- 7 +deriving + via AnnotateGenericallyAs + ( Annotated a + , Annotated b + , Annotated c + , Annotated d + , Annotated e + , Annotated f + , Annotated g + ) + (a, b, c, d, e, f, g) + instance ( CanAnnotate a + , CanAnnotate b + , CanAnnotate c + , CanAnnotate d + , CanAnnotate e + , CanAnnotate f + , CanAnnotate g + ) => CanAnnotate (a, b, c, d, e, f, g) + +-- 8 +deriving + via AnnotateGenericallyAs + ( Annotated a + , Annotated b + , Annotated c + , Annotated d + , Annotated e + , Annotated f + , Annotated g + , Annotated h + ) + (a, b, c, d, e, f, g, h) + instance ( CanAnnotate a + , CanAnnotate b + , CanAnnotate c + , CanAnnotate d + , CanAnnotate e + , CanAnnotate f + , CanAnnotate g + , CanAnnotate h + ) => CanAnnotate (a, b, c, d, e, f, g, h) + +-- 9 +deriving + via AnnotateGenericallyAs + ( Annotated a + , Annotated b + , Annotated c + , Annotated d + , Annotated e + , Annotated f + , Annotated g + , Annotated h + , Annotated i + ) + (a, b, c, d, e, f, g, h, i) + instance ( CanAnnotate a + , CanAnnotate b + , CanAnnotate c + , CanAnnotate d + , CanAnnotate e + , CanAnnotate f + , CanAnnotate g + , CanAnnotate h + , CanAnnotate i + ) => CanAnnotate (a, b, c, d, e, f, g, h, i) diff --git a/src/Data/Structured.hs b/src/Data/Structured.hs new file mode 100644 index 0000000..e556bd6 --- /dev/null +++ b/src/Data/Structured.hs @@ -0,0 +1,663 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Pretty-print value in a way that is valid Haskell +-- +-- Intended for qualified import +-- +-- > import qualified Data.Structured as Structured +module Data.Structured ( + Show(..) + , show + , showsPrec + , print + -- * Structured values + , Value(..) + -- * Generics + , gtoValue + , gtoValueAfter + , sopToValue + , sopToValueAfter + -- * Deriving-via support + , ToPreludeShow(..) + , FromPreludeShow(..) + ) where + +import Prelude hiding (Show(..), print) +import qualified Prelude + +import Control.Monad +import Data.Bifunctor +import Data.ByteString.Short (ShortByteString) +import Data.Default +import Data.Functor.Identity +import Data.Int +import Data.List (intersperse) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.SOP +import Data.SOP.Dict +import Data.String +import Data.Text (Text) +import Data.Text.Lazy.Builder (Builder) +import Data.Tuple.Solo +import Data.Typeable +import Data.WideWord +import Data.Word +import GHC.Show (appPrec) + +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.KeyMap as Aeson.KeyMap +import qualified Data.Aeson.Text as Aeson +import qualified Data.ByteString as Strict +import qualified Data.ByteString.Lazy as Lazy +import qualified Data.List.NonEmpty as NE +import qualified Data.Text as Text +import qualified Data.Text.Lazy as Lazy +import qualified Data.Text.Lazy as Text.Lazy +import qualified Data.Text.Lazy.Builder as B +import qualified Data.Vector as Vector +import qualified Generics.SOP as SOP + +{------------------------------------------------------------------------------- + Main API +-------------------------------------------------------------------------------} + +-- | Pretty-print value in a way that is valid Haskell +-- +-- This is similar to what @pretty-show@ offers, but @pretty-show@ does not +-- guarantee valid Haskell (for example, strings are shown without quotes). +class Show a where + -- | Generate structured value + -- + -- Typically instances are derived using generics: + -- + -- > data MyType = .. + -- > deriving stock (GHC.Generic) + -- > deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + -- > deriving anyclass (Structured.Show) + -- + -- If you want to tweak the generic instance, see 'gtoValueAfter'. + toValue :: a -> Value + + default toValue :: + (SOP.HasDatatypeInfo a, All2 Show (SOP.Code a)) + => a -> Value + toValue = gtoValue + +show :: Show a => a -> String +show = render False . toValue + +showsPrec :: Show a => Int -> a -> ShowS +showsPrec p = showString . render (p > appPrec) . toValue + +print :: Show a => a -> IO () +print = putStrLn . show + +{------------------------------------------------------------------------------- + Value +-------------------------------------------------------------------------------} + +-- | Structured value +data Value where + -- | Constructor (or smart constructor) application + -- + -- We allow for some type applications, too. + Constr :: Text -> [TypeRep] -> [Value] -> Value + + -- | Record + Record :: Text -> [(String, Value)] -> Value + + -- | List + List :: [Value] -> Value + + -- | Tuple + Tuple :: [Value] -> Value + + -- | Anything String-like + -- + -- Precondition: the 'Show' and 'IsString' instances must be compatible. + String :: forall a. (Prelude.Show a, IsString a) => a -> Value + + -- | Integral numbers + -- + -- These are shown assuming @NumericUnderscores@. + Integral :: forall a. (Prelude.Show a, Integral a) => a -> Value + + -- | Quasi-quote + -- + -- We separate out the quasi-quoter from the quoted string proper. + -- The lines of the quasi-quoted string are listed separately. + QuasiQ :: Text -> NonEmpty Builder -> Value + + -- | JSON value + -- + -- We define this as an explicit constructor, in case we ever want to + -- generate structured JSON logs from these values. + -- + -- The pretty-printer uses the @aesonQQ@ quasi-quoter. + JSON :: Aeson.Value -> Value + + -- | Value shown using the Prelude's show + PreludeShow :: Prelude.Show a => a -> Value + +deriving instance Prelude.Show Value + +{------------------------------------------------------------------------------- + Deriving-via support +-------------------------------------------------------------------------------} + +-- | Derive 'Prelude.Show' through 'Show' +-- +-- You might not want to do always do this; in some circumstances it may be +-- useful to have a non-pretty-printed 'Show' instance alongside 'Show'. +newtype ToPreludeShow a = ToPreludeShow a + +-- | Derive 'Show' through 'Prelude.Show' +-- +-- NOTE: This should be used sparingly. When 'Show x' is derived using +-- 'Prelude.Show x', the result should still be a law-abiding instance (generate +-- valid Haskell code), assuming that the 'Prelude.Show' instance is +-- law-abiding; however, it will limit the ability to generate structured +-- values in different formats, such as JSON. +newtype FromPreludeShow a = FromPreludeShow a + +instance Show a => Prelude.Show (ToPreludeShow a) where + showsPrec p (ToPreludeShow x) = showsPrec p x + +instance Prelude.Show a => Show (FromPreludeShow a) where + toValue (FromPreludeShow x) = PreludeShow x + +{------------------------------------------------------------------------------- + Generics +-------------------------------------------------------------------------------} + +-- | Newtype which is transparent for the purposes of 'Show' +-- +-- This is only used internally in 'sopToValue'. +newtype Transparent a = Transparent a + deriving newtype Show + +gtoValue :: forall a. + (SOP.HasDatatypeInfo a, All2 Show (SOP.Code a)) + => a -> Value +gtoValue x = sopToValue (SOP.from x) (SOP.datatypeInfo (Proxy @a)) + +-- | Generic derivation of 'toValue' +-- +-- The standard generics instance will depend on 'Show' for all nested values. +-- This is usually the right choice, but occassionally you will want to show +-- nested values in a different manner; in this case, you can use +-- 'gtoValueAfter'. Example: +-- +-- > instance Structured.Show RecordB where +-- > toValue = Structured.gtoValueAfter Structured.FromPreludeShow +-- +-- (However, 'FromPreludeShow' should be used sparingly; see discussion there.) +gtoValueAfter :: forall f a. + (SOP.HasDatatypeInfo a, All2 (Compose Show f) (SOP.Code a)) + => (forall x. x -> f x) + -> a -> Value +gtoValueAfter f x = sopToValueAfter f (SOP.from x) (SOP.datatypeInfo (Proxy @a)) + +sopToValue :: forall xss. + All2 Show xss + => SOP I xss -> SOP.DatatypeInfo xss -> Value +sopToValue = + case aux of Dict -> sopToValueAfter Transparent + where + aux :: Dict (All2 (Compose Show Transparent)) xss + aux = all_POP $ hcpure (Proxy @Show) Dict + +sopToValueAfter :: forall f xss. + All2 (Compose Show f) xss + => (forall x. x -> f x) + -> SOP I xss -> SOP.DatatypeInfo xss -> Value +sopToValueAfter f (SOP xss) info = hcollapse $ + hczipWith (Proxy @(All (Compose Show f))) aux (SOP.constructorInfo info) xss + where + aux :: + All (Compose Show f) xs + => SOP.ConstructorInfo xs -> NP I xs -> K Value xs + aux (SOP.Constructor name) xs = K $ auxSimple name xs + aux (SOP.Record name fields) xs = K $ auxRecord name fields xs + aux (SOP.Infix _ _ _) _ = error "sopToValue: TODO: infix" + + auxSimple :: + All (Compose Show f) xs + => String -> NP I xs -> Value + auxSimple constr xs = Constr (Text.pack constr) [] $ hcollapse $ + hcmap (Proxy @(Compose Show f)) (mapIK (toValue . f)) xs + + auxRecord :: + All (Compose Show f) xs + => SOP.ConstructorName -> NP SOP.FieldInfo xs -> NP I xs -> Value + auxRecord constr fields xs = Record (Text.pack constr) $ hcollapse $ + hczipWith (Proxy @(Compose Show f)) auxRecordField fields xs + + auxRecordField :: + Show (f x) + => SOP.FieldInfo x -> I x -> K (String, Value) x + auxRecordField field (I x) = K (SOP.fieldName field, toValue (f x)) + +{------------------------------------------------------------------------------- + Standard instances +-------------------------------------------------------------------------------} + +instance Show Word where toValue = Integral +instance Show Word8 where toValue = Integral +instance Show Word16 where toValue = Integral +instance Show Word32 where toValue = Integral +instance Show Word64 where toValue = Integral +instance Show Word128 where toValue = Integral + +instance Show Int where toValue = Integral +instance Show Int8 where toValue = Integral +instance Show Int16 where toValue = Integral +instance Show Int32 where toValue = Integral +instance Show Int64 where toValue = Integral +instance Show Int128 where toValue = Integral + +instance Show Integer where toValue = Integral + +instance {-# OVERLAPPABLE #-} Show a => Show [a] where + toValue = List . map toValue + +instance Show Aeson.Value where + toValue = JSON + +instance Typeable a => Show (Proxy (a :: k)) where + toValue p = Constr "Proxy" [typeRep p] [] + +{------------------------------------------------------------------------------- + String-like types +-------------------------------------------------------------------------------} + +instance {-# OVERLAPPING #-} Show String where + toValue = String + +instance Show Strict.ByteString where toValue = String +instance Show Lazy.ByteString where toValue = String +instance Show ShortByteString where toValue = String +instance Show Text where toValue = String +instance Show Lazy.Text where toValue = String + +{------------------------------------------------------------------------------- + Tuples +-------------------------------------------------------------------------------} + +-- 0 +instance Show () + +-- 1 (Solo does not support SOP generics) +instance Show a => Show (Solo a) where + toValue (Solo x) = Constr "Solo" [] [toValue x] + +-- 2 +instance ( Show a + , Show b + ) => Show (a, b) where + toValue (a, b) = Tuple [ + toValue a + , toValue b + ] + +-- 3 +instance ( Show a + , Show b + , Show c + ) => Show (a, b, c) where + toValue (a, b, c) = Tuple [ + toValue a + , toValue b + , toValue c + ] + +-- 4 +instance ( Show a + , Show b + , Show c + , Show d + ) => Show (a, b, c, d) where + toValue (a, b, c, d) = Tuple [ + toValue a + , toValue b + , toValue c + , toValue d + ] + +-- 5 +instance ( Show a + , Show b + , Show c + , Show d + , Show e + ) => Show (a, b, c, d, e) where + toValue (a, b, c, d, e) = Tuple [ + toValue a + , toValue b + , toValue c + , toValue d + , toValue e + ] + +-- 6 +instance ( Show a + , Show b + , Show c + , Show d + , Show e + , Show f + ) => Show (a, b, c, d, e, f) where + toValue (a, b, c, d, e, f) = Tuple [ + toValue a + , toValue b + , toValue c + , toValue d + , toValue e + , toValue f + ] + +-- 7 +instance ( Show a + , Show b + , Show c + , Show d + , Show e + , Show f + , Show g + ) => Show (a, b, c, d, e, f, g) where + toValue (a, b, c, d, e, f, g) = Tuple [ + toValue a + , toValue b + , toValue c + , toValue d + , toValue e + , toValue f + , toValue g + ] + +-- 8 +instance ( Show a + , Show b + , Show c + , Show d + , Show e + , Show f + , Show g + , Show h + ) => Show (a, b, c, d, e, f, g, h) where + toValue (a, b, c, d, e, f, g, h) = Tuple [ + toValue a + , toValue b + , toValue c + , toValue d + , toValue e + , toValue f + , toValue g + , toValue h + ] + +-- 9 +instance ( Show a + , Show b + , Show c + , Show d + , Show e + , Show f + , Show g + , Show h + , Show i + ) => Show (a, b, c, d, e, f, g, h, i) where + toValue (a, b, c, d, e, f, g, h, i) = Tuple [ + toValue a + , toValue b + , toValue c + , toValue d + , toValue e + , toValue f + , toValue g + , toValue h + , toValue i + ] + +{------------------------------------------------------------------------------- + Instances that rely on generics +-------------------------------------------------------------------------------} + +instance Show Bool + +instance Show a => Show (Maybe a) + +instance (Show a, Show b) => Show (Either a b) + +instance Show a => Show (Identity a) + +{------------------------------------------------------------------------------- + Rendering proper +-------------------------------------------------------------------------------} + +render :: + Bool -- ^ Are we in a context that may require brackets? + -> Value -> String +render = \contextNeedsBrackets -> + Text.Lazy.unpack + . B.toLazyText + . intercalate "\n" + . NE.toList + . go contextNeedsBrackets + where + go :: Bool -> Value -> NonEmpty Builder + go contextneedsBrackets val = + bracketIf (contextneedsBrackets && requiresBrackets val) $ + case val of + Integral x -> simple $ addNumericUnderscores (Prelude.show x) + String x -> simple $ Prelude.show x + Constr c ts xs -> renderComposite (compositeConstr c ts) $ + map (go True) xs + List xs -> renderComposite compositeList $ + map (go False) xs + Tuple xs -> renderComposite compositeTuple $ + map (go False) xs + Record r xs -> renderComposite (compositeHaskellRecord r) $ + map (uncurry goField . second (go False)) xs + QuasiQ qq str -> renderComposite (compositeQuasiQ qq) [str] + JSON json -> go contextneedsBrackets $ QuasiQ "aesonQQ" $ + renderJSON json + PreludeShow x -> NE.fromList . map B.fromString $ + lines (Prelude.showsPrec appPrec x "") + + simple :: String -> NonEmpty Builder + simple = pure . B.fromString + + goField :: String -> NonEmpty Builder -> NonEmpty Builder + goField field (firstLine :| rest) = + (B.fromString field <> " = " <> firstLine) + :| indent rest + + bracketIf :: Bool -> NonEmpty Builder -> NonEmpty Builder + bracketIf False = id + bracketIf True = \case + oneLine :| [] -> ("(" <> oneLine <> ")") :| [] + firstLine :| rest -> ("( " <> firstLine) :| concat [ + indent rest + , [")"] + ] + +renderJSON :: Aeson.Value -> NonEmpty Builder +renderJSON = go + where + go :: Aeson.Value -> NonEmpty Builder + go (Aeson.Object xs) = renderComposite compositeJsonRecord $ + map (uncurry goField . second go) $ + Aeson.KeyMap.toList xs + go (Aeson.Array xs) = renderComposite compositeList $ + map go $ + Vector.toList xs + go val = Aeson.encodeToTextBuilder val :| [] + + goField :: Aeson.KeyMap.Key -> NonEmpty Builder -> NonEmpty Builder + goField key (firstLine :| rest) = + B.fromString (Prelude.show key) <> ": " <> firstLine + :| map (" " <>) rest + +-- | Does this value require brackets when shown? +-- +-- Of course, these brackets will only be necessary if the context demands them. +requiresBrackets :: Value -> Bool +requiresBrackets = \case + Constr _ ts xs -> not (null ts) || not (null xs) + _otherwise -> False + +{------------------------------------------------------------------------------- + Internal: rendering composite values +-------------------------------------------------------------------------------} + +data Composite = Composite { + -- | Header (e.g. record name, type applications, ..) + compositeHeader :: Maybe Text + + -- | Prefix (e.g. @{@ or @(@) + , compositePrefix :: Maybe Text + + -- | Suffix (e.g, @}@ or @)@) + , compositeSuffix :: Maybe Text + + -- | Element separator (e.g. @,@) + , compositeSeparator :: Char + + -- | Should elements be shown on one line? + -- + -- By default, this is true only if there is only a single element, + -- and that element is itself only one line. + , compositeOneLine :: [NonEmpty Builder] -> Maybe [Builder] + } + +instance Default Composite where + def = Composite { + compositeHeader = Nothing + , compositePrefix = Nothing + , compositeSuffix = Nothing + , compositeSeparator = ',' + , compositeOneLine = \case + [firstLine :| []] -> Just [firstLine] + _otherwise -> Nothing + } + +compositeList :: Composite +compositeList = def { + compositePrefix = Just "[" + , compositeSuffix = Just "]" + , compositeOneLine = \rs -> do + xs <- mapM isOneLine rs + + let argLengths :: [Int64] + argLengths = map (Text.Lazy.length . B.toLazyText) xs + guard $ or [ + sum argLengths < 80 + , all (<= 5) argLengths + ] + + return xs + } + where + isOneLine :: NonEmpty a -> Maybe a + isOneLine (firstLine :| []) = Just firstLine + isOneLine _otherwise = Nothing + +compositeTuple :: Composite +compositeTuple = def { + compositePrefix = Just "(" + , compositeSuffix = Just ")" + } + +compositeConstr :: Text -> [TypeRep] -> Composite +compositeConstr c ts = def { + compositeSeparator = ' ' + , compositeHeader = Just $ intercalate " " $ c : map typeApp ts + } + where + -- We are careful to insert brackets around the typerep if needed + typeApp :: TypeRep -> Text + typeApp typ = "@" <> Text.pack (Prelude.showsPrec appPrec typ []) + +compositeHaskellRecord :: Text -> Composite +compositeHaskellRecord r = def { + compositeHeader = Just $ r + , compositePrefix = Just $ "{" + , compositeSuffix = Just $ "}" + , compositeOneLine = const Nothing + } + +compositeJsonRecord :: Composite +compositeJsonRecord = def { + compositePrefix = Just $ "{" + , compositeSuffix = Just $ "}" + , compositeOneLine = const Nothing + } + +compositeQuasiQ :: Text -> Composite +compositeQuasiQ qq = def { + compositePrefix = Just $ "[" <> qq <> "|" + , compositeSuffix = Just $ "|]" + } + +-- | Render composite value +renderComposite :: Composite -> [NonEmpty Builder] -> NonEmpty Builder +renderComposite Composite{..} = + go + where + go :: [NonEmpty Builder] -> NonEmpty Builder + go rs + | Just xs <- compositeOneLine rs + = pure $ mconcat [ + prefix + , intercalate (B.singleton compositeSeparator) xs + , maybe mempty B.fromText compositeSuffix + ] + + | otherwise + = prefix + :| concat [ + concatMap NE.toList $ sepElemsBy compositeSeparator rs + , [B.fromText suffix | Just suffix <- [compositeSuffix]] + ] + + prefix :: Builder + prefix = mconcat [ + maybe mempty (\hdr -> B.fromText hdr <> " ") compositeHeader + , maybe mempty B.fromText compositePrefix + ] + + sepElemsBy :: Char -> [NonEmpty Builder] -> [NonEmpty Builder] + sepElemsBy sep = zipWith aux (True : repeat False) + where + aux :: Bool -> NonEmpty Builder -> NonEmpty Builder + aux firstEntry (firstLine :| rest) = + ( if firstEntry + then (B.singleton ' ' <> B.singleton ' ' <> firstLine) + else (B.singleton sep <> B.singleton ' ' <> firstLine) + ) + :| indent rest + +{------------------------------------------------------------------------------- + Rendering auxiliary +-------------------------------------------------------------------------------} + +indent :: [Builder] -> [Builder] +indent = map (B.fromText " " <>) + +addNumericUnderscores :: String -> String +addNumericUnderscores = + reverse + . aux + . reverse + where + aux :: String -> String + aux str = + case splitAt 3 str of + (_ , [] ) -> str + (firstThree , rest) -> firstThree ++ "_" ++ aux rest + +-- | Generation of @intercalate@ from the Prelude +intercalate :: Monoid a => a -> [a] -> a +intercalate x = mconcat . intersperse x \ No newline at end of file diff --git a/src/Data/Structured/TH.hs b/src/Data/Structured/TH.hs new file mode 100644 index 0000000..cac0919 --- /dev/null +++ b/src/Data/Structured/TH.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Data.Structured.TH ( + deriveInstance + ) where + +import qualified Data.Structured as Structured +import qualified Data.Text as Text + +import Language.Haskell.TH +import Language.Haskell.TH.Datatype + +-- | Derive 'Show' instance +-- +-- Normally TH is not required, and you can rely on generics instead. However, +-- in some cases TH is the only option; for example, this is the case when +-- deriving a 'Show' instance for a GADT. +-- +-- Example usage: +-- +-- > Structured.deriveInstance 'ConstrOfMyType [t| +-- > forall a. Structured.Show a => Structured.Show (MyType a) +-- > |] +-- +-- All type variables must be explicitly quantified (use an empty forall if +-- there are none), and any required constraints must be explicitly listed. In +-- addition, one of the constructors of @MyType@ must be listed (this is used to +-- resolve the datatype, ensuring that it works with regular datatypes as well +-- as associated datatypes). +deriveInstance :: Name -> Q Type -> Q [Dec] +deriveInstance constr header = do + info <- reifyDatatype constr + (ctxt, rhs) <- parseHeader =<< header + (:[]) <$> + instanceD + (return ctxt) + (return rhs) + [ funD 'Structured.toValue $ map caseFor (datatypeCons info) + ] + +-- | Parse instance header +parseHeader :: Type -> Q (Cxt, Type) +parseHeader = \case + ForallT _bndrs ctxt rhs@(AppT (ConT nameShow) _) + | nameShow == ''Structured.Show + -> return (ctxt, rhs) + _otherwise -> + fail $ "Invalid header" + +-- | Case for one of the constructors +caseFor :: ConstructorInfo -> Q Clause +caseFor ConstructorInfo{ + constructorName = con + , constructorFields = fields + , constructorVariant = variant + } = do + args <- mapM (const $ newName "x") fields + clause + [conP con (map varP args)] + ( normalB $ + case variant of + RecordConstructor fieldNames -> record fieldNames args + _otherwise -> constr args + ) + [] + where + -- Regular (non-record) constructor + constr :: [Name] -> ExpQ + constr args = appsE [ + conE 'Structured.Constr + , varE 'Text.pack + `appE` + litE (StringL (nameBase con)) + , listE [] -- We do not support any type applications + , listE $ + map + (\x -> varE 'Structured.toValue `appE` varE x) + args + ] + + record :: [Name] -> [Name] -> ExpQ + record fieldNames args = appsE [ + conE 'Structured.Record + , varE 'Text.pack + `appE` + litE (StringL (nameBase con)) + , listE $ + zipWith + (\f x -> tupE [ + litE (StringL (nameBase f)) + , varE 'Structured.toValue `appE` varE x + ] + ) + fieldNames + args + ] diff --git a/src/Foreign/Rust/External/Bincode.hs b/src/Foreign/Rust/External/Bincode.hs new file mode 100644 index 0000000..57fbfa4 --- /dev/null +++ b/src/Foreign/Rust/External/Bincode.hs @@ -0,0 +1,34 @@ +-- | External (Rust-side) Bincode serialisation/deserialisation +-- +-- Intended for qualified import. +-- +-- > import qualified Foreign.Rust.External.Bincode as External +module Foreign.Rust.External.Bincode ( + -- * Serialisation + Bincode(..) + , ToBincode(..) + , FromBincode(..) + ) where + +import Codec.Borsh + +import qualified Data.ByteString.Lazy as Lazy + +import Foreign.Rust.Serialisation.Raw + +{------------------------------------------------------------------------------- + Serialisation +-------------------------------------------------------------------------------} + +newtype Bincode = Bincode Lazy.ByteString + deriving stock (Eq) + deriving newtype (BorshSize, ToBorsh, FromBorsh) + deriving newtype (IsRaw) + +-- | Types with an external Bincode serialiser (typically, in Rust) +class ToBincode a where + toBincode :: a -> Bincode + +-- | Types with an external Bincode deserialiser (typically, in Rust) +class FromBincode a where + fromBincode :: Bincode -> Either String a \ No newline at end of file diff --git a/src/Foreign/Rust/External/JSON.hs b/src/Foreign/Rust/External/JSON.hs new file mode 100644 index 0000000..e8ad823 --- /dev/null +++ b/src/Foreign/Rust/External/JSON.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | External (Rust-side) JSON serialisation/deserialisation +-- +-- Intended for qualified import. +-- +-- > import Foreign.Rust.External.JSON (UseExternalJSON, ShowAsJSON) +-- > import qualified Foreign.Rust.External.JSON as External +module Foreign.Rust.External.JSON ( + -- * Serialisation + JSON(..) + , ToJSON(..) + , FromJSON(..) + -- * Deriving-via: derive Aeson instances using external (de)serialiser + , UseExternalJSON(..) + ) where + +import Codec.Borsh + +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Encoding as Aeson (unsafeToEncoding) +import qualified Data.Aeson.Types as Aeson (parseFail) +import qualified Data.Binary.Builder as Binary +import qualified Data.ByteString.Lazy as Lazy (ByteString) + +{------------------------------------------------------------------------------- + Serialisation +-------------------------------------------------------------------------------} + +-- | Serialised JSON +newtype JSON = JSON Lazy.ByteString + deriving stock (Eq) + deriving newtype (BorshSize, ToBorsh, FromBorsh) + +-- | Types with an external JSON renderer (typically, in Rust) +class ToJSON a where + toJSON :: a -> JSON + +-- | Types with an external JSON parser (typically, in Rust) +class FromJSON a where + fromJSON :: JSON -> Either String a + +{------------------------------------------------------------------------------- + Deriving-via: derive Aeson instances using external (de)serialiser +-------------------------------------------------------------------------------} + +newtype UseExternalJSON a = UseExternalJSON a + +instance ToJSON a => Aeson.ToJSON (UseExternalJSON a) where + toJSON (UseExternalJSON x) = + reparse (toJSON x) + where + -- We get serialised JSON from the external renderer, and then need to + -- re-parse that to a 'Value'. If this fails, however, it would mean that + -- the Rust-side generated invalid JSON. + reparse :: JSON -> Aeson.Value + reparse (JSON bs) = + case Aeson.eitherDecode bs of + Left err -> error err + Right val -> val + + -- This relies on 'toJSON' generating valid JSON + toEncoding (UseExternalJSON x) = + case toJSON x of + JSON bs -> Aeson.unsafeToEncoding $ Binary.fromLazyByteString bs + +instance FromJSON a => Aeson.FromJSON (UseExternalJSON a) where + parseJSON val = + case fromJSON (JSON (Aeson.encode val)) of + Left failure -> Aeson.parseFail failure + Right tx -> return $ UseExternalJSON tx + diff --git a/src/Foreign/Rust/Failure.hs b/src/Foreign/Rust/Failure.hs new file mode 100644 index 0000000..3043442 --- /dev/null +++ b/src/Foreign/Rust/Failure.hs @@ -0,0 +1,27 @@ +module Foreign.Rust.Failure ( + Failure -- Opaque + , failureMessage + , mkFailure + ) where + +import GHC.Stack +import Data.Text (Text) + +-- | Failure reported by a Rust function +-- +-- TODO: For some cases we might be able to attach a Rust callstack, too. +data Failure = Failure { + failureMessage :: Text + , failureCallstackHaskell :: PrettyCallStack + } + deriving (Show) + +mkFailure :: HasCallStack => Text -> Failure +mkFailure e = Failure e (PrettyCallStack callStack) + +newtype PrettyCallStack = PrettyCallStack CallStack + +instance Show PrettyCallStack where + show (PrettyCallStack stack) = prettyCallStack stack + + diff --git a/src/Foreign/Rust/Marshall/Fixed.hs b/src/Foreign/Rust/Marshall/Fixed.hs new file mode 100644 index 0000000..dc7d91d --- /dev/null +++ b/src/Foreign/Rust/Marshall/Fixed.hs @@ -0,0 +1,55 @@ +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +-- | Marshalling to and from Rust, using Borsh +-- +-- This module deals with types with fixed sized encodings. +-- See also "Foreign.Rust.Marshall.Variable". +module Foreign.Rust.Marshall.Fixed ( + -- * Haskell to Rust + toBorshFixed + -- * Rust to Haskell + , allocFixedBuffer + , fromBorshFixed + ) where + +import Codec.Borsh +import Data.Proxy +import Data.Typeable (Typeable) +import Foreign +import Foreign.C.Types + +import qualified Data.ByteString as Strict + +import Foreign.Rust.Marshall.Util + +{------------------------------------------------------------------------------- + Haskell to Rust +-------------------------------------------------------------------------------} + +toBorshFixed :: + (ToBorsh a, StaticBorshSize a ~ 'HasKnownSize) + => a -> ((Ptr CUChar, CULong) -> IO r) -> IO r +toBorshFixed a k = + Strict.useAsCStringLen (serialiseStrict a) (k . castFromSignedLen) + +{------------------------------------------------------------------------------- + Rust to Haskell +-------------------------------------------------------------------------------} + +allocFixedBuffer :: forall a. + (BorshSize a, StaticBorshSize a ~ 'HasKnownSize) + => ((Ptr CUChar, CULong) -> IO a) -> IO a +allocFixedBuffer k = + case borshSize (Proxy @a) of + SizeKnown n -> + allocaBytes (cast n) $ \ptr -> k (ptr, fromIntegral n) + where + cast :: Word32 -> Int + cast = fromIntegral + +fromBorshFixed :: + (FromBorsh a, StaticBorshSize a ~ 'HasKnownSize, Typeable a) + => Ptr CUChar -> CULong -> IO a +fromBorshFixed ptr len = + deserialiseStrictOrPanic <$> + Strict.packCStringLen (castToSigned ptr, fromIntegral len) diff --git a/src/Foreign/Rust/Marshall/Util.hs b/src/Foreign/Rust/Marshall/Util.hs new file mode 100644 index 0000000..4cffbfc --- /dev/null +++ b/src/Foreign/Rust/Marshall/Util.hs @@ -0,0 +1,58 @@ +module Foreign.Rust.Marshall.Util ( + -- * Borsh + serialiseStrict + , deserialiseStrictOrPanic + , deserialiseLazyOrPanic + -- * Casting + , castFromSigned + , castToSigned + , castFromSignedLen + ) where + +import Codec.Borsh +import Data.Typeable +import Foreign +import Foreign.C +import GHC.Stack + +import qualified Data.ByteString as Strict +import qualified Data.ByteString.Lazy as Lazy + +{------------------------------------------------------------------------------- + Borsh +-------------------------------------------------------------------------------} + +serialiseStrict :: ToBorsh a => a -> Strict.ByteString +serialiseStrict = Lazy.toStrict . serialiseBorsh + +deserialiseStrictOrPanic :: + (HasCallStack, FromBorsh a, Typeable a) + => Strict.ByteString -> a +deserialiseStrictOrPanic = deserialiseLazyOrPanic . Lazy.fromStrict + +deserialiseLazyOrPanic :: forall a. + (HasCallStack, FromBorsh a, Typeable a) + => Lazy.ByteString -> a +deserialiseLazyOrPanic bs = + case deserialiseBorsh bs of + Right a -> a + Left err -> error $ concat [ + "deserialiseLazyOrPanic for " ++ show (typeOf (Proxy @a)) ++ ": " + , show err ++ "\n" + , "buffer: " ++ show (Lazy.unpack bs) + , " (" ++ show (Lazy.length bs) ++ ")" + ] + +{------------------------------------------------------------------------------- + Casting +-------------------------------------------------------------------------------} + +castFromSigned :: Ptr CChar -> Ptr CUChar +castFromSigned = castPtr + +castToSigned :: Ptr CUChar -> Ptr CChar +castToSigned = castPtr + +castFromSignedLen :: (Ptr CChar, Int) -> (Ptr CUChar, CULong) +castFromSignedLen (ptr, len) = (castFromSigned ptr, fromIntegral len) + diff --git a/src/Foreign/Rust/Marshall/Variable.hs b/src/Foreign/Rust/Marshall/Variable.hs new file mode 100644 index 0000000..25e8465 --- /dev/null +++ b/src/Foreign/Rust/Marshall/Variable.hs @@ -0,0 +1,141 @@ +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +-- | Marshalling to and from Rust, using Borsh +-- +-- This module deals with types with variable sized encodings. +-- See also "Foreign.Rust.Marshall.Fixed". +module Foreign.Rust.Marshall.Variable ( + -- * Haskell to Rust + toBorshVar + -- * Rust to Haskell + , Buffer -- opaque + , getVarBuffer + , withBorshVarBuffer + , withBorshMaxBuffer + , withBorshFailure + ) where + +import Codec.Borsh +import Data.Bifunctor +import Data.Text (Text) +import Data.Typeable +import Foreign +import Foreign.C.Types +import GHC.Stack +import System.IO.Unsafe (unsafePerformIO) + +import qualified Data.ByteString as Strict + +import Foreign.Rust.Marshall.Util +import Foreign.Rust.Failure + +{------------------------------------------------------------------------------- + Haskell to Rust +-------------------------------------------------------------------------------} + +toBorshVar :: + (ToBorsh a, StaticBorshSize a ~ 'HasVariableSize) + => a -> ((Ptr CUChar, CULong) -> IO r) -> IO r +toBorshVar a k = + Strict.useAsCStringLen (serialiseStrict a) (k . castFromSignedLen) + +{------------------------------------------------------------------------------- + Rust to Haskell +-------------------------------------------------------------------------------} + +-- | Buffer containing value of (phantom) type @a@ +data Buffer a = Buffer (Ptr CUChar) (Ptr CULong) + +getVarBuffer :: Buffer a -> (Ptr CUChar, Ptr CULong) +getVarBuffer (Buffer buf ptrSize) = (buf, ptrSize) + +-- | Provide buffer for foreign call +-- +-- We start with an initial buffer of 1 kB. If that suffices, we copy the +-- (appropriate part of) the buffer to a ByteString and we're done. If not, +-- the foreign call will tell us what the required buffer size is, so we +-- try again with a larger buffer. +-- +-- We allocate these buffers on the Haskell heap ('allocaBytes'), not the C +-- heap ('malloc'). This ensures that these buffers are visible to Haskell +-- profiling tools, and also appears to be more reliable on OSX. A slight +-- downside is that it doesn't give us a way to /change/ the size of a buffer, +-- but that's not an essential feature. +withBorshVarBuffer :: forall a. + ( FromBorsh a + , StaticBorshSize a ~ 'HasVariableSize + , Typeable a + ) + => (Buffer a -> IO ()) -> a +withBorshVarBuffer = withBorshBufferOfInitSize 1024 + +withBorshMaxBuffer :: forall a. + ( FromBorsh a + , StaticBorshSize a ~ 'HasVariableSize + , BorshMaxSize a + , Typeable a + ) + => (Buffer a -> IO ()) -> a +withBorshMaxBuffer = + withBorshBufferOfInitSize initBufSize + where + initBufSize :: CULong + initBufSize = fromIntegral $ borshMaxSize (Proxy @a) + +-- | Wrapper around 'withBorshVarBuffer' with explicit support for failures +withBorshFailure :: forall a. + ( FromBorsh a + , StaticBorshSize a ~ 'HasVariableSize + , Typeable a + , HasCallStack + ) + => (Buffer (Either Text a) -> IO ()) -> Either Failure a +withBorshFailure = first mkFailure . withBorshVarBuffer + +{------------------------------------------------------------------------------- + Internal auxiliary +-------------------------------------------------------------------------------} + +-- | Generalization of 'withBorshVarBuffer' and 'withMaxBorshBuffer' +withBorshBufferOfInitSize :: forall a. + ( FromBorsh a + , StaticBorshSize a ~ 'HasVariableSize + , Typeable a + ) + => CULong -> (Buffer a -> IO ()) -> a +withBorshBufferOfInitSize initBufSize f = unsafePerformIO $ do + mFirstAttempt <- allocaBytes (culongToInt initBufSize) $ \buf -> do + (bigEnough, reqSz) <- callWithSize buf initBufSize + if bigEnough then + Right . deserialiseStrictOrPanic <$> + Strict.packCStringLen (castPtr buf, culongToInt reqSz) + else + return $ Left reqSz + case mFirstAttempt of + Right r -> + return r + Left reqSz -> do + allocaBytes (culongToInt reqSz) $ \buf -> do + (bigEnough, reqSz') <- callWithSize buf reqSz + if bigEnough && reqSz == reqSz' then + deserialiseStrictOrPanic <$> + Strict.packCStringLen (castPtr buf, culongToInt reqSz) + else + fail $ concat [ + "withBorshVarBuffer: unexpected change in required buffer size. " + , "was " ++ show reqSz ++ ", " + , "now " ++ show reqSz' ++ "." + ] + where + -- Call the function with the current buffer size + -- Returns whether or not the buffer was big enough, and the required size + callWithSize :: Ptr CUChar -> CULong -> IO (Bool, CULong) + callWithSize buf providedSize = alloca $ \ptrBufSize -> do + poke ptrBufSize providedSize + f $ Buffer buf ptrBufSize + requiredSize <- peek ptrBufSize + return (requiredSize <= providedSize, requiredSize) + + -- Buffer allocations should not take a signed 'Int' as argument 🙄 + culongToInt :: CULong -> Int + culongToInt = fromIntegral diff --git a/src/Foreign/Rust/SafeConv.hs b/src/Foreign/Rust/SafeConv.hs new file mode 100644 index 0000000..e8752a5 --- /dev/null +++ b/src/Foreign/Rust/SafeConv.hs @@ -0,0 +1,18 @@ +module Foreign.Rust.SafeConv ( + SafeConv(..) + ) where + +import Data.Word +import Foreign.C.Types + +class SafeConv a b where + safeConvFrom :: a -> b + safeConvTo :: b -> a + +instance SafeConv CULong Word64 where + safeConvFrom = fromIntegral + safeConvTo = fromIntegral + +instance SafeConv CULLong Word64 where + safeConvFrom = fromIntegral + safeConvTo = fromIntegral diff --git a/src/Foreign/Rust/Serialisation/JSON.hs b/src/Foreign/Rust/Serialisation/JSON.hs new file mode 100644 index 0000000..34a90c5 --- /dev/null +++ b/src/Foreign/Rust/Serialisation/JSON.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Serialise opaque types using JSON +-- +-- See "Foreign.Rust.Serialisation.Raw" for detailed discussion. +module Foreign.Rust.Serialisation.JSON ( + -- * Deriving-via support + AsJSON(..) + -- * Show instance + , asJSON + ) where + +import Data.Annotated +import Data.Aeson (FromJSON(..)) +import Data.Typeable + +import qualified Data.Aeson.Types as Aeson +import qualified Data.Structured as Structured + +{------------------------------------------------------------------------------- + Deriving-via combinator +-------------------------------------------------------------------------------} + +-- | Serialise using JSON +-- +-- The 'Show' instance will produce something like +-- +-- > asJSON @UsesJSON +-- > [aesonQQ| +-- > { +-- > "a": null +-- > , "b": [1,2,3] +-- > } +-- > |] +-- +-- This depends on 'asJSON' (defined in this module), @QuasiQuotes@ and +-- "Data.Aeson.QQ.Simple". +-- +-- NOTE: 'Annotated' instance is only useful when using 'AsBase64' directly +-- (rather than using deriving-via). +newtype AsJSON a = AsJSON { unwrapAsJSON :: a } + deriving newtype CanAnnotate + +{------------------------------------------------------------------------------- + Show +-------------------------------------------------------------------------------} + +deriving + via Structured.ToPreludeShow (AsJSON a) + instance (Typeable a, Aeson.ToJSON a) => Show (AsJSON a) + +instance (Typeable a, Aeson.ToJSON a) => Structured.Show (AsJSON a) where + toValue (AsJSON x) = + Structured.Constr "asJSON" [typeRep (Proxy @a)] [ + Structured.JSON (Aeson.toJSON x) + ] + +asJSON :: forall a. FromJSON a => Aeson.Value -> a +asJSON = either error id . Aeson.parseEither Aeson.parseJSON diff --git a/src/Foreign/Rust/Serialisation/Raw.hs b/src/Foreign/Rust/Serialisation/Raw.hs new file mode 100644 index 0000000..fb5804c --- /dev/null +++ b/src/Foreign/Rust/Serialisation/Raw.hs @@ -0,0 +1,107 @@ +-- | Dealing with types that are represented in raw form Haskell side +module Foreign.Rust.Serialisation.Raw ( + IsRaw(..) + ) where + +import Data.FixedSizeArray (FixedSizeArray) +import Data.Proxy +import Data.Word +import GHC.TypeLits + +import qualified Data.ByteString as Strict +import qualified Data.ByteString.Lazy as Lazy +import qualified Data.FixedSizeArray as FSA +import qualified Data.Vector.Generic as Vector + +{------------------------------------------------------------------------------- + Abstract over raw representation +-------------------------------------------------------------------------------} + +-- | Datatype that is represented as raw bytes Haskell-side +-- +-- Sometimes when dealing with Rust-side values we represent them as opaque +-- values Haskell side: essentially just a list of bytes. However, we typically +-- still want to be able to display, serialise and deserialise such values. +-- +-- 'IsRaw' abstracts over how exactly those raw bytes stored; in the following +-- modules we then provide deriving-via combinators for specific encodings: +-- +-- * Foreign.Rust.Serialisation.Raw.Base16 (base-16, hexadecimal, hexdump) +-- * Foreign.Rust.Serialisation.Raw.Base58 (base-58, bitcoin format) +-- * Foreign.Rust.Serialisation.Raw.Base64 (base-64) +-- * Foreign.Rust.Serialisation.Raw.Decimal (list of decimal values) +-- +-- All of these modules provide combinators to derive +-- +-- * 'Prelude.Show' and 'Data.Structured.Show' (law-abiding in the sense of +-- generating valid Haskell) +-- * 'FromJSON' and 'ToJSON' +-- +-- All of these modules show the raw bytes, they just differ in /how/ they show +-- those raw bytes. If you want a more human-readable format, consider using +-- "Foreign.Rust.Serialisation.JSON". +class IsRaw a where + {-# MINIMAL (toRaw | toBytes), (fromRaw | fromBytes) #-} + + -- rawSize + + rawSize :: a -> Word32 + rawSize = fromIntegral . Lazy.length . toRaw + + -- toRaw + + toRaw :: a -> Lazy.ByteString + toRaw = Lazy.pack . toBytes + + toBytes :: a -> [Word8] + toBytes = Lazy.unpack . toRaw + + -- fromRaw + + fromRaw :: Lazy.ByteString -> Either String a + fromRaw = fromBytes . Lazy.unpack + + fromBytes :: [Word8] -> Either String a + fromBytes = fromRaw . Lazy.pack + + +{------------------------------------------------------------------------------- + ByteString +-------------------------------------------------------------------------------} + +instance IsRaw Lazy.ByteString where + rawSize = fromIntegral . Lazy.length + toRaw = id + fromRaw = Right + +instance IsRaw Strict.ByteString where + rawSize = fromIntegral . Strict.length + toRaw = Lazy.fromStrict + fromRaw = Right . Lazy.toStrict + +{------------------------------------------------------------------------------- + [Word8] +-------------------------------------------------------------------------------} + +instance IsRaw [Word8] where + rawSize = fromIntegral . length + toBytes = id + fromBytes = Right + +{------------------------------------------------------------------------------- + FixedSizeArray +-------------------------------------------------------------------------------} + +instance KnownNat n => IsRaw (FixedSizeArray n Word8) where + rawSize = const $ fromIntegral $ natVal (Proxy @n) + toBytes = Vector.toList + fromBytes = \xs -> + let expectedSize, actualSize :: Int + expectedSize = fromIntegral $ natVal (Proxy @n) + actualSize = length xs + in if actualSize == expectedSize + then Right $ FSA.fromList xs + else Left $ "Expected " ++ show expectedSize ++ "bytes, " + ++ "but got " ++ show actualSize ++ ": " + ++ show xs + diff --git a/src/Foreign/Rust/Serialisation/Raw/Base16.hs b/src/Foreign/Rust/Serialisation/Raw/Base16.hs new file mode 100644 index 0000000..15387ca --- /dev/null +++ b/src/Foreign/Rust/Serialisation/Raw/Base16.hs @@ -0,0 +1,83 @@ +-- | Base-16 encoding (hexdump) +-- +-- See "Foreign.Rust.Serialisation.Raw" for discussion. +module Foreign.Rust.Serialisation.Raw.Base16 ( + -- * Deriving-via support + AsBase16(..) + ) where + +import Control.Monad +import Data.Aeson (ToJSON(..), FromJSON(..), withText) +import Data.Annotated +import Data.String + +import qualified Data.Aeson.Types as Aeson +import qualified Data.ByteString.Base16.Lazy as Base16 +import qualified Data.ByteString.Lazy as Lazy +import qualified Data.ByteString.Lazy.Char8 as Char8 +import qualified Data.Structured as Structured +import qualified Data.Text as Text + +import Foreign.Rust.Serialisation.Raw + +{------------------------------------------------------------------------------- + Deriving-via combinator +-------------------------------------------------------------------------------} + +-- | Show values in base-16 (hexadecimal/hexdump) +-- +-- The 'Show' instance will produce something like +-- +-- > "01020304" +-- +-- This depends on @OverloadedStrings@. +-- +-- NOTE: 'Annotated' instance is only useful when using 'AsBase16' directly +-- (rather than using deriving-via). +newtype AsBase16 a = AsBase16 { unwrapAsBase16 ::a } + deriving newtype CanAnnotate + +{------------------------------------------------------------------------------- + JSON +-------------------------------------------------------------------------------} + +instance IsRaw a => ToJSON (AsBase16 a) where + toJSON = toJSON . encode . unwrapAsBase16 + +instance IsRaw a => FromJSON (AsBase16 a) where + parseJSON = either Aeson.parseFail (return . AsBase16) . decode <=< parseJSON + +{------------------------------------------------------------------------------- + Show +-------------------------------------------------------------------------------} + +instance IsRaw a => Show (AsBase16 a) where + show = show . encode . unwrapAsBase16 + +instance IsRaw a => Structured.Show (AsBase16 a) where + toValue = Structured.toValue . encode . unwrapAsBase16 + +instance IsRaw a => IsString (AsBase16 a) where + fromString = either error AsBase16 . decode . fromString + +{------------------------------------------------------------------------------- + Auxiliary: base-16 encoded value +-------------------------------------------------------------------------------} + +newtype Base16 = Base16 { getBase16 :: Lazy.ByteString } + deriving newtype (Show, IsString) + +instance ToJSON Base16 where + toJSON = Aeson.String . Text.pack . Char8.unpack . getBase16 + +instance FromJSON Base16 where + parseJSON = withText "Base16" $ return . Base16 . Char8.pack . Text.unpack + +instance Structured.Show Base16 where + toValue = Structured.String + +encode :: IsRaw a => a -> Base16 +encode = Base16 . Base16.encode . toRaw + +decode :: IsRaw a => Base16 -> Either String a +decode = fromRaw <=< Base16.decode . getBase16 diff --git a/src/Foreign/Rust/Serialisation/Raw/Base58.hs b/src/Foreign/Rust/Serialisation/Raw/Base58.hs new file mode 100644 index 0000000..7a62935 --- /dev/null +++ b/src/Foreign/Rust/Serialisation/Raw/Base58.hs @@ -0,0 +1,102 @@ +-- | Base-58 encoding +-- +-- See "Foreign.Rust.Serialisation.Raw" for discussion. +module Foreign.Rust.Serialisation.Raw.Base58 ( + -- * Deriving-via support + AsBase58(..) + ) where + +import Control.Monad +import Data.Aeson (ToJSON(..), FromJSON(..), withText) +import Data.Annotated +import Data.String + +import qualified Data.Aeson.Types as Aeson +import qualified Data.ByteString as Strict +import qualified Data.ByteString.Base58 as Base58 +import qualified Data.ByteString.Char8 as Char8 +import qualified Data.ByteString.Lazy as Lazy +import qualified Data.Structured as Structured +import qualified Data.Text as Text + +import Foreign.Rust.Serialisation.Raw + +{------------------------------------------------------------------------------- + Deriving-via combinator +-------------------------------------------------------------------------------} + +-- | Serialise using base-58 +-- +-- The 'Show' instance will produce something like +-- +-- > "2VfUX" +-- +-- This depends on @OverloadedStrings@. +-- +-- NOTE: 'Annotated' instance is only useful when using 'AsBase58' directly +-- (rather than using deriving-via). +newtype AsBase58 a = AsBase58 { unwrapAsBase58 :: a } + deriving newtype CanAnnotate + +{------------------------------------------------------------------------------- + JSON +-------------------------------------------------------------------------------} + +instance IsRaw a => ToJSON (AsBase58 a) where + toJSON = toJSON . encode . unwrapAsBase58 + +instance IsRaw a => FromJSON (AsBase58 a) where + parseJSON = either Aeson.parseFail (return . AsBase58) . decode <=< parseJSON + +{------------------------------------------------------------------------------- + Show +-------------------------------------------------------------------------------} + +instance IsRaw a => Show (AsBase58 a) where + show = show . encode . unwrapAsBase58 + +instance IsRaw a => Structured.Show (AsBase58 a) where + toValue = Structured.toValue . encode . unwrapAsBase58 + +instance IsRaw a => IsString (AsBase58 a) where + fromString = either error AsBase58 . decode . fromString + +{------------------------------------------------------------------------------- + Auxiliary: base-58 encoded value +-------------------------------------------------------------------------------} + +-- | Base58-encoded value +-- +-- NOTE: base-58 is a relatively expensive encoding; in particular, unlike +-- base-64, base-58 does not make it very easy to process chunks of data +-- separately. Ideally, it should therefore only be used for a small pieces of +-- data. For this reason, we use a strict bytestring here. +newtype Base58 = Base58 { getBase58 :: Strict.ByteString } + deriving newtype (Show, IsString) + +instance ToJSON Base58 where + toJSON = Aeson.String . Text.pack . Char8.unpack . getBase58 + +instance FromJSON Base58 where + parseJSON = withText "Base58" $ return . Base58 . Char8.pack . Text.unpack + +instance Structured.Show Base58 where + toValue = Structured.String + +encode :: IsRaw a => a -> Base58 +encode = Base58 . encodeBitcoin . Lazy.toStrict . toRaw + +decode :: IsRaw a => Base58 -> Either String a +decode = fromRaw <=< fmap Lazy.fromStrict . decodeBitcoin . getBase58 + +{------------------------------------------------------------------------------- + Internal auxiliary +-------------------------------------------------------------------------------} + +encodeBitcoin :: Strict.ByteString -> Strict.ByteString +encodeBitcoin = Base58.encodeBase58 Base58.bitcoinAlphabet + +decodeBitcoin :: Strict.ByteString -> Either String Strict.ByteString +decodeBitcoin = + maybe (Left "invalid Base58 encoding") Right + . Base58.decodeBase58 Base58.bitcoinAlphabet diff --git a/src/Foreign/Rust/Serialisation/Raw/Base64.hs b/src/Foreign/Rust/Serialisation/Raw/Base64.hs new file mode 100644 index 0000000..ca2f868 --- /dev/null +++ b/src/Foreign/Rust/Serialisation/Raw/Base64.hs @@ -0,0 +1,83 @@ +-- | Base-64 encoding +-- +-- See "Foreign.Rust.Serialisation.Raw" for discussion. +module Foreign.Rust.Serialisation.Raw.Base64 ( + -- * Deriving-via support + AsBase64(..) + ) where + +import Control.Monad +import Data.Aeson (ToJSON(..), FromJSON(..), withText) +import Data.Annotated +import Data.String + +import qualified Data.Aeson.Types as Aeson +import qualified Data.ByteString.Base64.Lazy as Base64 +import qualified Data.ByteString.Lazy as Lazy +import qualified Data.ByteString.Lazy.Char8 as Char8 +import qualified Data.Structured as Structured +import qualified Data.Text as Text + +import Foreign.Rust.Serialisation.Raw + +{------------------------------------------------------------------------------- + Deriving-via combinator +-------------------------------------------------------------------------------} + +-- | Serialise using base-64 +-- +-- The 'Show' instance will produce something like +-- +-- > "AQIDBA==" +-- +-- This depends on @OverloadedStrings@. +-- +-- NOTE: 'Annotated' instance is only useful when using 'AsBase64' directly +-- (rather than using deriving-via). +newtype AsBase64 a = AsBase64 { unwrapAsBase64 :: a } + deriving newtype CanAnnotate + +{------------------------------------------------------------------------------- + JSON +-------------------------------------------------------------------------------} + +instance IsRaw a => ToJSON (AsBase64 a) where + toJSON = toJSON . encode . unwrapAsBase64 + +instance IsRaw a => FromJSON (AsBase64 a) where + parseJSON = either Aeson.parseFail (return . AsBase64) . decode <=< parseJSON + +{------------------------------------------------------------------------------- + Show +-------------------------------------------------------------------------------} + +instance IsRaw a => Show (AsBase64 a) where + show = show . encode . unwrapAsBase64 + +instance IsRaw a => Structured.Show (AsBase64 a) where + toValue = Structured.toValue . encode . unwrapAsBase64 + +instance IsRaw a => IsString (AsBase64 a) where + fromString = either error AsBase64 . decode . fromString + +{------------------------------------------------------------------------------- + Auxiliary: base-64 encoded value +-------------------------------------------------------------------------------} + +newtype Base64 = Base64 { getBase64 :: Lazy.ByteString } + deriving newtype (Show, IsString) + +instance ToJSON Base64 where + toJSON = Aeson.String . Text.pack . Char8.unpack . getBase64 + +instance FromJSON Base64 where + parseJSON = withText "Base64" $ return . Base64 . Char8.pack . Text.unpack + +instance Structured.Show Base64 where + toValue = Structured.String + +encode :: IsRaw a => a -> Base64 +encode = Base64 . Base64.encode . toRaw + +decode :: IsRaw a => Base64 -> Either String a +decode = fromRaw <=< Base64.decode . getBase64 diff --git a/src/Foreign/Rust/Serialisation/Raw/Decimal.hs b/src/Foreign/Rust/Serialisation/Raw/Decimal.hs new file mode 100644 index 0000000..3f734cd --- /dev/null +++ b/src/Foreign/Rust/Serialisation/Raw/Decimal.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | List of decimal values +-- +-- See "Foreign.Rust.Serialisation.Raw" for discussion. +module Foreign.Rust.Serialisation.Raw.Decimal ( + -- * Deriving-via support + AsDecimal(..) + -- * Show instance + , asDecimal + ) where + +import Control.Monad +import Data.Aeson +import Data.Aeson.Types +import Data.Typeable +import Data.Word + +import qualified Data.Structured as Structured + +import Foreign.Rust.Serialisation.Raw + +{------------------------------------------------------------------------------- + Deriving-via combinator +-------------------------------------------------------------------------------} + +-- | Serialise to list of decimal values +-- +-- The 'Show' instance will produce something like +-- +-- > asDecimal @MyType [1,2,3,4] +-- +-- This depends on 'asDecimal' (defined in this module). +newtype AsDecimal a = AsDecimal { unwrapAsDecimal :: a } + +{------------------------------------------------------------------------------- + JSON +-------------------------------------------------------------------------------} + +instance IsRaw a => ToJSON (AsDecimal a) where + toJSON = toJSON . toBytes . unwrapAsDecimal + +instance IsRaw a => FromJSON (AsDecimal a) where + parseJSON = either parseFail (return . AsDecimal) . fromBytes <=< parseJSON + +{------------------------------------------------------------------------------- + Show +-------------------------------------------------------------------------------} + +deriving + via Structured.ToPreludeShow (AsDecimal a) + instance (Typeable a, IsRaw a) => Show (AsDecimal a) + +instance (Typeable a, IsRaw a) => Structured.Show (AsDecimal a) where + toValue (AsDecimal x) = + Structured.Constr "asDecimal" [typeRep (Proxy @a)] [ + Structured.toValue (toBytes x) + ] + +asDecimal :: IsRaw a => [Word8] -> a +asDecimal = either error id . fromBytes \ No newline at end of file diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 index 0000000..2f09689 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,18 @@ +module Main (main) where + +import Test.Tasty + +import qualified Test.Serialisation.JSON +import qualified Test.Serialisation.Raw.Base16 +import qualified Test.Serialisation.Raw.Base58 +import qualified Test.Serialisation.Raw.Base64 +import qualified Test.Serialisation.Raw.Decimal + +main :: IO () +main = defaultMain $ testGroup "foreign-rust" [ + Test.Serialisation.JSON.tests + , Test.Serialisation.Raw.Base16.tests + , Test.Serialisation.Raw.Base58.tests + , Test.Serialisation.Raw.Base64.tests + , Test.Serialisation.Raw.Decimal.tests + ] \ No newline at end of file diff --git a/test/Test/Serialisation/JSON.hs b/test/Test/Serialisation/JSON.hs new file mode 100644 index 0000000..c39b81e --- /dev/null +++ b/test/Test/Serialisation/JSON.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Test.Serialisation.JSON (tests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import Test.Serialisation.Types +import Test.Util.TH + +import Foreign.Rust.Serialisation.JSON (asJSON) + +tests :: TestTree +tests = testGroup "Test.Serialisation.JSON" [ + testCase "show" test_show + , testCase "structured" test_structured + ] + +test_show :: Assertion +test_show = + assertEqual "" exampleUsesJSON $ + $(reparseShow exampleUsesJSON) + +test_structured :: Assertion +test_structured = + assertEqual "" exampleUsesJSON $ + $(reparseStructured exampleUsesJSON) diff --git a/test/Test/Serialisation/Raw/Base16.hs b/test/Test/Serialisation/Raw/Base16.hs new file mode 100644 index 0000000..cfa6e46 --- /dev/null +++ b/test/Test/Serialisation/Raw/Base16.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Test.Serialisation.Raw.Base16 (tests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import qualified Data.Aeson as Aeson + +import Test.Serialisation.Types +import Test.Util.TH + +tests :: TestTree +tests = testGroup "Test.Serialisation.Raw.Base16" [ + testCase "show" test_show + , testCase "structured" test_structured + , testCase "json" test_json + ] + +test_show :: Assertion +test_show = + assertEqual "" exampleUsesBase16 $ + $(reparseShow exampleUsesBase16) + +test_structured :: Assertion +test_structured = + assertEqual "" exampleUsesBase16 $ + $(reparseStructured exampleUsesBase16) + +test_json :: Assertion +test_json = + assertEqual "" (Right exampleUsesBase16) $ + Aeson.eitherDecode $ Aeson.encode exampleUsesBase16 \ No newline at end of file diff --git a/test/Test/Serialisation/Raw/Base58.hs b/test/Test/Serialisation/Raw/Base58.hs new file mode 100644 index 0000000..52bfe5c --- /dev/null +++ b/test/Test/Serialisation/Raw/Base58.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Test.Serialisation.Raw.Base58 (tests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import qualified Data.Aeson as Aeson + +import Test.Serialisation.Types +import Test.Util.TH + +tests :: TestTree +tests = testGroup "Test.Serialisation.Raw.Base58" [ + testCase "show" test_show + , testCase "structured" test_structured + , testCase "json" test_json + ] + +test_show :: Assertion +test_show = + assertEqual "" exampleUsesBase58 $ + $(reparseShow exampleUsesBase58) + +test_structured :: Assertion +test_structured = + assertEqual "" exampleUsesBase58 $ + $(reparseStructured exampleUsesBase58) + +test_json :: Assertion +test_json = + assertEqual "" (Right exampleUsesBase58) $ + Aeson.eitherDecode $ Aeson.encode exampleUsesBase58 \ No newline at end of file diff --git a/test/Test/Serialisation/Raw/Base64.hs b/test/Test/Serialisation/Raw/Base64.hs new file mode 100644 index 0000000..a588ce2 --- /dev/null +++ b/test/Test/Serialisation/Raw/Base64.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Test.Serialisation.Raw.Base64 (tests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import qualified Data.Aeson as Aeson + +import Test.Serialisation.Types +import Test.Util.TH + +tests :: TestTree +tests = testGroup "Test.Serialisation.Raw.Base64" [ + testCase "show" test_show + , testCase "structured" test_structured + , testCase "json" test_json + ] + +test_show :: Assertion +test_show = + assertEqual "" exampleUsesBase64 $ + $(reparseShow exampleUsesBase64) + +test_structured :: Assertion +test_structured = + assertEqual "" exampleUsesBase64 $ + $(reparseStructured exampleUsesBase64) + +test_json :: Assertion +test_json = + assertEqual "" (Right exampleUsesBase64) $ + Aeson.eitherDecode $ Aeson.encode exampleUsesBase64 \ No newline at end of file diff --git a/test/Test/Serialisation/Raw/Decimal.hs b/test/Test/Serialisation/Raw/Decimal.hs new file mode 100644 index 0000000..9ecd4b9 --- /dev/null +++ b/test/Test/Serialisation/Raw/Decimal.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Test.Serialisation.Raw.Decimal (tests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import qualified Data.Aeson as Aeson + +import Test.Serialisation.Types +import Test.Util.TH + +import Foreign.Rust.Serialisation.Raw.Decimal (asDecimal) + +tests :: TestTree +tests = testGroup "Test.Serialisation.Raw.Decimal" [ + testCase "show" test_show + , testCase "structured" test_structured + , testCase "json" test_json + ] + +test_show :: Assertion +test_show = + assertEqual "" exampleUsesDecimal $ + $(reparseShow exampleUsesDecimal) + +test_structured :: Assertion +test_structured = + assertEqual "" exampleUsesDecimal $ + $(reparseStructured exampleUsesDecimal) + +test_json :: Assertion +test_json = + assertEqual "" (Right exampleUsesDecimal) $ + Aeson.eitherDecode $ Aeson.encode exampleUsesDecimal \ No newline at end of file diff --git a/test/Test/Serialisation/Types.hs b/test/Test/Serialisation/Types.hs new file mode 100644 index 0000000..cfea072 --- /dev/null +++ b/test/Test/Serialisation/Types.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE QuasiQuotes #-} + +-- | Example types +-- +-- Defined as separate module to avoid TH stage restrictions +module Test.Serialisation.Types ( + UsesDecimal(..) + , exampleUsesDecimal + , UsesBase16(..) + , exampleUsesBase16 + , UsesBase58(..) + , exampleUsesBase58 + , UsesBase64(..) + , exampleUsesBase64 + , UsesJSON(..) + , exampleUsesJSON + ) where + +import Data.Aeson +import Data.Aeson.QQ.Simple +import Data.String +import Data.Word + +import qualified Data.Structured as Structured + +import Foreign.Rust.Serialisation.JSON +import Foreign.Rust.Serialisation.Raw +import Foreign.Rust.Serialisation.Raw.Base16 +import Foreign.Rust.Serialisation.Raw.Base58 +import Foreign.Rust.Serialisation.Raw.Base64 +import Foreign.Rust.Serialisation.Raw.Decimal + +{------------------------------------------------------------------------------- + AsDecimal +-------------------------------------------------------------------------------} + +newtype UsesDecimal = UsesDecimal [Word8] + deriving stock (Eq) + deriving newtype (IsRaw) + deriving (Show, Structured.Show) via AsDecimal UsesDecimal + deriving (FromJSON, ToJSON) via AsDecimal UsesDecimal + +exampleUsesDecimal :: UsesDecimal +exampleUsesDecimal = UsesDecimal [1, 2, 3, 4] + +{------------------------------------------------------------------------------- + AsBase16 +-------------------------------------------------------------------------------} + +newtype UsesBase16 = UsesBase16 [Word8] + deriving stock (Eq) + deriving newtype (IsRaw) + deriving (Show, Structured.Show, IsString) via AsBase16 UsesBase16 + deriving (FromJSON, ToJSON) via AsBase16 UsesBase16 + +exampleUsesBase16 :: UsesBase16 +exampleUsesBase16 = UsesBase16 [1, 2, 3, 4] + +{------------------------------------------------------------------------------- + AsBase58 +-------------------------------------------------------------------------------} + +newtype UsesBase58 = UsesBase58 [Word8] + deriving stock (Eq) + deriving newtype (IsRaw) + deriving (Show, Structured.Show, IsString) via AsBase58 UsesBase58 + deriving (FromJSON, ToJSON) via AsBase58 UsesBase58 + +exampleUsesBase58 :: UsesBase58 +exampleUsesBase58 = UsesBase58 [1, 2, 3, 4] + +{------------------------------------------------------------------------------- + AsBase64 +-------------------------------------------------------------------------------} + +newtype UsesBase64 = UsesBase64 [Word8] + deriving stock (Eq) + deriving newtype (IsRaw) + deriving (Show, Structured.Show, IsString) via AsBase64 UsesBase64 + deriving (FromJSON, ToJSON) via AsBase64 UsesBase64 + +exampleUsesBase64 :: UsesBase64 +exampleUsesBase64 = UsesBase64 [1, 2, 3, 4] + +{------------------------------------------------------------------------------- + AsJSON +-------------------------------------------------------------------------------} + +newtype UsesJSON = UsesJSON Value + deriving stock (Eq) + deriving newtype (ToJSON, FromJSON) + deriving (Show, Structured.Show) via AsJSON UsesJSON + +exampleUsesJSON :: UsesJSON +exampleUsesJSON = UsesJSON [aesonQQ| + { "a": null + , "b": [1, 2, 3] + } + |] diff --git a/test/Test/Util/TH.hs b/test/Test/Util/TH.hs new file mode 100644 index 0000000..580298f --- /dev/null +++ b/test/Test/Util/TH.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Test.Util.TH ( + reparseShow + , reparseStructured + ) where + +import Data.String (fromString) + +import qualified Data.Structured as Structured +import qualified Language.Haskell.TH as TH +import qualified Language.Haskell.Exts as Exts +import Language.Haskell.TH (Q) +import Language.Haskell.TH.Quote +import Data.Aeson.QQ.Simple + +{------------------------------------------------------------------------------- + Parse expressions +-------------------------------------------------------------------------------} + +parseExp :: String -> Q TH.Exp +parseExp = + toExp + . Exts.fromParseResult + . Exts.parseExpWithMode parseMode + where + parseMode :: Exts.ParseMode + parseMode = Exts.defaultParseMode { + Exts.extensions = [ + Exts.EnableExtension Exts.OverloadedStrings + , Exts.EnableExtension Exts.TypeApplications + , Exts.EnableExtension Exts.QuasiQuotes + ] + } + +reparseShow :: Show a => a -> Q TH.Exp +reparseShow = parseExp . show + +reparseStructured :: Structured.Show a => a -> Q TH.Exp +reparseStructured = parseExp . Structured.show + +{------------------------------------------------------------------------------- + Translate haskell-src-exts @Exp@ to TH @Exp@ + + There is a package for this (@haskell-src-meta@), but it does not support + overloaded string nor quasi-quotes, which makes it rather useless for our + purposes. We only need to support a tiny handful of expressions, so we just + define it ourselves. +-------------------------------------------------------------------------------} + +toExp :: Exts.Exp Exts.SrcSpanInfo -> Q TH.Exp +toExp = \case + + -- Standard instances + -- (These would presumably be similar in haskell-src-meta) + + Exts.Var _ (Exts.UnQual _ (Exts.Ident _ n)) -> + pure $ TH.VarE $ TH.mkName n + Exts.App _ e (Exts.TypeApp _ (Exts.TyCon _ (Exts.UnQual _ (Exts.Ident _ n)))) -> + TH.AppTypeE <$> toExp e <*> pure (TH.ConT (TH.mkName n)) + Exts.App _ e1 e2 -> + TH.AppE <$> toExp e1 <*> toExp e2 + Exts.List _ es -> + TH.ListE <$> mapM toExp es + Exts.Lit _ (Exts.Int _ x _) -> + pure $ TH.LitE (TH.IntegerL x) + + -- Overloaded strings + + Exts.Lit _ (Exts.String _ x _) -> + pure $ TH.AppE (TH.VarE 'fromString) (TH.LitE (TH.StringL x)) + + -- Quasi-quotes + + Exts.QuasiQuote _ "aesonQQ" str -> + quoteExp aesonQQ str + + -- Anything else is urecognized + + e -> fail $ "toExp: unrecognized expression " ++ show e +