packages feed

borsh (empty) → 0.1.0

raw patch · 30 files changed

+3873/−0 lines, 30 filesdep +QuickCheckdep +basedep +borsh

Dependencies added: QuickCheck, base, borsh, bytestring, containers, generics-sop, memory, optics-core, profunctors, quickcheck-instances, sop-core, tasty, tasty-quickcheck, text, vector, wide-word

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for borsh++## 0.1.0 -- 2022-11-11++* First released version
+ LICENSE view
@@ -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.
+ borsh.cabal view
@@ -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
+ src/Codec/Borsh.hs view
@@ -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(..))
+ src/Codec/Borsh/Class.hs view
@@ -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 <https://borsh.io/> 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
+ src/Codec/Borsh/Decoding.hs view
@@ -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"
+ src/Codec/Borsh/Encoding.hs view
@@ -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+
+ src/Codec/Borsh/Incremental.hs view
@@ -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
+ src/Codec/Borsh/Incremental/Decoder.hs view
@@ -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))
+ src/Codec/Borsh/Incremental/Located.hs view
@@ -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)
+ src/Codec/Borsh/Incremental/Monad.hs view
@@ -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+
+ src/Codec/Borsh/Internal/Util/BitwiseCast.hs view
@@ -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
+ src/Codec/Borsh/Internal/Util/ByteString.hs view
@@ -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
+ src/Codec/Borsh/Internal/Util/ByteSwap.hs view
@@ -0,0 +1,51 @@+-- | Swap between big-endian and little endian+--+-- This is adapted from the `memory` package. Once+-- <https://github.com/vincenthz/hs-memory/pull/97> 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
+ src/Codec/Borsh/Internal/Util/SOP.hs view
@@ -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)
+ src/Data/FixedSizeArray.hs view
@@ -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))+
+ src/Data/Int128.hs view
@@ -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)
+ src/Data/Word128.hs view
@@ -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)
+ test/Main.hs view
@@ -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+    ]
+ test/Test/Codec/Borsh/ExampleType/BTree.hs view
@@ -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+    ]+
+ test/Test/Codec/Borsh/ExampleType/NTree.hs view
@@ -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+    ]+
+ test/Test/Codec/Borsh/ExampleType/SimpleList.hs view
@@ -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])
+ test/Test/Codec/Borsh/ExampleType/SimpleStructs.hs view
@@ -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+
+ test/Test/Codec/Borsh/Roundtrip.hs view
@@ -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
+ test/Test/Codec/Borsh/Size.hs view
@@ -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++
+ test/Test/Codec/Borsh/Util/Length.hs view
@@ -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))+
+ test/Test/Codec/Borsh/Util/Orphans.hs view
@@ -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+
+ test/Test/Codec/Borsh/Util/QuickCheck.hs view
@@ -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+
+ test/Test/Codec/Borsh/Util/RandomType.hs view
@@ -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 _ = "<ShrinkFun>"++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 <https://en.wikipedia.org/wiki/St._Petersburg_paradox>.+-- 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 <https://en.wikipedia.org/wiki/St._Petersburg_paradox>.+-- 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+
+ test/Test/Codec/Borsh/Util/SOP.hs view
@@ -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