diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for borsh + +## 0.1.0 -- 2022-11-11 + +* First released version diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2022, Well-Typed LLP + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Edsko de Vries nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/borsh.cabal b/borsh.cabal new file mode 100644 --- /dev/null +++ b/borsh.cabal @@ -0,0 +1,138 @@ +cabal-version: 3.0 +name: borsh +version: 0.1.0 +synopsis: Implementation of BORSH serialisation +description: + This package provides type classes and combinators for + serialisation\/deserialisation to\/from [Borsh](https://borsh.io/) format. + Unlike [CBOR](http://cbor.io/), Borsh is a non self-describing serialisation + format. It is designed such that any object serialises to a canonical and + deterministic string of bytes. + + The library supports incremental encoding and incremental decoding, and + supports the use of the @ST@ monad in the decoder for efficient decoding for + types such as arrays. However, the library has currently not been optimized + for speed, and there may well be low-hanging fruit to make it faster. + +license: BSD-3-Clause +license-file: LICENSE +author: Edsko de Vries, Finley McIlwaine +maintainer: edsko@well-typed.com +category: Codec +build-type: Simple +extra-doc-files: CHANGELOG.md +bug-reports: https://github.com/well-typed/borsh/issues + +source-repository head + type: git + location: https://github.com/well-typed/borsh + +common lang + ghc-options: + -Wall + -Wredundant-constraints + if impl(ghc >= 8.10) + ghc-options: + -Wunused-packages + build-depends: + base >= 4.12 && < 4.17 + default-language: + Haskell2010 + default-extensions: + BangPatterns + ConstraintKinds + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + DerivingVia + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + NumericUnderscores + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + TypeOperators + UndecidableInstances + +library + import: + lang + exposed-modules: + Codec.Borsh + Codec.Borsh.Incremental + + Data.FixedSizeArray + Data.Int128 + Data.Word128 + other-modules: + Codec.Borsh.Class + Codec.Borsh.Decoding + Codec.Borsh.Encoding + Codec.Borsh.Incremental.Decoder + Codec.Borsh.Incremental.Located + Codec.Borsh.Incremental.Monad + Codec.Borsh.Internal.Util.BitwiseCast + Codec.Borsh.Internal.Util.ByteString + Codec.Borsh.Internal.Util.ByteSwap + Codec.Borsh.Internal.Util.SOP + hs-source-dirs: + src + build-depends: + , bytestring >= 0.10 && < 0.12 + , containers >= 0.6 && < 0.7 + , generics-sop >= 0.5 && < 0.6 + , memory >= 0.17 && < 0.19.0 + , sop-core >= 0.5 && < 0.6 + , text >= 1.2 && < 2.1 + + -- At least 0.13.0.0 necessary for re-exported PrimMonad and PrimState + , vector >= 0.13 && < 0.14 + , wide-word >= 0.1 && < 0.2 + +test-suite test-borsh + import: + lang + type: + exitcode-stdio-1.0 + hs-source-dirs: + test + main-is: + Main.hs + other-modules: + Test.Codec.Borsh.ExampleType.BTree + Test.Codec.Borsh.ExampleType.NTree + Test.Codec.Borsh.ExampleType.SimpleList + Test.Codec.Borsh.ExampleType.SimpleStructs + Test.Codec.Borsh.Roundtrip + Test.Codec.Borsh.Size + Test.Codec.Borsh.Util.Length + Test.Codec.Borsh.Util.Orphans + Test.Codec.Borsh.Util.QuickCheck + Test.Codec.Borsh.Util.RandomType + Test.Codec.Borsh.Util.SOP + build-depends: + , borsh + , bytestring + , containers + , generics-sop + , optics-core + , profunctors + , QuickCheck + , quickcheck-instances + , sop-core + , tasty + , tasty-quickcheck + , text diff --git a/src/Codec/Borsh.hs b/src/Codec/Borsh.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Borsh.hs @@ -0,0 +1,32 @@ +module Codec.Borsh ( + -- * Serialisation + ToBorsh(..) + , Encoder(..) + , serialiseBorsh + -- * Deserialisation + , FromBorsh(..) + , Decoder + , DeserialiseFailure(..) + , deserialiseBorsh + -- * Size of encodings + , BorshSize(..) + , Size(..) + , KnownSize(..) + , BorshSizeSum(..) + -- * Deriving-via support + , Struct(..) + ) where + +import Codec.Borsh.Class + ( BorshSizeSum(..), + Struct(..), + FromBorsh(..), + ToBorsh(..), + BorshSize(..), + Size(..), + KnownSize(..), + serialiseBorsh, + deserialiseBorsh ) +import Codec.Borsh.Encoding (Encoder(..)) +import Codec.Borsh.Incremental (Decoder) +import Codec.Borsh.Incremental.Monad (DeserialiseFailure(..)) diff --git a/src/Codec/Borsh/Class.hs b/src/Codec/Borsh/Class.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Borsh/Class.hs @@ -0,0 +1,758 @@ +{-# LANGUAGE PolyKinds #-} + +module Codec.Borsh.Class ( + -- * Serialisation + ToBorsh(..) + , FromBorsh(..) + -- ** Deriving-via support + , Struct(..) + -- * Size information + , KnownSize(..) + , Size(..) + , BorshSize(..) + , BorshSizeSum(..) + -- * Derived functionality + , serialiseBorsh + , deserialiseBorsh + ) where + +import Data.Functor.Contravariant +import Data.Int +import Data.Kind +import Data.Map (Map) +import Data.Proxy +import Data.Set (Set) +import Data.Text (Text) +import Data.Word +import Generics.SOP +import GHC.TypeNats + +import qualified Data.ByteString as S +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Lazy as L + +import Codec.Borsh.Decoding +import Codec.Borsh.Encoding +import Codec.Borsh.Incremental +import Data.FixedSizeArray (FixedSizeArray) +import Data.Int128 +import Data.Word128 (Word128) + +{------------------------------------------------------------------------------- + Size information + + We do not try to compute the size at the type-level (we don't need to and + this would get messy), but we /do/ record at the type level whether the + size is statically known or not. +-------------------------------------------------------------------------------} + +data KnownSize = HasKnownSize | HasVariableSize + +-- | The statically known size of encodings of values of a particular type. +data Size (a :: KnownSize) where + SizeKnown :: Int -> Size 'HasKnownSize + SizeVariable :: Size 'HasVariableSize + +deriving instance Show (Size a) +deriving instance Eq (Size a) + +class BorshSize (a :: Type) where + type StaticBorshSize a :: KnownSize + type StaticBorshSize a = SumKnownSize (Code a) + + -- | Size of the Borsh encoding, if known ahead of time + -- + -- See 'encodeBorsh' for discussion of the generic instance. + borshSize :: Proxy a -> Size (StaticBorshSize a) + + default borshSize :: + ( StaticBorshSize a ~ SumKnownSize (Code a) + , BorshSizeSum (Code a) + ) + => Proxy a -> Size (StaticBorshSize a) + borshSize _ = borshSizeSum (Proxy @(Code a)) + +{------------------------------------------------------------------------------- + Definition +-------------------------------------------------------------------------------} + +class BorshSize a => ToBorsh a where + -- | Encoder to Borsh + -- + -- NOTE: The default generic encoder uses the Borsh encoding for enums, + -- and will therefore use constructor tag; see 'Struct' for detailed + -- discussion. Since the spec mandates the presence of that constructor tag, + -- the generic encoder/decoder does not apply to types without constructors. + encodeBorsh :: Encoder a + + default encodeBorsh :: + (Generic a, BorshSizeSum (Code a), All2 ToBorsh (Code a)) + => Encoder a + encodeBorsh = Encoder $ runEncoder encodeBorsh . from + +class BorshSize a => FromBorsh a where + -- | Decode from Borsh + -- + -- See 'encodeBorsh' for discussion of the generic instance. + decodeBorsh :: Decoder s a + + default decodeBorsh :: + (Generic a, BorshSizeSum (Code a), All2 FromBorsh (Code a)) + => Decoder s a + decodeBorsh = to <$> decodeBorsh + +{------------------------------------------------------------------------------- + Structs +-------------------------------------------------------------------------------} + +-- | Deriving-via support for structs +-- +-- The Borsh spec mandates that enums have a tag indicating +-- the constructor, even when there is only a single constructor in the enum. +-- In Rust this makes more sense than in Haskell, since in Rust enums and +-- structs are introduced through different keywords. In Haskell, of course, +-- the only difference between them is that a struct is an enum with a single +-- constructor. +-- +-- The default generic encoder en decoder you get in 'ToBorsh' and 'FromBorsh' +-- will therefore add the tag, independent of the number of constructors. If +-- you want the encoding of a struct, without the tag, you need to use deriving +-- via: +-- +-- > data MyStruct = .. +-- > deriving (BorshSize, ToBorsh, FromBorsh) via Struct MyStruct +-- +-- NOTE: Doing so may have consequences for forwards compatibility: if a tag +-- is present, additional constructors can be added without invalidating the +-- encoding of existing constructors. +newtype Struct a = Struct { getStruct :: a } + +instance (IsProductType a xs, All BorshSize xs) => BorshSize (Struct a) where + type StaticBorshSize (Struct a) = ProdKnownSize (ProductCode a) + borshSize _ = sizeOfProd (Proxy @(ProductCode a)) + +instance ( IsProductType a xs + , All BorshSize xs + , All ToBorsh xs + ) => ToBorsh (Struct a) where + encodeBorsh = contramap (productTypeFrom . getStruct) encodeBorsh + +instance ( IsProductType a xs + , All BorshSize xs + , All FromBorsh xs + ) => FromBorsh (Struct a) where + decodeBorsh = fmap (Struct . productTypeTo) decodeBorsh + +{------------------------------------------------------------------------------- + Derived functionality +-------------------------------------------------------------------------------} + +serialiseBorsh :: ToBorsh a => a -> L.ByteString +serialiseBorsh = B.toLazyByteString . runEncoder encodeBorsh + +deserialiseBorsh :: FromBorsh a => L.ByteString -> Either DeserialiseFailure a +deserialiseBorsh bs = + aux <$> deserialiseByteString decodeBorsh bs + where + aux (_leftover, _offset, a) = a + +{------------------------------------------------------------------------------- + Sizes +-------------------------------------------------------------------------------} + +instance BorshSize Word8 where + type StaticBorshSize Word8 = 'HasKnownSize + borshSize _ = SizeKnown 1 + +instance BorshSize Word16 where + type StaticBorshSize Word16 = 'HasKnownSize + borshSize _ = SizeKnown 2 + +instance BorshSize Word32 where + type StaticBorshSize Word32 = 'HasKnownSize + borshSize _ = SizeKnown 4 + +instance BorshSize Word64 where + type StaticBorshSize Word64 = 'HasKnownSize + borshSize _ = SizeKnown 8 + +instance BorshSize Word128 where + type StaticBorshSize Word128 = 'HasKnownSize + borshSize _ = SizeKnown 16 + +instance BorshSize Int8 where + type StaticBorshSize Int8 = 'HasKnownSize + borshSize _ = SizeKnown 1 + +instance BorshSize Int16 where + type StaticBorshSize Int16 = 'HasKnownSize + borshSize _ = SizeKnown 2 + +instance BorshSize Int32 where + type StaticBorshSize Int32 = 'HasKnownSize + borshSize _ = SizeKnown 4 + +instance BorshSize Int64 where + type StaticBorshSize Int64 = 'HasKnownSize + borshSize _ = SizeKnown 8 + +instance BorshSize Int128 where + type StaticBorshSize Int128 = 'HasKnownSize + borshSize _ = SizeKnown 16 + +instance BorshSize Float where + type StaticBorshSize Float = 'HasKnownSize + borshSize _ = SizeKnown 4 + +instance BorshSize Double where + type StaticBorshSize Double = 'HasKnownSize + borshSize _ = SizeKnown 8 + +instance (KnownNat n, BorshSize a) => BorshSize (FixedSizeArray n a) where + type StaticBorshSize (FixedSizeArray n a) = StaticBorshSize a + + borshSize _ = + case borshSize (Proxy @a) of + SizeVariable -> SizeVariable + SizeKnown n -> SizeKnown (n * fromIntegral (natVal (Proxy @n))) + +instance BorshSize Text where + type StaticBorshSize Text = 'HasVariableSize + borshSize _ = SizeVariable + +instance BorshSize [a] where + -- Use generic defaults + +instance BorshSize (Maybe a) where + -- Use generic defaults + +instance BorshSize (Set a) where + type StaticBorshSize (Set a) = 'HasVariableSize + borshSize _ = SizeVariable + +instance BorshSize (Map k a) where + type StaticBorshSize (Map k a) = 'HasVariableSize + borshSize _ = SizeVariable + +instance All BorshSize xs => BorshSize (NP I xs) where + type StaticBorshSize (NP I xs) = ProdKnownSize xs + borshSize _ = sizeOfProd (Proxy @xs) + +instance BorshSizeSum xss => BorshSize (SOP I xss) where + type StaticBorshSize (SOP I xss) = SumKnownSize xss + borshSize _ = borshSizeSum (Proxy @xss) + +{------------------------------------------------------------------------------- + ToBorsh instances +-------------------------------------------------------------------------------} + +instance ToBorsh Word8 where encodeBorsh = encodeU8 +instance ToBorsh Word16 where encodeBorsh = encodeU16 +instance ToBorsh Word32 where encodeBorsh = encodeU32 +instance ToBorsh Word64 where encodeBorsh = encodeU64 +instance ToBorsh Word128 where encodeBorsh = encodeU128 +instance ToBorsh Int8 where encodeBorsh = encodeI8 +instance ToBorsh Int16 where encodeBorsh = encodeI16 +instance ToBorsh Int32 where encodeBorsh = encodeI32 +instance ToBorsh Int64 where encodeBorsh = encodeI64 +instance ToBorsh Int128 where encodeBorsh = encodeI128 +instance ToBorsh Float where encodeBorsh = encodeF32 +instance ToBorsh Double where encodeBorsh = encodeF64 +instance ToBorsh Text where encodeBorsh = encodeString + +instance (KnownNat n, ToBorsh a) => ToBorsh (FixedSizeArray n a) where + encodeBorsh = encodeArray encodeBorsh + +instance ToBorsh a => ToBorsh [a] where + encodeBorsh = encodeVec encodeBorsh + +instance ToBorsh a => ToBorsh (Maybe a) where + encodeBorsh = encodeOption encodeBorsh + +instance ToBorsh a => ToBorsh (Set a) where + encodeBorsh = encodeHashSet encodeBorsh + +instance (ToBorsh k, ToBorsh a) => ToBorsh (Map k a) where + encodeBorsh = encodeHashMap encodeBorsh encodeBorsh + +instance (All BorshSize xs, All ToBorsh xs) => ToBorsh (NP I xs) where + encodeBorsh = encodeStruct $ hcpure (Proxy @ToBorsh) encodeBorsh + +instance ( BorshSizeSum xss + , All2 ToBorsh xss + , All SListI xss + ) => ToBorsh (SOP I xss) where + encodeBorsh = encodeEnum $ hcpure (Proxy @ToBorsh) encodeBorsh + +{------------------------------------------------------------------------------- + FromBorsh instances +-------------------------------------------------------------------------------} + +instance FromBorsh Word8 where decodeBorsh = decodeU8 +instance FromBorsh Word16 where decodeBorsh = decodeU16 +instance FromBorsh Word32 where decodeBorsh = decodeU32 +instance FromBorsh Word64 where decodeBorsh = decodeU64 +instance FromBorsh Word128 where decodeBorsh = decodeU128 +instance FromBorsh Int8 where decodeBorsh = decodeI8 +instance FromBorsh Int16 where decodeBorsh = decodeI16 +instance FromBorsh Int32 where decodeBorsh = decodeI32 +instance FromBorsh Int64 where decodeBorsh = decodeI64 +instance FromBorsh Int128 where decodeBorsh = decodeI128 +instance FromBorsh Float where decodeBorsh = decodeF32 +instance FromBorsh Double where decodeBorsh = decodeF64 +instance FromBorsh Text where decodeBorsh = decodeString + +instance FromBorsh a => FromBorsh [a] where + decodeBorsh = decodeVec decodeBorsh + +instance (FromBorsh a, KnownNat n) => FromBorsh (FixedSizeArray n a) where + decodeBorsh = decodeArray decodeBorsh + +instance FromBorsh a => FromBorsh (Maybe a) where + decodeBorsh = decodeOption decodeBorsh + +instance (FromBorsh a, Ord a) => FromBorsh (Set a) where + decodeBorsh = decodeHashSet decodeBorsh + +instance + (FromBorsh k, FromBorsh a, Ord k) + => FromBorsh (Map k a) where + decodeBorsh = decodeHashMap decodeBorsh decodeBorsh + +instance (All BorshSize xs, All FromBorsh xs) => FromBorsh (NP I xs) where + decodeBorsh = decodeStruct $ hcpure (Proxy @FromBorsh) decodeBorsh + +instance ( BorshSizeSum xss + , All SListI xss + , All2 FromBorsh xss + ) => FromBorsh (SOP I xss) where + decodeBorsh = decodeEnum $ hcpure (Proxy @FromBorsh) decodeBorsh + +{------------------------------------------------------------------------------- + Instances for tuples +-------------------------------------------------------------------------------} + +-- size 0 + +deriving via Struct () instance BorshSize () +deriving via Struct () instance ToBorsh () +deriving via Struct () instance FromBorsh () + +-- size 2 + +deriving via Struct (a, b) + instance + ( BorshSize a + , BorshSize b + ) + => BorshSize (a, b) +deriving via Struct (a, b) + instance + ( ToBorsh a + , ToBorsh b + ) + => ToBorsh (a, b) +deriving via Struct (a, b) + instance + ( FromBorsh a + , FromBorsh b + ) + => FromBorsh (a, b) + +-- size 3 + +deriving via Struct (a, b, c) + instance + ( BorshSize a + , BorshSize b + , BorshSize c + ) + => BorshSize (a, b, c) +deriving via Struct (a, b, c) + instance + ( ToBorsh a + , ToBorsh b + , ToBorsh c + ) + => ToBorsh (a, b, c) +deriving via Struct (a, b, c) + instance + ( FromBorsh a + , FromBorsh b + , FromBorsh c + ) + => FromBorsh (a, b, c) + +-- size 4 + +deriving via Struct (a, b, c, d) + instance + ( BorshSize a + , BorshSize b + , BorshSize c + , BorshSize d + ) + => BorshSize (a, b, c, d) +deriving via Struct (a, b, c, d) + instance + ( ToBorsh a + , ToBorsh b + , ToBorsh c + , ToBorsh d + ) + => ToBorsh (a, b, c, d) +deriving via Struct (a, b, c, d) + instance + ( FromBorsh a + , FromBorsh b + , FromBorsh c + , FromBorsh d + ) + => FromBorsh (a, b, c, d) + +-- size 5 + +deriving via Struct (a, b, c, d, e) + instance + ( BorshSize a + , BorshSize b + , BorshSize c + , BorshSize d + , BorshSize e + ) + => BorshSize (a, b, c, d, e) +deriving via Struct (a, b, c, d, e) + instance + ( ToBorsh a + , ToBorsh b + , ToBorsh c + , ToBorsh d + , ToBorsh e + ) + => ToBorsh (a, b, c, d, e) +deriving via Struct (a, b, c, d, e) + instance + ( FromBorsh a + , FromBorsh b + , FromBorsh c + , FromBorsh d + , FromBorsh e + ) + => FromBorsh (a, b, c, d, e) + +-- size 6 + +deriving via Struct (a, b, c, d, e, f) + instance + ( BorshSize a + , BorshSize b + , BorshSize c + , BorshSize d + , BorshSize e + , BorshSize f + ) + => BorshSize (a, b, c, d, e, f) +deriving via Struct (a, b, c, d, e, f) + instance + ( ToBorsh a + , ToBorsh b + , ToBorsh c + , ToBorsh d + , ToBorsh e + , ToBorsh f + ) + => ToBorsh (a, b, c, d, e, f) +deriving via Struct (a, b, c, d, e, f) + instance + ( FromBorsh a + , FromBorsh b + , FromBorsh c + , FromBorsh d + , FromBorsh e + , FromBorsh f + ) + => FromBorsh (a, b, c, d, e, f) + +-- size 7 + +deriving via Struct (a, b, c, d, e, f, g) + instance + ( BorshSize a + , BorshSize b + , BorshSize c + , BorshSize d + , BorshSize e + , BorshSize f + , BorshSize g + ) + => BorshSize (a, b, c, d, e, f, g) +deriving via Struct (a, b, c, d, e, f, g) + instance + ( ToBorsh a + , ToBorsh b + , ToBorsh c + , ToBorsh d + , ToBorsh e + , ToBorsh f + , ToBorsh g + ) + => ToBorsh (a, b, c, d, e, f, g) +deriving via Struct (a, b, c, d, e, f, g) + instance + ( FromBorsh a + , FromBorsh b + , FromBorsh c + , FromBorsh d + , FromBorsh e + , FromBorsh f + , FromBorsh g + ) + => FromBorsh (a, b, c, d, e, f, g) + +-- size 8 + +deriving via Struct (a, b, c, d, e, f, g, h) + instance + ( BorshSize a + , BorshSize b + , BorshSize c + , BorshSize d + , BorshSize e + , BorshSize f + , BorshSize g + , BorshSize h + ) + => BorshSize (a, b, c, d, e, f, g, h) +deriving via Struct (a, b, c, d, e, f, g, h) + instance + ( ToBorsh a + , ToBorsh b + , ToBorsh c + , ToBorsh d + , ToBorsh e + , ToBorsh f + , ToBorsh g + , ToBorsh h + ) + => ToBorsh (a, b, c, d, e, f, g, h) +deriving via Struct (a, b, c, d, e, f, g, h) + instance + ( FromBorsh a + , FromBorsh b + , FromBorsh c + , FromBorsh d + , FromBorsh e + , FromBorsh f + , FromBorsh g + , FromBorsh h + ) + => FromBorsh (a, b, c, d, e, f, g, h) + +-- size 9 + +deriving via Struct (a, b, c, d, e, f, g, h, i) + instance + ( BorshSize a + , BorshSize b + , BorshSize c + , BorshSize d + , BorshSize e + , BorshSize f + , BorshSize g + , BorshSize h + , BorshSize i + ) + => BorshSize (a, b, c, d, e, f, g, h, i) +deriving via Struct (a, b, c, d, e, f, g, h, i) + instance + ( ToBorsh a + , ToBorsh b + , ToBorsh c + , ToBorsh d + , ToBorsh e + , ToBorsh f + , ToBorsh g + , ToBorsh h + , ToBorsh i + ) + => ToBorsh (a, b, c, d, e, f, g, h, i) +deriving via Struct (a, b, c, d, e, f, g, h, i) + instance + ( FromBorsh a + , FromBorsh b + , FromBorsh c + , FromBorsh d + , FromBorsh e + , FromBorsh f + , FromBorsh g + , FromBorsh h + , FromBorsh i + ) + => FromBorsh (a, b, c, d, e, f, g, h, i) + +-- size 10 + +deriving via Struct (a, b, c, d, e, f, g, h, i, j) + instance + ( BorshSize a + , BorshSize b + , BorshSize c + , BorshSize d + , BorshSize e + , BorshSize f + , BorshSize g + , BorshSize h + , BorshSize i + , BorshSize j + ) + => BorshSize (a, b, c, d, e, f, g, h, i, j) +deriving via Struct (a, b, c, d, e, f, g, h, i, j) + instance + ( ToBorsh a + , ToBorsh b + , ToBorsh c + , ToBorsh d + , ToBorsh e + , ToBorsh f + , ToBorsh g + , ToBorsh h + , ToBorsh i + , ToBorsh j + ) + => ToBorsh (a, b, c, d, e, f, g, h, i, j) +deriving via Struct (a, b, c, d, e, f, g, h, i, j) + instance + ( FromBorsh a + , FromBorsh b + , FromBorsh c + , FromBorsh d + , FromBorsh e + , FromBorsh f + , FromBorsh g + , FromBorsh h + , FromBorsh i + , FromBorsh j + ) + => FromBorsh (a, b, c, d, e, f, g, h, i, j) + +{------------------------------------------------------------------------------- + Instances for other common Haskell types +-------------------------------------------------------------------------------} + +-- Lazy ByteString + +instance BorshSize L.ByteString where + type StaticBorshSize L.ByteString = 'HasVariableSize + borshSize _ = SizeVariable + +instance ToBorsh L.ByteString where + encodeBorsh = encodeLazyByteString + +instance FromBorsh L.ByteString where + decodeBorsh = decodeLazyByteString + +-- Strict ByteString + +instance BorshSize S.ByteString where + type StaticBorshSize S.ByteString = 'HasVariableSize + borshSize _ = SizeVariable + +instance ToBorsh S.ByteString where + encodeBorsh = encodeStrictByteString + +instance FromBorsh S.ByteString where + decodeBorsh = decodeStrictByteString + +-- Char + +instance BorshSize Char where + type StaticBorshSize Char = 'HasKnownSize + borshSize _ = SizeKnown 4 + +instance ToBorsh Char where + encodeBorsh = encodeChar + +instance FromBorsh Char where + decodeBorsh = decodeChar + +-- Bool + +instance BorshSize Bool where + type StaticBorshSize Bool = 'HasKnownSize + borshSize _ = SizeKnown 1 + +instance ToBorsh Bool where + encodeBorsh = encodeBool + +instance FromBorsh Bool where + decodeBorsh = decodeBool + +-- Either + +deriving instance BorshSize (Either a b) +deriving instance (ToBorsh a, ToBorsh b) => ToBorsh (Either a b) +deriving instance (FromBorsh a, FromBorsh b) => FromBorsh (Either a b) + +{------------------------------------------------------------------------------- + Internal auxiliary: size of products and sums-of-products +-------------------------------------------------------------------------------} + +-- | A product of types has known size if all types in the products do +type family ProdKnownSize (xs :: [Type]) :: KnownSize where + ProdKnownSize '[] = 'HasKnownSize + ProdKnownSize (x ': xs) = ProdKnownAux (StaticBorshSize x) xs + +-- | Auxiliary to 'ProdKnownSize' +-- +-- Defined in such a way that we know the result is of variable size as soon +-- as we encounter the first type of variable size (independent of the tail). +type family ProdKnownAux (x :: KnownSize) (xs :: [Type]) :: KnownSize where + ProdKnownAux 'HasKnownSize xs = ProdKnownSize xs + ProdKnownAux 'HasVariableSize xs = 'HasVariableSize + +-- | A sum of products has known size if it has at most one constructor, +-- and all arguments of that constructor have known size +type family SumKnownSize (xs :: [[Type]]) :: KnownSize where + SumKnownSize '[] = 'HasKnownSize + SumKnownSize '[xs] = ProdKnownSize xs + SumKnownSize _ = 'HasVariableSize + +-- | Type-level composition of 'Size' and 'StaticBorshSize' +newtype SoK (a :: Type) = SoK (Size (StaticBorshSize a)) + +constrSoK :: forall a. BorshSize a => SoK a +constrSoK = SoK $ borshSize (Proxy @a) + +sizeOfProd :: forall xs. All BorshSize xs => Proxy xs -> Size (ProdKnownSize xs) +sizeOfProd _ = + go (hcpure (Proxy @BorshSize) constrSoK :: NP SoK xs) + where + go :: forall xs'. NP SoK xs' -> Size (ProdKnownSize xs') + go Nil = SizeKnown 0 + go (SoK s :* ss) = + case (s, go ss) of + (SizeKnown sz , SizeKnown sz') -> SizeKnown (sz + sz') + (SizeKnown _ , SizeVariable ) -> SizeVariable + (SizeVariable , _ ) -> SizeVariable + +-- | Auxiliary class to @BorshSize@ describing the conditions under which the +-- size of the encoding of a value of a sum-type is known. +class BorshSizeSum (xss :: [[Type]]) where + borshSizeSum :: Proxy xss -> Size (SumKnownSize xss) + +instance BorshSizeSum '[] where + -- In a way the size of the @Void@ type is meaningless, because there /are/ + -- no elements of @Void@, and hence there /is/ no encoding. + -- TODO: Should we return undefined here..? + borshSizeSum _ = SizeKnown 0 + +instance All BorshSize xs => BorshSizeSum '[xs] where + borshSizeSum _ = + -- This assumes the presence of the constructor tag + -- (see detailed discussion in 'Struct') + case sizeOfProd (Proxy @xs) of + SizeKnown sz -> SizeKnown (sz + 1) + SizeVariable -> SizeVariable + +instance BorshSizeSum (xs ': ys ': zss) where + borshSizeSum _ = SizeVariable diff --git a/src/Codec/Borsh/Decoding.hs b/src/Codec/Borsh/Decoding.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Borsh/Decoding.hs @@ -0,0 +1,199 @@ +module Codec.Borsh.Decoding ( + -- * Decoders for non-composite types mandated by the Borsh spec + decodeU8 + , decodeU16 + , decodeU32 + , decodeU64 + , decodeU128 + , decodeI8 + , decodeI16 + , decodeI32 + , decodeI64 + , decodeI128 + , decodeF32 + , decodeF64 + , decodeString + -- * Decoders for composite types mandated by the Borsh spec + , decodeArray + , decodeVec + , decodeOption + , decodeHashSet + , decodeHashMap + , decodeStruct + , decodeEnum + -- * Decoders for Haskell types not mandated by the Borsh spec + , decodeLazyByteString + , decodeStrictByteString + , decodeChar + , decodeBool + ) where + +import Data.Char (chr) +import Data.Int +import Data.Map (Map) +import Data.Maybe +import Data.Proxy +import Data.Set (Set) +import Data.STRef +import Data.Text (Text) +import Data.Word +import Generics.SOP +import GHC.TypeLits + +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Text.Encoding as Text +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Generic.Mutable as GM + +import Codec.Borsh.Incremental +import Codec.Borsh.Internal.Util.BitwiseCast +import Codec.Borsh.Internal.Util.SOP +import Data.FixedSizeArray (FixedSizeArray, MFixedSizeArray) +import Data.Word128 (Word128) +import Data.Int128 (Int128) + +import qualified Data.FixedSizeArray as FSA + +{------------------------------------------------------------------------------- + Decoders for the non-composite types mandated by the Borsh spec +-------------------------------------------------------------------------------} + +decodeU8 :: Decoder s Word8 +decodeU16 :: Decoder s Word16 +decodeU32 :: Decoder s Word32 +decodeU64 :: Decoder s Word64 +decodeU128 :: Decoder s Word128 + +decodeU8 = decodeLittleEndian +decodeU16 = decodeLittleEndian +decodeU32 = decodeLittleEndian +decodeU64 = decodeLittleEndian +decodeU128 = decodeLittleEndian + +decodeI8 :: Decoder s Int8 +decodeI16 :: Decoder s Int16 +decodeI32 :: Decoder s Int32 +decodeI64 :: Decoder s Int64 +decodeI128 :: Decoder s Int128 + +decodeI8 = (castBits @Word8 ) <$> decodeLittleEndian +decodeI16 = (castBits @Word16 ) <$> decodeLittleEndian +decodeI32 = (castBits @Word32 ) <$> decodeLittleEndian +decodeI64 = (castBits @Word64 ) <$> decodeLittleEndian +decodeI128 = (castBits @Word128) <$> decodeLittleEndian + +decodeF32 :: Decoder s Float +decodeF64 :: Decoder s Double + +decodeF32 = (castBits @Word32) <$> decodeLittleEndian +decodeF64 = (castBits @Word64) <$> decodeLittleEndian + +decodeString :: Decoder s Text +decodeString = do + len <- decodeU32 + lbs <- decodeLargeToken len + case Text.decodeUtf8' $ L.toStrict lbs of + Right txt -> return txt + Left err -> fail (show err) + +{------------------------------------------------------------------------------- + Decoders for composite types mandated by the Borsh spec +-------------------------------------------------------------------------------} + +decodeArray :: forall n s a. + KnownNat n + => Decoder s a -> Decoder s (FixedSizeArray n a) +decodeArray d = do + -- Construct mutable array before we start processing elements, + -- along with a counter for the next element + mArr :: MFixedSizeArray n s a <- liftDecoder $ FSA.new + next :: STRef s Int <- liftDecoder $ newSTRef 0 + + let d' :: Decoder s () + d' = d >>= \b -> liftDecoder $ do + i <- readSTRef next + modifySTRef next (+ 1) + GM.write mArr i b + + decodeIncremental_ count d' + liftDecoder $ G.freeze mArr + where + count :: Word32 + count = fromIntegral $ natVal (Proxy @n) + +decodeVec :: Decoder s a -> Decoder s [a] +decodeVec d = decodeU32 >>= \count -> decodeIncremental count d + +decodeOption :: Decoder s a -> Decoder s (Maybe a) +decodeOption d = do + present <- decodeU8 + case present of + 0 -> return Nothing + 1 -> Just <$> d + _ -> fail "Expected 0 or 1 for option prefix" + +decodeHashSet :: Ord a => Decoder s a -> Decoder s (Set a) +decodeHashSet d = do + count <- decodeU32 + Set.fromList <$> decodeIncremental count d + +decodeHashMap :: Ord k => Decoder s k -> Decoder s a -> Decoder s (Map k a) +decodeHashMap dk dv = do + count <- decodeU32 + Map.fromList <$> decodeIncremental count dPair + where + dPair = (,) <$> dk <*> dv + +decodeStruct :: All Top xs => NP (Decoder s) xs -> Decoder s (NP I xs) +decodeStruct = hsequence + +decodeEnum :: forall s xss. + All SListI xss + => POP (Decoder s) xss -> Decoder s (SOP I xss) +decodeEnum = + selectDecoder + . hcollapse + . hczipWith3 + (Proxy @SListI) + (\(K ix) (Fn inj) ds -> K $ (ix, SOP . unK . inj <$> hsequence ds)) + indices + (injections :: NP (Injection (NP I) xss) xss) + . unPOP + where + selectDecoder :: [(Word8, Decoder s (SOP I xss))] -> Decoder s (SOP I xss) + selectDecoder decs = do + n <- fromIntegral <$> decodeU8 + fromMaybe (fail err) $ lookup n decs + where + err :: String + err = "Expected index < " ++ show (length decs) + +{------------------------------------------------------------------------------- + Decoders for Haskell types not mandated by the Borsh spec +-------------------------------------------------------------------------------} + +-- ByteStrings + +decodeLazyByteString :: Decoder s L.ByteString +decodeLazyByteString = do + len <- decodeU32 + decodeLargeToken len + +decodeStrictByteString :: Decoder s S.ByteString +decodeStrictByteString = do + len <- decodeU32 + L.toStrict <$> decodeLargeToken len + +-- Char, Bool + +decodeChar :: Decoder s Char +decodeChar = chr . fromIntegral <$> decodeU32 + +decodeBool :: Decoder s Bool +decodeBool = decodeU8 >>= \case + 0 -> return False + 1 -> return True + _ -> fail "Expected 0 or 1 while decoding Bool" diff --git a/src/Codec/Borsh/Encoding.hs b/src/Codec/Borsh/Encoding.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Borsh/Encoding.hs @@ -0,0 +1,192 @@ +module Codec.Borsh.Encoding ( + -- * Encoder definition + Encoder (..) + -- * Encoders for non-composite types mandated by the Borsh spec + , encodeU8 + , encodeU16 + , encodeU32 + , encodeU64 + , encodeU128 + , encodeI8 + , encodeI16 + , encodeI32 + , encodeI64 + , encodeI128 + , encodeF32 + , encodeF64 + , encodeString + -- * Encoders for composite types mandated by the Borsh spec + , encodeArray + , encodeVec + , encodeOption + , encodeHashSet + , encodeHashMap + , encodeStruct + , encodeEnum + -- * Encoders for Haskell types not mandated by the Borsh spec + , encodeLazyByteString + , encodeStrictByteString + , encodeChar + , encodeBool + ) where + +import Data.Char (ord) +import Data.ByteString.Builder (Builder) +import Data.Foldable (toList) +import Data.Functor.Contravariant +import Data.Int +import Data.Map (Map) +import Data.Set (Set) +import Data.SOP +import Data.Text (Text) +import Data.Word + +import qualified Data.ByteString as S +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Lazy as L +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text.Encoding as Text + +import Data.FixedSizeArray (FixedSizeArray) +import Codec.Borsh.Internal.Util.ByteString +import Codec.Borsh.Internal.Util.SOP (indices) +import Data.Word128 +import Data.Int128 + +{------------------------------------------------------------------------------- + Encoder definition +-------------------------------------------------------------------------------} + +-- | Encoder +-- +-- An encoder describes how to serialise a given value in BORSH format. +newtype Encoder a = Encoder { + runEncoder :: a -> Builder + } + +instance Contravariant Encoder where + contramap f (Encoder e) = Encoder (e . f) + +liftEncoder :: Encoder a -> (I -.-> K Builder) a +liftEncoder (Encoder e) = fn $ K . e . unI + +{------------------------------------------------------------------------------- + Encoders for non-composite types mandated by the Borsh spec +-------------------------------------------------------------------------------} + +encodeU8 :: Encoder Word8 +encodeU16 :: Encoder Word16 +encodeU32 :: Encoder Word32 +encodeU64 :: Encoder Word64 +encodeI8 :: Encoder Int8 +encodeI16 :: Encoder Int16 +encodeI32 :: Encoder Int32 +encodeI64 :: Encoder Int64 +encodeF32 :: Encoder Float +encodeF64 :: Encoder Double + +encodeU8 = Encoder B.word8 +encodeU16 = Encoder B.word16LE +encodeU32 = Encoder B.word32LE +encodeU64 = Encoder B.word64LE +encodeI8 = Encoder B.int8 +encodeI16 = Encoder B.int16LE +encodeI32 = Encoder B.int32LE +encodeI64 = Encoder B.int64LE +encodeF32 = Encoder B.floatLE +encodeF64 = Encoder B.doubleLE + +encodeU128 :: Encoder Word128 +encodeU128 = Encoder $ + \w128 -> B.word64LE (word128LS64 w128) <> B.word64LE (word128MS64 w128) + +encodeI128 :: Encoder Int128 +encodeI128 = Encoder $ + \i128 -> B.word64LE (int128LS64 i128) <> B.word64LE (int128MS64 i128) + +-- Encoding 'Text' +-- +-- Borsh requires the length of the utf8-encoded string before the string, but +-- unfortunately we have no easy way to compute this without encoding the entire +-- string. This means that we are not streaming here: the entire utf8 encoding +-- is constructed in memory. +-- +-- With text version 2.0 we can use @lengthWord8@ but that is not available most +-- of the time. +encodeString :: Encoder Text +encodeString = Encoder $ \txt -> + B.word32LE (lengthLazy $ utf8 txt) <> B.lazyByteString (utf8 txt) + where + utf8 :: Text -> L.ByteString + utf8 txt = B.toLazyByteString $ Text.encodeUtf8Builder txt + +{------------------------------------------------------------------------------- + Encoders for composite types mandated by the Borsh spec +-------------------------------------------------------------------------------} + +encodeArray :: Encoder a -> Encoder (FixedSizeArray n a) +encodeArray e = Encoder $ mconcat . map (runEncoder e) . toList + +encodeVec :: Encoder a -> Encoder [a] +encodeVec e = Encoder $ \xs -> mconcat $ + runEncoder encodeU32 (fromIntegral $ length xs) + : map (runEncoder e) xs + +encodeOption :: Encoder a -> Encoder (Maybe a) +encodeOption e = Encoder $ \case + Nothing -> runEncoder encodeU8 0 + Just x -> runEncoder encodeU8 1 <> runEncoder e x + +encodeHashSet :: Encoder a -> Encoder (Set a) +encodeHashSet e = Encoder $ \xs -> mconcat $ + runEncoder encodeU32 (fromIntegral $ Set.size xs) + : (map (runEncoder e) $ Set.toList xs) + +encodeHashMap :: Encoder k -> Encoder a -> Encoder (Map k a) +encodeHashMap ek ev = Encoder $ \xs -> mconcat $ + runEncoder encodeU32 (fromIntegral $ Map.size xs) + : (map ePair $ Map.toList xs) + where + ePair (k,v) = runEncoder ek k <> runEncoder ev v + +encodeStruct :: SListI xs => NP Encoder xs -> Encoder (NP I xs) +encodeStruct es = Encoder $ + mconcat + . hcollapse + . hap (hliftA liftEncoder es) + +encodeEnum :: All SListI xss => POP Encoder xss -> Encoder (SOP I xss) +encodeEnum es = Encoder $ + hcollapse + . hczipWith (Proxy @SListI) aux indices + . unSOP + . hap (hliftA liftEncoder es) + where + aux :: SListI xs => K Word8 xs -> NP (K Builder) xs -> K Builder xs + aux (K ix) xs = K $ runEncoder encodeU8 ix <> mconcat (hcollapse xs) + +{------------------------------------------------------------------------------- + Encoders for Haskell types not mandated by the Borsh spec +-------------------------------------------------------------------------------} + +-- ByteStrings + +encodeLazyByteString :: Encoder L.ByteString +encodeLazyByteString = Encoder $ \bs -> + runEncoder encodeU32 (fromIntegral $ L.length bs) + <> B.lazyByteString bs + +encodeStrictByteString :: Encoder S.ByteString +encodeStrictByteString = Encoder $ \bs -> + runEncoder encodeU32 (fromIntegral $ S.length bs) + <> B.byteString bs + +-- Char, Bool + +encodeChar :: Encoder Char +encodeChar = Encoder $ runEncoder encodeU32 . fromIntegral . ord + +encodeBool :: Encoder Bool +encodeBool = Encoder $ runEncoder encodeU8 . fromIntegral . fromEnum + diff --git a/src/Codec/Borsh/Incremental.hs b/src/Codec/Borsh/Incremental.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Borsh/Incremental.hs @@ -0,0 +1,27 @@ + +module Codec.Borsh.Incremental ( + -- * Constructing decoders + Decoder(..) + , DecodeResult(..) + , liftDecoder + -- * Running decoders + , DeserialiseFailure(..) + , deserialiseByteString + -- * Specialised decoders + -- + -- | These functions comprise a low-level decoder interface which will not + -- be necessary for most applications. Most applications should simply use + -- 'Codec.Borsh.Class.deserialiseBorsh' + , decodeLittleEndian + , decodeLargeToken + , decodeIncremental + , decodeIncremental_ + -- * Located values + , Located(..) + , ByteOffset + , LocatedChunk + ) where + +import Codec.Borsh.Incremental.Decoder +import Codec.Borsh.Incremental.Located +import Codec.Borsh.Incremental.Monad diff --git a/src/Codec/Borsh/Incremental/Decoder.hs b/src/Codec/Borsh/Incremental/Decoder.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Borsh/Incremental/Decoder.hs @@ -0,0 +1,263 @@ +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} + +module Codec.Borsh.Incremental.Decoder ( + -- * Definition + Decoder(..) + -- * Operations supported by any decoder + , liftDecoder + , decodeLittleEndian + , decodeLargeToken + , decodeIncremental + , decodeIncremental_ + -- * Running + , DecodeResult(..) + , deserialiseByteString + ) where + +import Control.Applicative +import Control.Monad +import Control.Monad.Fail +import Control.Monad.ST +import Data.Word + +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L + +import Codec.Borsh.Incremental.Located +import Codec.Borsh.Incremental.Monad +import Codec.Borsh.Internal.Util.ByteString +import Codec.Borsh.Internal.Util.ByteSwap + +{------------------------------------------------------------------------------- + Definition +-------------------------------------------------------------------------------} + +-- | Decoder +-- +-- A decoder describes how to match against a single chunk of the input. +newtype Decoder s a = Decoder { + matchChunk :: LocatedChunk -> ST s (LocatedChunk, DecodeResult s a) + } + +{------------------------------------------------------------------------------- + Operations supported by the 'Decoder' monad +-------------------------------------------------------------------------------} + +liftDecoder :: ST s a -> Decoder s a +liftDecoder sa = Decoder $ \chunk -> (chunk, ) . DecodeDone <$> sa + +decodeLittleEndian :: forall s a. ByteSwap a => Decoder s a +decodeLittleEndian = Decoder aux + where + aux :: LocatedChunk -> ST s (LocatedChunk, DecodeResult s a) + aux chunk@(L bs off) = + case peekByteString bs of + Just (x, sizeX, bs') -> + return (L bs' (off + sizeX), DecodeDone x) + Nothing -> + return (chunk, DecodeNeedsData decodeLittleEndian) + +decodeLargeToken :: Word32 -> Decoder s L.ByteString +decodeLargeToken n = Decoder $ \chunk -> + return (chunk, DecodeLargeToken n return) + +decodeIncremental :: Word32 -> Decoder s a -> Decoder s [a] +decodeIncremental n d = Decoder $ \chunk -> + return (chunk, DecodeIncremental n d return) + +decodeIncremental_ :: Word32 -> Decoder s () -> Decoder s () +decodeIncremental_ n d = Decoder $ \chunk -> + return (chunk, DecodeIncremental_ n d $ return ()) + +{------------------------------------------------------------------------------- + Results +-------------------------------------------------------------------------------} + +data DecodeResult s a where + -- | The decoder terminated successfully: we can stop decoding + DecodeDone :: a -> DecodeResult s a + + -- | The decoder failed: we should abort + DecodeFail :: String -> DecodeResult s a + + -- | The decoder needs more data before it can continue + -- + -- NOTE: The decoder that is waiting for more data may not be (and typically + -- will not be) the decoder we started with in 'matchChunk': in the typical + -- case, a bunch of values will have been decoded successfully before we get + -- to a (continuation) decoder that requires data beyond the current chunk. + DecodeNeedsData :: Decoder s a -> DecodeResult s a + + -- | Large token of known length that spans multiple chunks + -- + -- This is NOT incremental: all chunks will be read into memory before the + -- function is applied. Primarily useful for large types that are not + -- easily split into (valid) chunks, such as UTF8-encoded text (if were + -- wanted to split that, we'd have to split it at UTF8 boundaries). + -- + -- The continuation will be called with a lazy bytestring of precisely the + -- requested length (provided enough input is available, of course), along + -- with the remaining input token to be provided to the continuation decoder. + DecodeLargeToken :: + Word32 -- ^ Required number of bytes + -> (L.ByteString -> Decoder s a) + -> DecodeResult s a + + -- | Incremental interface + -- + -- When decoding large objects such as lists, we do not want to bring all + -- required chunks into memory before decoding the list. Instead, we want to + -- decode the list elements as we go. In this case, 'DecodeIncremental' can + -- be used to repeatedly decode a value using decoder for the elements; when + -- all elements have been processed, the continuation decoder is called. + -- + -- NOTE: This interface is incremental in the sense that the /input chunks/ + -- are read one at a time. It is /NOT/ incremental in the generated /output/. + DecodeIncremental :: + Word32 -- ^ How often to repeat the smaller decoder + -> Decoder s a -- ^ Decoder to repeat + -> ([a] -> Decoder s b) -- ^ Process all elements + -> DecodeResult s b + + -- | Variation on 'DecodeIncremental', where we do not accumulate results + -- + -- This is useful for example for datatypes that we can update imperatively, + -- such as mutable arrays. It could also be used to skip over unused parts + -- of the input. + DecodeIncremental_ :: + Word32 -- ^ How often to repeat the smaller decoder + -> Decoder s () -- ^ Decoder to repeat (imperatively handling each element) + -> Decoder s a -- ^ Continuation + -> DecodeResult s a + +{------------------------------------------------------------------------------- + Monad instance +-------------------------------------------------------------------------------} + +instance Functor (Decoder s) where + fmap = liftA + +instance Applicative (Decoder s) where + pure x = Decoder $ \chunk -> return (chunk, DecodeDone x) + (<*>) = ap + +instance Monad (Decoder s) where + return = pure + x >>= f = Decoder $ \chunk -> do + (chunk', result) <- matchChunk x chunk + case result of + DecodeDone a -> + matchChunk (f a) chunk' + DecodeFail e -> + return (chunk', DecodeFail e) + DecodeNeedsData d -> + return (chunk', DecodeNeedsData (d >>= f)) + DecodeLargeToken reqLen k -> + return (chunk', DecodeLargeToken reqLen (k >=> f)) + DecodeIncremental count d k -> + return (chunk', DecodeIncremental count d (k >=> f)) + DecodeIncremental_ count d k -> + return (chunk', DecodeIncremental_ count d (k >>= f)) + +instance MonadFail (Decoder s) where + fail e = Decoder $ \chunk -> return (chunk, DecodeFail e) + +{------------------------------------------------------------------------------- + Running decoders +-------------------------------------------------------------------------------} + +-- | Top-level entry point +-- +-- We start without any input at all (and depending on the specific decoder, +-- we may never need any). +runDecoder :: Decoder s a -> Incr s (LocatedChunk, a) +runDecoder = runWith $ L S.empty 0 + +-- | Run decoder against specified chunk +runWith :: LocatedChunk -> Decoder s a -> Incr s (LocatedChunk, a) +runWith chunk d = uncurry processResult =<< liftIncr (matchChunk d chunk) + +{------------------------------------------------------------------------------- + Processing the result of a decoder +-------------------------------------------------------------------------------} + +-- | Process decoder result +processResult :: LocatedChunk -> DecodeResult s a -> Incr s (LocatedChunk, a) +processResult chunk = \case + DecodeDone x -> return (chunk, x) + DecodeFail e -> decodeFail chunk e + + DecodeNeedsData d -> processNeedsData d chunk + DecodeLargeToken n k -> processLargeToken n k chunk + DecodeIncremental n d k -> processIncremental n d k chunk + DecodeIncremental_ n d k -> processIncremental_ n d k chunk + +processNeedsData :: + Decoder s a + -> Located S.ByteString + -> Incr s (LocatedChunk, a) +processNeedsData d chunk@(L bs off) = needChunk >>= \case + Nothing -> decodeFail chunk "end of input" + Just next -> runWith (L (bs <> next) off) d + +-- | Auxiliary to 'processResult': process token that spans multple chunks +-- +-- Precondition: if the accumulated length exceeds the required length, we must +-- be able to split the mostly added chunk to make up for the difference. +processLargeToken :: forall s a. + Word32 -- ^ Required total size + -> (L.ByteString -> Decoder s a) -- ^ Continuation + -> LocatedChunk -- ^ Current chunk + -> Incr s (LocatedChunk, a) +processLargeToken reqLen k = go . toLocatedChunks + where + go :: LocatedChunks -> Incr s (LocatedChunk, a) + go acc = + case splitChunks reqLen acc of + Nothing -> needChunk >>= \case + Nothing -> decodeFail (fromLocatedChunks acc) "end of input" + Just next -> go (addChunk next acc) + Just (large, left) -> + uncurry processResult =<< liftIncr (matchChunk (k large) left) + +-- | Auxiliary to 'processResult': incremental decoding +processIncremental :: forall s a b. + Word32 -- ^ Number of elements required + -> Decoder s a -- ^ Decoder to repeat + -> ([a] -> Decoder s b) -- ^ Continuation once we processed all elements + -> LocatedChunk -- ^ Current chunk + -> Incr s (LocatedChunk, b) +processIncremental count d k = go [] count + where + go :: [a] -> Word32 -> LocatedChunk -> Incr s (LocatedChunk, b) + go acc 0 chunk = do result <- liftIncr (matchChunk (k (reverse acc)) chunk) + uncurry processResult result + go acc n chunk = do (chunk', a) <- runWith chunk d + go (a:acc) (n - 1) chunk' + +-- | Imperative version of 'processIncremental' +-- +-- See 'DecodeIncremental_' for discussion. +processIncremental_ :: forall s a. + Word32 -- ^ Number of elements required + -> Decoder s () -- ^ Decoder to repeat + -> Decoder s a -- ^ Continuation once we processed all elements + -> LocatedChunk -- ^ Current chunk + -> Incr s (LocatedChunk, a) +processIncremental_ count d k = go count + where + go :: Word32 -> LocatedChunk -> Incr s (LocatedChunk, a) + go 0 chunk = do result <- liftIncr (matchChunk k chunk) + uncurry processResult result + go n chunk = do (chunk', ()) <- runWith chunk d + go (n - 1) chunk' + +{------------------------------------------------------------------------------- + Top-level API +-------------------------------------------------------------------------------} + +deserialiseByteString :: + (forall s. Decoder s a) + -> L.ByteString + -> Either DeserialiseFailure (L.ByteString, ByteOffset, a) +deserialiseByteString d = runIDecode (runIncr (runDecoder d)) diff --git a/src/Codec/Borsh/Incremental/Located.hs b/src/Codec/Borsh/Incremental/Located.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Borsh/Incremental/Located.hs @@ -0,0 +1,78 @@ +module Codec.Borsh.Incremental.Located ( + -- * Values along with an input location + ByteOffset + , Located(..) + , LocatedChunk + -- * Located chunks + , LocatedChunks + , toLocatedChunks + , fromLocatedChunks + , addChunk + , splitChunks + ) where + +import Data.Foldable (toList) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Word + +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.List.NonEmpty as NE + +import Codec.Borsh.Internal.Util.ByteString + +{------------------------------------------------------------------------------- + Values along with an input location +-------------------------------------------------------------------------------} + +-- | Offset in bytes within the input +type ByteOffset = Word32 + +-- | Value at a particular point in the input +data Located a = L !a {-# UNPACK #-} !ByteOffset + +-- | The most common case: chunk of the input at a particular point +type LocatedChunk = Located S.ByteString + +{------------------------------------------------------------------------------- + Simple application of 'Located' to a bunch of chunks +-------------------------------------------------------------------------------} + +-- | Bunch of chunks, starting at a particular point +-- +-- The chunks are stored in reverse order, and we cache their total length. +type LocatedChunks = Located (NonEmpty S.ByteString, Word32) + +toLocatedChunks :: LocatedChunk -> LocatedChunks +toLocatedChunks (L bs off) = L (bs :| [], lengthStrict bs) off + +-- | Concatenate all chunks together +-- +-- NOTE: This is expensive, and should be used only in exception circumstances. +fromLocatedChunks :: LocatedChunks -> LocatedChunk +fromLocatedChunks (L (bss, _) off) = L (S.concat (reverse $ toList bss)) off + +-- | Add chunk +-- +-- This does not affect the offset, since the chunk is (logically) at the /end/ +-- of the already-known chunks +addChunk :: S.ByteString -> LocatedChunks -> LocatedChunks +addChunk bs (L (bss, len) off) = L (NE.cons bs bss, len + lengthStrict bs) off + +-- | Split chunks at the required length, if sufficient chunks are available +-- +-- Precondition: if the accumulated length exceeds the required length, we must +-- be able to split the mostly added chunk to make up for the difference. +splitChunks :: Word32 -> LocatedChunks -> Maybe (L.ByteString, LocatedChunk) +splitChunks reqLen (L (mostRecent :| older, len) off) + | reqLen > len = Nothing + | otherwise = Just (large, L rest (off + fromIntegral (L.length large))) + where + excess :: Word32 + excess = len - reqLen + + req, rest :: S.ByteString + (req, rest) = splitAtEnd (fromIntegral excess) mostRecent + + large :: L.ByteString + large = L.fromChunks $ reverse (req : older) diff --git a/src/Codec/Borsh/Incremental/Monad.hs b/src/Codec/Borsh/Incremental/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Borsh/Incremental/Monad.hs @@ -0,0 +1,109 @@ +module Codec.Borsh.Incremental.Monad ( + -- * Definition + Incr(..) + , runIncr + -- * Operations supported by the monad + , liftIncr + , needChunk + , decodeFail + -- * (Partial) results + , IDecode(..) + , DeserialiseFailure(..) + , runIDecode + ) where + +import Control.Monad +import Control.Monad.ST +import Control.Exception + +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L + +import Codec.Borsh.Incremental.Located + +{------------------------------------------------------------------------------- + Definition +-------------------------------------------------------------------------------} + +-- | Monad for incremental decoding +-- +-- Think of 'Incr' as the monad we use for processing the full input, whereas +-- 'Decoder' is the monad used for processing a single chunk of the input. +newtype Incr s a = Incr { + getIncr :: forall r. (a -> ST s (IDecode s r)) -> ST s (IDecode s r) + } + +runIncr :: Incr s (LocatedChunk, a) -> ST s (IDecode s a) +runIncr (Incr f) = f $ \(chunk, x) -> return $ IDecodeDone chunk x + +{------------------------------------------------------------------------------- + Monad instance +-------------------------------------------------------------------------------} + +instance Functor (Incr s) where + fmap = liftM + +instance Applicative (Incr s) where + pure x = Incr ($ x) + (<*>) = ap + +instance Monad (Incr s) where + return = pure + m >>= f = Incr $ \k -> getIncr m $ \x -> getIncr (f x) k + +{------------------------------------------------------------------------------- + Operations supported by the monad +-------------------------------------------------------------------------------} + +liftIncr :: ST s a -> Incr s a +liftIncr action = Incr (action >>=) + +needChunk :: Incr s (Maybe S.ByteString) +needChunk = Incr $ \k -> return $ IDecodePartial $ \mbs -> k mbs + +decodeFail :: LocatedChunk -> String -> Incr s a +decodeFail chunk@(L _ off) e = Incr $ \_ -> + return $ IDecodeFail chunk (DeserialiseFailure off e) + +{------------------------------------------------------------------------------- + (Partial) results +-------------------------------------------------------------------------------} + +data IDecode s a = + IDecodePartial (Maybe S.ByteString -> ST s (IDecode s a)) + | IDecodeDone !LocatedChunk a + | IDecodeFail !LocatedChunk DeserialiseFailure + +-- | Error type for deserialisation. +data DeserialiseFailure = + DeserialiseFailure + ByteOffset -- ^ The position of the decoder when the failure occurred + String -- ^ Message explaining the failure + deriving stock (Eq, Show) + deriving anyclass (Exception) + +runIDecode :: + (forall s. ST s (IDecode s a)) + -> L.ByteString + -> Either DeserialiseFailure (L.ByteString, ByteOffset, a) +runIDecode d lbs = + runST (go (L.toChunks lbs) =<< d) + where + go :: [S.ByteString] + -> IDecode s a + -> ST s (Either DeserialiseFailure (L.ByteString, ByteOffset, a)) + go chunks = \case + IDecodeFail _ err -> + return (Left err) + IDecodeDone (L bs off) x -> + return (Right (L.fromChunks $ prepend bs chunks, off, x)) + IDecodePartial k -> + case chunks of + [] -> k Nothing >>= go [] + bs:chunks' -> k (Just bs) >>= go chunks' + + prepend :: S.ByteString -> [S.ByteString] -> [S.ByteString] + prepend bs bss + | S.null bs = bss + | otherwise = bs : bss + diff --git a/src/Codec/Borsh/Internal/Util/BitwiseCast.hs b/src/Codec/Borsh/Internal/Util/BitwiseCast.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Borsh/Internal/Util/BitwiseCast.hs @@ -0,0 +1,30 @@ +module Codec.Borsh.Internal.Util.BitwiseCast (BitwiseCast(..)) where + +import Data.Int +import Data.Word +import GHC.Float + +import Data.Int128 (Int128) +import Data.Word128 (Word128) + +class BitwiseCast a b where + -- | Bit-for-bit copy from @a@ to @b@ + castBits :: a -> b + +instance BitwiseCast Float Word32 where castBits = castFloatToWord32 +instance BitwiseCast Double Word64 where castBits = castDoubleToWord64 + +instance BitwiseCast Word32 Float where castBits = castWord32ToFloat +instance BitwiseCast Word64 Double where castBits = castWord64ToDouble + +instance BitwiseCast Word8 Int8 where castBits = fromIntegral +instance BitwiseCast Word16 Int16 where castBits = fromIntegral +instance BitwiseCast Word32 Int32 where castBits = fromIntegral +instance BitwiseCast Word64 Int64 where castBits = fromIntegral +instance BitwiseCast Word128 Int128 where castBits = fromIntegral + +instance BitwiseCast Int8 Word8 where castBits = fromIntegral +instance BitwiseCast Int16 Word16 where castBits = fromIntegral +instance BitwiseCast Int32 Word32 where castBits = fromIntegral +instance BitwiseCast Int64 Word64 where castBits = fromIntegral +instance BitwiseCast Int128 Word128 where castBits = fromIntegral diff --git a/src/Codec/Borsh/Internal/Util/ByteString.hs b/src/Codec/Borsh/Internal/Util/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Borsh/Internal/Util/ByteString.hs @@ -0,0 +1,74 @@ +module Codec.Borsh.Internal.Util.ByteString ( + peekByteString + , splitAtEnd + , lengthStrict + , lengthLazy + ) where + +import Foreign +import System.IO.Unsafe (unsafePerformIO) + +import qualified Data.ByteString as S +import qualified Data.ByteString.Internal as S.Internal +import qualified Data.ByteString.Lazy as L + +import Codec.Borsh.Internal.Util.ByteSwap + +-- | Peek at the start of the bytestring +-- +-- If the bytestring is long enough, returns the value, the size of that value, +-- and the remaining bytes. +-- +-- Implementation note: this could be simplified using @bytestring >= 0.11@, as +-- the @offset@ argument has been removed. As it stands, this implementation is +-- backwards compatible. +peekByteString :: forall a. + ByteSwap a + => S.ByteString + -> Maybe (a, Word32, S.ByteString) +peekByteString bs + | sizeA > len = Nothing + | otherwise = Just ( + fromLE . LE $ unsafePerformIO $ withForeignPtr (plusForeignPtr fPtr offset) (peek . cast) + , fromIntegral sizeA + , S.drop sizeA bs + ) + where + sizeA :: Int + sizeA = sizeOf (undefined :: a) + + fPtr :: ForeignPtr Word8 + offset, len :: Int + (fPtr, offset, len) = S.Internal.toForeignPtr bs + + cast :: Ptr Word8 -> Ptr a + cast = castPtr + +-- | /O(1)/ @splitAtEnd n xs@ is equivalent to @(takeEnd n xs, dropEnd n xs)@ +-- +-- > splitAtEnd 0 "abcde" == ("abcde", "") +-- > splitAtEnd 1 "abcde" == ("abcd", "e") +-- > splitAtEnd 5 "abcde" == ("", "abcde") +-- +-- Edge cases, similar to behaviour of 'splitAt': + +-- > splitAtEnd (-1) "abcde" == ("abcde", "") -- split before start +-- > splitAtEnd 6 "abcde" == ("", "abcde") -- split after end +splitAtEnd :: + Int + -> S.ByteString + -> (S.ByteString, S.ByteString) +splitAtEnd n bs = S.splitAt n' bs + where + -- This may drop below zero if @n > length bs@. This will give us the + -- correct behaviour from 'splitAt' + n' :: Int + n' = S.length bs - n + +-- | Wrapper around 'S.length' with more sane return type +lengthStrict :: S.ByteString -> Word32 +lengthStrict = fromIntegral . S.length + +-- | Wrapper around 'L.length' with more sane return type +lengthLazy :: L.ByteString -> Word32 +lengthLazy = fromIntegral . L.length diff --git a/src/Codec/Borsh/Internal/Util/ByteSwap.hs b/src/Codec/Borsh/Internal/Util/ByteSwap.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Borsh/Internal/Util/ByteSwap.hs @@ -0,0 +1,51 @@ +-- | Swap between big-endian and little endian +-- +-- This is adapted from the `memory` package. Once +-- is merged this should not +-- be necessary anymore. +module Codec.Borsh.Internal.Util.ByteSwap ( + ByteSwap(..) + , LE(..) + , toLE + , fromLE + , BE(..) + , toBE + , fromBE + ) where + +import Data.Word +import Foreign (Storable) + +import Data.Memory.Endian (getSystemEndianness, Endianness(LittleEndian)) + +-- | Little Endian value +newtype LE a = LE { unLE :: a } + deriving newtype (Show, Eq, Storable) + +-- | Big Endian value +newtype BE a = BE { unBE :: a } + deriving newtype (Show, Eq, Storable) + +-- | Convert a value in cpu endianess to big endian +toBE :: ByteSwap a => a -> BE a +toBE = BE . (if getSystemEndianness == LittleEndian then byteSwap else id) + +-- | Convert from a big endian value to the cpu endianness +fromBE :: ByteSwap a => BE a -> a +fromBE (BE a) = if getSystemEndianness == LittleEndian then byteSwap a else a + +-- | Convert a value in cpu endianess to little endian +toLE :: ByteSwap a => a -> LE a +toLE = LE . (if getSystemEndianness == LittleEndian then id else byteSwap) + +-- | Convert from a little endian value to the cpu endianness +fromLE :: ByteSwap a => LE a -> a +fromLE (LE a) = if getSystemEndianness == LittleEndian then a else byteSwap a + +class Storable a => ByteSwap a where + byteSwap :: a -> a + +instance ByteSwap Word8 where byteSwap = id +instance ByteSwap Word16 where byteSwap = byteSwap16 +instance ByteSwap Word32 where byteSwap = byteSwap32 +instance ByteSwap Word64 where byteSwap = byteSwap64 diff --git a/src/Codec/Borsh/Internal/Util/SOP.hs b/src/Codec/Borsh/Internal/Util/SOP.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Borsh/Internal/Util/SOP.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE PolyKinds #-} + +module Codec.Borsh.Internal.Util.SOP ( + indices + ) where + +import Data.SOP +import Data.Word + +indices :: forall k (xs :: [k]). SListI xs => NP (K Word8) xs +indices = go sList 0 + where + go :: forall xs'. SList xs' -> Word8 -> NP (K Word8) xs' + go SNil _ = Nil + go SCons ix = K ix :* go sList (succ ix) diff --git a/src/Data/FixedSizeArray.hs b/src/Data/FixedSizeArray.hs new file mode 100644 --- /dev/null +++ b/src/Data/FixedSizeArray.hs @@ -0,0 +1,111 @@ +-- | Fixed size arrays +-- +-- Intended for qualified import +-- +-- > import Data.FixedSizeArray (FixedSizeArray) +-- > import qualified Data.FixedSizeArray as FSA +module Data.FixedSizeArray ( + FixedSizeArray -- opaque + , MFixedSizeArray -- opaque + , toArray + , toMArray + -- * Construction + , fromList + , fromArray + , fromMArray + , new + ) where + +import Data.Coerce (coerce) +import Data.Kind (Type) +import Data.Proxy +import Data.Vector (Vector, MVector) +import GHC.TypeLits + +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Generic.Mutable as GM + +{------------------------------------------------------------------------------- + Definition +-------------------------------------------------------------------------------} + +-- | Fixed size arrays +-- +-- @FixedSizeArray n a@ is the Haskell counter-part to the Rust type @[A; N]@. +-- +-- NOTE: For convenience, this is an instance of 'G.Vector', but the invariant +-- that the length of the vector should never change is not currently checked. +newtype FixedSizeArray (n :: Nat) (a :: Type) = FromArray { + toArray :: Vector a + } + deriving stock (Show, Eq, Ord) + deriving newtype (Functor, Foldable) + +instance KnownNat n => Traversable (FixedSizeArray n) where + traverse f = fmap fromArray . traverse f . toArray + +-- | Mutable fixed-size arrays +newtype MFixedSizeArray (n :: Nat) s (a :: Type) = FromMArray { + toMArray :: MVector s a + } + +type instance G.Mutable (FixedSizeArray n) = MFixedSizeArray n + +instance GM.MVector (MFixedSizeArray n) a where + basicLength = coerce $ GM.basicLength @MVector @a + basicUnsafeSlice = coerce $ GM.basicUnsafeSlice @MVector @a + basicOverlaps = coerce $ GM.basicOverlaps @MVector @a + basicUnsafeNew = coerce $ GM.basicUnsafeNew @MVector @a + basicInitialize = coerce $ GM.basicInitialize @MVector @a + basicUnsafeRead = coerce $ GM.basicUnsafeRead @MVector @a + basicUnsafeWrite = coerce $ GM.basicUnsafeWrite @MVector @a + +instance G.Vector (FixedSizeArray n) a where + basicUnsafeFreeze = coerce $ G.basicUnsafeFreeze @Vector @a + basicUnsafeThaw = coerce $ G.basicUnsafeThaw @Vector @a + basicLength = coerce $ G.basicLength @Vector @a + basicUnsafeSlice = coerce $ G.basicUnsafeSlice @Vector @a + basicUnsafeIndexM = coerce $ G.basicUnsafeIndexM @Vector @a + +{------------------------------------------------------------------------------- + Construction +-------------------------------------------------------------------------------} + +-- | Construct 'FixedSizeArray' from list of unknown size +-- +-- Throws an exception if the list does not have the right number of elements. +fromList :: forall n a. KnownNat n => [a] -> FixedSizeArray n a +fromList = fromArray . G.fromList + +-- | Construct 'FixedSizeArray' from array of unknown size +-- +-- Throws an exception if the array does not have the right size. +fromArray :: forall n a. KnownNat n => Vector a -> FixedSizeArray n a +fromArray v + | G.length v == fromIntegral (natVal (Proxy @n)) = FromArray v + | otherwise = error $ concat [ + "fromArray: invalid length. " + , "expected " ++ show (natVal (Proxy @n)) + , ", but got " + , show $ G.length v + ] + +-- | Construct 'FixedSizeArray' from mutable array of unknown size +-- +-- Throws an exception if the array does not have the right size. +fromMArray :: forall n s a. KnownNat n => MVector s a -> MFixedSizeArray n s a +fromMArray v + | GM.length v == fromIntegral (natVal (Proxy @n)) = FromMArray v + | otherwise = error $ concat [ + "fromArray: invalid length. " + , "expected " ++ show (natVal (Proxy @n)) + , ", but got " + , show $ GM.length v + ] + +-- | Construct new mutable array of the appropriate size +new :: forall m n a. + (GM.PrimMonad m, KnownNat n) + => m (MFixedSizeArray n (GM.PrimState m) a) +new = FromMArray <$> GM.new (fromIntegral $ natVal (Proxy @n)) + diff --git a/src/Data/Int128.hs b/src/Data/Int128.hs new file mode 100644 --- /dev/null +++ b/src/Data/Int128.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Data.Int128 ( + -- * Definition + Int128 -- Opaque + -- * Construction + , int128 + -- * Destruction + , int128MS64 + , int128LS64 + ) where + +import Data.Bits +import Data.Data +import Data.Ix +import Data.Word +import Foreign +import GHC.Generics + +import qualified Data.WideWord.Int128 as WW + +import Codec.Borsh.Internal.Util.ByteSwap (ByteSwap(..)) + +{------------------------------------------------------------------------------- + Definition, construction, destruction +-------------------------------------------------------------------------------} + +-- | Signed 128-bit word +-- +-- Implementation note: this currently relies on the implementation of the +-- [wide-word](https://hackage.haskell.org/package/wide-word) package, with some +-- additional instances. However, the use of @wide-word@ is not part of the +-- public API of the @borsh@ package. +newtype Int128 = Int128 WW.Int128 + deriving stock Data + deriving newtype ( + Bits + , Bounded + , Enum + , Eq + , FiniteBits + , Generic + , Integral + , Ix + , Num + , Ord + , Read + , Real + , Show + , Storable + ) + +-- | Construct an 'Int128' +int128 :: + Word64 -- ^ Most significant bits + -> Word64 -- ^ Least significant bits + -> Int128 +int128 hi lo = Int128 (WW.Int128 hi lo) + +-- | Get the most significant 64 bits from an 'Int128' +int128MS64 :: Int128 -> Word64 +int128MS64 (Int128 (WW.Int128 hi _)) = hi + +-- | Get the least significant 64 bits from an 'Int128' +int128LS64 :: Int128 -> Word64 +int128LS64 (Int128 (WW.Int128 _ lo)) = lo + +{------------------------------------------------------------------------------- + Instances +-------------------------------------------------------------------------------} + +instance ByteSwap Int128 where + byteSwap (Int128 (WW.Int128 hi lo)) = + Int128 $ WW.Int128 (byteSwap64 lo) (byteSwap64 hi) diff --git a/src/Data/Word128.hs b/src/Data/Word128.hs new file mode 100644 --- /dev/null +++ b/src/Data/Word128.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Data.Word128 ( + -- * Definition + Word128 -- opaque + -- * Construction + , word128 + -- * Destruction + , word128MS64 + , word128LS64 + ) where + +import Data.Bits +import Data.Data +import Data.Ix +import Data.Word +import Foreign +import GHC.Generics + +import qualified Data.WideWord.Word128 as WW + +import Codec.Borsh.Internal.Util.ByteSwap (ByteSwap(..)) + +{------------------------------------------------------------------------------- + Definition, construction, destruction +-------------------------------------------------------------------------------} + +-- | Unsigned 128-bit word +-- +-- Implementation note: this currently relies on the implementation of the +-- [wide-word](https://hackage.haskell.org/package/wide-word) package, with some +-- additional instances. However, the use of @wide-word@ is not part of the +-- public API of the @borsh@ package. +newtype Word128 = Word128 WW.Word128 + deriving stock Data + deriving newtype ( + Bits + , Bounded + , Enum + , Eq + , FiniteBits + , Generic + , Integral + , Ix + , Num + , Ord + , Read + , Real + , Show + , Storable + ) + +-- | Construct a 'Word128' +word128 :: + Word64 -- ^ Most significant bits + -> Word64 -- ^ Least significant bits + -> Word128 +word128 hi lo = Word128 (WW.Word128 hi lo) + +-- | Get the most significant 64 bits from a 'Word128' +word128MS64 :: Word128 -> Word64 +word128MS64 (Word128 (WW.Word128 hi _)) = hi + +-- | Get the least significant 64 bits from a 'Word128' +word128LS64 :: Word128 -> Word64 +word128LS64 (Word128 (WW.Word128 _ lo)) = lo + +{------------------------------------------------------------------------------- + Instances +-------------------------------------------------------------------------------} + +instance ByteSwap Word128 where + byteSwap (Word128 (WW.Word128 hi lo)) = + Word128 $ WW.Word128 (byteSwap64 lo) (byteSwap64 hi) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,12 @@ +module Main (main) where + +import Test.Tasty + +import qualified Test.Codec.Borsh.Roundtrip +import qualified Test.Codec.Borsh.Size + +main :: IO () +main = defaultMain $ testGroup "borsh" [ + Test.Codec.Borsh.Roundtrip.tests + , Test.Codec.Borsh.Size.tests + ] diff --git a/test/Test/Codec/Borsh/ExampleType/BTree.hs b/test/Test/Codec/Borsh/ExampleType/BTree.hs new file mode 100644 --- /dev/null +++ b/test/Test/Codec/Borsh/ExampleType/BTree.hs @@ -0,0 +1,85 @@ +module Test.Codec.Borsh.ExampleType.BTree ( + BTree(..) + , arbitraryBTreeWithElems + ) where + +import Data.Word (Word8) +import Generics.SOP +import Test.QuickCheck + +import qualified GHC.Generics as GHC + +import Codec.Borsh + +import Test.Codec.Borsh.Util.QuickCheck + +-- | Binary trees +data BTree a = BTip | BLeaf a | BNode (BTree a) (BTree a) + deriving ( + Show + , Eq + , Ord + , Functor + , Foldable + , Traversable + , GHC.Generic + , Generic + , BorshSize + , FromBorsh + ) + +-- Manual ToBorsh instance as a sort of "golden" test for the derived FromBorsh +-- instance +instance ToBorsh a => ToBorsh (BTree a) where + encodeBorsh = Encoder $ \case + BTip -> runEncoder encodeBorsh (0 :: Word8) + BLeaf x -> runEncoder encodeBorsh (1 :: Word8) <> runEncoder encodeBorsh x + BNode l r -> + runEncoder encodeBorsh (2 :: Word8) + <> runEncoder encodeBorsh l + <> runEncoder encodeBorsh r + +arbitraryBTreeWithElems :: [a] -> Gen (BTree a) +arbitraryBTreeWithElems xs = do + (left, right) <- split2 xs + case (left, right) of + ([] , [] ) -> return $ BTip + ([x] , [] ) -> return $ BLeaf x + ([] , [y]) -> return $ BLeaf y + (l , r ) -> BNode <$> arbitraryBTreeWithElems l + <*> arbitraryBTreeWithElems r + +instance Arbitrary a => Arbitrary (BTree a) where + arbitrary :: Gen (BTree a) + arbitrary = sized $ \sz -> + if sz <= 0 then + leaf + else + resize (sz `div` 2) $ oneof [leaf, node] + where + leaf = BLeaf <$> arbitrary + node = BNode <$> arbitrary <*> arbitrary + + shrink :: BTree a -> [BTree a] + shrink BTip = [] + shrink (BLeaf x) = concat [ + -- Shrink to a tip + [ BTip ] + + -- Shrink the element + , BLeaf <$> shrink x + ] + shrink (BNode l r) = concat [ + -- Shrink to the left + [ l ] + + -- Shrink to the right + , [ r ] + + -- Shrink the left + , BNode <$> shrink l <*> pure r + + -- Shrink the right + , BNode <$> pure l <*> shrink r + ] + diff --git a/test/Test/Codec/Borsh/ExampleType/NTree.hs b/test/Test/Codec/Borsh/ExampleType/NTree.hs new file mode 100644 --- /dev/null +++ b/test/Test/Codec/Borsh/ExampleType/NTree.hs @@ -0,0 +1,74 @@ +module Test.Codec.Borsh.ExampleType.NTree ( + NTree(..) + , arbitraryNTreeWithElems + ) where + +import Data.Word (Word8) +import Generics.SOP +import Test.QuickCheck + +import qualified GHC.Generics as GHC + +import Codec.Borsh + +import Test.Codec.Borsh.Util.QuickCheck + +-- | N-ary trees +data NTree a = NLeaf | NNode a [NTree a] + deriving ( + Show + , Eq + , Ord + , Functor + , Foldable + , Traversable + , GHC.Generic + , Generic + , BorshSize + , ToBorsh + ) + -- Manual FromBorsh instance as a sort of "golden" test for the derived ToBorsh +-- instance +instance FromBorsh a => FromBorsh (NTree a) where + decodeBorsh = do + c <- decodeBorsh @Word8 + if c == 0 then + return NLeaf + else + NNode <$> decodeBorsh <*> decodeBorsh + +arbitraryNTreeWithElems :: [a] -> Gen (NTree a) +arbitraryNTreeWithElems [] = pure NLeaf +arbitraryNTreeWithElems (x:xs) = do + n <- choose (0,10) + cs <- splitN n xs + NNode x <$> mapM arbitraryNTreeWithElems cs + +instance Arbitrary a => Arbitrary (NTree a) where + arbitrary :: Gen (NTree a) + arbitrary = sized $ \sz -> + if sz <= 0 then + leaf + else oneof [ + resize (sz - 1) leaf + , do + len <- choose (0,sz) + resize (sz `div` (len + 1)) node + ] + where + leaf = pure NLeaf + node = NNode <$> arbitrary <*> arbitrary + + shrink :: NTree a -> [NTree a] + shrink NLeaf = [] + shrink (NNode x cs) = concat [ + -- Shrink to a leaf + [ NLeaf ] + + -- Shrink the children + , NNode x <$> shrink cs + + -- Shrink the element + , NNode <$> shrink x <*> pure cs + ] + diff --git a/test/Test/Codec/Borsh/ExampleType/SimpleList.hs b/test/Test/Codec/Borsh/ExampleType/SimpleList.hs new file mode 100644 --- /dev/null +++ b/test/Test/Codec/Borsh/ExampleType/SimpleList.hs @@ -0,0 +1,32 @@ +module Test.Codec.Borsh.ExampleType.SimpleList ( + SimpleList(..) + , arbitraryLargeSimpleList + , arbitrarySimpleListOfSize + ) where + +import Control.Monad +import Data.Word +import Generics.SOP +import Test.QuickCheck + +import Codec.Borsh + +-- | Lists of 1s and 2s +newtype SimpleList = SimpleList { getSimpleList :: [Word8] } + deriving newtype (Show, Eq, Ord, Generic, BorshSize, FromBorsh, ToBorsh) + +instance Arbitrary SimpleList where + arbitrary = sized arbitrarySimpleListOfSize + + -- We don't want to shrink the elements of the list since we want them to stay + -- as 1s an 2s (so the 0s in the encoding are more obvious) + shrink (SimpleList xs) = SimpleList <$> shrinkList (const []) xs + +-- | Generate large list, in the hope that it crosses chunk boundaries +arbitraryLargeSimpleList :: Gen SimpleList +arbitraryLargeSimpleList = do + len <- choose (0, 10_000) + arbitrarySimpleListOfSize len + +arbitrarySimpleListOfSize :: Int -> Gen SimpleList +arbitrarySimpleListOfSize len = SimpleList <$> replicateM len (elements [1, 2]) diff --git a/test/Test/Codec/Borsh/ExampleType/SimpleStructs.hs b/test/Test/Codec/Borsh/ExampleType/SimpleStructs.hs new file mode 100644 --- /dev/null +++ b/test/Test/Codec/Borsh/ExampleType/SimpleStructs.hs @@ -0,0 +1,63 @@ +module Test.Codec.Borsh.ExampleType.SimpleStructs ( + PolyStruct(..) + , SimpleStruct1(..) + , SimpleStruct2(..) + ) where + +import Data.Proxy (Proxy(..)) +import Data.Word (Word8, Word64, Word16) +import Generics.SOP (Generic) +import Test.QuickCheck + +import qualified GHC.Generics as GHC + +import Codec.Borsh + +{------------------------------------------------------------------------------- + Polymorphic +-------------------------------------------------------------------------------} + +data PolyStruct a = Poly a a a + deriving (Show, Eq, Ord, GHC.Generic, Generic) + deriving (BorshSize, ToBorsh, FromBorsh) via Struct (PolyStruct a) + +instance Arbitrary a => Arbitrary (PolyStruct a) where + arbitrary = Poly <$> arbitrary <*> arbitrary <*> arbitrary + shrink (Poly x y z) = Poly <$> shrink x <*> shrink y <*> shrink z + +{------------------------------------------------------------------------------- + Monomorphic +-------------------------------------------------------------------------------} + +data SimpleStruct1 = Struct1 Word8 () Word64 + deriving (Show, Eq, Ord, GHC.Generic, Generic) + deriving (BorshSize, ToBorsh, FromBorsh) via Struct SimpleStruct1 + +instance Arbitrary SimpleStruct1 where + arbitrary = Struct1 <$> arbitrary <*> arbitrary <*> arbitrary + shrink (Struct1 x y z) = Struct1 <$> shrink x <*> shrink y <*> shrink z + +{------------------------------------------------------------------------------- + Monomorphic with hand-written BorshSize instance + + The hand-written 'BorshSize' instance is useful to verify that the generic + encoder/decoder generate values of the expected size. (Conversely, the + automatically derived instance for 'SimpleStruct1' is useful to check that the + generic machinery for 'BorshSize' works.) +-------------------------------------------------------------------------------} + +data SimpleStruct2 = Struct2 () SimpleStruct1 Word16 + deriving (Show, Eq, Ord, GHC.Generic, Generic) + deriving (ToBorsh, FromBorsh) via Struct SimpleStruct2 + +instance BorshSize SimpleStruct2 where + type StaticBorshSize SimpleStruct2 = 'HasKnownSize + + borshSize _ = + case borshSize (Proxy @SimpleStruct1) of + SizeKnown n -> SizeKnown $ n + 2 + +instance Arbitrary SimpleStruct2 where + arbitrary = Struct2 <$> arbitrary <*> arbitrary <*> arbitrary + shrink (Struct2 x y z) = Struct2 <$> shrink x <*> shrink y <*> shrink z + diff --git a/test/Test/Codec/Borsh/Roundtrip.hs b/test/Test/Codec/Borsh/Roundtrip.hs new file mode 100644 --- /dev/null +++ b/test/Test/Codec/Borsh/Roundtrip.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Codec.Borsh.Roundtrip (tests) where + +import Test.Tasty +import Test.Tasty.QuickCheck + +import Codec.Borsh + +import Test.Codec.Borsh.Util.RandomType + +tests :: TestTree +tests = testGroup "Test.Codec.Borsh.Roundtrip" [ + testProperty "roundtrip" test_roundtrip + ] + +test_roundtrip :: SomeBorshValue -> Property +test_roundtrip (SomeValue _typ val) = + deserialiseBorsh (serialiseBorsh val) + === Right val diff --git a/test/Test/Codec/Borsh/Size.hs b/test/Test/Codec/Borsh/Size.hs new file mode 100644 --- /dev/null +++ b/test/Test/Codec/Borsh/Size.hs @@ -0,0 +1,28 @@ +module Test.Codec.Borsh.Size (tests) where + +import Data.Proxy +import Test.Tasty +import Test.Tasty.QuickCheck + +import qualified Data.ByteString.Lazy as L + +import Codec.Borsh + +import Test.Codec.Borsh.Util.RandomType + +tests :: TestTree +tests = testGroup "Test.Codec.Borsh.Size" [ + testProperty "size" test_size + ] + +test_size :: SomeBorshValue -> Property +test_size = + \(SomeValue _typ val) -> aux val + where + aux :: forall a. ToBorsh a => a -> Property + aux val = + case borshSize (Proxy @a) of + SizeVariable -> label "Trivial" $ True + SizeKnown n -> L.length (serialiseBorsh val) === fromIntegral n + + diff --git a/test/Test/Codec/Borsh/Util/Length.hs b/test/Test/Codec/Borsh/Util/Length.hs new file mode 100644 --- /dev/null +++ b/test/Test/Codec/Borsh/Util/Length.hs @@ -0,0 +1,36 @@ +module Test.Codec.Borsh.Util.Length ( + Length(..) + , SomeLength(..) + ) where + +import Data.Maybe (fromJust) +import Data.Proxy +import GHC.TypeLits +import Test.QuickCheck + +-- | Like Proxy, but with a more informative show instance +data Length (n :: Nat) = Length + +lengthVal :: forall n. KnownNat n => Length n -> Int +lengthVal _ = fromIntegral $ natVal (Proxy @n) + +instance KnownNat n => Show (Length n) where + show = show . lengthVal + +data SomeLength where + SomeLength :: KnownNat n => Length n -> SomeLength + +toSomeLength :: SomeNat -> SomeLength +toSomeLength (SomeNat n) = SomeLength (aux n) + where + aux :: forall n. Proxy n -> Length n + aux _ = Length + +instance Arbitrary SomeLength where + arbitrary = toSomeLength . fromJust . someNatVal <$> choose (0, 3) + shrink (SomeLength n) = aux n + where + aux :: forall n. KnownNat n => Length n -> [SomeLength] + aux _ = map (toSomeLength . fromJust . someNatVal) $ + shrink (natVal (Proxy @n)) + diff --git a/test/Test/Codec/Borsh/Util/Orphans.hs b/test/Test/Codec/Borsh/Util/Orphans.hs new file mode 100644 --- /dev/null +++ b/test/Test/Codec/Borsh/Util/Orphans.hs @@ -0,0 +1,46 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Codec.Borsh.Util.Orphans () where + +import Control.Monad (replicateM) +import Data.SOP +import qualified Data.Text as Text +import Data.Text (Text) +import GHC.TypeLits +import Test.QuickCheck hiding (Fn) + + +import Data.FixedSizeArray (FixedSizeArray) +import Data.Word128 +import Data.Int128 + +import qualified Data.FixedSizeArray as FSA + +instance Arbitrary Word128 where + arbitrary = word128 <$> arbitrary <*> arbitrary + shrink w128 = concat [ + [word128 hi' lo | hi' <- shrink hi] + , [word128 hi lo' | lo' <- shrink lo] + ] + where + hi = word128MS64 w128 + lo = word128LS64 w128 + +instance Arbitrary Int128 where + arbitrary = int128 <$> arbitrary <*> arbitrary + shrink i128 = concat [ + [int128 hi' lo | hi' <- shrink hi] + , [int128 hi lo' | lo' <- shrink lo] + ] + where + hi = int128MS64 i128 + lo = int128LS64 i128 + +instance Arbitrary Text where + arbitrary = Text.pack <$> arbitrary + shrink = map Text.pack . shrink . Text.unpack + +instance (KnownNat n, Arbitrary a) => Arbitrary (FixedSizeArray n a) where + arbitrary = FSA.fromList <$> + replicateM (fromIntegral $ natVal (Proxy @n)) arbitrary + diff --git a/test/Test/Codec/Borsh/Util/QuickCheck.hs b/test/Test/Codec/Borsh/Util/QuickCheck.hs new file mode 100644 --- /dev/null +++ b/test/Test/Codec/Borsh/Util/QuickCheck.hs @@ -0,0 +1,51 @@ +module Test.Codec.Borsh.Util.QuickCheck ( + -- * Compositional shrinking + Shrinker(..) + , shrinker + -- * Generators + , split2 + , splitN + ) where + +import Control.Monad +import Test.QuickCheck + +{------------------------------------------------------------------------------- + Compositional shrinking +-------------------------------------------------------------------------------} + +newtype Shrinker a = Shrinker { runShrinker :: a -> [a] } + +instance Semigroup (Shrinker a) where + Shrinker f <> Shrinker g = Shrinker $ \x -> f x ++ g x + +instance Monoid (Shrinker a) where + mempty = Shrinker $ \_ -> [] + +shrinker :: Arbitrary a => Shrinker a +shrinker = Shrinker shrink + +{------------------------------------------------------------------------------- + Generators +-------------------------------------------------------------------------------} + +split2 :: [a] -> Gen ([a], [a]) +split2 = splitN 2 >=> \case + [xs,ys] -> return (xs, ys) + _ -> error "splitN post-condition failed" + +-- Post-condition: outer list will contain precisely @n@ elements +splitN :: Int -> [a] -> Gen [[a]] +splitN 0 = const $ pure [] +splitN n = shuffle >=> go + where + go :: [a] -> Gen [[a]] + go [] = pure $ replicate n [] + go (x:xs) = do + splits <- splitN n xs + select <- choose (0,n-1) + case splitAt select splits of + (_ ,[] ) -> error "expected non-empty tail in split" + (xs',y:ys) -> + return $ xs' ++ (x:y):ys + diff --git a/test/Test/Codec/Borsh/Util/RandomType.hs b/test/Test/Codec/Borsh/Util/RandomType.hs new file mode 100644 --- /dev/null +++ b/test/Test/Codec/Borsh/Util/RandomType.hs @@ -0,0 +1,1011 @@ +-- 11 iterations needed for GHC 9.2.2 +{-# OPTIONS_GHC -fconstraint-solver-iterations=11 #-} + +module Test.Codec.Borsh.Util.RandomType ( + -- * Types + BorshType(..) + , SomeBorshType(..) + -- * Values of those types + , SomeBorshValue(..) + + -- TODO remove these + , arbitraryValue + , arbitraryType + ) where + +import Control.Monad +import Data.ByteString (ByteString) +import Data.FixedSizeArray (FixedSizeArray) +import Data.Foldable (toList) +import Data.Int +import Data.Int128 +import Data.Kind +import Data.Map (Map) +import Data.Maybe (mapMaybe, maybeToList) +import Data.Profunctor +import Data.Set (Set) +import Data.Text (Text) +import Data.Word +import Data.Word128 +import Generics.SOP +import Generics.SOP.Dict +import Generics.SOP.NP (map_NP) +import GHC.Float +import GHC.TypeLits +import Test.QuickCheck hiding (shrinkIntegral) +import Test.QuickCheck.Instances.ByteString () +import Test.QuickCheck.Instances.UnorderedContainers () + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Text as Text + +import Codec.Borsh + +import qualified Data.FixedSizeArray as FSA + +import Test.Codec.Borsh.ExampleType.BTree +import Test.Codec.Borsh.ExampleType.NTree +import Test.Codec.Borsh.ExampleType.SimpleList +import Test.Codec.Borsh.ExampleType.SimpleStructs +import Test.Codec.Borsh.Util.Length +import Test.Codec.Borsh.Util.Orphans () +import Test.Codec.Borsh.Util.SOP + +{------------------------------------------------------------------------------- + Preliminaries +-------------------------------------------------------------------------------} + +class ( Arbitrary a + , Show a + , Eq a + , Ord a + , BorshSize a + , ToBorsh a + , FromBorsh a + ) => CanTest a + +instance ( Arbitrary a + , Show a + , Eq a + , Ord a + , BorshSize a + , ToBorsh a + , FromBorsh a + ) => CanTest a + +{------------------------------------------------------------------------------- + Auxiliary: working with n-ary products + + We would like to generate arbitrary structs/enums for our property tests. In + order to do this properly, we need to generate arbitrary-length n-ary products +-------------------------------------------------------------------------------} + +data SomeBorshNP where + SomeBorshNP :: + ( All CanTest xs + , All (Compose Show BorshType) xs + ) + => NP BorshType xs -> SomeBorshNP + +deriving instance Show SomeBorshNP + +data SomeBorshPOP where + SomeBorshPOP :: + ( All2 CanTest (xs ': xss) + , All (Compose Show (NP BorshType)) (xs ': xss) + , BorshSizeSum (xs ': xss) + ) + => POP BorshType (xs ': xss) -> SomeBorshPOP + +deriving instance Show SomeBorshPOP + +someBorshPOP :: forall xs xss. + ( All2 CanTest (xs ': xss) + , All (Compose Show (NP BorshType)) (xs ': xss) + ) + => POP BorshType (xs ': xss) -> SomeBorshPOP +someBorshPOP xss = + case dictBorshSizeSum (Proxy @(xs ': xss)) of + Dict -> SomeBorshPOP xss + +generateSomeNP :: Int -> Gen SomeBorshNP +generateSomeNP = \sz -> do + len <- choose (0, 3) :: Gen Int + go len (sz `div` (len + 1)) + where + go :: Int -> Int -> Gen SomeBorshNP + go i sz | i <= 0 = pure (SomeBorshNP Nil) + | otherwise = do + SomeType x <- resize sz arbitraryType + SomeBorshNP xs <- go (i - 1) sz + pure $ SomeBorshNP (x :* xs) + +generateSomePOP :: Int -> Gen SomeBorshPOP +generateSomePOP = \sz -> do + len <- choose (1, 3) :: Gen Int + go len (sz `div` len) + where + go :: Int -> Int -> Gen SomeBorshPOP + go i sz | i <= 1 = do + SomeBorshNP np <- generateSomeNP sz + pure $ someBorshPOP (POP (np :* Nil)) + | otherwise = do + SomeBorshNP np <- generateSomeNP sz + SomeBorshPOP (POP nps) <- go (i - 1) sz + pure $ SomeBorshPOP (POP (np :* nps)) + +{------------------------------------------------------------------------------- + Auxiliary: shrunk NPs and POPs +-------------------------------------------------------------------------------} + +-- | Shrunk product +-- +-- When we shrink products recursively, we need to know that we only shrink +-- products to products: this allows us to prepend something to the product +-- in the recursive case. +data ShrunkNP xs where + ShrunkNP :: + ( All CanTest xs' + , SListI xs' + ) + => NP BorshType xs' -> ShrinkFun (NP I xs) (NP I xs') -> ShrunkNP xs + +fromShrunkNP :: ShrunkNP xs -> SomeShrunkType (NP I xs) +fromShrunkNP (ShrunkNP ts f) = + case allTestingConstraints ts of + Dict -> SomeShrunk (BtStruct ts) f + +shrinkNpDropHead :: + All CanTest xs + => NP BorshType xs -> ShrunkNP (x : xs) +shrinkNpDropHead xs = ShrunkNP xs $ ShrinkFun (return . tl) + +shrinkNpShrinkHead :: + All CanTest (x ': xs) + => SomeShrunkType x -> NP BorshType xs -> ShrunkNP (x ': xs) +shrinkNpShrinkHead (SomeShrunk x (ShrinkFun f)) xs = + ShrunkNP (x :* xs) (ShrinkFun $ mapHeadNP (map I . f . unI)) + +shrinkNpTail :: + All CanTest (x ': xs) + => BorshType x -> ShrunkNP xs -> ShrunkNP (x : xs) +shrinkNpTail x (ShrunkNP xs (ShrinkFun f)) = + ShrunkNP (x :* xs) (ShrinkFun $ mapTailNP f) + +-- | Shrink one of the types in the product +shrinkProdElem :: + All CanTest xs + => NP BorshType xs -> NP ([] :.: SomeShrunkType) xs -> [ShrunkNP xs] +shrinkProdElem Nil Nil = [] +shrinkProdElem (x :* xs) (Comp shrinkA :* ss) = concat [ + map (`shrinkNpShrinkHead` xs) shrinkA + , map (shrinkNpTail x) $ shrinkProdElem xs ss + ] + +-- | Drop one of the types in the product +shrinkProdSize :: + All CanTest xs + => NP BorshType xs -> [ShrunkNP xs] +shrinkProdSize Nil = [] +shrinkProdSize (x :* xs) = shrinkNpDropHead xs + : map (shrinkNpTail x) (shrinkProdSize xs) + +data ShrunkPOP xss where + ShrunkPOP :: + ( All2 CanTest xss' + , SListI xss' + , BorshSizeSum xss' + ) + => POP BorshType xss' -> ShrinkFun (SOP I xss) (SOP I xss') -> ShrunkPOP xss + +shrunkPOP :: forall xss xss'. + All2 CanTest xss' + => POP BorshType xss' + -> ShrinkFun (SOP I xss) (SOP I xss') + -> ShrunkPOP xss +shrunkPOP xss f = + case dictBorshSizeSum (Proxy @xss') of + Dict -> ShrunkPOP xss f + +fromShrunkPOP :: ShrunkPOP xss -> Maybe (SomeShrunkType (SOP I xss)) +fromShrunkPOP (ShrunkPOP ts f) = + case ts of + POP Nil -> Nothing + POP (_ :* _) -> + case all2TestingConstraints ts of + Dict -> Just $ SomeShrunk (BtEnum ts) f + +shrinkPOPDropHead :: + All2 CanTest xss + => POP BorshType xss -> ShrunkPOP (xs : xss) +shrinkPOPDropHead xss = shrunkPOP xss $ ShrinkFun $ \(SOP x) -> case x of + Z _ -> [] + S x' -> [SOP x'] + +shrinkPOPShrinkHead :: forall xs xss. + All2 CanTest (xs ': xss) + => ShrunkNP xs -> POP BorshType xss -> ShrunkPOP (xs ': xss) +shrinkPOPShrinkHead (ShrunkNP ts (ShrinkFun f)) (POP xs) = + shrunkPOP (POP $ ts :* xs) (ShrinkFun $ mapHeadSOP f) + +shrinkPOPTail :: forall xs xss. + All2 CanTest (xs ': xss) + => NP BorshType xs -> ShrunkPOP xss -> ShrunkPOP (xs : xss) +shrinkPOPTail xs (ShrunkPOP (POP xss) (ShrinkFun f)) = + shrunkPOP (POP $ xs :* xss) (ShrinkFun $ mapTailSOP f) + +-- | Shrink one of the products in a POP +shrinkPOPElem :: + All2 CanTest xss + => POP BorshType xss -> NP ([] :.: ShrunkNP) xss -> [ShrunkPOP xss] +shrinkPOPElem (POP Nil) Nil = [] +shrinkPOPElem (POP (x :* xs)) (Comp shrinkP :* ss) = concat [ + map (`shrinkPOPShrinkHead` POP xs) shrinkP + , map (shrinkPOPTail x) $ shrinkPOPElem (POP xs) ss + ] + +shrinkPOPSize :: + All2 CanTest xss + => POP BorshType xss -> [ShrunkPOP xss] +shrinkPOPSize (POP Nil) = [] +shrinkPOPSize (POP (xs :* xss)) = shrinkPOPDropHead (POP xss) + : map (shrinkPOPTail xs) (shrinkPOPSize (POP xss)) + +{------------------------------------------------------------------------------- + Types +-------------------------------------------------------------------------------} + +-- | Non-composite types +data BorshSimpleType :: Type -> Type where + BtU8 :: BorshSimpleType Word8 + BtU16 :: BorshSimpleType Word16 + BtU32 :: BorshSimpleType Word32 + BtU64 :: BorshSimpleType Word64 + BtU128 :: BorshSimpleType Word128 + BtI8 :: BorshSimpleType Int8 + BtI16 :: BorshSimpleType Int16 + BtI32 :: BorshSimpleType Int32 + BtI64 :: BorshSimpleType Int64 + BtI128 :: BorshSimpleType Int128 + BtF32 :: BorshSimpleType Float + BtF64 :: BorshSimpleType Double + BtText :: BorshSimpleType Text + BtUnit :: BorshSimpleType () + + -- Example user-defined types + BtSimpleList :: BorshSimpleType SimpleList + BtSimpleStruct1 :: BorshSimpleType SimpleStruct1 + BtSimpleStruct2 :: BorshSimpleType SimpleStruct2 + + -- Common Haskell types + BtByteString :: BorshSimpleType ByteString + BtChar :: BorshSimpleType Char + BtBool :: BorshSimpleType Bool + +deriving instance Show (BorshSimpleType a) + +data BorshType :: Type -> Type where + BtSimple :: BorshSimpleType t -> BorshType t + + -- Composite + + BtArray :: + (KnownNat n, CanTest a) + => Length n + -> BorshType a + -> BorshType (FixedSizeArray n a) + + BtVec :: + CanTest a + => BorshType a + -> BorshType [a] + + BtOption :: + CanTest a + => BorshType a + -> BorshType (Maybe a) + + BtHashSet :: + (CanTest a) + => BorshType a + -> BorshType (Set a) + + BtHashMap :: + (CanTest k, CanTest a) + => BorshType k + -> BorshType a + -> BorshType (Map k a) + + BtStruct :: + ( All CanTest xs + , All (Compose Show BorshType) xs + ) + => NP BorshType xs + -> BorshType (NP I xs) + + BtEnum :: + ( All2 CanTest (xs ': xss) + , All (Compose Show (NP BorshType)) (xs ': xss) + ) + => -- POP: For every constructor, and every argument to every constructor, + -- what is the type of that argument? + POP BorshType (xs ': xss) + -- /Values/ are using a /specific/ constructor, hence SOP, not POP + -> BorshType (SOP I (xs ': xss)) + + -- Example user-defined types + + BtBTree :: + CanTest a + => BorshType a -> BorshType (BTree a) + + BtNTree :: + CanTest a + => BorshType a -> BorshType (NTree a) + + BtPolyStruct :: CanTest a => BorshType a -> BorshType (PolyStruct a) + + -- Common Haskell types + BtEither :: + ( CanTest a + , CanTest b + ) + => BorshType a -> BorshType b -> BorshType (Either a b) + +deriving instance Show (BorshType a) + +data SomeBorshType where + SomeType :: CanTest a => BorshType a -> SomeBorshType + +deriving instance Show SomeBorshType + +{------------------------------------------------------------------------------- + Shrinking types +-------------------------------------------------------------------------------} + +shrinkToUnit :: ShrinkFun a () +shrinkToUnit = ShrinkFun $ \_ -> return () + +shrinkIntegral :: (Integral a, Num b) => ShrinkFun a b +shrinkIntegral = ShrinkFun $ return . fromIntegral + +shrinkU128 :: ShrinkFun Word128 Word64 +shrinkU128 = ShrinkFun $ return . word128LS64 + +shrinkDouble :: ShrinkFun Double Word64 +shrinkDouble = ShrinkFun $ return . castDoubleToWord64 + +shrinkFloat :: ShrinkFun Float Word32 +shrinkFloat = ShrinkFun $ return . castFloatToWord32 + +shrinkFoldable :: Foldable f => ShrinkFun (f a) a +shrinkFoldable = ShrinkFun toList + +shrinkTraversable :: Traversable f => ShrinkFun a b -> ShrinkFun (f a) (f b) +shrinkTraversable (ShrinkFun f) = ShrinkFun $ traverse f + +shrinkFixedArraySize :: forall n m a. + (KnownNat n, KnownNat m) + => ShrinkFun (FixedSizeArray n a) (FixedSizeArray m a) +shrinkFixedArraySize + | natVal (Proxy @m) < natVal (Proxy @n) + = ShrinkFun $ + return . FSA.fromList . take (fromIntegral $ natVal (Proxy @m)) . toList + + | otherwise + = ShrinkFun $ const [] + +shrinkHashSet :: + Ord b + => ShrinkFun a b + -> ShrinkFun (Set a) (Set b) +shrinkHashSet = dimap Set.toList Set.fromList . shrinkTraversable + +shrinkHashMap :: + Ord k2 + => ShrinkFun (k1,a) (k2,b) + -> ShrinkFun (Map k1 a) (Map k2 b) +shrinkHashMap = dimap Map.toList Map.fromList . shrinkTraversable + +shrinkHashMapToKey :: ShrinkFun (Map k a) k +shrinkHashMapToKey = ShrinkFun Map.keys + +deriving instance (Show a) => Show (SomeShrunkType a) + +instance Show (ShrinkFun a b) where + show _ = "" + +newtype ShrinkFun a b = ShrinkFun (a -> [b]) + +instance Profunctor ShrinkFun where + dimap f g (ShrinkFun h) = ShrinkFun $ fmap g . h . f + +instance Strong ShrinkFun where + first' (ShrinkFun f) = ShrinkFun $ \(a,c) -> (,c) <$> f a + +data SomeShrunkType a where + SomeShrunk :: + CanTest b + => BorshType b + -> ShrinkFun a b + -> SomeShrunkType a + +-- | Shrink simple type +-- +-- See additional discussion in 'shrinkType' +shrinkSimpleType :: BorshSimpleType a -> Maybe (SomeShrunkType a) +shrinkSimpleType = \case + BtU8 -> Just $ SomeShrunk (BtSimple BtUnit) shrinkToUnit + BtU16 -> Just $ SomeShrunk (BtSimple BtU8) shrinkIntegral + BtU32 -> Just $ SomeShrunk (BtSimple BtU16) shrinkIntegral + BtU64 -> Just $ SomeShrunk (BtSimple BtU32) shrinkIntegral + BtU128 -> Just $ SomeShrunk (BtSimple BtU64) shrinkU128 + BtI8 -> Just $ SomeShrunk (BtSimple BtU8) shrinkIntegral + BtI16 -> Just $ SomeShrunk (BtSimple BtU16) shrinkIntegral + BtI32 -> Just $ SomeShrunk (BtSimple BtU32) shrinkIntegral + BtI64 -> Just $ SomeShrunk (BtSimple BtU64) shrinkIntegral + BtI128 -> Just $ SomeShrunk (BtSimple BtU128) shrinkIntegral + BtF32 -> Just $ SomeShrunk (BtSimple BtU32) shrinkFloat + BtF64 -> Just $ SomeShrunk (BtSimple BtU64) shrinkDouble + BtText -> Just $ SomeShrunk (BtSimple BtUnit) shrinkToUnit + BtUnit -> Nothing + + -- TODO: We /could/ shrink these to one of their fields (not very important) + BtSimpleList -> Just $ SomeShrunk (BtSimple BtUnit) shrinkToUnit + BtSimpleStruct1 -> Just $ SomeShrunk (BtSimple BtUnit) shrinkToUnit + BtSimpleStruct2 -> Just $ SomeShrunk (BtSimple BtUnit) shrinkToUnit + BtByteString -> Just $ SomeShrunk (BtSimple BtUnit) shrinkToUnit + + BtChar -> Just $ SomeShrunk (BtSimple BtUnit) shrinkToUnit + BtBool -> Just $ SomeShrunk (BtSimple BtUnit) shrinkToUnit + +-- | Shrink type +-- +-- * We do not try to shrink quickly; one step at a time is fine +-- * We shrink unsigned sized types to the smaller versions (@Word64@ -> @Word32@) +-- * We shrink signed types to their unsigned version (bit-for-bit) +-- * We shrink floats to words (bit-for-bit) +-- * We can always shrink to unit +-- +-- Implementation note: no catch-all case, so that we are forced to consider how +-- to shrink any new types that we add. +shrinkType :: BorshType a -> [SomeShrunkType a] +shrinkType = \case + + -- Non-composite + + BtSimple t -> maybeToList $ shrinkSimpleType t + + -- Composite + + BtArray n t -> concat [ + -- Drop the array altogether + [ SomeShrunk t shrinkFoldable ] + + -- Shrink the size of the array + , [ SomeShrunk (BtArray n' t) shrinkFixedArraySize + | SomeLength n' <- shrink (SomeLength n) + ] + + -- Shrink the type of the elements + , [ SomeShrunk (BtArray n t') (shrinkTraversable f) + | SomeShrunk t' f <- shrinkType t + ] + ] + + BtVec t -> concat [ + [ SomeShrunk t shrinkFoldable ] + , [ SomeShrunk (BtVec t') (shrinkTraversable f) + | SomeShrunk t' f <- shrinkType t] + ] + + BtOption t -> concat [ + [ SomeShrunk t shrinkFoldable ] + , [ SomeShrunk (BtOption t') (shrinkTraversable f) + | SomeShrunk t' f <- shrinkType t + ] + ] + + BtHashSet t -> concat [ + [ SomeShrunk t shrinkFoldable ] + , [ SomeShrunk (BtHashSet t') (shrinkHashSet f) + | SomeShrunk t' f <- shrinkType t + ] + ] + + BtHashMap k t -> concat [ + [ SomeShrunk t shrinkFoldable ] + , [ SomeShrunk k shrinkHashMapToKey ] + , [ SomeShrunk (BtHashMap k t') (shrinkHashMap (second' f)) + | SomeShrunk t' f <- shrinkType t + ] + , [ SomeShrunk (BtHashMap k' t ) (shrinkHashMap (first' f)) + | SomeShrunk k' f <- shrinkType k + ] + ] + + BtStruct xs -> map fromShrunkNP (shrinkNP xs) + + BtEnum xss -> mapMaybe fromShrunkPOP (shrinkPOP xss) + + -- User-defined + + BtBTree t -> concat [ + [ SomeShrunk t $ ShrinkFun $ \case + BTip -> [] + BLeaf a -> [a] + BNode _ _ -> [] + ] + + , [ SomeShrunk (BtBTree t') (ShrinkFun $ traverse f) + | SomeShrunk t' (ShrinkFun f) <- shrinkType t + ] + ] + + BtNTree t -> concat [ + [ SomeShrunk t $ ShrinkFun $ \case + NLeaf -> [] + NNode a _ -> [a] + ] + + , [ SomeShrunk (BtNTree t') (ShrinkFun $ traverse f) + | SomeShrunk t' (ShrinkFun f) <- shrinkType t + ] + ] + + BtPolyStruct t -> concat [ + [ SomeShrunk t $ ShrinkFun $ \case + Poly x _ _ -> [ x ] + ] + + , [ SomeShrunk (BtPolyStruct t') + ( ShrinkFun $ \(Poly x y z) -> + Poly <$> (f x) <*> (f y) <*> (f z) + ) + | SomeShrunk t' (ShrinkFun f) <- shrinkType t + ] + ] + + BtEither ta tb -> concat [ + [ SomeShrunk ta $ ShrinkFun $ \case + Left a -> [ a ] + Right _ -> [] + ] + + , [ SomeShrunk tb $ ShrinkFun $ \case + Left _ -> [] + Right b -> [ b ] + ] + + , [ SomeShrunk (BtEither ta' tb') + ( ShrinkFun $ \case + Left a -> Left <$> fa a + Right b -> Right <$> fb b + ) + | SomeShrunk ta' (ShrinkFun fa) <- shrinkType ta + , SomeShrunk tb' (ShrinkFun fb) <- shrinkType tb + ] + ] + +shrinkNP :: All CanTest xs => NP BorshType xs -> [ShrunkNP xs] +shrinkNP xs = case allTestingConstraints xs of + Dict -> + concat [ + -- Shrink one of the types in the product + shrinkProdElem xs (map_NP (Comp . shrinkType) xs) + + -- Drop one of the types in the product + , shrinkProdSize xs + ] + +shrinkPOP :: + All2 CanTest xss + => POP BorshType xss -> [ShrunkPOP xss] +shrinkPOP xss = + concat [ + -- Shrink one of the products in the product + shrinkPOPElem xss ( + hcmap p (Comp . shrinkNP) (unPOP xss) + ) + + -- Drop one of the products in the product + , shrinkPOPSize xss + ] + where + p = Proxy :: Proxy (All CanTest) + +{------------------------------------------------------------------------------- + Arbitrary instance for BorshType +-------------------------------------------------------------------------------} + +arbitrarySimpleType :: Gen SomeBorshType +arbitrarySimpleType = elements [ + SomeType $ BtSimple BtU8 + , SomeType $ BtSimple BtU16 + , SomeType $ BtSimple BtU32 + , SomeType $ BtSimple BtU64 + , SomeType $ BtSimple BtU128 + , SomeType $ BtSimple BtI8 + , SomeType $ BtSimple BtI16 + , SomeType $ BtSimple BtI32 + , SomeType $ BtSimple BtI64 + , SomeType $ BtSimple BtI128 + , SomeType $ BtSimple BtF32 + , SomeType $ BtSimple BtF64 + , SomeType $ BtSimple BtUnit + , SomeType $ BtSimple BtText + , SomeType $ BtSimple BtSimpleList + , SomeType $ BtSimple BtSimpleStruct1 + , SomeType $ BtSimple BtSimpleStruct2 + , SomeType $ BtSimple BtByteString + , SomeType $ BtSimple BtChar + , SomeType $ BtSimple BtBool + ] + where + _coveredAllCases :: BorshSimpleType typ -> () + _coveredAllCases BtU8 = () + _coveredAllCases BtU16 = () + _coveredAllCases BtU32 = () + _coveredAllCases BtU64 = () + _coveredAllCases BtU128 = () + _coveredAllCases BtI8 = () + _coveredAllCases BtI16 = () + _coveredAllCases BtI32 = () + _coveredAllCases BtI64 = () + _coveredAllCases BtI128 = () + _coveredAllCases BtF32 = () + _coveredAllCases BtF64 = () + _coveredAllCases BtUnit = () + _coveredAllCases BtText = () + _coveredAllCases BtSimpleList = () + _coveredAllCases BtSimpleStruct1 = () + _coveredAllCases BtSimpleStruct2 = () + _coveredAllCases BtByteString = () + _coveredAllCases BtChar = () + _coveredAllCases BtBool = () + +-- | Generate arbitrary type +-- +-- We have to be careful here: we are generating a recursive structure, and so +-- are susceptible to . +-- We need to keep track of the number of elements we want to generate. +arbitraryType :: Gen SomeBorshType +arbitraryType = sized go + where + go :: Int -> Gen SomeBorshType + go sz + | sz <= 0 = arbitrarySimpleType + | otherwise = oneof [ + arbitrarySimpleType + + -- Composite + + , (\(SomeLength n) (SomeType t) -> SomeType (BtArray n t)) + <$> arbitrary + <*> go (sz - 1) + + , (\(SomeType t) -> SomeType (BtVec t)) + <$> go (sz - 1) + + , (\(SomeType t) -> SomeType (BtOption t)) + <$> go (sz - 1) + + , (\(SomeType t) -> SomeType (BtHashSet t)) + <$> go (sz - 1) + + , (\(SomeType k) (SomeType t) -> SomeType (BtHashMap k t)) + <$> go (sz `div` 2) + <*> go (sz `div` 2) + + , (\(SomeBorshNP xs) -> + case allTestingConstraints xs of + Dict -> SomeType (BtStruct xs) + ) + <$> generateSomeNP sz + + , (\(SomeBorshPOP xss) -> + case all2TestingConstraints xss of + Dict -> SomeType (BtEnum xss) + ) + <$> generateSomePOP sz + + -- Example user-defined types + + , (\(SomeType t) -> SomeType (BtBTree t)) <$> go (sz - 1) + + , (\(SomeType t) -> SomeType (BtNTree t)) <$> go (sz - 1) + + , (\(SomeType t) -> SomeType (BtPolyStruct t)) + <$> go (sz - 1) + + -- Common Haskell types + + , (\(SomeType ta) (SomeType tb) -> SomeType (BtEither ta tb)) + <$> go (sz `div` 2) + <*> go (sz `div` 2) + + ] + + _coveredAllCases :: BorshType typ -> () + _coveredAllCases BtSimple{} = () + _coveredAllCases BtArray{} = () + _coveredAllCases BtVec{} = () + _coveredAllCases BtOption{} = () + _coveredAllCases BtHashSet{} = () + _coveredAllCases BtHashMap{} = () + _coveredAllCases BtStruct{} = () + _coveredAllCases BtEnum{} = () + _coveredAllCases BtBTree{} = () + _coveredAllCases BtNTree{} = () + _coveredAllCases BtPolyStruct{} = () + _coveredAllCases BtEither{} = () + +instance Arbitrary SomeBorshType where + arbitrary = arbitraryType + shrink (SomeType typ) = [SomeType typ' | SomeShrunk typ' _ <- shrinkType typ] + +{------------------------------------------------------------------------------- + Values of those types +-------------------------------------------------------------------------------} + +data SomeBorshValue where + SomeValue :: CanTest a => BorshType a -> a -> SomeBorshValue + +deriving instance Show SomeBorshValue + +-- | Generate arbitrary value +-- +-- We have to be careful here: we are generating a recursive structure, and so +-- are susceptible to . +-- We need to keep track of the number of elements we want to generate. +arbitraryValue :: BorshType a -> Gen a +arbitraryValue = \t -> sized $ \sz -> + go True sz t + where + goSimple :: Bool -> BorshSimpleType a -> Gen a + goSimple topLevel = \case + BtU8 -> arbitrary + BtU16 -> arbitrary + BtU32 -> arbitrary + BtU64 -> arbitrary + BtU128 -> arbitrary + BtI8 -> arbitrary + BtI16 -> arbitrary + BtI32 -> arbitrary + BtI64 -> arbitrary + BtI128 -> arbitrary + BtF32 -> arbitrary + BtF64 -> arbitrary + BtUnit -> arbitrary + BtText -> sized $ \sz -> do + numChars <- choose (0, sz) + Text.pack <$> replicateM numChars arbitrary + + BtSimpleList -> + if topLevel then + arbitraryLargeSimpleList + else sized $ \sz -> do + n <- choose (0, sz) + arbitrarySimpleListOfSize n + + BtSimpleStruct1 -> + Struct1 + <$> goSimple False BtU8 + <*> goSimple False BtUnit + <*> goSimple False BtU64 + + BtSimpleStruct2 -> + Struct2 + <$> goSimple False BtUnit + <*> goSimple False BtSimpleStruct1 + <*> goSimple False BtU16 + + BtByteString -> arbitrary + BtChar -> arbitrary + BtBool -> arbitrary + + go :: Bool -> Int -> BorshType a -> Gen a + go topLevel sz | sz < 0 = go topLevel 0 + go topLevel sz = \case + -- Non-composite + + BtSimple t -> goSimple topLevel t + + -- Composite + + BtArray tn t -> + fmap FSA.fromList $ + replicateM n $ go False (sz `div` (n + 1)) t + where + n :: Int + n = fromIntegral $ natVal tn + + BtVec t -> do + n <- choose (0, sz) + replicateM n $ go False (sz `div` (n + 1)) t + + BtOption t -> oneof [ + return Nothing + , Just <$> go False (sz - 1) t + ] + + BtHashSet t -> Set.fromList <$> do + n <- choose (0, sz) + replicateM n $ go False (sz `div` (n + 1)) t + + BtHashMap k t-> Map.fromList <$> do + n <- choose (0, sz) + replicateM n $ (,) + <$> go False (sz `div` (n + 1) `div` 2) k + <*> go False (sz `div` (n + 1) `div` 2) t + + BtStruct ts -> + case allTestingConstraints ts of + Dict -> goNP ts sz + + BtEnum tss -> + case all2TestingConstraints tss of + Dict -> goSOP tss sz + + -- Example user-defined types + + BtBTree t -> do + n <- choose (0, sz) + xs <- replicateM n $ go False (sz `div` (n + 1)) t + arbitraryBTreeWithElems xs + + BtNTree t -> do + n <- choose (0, sz) + xs <- replicateM n $ go False (sz `div` (n + 1)) t + arbitraryNTreeWithElems xs + + BtPolyStruct t -> + Poly + <$> go False (sz `div` 3) t + <*> go False (sz `div` 3) t + <*> go False (sz `div` 3) t + + BtEither ta tb -> oneof [ + Left <$> go False (sz `div` 2) ta + , Right <$> go False (sz `div` 2) tb + ] + + -- NP and SOP + + goNP :: SListI xs => NP BorshType xs -> Int -> Gen (NP I xs) + goNP ts sz = + arbitraryNP $ hmap (go False (sz `div` (numArgs + 1))) ts + where + numArgs :: Int + numArgs = lengthNP ts + + goSOP :: forall xs xss. + All SListI (xs ': xss) + => POP BorshType (xs : xss) + -> Int + -> Gen (SOP I (xs : xss)) + goSOP tss sz = + arbitrarySOP $ hmap (go False (sz `div` (maxNumArgs + 1))) tss + where + -- We conservatively divide by the number of arguments of the + -- constructor with the most arguments + maxNumArgs :: Int + maxNumArgs = + maximum . hcollapse $ + hcmap (Proxy @SListI) (K . lengthNP) (unPOP tss) + +instance Arbitrary SomeBorshValue where + arbitrary = do + SomeType typ <- arbitrary + val <- arbitraryValue typ + return $ SomeValue typ val + + shrink (SomeValue typ val) = concat [ + -- Shrink the type + [ SomeValue typ' val' + | SomeShrunk typ' (ShrinkFun f) <- shrinkType typ + , val' <- f val + ] + + -- Shrink the value + , [ SomeValue typ val' + | val' <- shrink val + ] + ] + +{------------------------------------------------------------------------------- + Reasoning +-------------------------------------------------------------------------------} + +dictBorshSizeSum :: forall xss proxy. + All2 CanTest xss + => proxy xss + -> Dict BorshSizeSum xss +dictBorshSizeSum _ = + case all2TestingConstraints (Proxy @xss) of + Dict -> aux shape + where + aux :: All2 BorshSize xss => Shape xss -> Dict BorshSizeSum xss + aux ShapeNil = Dict + aux (ShapeCons ShapeNil) = Dict + aux (ShapeCons (ShapeCons _)) = Dict + +allTestingConstraints :: forall proxy xs. + All CanTest xs + => proxy xs + -> Dict ( + All (Compose Show I) + `And` All (Compose Show BorshType) + `And` All (Compose Show FieldInfo) + `And` All (Compose Eq I) + `And` All (Compose Ord I) + `And` All Arbitrary + `And` All BorshSize + `And` All ToBorsh + `And` All FromBorsh + ) xs +allTestingConstraints _ = transformAllConstraints $ unAll_NP dict + where dict = Dict :: Dict (All CanTest) xs + +transformAllConstraints :: + All CanTest xs + => NP (Dict CanTest) xs + -> Dict ( + All (Compose Show I) + `And` All (Compose Show BorshType) + `And` All (Compose Show FieldInfo) + `And` All (Compose Eq I) + `And` All (Compose Ord I) + `And` All Arbitrary + `And` All BorshSize + `And` All ToBorsh + `And` All FromBorsh + ) xs +transformAllConstraints Nil = Dict +transformAllConstraints (x :* xs) = + case (x, transformAllConstraints xs) of + (Dict, Dict) -> Dict + +all2TestingConstraints :: forall proxy xss. + All2 CanTest xss + => proxy xss + -> Dict ( + All (Compose Eq (NP I)) + `And` All (Compose Ord (NP I)) + `And` All (Compose Show (NP I)) + `And` All2 (Compose Show I) + `And` All2 (Compose Eq I) + `And` All2 (Compose Ord I) + `And` All2 Arbitrary + `And` All SListI + `And` All2 BorshSize + `And` All2 ToBorsh + `And` All2 FromBorsh + `And` All (Compose Show (NP BorshType)) + ) xss +all2TestingConstraints _ = transformAll2Constraints $ unAll_POP dict + where dict = Dict :: Dict (All2 CanTest) xss + +transformAll2Constraints :: + All2 CanTest xss + => POP (Dict CanTest) xss + -> Dict ( + All (Compose Eq (NP I)) + `And` All (Compose Ord (NP I)) + `And` All (Compose Show (NP I)) + `And` All2 (Compose Show I) + `And` All2 (Compose Eq I) + `And` All2 (Compose Ord I) + `And` All2 Arbitrary + `And` All SListI + `And` All2 BorshSize + `And` All2 ToBorsh + `And` All2 FromBorsh + `And` All (Compose Show (NP BorshType)) + ) xss +transformAll2Constraints (POP Nil) = Dict +transformAll2Constraints (POP (x :* xs)) = + case (transformAllConstraints x, transformAll2Constraints (POP xs)) of + (Dict, Dict) -> Dict + diff --git a/test/Test/Codec/Borsh/Util/SOP.hs b/test/Test/Codec/Borsh/Util/SOP.hs new file mode 100644 --- /dev/null +++ b/test/Test/Codec/Borsh/Util/SOP.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE PatternSynonyms #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Codec.Borsh.Util.SOP ( + -- * Mapping + mapHeadNP + , mapTailNP + , mapHeadSOP + , mapTailSOP + -- * Misc + , lengthNP + -- * Generation + , arbitraryNP + , arbitrarySOP + ) where + +import Data.SOP +import Test.QuickCheck hiding (pattern Fn) +import Optics.Core + +import Test.Codec.Borsh.Util.QuickCheck + +{------------------------------------------------------------------------------- + Mapping +-------------------------------------------------------------------------------} + +mapHeadNP :: + Functor m + => (f x -> m (f y)) + -> NP f (x ': xs) -> m (NP f (y ': xs)) +mapHeadNP f (x :* xs) = fmap (:* xs) (f x) + +mapTailNP :: + Functor m + => (NP f xs -> m (NP f ys)) + -> NP f (z : xs) -> m (NP f (z : ys)) +mapTailNP f (z :* xs) = fmap (z :*) (f xs) + +mapHeadSOP :: + Applicative m + => (NP f xs -> m (NP f ys)) + -> SOP f (xs ': xss) -> m (SOP f (ys ': xss)) +mapHeadSOP f (SOP (Z x)) = SOP . Z <$> f x +mapHeadSOP _ (SOP (S s)) = pure $ SOP (S s) + +mapTailSOP :: + Applicative m + => (SOP f xss -> m (SOP f yss)) + -> SOP f (zs : xss) -> m (SOP f (zs : yss)) +mapTailSOP _ (SOP (Z x)) = pure $ SOP (Z x) +mapTailSOP f (SOP (S s)) = SOP . S . unSOP <$> f (SOP s) + +{------------------------------------------------------------------------------- + Misc +-------------------------------------------------------------------------------} + +lengthNP :: forall f xs. SListI xs => NP f xs -> Int +lengthNP _ = lengthSList (Proxy @xs) + +{------------------------------------------------------------------------------- + Lenses +-------------------------------------------------------------------------------} + +newtype LensNP xs a = LensNP (Lens' (NP I xs) a) + +lensHeadNP :: LensNP (x : xs) x +lensHeadNP = LensNP $ + lens + (unI . hd) + (\(_ :* xs) x -> I x :* xs) + +shiftLensNP :: LensNP xs a -> LensNP (x : xs) a +shiftLensNP (LensNP l) = LensNP $ + lens + (view l . tl) + (\(x :* xs) a -> x :* set l a xs) + +lensesNP :: forall xs. SListI xs => NP (LensNP xs) xs +lensesNP = + case sList :: SList xs of + SNil -> Nil + SCons -> lensHeadNP :* hmap shiftLensNP lensesNP + +{------------------------------------------------------------------------------- + Compositional generation +-------------------------------------------------------------------------------} + +arbitraryNP :: SListI xs => NP Gen xs -> Gen (NP I xs) +arbitraryNP = hsequence + +-- | Auxiliary to 'arbitrarySOP' +-- +-- Post-condition: the result list will have as many entries as the POP. +arbitrarySOP' :: forall xss. All SListI xss => POP Gen xss -> [Gen (SOP I xss)] +arbitrarySOP' = + hcollapse + . hczipWith + (Proxy @SListI) (\(Fn inj) -> K . aux (SOP . unK . inj) ) + (injections @xss @(NP I)) + . unPOP + where + aux :: SListI xs => (NP I xs -> SOP I xss) -> NP Gen xs -> Gen (SOP I xss) + aux inj = fmap inj . arbitraryNP + +-- | Generate arbitrary SOP +-- +-- The restriction to non-empty SOPs ensures the call to 'oneof' will not fail. +arbitrarySOP :: + All SListI (xs ': xss) + => POP Gen (xs ': xss) -> Gen (SOP I (xs ': xss)) +arbitrarySOP = oneof . arbitrarySOP' + +{------------------------------------------------------------------------------- + Compositional shrinking +-------------------------------------------------------------------------------} + +shrinkNP :: forall xs. SListI xs => NP Shrinker xs -> Shrinker (NP I xs) +shrinkNP = + mconcat + . hcollapse + . hzipWith (\(LensNP l) (Shrinker f) -> K $ Shrinker $ aux l f) lensesNP + where + aux :: Lens' (NP I xs) a -> (a -> [a]) -> NP I xs -> [NP I xs] + aux l f xs = [ set l a' xs | a' <- f (view l xs) ] + +shrinkSOP :: forall xss. + All SListI xss + => POP Shrinker xss -> Shrinker (SOP I xss) +shrinkSOP = \(POP sss) -> Shrinker $ \(SOP xss) -> + hcollapse + $ hczipWith3 + (Proxy @SListI) + (\ss (Fn inj) xs -> K $ aux (shrinkNP ss) (SOP . unK . inj) xs) + sss + (injections @xss @(NP I)) + xss + where + aux :: Shrinker (NP I a) -> (NP I a -> SOP I xss) -> NP I a -> [SOP I xss] + aux (Shrinker f) inj = map inj . f + +{------------------------------------------------------------------------------- + Arbitrary instances +-------------------------------------------------------------------------------} + +instance All Arbitrary xs => Arbitrary (NP I xs) where + arbitrary = arbitraryNP $ hcpure (Proxy @Arbitrary) arbitrary + shrink = runShrinker $ shrinkNP $ hcpure (Proxy @Arbitrary) shrinker + +instance ( SListI (xs ': xss) + , All SListI xss + , All2 Arbitrary (xs ': xss) + ) => Arbitrary (SOP I (xs ': xss)) where + arbitrary = arbitrarySOP $ hcpure (Proxy @Arbitrary) arbitrary + shrink = runShrinker $ shrinkSOP $ hcpure (Proxy @Arbitrary) shrinker