diff --git a/plutus-benchmark/common/PlutusBenchmark/Common.hs b/plutus-benchmark/common/PlutusBenchmark/Common.hs index b03aade8c09..67338f63a04 100644 --- a/plutus-benchmark/common/PlutusBenchmark/Common.hs +++ b/plutus-benchmark/common/PlutusBenchmark/Common.hs @@ -50,8 +50,8 @@ import Criterion.Main import Criterion.Types (Config (..)) import Data.ByteString qualified as BS import Data.SatInt (fromSatInt) -import Flat qualified import GHC.IO.Encoding (setLocaleEncoding) +import PlutusCore.Flat qualified as Flat import System.Directory import System.FilePath import System.IO diff --git a/plutus-benchmark/coop/exe/Main.hs b/plutus-benchmark/coop/exe/Main.hs index 3d92c6634e3..ecef1478414 100644 --- a/plutus-benchmark/coop/exe/Main.hs +++ b/plutus-benchmark/coop/exe/Main.hs @@ -13,7 +13,7 @@ import PlutusTx import Data.ByteString.Lazy qualified as BSL import Data.Foldable (traverse_) -import Flat (flat, unflat) +import PlutusCore.Flat (flat, unflat) import System.Directory (doesFileExist) import System.FilePath ((<.>), ()) diff --git a/plutus-benchmark/nofib/exe/Main.hs b/plutus-benchmark/nofib/exe/Main.hs index 77a417794e5..feb1099da4a 100644 --- a/plutus-benchmark/nofib/exe/Main.hs +++ b/plutus-benchmark/nofib/exe/Main.hs @@ -15,8 +15,8 @@ import Data.Char (isSpace) import Data.Foldable (traverse_) import Data.SatInt import Data.String (fromString) -import Flat qualified import Options.Applicative as Opt hiding (action) +import PlutusCore.Flat qualified as Flat import Prettyprinter (Doc, indent, line, vsep) import System.Exit (exitFailure) import System.IO diff --git a/plutus-benchmark/plutus-benchmark.cabal b/plutus-benchmark/plutus-benchmark.cabal index cb413bbd7d1..3d8f6e98646 100644 --- a/plutus-benchmark/plutus-benchmark.cabal +++ b/plutus-benchmark/plutus-benchmark.cabal @@ -93,8 +93,8 @@ library plutus-benchmark-common , deepseq , directory , filepath - , flat ^>=0.6 , plutus-core ^>=1.53 + , plutus-core:flat , plutus-ledger-api ^>=1.53 , plutus-tx:plutus-tx-testlib , tasty @@ -133,12 +133,12 @@ executable nofib-exe build-depends: , base >=4.9 && <5 , bytestring - , flat ^>=0.6 , lens , nofib-internal , optparse-applicative , plutus-benchmark-common , plutus-core ^>=1.53 + , plutus-core:flat , plutus-tx ^>=1.53 , prettyprinter , transformers @@ -289,10 +289,10 @@ library validation-internal , criterion >=1.5.9.0 , directory , filepath - , flat ^>=0.6 , optparse-applicative , plutus-benchmark-common , plutus-core ^>=1.53 + , plutus-core:flat benchmark validation import: lang, os-support @@ -317,9 +317,9 @@ test-suite validation-tests , bytestring , directory , filepath - , flat ^>=0.6 , plutus-benchmark-common , plutus-core ^>=1.53 + , plutus-core:flat , plutus-core:plutus-core-testlib , plutus-tx ^>=1.53 , plutus-tx:plutus-tx-testlib @@ -780,9 +780,9 @@ executable gen-coop-flat , coop , directory , filepath - , flat , plutus-benchmark-common , plutus-core + , plutus-core:flat , plutus-ledger-api , plutus-tx ^>=1.53 , plutus-tx:plutus-tx-testlib diff --git a/plutus-benchmark/validation/src/PlutusBenchmark/Validation/Common.hs b/plutus-benchmark/validation/src/PlutusBenchmark/Validation/Common.hs index 7e09b23bd0a..3a285f994ba 100644 --- a/plutus-benchmark/validation/src/PlutusBenchmark/Validation/Common.hs +++ b/plutus-benchmark/validation/src/PlutusBenchmark/Validation/Common.hs @@ -24,7 +24,7 @@ import Options.Applicative import Data.ByteString qualified as BS import Data.List (isPrefixOf) -import Flat +import PlutusCore.Flat import System.Directory (listDirectory) import System.FilePath diff --git a/plutus-benchmark/validation/test/Spec.hs b/plutus-benchmark/validation/test/Spec.hs index b7e6e3edc30..7de994900e8 100644 --- a/plutus-benchmark/validation/test/Spec.hs +++ b/plutus-benchmark/validation/test/Spec.hs @@ -14,7 +14,7 @@ import PlutusTx.Test qualified as Tx import UntypedPlutusCore qualified as UPLC import Data.ByteString qualified as BS -import Flat +import PlutusCore.Flat import System.Directory (listDirectory) import System.FilePath diff --git a/plutus-core/executables/plutus/AnyProgram/IO.hs b/plutus-core/executables/plutus/AnyProgram/IO.hs index 219784b7525..0519b22f238 100644 --- a/plutus-core/executables/plutus/AnyProgram/IO.hs +++ b/plutus-core/executables/plutus/AnyProgram/IO.hs @@ -23,7 +23,7 @@ import Data.ByteString.Lazy qualified as BSL import Data.Maybe import Data.Singletons.Decide import Data.Text.Encoding qualified as T -import Flat +import PlutusCore.Flat import Prettyprinter import Prettyprinter.Render.Text import System.IO diff --git a/plutus-core/executables/src/PlutusCore/Executable/AstIO.hs b/plutus-core/executables/src/PlutusCore/Executable/AstIO.hs index 8d038c9448c..c70677bc24c 100644 --- a/plutus-core/executables/src/PlutusCore/Executable/AstIO.hs +++ b/plutus-core/executables/src/PlutusCore/Executable/AstIO.hs @@ -32,7 +32,7 @@ import UntypedPlutusCore qualified as UPLC import Control.Lens (traverseOf) import Data.ByteString.Lazy qualified as BSL -import Flat (Flat, flat, unflat) +import PlutusCore.Flat (Flat, flat, unflat) type UplcProgDB ann = UPLC.Program PLC.DeBruijn PLC.DefaultUni PLC.DefaultFun ann type UplcProgNDB ann = UPLC.Program PLC.NamedDeBruijn PLC.DefaultUni PLC.DefaultFun ann diff --git a/plutus-core/executables/src/PlutusCore/Executable/Common.hs b/plutus-core/executables/src/PlutusCore/Executable/Common.hs index 960fbe8844c..9b69f8d2705 100644 --- a/plutus-core/executables/src/PlutusCore/Executable/Common.hs +++ b/plutus-core/executables/src/PlutusCore/Executable/Common.hs @@ -80,8 +80,8 @@ import Data.Proxy (Proxy (..)) import Data.SatInt import Data.Text qualified as T import Data.Text.IO qualified as T -import Flat (Flat) import GHC.TypeLits (symbolVal) +import PlutusCore.Flat (Flat) import Prettyprinter ((<+>)) import Text.Megaparsec (errorBundlePretty) diff --git a/plutus-core/flat/LICENSE b/plutus-core/flat/LICENSE new file mode 100644 index 00000000000..19a55b29e19 --- /dev/null +++ b/plutus-core/flat/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, Pasqualino `Titto` Assini + +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 the copyright holder 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. \ No newline at end of file diff --git a/plutus-core/flat/README.md b/plutus-core/flat/README.md new file mode 100644 index 00000000000..acf40d5681e --- /dev/null +++ b/plutus-core/flat/README.md @@ -0,0 +1,7 @@ +# `flat` (vendored) + +This is a vendored copy of the `flat` Haskell library, included for use within the Plutus repository. + +It is not intended for standalone use or external distribution. Original source available at: https://github.com/Quid2/flat. + +Modifications (if any) from upstream should be documented below. diff --git a/plutus-core/flat/src/PlutusCore/Flat.hs b/plutus-core/flat/src/PlutusCore/Flat.hs new file mode 100644 index 00000000000..92872f9fdb8 --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat.hs @@ -0,0 +1,21 @@ +{-| +Haskell implementation of , a principled, portable and efficient binary data format. + +-} +module PlutusCore.Flat + ( module PlutusCore.Flat.Class + , module PlutusCore.Flat.Filler + , module X + , Decoded + , DecodeException(..) + ) +where + +import PlutusCore.Flat.AsBin as X +import PlutusCore.Flat.AsSize as X +import PlutusCore.Flat.Class +import PlutusCore.Flat.Decoder +import PlutusCore.Flat.Filler +import PlutusCore.Flat.Instances as X +import PlutusCore.Flat.Run as X +import PlutusCore.Flat.Types () diff --git a/plutus-core/flat/src/PlutusCore/Flat/AsBin.hs b/plutus-core/flat/src/PlutusCore/Flat/AsBin.hs new file mode 100644 index 00000000000..627464ccf6a --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/AsBin.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- | Wrapper type to decode a value to its flat serialisation. + +See <../test/Big.hs> for an example of use. + +See also 'Flat.Decoder.listTDecoder' and "Flat.AsSize" for other ways to handle large decoded values. + +In 0.5.X this type was called @Repr@. + +@since 0.6 +-} +module PlutusCore.Flat.AsBin(AsBin,unbin) where + +import Data.ByteString qualified as B +import Foreign (plusPtr) +import PlutusCore.Flat.Bits (bits, fromBools, toBools) +import PlutusCore.Flat.Class (Flat (..)) +import PlutusCore.Flat.Decoder.Prim (binOf) +import PlutusCore.Flat.Decoder.Types (Get (Get, runGet), GetResult (GetResult), + S (S, currPtr, usedBits)) +import PlutusCore.Flat.Run (unflatRawWithOffset) +import Text.PrettyPrint.HughesPJClass (Doc, Pretty (pPrint), prettyShow, text) + +-- $setup +-- >>> :set -XScopedTypeVariables +-- >>> import PlutusCore.Flat.Instances.Base +-- >>> import PlutusCore.Flat.Instances.Text +-- >>> import PlutusCore.Flat.Decoder.Types +-- >>> import PlutusCore.Flat.Types +-- >>> import PlutusCore.Flat.Run +-- >>> import Data.Word +-- >>> import qualified Data.Text as T +-- >>> import Text.PrettyPrint.HughesPJClass + +{- | + +When the flat serialisation of a value takes a lot less memory than the value itself, it can be convenient to keep the value in its encoded representation and decode it on demand. + +To do so, just decode a value `a` as a `AsBin a`. + +Examples: + +Encode a list of Ints and then decode it to a list of AsBin Int: + +>>> unflat (flat [1::Int .. 3]) :: Decoded ([AsBin Int]) +Right [AsBin {repr = "\129A", offsetBits = 1},AsBin {repr = "A ", offsetBits = 2},AsBin {repr = " \193", offsetBits = 3}] + +To decode an `AsBin a` to an `a`, use `unbin`: + +>>> unbin <$> (unflat (flat 'a') :: Decoded (AsBin Char)) +Right 'a' + +Keep the values of a list of Ints encoded and decode just one on demand: + +>>> let Right l :: Decoded [AsBin Int] = unflat (flat [1..5]) in unbin (l !! 2) +3 + +Show exactly how values are encoded: + +>>> let Right t :: Decoded (AsBin Bool,AsBin Word8,AsBin Bool) = unflat (flat (False,3:: Word64,True)) in prettyShow t +"(0, _0000001 1, _1)" + +Ten bits in total spread over two bytes: + +@ +0 +_0000001 1 + _1 += +00000001 11 +@ + +Tests: + +>>> unflat (flat ()) :: Decoded (AsBin ()) +Right (AsBin {repr = "", offsetBits = 0}) + +>>> unflat (flat (False,True)) :: Decoded (Bool,AsBin Bool) +Right (False,AsBin {repr = "A", offsetBits = 1}) + +>>> unflat (flat (False,False,255 :: Word8)) :: Decoded (Bool,Bool,AsBin Word8) +Right (False,False,AsBin {repr = "?\193", offsetBits = 2}) + +>>> let Right (b0,b1,rw,b3) :: Decoded (Bool,Bool,AsBin Word8,Bool) = unflat (flat (False,False,255 :: Word8,True)) in (b0,b1,unbin rw,b3) +(False,False,255,True) +-} + +data AsBin a = AsBin { + repr :: B.ByteString -- ^ Flat encoding of the value (encoding starts after offset bits in the first byte and ends in an unspecified position in the last byte) + ,offsetBits :: Int -- ^ First byte offset: number of unused most significant bits in the first byte + } deriving Show + +instance Flat a => Pretty (AsBin a) where + pPrint :: AsBin a -> Doc + pPrint r = let n = replicate (offsetBits r) in text $ n '_' ++ (drop (offsetBits r) . prettyShow . fromBools . (n False ++) . toBools . bits $ unbin r) + +-- | Decode a value +unbin :: Flat a => AsBin a -> a +unbin a = + case unflatRawWithOffset dec (repr a) (offsetBits a) of + Right a -> a + Left e -> error (show e) -- impossible, as it is a valid encoding + where + dec = Get $ \end s -> do + GetResult s' a <- runGet decode end s + let s'' = S (currPtr s' `plusPtr` if usedBits s' == 0 then 0 else 1) 0 + return $ GetResult s'' a + +instance Flat a => Flat (AsBin a) where + size = error "unused" + + encode = error "unused" + + decode :: Flat a => Get (AsBin a) + decode = uncurry AsBin <$> binOf (decode :: Get a) diff --git a/plutus-core/flat/src/PlutusCore/Flat/AsSize.hs b/plutus-core/flat/src/PlutusCore/Flat/AsSize.hs new file mode 100644 index 00000000000..79403b5feeb --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/AsSize.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- | +Wrapper type to decode a value to its size in bits. + +See also "Flat.AsBin". + +In 0.5.X this type was called @SizeOf@. + +@since 0.6 +-} +module PlutusCore.Flat.AsSize(AsSize(..)) where + +import PlutusCore.Flat.Class (Flat (..)) +import PlutusCore.Flat.Decoder.Prim (sizeOf) +import PlutusCore.Flat.Decoder.Types (Get) +import PlutusCore.Flat.Types (NumBits) + +-- $setup +-- >>> :set -XScopedTypeVariables +-- >>> import PlutusCore.Flat.Instances.Base +-- >>> import PlutusCore.Flat.Instances.Text +-- >>> import PlutusCore.Flat.Decoder.Types +-- >>> import PlutusCore.Flat.Types +-- >>> import PlutusCore.Flat.Run +-- >>> import Data.Word +-- >>> import qualified Data.Text as T + +{- | +Useful to skip unnecessary values and to check encoding sizes. + +Examples: + +Ignore the second and fourth component of a tuple: + +>>> let v = flat ('a',"abc",'z',True) in unflat v :: Decoded (Char,AsSize String,Char,AsSize Bool) +Right ('a',AsSize 28,'z',AsSize 1) + +Notice the variable size encoding of Words: + +>>> unflat (flat (1::Word16,1::Word64)) :: Decoded (AsSize Word16,AsSize Word64) +Right (AsSize 8,AsSize 8) + +Text: + +>>> unflat (flat (T.pack "",T.pack "a",T.pack "主",UTF8Text $ T.pack "主",UTF16Text $ T.pack "主",UTF16Text $ T.pack "a")) :: Decoded (AsSize T.Text,AsSize T.Text,AsSize T.Text,AsSize UTF8Text,AsSize UTF16Text,AsSize UTF16Text) +Right (AsSize 16,AsSize 32,AsSize 48,AsSize 48,AsSize 40,AsSize 40) + +Various encodings: + +>>> unflat (flat (False,[T.pack "",T.pack "a",T.pack "主"],'a')) :: Decoded (AsSize Bool,AsSize [T.Text],AsSize Char) +Right (AsSize 1,AsSize 96,AsSize 8) +-} +newtype AsSize a = AsSize NumBits deriving (Eq,Ord,Show) + +instance Flat a => Flat (AsSize a) where + size :: Flat a => AsSize a -> NumBits -> NumBits + size = error "unused" + + encode = error "unused" + + decode :: Flat a => Get (AsSize a) + decode = AsSize <$> sizeOf (decode :: Get a) diff --git a/plutus-core/flat/src/PlutusCore/Flat/Bits.hs b/plutus-core/flat/src/PlutusCore/Flat/Bits.hs new file mode 100644 index 00000000000..acb003c9889 --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Bits.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + + +-- |Utilities to represent and display bit sequences +module PlutusCore.Flat.Bits ( + Bits, + toBools, + fromBools, + bits, + paddedBits, + asBytes, + asBits, + takeBits, + takeAllBits, +) where +-- TODO: AsBits Class? + +import Data.Bits (FiniteBits (finiteBitSize), testBit) +import Data.ByteString qualified as B +import Data.Vector.Unboxed qualified as V +import Data.Word (Word8) +import PlutusCore.Flat.Class (Flat) +import PlutusCore.Flat.Decoder (Decoded) +import PlutusCore.Flat.Filler (PostAligned (PostAligned), fillerLength) +import PlutusCore.Flat.Run (flat, unflatRaw) +import Text.PrettyPrint.HughesPJClass (Doc, Pretty (pPrint), hsep, text) + +-- |A sequence of bits +type Bits = V.Vector Bool + +toBools :: Bits -> [Bool] +toBools = V.toList + +fromBools :: [Bool] -> Bits +fromBools = V.fromList + +{- $setup +>>> import Data.Word +>>> import PlutusCore.Flat.Instances.Base +>>> import PlutusCore.Flat.Instances.Test(tst,prettyShow) +-} + +{- |The sequence of bits corresponding to the serialization of the passed value (without any final byte padding) + +>>> bits True +[True] +-} +bits :: forall a. Flat a => a -> Bits +bits v = + let lbs = flat v + in case unflatRaw lbs :: Decoded (PostAligned a) of + Right (PostAligned _ f) -> takeBits (8 * B.length lbs - fillerLength f) lbs + Left _ -> error "incorrect coding or decoding, please inform the maintainer of this package" + +{- |The sequence of bits corresponding to the byte-padded serialization of the passed value + +>>> paddedBits True +[True,False,False,False,False,False,False,True] +-} +paddedBits :: forall a. Flat a => a -> Bits +paddedBits v = let lbs = flat v in takeAllBits lbs + +takeAllBits :: B.ByteString -> Bits +takeAllBits lbs= takeBits (8 * B.length lbs) lbs + +takeBits :: Int -> B.ByteString -> Bits +takeBits numBits lbs = + V.generate + (fromIntegral numBits) + ( \n -> + let (bb, b) = n `divMod` 8 + in testBit (B.index lbs (fromIntegral bb)) (7 - b) + ) + +{- |Convert an integral value to its equivalent bit representation + +>>> asBits (5::Word8) +[False,False,False,False,False,True,False,True] +-} +asBits :: FiniteBits a => a -> Bits +asBits w = let s = finiteBitSize w in V.generate s (testBit w . (s - 1 -)) + +{- |Convert a sequence of bits to the corresponding list of bytes + +>>> asBytes $ asBits (256+3::Word16) +[1,3] +-} +asBytes :: Bits -> [Word8] +asBytes = map byteVal . bytes . V.toList + +-- |Convert to the corresponding value (most significant bit first) +byteVal :: [Bool] -> Word8 +byteVal = sum . zipWith (\ e b -> (if b then e else 0)) ([2 ^ n | n <- [7 :: Int, 6 .. 0]]) + +-- |Split a list in groups of 8 elements or less +bytes :: [t] -> [[t]] +bytes [] = [] +bytes l = let (w, r) = splitAt 8 l in w : bytes r + +{- | +>>> prettyShow $ asBits (256+3::Word16) +"00000001 00000011" +-} +instance Pretty Bits where + pPrint = hsep . map prettyBits . bytes . V.toList + +prettyBits :: Foldable t => t Bool -> Doc +prettyBits l = + text . take (length l) . concatMap (\b -> if b then "1" else "0") $ l diff --git a/plutus-core/flat/src/PlutusCore/Flat/Class.hs b/plutus-core/flat/src/PlutusCore/Flat/Class.hs new file mode 100644 index 00000000000..44a32ab61ab --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Class.hs @@ -0,0 +1,483 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- |Generics-based generation of Flat instances +module PlutusCore.Flat.Class + ( + -- * The Flat class + Flat(..) + , getSize + , module GHC.Generics + , GFlatEncode,GFlatDecode,GFlatSize + ) +where + +import Data.Bits (Bits (unsafeShiftL, (.|.))) +import Data.Word (Word16) +import GHC.Generics +import GHC.TypeLits (Nat, type (+), type (<=)) +import PlutusCore.Flat.Decoder.Prim (ConsState (..), consBits, consBool, consClose, consOpen, dBool) +import PlutusCore.Flat.Decoder.Types (Get) +import PlutusCore.Flat.Encoder (Encoding, NumBits, eBits16, mempty) +import Prelude hiding (mempty) + +#if MIN_VERSION_base(4,9,0) +import Data.Kind +#endif + +#if ! MIN_VERSION_base(4,11,0) +import Data.Semigroup ((<>)) +#endif + + +-- External and Internal inlining +#define INL 2 +-- Internal inlining +-- #define INL 1 +-- No inlining +-- #define INL 0 + +#if INL == 1 +import GHC.Exts (inline) +#endif + +-- import Data.Proxy + +-- |Calculate the maximum size in bits of the serialisation of the value +getSize :: Flat a => a -> NumBits +getSize a = size a 0 + +{-| Class of types that can be encoded/decoded + +Encoding a value involves three steps: + +* calculate the maximum size of the serialised value, using `size` + +* preallocate a buffer of the required size + +* encode the value in the buffer, using `encode` +-} +class Flat a where + -- |Return the encoding corrresponding to the value + encode :: a -> Encoding + default encode :: (Generic a, GFlatEncode (Rep a)) => a -> Encoding + encode = gencode . from + + -- |Decode a value + decode :: Get a + default decode :: (Generic a, GFlatDecode (Rep a)) => Get a + decode = to `fmap` gget + + -- |Add maximum size in bits of the value to the total count + -- + -- Used to calculated maximum buffer size before encoding + size :: a -> NumBits -> NumBits + default size :: (Generic a, GFlatSize (Rep a)) => a -> NumBits -> NumBits + size !x !n = gsize n $ from x + +#if INL>=2 + -- With these, generated code is optimised for specific data types (e.g.: Tree Bool will fuse the code of Tree and Bool) + -- This can improve performance very significantly (up to 10X) but also increases compilation times. + {-# INLINE size #-} + {-# INLINE decode #-} + {-# INLINE encode #-} +#elif INL == 1 +#elif INL == 0 + {-# NOINLINE size #-} + {-# NOINLINE decode #-} + {-# NOINLINE encode #-} +#endif + +-- |Generic Encoder +class GFlatEncode f where gencode :: f a -> Encoding + +instance {-# OVERLAPPABLE #-} GFlatEncode f => GFlatEncode (M1 i c f) where + gencode = gencode . unM1 + {-# INLINE gencode #-} + + -- Special case, single constructor datatype +instance {-# OVERLAPPING #-} GFlatEncode a => GFlatEncode (D1 i (C1 c a)) where + gencode = gencode . unM1 . unM1 + {-# INLINE gencode #-} + + -- Type without constructors +instance GFlatEncode V1 where + gencode = unused + {-# INLINE gencode #-} + + -- Constructor without arguments +instance GFlatEncode U1 where + gencode U1 = mempty + {-# INLINE gencode #-} + +instance Flat a => GFlatEncode (K1 i a) where + {-# INLINE gencode #-} +#if INL == 1 + gencode x = inline encode (unK1 x) +#else + gencode = encode . unK1 +#endif + +instance (GFlatEncode a, GFlatEncode b) => GFlatEncode (a :*: b) where + --gencode (!x :*: (!y)) = gencode x <++> gencode y + gencode (x :*: y) = gencode x <> gencode y + {-# INLINE gencode #-} + +instance (NumConstructors (a :+: b) <= 512,GFlatEncodeSum (a :+: b)) => GFlatEncode (a :+: b) where +-- instance (GFlatEncodeSum (a :+: b)) => GFlatEncode (a :+: b) where + gencode = gencodeSum 0 0 + {-# INLINE gencode #-} + +-- Constructor Encoding +class GFlatEncodeSum f where + gencodeSum :: Word16 -> NumBits -> f a -> Encoding + +instance (GFlatEncodeSum a, GFlatEncodeSum b) => GFlatEncodeSum (a :+: b) where + gencodeSum !code !numBits s = case s of + L1 !x -> gencodeSum (code `unsafeShiftL` 1) (numBits+1) x + R1 !x -> gencodeSum ((code `unsafeShiftL` 1) .|. 1) (numBits+1) x + {-# INLINE gencodeSum #-} + +instance GFlatEncode a => GFlatEncodeSum (C1 c a) where + gencodeSum !code !numBits x = eBits16 numBits code <> gencode x + {-# INLINE gencodeSum #-} + +-- |Generic Decoding +class GFlatDecode f where + gget :: Get (f t) + +-- |Metadata (constructor name, etc) +instance GFlatDecode a => GFlatDecode (M1 i c a) where + gget = M1 <$> gget + {-# INLINE gget #-} + +-- |Type without constructors +instance GFlatDecode V1 where + gget = unused + {-# INLINE gget #-} + +-- |Constructor without arguments +instance GFlatDecode U1 where + gget = pure U1 + {-# INLINE gget #-} + +-- |Product: constructor with parameters +instance (GFlatDecode a, GFlatDecode b) => GFlatDecode (a :*: b) where + gget = (:*:) <$> gget <*> gget + {-# INLINE gget #-} + +-- |Constants, additional parameters, and rank-1 recursion +instance Flat a => GFlatDecode (K1 i a) where +#if INL == 1 + gget = K1 <$> inline decode +#else + gget = K1 <$> decode +#endif + {-# INLINE gget #-} + + +-- Different valid decoding setups +-- #define DEC_BOOLG +-- #define DEC_BOOL + +-- #define DEC_BOOLG +-- #define DEC_BOOL +-- #define DEC_BOOL48 + +-- #define DEC_CONS +-- #define DEC_BOOLC +-- #define DEC_BOOL + +-- #define DEC_CONS +-- #define DEC_BOOLC +-- #define DEC_BOOL +-- #define DEC_BOOL48 + +-- #define DEC_CONS + +-- #define DEC_CONS +-- #define DEC_CONS48 + +#define DEC_CONS +#define DEC_CONS48 +#define DEC_BOOLC +#define DEC_BOOL + +#ifdef DEC_BOOLG +instance (GFlatDecode a, GFlatDecode b) => GFlatDecode (a :+: b) +#endif + +#ifdef DEC_BOOLC +-- Special case for data types with two constructors +instance {-# OVERLAPPING #-} (GFlatDecode a,GFlatDecode b) => GFlatDecode (C1 m1 a :+: C1 m2 b) +#endif + +#ifdef DEC_BOOL + where + gget = do + -- error "DECODE2_C2" + !tag <- dBool + !r <- if tag then R1 <$> gget else L1 <$> gget + return r + {-# INLINE gget #-} +#endif + +#ifdef DEC_CONS +-- | Data types with up to 512 constructors +-- Uses a custom constructor decoding state +-- instance {-# OVERLAPPABLE #-} (GFlatDecodeSum (a :+: b),GFlatDecode a, GFlatDecode b) => GFlatDecode (a :+: b) where +instance {-# OVERLAPPABLE #-} (NumConstructors (a :+: b) <= 512, GFlatDecodeSum (a :+: b)) => GFlatDecode (a :+: b) where + gget = do + cs <- consOpen + getSum cs + {-# INLINE gget #-} + +-- |Constructor Decoder +class GFlatDecodeSum f where + getSum :: ConsState -> Get (f a) + +#ifdef DEC_CONS48 + +-- Decode constructors in groups of 2 or 3 bits +-- Significantly reduce instance compilation time and slightly improve execution times +instance {-# OVERLAPPING #-} (GFlatDecodeSum n1,GFlatDecodeSum n2,GFlatDecodeSum n3,GFlatDecodeSum n4) => GFlatDecodeSum ((n1 :+: n2) :+: (n3 :+: n4)) -- where -- getSum = undefined + where + getSum cs = do + -- error "DECODE4" + let (cs',tag) = consBits cs 2 + case tag of + 0 -> L1 . L1 <$> getSum cs' + 1 -> L1 . R1 <$> getSum cs' + 2 -> R1 . L1 <$> getSum cs' + _ -> R1 . R1 <$> getSum cs' + {-# INLINE getSum #-} + +instance {-# OVERLAPPING #-} (GFlatDecodeSum n1,GFlatDecodeSum n2,GFlatDecodeSum n3,GFlatDecodeSum n4,GFlatDecodeSum n5,GFlatDecodeSum n6,GFlatDecodeSum n7,GFlatDecodeSum n8) => GFlatDecodeSum (((n1 :+: n2) :+: (n3 :+: n4)) :+: ((n5 :+: n6) :+: (n7 :+: n8))) -- where -- getSum cs = undefined + where + getSum cs = do + --error "DECODE8" + let (cs',tag) = consBits cs 3 + case tag of + 0 -> L1 . L1 . L1 <$> getSum cs' + 1 -> L1 . L1 . R1 <$> getSum cs' + 2 -> L1 . R1 . L1 <$> getSum cs' + 3 -> L1 . R1 . R1 <$> getSum cs' + 4 -> R1 . L1 . L1 <$> getSum cs' + 5 -> R1 . L1 . R1 <$> getSum cs' + 6 -> R1 . R1 . L1 <$> getSum cs' + _ -> R1 . R1 . R1 <$> getSum cs' + {-# INLINE getSum #-} + +instance {-# OVERLAPPABLE #-} (GFlatDecodeSum a, GFlatDecodeSum b) => GFlatDecodeSum (a :+: b) where +#else +instance (GFlatDecodeSum a, GFlatDecodeSum b) => GFlatDecodeSum (a :+: b) where +#endif + + getSum cs = do + let (cs',tag) = consBool cs + if tag then R1 <$> getSum cs' else L1 <$> getSum cs' + {-# INLINE getSum #-} + + +instance GFlatDecode a => GFlatDecodeSum (C1 c a) where + getSum (ConsState _ usedBits) = consClose usedBits >> gget + {-# INLINE getSum #-} +#endif + +#ifdef DEC_BOOL48 +instance {-# OVERLAPPING #-} (GFlatDecode n1,GFlatDecode n2,GFlatDecode n3,GFlatDecode n4) => GFlatDecode ((n1 :+: n2) :+: (n3 :+: n4)) -- where -- gget = undefined + where + gget = do + -- error "DECODE4" + !tag <- dBEBits8 2 + case tag of + 0 -> L1 <$> L1 <$> gget + 1 -> L1 <$> R1 <$> gget + 2 -> R1 <$> L1 <$> gget + _ -> R1 <$> R1 <$> gget + {-# INLINE gget #-} + +instance {-# OVERLAPPING #-} (GFlatDecode n1,GFlatDecode n2,GFlatDecode n3,GFlatDecode n4,GFlatDecode n5,GFlatDecode n6,GFlatDecode n7,GFlatDecode n8) => GFlatDecode (((n1 :+: n2) :+: (n3 :+: n4)) :+: ((n5 :+: n6) :+: (n7 :+: n8))) -- where -- gget = undefined + where + gget = do + --error "DECODE8" + !tag <- dBEBits8 3 + case tag of + 0 -> L1 <$> L1 <$> L1 <$> gget + 1 -> L1 <$> L1 <$> R1 <$> gget + 2 -> L1 <$> R1 <$> L1 <$> gget + 3 -> L1 <$> R1 <$> R1 <$> gget + 4 -> R1 <$> L1 <$> L1 <$> gget + 5 -> R1 <$> L1 <$> R1 <$> gget + 6 -> R1 <$> R1 <$> L1 <$> gget + _ -> R1 <$> R1 <$> R1 <$> gget + {-# INLINE gget #-} +#endif + +-- |Calculate the number of bits required for the serialisation of a value +-- Implemented as a function that adds the maximum size to a running total +class GFlatSize f where gsize :: NumBits -> f a -> NumBits + +-- |Skip metadata +instance GFlatSize f => GFlatSize (M1 i c f) where + gsize !n = gsize n . unM1 + {-# INLINE gsize #-} + +-- |Type without constructors +instance GFlatSize V1 where + gsize !n _ = n + {-# INLINE gsize #-} + +-- |Constructor without arguments +instance GFlatSize U1 where + gsize !n _ = n + {-# INLINE gsize #-} + +-- |Skip metadata +instance Flat a => GFlatSize (K1 i a) where +#if INL == 1 + gsize !n x = inline size (unK1 x) n +#else + gsize !n x = size (unK1 x) n +#endif + {-# INLINE gsize #-} + +instance (GFlatSize a, GFlatSize b) => GFlatSize (a :*: b) where + gsize !n (x :*: y) = + let !n' = gsize n x + in gsize n' y + -- gsize (gsize n x) y + {-# INLINE gsize #-} + +-- Alternative 'gsize' implementations +#define SIZ_ADD +-- #define SIZ_NUM + +-- #define SIZ_MAX +-- #define SIZ_MAX_VAL +-- #define SIZ_MAX_PROX + +#ifdef SIZ_ADD +instance (GFlatSizeSum (a :+: b)) => GFlatSize (a :+: b) where + gsize !n = gsizeSum n +#endif + +#ifdef SIZ_NUM +instance (GFlatSizeSum (a :+: b)) => GFlatSize (a :+: b) where + gsize !n x = n + gsizeSum 0 x +#endif + +#ifdef SIZ_MAX +instance (GFlatSizeNxt (a :+: b),GFlatSizeMax (a:+:b)) => GFlatSize (a :+: b) where + gsize !n x = gsizeNxt (gsizeMax x + n) x + {-# INLINE gsize #-} + +-- |Calculate the maximum size of a class constructor (that might be one bit more than the size of some of its constructors) +#ifdef SIZ_MAX_VAL +class GFlatSizeMax (f :: * -> *) where gsizeMax :: f a -> NumBits + +instance (GFlatSizeMax f, GFlatSizeMax g) => GFlatSizeMax (f :+: g) where + gsizeMax _ = 1 + max (gsizeMax (undefined::f a )) (gsizeMax (undefined::g a)) + {-# INLINE gsizeMax #-} + +instance (GFlatSize a) => GFlatSizeMax (C1 c a) where + {-# INLINE gsizeMax #-} + gsizeMax _ = 0 +#endif + +#ifdef SIZ_MAX_PROX +-- instance (GFlatSizeNxt (a :+: b),GFlatSizeMax (a:+:b)) => GFlatSize (a :+: b) where +-- gsize !n x = gsizeNxt (gsizeMax x + n) x +-- {-# INLINE gsize #-} + + +-- -- |Calculate size in bits of constructor +-- class KnownNat n => GFlatSizeMax (n :: Nat) (f :: * -> *) where gsizeMax :: f a -> Proxy n -> NumBits + +-- instance (GFlatSizeMax (n + 1) a, GFlatSizeMax (n + 1) b, KnownNat n) => GFlatSizeMax n (a :+: b) where +-- gsizeMax !n x _ = case x of +-- L1 !l -> gsizeMax n l (Proxy :: Proxy (n+1)) +-- R1 !r -> gsizeMax n r (Proxy :: Proxy (n+1)) +-- {-# INLINE gsizeMax #-} + +-- instance (GFlatSize a, KnownNat n) => GFlatSizeMax n (C1 c a) where +-- {-# INLINE gsizeMax #-} +-- gsizeMax !n !x _ = gsize (constructorSize + n) x +-- where +-- constructorSize :: NumBits +-- constructorSize = fromInteger (natVal (Proxy :: Proxy n)) + +-- class KnownNat (ConsSize f) => GFlatSizeMax (f :: * -> *) where +-- gsizeMax :: f a -> NumBits +-- gsizeMax _ = fromInteger (natVal (Proxy :: Proxy (ConsSize f))) + +type family ConsSize (a :: * -> *) :: Nat where + ConsSize (C1 c a) = 0 + ConsSize (x :+: y) = 1 + Max (ConsSize x) (ConsSize y) + +type family Max (n :: Nat) (m :: Nat) :: Nat where + Max n m = If (n <=? m) m n + +type family If c (t::Nat) (e::Nat) where + If 'True t e = t + If 'False t e = e +#endif + +-- |Calculate the size of a value, not taking in account its constructor +class GFlatSizeNxt (f :: * -> *) where gsizeNxt :: NumBits -> f a -> NumBits + +instance (GFlatSizeNxt a, GFlatSizeNxt b) => GFlatSizeNxt (a :+: b) where + gsizeNxt n x = case x of + L1 !l-> gsizeNxt n l + R1 !r-> gsizeNxt n r + {-# INLINE gsizeNxt #-} + +instance (GFlatSize a) => GFlatSizeNxt (C1 c a) where + {-# INLINE gsizeNxt #-} + gsizeNxt !n !x = gsize n x +#endif + +-- |Calculate size in bits of constructor +-- vs proxy implementation: similar compilation time but much better run times (at least for Tree N, -70%) +#if MIN_VERSION_base(4,9,0) +class GFlatSizeSum (f :: Type -> Type) where +#else +class GFlatSizeSum (f :: * -> *) where +#endif + gsizeSum :: NumBits -> f a -> NumBits + +instance (GFlatSizeSum a, GFlatSizeSum b) + => GFlatSizeSum (a :+: b) where + gsizeSum !n x = case x of + L1 !l-> gsizeSum (n+1) l + R1 !r-> gsizeSum (n+1) r + {-# INLINE gsizeSum #-} + +instance (GFlatSize a) => GFlatSizeSum (C1 c a) where + {-# INLINE gsizeSum #-} + gsizeSum !n !x = gsize n x + + +-- |Calculate number of constructors +#if MIN_VERSION_base(4,9,0) +type family NumConstructors (a :: Type -> Type) :: Nat where +#else +type family NumConstructors (a :: * -> *) :: Nat where +#endif + NumConstructors (C1 c a) = 1 + NumConstructors (x :+: y) = NumConstructors x + NumConstructors y + +unused :: forall a . a +unused = error "Now, now, you could not possibly have meant this.." diff --git a/plutus-core/flat/src/PlutusCore/Flat/Data/ByteString/Convert.hs b/plutus-core/flat/src/PlutusCore/Flat/Data/ByteString/Convert.hs new file mode 100644 index 00000000000..3e66012c686 --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Data/ByteString/Convert.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE FlexibleInstances #-} + +module PlutusCore.Flat.Data.ByteString.Convert + ( AsByteString(..) + ) +where + +import Data.ByteString qualified as B +import Data.ByteString.Lazy qualified as L +import Data.Word + +-- |Convert to/from strict ByteStrings +class AsByteString a where + toByteString :: a -> B.ByteString + fromByteString :: B.ByteString -> a + +instance AsByteString B.ByteString where + toByteString = id + fromByteString = id + +instance AsByteString L.ByteString where + toByteString = L.toStrict + fromByteString = L.fromStrict + +instance AsByteString [Word8] where + toByteString = B.pack + fromByteString = B.unpack + diff --git a/plutus-core/flat/src/PlutusCore/Flat/Data/FloatCast.hs b/plutus-core/flat/src/PlutusCore/Flat/Data/FloatCast.hs new file mode 100644 index 00000000000..e5742e9a201 --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Data/FloatCast.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} + +{- | Primitives to convert between Float\/Double and Word32\/Word64. + +Code copied from . + +Based on: .. + +Implements casting via a 1-element STUArray, as described in . +-} +module PlutusCore.Flat.Data.FloatCast + ( floatToWord + , wordToFloat + , doubleToWord + , wordToDouble + , runST + , cast + ) +where + +import Data.Array.ST (MArray, STUArray, newArray, readArray) +import Data.Array.Unsafe (castSTUArray) +import Data.Word (Word32, Word64) +import GHC.ST (ST, runST) +-- import Flat.Endian + + + + +{- | Reinterpret-casts a `Word32` to a `Float`. + +prop> \f -> wordToFloat (floatToWord f ) == f ++++ OK, passed 100 tests. + +>>> floatToWord (-0.15625) +3189768192 + +>>> wordToFloat 3189768192 +-0.15625 + +>>> floatToWord (-5.828125) == 0xC0BA8000 +True +-} +wordToFloat :: Word32 -> Float +wordToFloat x = runST (cast x) +{-# INLINE wordToFloat #-} + +-- | Reinterpret-casts a `Float` to a `Word32`. +floatToWord :: Float -> Word32 +floatToWord x = runST (cast x) +{-# INLINE floatToWord #-} + +-- $setup +-- >>> import Numeric (showHex) +-- >>> import Data.Word + +{-| +Reinterpret-casts a `Double` to a `Word64`. + +prop> \f -> wordToDouble (doubleToWord f ) == f ++++ OK, passed 100 tests. + +>>> showHex (doubleToWord 1.0000000000000004) "" +"3ff0000000000002" + +>>> doubleToWord 1.0000000000000004 == 0x3FF0000000000002 +True + +>>> showHex (doubleToWord (-0.15625)) "" +"bfc4000000000000" + +>>> wordToDouble 0xbfc4000000000000 +-0.15625 +-} +{-# INLINE doubleToWord #-} +doubleToWord :: Double -> Word64 +doubleToWord x = runST (cast x) +-- doubleToWord x = fix64 $ runST (cast x) + +-- | Reinterpret-casts a `Word64` to a `Double`. +{-# INLINE wordToDouble #-} +wordToDouble :: Word64 -> Double +wordToDouble x = runST (cast x) +-- wordToDouble x = runST (cast $ fix64 x) + +-- | +-- >>> runST (cast (0xF0F1F2F3F4F5F6F7::Word64)) == (0xF0F1F2F3F4F5F6F7::Word64) +-- True +cast + :: (MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s)) => a -> ST s b +cast x = newArray (0 :: Int, 0) x >>= castSTUArray >>= flip readArray 0 +{-# INLINE cast #-} diff --git a/plutus-core/flat/src/PlutusCore/Flat/Data/ZigZag.hs b/plutus-core/flat/src/PlutusCore/Flat/Data/ZigZag.hs new file mode 100644 index 00000000000..6d5b5fbc5ae --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Data/ZigZag.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | of signed integrals. +module PlutusCore.Flat.Data.ZigZag (ZigZag(..)) where + +import Data.Bits (Bits (shiftL, shiftR, xor, (.&.)), FiniteBits (finiteBitSize)) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Word (Word16, Word32, Word64, Word8) +import Numeric.Natural (Natural) + +-- $setup +-- >>> :set -XNegativeLiterals -XScopedTypeVariables -XFlexibleContexts +-- >>> import Data.Word +-- >>> import Data.Int +-- >>> import Numeric.Natural +-- >>> import Test.QuickCheck.Arbitrary +-- >>> instance Arbitrary Natural where arbitrary = arbitrarySizedNatural; shrink = shrinkIntegral + +{-| +Convert between a signed integral and the corresponding ZigZag encoded unsigned integral (e.g. between Int8 and Word8 or Integral and Natural). + +Allow conversion only between compatible types, invalid conversions produce a type error: + +@ +zigZag (-1::Int64) :: Word32 +... +... Couldn't match type ... +... +@ +>>> zigZag (0::Int8) +0 + +>>> zigZag (-1::Int16) +1 + +>>> zigZag (1::Int32) +2 + +>>> zigZag (-2::Int16) +3 + +>>> zigZag (-50::Integer) +99 + +>>> zigZag (50::Integer) +100 + +>>> zigZag (64::Integer) +128 + +>>> zigZag (-256::Integer) +511 + +>>> zigZag (256::Integer) +512 + +>>> map zigZag [-3..3::Integer] +[5,3,1,0,2,4,6] + +>>> map zagZig [0..6::Word8] +[0,-1,1,-2,2,-3,3] + +prop> \(f::Integer) -> zagZig (zigZag f) == f ++++ OK, passed 100 tests. + +prop> \(f::Natural) -> zigZag (zagZig f) == f ++++ OK, passed 100 tests. + +prop> \(f::Int8) -> zagZig (zigZag f) == f ++++ OK, passed 100 tests. + +prop> \(f::Word8) -> zigZag (zagZig f) == f ++++ OK, passed 100 tests. + +prop> \(s::Int8) -> zigZag s == fromIntegral (zigZag (fromIntegral s :: Integer)) ++++ OK, passed 100 tests. + +prop> \(u::Word8) -> zagZig u == fromIntegral (zagZig (fromIntegral u :: Natural)) ++++ OK, passed 100 tests. + +prop> \(f::Int64) -> zagZig (zigZag f) == f ++++ OK, passed 100 tests. + +prop> \(f::Word64) -> zigZag (zagZig f) == f ++++ OK, passed 100 tests. + +prop> \(s::Int64) -> zigZag s == fromIntegral (zigZag (fromIntegral s :: Integer)) ++++ OK, passed 100 tests. + +prop> \(u::Word64) -> zagZig u == fromIntegral (zagZig (fromIntegral u :: Natural)) ++++ OK, passed 100 tests. +-} +class (Integral signed, Integral unsigned) + => ZigZag signed unsigned | unsigned -> signed, signed -> unsigned where + zigZag :: signed -> unsigned + default zigZag :: FiniteBits signed => signed -> unsigned + zigZag s = fromIntegral + ((s `shiftL` 1) `xor` (s `shiftR` (finiteBitSize s - 1))) + + {-# INLINE zigZag #-} + zagZig :: unsigned -> signed + default zagZig :: (Bits unsigned) => unsigned -> signed + zagZig u = fromIntegral ((u `shiftR` 1) `xor` negate (u .&. 1)) + + -- default zagZig :: (Bits signed) => unsigned -> signed + -- zagZig u = let (s::signed) = fromIntegral u in ((s `shiftR` 1) `xor` (negate (s .&. 1))) + {-# INLINE zagZig #-} + +instance ZigZag Int8 Word8 + +instance ZigZag Int16 Word16 + +instance ZigZag Int32 Word32 + +instance ZigZag Int64 Word64 + +instance ZigZag Integer Natural where + zigZag x + | x >= 0 = fromIntegral $ x `shiftL` 1 + | otherwise = fromIntegral $ negate (x `shiftL` 1) - 1 + + zagZig u = let s = fromIntegral u + in ((s `shiftR` 1) `xor` negate (s .&. 1)) diff --git a/plutus-core/flat/src/PlutusCore/Flat/Decoder.hs b/plutus-core/flat/src/PlutusCore/Flat/Decoder.hs new file mode 100644 index 00000000000..5b0e31dc107 --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Decoder.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE CPP #-} +-- |Strict Decoder +module PlutusCore.Flat.Decoder ( + strictDecoder, + listTDecoder, + Decoded, + DecodeException(..), + Get, + dByteString, + dLazyByteString, + dShortByteString, + dShortByteString_, +#if! defined (ETA_VERSION) + dUTF16, +#endif + dUTF8, + decodeArrayWith, + decodeListWith, + dFloat, + dDouble, + dInteger, + dNatural, + dChar, + dBool, + dWord8, + dWord16, + dWord32, + dWord64, + dWord, + dInt8, + dInt16, + dInt32, + dInt64, + dInt, + dBE8, + dBE16, + dBE32, + dBE64, + dBEBits8, + dBEBits16, + dBEBits32, + dBEBits64, + dropBits, + + ConsState(..),consOpen,consClose,consBool,consBits + ) where + +import PlutusCore.Flat.Decoder.Prim +import PlutusCore.Flat.Decoder.Run +import PlutusCore.Flat.Decoder.Strict +import PlutusCore.Flat.Decoder.Types diff --git a/plutus-core/flat/src/PlutusCore/Flat/Decoder/Prim.hs b/plutus-core/flat/src/PlutusCore/Flat/Decoder/Prim.hs new file mode 100644 index 00000000000..4a11c5d85d1 --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Decoder/Prim.hs @@ -0,0 +1,436 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- |Strict Decoder Primitives +module PlutusCore.Flat.Decoder.Prim ( + dBool, + dWord8, + dBE8, + dBE16, + dBE32, + dBE64, + dBEBits8, + dBEBits16, + dBEBits32, + dBEBits64, + dropBits, + dFloat, + dDouble, + getChunksInfo, + dByteString_, + dLazyByteString_, + dByteArray_, + + ConsState(..),consOpen,consClose,consBool,consBits, + + sizeOf,binOf + ) where + +import Control.Monad (when) +import Data.ByteString qualified as B +import Data.ByteString.Lazy qualified as L +import Data.Word (Word16, Word32, Word64, Word8) +import Foreign (Bits (unsafeShiftL, unsafeShiftR, (.&.), (.|.)), FiniteBits (finiteBitSize), Ptr, + Storable (peek), castPtr, plusPtr, ptrToIntPtr) +import PlutusCore.Flat.Data.FloatCast (wordToDouble, wordToFloat) +import PlutusCore.Flat.Decoder.Types (Get (Get, runGet), GetResult (..), S (..), badEncoding, badOp, + notEnoughSpace) +import PlutusCore.Flat.Endian (toBE16, toBE32, toBE64) +import PlutusCore.Flat.Memory (ByteArray, chunksToByteArray, chunksToByteString, minusPtr, + peekByteString) + +-- $setup +-- >>> :set -XBinaryLiterals +-- >>> import Data.Word +-- >>> import Data.Int +-- >>> import PlutusCore.Flat.Run +-- >>> import PlutusCore.Flat.Bits +-- >>> import Text.PrettyPrint.HughesPJClass (Pretty (pPrint)) + +{- |A special state, optimised for constructor decoding. + +It consists of: + +* The bits to parse, the top bit being the first to parse (could use a Word16 instead, no difference in performance) + +* The number of decoded bits + +Supports up to 512 constructors (9 bits). +-} +data ConsState = + ConsState {-# UNPACK #-} !Word !Int + +-- |Switch to constructor decoding +-- {-# INLINE consOpen #-} +consOpen :: Get ConsState +consOpen = Get $ \endPtr s -> do + let u = usedBits s + let d = ptrToIntPtr endPtr - ptrToIntPtr (currPtr s) + w <- if d > 1 then do -- two different bytes + w16::Word16 <- toBE16 <$> peek (castPtr $ currPtr s) + return $ fromIntegral w16 `unsafeShiftL` (u+(wordSize-16)) + else if d == 1 then do -- single last byte left + w8 :: Word8 <- peek (currPtr s) + return $ fromIntegral w8 `unsafeShiftL` (u+(wordSize-8)) + else notEnoughSpace endPtr s + return $ GetResult s (ConsState w 0) + +-- |Switch back to normal decoding +-- {-# NOINLINE consClose #-} +consClose :: Int -> Get () +consClose n = Get $ \endPtr s -> do + let u' = n+usedBits s + if u' < 8 + then return $ GetResult (s {usedBits=u'}) () + else if currPtr s >= endPtr + then notEnoughSpace endPtr s + else return $ GetResult (s {currPtr=currPtr s `plusPtr` 1,usedBits=u'-8}) () + + {- ensureBits endPtr s n = when ((endPtr `minusPtr` currPtr s) * 8 - usedBits s < n) $ notEnoughSpace endPtr s + dropBits8 s n = + let u' = n+usedBits s + in if u' < 8 + then s {usedBits=u'} + else s {currPtr=currPtr s `plusPtr` 1,usedBits=u'-8} + -} + + --ensureBits endPtr s n + --return $ GetResult (dropBits8 s n) () + +-- |Decode a single bit +consBool :: ConsState -> (ConsState,Bool) +consBool cs = (0/=) <$> consBits cs 1 + +-- consBool (ConsState w usedBits) = (ConsState (w `unsafeShiftL` 1) (1+usedBits),0 /= 32768 .&. w) + +-- |Decode from 1 to 3 bits +-- +-- It could read more bits that are available, but it doesn't matter, errors will be checked in consClose. +consBits :: ConsState -> Int -> (ConsState, Word) +consBits cs 3 = consBits_ cs 3 7 +consBits cs 2 = consBits_ cs 2 3 +consBits cs 1 = consBits_ cs 1 1 +consBits _ _ = error "unsupported" + +consBits_ :: ConsState -> Int -> Word -> (ConsState, Word) + +-- Different decoding primitives +-- All with equivalent performance +-- #define CONS_ROT +-- #define CONS_SHL +#define CONS_STA + +#ifdef CONS_ROT +consBits_ (ConsState w usedBits) numBits mask = + let usedBits' = numBits+usedBits + w' = w `rotateL` numBits -- compiles to an or+shiftl+shiftr + in (ConsState w' usedBits',w' .&. mask) +#endif + +#ifdef CONS_SHL +consBits_ (ConsState w usedBits) numBits mask = + let usedBits' = numBits+usedBits + w' = w `unsafeShiftL` numBits + in (ConsState w' usedBits', (w `unsafeShiftR` (wordSize - numBits)) .&. mask) +#endif + +#ifdef CONS_STA +consBits_ (ConsState w usedBits) numBits mask = + let usedBits' = numBits+usedBits + in (ConsState w usedBits', (w `unsafeShiftR` (wordSize - usedBits')) .&. mask) +#endif + +wordSize :: Int +wordSize = finiteBitSize (0 :: Word) + +{-# INLINE ensureBits #-} +-- |Ensure that the specified number of bits is available +ensureBits :: Ptr Word8 -> S -> Int -> IO () +ensureBits endPtr s n = when ((endPtr `minusPtr` currPtr s) * 8 - usedBits s < n) $ notEnoughSpace endPtr s + +{-# INLINE dropBits #-} +-- |Drop the specified number of bits +dropBits :: Int -> Get () +dropBits n + | n > 0 = Get $ \endPtr s -> do + ensureBits endPtr s n + return $ GetResult (dropBits_ s n) () + | n == 0 = return () + | otherwise = error $ unwords ["dropBits",show n] + +{-# INLINE dropBits_ #-} +dropBits_ :: S -> Int -> S +dropBits_ s n = + let (bytes,bits) = (n+usedBits s) `divMod` 8 + -- let + -- n' = n+usedBits s + -- bytes = n' `unsafeShiftR` 3 + -- bits = n' .|. 7 + in S {currPtr=currPtr s `plusPtr` bytes,usedBits=bits} + +{-# INLINE dBool #-} +-- Inlining dBool massively increases compilation time but decreases run time by a third +-- TODO: test dBool inlining for ghc >= 8.8.4 +-- |Decode a boolean +dBool :: Get Bool +dBool = Get $ \endPtr s -> + if currPtr s >= endPtr + then notEnoughSpace endPtr s + else do + !w <- peek (currPtr s) + let !b = 0 /= (w .&. (128 `unsafeShiftR` usedBits s)) + let !s' = if usedBits s == 7 + then s { currPtr = currPtr s `plusPtr` 1, usedBits = 0 } + else s { usedBits = usedBits s + 1 } + return $ GetResult s' b + + +{-# INLINE dBEBits8 #-} +{- | Return the n most significant bits (up to maximum of 8) + +The bits are returned right shifted: + +>>> unflatWith (dBEBits8 3) [0b11100001::Word8] == Right 0b00000111 +True + +>>> unflatWith (dBEBits8 9) [0b11100001::Word8,0b11111111] +Left (BadOp "read8: cannot read 9 bits") +-} +dBEBits8 :: Int -> Get Word8 +dBEBits8 n = Get $ \endPtr s -> do + ensureBits endPtr s n + take8 s n + +{-# INLINE dBEBits16 #-} +{- | Return the n most significant bits (up to maximum of 16) + +The bits are returned right shifted: + +>>> pPrint . asBits <$> unflatWith (dBEBits16 11) [0b10110111::Word8,0b11100001] +Right 00000101 10111111 + +If more than 16 bits are requested, only the last 16 are returned: + +>>> pPrint . asBits <$> unflatWith (dBEBits16 19) [0b00000000::Word8,0b11111111,0b11100001] +Right 00000111 11111111 +-} +dBEBits16 :: Int -> Get Word16 +dBEBits16 n = Get $ \endPtr s -> do + ensureBits endPtr s n + takeN n s + +{-# INLINE dBEBits32 #-} +-- |Return the n most significant bits (up to maximum of 32) +-- The bits are returned right shifted. +dBEBits32 :: Int -> Get Word32 +dBEBits32 n = Get $ \endPtr s -> do + ensureBits endPtr s n + takeN n s + +{-# INLINE dBEBits64 #-} +-- |Return the n most significant bits (up to maximum of 64) +-- The bits are returned right shifted. +dBEBits64 :: Int -> Get Word64 +dBEBits64 n = Get $ \endPtr s -> do + ensureBits endPtr s n + takeN n s + +-- {-# INLINE take8 #-} +-- take8 :: Int -> S -> IO (GetResult Word8) +-- take8 n s +-- | n == 0 = return $ GetResult s 0 + +-- -- all bits in the same byte +-- | n <= 8 - usedBits s = do +-- w <- peek (currPtr s) +-- let (bytes,bits) = (n+usedBits s) `divMod` 8 +-- return $ GetResult (S {currPtr=currPtr s `plusPtr` bytes,usedBits=bits}) ((w `unsafeShiftL` usedBits s) `unsafeShiftR` (8 - n)) + +-- -- two different bytes +-- | n <= 8 = do +-- w::Word16 <- toBE16 <$> peek (castPtr $ currPtr s) +-- return $ GetResult (S {currPtr=currPtr s `plusPtr` 1,usedBits=(usedBits s + n) `mod` 8}) (fromIntegral $ (w `unsafeShiftL` usedBits s) `unsafeShiftR` (16 - n)) + +-- | otherwise = error $ unwords ["take8: cannot take",show n,"bits"] + +{-# INLINE take8 #-} +take8 :: S -> Int -> IO (GetResult Word8) +-- take8 s n = GetResult (dropBits_ s n) <$> read8 s n +take8 s n = GetResult (dropBits8 s n) <$> read8 s n + where + --{-# INLINE read8 #-} + read8 :: S -> Int -> IO Word8 + read8 s n | n >=0 && n <=8 = + if n <= 8 - usedBits s + then do -- all bits in the same byte + w <- peek (currPtr s) + return $ (w `unsafeShiftL` usedBits s) `unsafeShiftR` (8 - n) + else do -- two different bytes + w::Word16 <- toBE16 <$> peek (castPtr $ currPtr s) + return $ fromIntegral $ (w `unsafeShiftL` usedBits s) `unsafeShiftR` (16 - n) + | otherwise = badOp $ unwords ["read8: cannot read",show n,"bits"] + -- {-# INLINE dropBits8 #-} + -- -- Assume n <= 8 + dropBits8 :: S -> Int -> S + dropBits8 s n = + let u' = n+usedBits s + in if u' < 8 + then s {usedBits=u'} + else s {currPtr=currPtr s `plusPtr` 1,usedBits=u'-8} + + +{-# INLINE takeN #-} +takeN :: (Num a, Bits a) => Int -> S -> IO (GetResult a) +takeN n s = read s 0 (n - (n `min` 8)) n + where + read s r sh n | n <=0 = return $ GetResult s r + | otherwise = do + let m = n `min` 8 + GetResult s' b <- take8 s m + read s' (r .|. (fromIntegral b `unsafeShiftL` sh)) ((sh-8) `max` 0) (n-8) + +-- takeN n = Get $ \endPtr s -> do +-- ensureBits endPtr s n +-- let (bytes,bits) = (n+usedBits s) `divMod` 8 +-- r <- case bytes of +-- 0 -> do +-- w <- peek (currPtr s) +-- return . fromIntegral $ ((w `unsafeShiftL` usedBits s) `unsafeShiftR` (8 - n)) +-- 1 -> do +-- w::Word16 <- toBE16 <$> peek (castPtr $ currPtr s) +-- return $ fromIntegral $ (w `unsafeShiftL` usedBits s) `unsafeShiftR` (16 - n) +-- 2 -> do +-- let r = 0 +-- w1 <- fromIntegral <$> r8 s +-- w2 <- fromIntegral <$> r16 s +-- w1 +-- return $ GetResult (S {currPtr=currPtr s `plusPtr` bytes,usedBits=bits}) r + +-- r8 s = peek (currPtr s) +-- r16 s = toBE16 <$> peek (castPtr $ currPtr s) + +-- |Return the 8 most significant bits (same as dBE8) +dWord8 :: Get Word8 +dWord8 = dBE8 + +{-# INLINE dBE8 #-} +-- |Return the 8 most significant bits +dBE8 :: Get Word8 +dBE8 = Get $ \endPtr s -> do + ensureBits endPtr s 8 + !w1 <- peek (currPtr s) + !w <- if usedBits s == 0 + then return w1 + else do + !w2 <- peek (currPtr s `plusPtr` 1) + return $ (w1 `unsafeShiftL` usedBits s) .|. (w2 `unsafeShiftR` (8-usedBits s)) + return $ GetResult (s {currPtr=currPtr s `plusPtr` 1}) w + +{-# INLINE dBE16 #-} +-- |Return the 16 most significant bits +dBE16 :: Get Word16 +dBE16 = Get $ \endPtr s -> do + ensureBits endPtr s 16 + !w1 <- toBE16 <$> peek (castPtr $ currPtr s) + !w <- if usedBits s == 0 + then return w1 + else do + !(w2::Word8) <- peek (currPtr s `plusPtr` 2) + return $ w1 `unsafeShiftL` usedBits s .|. fromIntegral (w2 `unsafeShiftR` (8-usedBits s)) + return $ GetResult (s {currPtr=currPtr s `plusPtr` 2}) w + +{-# INLINE dBE32 #-} +-- |Return the 32 most significant bits +dBE32 :: Get Word32 +dBE32 = Get $ \endPtr s -> do + ensureBits endPtr s 32 + !w1 <- toBE32 <$> peek (castPtr $ currPtr s) + !w <- if usedBits s == 0 + then return w1 + else do + !(w2::Word8) <- peek (currPtr s `plusPtr` 4) + return $ w1 `unsafeShiftL` usedBits s .|. fromIntegral (w2 `unsafeShiftR` (8-usedBits s)) + return $ GetResult (s {currPtr=currPtr s `plusPtr` 4}) w + +{-# INLINE dBE64 #-} +-- |Return the 64 most significant bits +dBE64 :: Get Word64 +dBE64 = Get $ \endPtr s -> do + ensureBits endPtr s 64 + -- !w1 <- toBE64 <$> peek (castPtr $ currPtr s) + !w1 <- toBE64 <$> peek64 (castPtr $ currPtr s) + !w <- if usedBits s == 0 + then return w1 + else do + !(w2::Word8) <- peek (currPtr s `plusPtr` 8) + return $ w1 `unsafeShiftL` usedBits s .|. fromIntegral (w2 `unsafeShiftR` (8-usedBits s)) + return $ GetResult (s {currPtr=currPtr s `plusPtr` 8}) w + where + -- {-# INLINE peek64 #-} + peek64 :: Ptr Word64 -> IO Word64 + peek64 = peek + -- peek64 ptr = fix64 <$> peek ptr + +{-# INLINE dFloat #-} +-- |Decode a Float +dFloat :: Get Float +dFloat = wordToFloat <$> dBE32 + +{-# INLINE dDouble #-} +-- |Decode a Double +dDouble :: Get Double +dDouble = wordToDouble <$> dBE64 + +-- |Decode a Lazy ByteString +dLazyByteString_ :: Get L.ByteString +dLazyByteString_ = L.fromStrict <$> dByteString_ + +-- |Decode a ByteString +dByteString_ :: Get B.ByteString +dByteString_ = chunksToByteString <$> getChunksInfo + +-- |Decode a ByteArray and its length +dByteArray_ :: Get (ByteArray,Int) +dByteArray_ = chunksToByteArray <$> getChunksInfo + +-- |Decode an Array (a list of chunks up to 255 bytes long) returning the pointer to the first data byte and a list of chunk sizes +getChunksInfo :: Get (Ptr Word8, [Int]) +getChunksInfo = Get $ \endPtr s -> do + + let getChunks srcPtr l = do + ensureBits endPtr s 8 + !n <- fromIntegral <$> peek srcPtr + if n==0 + then return (srcPtr `plusPtr` 1,l []) + else do + ensureBits endPtr s ((n+1)*8) + getChunks (srcPtr `plusPtr` (n+1)) (l . (n:)) -- ETA: stack overflow (missing tail call optimisation) + + when (usedBits s /=0) $ badEncoding endPtr s "usedBits /= 0" + (currPtr',ns) <- getChunks (currPtr s) id + return $ GetResult (s {currPtr=currPtr'}) (currPtr s `plusPtr` 1,ns) + +{- | Given a value's decoder, returns the size in bits of the encoded value + +@since 0.6 +-} +sizeOf :: Get a -> Get Int +sizeOf g = + Get $ \end s -> do + GetResult s' _ <- runGet g end s + return $ GetResult s' $ (currPtr s' `minusPtr` currPtr s) * 8 - usedBits s + usedBits s' + +{- | Given a value's decoder, returns the value's bit encoding. + +The encoding starts at the returned bit position in the return bytestring's first byte +and ends in an unspecified bit position in its final byte + +@since 0.6 +-} +binOf :: Get a -> Get (B.ByteString,Int) +binOf g = + Get $ \end s -> do + GetResult s' _ <- runGet g end s + return $ GetResult s' (peekByteString (currPtr s) (currPtr s' `minusPtr` currPtr s + if usedBits s' == 0 then 0 else 1),usedBits s) diff --git a/plutus-core/flat/src/PlutusCore/Flat/Decoder/Run.hs b/plutus-core/flat/src/PlutusCore/Flat/Decoder/Run.hs new file mode 100644 index 00000000000..e12dd5f5ed9 --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Decoder/Run.hs @@ -0,0 +1,72 @@ + +module PlutusCore.Flat.Decoder.Run(strictDecoder,listTDecoder) where + +import Control.Exception (Exception, try) +import Data.ByteString qualified as B +import Data.ByteString.Internal qualified as BS +import Foreign (Ptr, plusPtr, withForeignPtr) +import ListT (ListT (..)) +import PlutusCore.Flat.Decoder.Prim (dBool) +import PlutusCore.Flat.Decoder.Types (DecodeException, Get (runGet), GetResult (..), S (S), + tooMuchSpace) +import System.IO.Unsafe (unsafePerformIO) + +-- | Given a decoder and an input buffer returns either the decoded value or an error (if the input buffer is not fully consumed) +strictDecoder :: Get a -> B.ByteString -> Int -> Either DecodeException a +strictDecoder get bs usedBits= + strictDecoder_ get bs usedBits $ \(GetResult s'@(S ptr' o') a) endPtr -> + if ptr' /= endPtr || o' /= 0 + then tooMuchSpace endPtr s' + else return a + +strictDecoder_ :: + Exception e + => Get a1 + -> BS.ByteString + -> Int + -> (GetResult a1 -> Ptr b -> IO a) + -> Either e a +strictDecoder_ get (BS.PS base off len) usedBits check = + unsafePerformIO . try $ + withForeignPtr base $ \base0 -> + let ptr = base0 `plusPtr` off + endPtr = ptr `plusPtr` len + in do res <- runGet get endPtr (S ptr usedBits) + check res endPtr +{-# NOINLINE strictDecoder_ #-} + + +-- strictRawDecoder :: Exception e => Get t -> B.ByteString -> Either e (t,B.ByteString, NumBits) +-- strictRawDecoder get (BS.PS base off len) = unsafePerformIO . try $ +-- withForeignPtr base $ \base0 -> +-- let ptr = base0 `plusPtr` off +-- endPtr = ptr `plusPtr` len +-- in do +-- GetResult (S ptr' o') a <- runGet get endPtr (S ptr 0) +-- return (a, BS.PS base (ptr' `minusPtr` base0) (endPtr `minusPtr` ptr'), o') + +{-| +Decode a list of values, one value at a time. + +Useful in case that the decoded values takes a lot more memory than the encoded ones. + +See <../test/Big.hs> for a test and an example of use. + +See also "Flat.AsBin". + +@since 0.5 +-} +listTDecoder :: Get a -> BS.ByteString -> IO (ListT IO a) +listTDecoder get (BS.PS base off len) = + withForeignPtr base $ \base0 -> do + let ptr = base0 `plusPtr` off + endPtr = ptr `plusPtr` len + s = S ptr 0 + go s = do + GetResult s' b <- runGet dBool endPtr s + if b + then do + GetResult s'' a <- runGet get endPtr s' + return $ Just (a, ListT $ go s'') + else return Nothing + return $ ListT (go s) diff --git a/plutus-core/flat/src/PlutusCore/Flat/Decoder/Strict.hs b/plutus-core/flat/src/PlutusCore/Flat/Decoder/Strict.hs new file mode 100644 index 00000000000..f32cee9cbe3 --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Decoder/Strict.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} + +-- |Strict Decoder +module PlutusCore.Flat.Decoder.Strict + ( decodeArrayWith + , decodeListWith + , dByteString + , dLazyByteString + , dShortByteString + , dShortByteString_ +#if! defined (ETA_VERSION) + , dUTF16 +#endif + , dUTF8 + , dInteger + , dNatural + , dChar + , dWord8 + , dWord16 + , dWord32 + , dWord64 + , dWord + , dInt8 + , dInt16 + , dInt32 + , dInt64 + , dInt + ) where + +import Data.Bits +import Data.ByteString qualified as B +import Data.ByteString.Lazy qualified as L +import Data.ByteString.Short qualified as SBS +#if !MIN_VERSION_bytestring(0,11,0) +import Data.ByteString.Short.Internal qualified as SBS +#endif +import Control.Monad (unless) +import Data.DList qualified as DL +import Data.Int +import Data.Primitive.ByteArray +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import PlutusCore.Flat.Decoder.Prim +import PlutusCore.Flat.Decoder.Types + +#if! defined (ETA_VERSION) && ! MIN_VERSION_text(2,0,0) +import Data.Text.Array qualified as TA +import Data.Text.Internal qualified as T +#endif + +import Data.Word +import GHC.Base (unsafeChr) +import Numeric.Natural (Natural) +import PlutusCore.Flat.Data.ZigZag +#include "MachDeps.h" + +{-# INLINE decodeListWith #-} +decodeListWith :: Get a -> Get [a] +decodeListWith dec = go + where + go = do + b <- dBool + if b + then (:) <$> dec <*> go + else return [] + +decodeArrayWith :: Get a -> Get [a] +decodeArrayWith dec = DL.toList <$> getAsL_ dec + +-- TODO: test if it would it be faster with DList.unfoldr :: (b -> Maybe (a, b)) -> b -> Data.DList.DList a +-- getAsL_ :: Flat a => Get (DL.DList a) +getAsL_ :: Get a -> Get (DL.DList a) +getAsL_ dec = do + tag <- dWord8 + case tag of + 0 -> return DL.empty + _ -> do + h <- gets tag + t <- getAsL_ dec + return (DL.append h t) + where + gets 0 = return DL.empty + gets n = DL.cons <$> dec <*> gets (n - 1) + +{-# INLINE dNatural #-} +dNatural :: Get Natural +dNatural = dUnsigned + +{-# INLINE dInteger #-} +dInteger :: Get Integer +dInteger = zagZig <$> dUnsigned + +{-# INLINE dWord #-} +{-# INLINE dInt #-} +dWord :: Get Word +dInt :: Get Int + +#if WORD_SIZE_IN_BITS == 64 +dWord = (fromIntegral :: Word64 -> Word) <$> dWord64 + +dInt = (fromIntegral :: Int64 -> Int) <$> dInt64 +#elif WORD_SIZE_IN_BITS == 32 +dWord = (fromIntegral :: Word32 -> Word) <$> dWord32 + +dInt = (fromIntegral :: Int32 -> Int) <$> dInt32 +#else +#error expected WORD_SIZE_IN_BITS to be 32 or 64 +#endif + + + + + + + + +{-# INLINE dInt8 #-} +dInt8 :: Get Int8 +dInt8 = zagZig <$> dWord8 + +{-# INLINE dInt16 #-} +dInt16 :: Get Int16 +dInt16 = zagZig <$> dWord16 + +{-# INLINE dInt32 #-} +dInt32 :: Get Int32 +dInt32 = zagZig <$> dWord32 + +{-# INLINE dInt64 #-} +dInt64 :: Get Int64 +dInt64 = zagZig <$> dWord64 + +-- {-# INLINE dWord16 #-} +dWord16 :: Get Word16 +dWord16 = wordStep 0 (wordStep 7 (lastStep 14)) 0 + +-- {-# INLINE dWord32 #-} +dWord32 :: Get Word32 +dWord32 = wordStep 0 (wordStep 7 (wordStep 14 (wordStep 21 (lastStep 28)))) 0 + +-- {-# INLINE dWord64 #-} +dWord64 :: Get Word64 +dWord64 = + wordStep + 0 + (wordStep + 7 + (wordStep + 14 + (wordStep + 21 + (wordStep + 28 + (wordStep + 35 + (wordStep + 42 + (wordStep + 49 + (wordStep 56 (lastStep 63))))))))) + 0 + +{-# INLINE dChar #-} +dChar :: Get Char +-- dChar = chr . fromIntegral <$> dWord32 +-- Not really faster than the simpler version above +dChar = charStep 0 (charStep 7 (lastCharStep 14)) 0 + +{-# INLINE charStep #-} +charStep :: Int -> (Int -> Get Char) -> Int -> Get Char +charStep !shl !cont !n = do + !tw <- fromIntegral <$> dWord8 + let !w = tw .&. 127 + let !v = n .|. w `shift` shl + if tw == w + then return $ unsafeChr v + else cont v + +{-# INLINE lastCharStep #-} +lastCharStep :: Int -> Int -> Get Char +lastCharStep !shl !n = do + !tw <- fromIntegral <$> dWord8 + let !w = tw .&. 127 + let !v = n .|. w `shift` shl + if tw == w + then if v > 0x10FFFF + then charErr v + else return $ unsafeChr v + else charErr v + where + charErr v = fail $ "Unexpected extra byte or non unicode char" ++ show v + +{-# INLINE wordStep #-} +wordStep :: (Bits a, Num a) => Int -> (a -> Get a) -> a -> Get a +wordStep shl k n = do + tw <- fromIntegral <$> dWord8 + let w = tw .&. 127 + let v = n .|. w `shift` shl + if tw == w + then return v + --else oneShot k v + else k v + +{-# INLINE lastStep #-} +lastStep :: (FiniteBits b, Show b, Num b) => Int -> b -> Get b +lastStep shl n = do + tw <- fromIntegral <$> dWord8 + let w = tw .&. 127 + let v = n .|. w `shift` shl + if tw == w + then if countLeadingZeros w < shl + then wordErr v + else return v + else wordErr v + where + wordErr v = fail $ "Unexpected extra byte in unsigned integer" ++ show v + +-- {-# INLINE dUnsigned #-} +dUnsigned :: (Num b, Bits b) => Get b +dUnsigned = do + (v, shl) <- dUnsigned_ 0 0 + maybe + (return v) + (\s -> + if shl >= s + then fail "Unexpected extra data in unsigned integer" + else return v) $ + bitSizeMaybe v + +-- {-# INLINE dUnsigned_ #-} +dUnsigned_ :: (Bits t, Num t) => Int -> t -> Get (t, Int) +dUnsigned_ shl n = do + tw <- dWord8 + let w = tw .&. 127 + let v = n .|. fromIntegral w `shift` shl + if tw == w + then return (v, shl) + else dUnsigned_ (shl + 7) v + +--encode = encode . blob UTF8Encoding . L.fromStrict . T.encodeUtf8 +--decode = T.decodeUtf8 . L.toStrict . (unblob :: BLOB UTF8Encoding -> L.ByteString) <$> decode + +#if ! defined (ETA_VERSION) +-- BLOB UTF16Encoding +dUTF16 :: Get T.Text +dUTF16 = do + _ <- dFiller +#if MIN_VERSION_text(2,0,0) + -- Checked decoding (from UTF-8) + T.decodeUtf16LE <$> dByteString_ +#else + -- Unchecked decoding (already UTF16) + (ByteArray array, lengthInBytes) <- dByteArray_ + return (T.Text (TA.Array array) 0 (lengthInBytes `div` 2)) +#endif +#endif + +dUTF8 :: Get T.Text +dUTF8 = do + _ <- dFiller + bs <- dByteString_ + case T.decodeUtf8' bs of + Right t -> pure t + Left e -> fail $ "Input contains invalid UTF-8 data" ++ show e + +dFiller :: Get () +dFiller = do + tag <- dBool + unless tag dFiller + +dLazyByteString :: Get L.ByteString +dLazyByteString = dFiller >> dLazyByteString_ + +dShortByteString :: Get SBS.ShortByteString +dShortByteString = dFiller >> dShortByteString_ + +dShortByteString_ :: Get SBS.ShortByteString +dShortByteString_ = do + (ByteArray array, _) <- dByteArray_ + return $ SBS.SBS array + +dByteString :: Get B.ByteString +dByteString = dFiller >> dByteString_ + + + + diff --git a/plutus-core/flat/src/PlutusCore/Flat/Decoder/Types.hs b/plutus-core/flat/src/PlutusCore/Flat/Decoder/Types.hs new file mode 100644 index 00000000000..9ffb57cb698 --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Decoder/Types.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} + +-- |Strict Decoder Types +module PlutusCore.Flat.Decoder.Types + ( + Get(..) + , S(..) + , GetResult(..) + , Decoded + , DecodeException(..) + , notEnoughSpace + , tooMuchSpace + , badEncoding + , badOp + ) where + +import Control.DeepSeq (NFData (..)) +import Control.Exception (Exception, throwIO) +import Data.Word (Word8) +import Foreign (Ptr) + +#if MIN_VERSION_base(4,9,0) +import Control.Monad.Fail qualified as Fail +#endif + +{- | +A decoder. + +Given: + +* end of input buffer + +* current position in input buffer + +Returns: + +* decoded value + +* new position in input buffer +-} +newtype Get a = + Get + { runGet :: + Ptr Word8 + -> S + -> IO (GetResult a) + } + +-- Seems to give better performance than the derived version +instance Functor Get where + fmap f g = + Get $ \end s -> do + GetResult s' a <- runGet g end s + return $ GetResult s' (f a) + {-# INLINE fmap #-} + +-- Is this correct? +instance NFData (Get a) where + rnf !_ = () + +instance Show (Get a) where + show _ = "Get" + +instance Applicative Get where + pure x = Get (\_ ptr -> return $ GetResult ptr x) + {-# INLINE pure #-} + Get f <*> Get g = + Get $ \end ptr1 -> do + GetResult ptr2 f' <- f end ptr1 + GetResult ptr3 g' <- g end ptr2 + return $ GetResult ptr3 (f' g') + {-# INLINE (<*>) #-} + Get f *> Get g = + Get $ \end ptr1 -> do + GetResult ptr2 _ <- f end ptr1 + g end ptr2 + {-# INLINE (*>) #-} + +instance Monad Get where + return = pure + {-# INLINE return #-} + (>>) = (*>) + {-# INLINE (>>) #-} + Get x >>= f = + Get $ \end s -> do + GetResult s' x' <- x end s + runGet (f x') end s' + {-# INLINE (>>=) #-} +#if !(MIN_VERSION_base(4,13,0)) + fail = failGet +#endif + +#if MIN_VERSION_base(4,9,0) +instance Fail.MonadFail Get where + fail = failGet +#endif +{-# INLINE failGet #-} +failGet :: String -> Get a +failGet msg = Get $ \end s -> badEncoding end s msg + +-- |Decoder state +data S = + S + { currPtr :: {-# UNPACK #-}!(Ptr Word8) + , usedBits :: {-# UNPACK #-}!Int + } + deriving (Show, Eq, Ord) + +data GetResult a = + GetResult {-# UNPACK #-}!S !a + deriving (Functor) + +-- |A decoded value +type Decoded a = Either DecodeException a + +-- |An exception during decoding +data DecodeException + = NotEnoughSpace Env + | TooMuchSpace Env + | BadEncoding Env String + | BadOp String + deriving (Show, Eq, Ord) + +type Env = (Ptr Word8, S) + +notEnoughSpace :: Ptr Word8 -> S -> IO a +notEnoughSpace endPtr s = throwIO $ NotEnoughSpace (endPtr, s) + +tooMuchSpace :: Ptr Word8 -> S -> IO a +tooMuchSpace endPtr s = throwIO $ TooMuchSpace (endPtr, s) + +badEncoding :: Ptr Word8 -> S -> String -> IO a +badEncoding endPtr s msg = throwIO $ BadEncoding (endPtr, s) msg + +badOp :: String -> IO a +badOp msg = throwIO $ BadOp msg + +instance Exception DecodeException diff --git a/plutus-core/flat/src/PlutusCore/Flat/Encoder.hs b/plutus-core/flat/src/PlutusCore/Flat/Encoder.hs new file mode 100644 index 00000000000..7942f4ab105 --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Encoder.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +-- |Encoder and encoding primitives +module PlutusCore.Flat.Encoder ( + Encoding, + (<>), + NumBits, + encodersS, + mempty, + strictEncoder, + eTrueF, + eFalseF, + eFloat, + eDouble, + eInteger, + eNatural, + eWord16, + eWord32, + eWord64, + eWord8, + eBits, + eBits16, + eFiller, + eBool, + eTrue, + eFalse, + eBytes, +#if ! defined (ETA_VERSION) + eUTF16, +#endif + eLazyBytes, + eShortBytes, + eInt, + eInt8, + eInt16, + eInt32, + eInt64, + eWord, + eChar, + encodeArrayWith, + encodeListWith, + Size, + arrayBits, + sWord, + sWord8, + sWord16, + sWord32, + sWord64, + sInt, + sInt8, + sInt16, + sInt32, + sInt64, + sNatural, + sInteger, + sFloat, + sDouble, + sChar, + sBytes, + sLazyBytes, + sShortBytes, + sUTF16, + sFillerMax, + sBool, + sUTF8Max, + eUTF8, +#ifdef ETA_VERSION + trampolineEncoding, +#endif + ) where + +import PlutusCore.Flat.Encoder.Prim (eFalseF, eTrueF) +import PlutusCore.Flat.Encoder.Size (arrayBits) +import PlutusCore.Flat.Encoder.Strict +import PlutusCore.Flat.Encoder.Types (NumBits, Size) + +#if ! MIN_VERSION_base(4,11,0) +import Data.Semigroup ((<>)) +#endif diff --git a/plutus-core/flat/src/PlutusCore/Flat/Encoder/Prim.hs b/plutus-core/flat/src/PlutusCore/Flat/Encoder/Prim.hs new file mode 100644 index 00000000000..f940883f3eb --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Encoder/Prim.hs @@ -0,0 +1,541 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- |Encoding Primitives +module PlutusCore.Flat.Encoder.Prim + ( + -- Primitives whose name starts with 'e' encode a value in place + eBits16F + , eBitsF + , eFloatF + , eDoubleF +#if ! defined (ETA_VERSION) + , eUTF16F +#endif + , eUTF8F + , eCharF + , eNaturalF + , eIntegerF + , eInt64F + , eInt32F + , eIntF + , eInt16F + , eInt8F + , eWordF + , eWord64F + , eWord32F + , eWord16F + , eBytesF + , eLazyBytesF + , eShortBytesF + , eWord8F + , eFillerF + , eBoolF + , eTrueF + , eFalseF + + , varWordF + + , updateWord8 + , w7l + + -- * Exported for testing only + , eWord32BEF + , eWord64BEF + , eWord32E + , eWord64E + ) where + +import Control.Monad +import Data.ByteString qualified as B +import Data.ByteString.Lazy qualified as L +import Data.ByteString.Lazy.Internal qualified as L +import Data.ByteString.Short.Internal qualified as SBS +import Data.Char +import Data.Primitive.ByteArray +import Data.Text qualified as T +import PlutusCore.Flat.Data.FloatCast +import PlutusCore.Flat.Encoder.Types +import PlutusCore.Flat.Endian +import PlutusCore.Flat.Memory +import PlutusCore.Flat.Types + +#if ! defined (ETA_VERSION) && ! MIN_VERSION_text(2,0,0) +import Data.Text.Array qualified as TA +import Data.Text.Internal qualified as TI +-- import Data.FloatCast +-- import Data.Primitive.ByteArray +-- import qualified Data.Text as T +#endif +import Data.Text.Encoding qualified as TE +import Foreign +import PlutusCore.Flat.Data.ZigZag +-- import Debug.Trace +#include "MachDeps.h" +-- traceShowId :: a -> a +-- traceShowId = id + +-- $setup +-- >>> import PlutusCore.Flat.Instances.Test +-- >>> import PlutusCore.Flat.Bits +-- >>> import PlutusCore.Flat.Encoder.Strict +-- >>> import Control.Monad +-- >>> let enc e = prettyShow $ encBits 256 (Encoding e) + +{-# INLINE eFloatF #-} +eFloatF :: Float -> Prim +eFloatF = eWord32BEF . floatToWord + +{-# INLINE eDoubleF #-} +eDoubleF :: Double -> Prim +eDoubleF = eWord64BEF . doubleToWord + +{-# INLINE eWord64BEF #-} +eWord64BEF :: Word64 -> Prim +eWord64BEF = eWord64E toBE64 + +{-# INLINE eWord32BEF #-} +eWord32BEF :: Word32 -> Prim +eWord32BEF = eWord32E toBE32 + +{-# INLINE eCharF #-} +eCharF :: Char -> Prim +eCharF = eWord32F . fromIntegral . ord + +{-# INLINE eWordF #-} +eWordF :: Word -> Prim +{-# INLINE eIntF #-} +eIntF :: Int -> Prim + +#if WORD_SIZE_IN_BITS == 64 +eWordF = eWord64F . (fromIntegral :: Word -> Word64) + +eIntF = eInt64F . (fromIntegral :: Int -> Int64) +#elif WORD_SIZE_IN_BITS == 32 +eWordF = eWord32F . (fromIntegral :: Word -> Word32) + +eIntF = eInt32F . (fromIntegral :: Int -> Int32) +#else +#error expected WORD_SIZE_IN_BITS to be 32 or 64 +#endif + +{-# INLINE eInt8F #-} +eInt8F :: Int8 -> Prim +eInt8F = eWord8F . zigZag + +{-# INLINE eInt16F #-} +eInt16F :: Int16 -> Prim +eInt16F = eWord16F . zigZag + +{-# INLINE eInt32F #-} +eInt32F :: Int32 -> Prim +eInt32F = eWord32F . zigZag + +{-# INLINE eInt64F #-} +eInt64F :: Int64 -> Prim +eInt64F = eWord64F . zigZag + +{-# INLINE eIntegerF #-} +eIntegerF :: Integer -> Prim +eIntegerF = eIntegralF . zigZag + +{-# INLINE eNaturalF #-} +eNaturalF :: Natural -> Prim +eNaturalF = eIntegralF . toInteger + +{-# INLINE eIntegralF #-} +eIntegralF :: (Bits t, Integral t) => t -> Prim +eIntegralF t = + let vs = w7l t + in eIntegralW vs + +w7l :: (Bits t, Integral t) => t -> [Word8] +w7l t = + let l = low7 t + t' = t `unsafeShiftR` 7 + in if t' == 0 + then [l] + else w7 l : w7l t' + where + {-# INLINE w7 #-} + --lowByte :: (Bits t, Num t) => t -> Word8 + w7 :: Word8 -> Word8 + w7 l = l .|. 0x80 + +-- | Encoded as: data NonEmptyList = Elem Word7 | Cons Word7 List +{-# INLINE eIntegralW #-} +eIntegralW :: [Word8] -> Prim +eIntegralW vs s@(S op _ o) + | o == 0 = foldM pokeWord' op vs >>= \op' -> return (S op' 0 0) + | otherwise = foldM (flip eWord8F) s vs + +{- +>>> enc $ \s0 -> eTrueF s0 >>= \s1 -> eWord8F 0 s1 >>= \s2 -> eTrueF s2 +"10000000 01" +-} + +{-# INLINE eWord8F #-} +eWord8F :: Word8 -> Prim +eWord8F t s@(S op _ o) + | o == 0 = pokeWord op t + | otherwise = eByteUnaligned t s + +{-# INLINE eWord32E #-} +eWord32E :: (Word32 -> Word32) -> Word32 -> Prim +eWord32E conv t (S op w o) + | o == 0 = pokeW conv op t >> skipBytes op 4 + | otherwise = + pokeW conv op (asWord32 w `unsafeShiftL` 24 .|. t `unsafeShiftR` o) >> + return (S (plusPtr op 4) (asWord8 t `unsafeShiftL` (8 - o)) o) + +{-# INLINE eWord64E #-} +eWord64E :: (Word64 -> Word64) -> Word64 -> Prim +eWord64E conv t (S op w o) + | o == 0 = poke64 conv op t >> skipBytes op 8 + | otherwise = + poke64 conv op (asWord64 w `unsafeShiftL` 56 .|. t `unsafeShiftR` o) >> + return (S (plusPtr op 8) (asWord8 t `unsafeShiftL` (8 - o)) o) + +{-# INLINE eWord16F #-} +eWord16F :: Word16 -> Prim +eWord16F = varWordF + +{-# INLINE eWord32F #-} +eWord32F :: Word32 -> Prim +eWord32F = varWordF + +{-# INLINE eWord64F #-} +eWord64F :: Word64 -> Prim +eWord64F = varWordF + +{-# INLINE varWordF #-} +varWordF :: (Bits t, Integral t) => t -> Prim +varWordF t s@(S _ _ o) + | o == 0 = varWord eByteAligned t s + | otherwise = varWord eByteUnaligned t s + +{-# INLINE varWord #-} +varWord :: (Bits t, Integral t) => (Word8 -> Prim) -> t -> Prim +varWord writeByte t s + | t < 128 = writeByte (fromIntegral t) s + | t < 16384 = varWord2_ writeByte t s + | t < 2097152 = varWord3_ writeByte t s + | otherwise = varWordN_ writeByte t s + where + {-# INLINE varWord2_ #-} + -- TODO: optimise, using a single Write16? + varWord2_ writeByte t s = + writeByte (fromIntegral t .|. 0x80) s >>= + writeByte (fromIntegral (t `unsafeShiftR` 7) .&. 0x7F) + {-# INLINE varWord3_ #-} + varWord3_ writeByte t s = + writeByte (fromIntegral t .|. 0x80) s >>= + writeByte (fromIntegral (t `unsafeShiftR` 7) .|. 0x80) >>= + writeByte (fromIntegral (t `unsafeShiftR` 14) .&. 0x7F) + +-- {-# INLINE varWordN #-} +varWordN_ :: (Bits t, Integral t) => (Word8 -> Prim) -> t -> Prim +varWordN_ writeByte = go + where + go !v !st = + let !l = low7 v + !v' = v `unsafeShiftR` 7 + in if v' == 0 + then writeByte l st + else writeByte (l .|. 0x80) st >>= go v' + +{-# INLINE low7 #-} +low7 :: (Integral a) => a -> Word8 +low7 t = fromIntegral t .&. 0x7F + +-- | Encode text as UTF8 and encode the result as an array of bytes +eUTF8F :: T.Text -> Prim +eUTF8F = eBytesF . TE.encodeUtf8 + +-- | Encode text as UTF16 and encode the result as an array of bytes +#if ! defined (ETA_VERSION) +eUTF16F :: T.Text -> Prim +#if MIN_VERSION_text(2,0,0) +eUTF16F = eBytesF . TE.encodeUtf16LE +#else +eUTF16F t = eFillerF >=> eUTF16F_ t + where + eUTF16F_ (TI.Text (TA.Array array) w16Off w16Len) s = + writeArray array (2 * w16Off) (2 * w16Len) (nextPtr s) +#endif +#endif + +-- |Encode a Lazy ByteString +eLazyBytesF :: L.ByteString -> Prim +eLazyBytesF bs = eFillerF >=> \s -> write bs (nextPtr s) + -- Single copy + where + write lbs op = do + case lbs of + L.Chunk h t -> writeBS h op >>= write t + L.Empty -> pokeWord op 0 + +{-# INLINE eShortBytesF #-} +eShortBytesF :: SBS.ShortByteString -> Prim +eShortBytesF bs = eFillerF >=> eShortBytesF_ bs + where + eShortBytesF_ :: SBS.ShortByteString -> Prim + eShortBytesF_ bs@(SBS.SBS arr) (S op _ 0) = writeArray arr 0 (SBS.length bs) op + eShortBytesF_ _ _ = error "impossible" + +-- data Array a = Array0 | Array1 a ... | Array255 ... +writeArray :: ByteArray# -> Int -> Int -> Ptr Word8 -> IO S +writeArray arr soff slen sop = do + op' <- go soff slen sop + pokeWord op' 0 + where + go !off !len !op + | len == 0 = return op + | otherwise = + let l = min 255 len + in pokeWord' op (fromIntegral l) >>= pokeByteArray arr off l >>= + go (off + l) (len - l) + +eBytesF :: B.ByteString -> Prim +eBytesF bs = eFillerF >=> eBytesF_ + where + eBytesF_ s = do + op' <- writeBS bs (nextPtr s) + pokeWord op' 0 + +-- |Encode up to 9 bits +{-# INLINE eBits16F #-} +eBits16F :: NumBits -> Word16 -> Prim +--eBits16F numBits code | numBits >8 = eBitsF (numBits-8) (fromIntegral $ code `unsafeShiftR` 8) >=> eBitsF 8 (fromIntegral code) +-- eBits16F _ _ = eFalseF +eBits16F 9 code = + eBitsF 1 (fromIntegral $ code `unsafeShiftR` 8) >=> + eBitsF_ 8 (fromIntegral code) +eBits16F numBits code = eBitsF numBits (fromIntegral code) + +-- |Encode up to 8 bits. +{-# INLINE eBitsF #-} +eBitsF :: NumBits -> Word8 -> Prim +eBitsF 1 0 = eFalseF +eBitsF 1 1 = eTrueF +eBitsF 2 0 = eFalseF >=> eFalseF +eBitsF 2 1 = eFalseF >=> eTrueF +eBitsF 2 2 = eTrueF >=> eFalseF +eBitsF 2 3 = eTrueF >=> eTrueF +eBitsF n t = eBitsF_ n t + +{- +eBits Example: +Before: +n = 6 +t = 00.101011 +o = 3 +w = 111.00000 + +After: +[ptr] = w(111)t(10101) +w' = t(1)0000000 +o'= 1 + +o'=3+6=9 +f = 8-9 = -1 +o'' = 1 +8-o''=7 + +if n=8,o=3: +o'=11 +f=8-11=-3 +o''=3 +8-o''=5 +-} +-- {-# NOINLINE eBitsF_ #-} +eBitsF_ :: NumBits -> Word8 -> Prim +eBitsF_ n t (S op w o) = + let o' = o + n -- used bits + f = 8 - o' -- remaining free bits + in if | f > 0 -> return $ S op (w .|. (t `unsafeShiftL` f)) o' + | f == 0 -> pokeWord op (w .|. t) + | otherwise -> + let o'' = -f + in poke op (w .|. (t `unsafeShiftR` o'')) >> + return (S (plusPtr op 1) (t `unsafeShiftL` (8 - o'')) o'') + +{-# INLINE eBoolF #-} +eBoolF :: Bool -> Prim +eBoolF False = eFalseF +eBoolF True = eTrueF + +-- | >>> enc eTrueF +-- "1" +{-# INLINE eTrueF #-} +eTrueF :: Prim +eTrueF (S op w o) + | o == 7 = pokeWord op (w .|. 1) + | otherwise = return (S op (w .|. 128 `unsafeShiftR` o) (o + 1)) + +-- | >>> enc eFalseF +-- "0" +{-# INLINE eFalseF #-} +eFalseF :: Prim +eFalseF (S op w o) + | o == 7 = pokeWord op w + | otherwise = return (S op w (o + 1)) + +{- | + +>>> enc $ eTrueF >=> eFillerF +"10000001" + +>>> enc eFillerF +"00000001" +-} +{-# INLINE eFillerF #-} +eFillerF :: Prim +eFillerF (S op w _) = pokeWord op (w .|. 1) + +-- {-# INLINE poke16 #-} +-- TODO TEST +-- poke16 :: Word16 -> Prim +-- poke16 t (S op w o) | o == 0 = poke op w >> skipBytes op 2 +{- +To be used only when usedBits /= 0 + +>>> enc (eFalseF >=> eFalseF >=> eByteUnaligned 255) +"00111111 11" +-} +{-# INLINE eByteUnaligned #-} +eByteUnaligned :: Word8 -> Prim +eByteUnaligned t (S op w o) = + poke op (w .|. (t `unsafeShiftR` o)) >> + return (S (plusPtr op 1) (t `unsafeShiftL` (8 - o)) o) + +{- To be used only when usedBits = 0 + +>>> enc (eFalseF >=> eFalseF >=> eFalseF >=> eByteAligned 255) +"11111111" +-} +{-# INLINE eByteAligned #-} +eByteAligned :: Word8 -> Prim +eByteAligned t (S op _ _) = pokeWord op t + +{-| +>>> enc $ \s-> eWord8F 0 s >>= updateWord8 255 s +"11111111" + +>>> enc $ \s0 -> eTrueF s0 >>= \s1 -> eWord8F 255 s1 >>= eWord8F 255 >>= updateWord8 0 s1 +"10000000 01111111 1" + +>>> enc $ \s0 -> eFalseF s0 >>= \s1 -> eWord8F 0 s1 >>= updateWord8 255 s1 +"01111111 1" + +>>> enc $ \s0 -> eFalseF s0 >>= \s1 -> eWord8F 0 s1 >>= updateWord8 255 s1 >>= eFalseF +"01111111 10" + +>>> enc $ \s0 -> eTrueF s0 >>= \s1 -> eWord8F 255 s1 >>= eTrueF >>= updateWord8 0 s1 >>= eTrueF +"10000000 011" + +@since 0.5 +-} +updateWord8 :: Word8 -> S -> Prim +updateWord8 t mem s = do + uncache s + pokeWord8 t mem + cache s + +uncache :: S -> IO () +uncache s = poke (nextPtr s) (currByte s) + +cache :: Prim +cache s = do + w <- (mask s .&.) <$> peek (nextPtr s) + return $ s {currByte = w} + +mask :: S -> Word8 +mask s = 255 `unsafeShiftL` (8 - usedBits s) + +{-# INLINE pokeWord8 #-} +pokeWord8 :: Word8 -> S -> IO () +pokeWord8 t (S op _ 0) = poke op t +pokeWord8 t (S op w o) = do + poke op (w .|. (t `unsafeShiftR` o)) + let op' :: Ptr Word8 = plusPtr op 1 + v :: Word8 <- peek op' + poke op' (t `unsafeShiftL` (8 - o) .|. ((v `unsafeShiftL` o) `unsafeShiftR` o)) + +-- | o == 0 = pokeByteAligned t s +-- | otherwise = pokeByteUnaligned t s +-- where +-- {-# INLINE pokeByteUnaligned #-} +-- pokeByteUnaligned :: Word8 -> S -> IO () +-- pokeByteUnaligned t (S op w o) = do +-- let op' = plusPtr op 1 +-- poke op (w .|. (t `unsafeShiftR` o)) +-- v :: Word8 <- peek op' +-- poke op' (t `unsafeShiftL` (8 - o) .|. ((v `unsafeShiftL` o) `unsafeShiftR` o)) + +-- {-# INLINE pokeByteAligned #-} +-- pokeByteAligned :: Word8 -> S -> IO () +-- pokeByteAligned t (S op _ _) = poke op t + +-- FIX: not really pokes + +{-# INLINE pokeWord #-} +pokeWord :: Storable a => Ptr a -> a -> IO S +pokeWord op w = poke op w >> skipByte op + +{-# INLINE pokeWord' #-} +pokeWord' :: Storable a => Ptr a -> a -> IO (Ptr b) +pokeWord' op w = poke op w >> return (plusPtr op 1) + +{-# INLINE pokeW #-} +pokeW :: Storable a => (t -> a) -> Ptr a1 -> t -> IO () +pokeW conv op t = poke (castPtr op) (conv t) + +{-# INLINE poke64 #-} +poke64 :: (t -> Word64) -> Ptr a -> t -> IO () +poke64 conv op t = poke (castPtr op) (conv t) +-- poke64 conv op t = poke (castPtr op) (fix64 . conv $ t) + +{-# INLINE skipByte #-} +skipByte :: Monad m => Ptr a -> m S +skipByte op = return (S (plusPtr op 1) 0 0) + +{-# INLINE skipBytes #-} +skipBytes :: Monad m => Ptr a -> Int -> m S +skipBytes op n = return (S (plusPtr op n) 0 0) + +--{-# INLINE nextByteW #-} +--nextByteW op w = return (S (plusPtr op 1) 0 0) +writeBS :: B.ByteString -> Ptr Word8 -> IO (Ptr Word8) +writeBS bs op -- @(BS.PS foreignPointer sourceOffset sourceLength) op + | B.length bs == 0 = return op + | otherwise = + let (h, t) = B.splitAt 255 bs + in pokeWord' op (fromIntegral $ B.length h :: Word8) >>= pokeByteString h >>= + writeBS t + -- 2X slower (why?) + -- withForeignPtr foreignPointer goS + -- where + -- goS sourcePointer = go op (sourcePointer `plusPtr` sourceOffset) sourceLength + -- where + -- go !op !off !len | len == 0 = return op + -- | otherwise = do + -- let l = min 255 len + -- op' <- pokeWord' op (fromIntegral l) + -- BS.memcpy op' off l + -- go (op' `plusPtr` l) (off `plusPtr` l) (len-l) + +{-# INLINE asWord64 #-} +asWord64 :: Integral a => a -> Word64 +asWord64 = fromIntegral + +{-# INLINE asWord32 #-} +asWord32 :: Integral a => a -> Word32 +asWord32 = fromIntegral + +{-# INLINE asWord8 #-} +asWord8 :: Integral a => a -> Word8 +asWord8 = fromIntegral diff --git a/plutus-core/flat/src/PlutusCore/Flat/Encoder/Size.hs b/plutus-core/flat/src/PlutusCore/Flat/Encoder/Size.hs new file mode 100644 index 00000000000..fe636d4c193 --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Encoder/Size.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE CPP #-} + +-- |Primitives to calculate the maximum size in bits of the encoding of a value +module PlutusCore.Flat.Encoder.Size where + +import Data.Bits (Bits) +import Data.ByteString qualified as B +import Data.ByteString.Lazy qualified as L +import Data.ByteString.Short.Internal qualified as SBS +import Data.Char (ord) +import Data.Text qualified as T +import Data.Text.Internal qualified as TI +import PlutusCore.Flat.Data.ZigZag (ZigZag (zigZag)) +import PlutusCore.Flat.Encoder.Prim (w7l) +import PlutusCore.Flat.Types (Int16, Int32, Int64, Natural, NumBits, Text, Word16, Word32, Word64) +#include "MachDeps.h" +-- A filler can take anything from 1 to 8 bits +sFillerMax :: NumBits +sFillerMax = 8 + +sBool :: NumBits +sBool = 1 + +sWord8 :: NumBits +sWord8 = 8 + +sInt8 :: NumBits +sInt8 = 8 + +sFloat :: NumBits +sFloat = 32 + +sDouble :: NumBits +sDouble = 64 + +{-# INLINE sChar #-} +sChar :: Char -> NumBits +sChar = sWord32 . fromIntegral . ord + +sCharMax :: NumBits +sCharMax = 24 + +{-# INLINE sWord #-} +sWord :: Word -> NumBits +{-# INLINE sInt #-} +sInt :: Int -> NumBits +#if WORD_SIZE_IN_BITS == 64 +sWord = sWord64 . fromIntegral + +sInt = sInt64 . fromIntegral +#elif WORD_SIZE_IN_BITS == 32 +sWord = sWord32 . fromIntegral + +sInt = sInt32 . fromIntegral +#else +#error expected WORD_SIZE_IN_BITS to be 32 or 64 +#endif +-- TODO: optimize ints sizes +{-# INLINE sInt16 #-} +sInt16 :: Int16 -> NumBits +sInt16 = sWord16 . zigZag + +{-# INLINE sInt32 #-} +sInt32 :: Int32 -> NumBits +sInt32 = sWord32 . zigZag + +{-# INLINE sInt64 #-} +sInt64 :: Int64 -> NumBits +sInt64 = sWord64 . zigZag + +{-# INLINE sWord16 #-} +sWord16 :: Word16 -> NumBits +sWord16 w + | w < 128 = 8 + | w < 16384 = 16 + | otherwise = 24 + +{-# INLINE sWord32 #-} +sWord32 :: Word32 -> NumBits +sWord32 w + | w < 128 = 8 + | w < 16384 = 16 + | w < 2097152 = 24 + | w < 268435456 = 32 + | otherwise = 40 + +{-# INLINE sWord64 #-} +sWord64 :: Word64 -> NumBits +sWord64 w + | w < 128 = 8 + | w < 16384 = 16 + | w < 2097152 = 24 + | w < 268435456 = 32 + | w < 34359738368 = 40 + | w < 4398046511104 = 48 + | w < 562949953421312 = 56 + | w < 72057594037927936 = 64 + | w < 9223372036854775808 = 72 + | otherwise = 80 + +{-# INLINE sInteger #-} +sInteger :: Integer -> NumBits +sInteger = sIntegral . zigZag + +{-# INLINE sNatural #-} +sNatural :: Natural -> NumBits +sNatural = sIntegral . toInteger + +-- BAD: duplication of work with encoding +{-# INLINE sIntegral #-} +sIntegral :: (Bits t, Integral t) => t -> Int +sIntegral t = + let vs = w7l t + in length vs * 8 + +{-# INLINE sUTF8Max #-} +sUTF8Max :: Text -> NumBits +sUTF8Max (TI.Text _ _ lenInUnits) = + let len = +#if MIN_VERSION_text(2,0,0) + -- UTF-8 encoding, units are bytes + lenInUnits +#else + -- UTF-16 encoding, units are 16 bits words + -- worst case: a utf-16 unit becomes a 3 bytes utf-8 encoding + lenInUnits * 3 +#endif + in blobBits len + +{-# INLINE sUTF16Max #-} +sUTF16Max :: T.Text -> NumBits +sUTF16Max (TI.Text _ _ lenInUnits) = + let len = +#if MIN_VERSION_text(2,0,0) + -- UTF-8 encoding + -- worst case, a 1 byte UTF-8 char becomes a 2 bytes UTF-16 (ascii) + lenInUnits * 2 +#else + -- UTF-16 encoding + lenInUnits * 2 +#endif + in blobBits len + +{-# INLINE sBytes #-} +sBytes :: B.ByteString -> NumBits +sBytes = blobBits . B.length + +{-# INLINE sLazyBytes #-} +sLazyBytes :: L.ByteString -> NumBits +sLazyBytes bs = 16 + L.foldrChunks (\b l -> blkBitsBS b + l) 0 bs + +{-# INLINE sShortBytes #-} +sShortBytes :: SBS.ShortByteString -> NumBits +sShortBytes = blobBits . SBS.length + +{-# INLINE bitsToBytes #-} +bitsToBytes :: Int -> Int +bitsToBytes = numBlks 8 + +{-# INLINE numBlks #-} +numBlks :: Integral t => t -> t -> t +numBlks blkSize bits = + let (d, m) = bits `divMod` blkSize + in d + + (if m == 0 + then 0 + else 1) + +{-# INLINE arrayBits #-} +arrayBits :: Int -> NumBits +arrayBits = (8 *) . arrayChunks + +{-# INLINE arrayChunks #-} +arrayChunks :: Int -> NumBits +arrayChunks = (1 +) . numBlks 255 + +{-# INLINE blobBits #-} +blobBits :: Int -> NumBits +blobBits numBytes = + 16 -- initial filler + final 0 + + + blksBits numBytes + +{-# INLINE blkBitsBS #-} +blkBitsBS :: B.ByteString -> NumBits +blkBitsBS = blksBits . B.length + +{-# INLINE blksBits #-} +blksBits :: Int -> NumBits +blksBits numBytes = 8 * (numBytes + numBlks 255 numBytes) diff --git a/plutus-core/flat/src/PlutusCore/Flat/Encoder/Strict.hs b/plutus-core/flat/src/PlutusCore/Flat/Encoder/Strict.hs new file mode 100644 index 00000000000..28738e286da --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Encoder/Strict.hs @@ -0,0 +1,324 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- |Strict encoder +module PlutusCore.Flat.Encoder.Strict where + +import Control.Monad (when) +import Data.ByteString qualified as B +import Data.ByteString.Lazy qualified as L +import Data.Foldable +import PlutusCore.Flat.Encoder.Prim +import PlutusCore.Flat.Encoder.Size qualified as S +import PlutusCore.Flat.Encoder.Types +import PlutusCore.Flat.Memory +import PlutusCore.Flat.Types + +-- import Data.Semigroup +-- import Data.Semigroup (Semigroup (..)) + +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup (Semigroup (..)) +#endif + +#ifdef ETA_VERSION +-- import Data.Function(trampoline) +import GHC.IO (trampolineIO) +trampolineEncoding :: Encoding -> Encoding +trampolineEncoding (Encoding op) = Encoding (\s -> trampolineIO (op s)) +#else + +-- trampolineIO = id +#endif + +-- |Strict encoder +strictEncoder :: NumBits -> Encoding -> B.ByteString +strictEncoder numBits enc = + let (bs,numBitsUsed) = strictEncoderPartial numBits enc + bitsInLastByte = numBitsUsed `mod` 8 + in if bitsInLastByte /=0 + then error $ unwords ["encoder: did not end on byte boundary, bits used in last byte=",show bitsInLastByte] + else bs + +numEncodedBits :: Int -> Encoding -> NumBits +numEncodedBits numBits enc =snd $ strictEncoderPartial numBits enc + +strictEncoderPartial :: + Int -- ^ the maximum size in bits of the encoding + -> Encoding -- ^ the encoder + -> (B.ByteString, NumBits) -- ^ the encoded bytestring + the actual number of encoded bits +strictEncoderPartial numBits (Encoding op) + = let bufSize = S.bitsToBytes numBits + in unsafeCreateUptoN' bufSize $ \ptr -> do + S{..} <- op (S ptr 0 0) + let numBitsUsed = nextPtr `minusPtr` ptr * 8 + usedBits + when (numBitsUsed > numBits) $ error $ unwords ["encoder: size mismatch, expected <=",show numBits,"actual=",show numBitsUsed,"bits"] + return (nextPtr `minusPtr` ptr,numBitsUsed) + +newtype Encoding = + Encoding + { run :: Prim + } + +instance Show Encoding where + show _ = "Encoding" + +instance Semigroup Encoding where + {-# INLINE (<>) #-} + (<>) = encodingAppend + +instance Monoid Encoding where + {-# INLINE mempty #-} + mempty = Encoding return + +#if !(MIN_VERSION_base(4,11,0)) + {-# INLINE mappend #-} + mappend = encodingAppend +#endif + + {-# INLINE mconcat #-} + mconcat = foldl' mappend mempty + +{-# INLINE encodingAppend #-} +encodingAppend :: Encoding -> Encoding -> Encoding +encodingAppend (Encoding f) (Encoding g) = Encoding m + where + m s@(S !_ !_ !_) = do + !s1 <- f s + g s1 + +-- PROB: GHC 8.02 won't always apply the rules leading to poor execution times (e.g. with lists) +-- TODO: check with newest GHC versions +{-# RULES +"encodersSN" forall h t . encodersS (h : t) = + h `mappend` encodersS t +"encodersS0" encodersS [] = mempty + #-} + +{-# NOINLINE encodersS #-} +encodersS :: [Encoding] -> Encoding +-- Without the explicit parameter the rules won't fire! +encodersS ws = foldl' mappend mempty ws + +sizeListWith :: (Foldable t1, Num t2) => (t3 -> t2 -> t2) -> t1 t3 -> t2 -> t2 +sizeListWith size l sz = foldl' (\s e -> size e (s + 1)) (sz + 1) l +{-# INLINE sizeListWith #-} + +-- encodersS ws = error $ unwords ["encodersS CALLED",show ws] +{-# INLINE encodeListWith #-} +-- |Encode as a List +encodeListWith :: (t -> Encoding) -> [t] -> Encoding +encodeListWith enc = go + where + go [] = eFalse + go (x:xs) = eTrue <> enc x <> go xs + +-- {-# INLINE encodeList #-} +-- encodeList :: (Foldable t, Flat a) => t a -> Encoding +-- encodeList l = F.foldl' (\acc a -> acc <> eTrue <> encode a) mempty l <> eFalse +-- {-# INLINE encodeList2 #-} +-- encodeList2 :: (Foldable t, Flat a) => t a -> Encoding +-- encodeList2 l = foldr (\a acc -> eTrue <> encode a <> acc) mempty l <> eFalse +{-# INLINE encodeArrayWith #-} +-- |Encode as Array +encodeArrayWith :: (t -> Encoding) -> [t] -> Encoding +encodeArrayWith _ [] = eWord8 0 +encodeArrayWith f ws = Encoding $ go ws + where + go l s = do + -- write a placeholder for the number of elements in current block + s' <- eWord8F 0 s + (n, sn, l) <- gol l 0 s' + -- update actual number of elements + s'' <- updateWord8 n s sn + if null l + then eWord8F 0 s'' + else go l s'' + -- encode up to 255 elements and returns (numberOfWrittenElements,elementsLeftToWrite,currentState) + gol [] !n !s = return (n, s, []) + gol l@(x:xs) !n !s + | n == 255 = return (255, s, l) + | otherwise = run (f x) s >>= gol xs (n + 1) + +-- Encoding primitives +{-# INLINE eChar #-} +{-# INLINE eUTF8 #-} +{-# INLINE eNatural #-} +{-# INLINE eFloat #-} +{-# INLINE eDouble #-} +{-# INLINE eInteger #-} +{-# INLINE eInt64 #-} +{-# INLINE eInt32 #-} +{-# INLINE eInt16 #-} +{-# INLINE eInt8 #-} +{-# INLINE eInt #-} +{-# INLINE eWord64 #-} +{-# INLINE eWord32 #-} +{-# INLINE eWord16 #-} +{-# INLINE eWord8 #-} +{-# INLINE eWord #-} +{-# INLINE eBits #-} +{-# INLINE eFiller #-} +{-# INLINE eBool #-} +{-# INLINE eTrue #-} +{-# INLINE eFalse #-} +eChar :: Char -> Encoding +eChar = Encoding . eCharF + +#if! defined (ETA_VERSION) +{-# INLINE eUTF16 #-} +eUTF16 :: Text -> Encoding +eUTF16 = Encoding . eUTF16F +#endif + +eUTF8 :: Text -> Encoding +eUTF8 = Encoding . eUTF8F + +eBytes :: B.ByteString -> Encoding +eBytes = Encoding . eBytesF + +eLazyBytes :: L.ByteString -> Encoding +eLazyBytes = Encoding . eLazyBytesF + +eShortBytes :: ShortByteString -> Encoding +eShortBytes = Encoding . eShortBytesF + +eNatural :: Natural -> Encoding +eNatural = Encoding . eNaturalF + +eFloat :: Float -> Encoding +eFloat = Encoding . eFloatF + +eDouble :: Double -> Encoding +eDouble = Encoding . eDoubleF + +eInteger :: Integer -> Encoding +eInteger = Encoding . eIntegerF + +eInt64 :: Int64 -> Encoding +eInt64 = Encoding . eInt64F + +eInt32 :: Int32 -> Encoding +eInt32 = Encoding . eInt32F + +eInt16 :: Int16 -> Encoding +eInt16 = Encoding . eInt16F + +eInt8 :: Int8 -> Encoding +eInt8 = Encoding . eInt8F + +eInt :: Int -> Encoding +eInt = Encoding . eIntF + +eWord64 :: Word64 -> Encoding +eWord64 = Encoding . eWord64F + +eWord32 :: Word32 -> Encoding +eWord32 = Encoding . eWord32F + +eWord16 :: Word16 -> Encoding +eWord16 = Encoding . eWord16F + +eWord8 :: Word8 -> Encoding +eWord8 = Encoding . eWord8F + +eWord :: Word -> Encoding +eWord = Encoding . eWordF + +eBits16 :: NumBits -> Word16 -> Encoding +eBits16 n f = Encoding $ eBits16F n f + +eBits :: NumBits -> Word8 -> Encoding +eBits n f = Encoding $ eBitsF n f + +eFiller :: Encoding +eFiller = Encoding eFillerF + +eBool :: Bool -> Encoding +eBool = Encoding . eBoolF + +eTrue :: Encoding +eTrue = Encoding eTrueF + +eFalse :: Encoding +eFalse = Encoding eFalseF + +-- Size Primitives +-- Variable size +{-# INLINE vsize #-} +vsize :: (t -> NumBits) -> t -> NumBits -> NumBits +vsize !f !t !n = f t + n + +-- Constant size +{-# INLINE csize #-} +csize :: NumBits -> t -> NumBits -> NumBits +csize !n _ !s = n + s + +sChar :: Size Char +sChar = vsize S.sChar + +sInt64 :: Size Int64 +sInt64 = vsize S.sInt64 + +sInt32 :: Size Int32 +sInt32 = vsize S.sInt32 + +sInt16 :: Size Int16 +sInt16 = vsize S.sInt16 + +sInt8 :: Size Int8 +sInt8 = csize S.sInt8 + +sInt :: Size Int +sInt = vsize S.sInt + +sWord64 :: Size Word64 +sWord64 = vsize S.sWord64 + +sWord32 :: Size Word32 +sWord32 = vsize S.sWord32 + +sWord16 :: Size Word16 +sWord16 = vsize S.sWord16 + +sWord8 :: Size Word8 +sWord8 = csize S.sWord8 + +sWord :: Size Word +sWord = vsize S.sWord + +sFloat :: Size Float +sFloat = csize S.sFloat + +sDouble :: Size Double +sDouble = csize S.sDouble + +sBytes :: Size B.ByteString +sBytes = vsize S.sBytes + +sLazyBytes :: Size L.ByteString +sLazyBytes = vsize S.sLazyBytes + +sShortBytes :: Size ShortByteString +sShortBytes = vsize S.sShortBytes + +sNatural :: Size Natural +sNatural = vsize S.sNatural + +sInteger :: Size Integer +sInteger = vsize S.sInteger + +sUTF8Max :: Size Text +sUTF8Max = vsize S.sUTF8Max + +sUTF16 :: Size Text +sUTF16 = vsize S.sUTF16Max + +sFillerMax :: Size a +sFillerMax = csize S.sFillerMax + +sBool :: Size Bool +sBool = csize S.sBool diff --git a/plutus-core/flat/src/PlutusCore/Flat/Encoder/Types.hs b/plutus-core/flat/src/PlutusCore/Flat/Encoder/Types.hs new file mode 100644 index 00000000000..0bb167501f5 --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Encoder/Types.hs @@ -0,0 +1,25 @@ +-- |Encoder Types +module PlutusCore.Flat.Encoder.Types( + Size, + NumBits, + Prim, + S(..) +) where + +import GHC.Ptr (Ptr (..)) +import PlutusCore.Flat.Types + +-- |Add the maximum size in bits of the encoding of value a to a NumBits +type Size a = a -> NumBits -> NumBits + +-- |Strict encoder state +data S = + S + { nextPtr :: {-# UNPACK #-} !(Ptr Word8) + , currByte :: {-# UNPACK #-} !Word8 + , usedBits :: {-# UNPACK #-} !NumBits + } deriving Show + +-- |A basic encoder +type Prim = S -> IO S + diff --git a/plutus-core/flat/src/PlutusCore/Flat/Endian.hs b/plutus-core/flat/src/PlutusCore/Flat/Endian.hs new file mode 100644 index 00000000000..f16f1c09ad5 --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Endian.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE CPP #-} +-- | Endian utilities +-- +-- Exported for testing purposes, but not meant to be used outside this package. +module PlutusCore.Flat.Endian + ( + toBE32 + , toBE64 + , toBE16 + , isBigEndian + -- , fix64 + ) where + +#include "MachDeps.h" + +import Data.Word (Word16, Word32, Word64, byteSwap16, byteSwap32, byteSwap64) + +-- #ifdef ghcjs_HOST_OS +-- import Data.Bits +-- #endif + +-- $setup +-- >>> import Numeric (showHex) + +isBigEndian :: Bool +isBigEndian = +#if defined(WORDS_BIGENDIAN) || defined(ETA_VERSION) + True +#else + False +#endif + + +{- | +Convert a 64 bit value in cpu endianess to big endian + +>>> toBE64 0xF0F1F2F3F4F5F6F7 == if isBigEndian then 0xF0F1F2F3F4F5F6F7 else 0xF7F6F5F4F3F2F1F0 +True +-} +toBE64 :: Word64 -> Word64 +#if defined(WORDS_BIGENDIAN) || defined(ETA_VERSION) +toBE64 = id +#else +toBE64 = byteSwap64 +#endif + +{- | +Convert a 32 bit value in cpu endianess to big endian + +>>> toBE32 0xF0F1F2F3 == if isBigEndian then 0xF0F1F2F3 else 0xF3F2F1F0 +True +-} +toBE32 :: Word32 -> Word32 +#if defined(WORDS_BIGENDIAN) || defined(ETA_VERSION) +toBE32 = id +#else +toBE32 = byteSwap32 +#endif + +{- | +Convert a 16 bit value in cpu endianess to big endian + +>>> toBE16 0xF0F1 == if isBigEndian then 0xF0F1 else 0xF1F0 +True +-} +toBE16 :: Word16 -> Word16 +#if defined(WORDS_BIGENDIAN) || defined(ETA_VERSION) +toBE16 = id +#else +toBE16 = byteSwap16 +#endif diff --git a/plutus-core/flat/src/PlutusCore/Flat/Filler.hs b/plutus-core/flat/src/PlutusCore/Flat/Filler.hs new file mode 100644 index 00000000000..3a059194f6a --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Filler.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- |Pre-value and post-value byte alignments +module PlutusCore.Flat.Filler ( + Filler(..), + fillerLength, + PreAligned(..), + preAligned, + PostAligned(..), + postAligned, + preAlignedDecoder, + postAlignedDecoder + ) where + +import Control.DeepSeq (NFData) +import Data.Typeable (Typeable) +import PlutusCore.Flat.Class (Flat (..), Generic) +import PlutusCore.Flat.Decoder.Types (Get) +import PlutusCore.Flat.Encoder.Strict (eFiller, sFillerMax) + +-- |A meaningless sequence of 0 bits terminated with a 1 bit (easier to implement than the reverse) +-- +-- Used to align encoded values at byte/word boundaries. +data Filler = FillerBit !Filler + | FillerEnd + deriving (Show, Eq, Ord, Typeable, Generic, NFData) + +-- |Use a special encoding for the filler +instance Flat Filler where + encode _ = eFiller + size = sFillerMax + -- use generated decode + +-- |A Post aligned value, a value followed by a filler +-- +-- Useful to complete the encoding of a top-level value +#ifdef ETA_VERSION + +data PostAligned a = PostAligned { postValue :: a, postFiller :: Filler } + deriving (Show, Eq, Ord, Typeable, Generic, NFData) + +instance Flat a => Flat (PostAligned a) where + encode (PostAligned val fill) = trampolineEncoding (encode val) <> encode fill + +#else + +data PostAligned a = PostAligned { postValue :: a, postFiller :: Filler } + deriving (Show, Eq, Ord, Typeable, Generic, NFData,Flat) + +#endif + +-- |A Pre aligned value, a value preceded by a filler +-- +-- Useful to prealign ByteArrays, Texts and any structure that can be encoded more efficiently when byte aligned. +data PreAligned a = PreAligned { preFiller :: Filler, preValue :: a } + deriving (Show, Eq, Ord, Typeable, Generic, NFData, Flat) + +-- |Length of a filler in bits +fillerLength :: Num a => Filler -> a +fillerLength FillerEnd = 1 +fillerLength (FillerBit f) = 1 + fillerLength f + +-- |Post align a value +postAligned :: a -> PostAligned a +postAligned a = PostAligned a FillerEnd + +-- |Pre align a value +preAligned :: a -> PreAligned a +preAligned = PreAligned FillerEnd + +-- |Decode a value assuming that is PostAligned +postAlignedDecoder :: Get b -> Get b +postAlignedDecoder dec = do + v <- dec + _::Filler <- decode + return v + +-- |Decode a value assuming that is PreAligned +-- +-- @since 0.5 +preAlignedDecoder :: Get b -> Get b +preAlignedDecoder dec = do + _::Filler <- decode + dec diff --git a/plutus-core/flat/src/PlutusCore/Flat/Instances.hs b/plutus-core/flat/src/PlutusCore/Flat/Instances.hs new file mode 100644 index 00000000000..b0b3be035dc --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Instances.hs @@ -0,0 +1,15 @@ + +-- |Flat Instances for common data types from the packages on which `flat` has a dependency. +module PlutusCore.Flat.Instances + ( module X + ) +where + +import PlutusCore.Flat.Instances.Array () +import PlutusCore.Flat.Instances.Base () +import PlutusCore.Flat.Instances.ByteString () +import PlutusCore.Flat.Instances.Containers as X +import PlutusCore.Flat.Instances.DList () +import PlutusCore.Flat.Instances.Mono as X +import PlutusCore.Flat.Instances.Text as X +import PlutusCore.Flat.Instances.Unordered () diff --git a/plutus-core/flat/src/PlutusCore/Flat/Instances/Array.hs b/plutus-core/flat/src/PlutusCore/Flat/Instances/Array.hs new file mode 100644 index 00000000000..a27c0bb98f1 --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Instances/Array.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Flat instances for the `array` package +module PlutusCore.Flat.Instances.Array + () +where + +import Data.Array qualified as A +import Data.Array.IArray +import Data.Array.Unboxed qualified as U +import PlutusCore.Flat.Class +import PlutusCore.Flat.Decoder +import PlutusCore.Flat.Encoder +import PlutusCore.Flat.Instances.Base () +-- import PlutusCore.Flat.Instances.Util +import PlutusCore.Flat.Instances.Mono + +-- $setup +-- >>> :set -XFlexibleContexts +-- >>> import Flat.Instances.Test +-- >>> import Flat.Instances.Mono +-- >>> import qualified Data.Array as A +-- >>> import qualified Data.Array.Unboxed as U +-- >>> import Data.Array.IArray +-- >>> import Data.Word + +{-| +Array is encoded as (lowBound,highBound,AsArray (elems array)): + +>>> let arr = A.array ((1::Word,4::Word),(2,5)) [((1,4),11::Word),((1,5),22),((2,4),33),((2,5),44)] in tst (bounds arr,AsArray(elems arr)) == tst arr +True + +As it's easy to see: + +>>> tst $ A.array ((1::Word,4::Word),(2,5)) [((1,4),11::Word),((1,5),22),((2,4),33),((2,5),44)] +(True,80,[1,4,2,5,4,11,22,33,44,0]) + +>>> tst $ A.array ((1,4),(2,5)) [((1,4),"1.4"),((1,5),"1.5"),((2,4),"2.4"),((2,5),"2.5")] +(True,160,[2,8,4,10,4,152,203,166,137,140,186,106,153,75,166,137,148,186,106,0]) + +Arrays and Unboxed Arrays are encoded in the same way: + +>>> let bounds = ((1::Word,4::Word),(2,5));elems=[11::Word,22,33,44] in tst (U.listArray bounds elems :: U.UArray (Word,Word) Word) == tst (A.listArray bounds elems) +True +-} +instance (Flat i, Flat e, Ix i) => Flat (A.Array i e) where + size = sizeIArray + + encode = encodeIArray + + decode = decodeIArray + +instance (Flat i, Flat e, Ix i, IArray U.UArray e) => Flat (U.UArray i e) where + size = sizeIArray + + encode = encodeIArray + + decode = decodeIArray + +sizeIArray :: (IArray a e, Ix i, Flat e, Flat i) => a i e -> NumBits -> NumBits +sizeIArray arr = (sizeSequence . elems $ arr) . size (bounds arr) + +encodeIArray :: (Ix i, IArray a e, Flat i, Flat e) => a i e -> Encoding +encodeIArray arr = encode (bounds arr) <> encodeSequence (elems arr) + +decodeIArray :: (Ix i, IArray a e, Flat i, Flat e) => Get (a i e) +decodeIArray = listArray <$> decode <*> decodeSequence + +{-# INLINE sizeIArray #-} +{-# INLINE encodeIArray #-} +{-# INLINE decodeIArray #-} diff --git a/plutus-core/flat/src/PlutusCore/Flat/Instances/Base.hs b/plutus-core/flat/src/PlutusCore/Flat/Instances/Base.hs new file mode 100644 index 00000000000..453bf2dbda0 --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Instances/Base.hs @@ -0,0 +1,713 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} + +-- | Flat instances for the base library +module PlutusCore.Flat.Instances.Base () where + +import Control.Monad (liftM2) +import Data.Bool +import Data.Char +import Data.Complex (Complex (..)) +import Data.Fixed +-- #if MIN_VERSION_base(4,9,0) +import Data.List.NonEmpty qualified as B +-- #endif + +#if ! MIN_VERSION_base(4,8,0) +import Control.Applicative +import Data.Monoid (mempty) +#endif + +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup qualified as Semigroup +#endif + +import Data.Monoid qualified as Monoid +import Data.Ratio +import PlutusCore.Flat.Instances.Util +import Prelude hiding (mempty) + +-- #if !MIN_VERSION_base(4,9,0) +-- import Data.Monoid ((<>)) +-- #endif + +#if MIN_VERSION_base(4,9,0) +import Data.Functor.Identity (Identity (..)) +#endif + +-- #if !MIN_VERSION_base(4,9,0) +-- deriving instance Generic (Complex a) +-- #endif + +{- ORMOLU_DISABLE -} +-- $setup +-- >>> :set -XNegativeLiterals -XTypeApplications +-- >>> import PlutusCore.Flat.Instances.Test +-- >>> import Data.Fixed +-- >>> import Data.Int +-- >>> import Data.Complex(Complex(..)) +-- >>> import Numeric.Natural +-- >>> import Data.Word +-- >>> import Data.Ratio +-- >>> import PlutusCore.Flat.Run +-- >>> import Data.Monoid +-- >>> import qualified Data.List.NonEmpty as B +-- >>> let test = tstBits +-- >>> let y = 33 +{- ORMOLU_ENABLE -} + +-- >>> y + +-- | @since 0.4.4 +#if MIN_VERSION_base(4,8,0) +instance Flat Monoid.All where + encode (Monoid.All a) = encode a + size (Monoid.All a) = size a + decode = Monoid.All <$> decode + +{- | + +>>> let w = Just (11::Word8); a = Alt w <> Alt (Just 24) in tst a == tst w +True + +>>> let w = Just (11::Word8); a = Alt Nothing <> Alt w in tst a == tst w +True + +@since 0.4.4 +-} +instance Flat (f a) => Flat (Monoid.Alt f a) where + encode (Monoid.Alt a) = encode a + size (Monoid.Alt a) = size a + decode = Monoid.Alt <$> decode +#endif + +#if MIN_VERSION_base(4,9,0) +-- | @since 0.4.4 +instance Flat a => Flat (Identity a) where + encode (Identity a) = encode a + size (Identity a) = size a + decode = Identity <$> decode +#endif + +-- | @since 0.4.4 +instance Flat a => Flat (Monoid.Dual a) where + encode (Monoid.Dual a) = encode a + size (Monoid.Dual a) = size a + decode = Monoid.Dual <$> decode + +-- | @since 0.4.4 +instance Flat Monoid.Any where + encode (Monoid.Any a) = encode a + size (Monoid.Any a) = size a + decode = Monoid.Any <$> decode + +-- | @since 0.4.4 +instance Flat a => Flat (Monoid.Sum a) where + encode (Monoid.Sum a) = encode a + size (Monoid.Sum a) = size a + decode = Monoid.Sum <$> decode + +-- | @since 0.4.4 +instance Flat a => Flat (Monoid.Product a) where + encode (Monoid.Product a) = encode a + size (Monoid.Product a) = size a + decode = Monoid.Product <$> decode + +#if MIN_VERSION_base(4,9,0) +-- | @since 0.4.4 +instance Flat a => Flat (Semigroup.Min a) where + encode (Semigroup.Min a) = encode a + size (Semigroup.Min a) = size a + decode = Semigroup.Min <$> decode + +-- | @since 0.4.4 +instance Flat a => Flat (Semigroup.Max a) where + encode (Semigroup.Max a) = encode a + size (Semigroup.Max a) = size a + decode = Semigroup.Max <$> decode + +-- | @since 0.4.4 +instance Flat a => Flat (Semigroup.First a) where + encode (Semigroup.First a) = encode a + size (Semigroup.First a) = size a + decode = Semigroup.First <$> decode + +-- | @since 0.4.4 +instance Flat a => Flat (Semigroup.Last a) where + encode (Semigroup.Last a) = encode a + size (Semigroup.Last a) = size a + decode = Semigroup.Last <$> decode +#endif + +{- | +`()`, as all data types with a single constructor, has a zero-length encoding. + +>>> test () +(True,0,"") +-} +instance Flat () where + encode _ = mempty + + size _ = id + + decode = pure () + +{- | +One bit is plenty for a Bool. + +>>> test False +(True,1,"0") + +>>> test True +(True,1,"1") +-} +instance Flat Bool where + encode = eBool + + size = sBool + + decode = dBool + +{- | +Char's are mapped to Word32 and then encoded. + +For ascii characters, the encoding is standard ascii. + +>>> test 'a' +(True,8,"01100001") + +For unicode characters, the encoding is non standard. + +>>> test 'È' +(True,16,"11001000 00000001") + +>>> test '不' +(True,24,"10001101 10011100 00000001") + +#ifndef ETA +>>> test "\x1F600" +(True,26,"11000000 01110110 00000011 10") +#endif +-} +instance Flat Char where + size = sChar + + encode = eChar + + decode = dChar + +{- | +>>> test (Nothing::Maybe Bool) +(True,1,"0") + +>>> test (Just False::Maybe Bool) +(True,2,"10") +-} +instance Flat a => Flat (Maybe a) + +{- | +>>> test (Left False::Either Bool ()) +(True,2,"00") + +>>> test (Right ()::Either Bool ()) +(True,1,"1") +-} +instance (Flat a, Flat b) => Flat (Either a b) + +{- | +>>> test (MkFixed 123 :: Fixed E0) +(True,16,"11110110 00000001") + +>>> test (MkFixed 123 :: Fixed E0) == test (MkFixed 123 :: Fixed E2) +True +-} +instance Flat (Fixed a) where + encode (MkFixed n) = encode n + + size (MkFixed n) = size n + + decode = MkFixed <$> decode + +{- | +Word8 always take 8 bits. + +>>> test (0::Word8) +(True,8,"00000000") + +>>> test (255::Word8) +(True,8,"11111111") +-} +instance Flat Word8 where + encode = eWord8 + + decode = dWord8 + + size = sWord8 + +{- | +Natural, Word, Word16, Word32 and Word64 are encoded as a non empty list of 7 bits chunks (least significant chunk first and most significant bit first in every chunk). + +Words are always encoded in a whole number of bytes, as every chunk is 8 bits long (1 bit for the List constructor, plus 7 bits for the value). + +The actual definition is: + +@ +Word64 ≡ Word64 Word + +Word32 ≡ Word32 Word + +Word16 ≡ Word16 Word + +Word ≡ Word (LeastSignificantFirst (NonEmptyList (MostSignificantFirst Word7))) + +LeastSignificantFirst a ≡ LeastSignificantFirst a + +NonEmptyList a ≡ Elem a + | Cons a (NonEmptyList a) + +MostSignificantFirst a ≡ MostSignificantFirst a + +Word7 ≡ V0 + | V1 + | V2 + ... + | V127 +@ + +Values between as 0 and 127 fit in a single byte. + +127 (0b1111111) is represented as Elem V127 and encoded as: Elem=0 127=1111111 + +>>> test (127::Word) +(True,8,"01111111") + +254 (0b11111110) is represented as Cons V126 (Elem V1) (254=128+126) and encoded as: Cons=1 V126=1111110 (Elem=0 V1=0000001): + +>>> test (254::Word) +(True,16,"11111110 00000001") + +Another example, 32768 (Ob1000000000000000 = 0000010 0000000 0000000): + +>>> test (32768::Word32) +(True,24,"10000000 10000000 00000010") + +As this is a variable length encoding, values are encoded in the same way, whatever their type: + +>>> all (test (3::Word) ==) [test (3::Word16),test (3::Word32),test (3::Word64)] +True + + +Word/Int decoders return an error if the encoded value is outside their valid range: + +>>> unflat @Word16 (flat @Word32 $ fromIntegral @Word16 maxBound) +Right 65535 + +>>> unflat @Word16 (flat @Word32 $ fromIntegral @Word16 maxBound + 1) +Left (BadEncoding ... + +>>> unflat @Word32 (flat @Word64 $ fromIntegral @Word32 maxBound) +Right 4294967295 + +>>> unflat @Word32 (flat @Word64 $ fromIntegral @Word32 maxBound + 1) +Left (BadEncoding ... + +>>> unflat @Word64 (flat @Natural $ fromIntegral @Word64 maxBound) +Right 18446744073709551615 + +>>> unflat @Word64 (flat @Natural $ fromIntegral @Word64 maxBound + 1) +Left (BadEncoding ... + + + +>>> unflat @Int16 (flat @Int32 $ fromIntegral @Int16 maxBound) +Right 32767 + +>>> unflat @Int16 (flat @Int32 $ fromIntegral @Int16 maxBound + 1) +Left (BadEncoding ... + +>>> unflat @Int32 (flat @Int64 $ fromIntegral @Int32 maxBound) +Right 2147483647 + +>>> unflat @Int32 (flat @Int64 $ fromIntegral @Int32 maxBound + 1) +Left (BadEncoding ... + +>>> unflat @Int64 (flat @Integer $ fromIntegral @Int64 maxBound) +Right 9223372036854775807 + +>>> unflat @Int64 (flat @Integer $ fromIntegral @Int64 maxBound + 1) +Left (BadEncoding ... + + +>>> unflat @Int16 (flat @Int32 $ fromIntegral @Int16 minBound) +Right (-32768) + +>>> unflat @Int16 (flat @Int32 $ fromIntegral @Int16 minBound - 1) +Left (BadEncoding ... + +>>> unflat @Int32 (flat @Int64 $ fromIntegral @Int32 minBound) +Right (-2147483648) + +>>> unflat @Int32 (flat @Int64 $ fromIntegral @Int32 minBound - 1) +Left (BadEncoding ... + +>>> unflat @Int64 (flat @Integer $ fromIntegral @Int64 minBound) +Right (-9223372036854775808) + +>>> unflat @Int64 (flat @Integer $ fromIntegral @Int64 minBound - 1) +Left (BadEncoding ... +-} +instance Flat Word where + size = sWord + + encode = eWord + + decode = dWord + +{- | +Naturals are encoded just as the fixed size Words. + +>>> test (0::Natural) +(True,8,"00000000") + +>>> test (2^120::Natural) +(True,144,"10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 00000010") +-} +instance Flat Natural where + size = sNatural + + encode = eNatural + + decode = dNatural + +instance Flat Word16 where + encode = eWord16 + + decode = dWord16 + + size = sWord16 + +instance Flat Word32 where + encode = eWord32 + + decode = dWord32 + + size = sWord32 + +instance Flat Word64 where + encode = eWord64 + + decode = dWord64 + + size = sWord64 + +{- | +Integer, Int, Int16, Int32 and Int64 are defined as the encoded version of the equivalent unsigned Word: + +@ +Int ≡ Int (ZigZag Word) + +Int64 ≡ Int64 (ZigZag Word64) + +Int32 ≡ Int32 (ZigZag Word32) + +Int16 ≡ Int16 (ZigZag Word16) + +Int8 ≡ Int8 (ZigZag Word8) + +ZigZag a ≡ ZigZag a +@ + +ZigZag encoding alternates between positive and negative numbers, so that numbers whose absolute value is small can be encoded efficiently: + +>>> test (0::Int) +(True,8,"00000000") + +>>> test (-1::Int) +(True,8,"00000001") + +>>> test (1::Int) +(True,8,"00000010") + +>>> test (-2::Int) +(True,8,"00000011") + +>>> test (2::Int) +(True,8,"00000100") +-} +instance Flat Int where + size = sInt + + encode = eInt + + decode = dInt + +{- | +Integers are encoded just as the fixed size Ints. + +>>> test (0::Integer) +(True,8,"00000000") + +>>> test (-1::Integer) +(True,8,"00000001") + +>>> test (1::Integer) +(True,8,"00000010") + +>>> test (-(2^4)::Integer) +(True,8,"00011111") + +>>> test (2^4::Integer) +(True,8,"00100000") + +>>> test (-(2^120)::Integer) +(True,144,"11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 00000011") + +>>> test (2^120::Integer) +(True,144,"10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 00000100") +-} +instance Flat Integer where + size = sInteger + + encode = eInteger + + decode = dInteger + +{- | +>>> test (0::Int8) +(True,8,"00000000") + +>>> test (127::Int8) +(True,8,"11111110") + +>>> test (-128::Int8) +(True,8,"11111111") +-} +instance Flat Int8 where + encode = eInt8 + + decode = dInt8 + + size = sInt8 + +{- | +>>> test (0::Int16) +(True,8,"00000000") + +>>> test (1::Int16) +(True,8,"00000010") + +>>> test (-1::Int16) +(True,8,"00000001") + +>>> test (minBound::Int16) +(True,24,"11111111 11111111 00000011") + +equivalent to 0b1111111111111111 + +>>> test (maxBound::Int16) +(True,24,"11111110 11111111 00000011") + +equivalent to 0b1111111111111110 +-} +instance Flat Int16 where + size = sInt16 + + encode = eInt16 + + decode = dInt16 + +{- | +>>> test (0::Int32) +(True,8,"00000000") + +>>> test (minBound::Int32) +(True,40,"11111111 11111111 11111111 11111111 00001111") + +>>> test (maxBound::Int32) +(True,40,"11111110 11111111 11111111 11111111 00001111") +-} +instance Flat Int32 where + size = sInt32 + + encode = eInt32 + + decode = dInt32 + +{- | +>>> test (0::Int64) +(True,8,"00000000") + +>>> test (minBound::Int64) +(True,80,"11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 00000001") + +>>> test (maxBound::Int64) +(True,80,"11111110 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 00000001") +-} +instance Flat Int64 where + size = sInt64 + + encode = eInt64 + + decode = dInt64 + +{- | +Floats are encoded as standard IEEE binary32 values: + +@ +IEEE_754_binary32 ≡ IEEE_754_binary32 {sign :: Sign, + exponent :: MostSignificantFirst Bits8, + fraction :: MostSignificantFirst Bits23} +@ + +>>> test (0::Float) +(True,32,"00000000 00000000 00000000 00000000") + +>>> test (1.4012984643E-45::Float) +(True,32,"00000000 00000000 00000000 00000001") + +>>> test (1.1754942107E-38::Float) +(True,32,"00000000 01111111 11111111 11111111") +-} +instance Flat Float where + size = sFloat + + encode = eFloat + + decode = dFloat + +{- | +Doubles are encoded as standard IEEE binary64 values: + +@ +IEEE_754_binary64 ≡ IEEE_754_binary64 {sign :: Sign, + exponent :: MostSignificantFirst Bits11, + fraction :: MostSignificantFirst Bits52} +@ +-} +instance Flat Double where + size = sDouble + + encode = eDouble + + decode = dDouble + +{- | +>>> test (4 :+ 2 :: Complex Word8) +(True,16,"00000100 00000010") +-} +instance Flat a => Flat (Complex a) + +{- | +Ratios are encoded as tuples of (numerator,denominator) + +>>> test (3%4::Ratio Word8) +(True,16,"00000011 00000100") +-} +instance (Integral a, Flat a) => Flat (Ratio a) where + size a = size (numerator a, denominator a) + + encode a = encode (numerator a, denominator a) + + -- decode = uncurry (%) <$> decode + decode = liftM2 (%) decode decode + +{- | +>>> test ([]::[Bool]) +(True,1,"0") + +>>> test [False,False] +(True,5,"10100") + +This instance and other similar ones are declared as @OVERLAPPABLE@, because for better encoding/decoding +performance it can be useful to declare instances of concrete types, such as @[Char]@ (not provided out of the box). +-} +instance {-# OVERLAPPABLE #-} Flat a => Flat [a] + +{- +>>> import Weigh +>>> flat [1..10::Int] +-} + + +-- Generic list instance (stack overflows with ETA, see https://github.com/typelead/eta/issues/901) +-- where +--size [] n = n+1 +--size (h:t) n = trampoline size t (trampoline size h (n+1)) +-- size = sizeListWith size -- foldl' (\n e -> ) n +-- encode = error "BAD" +-- encode = trampoline . encodeListWith encode +-- decode = decodeListWith decode +-- sizeListWith siz l n = foldl' (\n e -> 1 + n + siz e 0) n l +-- #ifdef ETA_VERSION +-- import Data.Function(trampoline) +-- import GHC.IO(trampolineIO) +-- #else +-- trampoline = id +-- trampolineIO = id +-- #endif + +-- #if MIN_VERSION_base(4,9,0) + +{- | +>>> test (B.fromList [True]) +(True,2,"10") + +>>> test (B.fromList [False,False]) +(True,4,"0100") +-} +instance {-# OVERLAPPABLE #-} Flat a => Flat (B.NonEmpty a) + +-- #endif + +{- | +Tuples are supported up to 7 elements. + +>>> test (False,()) +(True,1,"0") + +>>> test ((),()) +(True,0,"") + +"7 elements tuples ought to be enough for anybody" (Bill Gates - apocryphal) + +>>> test (False,True,True,True,False,True,True) +(True,7,"0111011") + +tst (1::Int,"2","3","4","5","6","7","8") +...error +-} + +-- Not sure if these should be OVERLAPPABLE +instance {-# OVERLAPPABLE #-} (Flat a, Flat b) => Flat (a, b) + +instance {-# OVERLAPPABLE #-} (Flat a, Flat b, Flat c) => Flat (a, b, c) + +instance + {-# OVERLAPPABLE #-} + (Flat a, Flat b, Flat c, Flat d) => + Flat (a, b, c, d) + +instance + {-# OVERLAPPABLE #-} + (Flat a, Flat b, Flat c, Flat d, Flat e) => + Flat (a, b, c, d, e) + +instance + {-# OVERLAPPABLE #-} + (Flat a, Flat b, Flat c, Flat d, Flat e, Flat f) => + Flat (a, b, c, d, e, f) + +instance + {-# OVERLAPPABLE #-} + ( Flat a + , Flat b + , Flat c + , Flat d + , Flat e + , Flat f + , Flat g + ) => + Flat (a, b, c, d, e, f, g) diff --git a/plutus-core/flat/src/PlutusCore/Flat/Instances/ByteString.hs b/plutus-core/flat/src/PlutusCore/Flat/Instances/ByteString.hs new file mode 100644 index 00000000000..439b0d7e8ff --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Instances/ByteString.hs @@ -0,0 +1,88 @@ +-- | Flat instances for the bytestring library +{-# LANGUAGE NoMonomorphismRestriction #-} + +module PlutusCore.Flat.Instances.ByteString + () +where + +import Data.ByteString qualified as B +import Data.ByteString.Lazy qualified as L +import Data.ByteString.Short qualified as SBS +import PlutusCore.Flat.Class +import PlutusCore.Flat.Decoder +import PlutusCore.Flat.Encoder + +-- $setup +-- >>> import PlutusCore.Flat.Instances.Test +-- >>> import PlutusCore.Flat.Instances.Base +-- >>> import qualified Data.ByteString as B +-- >>> import qualified Data.ByteString.Lazy as L +-- >>> import qualified Data.ByteString.Short as SBS + +{-| +ByteString, ByteString.Lazy and ByteString.Short are all encoded as Prealigned Arrays: + +@ +PreAligned a ≡ PreAligned {preFiller :: Filler, preValue :: a} + +Filler ≡ FillerBit Filler + | FillerEnd + +Array v = A0 + | A1 v (Array v) + | A2 v v (Array v) + ... + | A255 ... (Array v) +@ + +That's to say as a byte-aligned sequence of blocks of up to 255 elements, with every block preceded by the count of the elements in the block and a final 0-length block. + +>>> tst (B.pack [11,22,33]) +(True,48,[1,3,11,22,33,0]) + +where: + +1= PreAlignment (takes a byte if we are already on a byte boundary) + +3= Number of bytes in ByteString + +11,22,33= Bytes + +0= End of Array + +>>> tst (B.pack []) +(True,16,[1,0]) + +Pre-alignment ensures that a ByteString always starts at a byte boundary: + +>>> tst ((False,True,False,B.pack [11,22,33])) +(True,51,[65,3,11,22,33,0]) + +All ByteStrings are encoded in the same way: + +>>> all (tst (B.pack [55]) ==) [tst (L.pack [55]),tst (SBS.pack [55])] +True +-} +instance Flat B.ByteString where + encode = eBytes + size = sBytes + decode = dByteString + +{- | +>>> tst ((False,True,False,L.pack [11,22,33])) +(True,51,[65,3,11,22,33,0]) +-} +instance Flat L.ByteString where + encode = eLazyBytes + size = sLazyBytes + decode = dLazyByteString + +{- | +>>> tst ((False,True,False,SBS.pack [11,22,33])) +(True,51,[65,3,11,22,33,0]) +-} +instance Flat SBS.ShortByteString where + encode = eShortBytes + size = sShortBytes + decode = dShortByteString + diff --git a/plutus-core/flat/src/PlutusCore/Flat/Instances/Containers.hs b/plutus-core/flat/src/PlutusCore/Flat/Instances/Containers.hs new file mode 100644 index 00000000000..81fc9de71e3 --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Instances/Containers.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeSynonymInstances #-} + +{-# LANGUAGE CPP #-} +-- |Instances for the containers library +module PlutusCore.Flat.Instances.Containers (sizeMap + , encodeMap + , decodeMap +) where + +import Data.IntMap +import Data.Map +import Data.Sequence +import Data.Set +import Data.Tree +import PlutusCore.Flat.Instances.Base () +import PlutusCore.Flat.Instances.Mono +import PlutusCore.Flat.Instances.Util + +-- $setup +-- >>> import PlutusCore.Flat.Instances.Test +-- >>> import Data.Set +-- >>> import Data.Sequence +-- >>> import Data.IntMap +-- >>> import Data.Map +-- >>> import Data.Tree +-- >>> import PlutusCore.Flat.Instances.Mono + +{-| +Maps are defined as a list of (Key,Value) tuples: + +@ +Map = List (Key,Value) + +List a = Nil | Cons a (List a) +@ +-} + +{-| +>>> tst (Data.IntMap.empty :: IntMap ()) +(True,1,[0]) + +>>> asList Data.IntMap.fromList [(1,"a"),(2,"b")] +True +-} +instance Flat a => Flat (IntMap a) where + size = sizeMap + encode = encodeMap + decode = decodeMap + +{-| +Maps are encoded as lists: + +>>> tst (Data.Map.empty :: Map () ()) +(True,1,[0]) + +>>> asList Data.Map.fromList [("a","aa"),("b","bb")] +True + +Key/Values are encoded in order: + +>>> let l = [("a","aa"),("b","bb")] in tst (Data.Map.fromList l) == tst (Data.Map.fromList $ Prelude.reverse l) +True + +IntMap and Map are encoded in the same way: + +>>> let l = [(2::Int,"b"),(1,"a")] in tst (Data.IntMap.fromList l) == tst (Data.Map.fromList l) +True +-} +instance (Flat a, Flat b, Ord a) => Flat (Map a b) where + size = sizeMap + encode = encodeMap + decode = decodeMap + +{-| +Data.Sequence.Seq is encoded as a list. + +>>> asList Data.Sequence.fromList [3::Word8,4,7] +True + +In flat <0.4, it was encoded as an Array. + +If you want to restore the previous behaviour, use AsArray: + +>>> tst $ AsArray (Data.Sequence.fromList [11::Word8,22,33]) +(True,40,[3,11,22,33,0]) + +>>> tst $ Data.Sequence.fromList [11::Word8,22,33] +(True,28,[133,197,164,32]) +-} +instance Flat a => Flat (Seq a) where + size = sizeList -- . toList + encode = encodeList -- . Data.Sequence.toList + decode = Data.Sequence.fromList <$> decodeList + +{-| +Data.Set is encoded as a list + +>>> asList Data.Set.fromList [3::Word8,4,7] +True +-} +instance (Flat a,Ord a) => Flat (Set a) where + size = sizeSet + encode = encodeSet + decode = decodeSet + +{-| +>>> tst (Node (1::Word8) [Node 2 [Node 3 []], Node 4 []]) +(True,39,[1,129,64,200,32]) +-} +#if ! MIN_VERSION_containers(0,5,8) +deriving instance Generic (Tree a) +#endif + +instance (Flat a) => Flat (Tree a) diff --git a/plutus-core/flat/src/PlutusCore/Flat/Instances/DList.hs b/plutus-core/flat/src/PlutusCore/Flat/Instances/DList.hs new file mode 100644 index 00000000000..45c381467b0 --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Instances/DList.hs @@ -0,0 +1,27 @@ +module PlutusCore.Flat.Instances.DList + () +where + +import Data.DList (DList, fromList, toList) +import PlutusCore.Flat.Class (Flat (..)) +import PlutusCore.Flat.Instances.Mono (decodeList, encodeList, sizeList) + +-- $setup +-- >>> import PlutusCore.Flat.Instances.Test +-- >>> import PlutusCore.Flat.Instances.Base() +-- >>> import PlutusCore.Flat.Run +-- >>> import Data.DList +-- >>> let test = tstBits + +{-| +>>> test (Data.DList.fromList [7::Word,7]) +(True,19,"10000011 11000001 110") + +>>> let l = [7::Word,7] in flat (Data.DList.fromList l) == flat l +True +-} + +instance Flat a => Flat (DList a) where + size = sizeList . toList + encode = encodeList . toList + decode = fromList <$> decodeList diff --git a/plutus-core/flat/src/PlutusCore/Flat/Instances/Extra.hs b/plutus-core/flat/src/PlutusCore/Flat/Instances/Extra.hs new file mode 100644 index 00000000000..4eb63dd4ae0 --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Instances/Extra.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE FlexibleInstances #-} +module PlutusCore.Flat.Instances.Extra where + +import PlutusCore.Flat.Class (Flat) +import PlutusCore.Flat.Instances.Base () + +-- $setup +-- >>> import PlutusCore.Flat.Instances.Test + +{- | +For better encoding/decoding performance, it is useful to declare instances of concrete list types, such as [Char]. + +>>> tstBits "" +(True,1,"0") + +>>> tstBits "aaa" +(True,28,"10110000 11011000 01101100 0010") +-} +instance {-# OVERLAPPING #-} Flat [Char] + diff --git a/plutus-core/flat/src/PlutusCore/Flat/Instances/Mono.hs b/plutus-core/flat/src/PlutusCore/Flat/Instances/Mono.hs new file mode 100644 index 00000000000..ac0530ab1da --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Instances/Mono.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE UndecidableInstances #-} + +module PlutusCore.Flat.Instances.Mono + ( sizeSequence + , encodeSequence + , decodeSequence + , sizeList + , encodeList + , decodeList + , sizeSet + , encodeSet + , decodeSet + , sizeMap + , encodeMap + , decodeMap + , AsArray(..) + , AsList(..) + , AsSet(..) + , AsMap(..) + ) +where + +import Data.Containers +import Data.Foldable qualified as F +import Data.MonoTraversable (Element, MonoFoldable, ofoldl', otoList) +import Data.Sequences (IsSequence) +import Data.Sequences qualified as S +import PlutusCore.Flat.Instances.Util + +{- $setup +>>> import PlutusCore.Flat.Instances.Base() +>>> import PlutusCore.Flat.Instances.Test +>>> import Data.Word +>>> import qualified Data.Set +>>> import qualified Data.Map +-} + +{-| +Sequences are defined as Arrays: + +Array v = A0 + | A1 v (Array v) + | A2 v v (Array v) + ... + | A255 ... (Array v) + +In practice, this means that the sequence is encoded as a sequence of blocks of up to 255 elements, with every block preceded by the count of the elements in the block and a final 0-length block. + +Lists are defined as: + +List a ≡ Nil + | Cons a (List a) + +In practice, this means that the list elements will be prefixed with a 1 bit and followed by a final 0 bit. + +The AsList/AsArray wrappers can be used to serialise sequences as Lists or Arrays. + +Let's see some examples. + +>>> flatBits $ AsList [True,True,True] +"1111110" + +So we have Cons True (11) repeated three times, followed by a final Nil (0). + +The list encoding is the default one for lists so AsList is in this case unnecessary: + +>>> flatBits $ [True,True,True] +"1111110" + +We can force a list to be encoded as an Array with AsArray: + +>>> flatBits $ AsArray [True,True,True] +"00000011 11100000 000" + +We have the initial block with a count of 3 (3 == 00000011) followed by the elements True True True (111) and then the final block of 0 elements ("00000 000"). + +>>> flatBits $ [AsArray [True,True,True]] +"10000001 11110000 00000" + +>>> flatBits $ (True,True,True,AsArray $ replicate 7 True) +"11100000 11111111 11000000 00" + +>>> flatBits $ AsArray ([]::[()]) +"00000000" + +>>> flatBits $ AsList ([]::[()]) +"0" + +>>> tst (AsList [11::Word8,22,33]) +(True,28,[133,197,164,32]) + +>>> tst (AsSet (Data.Set.fromList [11::Word8,22,33])) +(True,28,[133,197,164,32]) + +>>> tst [AsArray [1..3], AsArray [4..8]] +(True,99,[129,129,2,3,0,65,66,2,131,3,132,0,0]) + +>>> tst $ [AsArray [(1::Word8)..3], AsArray [4..8]] +(True,99,[129,128,129,1,128,65,65,1,65,129,194,0,0]) + +>>> tst $ [AsArray [(1::Int)..3]] +(True,42,[129,129,2,3,0,0]) +-} +newtype AsArray a = + AsArray + { unArray :: a + } deriving (Show,Eq,Ord) + +instance (IsSequence r, Flat (Element r)) => Flat (AsArray r) where + size (AsArray a) = sizeSequence a + encode (AsArray a) = encodeSequence a + decode = AsArray <$> decodeSequence + +{- | +Calculate size of an instance of IsSequence as the sum: + +* of the size of all the elements + +* plus the size of the array constructors (1 byte every 255 elements plus one final byte) +-} +sizeSequence + :: (IsSequence mono, Flat (Element mono)) => mono -> NumBits -> NumBits +sizeSequence s acc = + let (sz, len) = + ofoldl' (\(acc, l) e -> (size e acc, l + 1)) (acc, 0 :: NumBits) s + in sz + arrayBits len +{-# INLINE sizeSequence #-} + +-- TODO: check which one is faster +-- sizeSequence s acc = ofoldl' (flip size) acc s + arrayBits (olength s) + +-- |Encode an instance of IsSequence, as an array +encodeSequence :: (Flat (Element mono), MonoFoldable mono) => mono -> Encoding +encodeSequence = encodeArray . otoList +{-# INLINE encodeSequence #-} + +-- |Decode an instance of IsSequence, as an array +decodeSequence :: (Flat (Element b), IsSequence b) => Get b +decodeSequence = S.fromList <$> decodeArrayWith decode +{-# INLINE decodeSequence #-} + +newtype AsList a = + AsList + { unList :: a + } deriving (Show,Eq,Ord) + +instance (IsSequence l, Flat (Element l)) => Flat (AsList l) where + -- size = sizeList . S.unpack . unList + -- encode = encodeList . S.unpack . unList + -- decode = AsList . S.fromList <$> decodeListotoList + + size = sizeList . unList + encode = encodeList . unList + decode = AsList <$> decodeList + +{-# INLINE sizeList #-} +sizeList + :: (MonoFoldable mono, Flat (Element mono)) => mono -> NumBits -> NumBits +sizeList l sz = ofoldl' (\s e -> size e (s + 1)) (sz + 1) l + +{-# INLINE encodeList #-} +encodeList :: (Flat (Element mono), MonoFoldable mono) => mono -> Encoding +encodeList = encodeListWith encode . otoList + +{-# INLINE decodeList #-} +decodeList :: (IsSequence b, Flat (Element b)) => Get b +decodeList = S.fromList <$> decodeListWith decode + +{-| +Sets are saved as lists of values. + +>>> tstBits $ AsSet (Data.Set.fromList ([False,True,False]::[Bool])) +(True,5,"10110") +-} +newtype AsSet a = + AsSet + { unSet :: a + } deriving (Show,Eq,Ord) + +instance (IsSet set, Flat (Element set)) => Flat (AsSet set) where + size = sizeSet . unSet + encode = encodeSet . unSet + decode = AsSet <$> decodeSet + +sizeSet :: (IsSet set, Flat (Element set)) => Size set +sizeSet l acc = ofoldl' (\acc e -> size e (acc + 1)) (acc + 1) l +{-# INLINE sizeSet #-} + +encodeSet :: (IsSet set, Flat (Element set)) => set -> Encoding +encodeSet = encodeList . setToList +{-# INLINE encodeSet #-} + +decodeSet :: (IsSet set, Flat (Element set)) => Get set +decodeSet = setFromList <$> decodeList +{-# INLINE decodeSet #-} + +{-| +Maps are saved as lists of (key,value) tuples. + +>>> tst (AsMap (Data.Map.fromList ([]::[(Word8,())]))) +(True,1,[0]) + +>>> tst (AsMap (Data.Map.fromList [(3::Word,9::Word)])) +(True,18,[129,132,128]) +-} +newtype AsMap a = + AsMap + { unMap :: a + } deriving (Show,Eq,Ord) + +instance (IsMap map, Flat (ContainerKey map), Flat (MapValue map)) => Flat (AsMap map) where + size = sizeMap . unMap + encode = encodeMap . unMap + decode = AsMap <$> decodeMap + +{-# INLINE sizeMap #-} +sizeMap :: (Flat (ContainerKey r), Flat (MapValue r), IsMap r) => Size r +sizeMap m acc = + F.foldl' (\acc' (k, v) -> size k (size v (acc' + 1))) (acc + 1) + . mapToList + $ m +-- sizeMap l sz = ofoldl' (\s (k, v) -> size k (size v (s + 1))) (sz + 1) l + +{-# INLINE encodeMap #-} +-- |Encode an instance of IsMap, as a list of (Key,Value) tuples +encodeMap + :: (Flat (ContainerKey map), Flat (MapValue map), IsMap map) + => map + -> Encoding +encodeMap = encodeListWith (\(k, v) -> encode k <> encode v) . mapToList + +{-# INLINE decodeMap #-} +-- |Decode an instance of IsMap, as a list of (Key,Value) tuples +decodeMap + :: (Flat (ContainerKey map), Flat (MapValue map), IsMap map) => Get map +decodeMap = mapFromList <$> decodeListWith ((,) <$> decode <*> decode) + diff --git a/plutus-core/flat/src/PlutusCore/Flat/Instances/Test.hs b/plutus-core/flat/src/PlutusCore/Flat/Instances/Test.hs new file mode 100644 index 00000000000..d8f56405736 --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Instances/Test.hs @@ -0,0 +1,46 @@ +-- | doctest utilities +module PlutusCore.Flat.Instances.Test ( + tst, + tstBits, + asList, + flatBits, + allBits, + encBits, + prettyShow, + module Data.Word, +) where + +import Control.Monad ((>=>)) +import Data.Word +import PlutusCore.Flat.Bits (Bits, asBytes, bits, paddedBits, takeBits, toBools) +import PlutusCore.Flat.Class (Flat (..)) +import PlutusCore.Flat.Encoder.Prim (eFillerF) +import PlutusCore.Flat.Encoder.Strict (Encoding (Encoding), numEncodedBits, strictEncoder) +import PlutusCore.Flat.Run (flat, unflat) +import PlutusCore.Flat.Types (NumBits) +import Text.PrettyPrint.HughesPJClass (prettyShow) + +-- | Returns: result of flat/unflat test, encoding size in bits, byte encoding +tst :: (Eq a, Flat a) => a -> (Bool, NumBits, [Word8]) +tst v = (unflat (flat v) == Right v && size v 0 >= length (toBools (bits v)), size v 0, showBytes v) + +-- | Returns: result of flat/unflat test, encoding size in bits, bits encoding +tstBits :: (Eq a, Flat a) => a -> (Bool, NumBits, String) +tstBits v = (unflat (flat v) == Right v, size v 0, flatBits v) + +-- | Test that container is serialised as a List +asList :: (Eq a1, Eq a2, Flat a1, Flat a2) => (a2 -> a1) -> a2 -> Bool +asList f l = tst (f l) == tst l + +flatBits :: Flat a => a -> String +flatBits = prettyShow . bits + +allBits :: Flat a => a -> String +allBits = prettyShow . paddedBits + +-- |@since 0.5 +encBits :: NumBits -> Encoding -> Bits +encBits maxNumBits e@(Encoding enc) = takeBits (numEncodedBits maxNumBits e) (strictEncoder maxNumBits (Encoding $ enc >=> eFillerF)) + +showBytes :: Flat a => a -> [Word8] +showBytes = asBytes . bits diff --git a/plutus-core/flat/src/PlutusCore/Flat/Instances/Text.hs b/plutus-core/flat/src/PlutusCore/Flat/Instances/Text.hs new file mode 100644 index 00000000000..80ca27b2eff --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Instances/Text.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE CPP #-} + +-- | Flat instances for the text library +module PlutusCore.Flat.Instances.Text( + UTF8Text(..) +#if! defined (ETA_VERSION) && ! defined (ETA) + ,UTF16Text(..) +#endif +) where + +import Data.Text qualified as T +import Data.Text.Lazy qualified as TL +import PlutusCore.Flat.Instances.Util + +-- $setup +-- >>> import PlutusCore.Flat.Instances.Base() +-- >>> import PlutusCore.Flat.Instances.Test +-- >>> import qualified Data.Text as T +-- >>> import qualified Data.Text.Lazy as TL +-- >>> import Data.Word +-- >>> tt t = let (ts,_,bs) = tst t in (ts,bs) + +{- | +Text (and Data.Text.Lazy) is encoded as a byte aligned array of bytes corresponding to its UTF8 encoding. + +>>> tt $ T.pack "" +(True,[1,0]) + +>>> tt $ T.pack "aaa" +(True,[1,3,97,97,97,0]) + +>>> tt $ T.pack "¢¢¢" +(True,[1,6,194,162,194,162,194,162,0]) + +>>> tt $ T.pack "日日日" +(True,[1,9,230,151,165,230,151,165,230,151,165,0]) + +#ifndef ETA +>>> tt $ T.pack "𐍈𐍈𐍈" +(True,[1,12,240,144,141,136,240,144,141,136,240,144,141,136,0]) +#endif + +Strict and Lazy Text have the same encoding: + +>>> tst (T.pack "abc") == tst (TL.pack "abc") +True +-} +instance Flat T.Text where + size = sUTF8Max + encode = eUTF8 + decode = dUTF8 + +instance Flat TL.Text where + size = sUTF8Max . TL.toStrict + encode = eUTF8 . TL.toStrict + decode = TL.fromStrict <$> dUTF8 + +{-| +The desired text encoding can be explicitly specified using the wrappers UTF8Text and UTF16Text. + +The default encoding is UTF8: + +>>> tst (UTF8Text $ T.pack "日日日") == tst (T.pack "日日日") +True +-} +-- |A wrapper to encode/decode Text as UTF8 +newtype UTF8Text = UTF8Text {unUTF8::T.Text} deriving (Eq,Ord,Show) + +instance Flat UTF8Text where + size (UTF8Text t) = sUTF8Max t + encode (UTF8Text t) = eUTF8 t + decode = UTF8Text <$> dUTF8 + +#if ! defined (ETA_VERSION) && ! defined (ETA) +{-| +>>> tt (UTF16Text $ T.pack "aaa") +(True,[1,6,97,0,97,0,97,0,0]) + +>>> tt (UTF16Text $ T.pack "𐍈𐍈𐍈") +(True,[1,12,0,216,72,223,0,216,72,223,0,216,72,223,0]) +-} + +-- |A wrapper to encode/decode Text as UTF16 +newtype UTF16Text = UTF16Text {unUTF16::T.Text} deriving (Eq,Ord,Show) + +instance Flat UTF16Text where + size (UTF16Text t) = sUTF16 t + encode (UTF16Text t) = eUTF16 t + decode = UTF16Text <$> dUTF16 +#endif + diff --git a/plutus-core/flat/src/PlutusCore/Flat/Instances/Unordered.hs b/plutus-core/flat/src/PlutusCore/Flat/Instances/Unordered.hs new file mode 100644 index 00000000000..494b9688f07 --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Instances/Unordered.hs @@ -0,0 +1,48 @@ + +module PlutusCore.Flat.Instances.Unordered + () +where + +import Data.Hashable +import Data.HashMap.Strict qualified as MS +import Data.HashSet +import PlutusCore.Flat.Instances.Mono +import PlutusCore.Flat.Instances.Util + +-- $setup +-- >>> import PlutusCore.Flat.Instances.Base() +-- >>> import PlutusCore.Flat.Instances.Test +-- >>> import Data.Word +-- >>> import qualified Data.HashMap.Strict +-- >>> import qualified Data.HashMap.Lazy +-- >>> import qualified Data.HashSet +-- >>> let test = tstBits + +{-| +>>> test (Data.HashSet.fromList [1..3::Word]) +(True,28,"10000000 11000000 10100000 0110") +-} + +instance (Hashable a, Eq a,Flat a) => Flat (HashSet a) where + size = sizeSet + encode = encodeSet + decode = decodeSet + +{-| +>>> test (Data.HashMap.Strict.fromList [(1,11),(2,22)]) +(True,35,"10000001 00001011 01000001 00001011 000") + +>>> test (Data.HashMap.Lazy.fromList [(1,11),(2,22)]) +(True,35,"10000001 00001011 01000001 00001011 000") + +-} +instance (Hashable k,Eq k,Flat k,Flat v) => Flat (MS.HashMap k v) where + size = sizeMap + encode = encodeMap + decode = decodeMap + +-- instance (Hashable k,Eq k,Flat k,Flat v) => Flat (ML.HashMap k v) where +-- size = sizeMap +-- encode = encodeMap +-- decode = decodeMap + diff --git a/plutus-core/flat/src/PlutusCore/Flat/Instances/Util.hs b/plutus-core/flat/src/PlutusCore/Flat/Instances/Util.hs new file mode 100644 index 00000000000..0d6da4cb1d1 --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Instances/Util.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +module PlutusCore.Flat.Instances.Util + ( module F + -- sizeList + -- , decodeList + -- , encodeList + , encodeArray + ) +where + +import PlutusCore.Flat.Class as F +import PlutusCore.Flat.Decoder as F +import PlutusCore.Flat.Encoder as F +import PlutusCore.Flat.Types as F +-- import Data.List +-- import GHC.Exts(IsList) + +-- -- $setup +-- >>> import PlutusCore.Flat.Instances.Base() +-- >>> import PlutusCore.Flat.Instances.Test +-- >>> let test = tstBits + +-- {-| +-- >>> test [] +-- (True,1,"0") + +-- >>> test [1::Word8] +-- (True,10,"10000000 10") +-- -} + +-- {-# INLINE sizeList #-} +-- sizeList :: Flat a => [a] -> NumBits -> NumBits +-- sizeList l sz = foldl' (\s e -> size e (s + 1)) (sz + 1) l + +-- {-# INLINE encodeList #-} +-- encodeList :: Flat a => [a] -> Encoding +-- encodeList = encodeListWith encode + +-- {-# INLINE decodeList #-} +-- decodeList :: Flat a => Get [a] +-- decodeList = decodeListWith decode + +{-# INLINE encodeArray #-} +encodeArray :: Flat a => [a] -> Encoding +encodeArray = encodeArrayWith encode diff --git a/plutus-core/flat/src/PlutusCore/Flat/Instances/Vector.hs b/plutus-core/flat/src/PlutusCore/Flat/Instances/Vector.hs new file mode 100644 index 00000000000..97f41b7064f --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Instances/Vector.hs @@ -0,0 +1,46 @@ + +-- | Flat instances for the vector package. +module PlutusCore.Flat.Instances.Vector + () +where + +import PlutusCore.Flat.Instances.Mono +import PlutusCore.Flat.Instances.Util + +import Data.Vector qualified as V +import Data.Vector.Storable qualified as S +import Data.Vector.Unboxed qualified as U + +-- $setup +-- >>> import PlutusCore.Flat.Instances.Test +-- >>> import PlutusCore.Flat.Instances.Base() +-- >>> import qualified Data.Vector as V +-- >>> import qualified Data.Vector.Unboxed as U +-- >>> import qualified Data.Vector.Storable as S + +{-| +Vectors are encoded as arrays. + +>>> tst (V.fromList [11::Word8,22,33]) +(True,40,[3,11,22,33,0]) + +All Vectors are encoded in the same way: + +>>> let l = [11::Word8,22,33] in all (tst (V.fromList l) ==) [tst (U.fromList l),tst (S.fromList l)] +True +-} + +instance Flat a => Flat (V.Vector a) where + size = sizeSequence + encode = encodeSequence + decode = decodeSequence + +instance (U.Unbox a,Flat a) => Flat (U.Vector a) where + size = sizeSequence + encode = encodeSequence + decode = decodeSequence + +instance (S.Storable a,Flat a) => Flat (S.Vector a) where + size = sizeSequence + encode = encodeSequence + decode = decodeSequence diff --git a/plutus-core/flat/src/PlutusCore/Flat/Memory.hs b/plutus-core/flat/src/PlutusCore/Flat/Memory.hs new file mode 100644 index 00000000000..2467dab703c --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Memory.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} + +{- | +Memory access primitives. + +Includes code from the [store-core](https://hackage.haskell.org/package/store-core) package. +-} +module PlutusCore.Flat.Memory + ( chunksToByteString + , chunksToByteArray + , ByteArray + , pokeByteArray + , pokeByteString + , unsafeCreateUptoN' + , minusPtr + , peekByteString + ) +where + +import Control.Monad (foldM_, when) +import Control.Monad.Primitive (PrimMonad (..)) +import Data.ByteString qualified as B +import Data.ByteString.Internal qualified as BS +import Data.Primitive.ByteArray (ByteArray, ByteArray#, MutableByteArray (..), newByteArray, + unsafeFreezeByteArray) +import Foreign (Ptr, Word8, minusPtr, plusPtr, withForeignPtr) +import Foreign.Marshal.Utils (copyBytes) +import GHC.Prim (copyAddrToByteArray#, copyByteArrayToAddr#) +import GHC.Ptr (Ptr (..)) +import GHC.Types (IO (..), Int (..)) +import System.IO.Unsafe (unsafeDupablePerformIO, unsafePerformIO) + +unsafeCreateUptoN' :: Int -> (Ptr Word8 -> IO (Int, a)) -> (BS.ByteString, a) +unsafeCreateUptoN' l f = unsafeDupablePerformIO (createUptoN' l f) +{-# INLINE unsafeCreateUptoN' #-} + +createUptoN' :: Int -> (Ptr Word8 -> IO (Int, a)) -> IO (BS.ByteString, a) +createUptoN' l f = do + fp <- BS.mallocByteString l + (l', res) <- withForeignPtr fp $ \p -> f p + --print (unwords ["Buffer allocated:",show l,"bytes, used:",show l',"bytes"]) + when (l' > l) $ error + (unwords + ["Buffer overflow, allocated:", show l, "bytes, used:", show l', "bytes"] + ) + return (BS.PS fp 0 l', res) -- , minusPtr l') +{-# INLINE createUptoN' #-} + +-- |Copy bytestring to given pointer, returns new pointer +pokeByteString :: B.ByteString -> Ptr Word8 -> IO (Ptr Word8) +pokeByteString (BS.PS foreignPointer sourceOffset sourceLength) destPointer = + do + withForeignPtr foreignPointer $ \sourcePointer -> copyBytes + destPointer + (sourcePointer `plusPtr` sourceOffset) + sourceLength + return (destPointer `plusPtr` sourceLength) + +{-| Create a new bytestring, copying sourceLen bytes from sourcePtr + +@since 0.6 +-} +peekByteString :: + Ptr Word8 -- ^ sourcePtr + -> Int -- ^ sourceLen + -> BS.ByteString +peekByteString sourcePtr sourceLength = BS.unsafeCreate sourceLength $ \destPointer -> copyBytes destPointer sourcePtr sourceLength + +-- |Copy ByteArray to given pointer, returns new pointer +pokeByteArray :: ByteArray# -> Int -> Int -> Ptr Word8 -> IO (Ptr Word8) +pokeByteArray sourceArr sourceOffset len dest = do + copyByteArrayToAddr sourceArr sourceOffset dest len + let !dest' = dest `plusPtr` len + return dest' +{-# INLINE pokeByteArray #-} + + +-- | Wrapper around @copyByteArrayToAddr#@ primop. +-- +-- Copied from the store-core package +copyByteArrayToAddr :: ByteArray# -> Int -> Ptr a -> Int -> IO () +copyByteArrayToAddr arr (I# offset) (Ptr addr) (I# len) = + IO (\s -> (# copyByteArrayToAddr# arr offset addr len s, () #)) +{-# INLINE copyByteArrayToAddr #-} + +chunksToByteString :: (Ptr Word8, [Int]) -> BS.ByteString +chunksToByteString (sourcePtr0, lens) = + BS.unsafeCreate (sum lens) $ \destPtr0 -> foldM_ + (\(destPtr, sourcePtr) sourceLength -> + copyBytes destPtr sourcePtr sourceLength + >> return + ( destPtr `plusPtr` sourceLength + , sourcePtr `plusPtr` (sourceLength + 1) + ) + ) + (destPtr0, sourcePtr0) + lens + +chunksToByteArray :: (Ptr Word8, [Int]) -> (ByteArray, Int) +chunksToByteArray (sourcePtr0, lens) = unsafePerformIO $ do + let len = sum lens + arr <- newByteArray len + foldM_ + (\(destOff, sourcePtr) sourceLength -> + copyAddrToByteArray sourcePtr arr destOff sourceLength >> return + (destOff + sourceLength, sourcePtr `plusPtr` (sourceLength + 1)) + ) + (0, sourcePtr0) + lens + farr <- unsafeFreezeByteArray arr + return (farr, len) + + +-- | Wrapper around @copyAddrToByteArray#@ primop. +-- +-- Copied from the store-core package +copyAddrToByteArray + :: Ptr a -> MutableByteArray (PrimState IO) -> Int -> Int -> IO () +copyAddrToByteArray (Ptr addr) (MutableByteArray arr) (I# offset) (I# len) = + IO (\s -> (# copyAddrToByteArray# addr arr offset len s, () #)) +{-# INLINE copyAddrToByteArray #-} diff --git a/plutus-core/flat/src/PlutusCore/Flat/Run.hs b/plutus-core/flat/src/PlutusCore/Flat/Run.hs new file mode 100644 index 00000000000..e462da1e1bb --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Run.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- |Encoding and decoding functions +module PlutusCore.Flat.Run ( + flat, + flatRaw, + unflat, + unflatWith, + unflatRaw, + unflatRawWith, + unflatRawWithOffset, +) where + +import Data.ByteString qualified as B +import PlutusCore.Flat.Class (Flat (decode, encode), getSize) +import PlutusCore.Flat.Data.ByteString.Convert (AsByteString (..)) +import PlutusCore.Flat.Decoder (Decoded, Get, strictDecoder) +import PlutusCore.Flat.Encoder (NumBits) +import PlutusCore.Flat.Encoder qualified as E +import PlutusCore.Flat.Filler (postAligned, postAlignedDecoder) + +-- |Encode padded value. +flat :: Flat a => a -> B.ByteString +flat = flatRaw . postAligned + +-- |Decode padded value. +unflat :: (Flat a, AsByteString b) => b -> Decoded a +unflat = unflatWith decode + +-- |Decode padded value, using the provided unpadded decoder. +unflatWith :: AsByteString b => Get a -> b -> Decoded a +unflatWith dec = unflatRawWith (postAlignedDecoder dec) + +-- |Decode unpadded value. +unflatRaw :: (Flat a, AsByteString b) => b -> Decoded a +unflatRaw = unflatRawWith decode + +-- |Unflat unpadded value, using provided decoder +unflatRawWith :: AsByteString b => Get a -> b -> Decoded a +unflatRawWith dec bs = unflatRawWithOffset dec bs 0 + +unflatRawWithOffset :: AsByteString b => Get a -> b -> NumBits -> Decoded a +unflatRawWithOffset dec bs = strictDecoder dec (toByteString bs) + +-- unflatRawWith :: AsByteString b => Get a -> b -> Decoded a +-- unflatRawWith dec bs = unflatRawWithOffset dec bs 0 + +-- unflatRawWithOffset :: AsByteString b => Get a -> b -> Int -> Decoded a +-- unflatRawWithOffset dec bs = strictDecoder dec (toByteString bs) + +-- |Encode unpadded value +flatRaw :: (Flat a, AsByteString b) => a -> b +flatRaw a = + fromByteString $ + E.strictEncoder + (getSize a) + +#ifdef ETA_VERSION + (E.trampolineEncoding (encode a)) +#else + (encode a) +#endif + +-- #ifdef ETA_VERSION +-- deriving (Show, Eq, Ord, Typeable, Generic, NFData) + +-- instance Flat a => Flat (PostAligned a) where +-- encode (PostAligned val fill) = trampolineEncoding (encode val) <> encode fill + +-- #else +-- deriving (Show, Eq, Ord, Typeable, Generic, NFData,Flat) +-- #endif diff --git a/plutus-core/flat/src/PlutusCore/Flat/TestMemory.hs b/plutus-core/flat/src/PlutusCore/Flat/TestMemory.hs new file mode 100644 index 00000000000..64c663e3cca --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/TestMemory.hs @@ -0,0 +1,26 @@ +{- | +Represent a data type in memory using the flat representation. + +Access it as normal using pattern synonyms (https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/pattern_synonyms.html) or lenses? + +This should: +* massively reduce memory usage (without requiring any manual specialisation) +* possibly reduce traversal times (via better caching) + +-} +module PlutusCore.Flat.TestMemory where + +import Data.ByteString + +import PlutusCore.Flat + +{- +>>> fact fact 3 +3 * fact fact 2 = 3 * 2 * 1 +-} +-- x :: Int -> Int +x n = fact (fact n) + +fact :: (Int -> Int) -> Int -> Int +fact _ 1 = 1 +fact k n = n * k (n-1) diff --git a/plutus-core/flat/src/PlutusCore/Flat/Tutorial.hs b/plutus-core/flat/src/PlutusCore/Flat/Tutorial.hs new file mode 100644 index 00000000000..e0a52b013df --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Tutorial.hs @@ -0,0 +1,116 @@ +module PlutusCore.Flat.Tutorial + ( + -- $setup + + -- $main + ) +where + + +{- $setup +To (de)serialise a data type, make it an instance of the 'Flat.Class.Flat' class. + +There is based support to automatically derive a correct instance. + +Let’s see some code. + +We need a couple of extensions: + +>>> :set -XDeriveGeneric -XDeriveAnyClass + +The @Flat@ top module: + +>>> import PlutusCore.Flat + +And, just for fun, a couple of functions to display an encoded value as a sequence of bits: + +>>> import PlutusCore.Flat.Instances.Test (flatBits,allBits) + +Define a few custom data types, deriving @Generic@ and @Flat@: + +>>> data Result = Bad | Good deriving (Show,Generic,Flat) + +>>> data Direction = North | South | Center | East | West deriving (Show,Generic,Flat) + +>>> data List a = Nil | Cons a (List a) deriving (Show,Generic,Flat) +-} + +{- $main +Now we can encode a List of Directions using 'Flat.Run.flat': + +>>> flat $ Cons North (Cons South Nil) +"\149" + +The result is a strict . + +And decode it back using 'Flat.Run.unflat': + +>>> unflat . flat $ Cons North (Cons South Nil) :: Decoded (List Direction) +Right (Cons North (Cons South Nil)) + +The result is a 'Flat.Decoded' value: 'Either' a 'Flat.DecodeException' or the actual value. + +=== Optimal Bit-Encoding +#optimal-bit-encoding# + +A pecularity of Flat is that it uses an optimal bit-encoding rather than +the usual byte-oriented one. + +One bit is sufficient to encode a 'Result' or an empty 'List': + +>>> flatBits Good +"1" + +>>> flatBits (Nil::List Direction) +"0" + +Two or three bits suffice for a 'Direction': + +>>> flatBits South +"01" + +>>> flatBits West +"111" + +For the serialisation to work with byte-oriented devices or storage, we need to add some padding. + +To do so, rather than encoding a plain value, 'Flat.Run.flat' encodes a 'Flat.Filler.PostAligned' value, that's to say a value followed by a 'Flat.Filler.Filler' that stretches till the next byte boundary. + +In practice, the padding is a, possibly empty, sequence of 0s followed by a 1. + +For example, this list encodes as 7 bits: + +>>> flatBits $ Cons North (Cons South Nil) +"1001010" + +And, with the added padding of a final "1", will snugly fit in a single byte: + +>>> allBits $ Cons North (Cons South Nil) +"10010101" + +But .. you don't need to worry about these details as byte-padding is automatically added by the function 'Flat.Run.flat' and removed by 'Flat.Run.unflat'. + +=== Pre-defined Instances + +Flat instances are already defined for relevant types of some common packages: array, base, bytestring, containers, dlist, mono-traversable, text, unordered-containers, vector. + +They are automatically imported by the "Flat" module. + +For example: + +>>> flatBits $ Just True +"11" + +=== Wrapper Types + +There are a few wrapper types that modify the way encoding and/or decoding occur. + +* "Flat.AsBin" and "Flat.AsSize" decode to a value's flat binary representation or size in bits respectively. + +* 'Flat.Instances.Mono.AsArray' and 'Flat.Instances.Mono.AsList' encode/decode a sequence as a List or Array respectively, see "Flat.Instances.Mono" for details. + +* 'Flat.Instances.Text.UTF8Text' and 'Flat.Instances.Text.UTF16Text' encode/decode a Text as UTF8 or UTF16 respectively. + +-} + + diff --git a/plutus-core/flat/src/PlutusCore/Flat/Types.hs b/plutus-core/flat/src/PlutusCore/Flat/Types.hs new file mode 100644 index 00000000000..ec17bdcb0ec --- /dev/null +++ b/plutus-core/flat/src/PlutusCore/Flat/Types.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE FlexibleInstances #-} +-- |Common Types +module PlutusCore.Flat.Types ( + NumBits, + module Data.Word, + module Data.Int, + Natural, + SBS.ShortByteString, + T.Text, + ) where + +import Data.ByteString.Short.Internal qualified as SBS +import Data.Int +import Data.Text qualified as T +import Data.Word +import Numeric.Natural + +-- |Number of bits +type NumBits = Int + diff --git a/plutus-core/flat/test/Big.hs b/plutus-core/flat/test/Big.hs new file mode 100644 index 00000000000..add042dc85f --- /dev/null +++ b/plutus-core/flat/test/Big.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +{- +Test different ways of handlings a data type that has large values and a small encoding. + +To run with limited memory: cabal run big -- +RTS -M2g +-} + +module Main where + +import Data.ByteString qualified as B +import Data.List (foldl') +import ListT qualified as L +import PlutusCore.Flat (Decoded, Flat (..), flat, unflat, unflatWith) +import PlutusCore.Flat.AsBin (AsBin, unbin) +import PlutusCore.Flat.AsSize +import PlutusCore.Flat.Decoder (Get, listTDecoder) +import System.TimeIt (timeIt) + +-- Big is a type that has a small encoded representation but a very large in-memory footprint. +-- It is a very large bytestring whose bytes are all set to 0 +newtype Big = Big B.ByteString + +newBig :: Int -> Big +newBig gigas = Big $ B.replicate (gigas*giga) 0 + +-- length of Big in gigas +gigas :: Big -> Int +gigas (Big b) = B.length b `div` giga + +giga :: Int +giga = 1000000000 + +instance Show Big where show b = "Big of " ++ show (gigas b) ++ "Gbytes" + +instance Flat Big where + -- The encoded form is just the number of giga zeros (e.g. 5 for 5Giga zeros) + size big = size (gigas big) + encode big = encode (gigas big) + + -- The decoded form is massive + decode = newBig <$> decode + +main :: IO () +main = tbig + +tbig = do + let numOfBigs = 5 + + -- A serialised list of Big values + let bigsFile = flat $ replicate numOfBigs $ newBig 1 + print "Encoding Time" + timeIt $ print $ B.length bigsFile + + tstAsSize bigsFile + + tstAsBin bigsFile + + tstListT bigsFile + + tstBig bigsFile + +-- If we unserialise a list of Bigs and then process them (e.g. print them out) we end up in trouble, too much memory is required. +tstBig :: B.ByteString -> IO () +tstBig bigsFile = timeIt $ do + print "Decode to [Big]:" + let Right (bs :: [Big]) = unflat bigsFile + mapM_ print bs + +-- So instead we unserialise them to a list of their flat representations, to be unflatted on demand later on +tstAsBin :: B.ByteString -> IO () +tstAsBin bigsFile = timeIt $ do + print "Decode to [AsBin Big]:" + let Right (bsR :: [AsBin Big]) = unflat bigsFile + let bs = map unbin bsR + mapM_ print bs + +tstAsSize :: B.ByteString -> IO () +tstAsSize bigsFile = timeIt $ do + print "Decode to [AsSize Big]:" + let Right (bs :: [AsSize Big]) = unflat bigsFile + mapM_ print bs + +-- Or: we extract one element at the time via a ListT +-- See http://hackage.haskell.org/package/list-t-1.0.4/docs/ListT.html +tstListT :: B.ByteString -> IO () +tstListT bigsFile = timeIt $ do + print "Decode to ListT IO Big:" + stream :: L.ListT IO Big <- listTDecoder decode bigsFile + L.traverse_ print stream diff --git a/plutus-core/flat/test/Core.hs b/plutus-core/flat/test/Core.hs new file mode 100644 index 00000000000..1f651bafea0 --- /dev/null +++ b/plutus-core/flat/test/Core.hs @@ -0,0 +1,236 @@ +-- |Test the code generated by the Generics implementation of Flat +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + +{-# OPTIONS_GHC -O2 -fplugin Test.Inspection.Plugin #-} + +import Control.Monad +import Data.ByteString (ByteString) +import Data.Maybe +import Data.ZigZag +import PlutusCore.Flat +import PlutusCore.Flat.Encoder.Prim +import PlutusCore.Flat.Encoder.Strict +import PlutusCore.Flat.Types +import Test.Data +import Test.Data.Flat +import Test.E +import Test.E.Flat +import Test.Inspection + + +-- deriving instance Flat E2 +-- deriving instance Flat E3 +-- deriving instance Flat E4 +-- deriving instance Flat E8 +-- deriving instance Flat E16 +-- deriving instance Flat E17 +-- deriving instance Flat E32 +-- deriving instance Flat E256 +-- deriving instance Flat E258 +add2 :: NumBits -> NumBits +add2 n = n + 2 + +v1 :: NumBits +v1 = 1 + +v2 :: NumBits +v2 = 2 + +v3 :: NumBits +v3 = 3 + +v4 :: NumBits +v4 = 4 + +v5 :: NumBits +v5 = 5 + +v6 :: NumBits +v6 = 6 + +v8 :: NumBits +v8 = 8 + +s4 :: NumBits +s4 = size E4_1 0 + +sz2 :: NumBits -> NumBits +sz2 = size E2_1 + +f1 = encode E2_1 + +tte = Encoding $ eTrueF >=> eTrueF + +ttte = Encoding $ eTrueF >=> eTrueF >=> eTrueF + +ff = eFalseF >=> eFalseF + +ft = eFalseF >=> eTrueF + +f2 = encode E2_2 + +f4 = encode E4_4 + +f8 = encode E8_8 + +-- f32 :: Encoding +f32 = encode E32_1 + +f32_32 = flat E32_32 + +one = encode One + +five = encode Five + +encE2 = encode :: (E2 -> Encoding) + +fl2 = flat E2_2 + +leaf = encode (Leaf Five) + +dN = decode :: Get N + +-- sz :: Int +sz = getSize E4_1 + +sizeBool :: Bool -> NumBits +sizeBool b = size b 0 + +const1 :: Bool -> NumBits +const1 = const 1 + +const3 :: E8 -> NumBits +const3 = const 3 + +size3 :: E3 -> NumBits +size3 b = size b 0 + +size3Code :: E3 -> NumBits +size3Code b = case b of + E3_1 -> 1 + E3_2 -> 2 + E3_3 -> 2 + +size17 :: E17 -> NumBits +size17 b = size b 0 + +size17Code :: E17 -> NumBits +size17Code b = case b of + E17_16 -> 5 + E17_17 -> 5 + __ -> 4 + +size8 :: E8 -> NumBits +size8 b = size b 0 + +size32 :: E32 -> NumBits +size32 b = size b 0 + +sz0 = getSize E4_3 + +sz3_1 = getSize E3_1 + +sz3_3 = getSize E3_3 + +sz4 = getSize E4_3 + +sz8 = getSize E8_3 + +sz16 = getSize E16_7 + +sz17_1 = getSize E17_1 + +sz17_17 = getSize E17_17 + +sz32 = getSize E32_13 + +-- sz64 = getSize E64_33 +-- sz256 = getSize E256_1 +-- sz4 = getSize E4_3 +szl = getSize [False] + +szb = getSize False + +-- sz_direction = getSize North +inspect $ hasNoGenerics 'szb + +inspect $ 'sizeBool === 'const1 + +inspect $ 'size3 === 'size3Code + +inspect $ 'size17 === 'size17Code + +-- inspect $ 'size32 === 'const1 +-- almost but not quite +-- inspect $ 'size8 === 'const3 +-- Verify that sizes are fully calculated at compilation time, for simple enumerations +inspect $ 'szb === 'v1 + +inspect $ 'sz3_1 === 'v1 + +inspect $ 'sz3_3 === 'v2 + +inspect $ 'sz4 === 'v2 + +inspect $ 'sz8 === 'v3 + +inspect $ 'sz16 === 'v4 + +inspect $ 'sz17_1 === 'v4 + +inspect $ 'sz17_17 === 'v5 + +inspect $ 'sz32 === 'v5 + +-- This fails, a long nested case statement is generated instead +-- inspect $ 'sz256 === 'v8 +-- inspect $ 'f1 === 'f2 + +-- FAILS +-- inspect $ 'tte === 'f2 + +-- inspect $ 'five === 'one +-- inspect $ 'leaf === 'one + +-- FAILS +-- inspect $ 'leaf === 'dN + +-- inspect $ 'fl2 === 'encE2 +-- inspect $ 'f8 === 'ttte +-- inspect $ 'f1 === 'ttte +-- inspect $ 'sz2 === 'add2 +-- inspect $ 'ft === 'ff + + +-- d8 = zzDecode8 +-- d8s = zzDecode :: Word8 -> Int8 + +-- d64 = zzDecode64 +-- d64s = zzDecode :: Word64 -> Int64 + +-- e64 = zzEncode :: Int64 -> Word64 + +ziza = zigZag :: Int64 -> Word64 +zazi = zagZig :: Word8 -> Int8 + +u = undefined + +-- -- check that specialised decode generates the same code as custom decode function +-- inspect $ 'd8 === 'd8s + +-- inspect $ 'd64 === 'd64s + +-- inspect $ 'e64 === 'ziza -- e64 + +-- inspect $ 'zazi === 'd8s + +-- dec, dec1 :: Word8 -> Int8 +-- dec = zzDecode +-- dec1 = zzDecode1 +-- inspect $ 'dec === 'dec1 + + +main :: IO () +main = return () -- print (sz, sz0) diff --git a/plutus-core/flat/test/DocSpec.hs b/plutus-core/flat/test/DocSpec.hs new file mode 100644 index 00000000000..1be6d7e6692 --- /dev/null +++ b/plutus-core/flat/test/DocSpec.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} + +module PlutusCore.Flat.Test.Main where + +import Data.List (isSuffixOf) +import Data.Text qualified as T +import System.Environment +import System.FilePath.Find +import Test.DocTest (doctest, genTests) +t = main + +{- +Note: Some doctests won't compile with ghc 7.10.3 (as they use TypeApplication syntax) +-} + +-- e.g.: stack test :doc --file-watch --fast --test-arguments="Data.ZigZag Flat.Instances Flat.Instances.Base" +main :: IO () +main = do + args <- getArgs + -- print args + files <- if not (null args) + then return $ map + ( T.unpack + . (`T.append` ".hs") + . ("src/" `T.append`) + . T.replace "." "/" + . T.pack + ) + args + else find always ((extension ==? ".hs") &&? exceptFiles []) "src" + -- print files + runTests runOpts files + genTests genOpts files + +runTests opts files = doctest $ opts ++ files + +runOpts = ["--fast", "-XCPP","--verbose"] + +-- static tests are generated with ghcjs compatibility as they cannot be generated in ghcjs +-- but this creates trouble with imports +-- genOpts = runOpts ++ ["-Dghcjs_HOST_OS"] +-- genOpts = runOpts ++ ["-Dghcjs_HOST_OS", "-DETA"] +genOpts = runOpts + +exceptFiles :: Foldable t => t String -> FindClause Bool +exceptFiles mdls = + let excludes = liftOp (\fp modules -> not $ any (`isSuffixOf` fp) modules) + in filePath `excludes` mdls +-- let excludes = liftOp (\fp mdls -> not $ any (\mdl -> isSuffixOf mdl (traceShowId fp)) mdls) diff --git a/plutus-core/flat/test/DocTest.hs b/plutus-core/flat/test/DocTest.hs new file mode 100644 index 00000000000..777bf3623cc --- /dev/null +++ b/plutus-core/flat/test/DocTest.hs @@ -0,0 +1,171 @@ + +-- Execute doctest tests with no dependencies on doctest +-- TODO: move in a different doctest-static package +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} +-- move to doctest +module PlutusCore.Flat.Test.DocTest + ( asPrint + , test + , testProp + , LineChunk(..) + , ExpectedLine(..) + ) +where +import Data.Text qualified as T +import Test.Tasty +import Test.Tasty.HUnit + +import Test.Tasty.QuickCheck +-- import Runner.Example +import Data.Char +import Data.List +import Data.String + +class Print f where + asPrint :: f -> IO String + +instance Show a => Print (IO a) where + asPrint io = io >>= return . show + +instance {-# OVERLAPPABLE #-} Show a => Print a where + asPrint a = return (show a) + +{- + +-} +-- test :: TestName -> ExpectedResult -> IO String -> IO TestTree +test :: TestName -> String -> IO String -> IO TestTree +test loc expectedS valIO = do + let expected = read expectedS + actual <- lines <$> valIO + return $ testCase loc (mkResult expected actual @=? Equal) + -- return $ testCase loc (unlines exp @=? unlines actual) + +testProp :: Testable t => TestName -> t -> IO TestTree +testProp loc = return . testProperty loc + + +-- Code copied and adapted by doctest + +data Result = Equal | NotEqual [String] + deriving (Eq, Show,Read) + +-- | Remove trailing white space from a string. +-- +-- >>> stripEnd "foo " +-- "foo" +stripEnd :: String -> String +stripEnd = reverse . dropWhile isSpace . reverse + +mkResult :: ExpectedResult -> [String] -> Result +mkResult expected actual | expected `matches` actual = Equal + | otherwise = NotEqual (formatNotEqual expected actual) + where + chunksMatch :: [LineChunk] -> String -> Bool + chunksMatch [] "" = True + chunksMatch [LineChunk xs] ys = stripEnd xs == stripEnd ys + chunksMatch (LineChunk x : xs) ys = + x `isPrefixOf` ys && xs `chunksMatch` drop (length x) ys + chunksMatch zs@(WildCardChunk : xs) (_ : ys) = + xs `chunksMatch` ys || zs `chunksMatch` ys + chunksMatch _ _ = False + + matches :: ExpectedResult -> [String] -> Bool + matches (ExpectedLine x : xs) (y : ys) = x `chunksMatch` y && xs `matches` ys + matches (WildCardLine : xs) ys | xs `matches` ys = True + matches zs@(WildCardLine : _) (_ : ys) = zs `matches` ys + matches [] [] = True + matches [] _ = False + matches _ [] = False + + +formatNotEqual :: ExpectedResult -> [String] -> [String] +formatNotEqual expected_ actual = + formatLines "expected: " expected ++ formatLines " but got: " actual + where + expected :: [String] + expected = map + (\x -> case x of + ExpectedLine str -> concatMap lineChunkToString str + WildCardLine -> "..." + ) + expected_ + + -- use show to escape special characters in output lines if any output line + -- contains any unsafe character + escapeOutput | any (not . isSafe) (concat $ expected ++ actual) = map show + | otherwise = id + + isSafe :: Char -> Bool + isSafe c = c == ' ' || (isPrint c && (not . isSpace) c) + + formatLines :: String -> [String] -> [String] + formatLines message xs = case escapeOutput xs of + y : ys -> (message ++ y) : map (padding ++) ys + [] -> [message] + where padding = replicate (length message) ' ' + +lineChunkToString :: LineChunk -> String +lineChunkToString WildCardChunk = "..." +lineChunkToString (LineChunk str) = str + +-- import Control.DeepSeq (deepseq, NFData(rnf)) + +-- | A thing with a location attached. +data Located a = Located Location a + deriving (Eq, Show, Functor) + +-- instance NFData a => NFData (Located a) where +-- rnf (Located loc a) = loc `deepseq` a `deepseq` () + +-- | Discard location information. +unLoc :: Located a -> a +unLoc (Located _ a) = a + +-- | Add dummy location information. +noLocation :: a -> Located a +noLocation = Located (UnhelpfulLocation "") + +-- | A line number. +type Line = Int + +-- | A combination of file name and line number. +data Location = UnhelpfulLocation String | Location FilePath Line + deriving Eq + +instance Show Location where + show (UnhelpfulLocation s) = s + show (Location file line ) = file ++ ":" ++ show line + +-- instance NFData Location where +-- rnf (UnhelpfulLocation str) = str `deepseq` () +-- rnf (Location file line ) = file `deepseq` line `deepseq` () + +-- | +-- Create a list from a location, by repeatedly increasing the line number by +-- one. +enumerate :: Location -> [Location] +enumerate loc = case loc of + UnhelpfulLocation _ -> repeat loc + Location file line -> map (Location file) [line ..] + +data DocTest = Example Expression ExpectedResult | Property Expression + deriving (Eq, Show,Read) + +data LineChunk = LineChunk String | WildCardChunk + deriving (Show, Eq,Read) + +instance IsString LineChunk where + fromString = LineChunk + +data ExpectedLine = ExpectedLine [LineChunk] | WildCardLine + deriving (Show, Eq,Read) + +instance IsString ExpectedLine where + fromString = ExpectedLine . return . LineChunk + +type Expression = String +type ExpectedResult = [ExpectedLine] diff --git a/plutus-core/flat/test/DocTests.hs b/plutus-core/flat/test/DocTests.hs new file mode 100644 index 00000000000..b92593aec3c --- /dev/null +++ b/plutus-core/flat/test/DocTests.hs @@ -0,0 +1,6 @@ +module PlutusCore.Flat.Test.Main where +import DocTest.Flat.AsBin qualified +import Test.Tasty +import Test.Tasty.HUnit + +main = (testGroup "DocTests" <$> sequence [DocTest.Flat.AsBin.tests]) >>= defaultMain diff --git a/plutus-core/flat/test/EndianTest.hs b/plutus-core/flat/test/EndianTest.hs new file mode 100644 index 00000000000..889106d3b29 --- /dev/null +++ b/plutus-core/flat/test/EndianTest.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE CPP #-} +module PlutusCore.Flat.Test.Main where + +-- #include "MachDeps.h" + +-- #include + +-- import System.Arch + +isBigEndian :: Bool +isBigEndian = +#if defined(WORDS_BIGENDIAN) + True +#else + False +#endif + +main = print isBigEndian + +-- printInfo = do +-- print $ "BigEndian: " ++ show isBigEndian +-- print getSystemArch +-- print getSystemEndianness + diff --git a/plutus-core/flat/test/GenEnum.hs b/plutus-core/flat/test/GenEnum.hs new file mode 100644 index 00000000000..469bd3ce662 --- /dev/null +++ b/plutus-core/flat/test/GenEnum.hs @@ -0,0 +1,11 @@ +-- generate test enumerations +g = + let n = 256 + in unwords + [ "data E" ++ show n + , "=" + , intercalate " | " $ map (("N" ++) . show) [1 .. n] + , "deriving (Show,Generic,Flat)" + ] + + diff --git a/plutus-core/flat/test/ListTest.hs b/plutus-core/flat/test/ListTest.hs new file mode 100644 index 00000000000..2fd3e92ffbc --- /dev/null +++ b/plutus-core/flat/test/ListTest.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE CPP #-} +module PlutusCore.Flat.Test.Main where + +import PlutusCore.Flat + +#ifdef ETA_VERSION +import Data.Function (trampoline) +import GHC.IO (trampolineIO) +#else +trampoline = id +trampolineIO = id +#endif + + +longBools = replicate 1000000 False + +main = do + print $ length longBools + print $ (flat longBools) diff --git a/plutus-core/flat/test/MicroSpec.hs b/plutus-core/flat/test/MicroSpec.hs new file mode 100644 index 00000000000..a1372161247 --- /dev/null +++ b/plutus-core/flat/test/MicroSpec.hs @@ -0,0 +1,31 @@ +import Data.ByteString qualified as B +import Data.List +import PlutusCore.Flat +import Test.E +import Test.E.Flat +import Test.Microspec + +-- t = (size E256_256 0, flat E256_4) + +main :: IO () +main = microspec $ do + valTest E3_1 1 [1] + valTest E3_3 2 [193] + valTest E16_1 4 [1] + valTest E16_16 4 [241] + + --valTest E256_1 8 [0, 1] + --valTest E256_256 8 [255, 1] + + -- describe "reverse" $ do + -- it "reverse . reverse === id" + -- $ \l -> reverse (reverse l) === (l :: [Int]) + + -- describe "tail" $ it "length is -1" $ \(NonEmpty l) -> + -- length (tail l :: [Int]) === length l - 1 + + -- describe "solve the halting problem" $ pending + +valTest v sz enc = describe (show v) $ do + it "has right size" $ size v 0 === sz + it "has right encoding" $ B.unpack (flat v) === enc diff --git a/plutus-core/flat/test/Spec.hs b/plutus-core/flat/test/Spec.hs new file mode 100644 index 00000000000..522e2e5a067 --- /dev/null +++ b/plutus-core/flat/test/Spec.hs @@ -0,0 +1,800 @@ +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Tests for the flat module +module Main where + +import Control.Monad +import Data.Bits +import Data.ByteString qualified as B +import Data.ByteString.Lazy qualified as L +import Data.ByteString.Short qualified as SBS +import Data.Char +import Data.Either +import Data.Int +import Data.Proxy +import Data.Sequence qualified as Seq +import Data.String (fromString) +import Data.Text qualified as T +import Data.Text.Arbitrary +import Data.Word +import Numeric.Natural +import PlutusCore.Flat +import PlutusCore.Flat.Bits +import PlutusCore.Flat.Data.FloatCast +import PlutusCore.Flat.Decoder +import PlutusCore.Flat.Encoder qualified as E +import PlutusCore.Flat.Encoder.Prim qualified as E +import PlutusCore.Flat.Encoder.Strict qualified as E +import PlutusCore.Flat.Endian +import System.Exit +import Test.Data +import Test.Data.Arbitrary () +import Test.Data.Flat +import Test.Data.Values hiding (lbs, ns) +import Test.E +import Test.E.Arbitrary () +import Test.E.Flat +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck as QC hiding (getSize) +-- import Test.QuickCheck.Arbitrary +import Data.Complex qualified as B +import Data.IntMap.Lazy qualified as CL +import Data.IntMap.Strict qualified as CS +import Data.Map qualified as C +import Data.Map.Lazy qualified as CL +import Data.Map.Strict qualified as CS +import Data.Ratio qualified as B +-- import Data.List +-- import Data.Ord +#if MIN_VERSION_base(4,9,0) +import Data.List.NonEmpty qualified as BI +#endif + +instance Arbitrary UTF8Text where + arbitrary = UTF8Text <$> arbitrary + + shrink t = UTF8Text <$> shrink (unUTF8 t) + +#if! defined (ETA_VERSION) +instance Arbitrary UTF16Text where + arbitrary = UTF16Text <$> arbitrary + + shrink t = UTF16Text <$> shrink (unUTF16 t) +#endif + +-- instance Flat [Int16] +-- instance Flat [Word8] +-- instance Flat [Bool] +main = do + -- printInfo + -- print $ flat asciiStrT + mainTest + + -- print $ flatRaw 18446744073709551615::Word64 + -- print $ B.unpack . flat $ (True,0::Word64,18446744073709551615::Word64) + -- print (2^56::Word64,fromIntegral (1::Word8) `shiftL` 56 :: Word64,(18446744073709551615::Word64) `shiftR` 1) + -- mainShow + -- eWord64E id 0b +mainShow = do + mapM_ (\_ -> generate (arbitrary :: Gen Int) >>= print) [1 .. 10] + exitFailure + +mainTest = defaultMain tests + +tests :: TestTree +tests = testGroup "Tests" [testPrimitives, testEncDec, testFlat] + +testPrimitives = + testGroup "conversion/memory primitives" [testEndian, testFloatingConvert,testShifts ] + +testEncDec = testGroup + "encode/decode primitives" + [ testEncodingPrim + , testDecodingPrim +#ifdef TEST_DECBITS + , testDecBits +#endif + ] + +testFlat = testGroup + "flat/unflat" + [testSize, testLargeEnum, testContainers, flatUnflatRT, flatTests] + +-- Flat.Endian tests (to run, need to modify imports and cabal file) +testEndian = testGroup + "Endian" + [ convBE toBE16 (2 ^ 10 + 3) (2 ^ 9 + 2 ^ 8 + 4) + , convBE toBE32 (2 ^ 18 + 3) 50332672 + , convBE toBE64 (2 ^ 34 + 3) 216172782180892672 + , convBE toBE16 0x1234 0x3412 + , convBE toBE32 0x11223344 0x44332211 + , convBE toBE64 0x0123456789ABCDEF 0xEFCDAB8967452301] + +testFloatingConvert = testGroup + "Floating conversions" + [ conv floatToWord (-0.15625) 3189768192 + , conv wordToFloat 3189768192 (-0.15625) + , conv doubleToWord (-0.15625) 13818169556679524352 + , conv wordToDouble 13818169556679524352 (-0.15625) + , rt "floatToWord" (prop_float_conv :: RT Float) + , rt "doubleToWord" (prop_double_conv :: RT Double)] + +convBE f v littleEndianE = + let e = if isBigEndian + then v + else littleEndianE + in testCase (unwords ["conv BigEndian", sshow v, "to", sshow e]) $ f v @?= e + +conv f v e = testCase + (unwords ["conv", sshow v, showB . flat $ v, "to", sshow e]) + $ f v @?= e + +testShifts = testGroup "Shifts" $ map tst [0 .. 33] + where + tst n = testCase ("shiftR " ++ show n) + $ let val = 4294967295 :: Word32 + s = val `shift` (-n) + r = val `shiftR` n + in r @?= s + +-- shR = shiftR +-- shR = unsafeShiftR +shR val 0 = val +shR val n = shift val (-n) + +testEncodingPrim = testGroup + "Encoding Primitives" + [ encRawWith 1 E.eTrueF [0b10000001] + , encRawWith 3 (E.eTrueF >=> E.eFalseF >=> E.eTrueF) [0b10100001] + -- Depends on endianess + --,encRawWith 32 (E.eWord32E id $ 2^18 + 3) [3,0,4,0,1] + -- ,encRawWith 64 (E.eWord64E id $ 0x1122334455667788) [0x88,0x77,0x66,0x55,0x44,0x33,0x22,0x11,1] + --,encRawWith 65 (E.eTrueF >=> E.eWord64E id (2^34 + 3)) [1,0,0,0,2,0,0,128,129] + --,encRawWith 65 (E.eFalseF >=> E.eWord64E id (2^34 + 3)) [1,0,0,0,2,0,0,0,129] + -- Big Endian + , encRawWith 32 (E.eWord32BEF $ 2 ^ 18 + 3) [0, 4, 0, 3, 1] + , encRawWith 64 (E.eWord64BEF $ 2 ^ 34 + 3) [0, 0, 0, 4, 0, 0, 0, 3, 1] + , encRawWith + 65 + (E.eTrueF >=> E.eWord64BEF (2 ^ 34 + 3)) + [128, 0, 0, 2, 0, 0, 0, 1, 129] + , encRawWith + 65 + (E.eFalseF >=> E.eWord64BEF (2 ^ 34 + 3)) + [0, 0, 0, 2, 0, 0, 0, 1, 129]] + where + encRawWith sz enc exp = testCase + (unwords ["encode raw with size", show sz]) + $ flatRawWith sz enc @?= exp + +testDecodingPrim = testGroup + "Decoding Primitives" + [ dec + ((,,,) <$> dropBits 13 <*> dBool <*> dBool <*> dBool) + [0b10111110, 0b10011010] + ((), False, True, False) + , dec + ((,,,) <$> dropBits 1 <*> dBE16 <*> dBool <*> dropBits 6) + [0b11000000, 0b00000001, 0b01000000] + ((), 2 ^ 15 + 2, True, ()) + , dec + ((,,,) <$> dropBits 1 <*> dBE32 <*> dBool <*> dropBits 6) + [0b11000000, 0b00000000, 0b00000000, 0b00000001, 0b01000000] + ((), 2 ^ 31 + 2, True, ()) + , dec + dBE64 + [ 0b10000000 + , 0b00000000 + , 0b00000000 + , 0b00000000 + , 0b00000000 + , 0b00000000 + , 0b00000000 + , 0b00000010] + (2 ^ 63 + 2) + , dec + ((,,,) <$> dropBits 1 <*> dBE64 <*> dBool <*> dropBits 6) + [ 0b11000000 + , 0b00000000 + , 0b00000000 + , 0b00000000 + , 0b00000000 + , 0b00000000 + , 0b00000000 + , 0b00000001 + , 0b01000000] + ((), 2 ^ 63 + 2, True, ())] + where + dec decOp v e = testCase (unwords ["decode", sshow v]) + $ unflatRawWith decOp (B.pack v) @?= Right e + +testDecBits = testGroup "Decode Bits" + $ concat + [ decBitsN dBEBits8 + , decBitsN dBEBits16 + , decBitsN dBEBits32 + , decBitsN dBEBits64] +-- Test dBEBits8/16/32/64, extraction of up to 8/16/32/bits from various positions + where + decBitsN :: forall a. + (Num a, FiniteBits a, Show a, Flat a) + => (Int -> Get a) + -> [TestTree] + decBitsN dec = let s = finiteBitSize (undefined :: a) + in [decBits_ dec val numBitsToTake pre + | numBitsToTake <- [0 .. s] + , val <- [ 0 :: a + , 1 + 2 ^ (s - 2) + 2 ^ (s - 5) + , fromIntegral $ (2 ^ s :: Integer) - 1] + , pre <- [0, 1, 7]] + + decBits_ :: forall a. + (FiniteBits a, Show a, Flat a) + => (Int -> Get a) + -> a + -> Int + -> Int + -> TestTree + decBits_ deco val numBitsToTake pre = + -- a sequence composed by pre zero bits followed by the val and zero bits till the next byte boundary + let vs = B.pack . asBytes . fromBools + $ replicate pre False ++ toBools (asBits val) + len = B.length vs + sz = finiteBitSize (undefined :: a) + dec :: Get a + dec = do + dropBits pre + r <- deco numBitsToTake + dropBits (len * 8 - numBitsToTake - pre) + return r + -- we expect the first numBitsToTake bits of the value + expectedD@(Right expected) :: Decoded a = Right + $ val `shR` (sz - numBitsToTake) + actualD@(Right actual) :: Decoded a = unflatRawWith dec vs + in testCase + (unwords + [ "take" + , show numBitsToTake + , "bits from" + , show val + , "of size" + , show sz + , "with prefix" + , show pre + , "sequence" + , showB vs + , show expected + , show actual + , show $ val == actual + , show $ expected == actual + , show $ expected /= actual + , show $ show expected == show actual + , show $ flat expected == flat actual]) + $ actualD @?= expectedD + +testSize = testGroup "Size" + $ concat + [ sz () 0 + , sz True 1 + , sz One 2 + , sz Two 2 + , sz Three 2 + , sz Four 3 + , sz Five 3 + , sz 'a' 8 + , sz 'à' 16 + , sz '经' 24 + , sz (0 :: Word8) 8 + , sz (1 :: Word8) 8 + , concatMap (uncurry sz) ns + , concatMap (uncurry sz) nsI + , concatMap (uncurry sz) nsII + , sz (1.1 :: Float) 32 + , sz (1.1 :: Double) 64 + , sz "" 1 + , sz "abc" (4 + 3 * 8) + , sz ((), (), Unit) 0 + , sz (True, False, One, Five) 7 + , sz map1 7 + , sz bs (4 + 3 * 8) + , sz stBS bsSize + , sz lzBS bsSize + , sz shBS bsSize + , sz tx utf8Size + , sz (UTF8Text tx) utf8Size +#if ! defined (ETA_VERSION) + , sz (UTF16Text tx) utf16Size +#endif + ] + where + tx = T.pack "txt" + +#if MIN_VERSION_text(2,0,0) + utf8Size = 8 + 8 + (3 * 8) + 8 +#else + utf8Size = 8 + 8 + (3 * 3 * 8) + 8 +#endif + utf16Size = 8 + 8 + 3 * 16 + 8 + + bsSize = 8 + 8 + 3 * 8 + 8 + +sz v e = let calculated = getSize v + actual = B.length (flat v) * 8 - 1 -- FIX + in + [testCase (unwords ["size of", sshow v]) $ calculated @?= e + -- ,testCase (unwords ["calculated size <= actual", sshow v]) $ actual <= calculated @? unwords ["calculated size",show calculated,"actual",show actual] + ] + +-- E258_256 = 11111110 _257 = 111111110 _258 = 111111111 +testLargeEnum = testGroup "test enum with more than 256 constructors" + $ concat + [ +#ifdef ENUM_LARGE + sz E258_256 8 + , sz E258_257 9 + , sz E258_258 9 + -- As encodes are inlined, this is going to take for ever if this is compiled with -O1 or -O2 + -- , encRaw (E258_256) [0b11111110] + -- , encRaw (E258_257) [0b11111111,0b00000000] + -- , encRaw (E258_258) [0b11111111,0b10000000] + -- , encRaw (E258_256,E258_257,E258_258) [0b11111110,0b11111111,0b01111111,0b11000000] + , map trip [E258_1, E258_256, E258_257, E258_258] + , map trip [E256_1, E256_134, E256_256] +#endif + ] + +testContainers = + testGroup "containers" [trip longSeq, trip dataMap, trip listMap] + + -- , trip intMap +flatUnflatRT = testGroup + "unflat (flat v) == v" + [ rt "()" (prop_Flat_roundtrip :: RT ()) + , rt "Bool" (prop_Flat_roundtrip :: RT Bool) + , rt "Char" (prop_Flat_roundtrip :: RT Char) + , rt "Complex" (prop_Flat_roundtrip :: RT (B.Complex Float)) + , rt "Either N Bool" (prop_Flat_roundtrip :: RT (Either N Bool)) + , rt "Either Int Char" (prop_Flat_roundtrip :: RT (Either Int Char)) + , rt "Int8" (prop_Flat_Large_roundtrip :: RTL Int8) + , rt "Int16" (prop_Flat_Large_roundtrip :: RTL Int16) + , rt "Int32" (prop_Flat_Large_roundtrip :: RTL Int32) + , rt "Int64" (prop_Flat_Large_roundtrip :: RTL Int64) + , rt "Int" (prop_Flat_Large_roundtrip :: RTL Int) + , rt "[Int16]" (prop_Flat_roundtrip :: RT [Int16]) + , rt "String" (prop_Flat_roundtrip :: RT String) +#if MIN_VERSION_base(4,9,0) + , rt "NonEmpty" (prop_Flat_roundtrip :: RT (BI.NonEmpty Bool)) +#endif + , rt "Maybe N" (prop_Flat_roundtrip :: RT (Maybe N)) + , rt "Ratio" (prop_Flat_roundtrip :: RT (B.Ratio Int32)) + , rt "Word8" (prop_Flat_Large_roundtrip :: RTL Word8) + , rt "Word16" (prop_Flat_Large_roundtrip :: RTL Word16) + , rt "Word32" (prop_Flat_Large_roundtrip :: RTL Word32) + , rt "Word64" (prop_Flat_Large_roundtrip :: RTL Word64) + , rt "Word" (prop_Flat_Large_roundtrip :: RTL Word) + , rt "Natural" (prop_Flat_roundtrip :: RT Natural) + , rt "Integer" (prop_Flat_roundtrip :: RT Integer) + , rt "Float" (prop_Flat_roundtrip :: RT Float) + , rt "Double" (prop_Flat_roundtrip :: RT Double) + , rt "Text" (prop_Flat_roundtrip :: RT T.Text) + , rt "UTF8 Text" (prop_Flat_roundtrip :: RT UTF8Text) +#if! defined (ETA_VERSION) + , rt "UTF16 Text" (prop_Flat_roundtrip :: RT UTF16Text) +#endif + , rt "ByteString" (prop_Flat_roundtrip :: RT B.ByteString) + , rt "Lazy ByteString" (prop_Flat_roundtrip :: RT L.ByteString) + , rt "Short ByteString" (prop_Flat_roundtrip :: RT SBS.ShortByteString) + , rt "Map.Strict" (prop_Flat_roundtrip :: RT (CS.Map Int Bool)) + , rt "Map.Lazy" (prop_Flat_roundtrip :: RT (CL.Map Int Bool)) + , rt "IntMap.Strict" (prop_Flat_roundtrip :: RT (CS.IntMap Bool)) + , rt "IntMap.Lazy" (prop_Flat_roundtrip :: RT (CL.IntMap Bool)) + , rt "Unit" (prop_Flat_roundtrip :: RT Unit) + , rt "Un" (prop_Flat_roundtrip :: RT Un) + , rt "N" (prop_Flat_roundtrip :: RT N) + , rt "E2" (prop_Flat_roundtrip :: RT E2) + , rt "E3" (prop_Flat_roundtrip :: RT E3) + , rt "E4" (prop_Flat_roundtrip :: RT E4) + , rt "E8" (prop_Flat_roundtrip :: RT E8) + , rt "E16" (prop_Flat_roundtrip :: RT E16) + , rt "E17" (prop_Flat_roundtrip :: RT E17) + , rt "E32" (prop_Flat_roundtrip :: RT E32) + , rt "A" (prop_Flat_roundtrip :: RT A) + , rt "B" (prop_Flat_roundtrip :: RT B) + -- ,rt "Tree Bool" (prop_Flat_roundtrip:: RT (Tree Bool)) + -- ,rt "Tree N" (prop_Flat_roundtrip:: RT (Tree N)) + , rt "List N" (prop_Flat_roundtrip :: RT (List N))] + +rt n = QC.testProperty (unwords ["round trip", n]) + +flatTests = testGroup "flat/unflat Unit tests" + $ concat + [ -- Expected errors + errDec (Proxy :: Proxy Bool) [] -- no data + , errDec (Proxy :: Proxy Bool) [128] -- no filler + , errDec (Proxy :: Proxy Bool) [128 + 1, 1, 2, 4, 8] -- additional bytes + , errDec (Proxy :: Proxy Text) (B.unpack (flat ((fromString "\x80") :: B.ByteString))) -- invalid UTF-8 + , encRaw () [] + , encRaw ((), (), Unit) [] + , encRaw (Unit, 'a', Unit, 'a', Unit, 'a', Unit) [97, 97, 97] + , a () [1] + , a True [128 + 1] + , a (True, True) [128 + 64 + 1] + , a (True, False, True) [128 + 32 + 1] + , a (True, False, True, True) [128 + 32 + 16 + 1] + , a (True, False, True, True, True) [128 + 32 + 16 + 8 + 1] + , a (True, False, True, True, True, True) [128 + 32 + 16 + 8 + 4 + 1] + , a + (True, False, True, True, True, True, True) + [128 + 32 + 16 + 8 + 4 + 2 + 1] + , a + (True, False, True, True, (True, True, True, True)) + [128 + 32 + 16 + 8 + 4 + 2 + 1, 1] + , encRaw (True, False, True, True) [128 + 32 + 16] + , encRaw + ( (True, True, False, True, False) + , (False, False, True, False, True, True)) + [128 + 64 + 16 + 1, 64 + 32] + , encRaw ('\0', '\1', '\127') [0, 1, 127] + , encRaw (33 :: Word32, 44 :: Word32) [33, 44] + --,s (Elem True) [64] + --,s (NECons True (NECons False (Elem True))) [128+64+32+4] + , encRaw (0 :: Word8) [0] + , encRaw (1 :: Word8) [1] + , encRaw (255 :: Word8) [255] + , encRaw (0 :: Word16) [0] + , encRaw (1 :: Word16) [1] + , encRaw (255 :: Word16) [255, 1] + , encRaw (256 :: Word16) [128, 2] + , encRaw (65535 :: Word16) [255, 255, 3] + , encRaw (127 :: Word32) [127] + , encRaw (128 :: Word32) [128, 1] + , encRaw (129 :: Word32) [129, 1] + , encRaw (255 :: Word32) [255, 1] + , encRaw (16383 :: Word32) [255, 127] + , encRaw (16384 :: Word32) [128, 128, 1] + , encRaw (16385 :: Word32) [129, 128, 1] + , encRaw (32767 :: Word32) [255, 255, 1] + , encRaw (32768 :: Word32) [128, 128, 2] + , encRaw (32769 :: Word32) [129, 128, 2] + , encRaw (65535 :: Word32) [255, 255, 3] + , encRaw (2097151 :: Word32) [255, 255, 127] + , encRaw (2097152 :: Word32) [128, 128, 128, 1] + , encRaw (2097153 :: Word32) [129, 128, 128, 1] + , encRaw (4294967295 :: Word32) [255, 255, 255, 255, 15] + , encRaw (255 :: Word64) [255, 1] + , encRaw (65535 :: Word64) [255, 255, 3] + , encRaw (4294967295 :: Word64) [255, 255, 255, 255, 15] + , encRaw + (18446744073709551615 :: Word64) + [255, 255, 255, 255, 255, 255, 255, 255, 255, 1] + , encRaw + (False, 18446744073709551615 :: Word64) + [127, 255, 255, 255, 255, 255, 255, 255, 255, 128, 128] + , encRaw (255 :: Word) [255, 1] + , encRaw (65535 :: Word) [255, 255, 3] + , encRaw (4294967295 :: Word) [255, 255, 255, 255, 15] + , tstI [0 :: Int8, 2, -2] + , encRaw (127 :: Int8) [254] + , encRaw (-128 :: Int8) [255] + , tstI [0 :: Int16, 2, -2, 127, -128] + , tstI [0 :: Int32, 2, -2, 127, -128] + , tstI [0 :: Int64, 2, -2, 127, -128] + , encRaw (-1024 :: Int64) [255, 15] + , encRaw (maxBound :: Word8) [255] + , encRaw (True, maxBound :: Word8) [255, 128] + , encRaw (maxBound :: Word16) [255, 255, 3] + , encRaw (True, maxBound :: Word16) [255, 255, 129, 128] + , encRaw (maxBound :: Word32) [255, 255, 255, 255, 15] + , encRaw (True, maxBound :: Word32) [255, 255, 255, 255, 135, 128] + , encRaw + (maxBound :: Word64) + [255, 255, 255, 255, 255, 255, 255, 255, 255, 1] + , encRaw + (True, maxBound :: Word64) + [255, 255, 255, 255, 255, 255, 255, 255, 255, 128, 128] + , encRaw + (minBound :: Int64) + [255, 255, 255, 255, 255, 255, 255, 255, 255, 1] + , encRaw + (maxBound :: Int64) + [254, 255, 255, 255, 255, 255, 255, 255, 255, 1] + , tstI [0 :: Int, 2, -2, 127, -128] + , tstI [0 :: Integer, 2, -2, 127, -128, -256, -512] + , encRaw (-1024 :: Integer) [255, 15] + , encRaw (0 :: Float) [0, 0, 0, 0] + , encRaw (-2 :: Float) [0b11000000, 0, 0, 0] + , encRaw (0.085 :: Float) [0b00111101, 0b10101110, 0b00010100, 0b01111011] + , encRaw (0 :: Double) [0, 0, 0, 0, 0, 0, 0, 0] + , encRaw (-2 :: Double) [0b11000000, 0, 0, 0, 0, 0, 0, 0] + , encRaw (23 :: Double) [0b01000000, 0b00110111, 0, 0, 0, 0, 0, 0] + , encRaw (-0.15625 :: Float) [0b10111110, 0b00100000, 0, 0] + , encRaw (-0.15625 :: Double) [0b10111111, 0b11000100, 0, 0, 0, 0, 0, 0] + , encRaw + (-123.2325E-23 :: Double) + [ 0b10111011 + , 0b10010111 + , 0b01000111 + , 0b00101000 + , 0b01110101 + , 0b01111011 + , 0b01000111 + , 0b10111010] + , encRaw (Left True :: Either Bool (Double, Double)) [0b01000000] + , encRaw (-2.1234E15 :: Double) [195, 30, 44, 226, 90, 221, 64, 0] + , encRaw (1.1234E-22 :: Double) [59, 96, 249, 241, 120, 219, 249, 174] + , encRaw + ((False, -2.1234E15) :: (Bool, Double)) + [97, 143, 22, 113, 45, 110, 160, 0, 0] + , encRaw + ((True, -2.1234E15) :: (Bool, Double)) + [225, 143, 22, 113, 45, 110, 160, 0, 0] + , encRaw ((-2.1234E15, 1.1234E-22) :: (Double, Double)) + $ [0b11000011, 30, 44, 226, 90, 221, 64, 0] + ++ [59, 96, 249, 241, 120, 219, 249, 174] + , encRaw + ((True, -2.1234E15, 1.1234E-22) :: (Bool, Double, Double)) + [ 0b11100001 + , 143 + , 22 + , 113 + , 45 + , 110 + , 160 + , 0 + , 29 + , 176 + , 124 + , 248 + , 188 + , 109 + , 252 + , 215 + , 0] + , encRaw + (Right (-2.1234E15, 1.1234E-22) :: Either Bool (Double, Double)) + [ 0b11100001 + , 143 + , 22 + , 113 + , 45 + , 110 + , 160 + , 0 + , 29 + , 176 + , 124 + , 248 + , 188 + , 109 + , 252 + , 215 + , 0] + , encRaw (Left True :: Either Bool Direction) [0b01000000] + , encRaw (Right West :: Either Bool Direction) [0b11110000] + , map trip [minBound, maxBound :: Word8] + , map trip [minBound, maxBound :: Word16] + , map trip [minBound, maxBound :: Word32] + , map trip [minBound, maxBound :: Word64] + , map trip [minBound :: Int8, maxBound :: Int8] + , map trip [minBound :: Int16, maxBound :: Int16] + , map trip [minBound :: Int32, maxBound :: Int32] + , map trip [minBound :: Int64, maxBound :: Int64] + , map tripShow [0 :: Float, -0 :: Float, 0 / 0 :: Float, 1 / 0 :: Float] + , map + tripShow + [0 :: Double, -0 :: Double, 0 / 0 :: Double, 1 / 0 :: Double] + , encRaw '\0' [0] + , encRaw '\1' [1] + , encRaw '\127' [127] + , encRaw 'a' [97] + , encRaw 'à' [224, 1] + , encRaw '经' [207, 253, 1] + , [trip [chr 0x10FFFF]] + , encRaw Unit [] + , encRaw (Un False) [0] + , encRaw (One, Two, Three) [16 + 8] + , encRaw (Five, Five, Five) [255, 128] + --,s (NECons True (Elem True)) [128+64+16] + , encRaw "" [0] +#ifdef LIST_BIT + , encRaw "abc" [176, 216, 172, 96] + , encRaw [False, True, False, True] [128 + 32 + 16 + 8 + 2 + 1, 0] +#elif defined(LIST_BYTE) + , s "abc" s3 + , s (cs 600) s600 +#endif + -- Aligned structures + --,s (T.pack "") [1,0] + --,s (Just $ T.pack "abc") [128+1,3,97,98,99,0] + --,s (T.pack "abc") (al s3) + --,s (T.pack $ cs 600) (al s600) + , encRaw map1 [0b10111000] + , encRaw (B.pack $ csb 3) (bsl c3) + , encRaw (B.pack $ csb 600) (bsl s600) + , encRaw (L.pack $ csb 3) (bsl c3) + -- Long LazyStrings can have internal sections shorter than 255 + --,s (L.pack $ csb 600) (bsl s600) + , [trip [1 .. 100 :: Int16]] + -- See https://github.com/typelead/eta/issues/901 +#ifndef ETA_VERSION + , [trip longAsciiStrT] + , [trip longBoolListT] +#endif + , [trip asciiTextT] + , [trip english] + , [trip "维护和平正"] + , [trip (T.pack "abc")] + , [trip unicodeText] + , [trip unicodeTextUTF8T] + , [trip chineseTextUTF8T] +#if ! defined (ETA_VERSION) + , [trip chineseTextUTF16T] + , [trip unicodeTextUTF16T] +#endif + , [trip longBS, trip longLBS] + , [trip longSBS] + ] +--al = (1:) -- prealign + where + bsl = id -- noalign + + tstI = map ti + + ti v + | v >= 0 = testCase (unwords ["Int", show v]) + $ teq v (2 * fromIntegral v :: Word64) + | otherwise = testCase (unwords ["Int", show v]) + $ teq v (2 * fromIntegral (-v) - 1 :: Word64) + + teq a b = ser a @?= ser b + + --,testCase (unwords ["unflat raw",sshow v]) $ desRaw e @?= Right v] + -- Aligned values unflat to the original value, modulo the added filler. + a v e = [ testCase (unwords ["flat", sshow v]) $ ser v @?= e + , testCase (unwords ["unflat", sshow v]) + $ let Right v' = des e + in v @?= v'] + + -- a v e = [testCase (unwords ["flat postAligned",show v]) $ ser (postAligned v) @?= e + -- ,testCase (unwords ["unflat postAligned",show v]) $ let Right (PostAligned v' _) = des e in v @?= v'] +encRaw :: forall a. (Show a, Flat a) => a -> [Word8] -> [TestTree] +encRaw v e = + [ testCase (unwords ["flat raw", sshow v, show . B.unpack . flat $ v]) + $ serRaw v @?= e] + +trip :: forall a. (Show a, Flat a, Eq a) => a -> TestTree +trip v = testCase (unwords ["roundtrip", sshow v]) + $ + -- direct comparison + (unflat (flat v :: B.ByteString) :: Decoded a) @?= (Right v :: Decoded a) + +tripShow :: forall a. (Show a, Flat a, Eq a) => a -> TestTree +tripShow v = testCase (unwords ["roundtrip", sshow v]) + $ + -- we use show to get Right NaN == Right NaN + show (unflat (flat v :: B.ByteString) :: Decoded a) + @?= show (Right v :: Decoded a) + +-- Test Data +lzBS = L.pack bs + +stBS = B.pack bs + +bs = [32, 32, 32 :: Word8] + +s3 = [3, 97, 98, 99, 0] + +c3a = [3, 99, 99, 99, 0] -- Array Word8 + +c3 = pre c3a + +s600 = pre s600a + +pre = (1:) + +s600a = concat [[255], csb 255, [255], csb 255, [90], csb 90, [0]] + +s600B = + concat [[55], csb 55, [255], csb 255, [90], csb 90, [200], csb 200, [0]] + +longSeq :: Seq.Seq Word8 +longSeq = Seq.fromList lbs + +longBS = B.pack lbs + +longLBS = L.concat $ concat $ replicate 10 [L.pack lbs] + +lbs = concat $ replicate 100 [234, 123, 255, 0] + +cs n = replicate n 'c' -- take n $ cycle ['a'..'z'] + +csb = map (fromIntegral . ord) . cs + +map1 = C.fromList [(False, True), (True, False)] + +ns :: [(Word64, Int)] +ns = [((-) (2 ^ (i * 7)) 1, fromIntegral (8 * i)) | i <- [1 .. 10]] + +nsI :: [(Int64, Int)] +nsI = nsI_ + +nsII :: [(Integer, Int)] +nsII = nsI_ + +nsI_ = [((-) (2 ^ (((-) i 1) * 7)) 1, fromIntegral (8 * i)) | i <- [1 .. 10]] + +shBS = SBS.toShort stBS + +longSBS = SBS.toShort longBS + +sshow = take 80 . show + +showB = show . B.unpack + +errDec :: forall a. (Flat a, Eq a, Show a) => Proxy a -> [Word8] -> [TestTree] + +--errDec _ bs = [testCase "bad decode" $ let ev = (des bs::Decoded a) in ev @?= Left ""] +errDec _ bs = [ testCase "bad decode" + $ let ev = (des bs :: Decoded a) + in isRight ev @?= False] + +ser :: Flat a => a -> [Word8] +ser = B.unpack . flat + +des :: Flat a => [Word8] -> Decoded a +des = unflat + +flatRawWith sz enc = B.unpack + $ E.strictEncoder (sz + 8) (E.Encoding $ enc >=> E.eFillerF) + +serRaw :: Flat a => a -> [Word8] + +-- serRaw = B.unpack . flatRaw +-- serRaw = L.unpack . flatRaw +serRaw = asBytes . bits + +--desRaw :: Flat a => [Word8] -> Decoded a +--desRaw = unflatRaw . L.pack +type RT a = a -> Bool + +type RTL a = Large a -> Bool + +prop_Flat_roundtrip :: (Flat a, Eq a) => a -> Bool +prop_Flat_roundtrip = roundTripExt + +prop_Flat_Large_roundtrip :: (Eq b, Flat b) => Large b -> Bool +prop_Flat_Large_roundtrip (Large x) = roundTripExt x + +roundTrip x = unflat (flat x :: B.ByteString) == Right x + +-- Test roundtrip for both the value and the value embedded between bools +roundTripExt x = roundTrip x && roundTrip (True, x, False) + +prop_double_conv d = wordToDouble (doubleToWord d) == d + +prop_float_conv d = wordToFloat (floatToWord d) == d +{- +prop_common_unsigned :: (Num l,Num h,Flat l,Flat h) => l -> h -> Bool +prop_common_unsigned n _ = let n2 :: h = fromIntegral n + in flat n == flat n2 +-} +-- e :: Stream Bool +-- e = unflatIncremental . flat $ stream1 +-- el :: List Bool +-- el = unflatIncremental . flat $ infList +-- deflat = unflat +-- b1 :: BLOB UTF8 +-- b1 = BLOB UTF8 (preAligned (List255 [97,98,99])) +-- -- b1 = BLOB (preAligned (UTF8 (List255 [97,98,99]))) + + + + diff --git a/plutus-core/flat/test/Test/Data.hs b/plutus-core/flat/test/Test/Data.hs new file mode 100644 index 00000000000..b839fdceffe --- /dev/null +++ b/plutus-core/flat/test/Test/Data.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +{- + A collection of data types used for testing. +-} +module Test.Data where + +import Data.Data +import Data.Int +import Data.Word +import GHC.Generics +import Test.Data2 qualified as D2 + +-- import Test.Tasty.QuickCheck +data Void + deriving Generic + +data X = X X + deriving Generic + +data Unit = Unit + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +data Un = Un { un :: Bool } + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +data D2 = D2 Bool N + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +data D4 = D4 Bool N Unit N3 + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +-- Enumeration +data N3 = N1 + | N2 + | N3 + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic, Enum) + +data N = One + | Two + | Three + | Four + | Five + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic, Enum, Bounded) + +-- toForestD :: Forest a -> ForestD (Tr2 a) +-- toForestD (Forest lt) = undefined -- Forest2 (ForestD (map (\t -> let Tr2 tt = treeConv t in tt) . toList $ lt)) +-- toForestD (Forest lt) = undefined -- Forest2 (ForestD (map (\t -> let Tr2 tt = treeConv t in tt) . toList $ lt)) +toForest2 :: Forest a -> Forest2 a +toForest2 (Forest f) = Forest2 (ForestD $ fmap toTr f) + +toTr :: Tr a -> TrD (Forest2 a) a +toTr (Tr a f) = TrD a (toForest2 f) + +toTr2 :: Tr a -> Tr2 a +toTr2 (Tr a (Forest f)) = Tr2 (TrD a (ForestD $ fmap toTr2 f)) + +-- tying the recursive knot, equivalent to Forest/Tree +data Forest2 a = Forest2 (ForestD (TrD (Forest2 a) a)) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +data Tr2 a = Tr2 (TrD (ForestD (Tr2 a)) a) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +-- First-order non mutually recursive +data ForestD t = ForestD (List t) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +data TrD f a = TrD a f + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +-- Explicit mutually recursive +data Forest a = Forest (List (Tr a)) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +data Tr a = Tr a (Forest a) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +data Words = Words Word8 Word16 Word32 Word64 + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +data Ints = Ints Int8 Int16 Int32 Int64 + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +-- non-recursive data type +data Various = V1 (Maybe Bool) + -- | V2 Bool (Either Bool (Maybe Bool)) (N,N,N) + | V2 Bool (Either Bool (Maybe Bool)) + | VF Float Double Double + | VW Word Word8 Word16 Word32 Word64 + | VI Int Int8 Int16 Int32 Int64 + | VII Integer Integer Integer + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +-- Phantom type +data Phantom a = Phantom + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +-- Recursive data types +data RR a b c = RN { rna :: a, rnb :: b, rnc :: c } + | RA a (RR a a c) b + | RAB a (RR c b a) b + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +data Expr = ValB Bool + | Or Expr Expr + | If Expr Expr Expr + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +data List a = C a (List a) + | N + deriving (Eq, Ord, Read, Show, Typeable, Traversable, Data, Generic, Generic1 + , Functor, Foldable) + +data ListS a = Nil + | Cons a (ListS a) + deriving (Eq, Ord, Read, Show, Typeable, Functor, Foldable, Traversable, Data + , Generic, Generic1) + +-- non-regular Haskell datatypes like: +-- Binary instances but no Model +data Nest a = NilN + | ConsN (a, Nest (a, a)) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +data TN a = LeafT a + | BranchT (TN (a, a)) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +data Bush a = NilB + | ConsB (a, Bush (Bush a)) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +-- Perfectly balanced binary tree +data Perfect a = ZeroP a + | SuccP (Perfect (Fork a)) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +data Fork a = Fork a a + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +-- non regular with higher-order kind parameters +-- no Binary/Model instances +data PerfectF f α = NilP + | ConsP α (PerfectF f (f α)) + deriving (Typeable, Generic) -- No Data + +data Pr f g a = Pr (f a (g a)) + +data Higher f a = Higher (f a) + deriving (Typeable, Generic, Data) + +-- data Pr2 (f :: * -> *) a = Pr2 (f ) +data Free f a = Pure a + | Roll (f (Free f a)) + deriving (Typeable, Generic) + +-- mutual references +data A = A B + | AA Int + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +data B = B A + | BB Char + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +-- recursive sets: +-- Prob: ghc will just explode on this +-- data MM1 = MM1 MM2 MM4 MM0 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +-- data MM0 = MM0 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +-- data MM2 = MM2 MM3 Bool deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +-- data MM3 = MM3 MM4 Bool deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +-- data MM4 = MM4 MM4 MM2 MM5 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +-- data MM5 = MM5 Unit MM6 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +-- data MM6 = MM6 MM5 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +data A0 = A0 B0 B0 D0 Bool + | A1 (List Bool) (List Unit) (D2.List Bool) (D2.List Bool) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +data B0 = B0 C0 + | B1 + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +data C0 = C0 A0 + | C1 + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +data D0 = D0 E0 + | D1 + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +data E0 = E0 D0 + | E1 + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +data Even = Zero + | SuccE Odd + +data Odd = SuccO Even + +-- Existential types +-- data Fold a b = forall x. Fold (x -> a -> x) x (x -> b) +-- data Some :: (* -> *) -> * where +-- Some :: f a -> Some f +-- data Dict (c :: Constraint) where +-- Dict :: c => Dict c +data Direction = North + | South + | Center + | East + | West + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +data Stream a = Stream a (Stream a) + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic, Functor, Foldable + , Traversable) + +data Tree a = Node (Tree a) (Tree a) + | Leaf a + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic, Foldable) + +-- Example schema from: http://mechanical-sympathy.blogspot.co.uk/2014/05/simple-binary-encoding.html +data Car = + Car { serialNumber :: Word64 + , modelYear :: Word16 + , available :: Bool + , code :: CarModel + , someNumbers :: [Int32] + , vehicleCode :: String + , extras :: [OptionalExtra] + , engine :: Engine + , fuelFigures :: [Consumption] + , performanceFigures :: [(OctaneRating, [Acceleration])] + , make :: String + , carModel :: String + } + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +data Acceleration = Acceleration { mph :: Word16, seconds :: Float } + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +type OctaneRating = Word8 -- minValue="90" maxValue="110" + +data Consumption = Consumption { cSpeed :: Word16, cMpg :: Float } + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +data CarModel = ModelA + | ModelB + | ModelC + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +data OptionalExtra = SunRoof + | SportsPack + | CruiseControl + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +data Engine = Engine { capacity :: Word16 + , numCylinders :: Word8 + , maxRpm :: Word16 -- constant 9000 + , manufacturerCode :: String + , fuel :: String -- constant Petrol + } + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + diff --git a/plutus-core/flat/test/Test/Data/Arbitrary.hs b/plutus-core/flat/test/Test/Data/Arbitrary.hs new file mode 100644 index 00000000000..36f7543c519 --- /dev/null +++ b/plutus-core/flat/test/Test/Data/Arbitrary.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Data.Arbitrary where +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BL +import Data.ByteString.Short qualified as SBS +import Data.Text qualified as TS +import Data.Text.Lazy qualified as TL +import Test.Data +import Test.Tasty.QuickCheck +-- import Data.DeriveTH + +-- #if MIN_VERSION_base(4,9,0) +import Data.List.NonEmpty qualified as BI +-- #endif + +import Numeric.Natural (Natural) + +#if MIN_VERSION_base(4,8,0) && MIN_VERSION_QuickCheck(2,10,0) +instance Arbitrary a => Arbitrary (BI.NonEmpty a) where + arbitrary = BI.fromList . getNonEmpty <$> (arbitrary :: Gen (NonEmptyList a)) + shrink xs = BI.fromList <$> shrink (BI.toList xs) + +instance Arbitrary Natural where + arbitrary = arbitrarySizedNatural + shrink = shrinkIntegral +#endif + +-- Copied from quickcheck-instances (not used directly as it requires old-time that is incompatible with ghcjs) + +instance Arbitrary BS.ByteString where + arbitrary = BS.pack <$> arbitrary + shrink xs = BS.pack <$> shrink (BS.unpack xs) + +instance Arbitrary BL.ByteString where + arbitrary = BL.pack <$> arbitrary + shrink xs = BL.pack <$> shrink (BL.unpack xs) + +instance Arbitrary SBS.ShortByteString where + arbitrary = SBS.pack <$> arbitrary + shrink xs = SBS.pack <$> shrink (SBS.unpack xs) + +-- instance Arbitrary TS.Text where +-- arbitrary = TS.pack <$> arbitrary +-- shrink xs = TS.pack <$> shrink (TS.unpack xs) + +-- instance Arbitrary TL.Text where +-- arbitrary = TL.pack <$> arbitrary +-- shrink xs = TL.pack <$> shrink (TL.unpack xs) + +-- xxx = generate (arbitrary :: Gen (Large (Int))) + +{- +-- derive makeArbitrary ''N +derive makeArbitrary ''Tree + +derive makeArbitrary ''List + +derive makeArbitrary ''Unit + +derive makeArbitrary ''Un + +derive makeArbitrary ''A + +derive makeArbitrary ''B +-} +-- instance Arbitrary Word7 where arbitrary = toEnum <$> choose (0, 127) +-- derive makeArbitrary ''ASCII +-- To generate Arbitrary instances while avoiding a direct dependency on 'derive' (that is not supported by Eta) + +-- , run in the project directory: derive -a test/Test/Data.hs --derive=Arbitrary +{-! +deriving instance Arbitrary N +deriving instance Arbitrary Tree +deriving instance Arbitrary List +deriving instance Arbitrary Unit +deriving instance Arbitrary Un +deriving instance Arbitrary A +deriving instance Arbitrary B +!-} +-- GENERATED START +instance () => Arbitrary N where + arbitrary = do + x <- choose (0 :: Int, 4) + case x of + 0 -> return One + 1 -> return Two + 2 -> return Three + 3 -> return Four + 4 -> return Five + _ -> error "FATAL ERROR: Arbitrary instance, logic bug" + +instance (Arbitrary a) => Arbitrary (Tree a) where + arbitrary = do + x <- choose (0 :: Int, 1) + case x of + 0 -> do + x1 <- arbitrary + x2 <- arbitrary + return (Node x1 x2) + 1 -> Leaf <$> arbitrary + _ -> error "FATAL ERROR: Arbitrary instance, logic bug" + +instance (Arbitrary a) => Arbitrary (List a) where + arbitrary = do + x <- choose (0 :: Int, 1) + case x of + 0 -> do + x1 <- arbitrary + x2 <- arbitrary + return (C x1 x2) + 1 -> return N + _ -> error "FATAL ERROR: Arbitrary instance, logic bug" + +instance () => Arbitrary Unit where + arbitrary = return Unit + +instance () => Arbitrary Un where + arbitrary = Un <$> arbitrary + +instance () => Arbitrary A where + arbitrary = do + x <- choose (0 :: Int, 1) + case x of + 0 -> A <$> arbitrary + 1 -> AA <$> arbitrary + _ -> error "FATAL ERROR: Arbitrary instance, logic bug" + +instance () => Arbitrary B where + arbitrary = do + x <- choose (0 :: Int, 1) + case x of + 0 -> B <$> arbitrary + 1 -> BB <$> arbitrary + _ -> error "FATAL ERROR: Arbitrary instance, logic bug" +-- GENERATED STOP diff --git a/plutus-core/flat/test/Test/Data/Flat.hs b/plutus-core/flat/test/Test/Data/Flat.hs new file mode 100644 index 00000000000..ca6b406f7e9 --- /dev/null +++ b/plutus-core/flat/test/Test/Data/Flat.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +module Test.Data.Flat + ( module Test.Data + ) +where + +import PlutusCore.Flat +-- import Flat.Encoder +-- import Flat.Decoder +import Test.Data +import Test.Data2.Flat () +-- import Data.Word +-- import Data.Foldable +-- import Data.Int +-- import GHC.Generics + +{- +Compilation times: + encoderS specials cases | +| 7.10.3 | NO | 0:44 | +| 7.10.3 | YES | 0:39 | +| 8.0.1 | NO | 1:30 | +| 8.0.1 | YES | 1:30 | +| 8.0.2 | NO | 4:18 | +| 8.0.2 | YES | 4:18 | +-} +-- GHC 8.0.2 chokes on this +-- instance Flat A0 +-- instance Flat B0 +-- instance Flat C0 +-- instance Flat D0 +-- instance Flat E0 +#if MIN_VERSION_base(4,9,0) && ! MIN_VERSION_base(4,16,0) +deriving instance Generic (a, b, c, d, e, f, g, h) + +deriving instance Generic (a, b, c, d, e, f, g, h, i) +#endif + +instance {-# OVERLAPPABLE #-}( Flat a + , Flat b + , Flat c + , Flat d + , Flat e + , Flat f + , Flat g + , Flat h) => Flat (a, b, c, d, e, f, g, h) + +instance {-# OVERLAPPABLE #-}( Flat a + , Flat b + , Flat c + , Flat d + , Flat e + , Flat f + , Flat g + , Flat h + , Flat i) => Flat (a, b, c, d, e, f, g, h, i) + +instance Flat N + +instance Flat Unit + +instance Flat a => Flat (List a) + +instance Flat a => Flat (Tree a) + +instance Flat Direction + +instance Flat Words + +instance Flat Ints + +instance Flat Void + +instance Flat N3 + +instance Flat Un + +instance Flat a => Flat (ListS a) + +instance Flat A + +instance Flat B + +instance Flat D2 + +instance Flat D4 + +instance Flat a => Flat (Phantom a) + +-- Slow to compile +instance Flat Various +-- Custom instances +-- instance {-# OVERLAPPING #-} Flat (Tree (N,N,N)) --where +-- size (Node t1 t2) = 1 + size t1 + size t2 +-- size (Leaf a) = 1 + size a +-- -57% +-- instance {-# OVERLAPPING #-} Flat [N] -- where size = foldl' (\s n -> s + 1 + size n) 1 +-- instance {-# OVERLAPPING #-} Flat (N,N,N) -- where +-- {-# INLINE size #-} +-- size (n1,n2,n3) = size n1 + size n2 + size n3 +-- -50% +-- instance {-# OVERLAPPING #-} Flat (N,N,N) where +-- {-# INLINE encode #-} +-- encode (n1,n2,n3) = wprim $ (Step 9) (encodeN n1 >=> encodeN n2 >=> encodeN n3) +-- {-# INLINE encodeN #-} +-- encodeN = \case +-- One -> eBitsF 2 0 +-- Two -> eBitsF 2 1 +-- Three -> eBitsF 2 2 +-- Four -> eBitsF 3 6 +-- Five -> eBitsF 3 7 +-- instance (Flat a, Flat b, Flat c) => Flat (RR a b c) +-- instance Flat a => Flat (Perfect a) +-- instance Flat a => Flat (Fork a) +-- instance Flat a => Flat (Nest a) +--instance Flat a => Flat (Stream a) where decode = Stream <$> decode <*> decode +-- instance Flat Expr +--instance (Flat a,Flat (f a),Flat (f (f a))) => Flat (PerfectF f a) +-- instance Flat a => Flat (Stream a) +{- + | + | +One Two | + Three | + Four Five + -} +-- instance {-# OVERLAPPABLE #-} Flat a => Flat (Tree a) where +-- encode (Node t1 t2) = eFalse <> encode t1 <> encode t2 +-- encode (Leaf a) = eTrue <> encode a +-- instance {-# OVERLAPPING #-} Flat (Tree N) where +-- encode (Node t1 t2) = eFalse <> encode t1 <> encode t2 +-- encode (Leaf a) = eTrue <> encode a +-- -- -34% (why?) +-- instance Flat N where +-- {-# INLINE encode #-} +-- encode = \case +-- One -> eBits 2 0 +-- Two -> eBits 2 1 +-- Three -> eBits 2 2 +-- Four -> eBits 3 6 +-- Five -> eBits 3 7 +-- instance {-# OVERLAPPING #-} Flat (Tree N) +-- where +-- {-# INLINE decode #-} +-- decode = do +-- tag <- dBool +-- if tag +-- then Leaf <$> decode +-- else Node <$> decode <*> decode +-- instance Flat N +-- where +-- {-# INLINE decode #-} +-- decode = do +-- tag <- dBool +-- if tag +-- then do +-- tag <- dBool +-- if tag +-- then do +-- tag <- dBool +-- if tag +-- then return Five +-- else return Four +-- else return Three +-- else do +-- tag <- dBool +-- if tag +-- then return Two +-- else return One +-- {-# INLINE size #-} +-- size n s = s + case n of +-- One -> 2 +-- Two -> 2 +-- Three -> 2 +-- Four -> 3 +-- Five -> 3 +-- instance Flat N where +-- instance {-# OVERLAPPING #-} Flat (Tree N) -- where +-- -- {-# INLINE encode #-} +-- encode (Node t1 t2) = Writer $ \s -> do +-- !s1 <- runWriter eFalse s +-- !s2 <- runWriter (encode t1) s1 +-- s3 <- runWriter (encode t2) s2 +-- return s3 +-- encode (Leaf a) = Writer $ \s -> do +-- s1 <- runWriter eTrue s +-- runWriter (encode a) s1 +-- size (Node t1 t2) = 1 + size t1 + size t2 +-- size (Leaf a) = 1 + size a +--instance Flat N + + + diff --git a/plutus-core/flat/test/Test/Data/Values.hs b/plutus-core/flat/test/Test/Data/Values.hs new file mode 100644 index 00000000000..efb54b6261c --- /dev/null +++ b/plutus-core/flat/test/Test/Data/Values.hs @@ -0,0 +1,351 @@ + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Test.Data.Values where + +import Control.DeepSeq +import Control.Exception +import Data.ByteString qualified as B +import Data.ByteString.Lazy qualified as L +import Data.ByteString.Short.Internal qualified as SBS +import Data.Char +import Data.Foldable +import Data.Int +import Data.IntMap qualified as IM +import PlutusCore.Flat +-- import qualified Data.IntSet as IS +-- import Data.List +import Data.Map qualified as M +import Data.Sequence qualified as Seq +import Data.Text qualified as T +import Data.Word +import Test.Data +import Test.Data2 qualified as D2 +-- import Data.Array as A + + +instance NFData Various +instance NFData a => NFData (List a) +instance NFData a => NFData (D2.List a) +instance NFData N +instance NFData a => NFData (ListS a) +instance NFData a => NFData (Stream a) +instance NFData a => NFData (Tree a) +instance NFData Car +instance NFData Engine +instance NFData OptionalExtra +instance NFData CarModel +instance NFData Consumption +instance NFData Acceleration + +floatT = ("float",-234.123123::Float) +doubleT = ("double",-1.91237::Double) + +a01 = A0 B1 (B0 (C0 (A1 N N D2.Nil2 D2.Nil2))) (D0 E1) + +ab0 = A (B (A (BB 'g'))) + +pe1 :: PerfectF Maybe Bool +pe1 = ConsP True (ConsP (Just False) (ConsP (Just (Just True)) NilP)) + +pr1 :: Pr Either List Int +pr1 = Pr (Right (C 3 N)) +f1,f2,f3:: Free [] Int +f1 = Pure 1 +f2 = Roll [Pure 1,Pure 2] +f3 = Roll [Roll [Pure 3],Pure 4] + +rr1 :: RR Char () Int8 +rr1 = RAB 'a' (RN 11 () 'b') () + +-- h = from Three +infList :: List Bool +infList = C True infList + +hl1 = [1,3..111::Word] +hl2 = [1,3..111::Int] +hl3 = [False,True,True,False,True,True,True,True,False,True,True,True,True,False,True,False] + +b1 = B.pack [99,173,186,44,187,124,87,186,104,99,138,202,53,137,22,5,44,244,234,7,159,119,22,234] +b2 = B.pack . concat . replicate 100 $ [235,7,135,117,255,69,100,113,113,82,128,181,200,146,155,228,144,65,83,162,130,236,235,7,135,117,255,69,100,113,113,82,128,181,200,146,155,228,144,65,83,162,130,236,235,7,135,117,255,69,100,113,113,82,128,181,200,146,155,228,144,65,83,162,130,236] + +lb1 = L.pack . B.unpack $ b1 +lb2 = L.fromChunks $ replicate 100 $ B.replicate 400 33 + +s1 = "a" +s2 = "中文版本" +s3 = ['A'..'z'] +s4 :: [Char] +s4 = Prelude.concatMap show [1::Int ..400] + +t1 = T.pack s1 +t2 = T.pack s2 +t3 = T.pack s3 +t4 = T.pack s4 + + +p1 :: Phantom Char +p1 = Phantom + +--toList N = [] +--toList (C h t) = h : (toList t) + +l2L [] = N +l2L (x:xs) = C x (l2L xs) + +l1 = l2L $ take 11 [11::Word8,22..33] + +lBool :: List Bool +lBool = l2L $ map odd [1::Int ..99] + +lBool2 :: List Bool +lBool2 = l2L $ map odd [1::Int ..1000] + +lBool0 = C False (C True (C True (C False (C False (C False (C True (C False (C True (C False (C True (C True (C False (C False (C False N)))))))))))))) + +lN0 = C Three (C One N) + +lN = C Three (C Three (C One (C One (C Three (C Four (C One (C Five (C Two (C Three (C Four (C Two (C Five (C Five (C Two (C Four (C Three (C One (C Four (C Five (C Two (C Five (C One (C Five (C Two (C One (C One (C Two (C Four N)))))))))))))))))))))))))))) + +largeSize = 1000000 + +-- couples :: [(Word32,N)] +couples :: [(Int,N)] +couples = zip [1..] $ ns 1000 + +lN2 :: List N +lN2 = lnx 1000 + +lN3 = lnx (largeSize*5) + +lnx = l2L . ns + +ns n = map asN [1..n] + +asN :: Int -> N +asN = toEnum . (`mod` 5) + +-- asN = toN . (`mod` 5) + +-- toN :: Integer -> N +-- toN 1 = One +-- toN 2 = Two +-- toN 3 = Three +-- toN 4 = Four +-- toN _ = Five + +asN3 = toN3 . (`mod` 5) +toN3 :: Integer -> (N,N,N) +toN3 1 = (One,Two,Three) +toN3 2 = (Two,Three,Four) +toN3 3 = (Three,Four,Five) +toN3 4 = (Four,Five,One) +toN3 _ = (Four,Five,Two) + +t33T =("Tuple of Tuple",t33) +t33 = asN33 4 + +asN33 :: Integer -> ((N, N, N), (N, N, N), (N, N, N)) +asN33 n = (asN3 n,asN3 (n+1),asN3 (n+2)) + +treeNLarge :: Tree N +treeNLarge = mkTree asN largeSize + +treeNNNLarge :: Tree (N,N,N) +treeNNNLarge = mkTree asN3 largeSize + +treeN33Large :: Tree ((N,N,N),(N,N,N),(N,N,N)) +treeN33Large = mkTree asN33 largeSize + +treeVarious = mkTree (const v2) (100::Int) + +mkTreeOf :: forall a. (Enum a ,Bounded a)=> Int -> Tree a +mkTreeOf = let l = fromEnum (maxBound :: a) +1 + in mkTree ((toEnum :: (Int -> a)) . (`mod` l)) + +mkTree mk = mkTree_ 1 + where + mkTree_ p 1 = Leaf $ mk p + mkTree_ p n = let (d,m) = n `divMod` 2 + in Node (mkTree_ p d) (mkTree_ (p+d) (d+m)) + +tree1 :: Tree String +tree1 = Node (Leaf "a leaf") (Node (Leaf "and") (Leaf "more")) + +tree2 :: Tree Word64 +tree2 = Node (Leaf 17) (Node (Leaf 23) (Leaf 45)) + +-- ss = take 5 . toList $ stream1 + +-- stream1 = Stream True stream1 + +car1 = Car 2343 1965 True ModelB [18,234] "1234" [SunRoof,CruiseControl] (Engine 1200 3 9000 "Fiat" "Petrol") [Consumption 40 18,Consumption 60 23,Consumption 80 25] [(90,[Acceleration 40 12]),(110,[Acceleration 50 11])] "Fiat" "500" + +treeN = mkTree asN3 1 + +longAsciiStrT = ("asciiStr", longS english ) + +asciiTextT = ("asciiText", T.pack $ longS english ) + +unicodeTextUTF8T = ("unicodeTextUTF8",UTF8Text unicodeText) + +chineseTextUTF8T = ("chineseTextUTF8",UTF8Text chineseText) + +#if ! defined (ETA_VERSION) +unicodeTextUTF16T = ("unicodeTextUTF16",UTF16Text unicodeText) +chineseTextUTF16T = ("chineseTextUTF16",UTF16Text chineseText) +#endif + +-- chineseTextT = ("chineseText",chinesText) +chineseText = T.pack $ longS chinese + + +unicodeTextT = ("unicodeText",unicodeText) +unicodeText = T.pack unicodeStr + +unicodeStrT = ("unicodeStr",unicodeStr) + +unicodeStr = notLongS uniSS + + +-- uniSS = "\x1F600\&\x1F600\&\x1F600\&I promessi sposi è un celebre romanzo storico di Alessandro Manzoni, ritenuto il più famoso e il più letto tra quelli scritti in lingua italiana[1].维护和平正义 开创美好未来——习近平主席在纪念中国人民抗日战争暨世界反法西斯战争胜利70周年大会上重要讲话在国际社会引起热烈反响" +uniSS = concat [special,latin,chinese] +special = "∀\&" +-- Crashes eta +-- emoji = "\x1F600" + +english = "To hike, or not to hike? US Federal Reserve chair Janet Yellen faces a tricky decision at today's FOMC meeting. Photograph: Action Press/Rex. Theme park operator Merlin Entertainments suffered a significant drop in visitor numbers to its Alton Towers attraction after a serious rollercoaster accident in June." +latin = "I promessi sposi è un celebre romanzo storico di Alessandro Manzoni, ritenuto il più famoso e il più letto tra quelli scritti in lingua italiana[1]." +chinese = "维护和平正义 开创美好未来——习近平主席在纪念中国人民抗日战争暨世界反法西斯战争胜利70周年大会上重要讲话在国际社会引起热烈反响" + +longS = take 1000000 . concat . repeat + +notLongS = take 1000 . concat . repeat + +longBoolListT = ("Long [Bool]",map (odd . ord) (longS uniSS) :: [Bool]) + +arr0 = ("[Bool]",map (odd . ord) unicodeStr :: [Bool]) + +arr1 = ("[Word]",map (fromIntegral . ord) unicodeStr :: [Word]) + +arr2 = ("ByteString from String",B.pack . map (fromIntegral . ord) $ unicodeStr) +sbs = ("StrictByteString",b2) +lbs = ("LazyByteString",lb2) +shortbs = ("ShortByteString",SBS.toShort b2) + +-- array package +-- arrayT = ("Array", + + +intMapT = ("IntMap",intMap) +mapT = ("map",dataMap) +mapListT = ("mapList",listMap) +intMap = IM.fromList couples +dataMap = M.fromList couples +listMap = couples + +lN2T = ("List N",lN2) +lN3T = ("Large List N",lN3) +nativeListT = ("Large [N]",nativeList) +nativeList = toList lN3 +seqNT = ("Seq N",Seq.fromList . toList $ lN2) -- nativeList) +treeNT = ("treeN",treeN) +treeNLargeT = ("treeNLarge",treeNLarge) +treeNNNLargeT = ("treeNNNLarge",treeNNNLarge) +treeN33LargeT = ("treeN33Large",treeN33Large) +treeVariousT = ("Tree Various",treeVarious) +tuple0T = ("block-tuple",(False,(),(3::Word64,33::Word,(True,(),False)))) +tupleT = ("tuple",(Two,One,(Five,Three,(Three,(),Two)))) +tupleBools = ("tupleBools",(False,(True,False),((True,False,True),(True,False,True)))) +oneT = ("One",One) +tupleWords = ("tupleWord",(18::Word,623723::Word,(8888::Word,823::Word))) +word8T = ("Word8",34::Word8) +word64T = ("Word64",34723823923::Word64) +carT = ("car",car1) +wordsT = ("words",wordsV) +wordsV = (18::Word,33::Word8,1230::Word16,9990::Word32,1231232::Word64) +words0T = ("words0",words0V) +words0V = (0::Word,0::Word8,0::Word16,0::Word32,0::Word64) +intsT = ("ints",(444::Int,123::Int8,-8999::Int16,-123823::Int32,-34723823923::Int64)) +floatsT = ("floats",floats) +floatsUnaT = ("floats unaligned",(Three,floats)) +floats = (3.43::Float,44.23E+23::Double,0.1::Double) +int8T = ("Int8",-34::Int8) +int64T = ("Int64",-34723823923::Int64) +integerT = ("Integer",-3472382392399239230123123::Integer) +charT = ("Char",'a') +unicharT = ("Unicode char", '世') +v1T = ("V1",v1) +v1 = V1 (Just False) +v2T = ("V2",v2) +--v2 = V2 True (Right Nothing) (One,Two,Three) +v2 = V2 True (Right Nothing) +vfT = ("v floats",VF 3.43 44.23E+23 0.1) +vwT = ("v words",vw) +vw = VW 18 33 1230 9990 1231232 +-- vw = VW 0 0 0 0 0 +viT = ("v ints",VI 444 123 (-8999) (-123823) (-34723823923)) +viiT = ("v integers",VII 444 8888 (-34723823923)) + +-- Copied from binary-typed-0.3/benchmark/Criterion.hs +-- | Data with a normal form. +data NF = forall a. NFData a => NF a + +-- | Evaluate 'NF' data to normal form. +force' :: NF -> () +force' (NF x) = x `deepseq` () + +forceCafs :: IO () +forceCafs = mapM_ (evaluate . force') cafs + +-- | List of all data that should be fully evaluated before a benchmark is +-- run. +cafs :: [NF] +cafs = [ + NF carT + , NF charT + , NF unicharT + , NF wordsT + , NF words0T + , NF intsT + , NF floatT + , NF doubleT + , NF floatsT + , NF floatsUnaT + , NF tupleT + , NF tuple0T + , NF treeNLargeT + , NF treeNNNLargeT + , NF treeN33LargeT + , NF treeNT + , NF lN2T + , NF lN3T + , NF mapT + , NF mapListT + , NF nativeListT + , NF seqNT + , NF arr1 + , NF arr0 + , NF longS + , NF unicodeStr + , NF longBoolListT + , NF longAsciiStrT + , NF asciiTextT + , NF unicodeStrT + , NF unicodeTextT + --, NF unicodeTextUTF8T + --, NF unicodeTextUTF16T + , NF couples + , NF v1T + , NF v2T + , NF vfT + , NF vwT + , NF viT + , NF viiT + , NF treeVariousT + , NF sbs + , NF lbs + , NF shortbs + ] diff --git a/plutus-core/flat/test/Test/Data2.hs b/plutus-core/flat/test/Test/Data2.hs new file mode 100644 index 00000000000..be1b08619f7 --- /dev/null +++ b/plutus-core/flat/test/Test/Data2.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +module Test.Data2 where + +import Data.Data +import Data.Typeable +import GHC.Generics + +-- A definition with the same name of a definition in Test.Data, used to test for name clashes.a +data List a = Cons2 a (List a) + | Nil2 + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic ,Generic1) + diff --git a/plutus-core/flat/test/Test/Data2/Flat.hs b/plutus-core/flat/test/Test/Data2/Flat.hs new file mode 100644 index 00000000000..2ad0e884134 --- /dev/null +++ b/plutus-core/flat/test/Test/Data2/Flat.hs @@ -0,0 +1,5 @@ +module Test.Data2.Flat(module Test.Data2) where +import PlutusCore.Flat +import Test.Data2 + +instance Flat a => Flat (List a) diff --git a/plutus-core/flat/test/Test/E.hs b/plutus-core/flat/test/Test/E.hs new file mode 100644 index 00000000000..a025095131a --- /dev/null +++ b/plutus-core/flat/test/Test/E.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +module Test.E where + +import Control.DeepSeq +import Data.List +import PlutusCore.Flat +-- import Data.Proxy + +data S3 = S_1 | S_2 Bool | S_3 Char deriving (Show,Generic,Eq,NFData) + + +g :: (Num a, Enum a, Show a) => a -> String +g n = + let dt = "E" ++ show n + in unwords + [ "data" + , dt + , "=" + , intercalate " | " $ map ((\n -> dt ++ "_" ++ n) . show) [1 .. n] + , "deriving (Show,Generic,Eq,NFData,Enum,Bounded)" + ] + +data E1 = E1 deriving (Show,Generic,Eq,NFData,Enum,Bounded) + +data E2 = E2_1 | E2_2 deriving (Show,Generic,Eq,NFData,Enum,Bounded) + +data E3 = E3_1 | E3_2 | E3_3 deriving (Show,Generic,Eq,NFData,Enum,Bounded) + +data E4 = E4_1 | E4_2 | E4_3 | E4_4 deriving (Show,Generic,Eq,NFData,Enum,Bounded) + +data E8 = E8_1 | E8_2 | E8_3 | E8_4 | E8_5 | E8_6 | E8_7 | E8_8 deriving (Show,Generic,Eq,NFData,Enum,Bounded) + +data E16 = E16_1 | E16_2 | E16_3 | E16_4 | E16_5 | E16_6 | E16_7 | E16_8 | E16_9 | E16_10 | E16_11 | E16_12 | E16_13 | E16_14 | E16_15 | E16_16 deriving (Show,Generic,Eq,NFData,Enum,Bounded) + +data E17 = E17_1 | E17_2 | E17_3 | E17_4 | E17_5 | E17_6 | E17_7 | E17_8 | E17_9 | E17_10 | E17_11 | E17_12 | E17_13 | E17_14 | E17_15 | E17_16 | E17_17 deriving (Show,Generic,Eq,NFData,Enum,Bounded) + +data E32 = E32_1 | E32_2 | E32_3 | E32_4 | E32_5 | E32_6 | E32_7 | E32_8 | E32_9 | E32_10 | E32_11 | E32_12 | E32_13 | E32_14 | E32_15 | E32_16 | E32_17 | E32_18 | E32_19 | E32_20 | E32_21 | E32_22 | E32_23 | E32_24 | E32_25 | E32_26 | E32_27 | E32_28 | E32_29 | E32_30 | E32_31 | E32_32 deriving (Show,Generic,Eq,NFData,Enum,Bounded) + +#ifdef ENUM_LARGE +data E256 = E256_1 | E256_2 | E256_3 | E256_4 | E256_5 | E256_6 | E256_7 | E256_8 | E256_9 | E256_10 | E256_11 | E256_12 | E256_13 | E256_14 | E256_15 | E256_16 | E256_17 | E256_18 | E256_19 | E256_20 | E256_21 | E256_22 | E256_23 | E256_24 | E256_25 | E256_26 | E256_27 | E256_28 | E256_29 | E256_30 | E256_31 | E256_32 | E256_33 | E256_34 | E256_35 | E256_36 | E256_37 | E256_38 | E256_39 | E256_40 | E256_41 | E256_42 | E256_43 | E256_44 | E256_45 | E256_46 | E256_47 | E256_48 | E256_49 | E256_50 | E256_51 | E256_52 | E256_53 | E256_54 | E256_55 | E256_56 | E256_57 | E256_58 | E256_59 | E256_60 | E256_61 | E256_62 | E256_63 | E256_64 | E256_65 | E256_66 | E256_67 | E256_68 | E256_69 | E256_70 | E256_71 | E256_72 | E256_73 | E256_74 | E256_75 | E256_76 | E256_77 | E256_78 | E256_79 | E256_80 | E256_81 | E256_82 | E256_83 | E256_84 | E256_85 | E256_86 | E256_87 | E256_88 | E256_89 | E256_90 | E256_91 | E256_92 | E256_93 | E256_94 | E256_95 | E256_96 | E256_97 | E256_98 | E256_99 | E256_100 | E256_101 | E256_102 | E256_103 | E256_104 | E256_105 | E256_106 | E256_107 | E256_108 | E256_109 | E256_110 | E256_111 | E256_112 | E256_113 | E256_114 | E256_115 | E256_116 | E256_117 | E256_118 | E256_119 | E256_120 | E256_121 | E256_122 | E256_123 | E256_124 | E256_125 | E256_126 | E256_127 | E256_128 | E256_129 | E256_130 | E256_131 | E256_132 | E256_133 | E256_134 | E256_135 | E256_136 | E256_137 | E256_138 | E256_139 | E256_140 | E256_141 | E256_142 | E256_143 | E256_144 | E256_145 | E256_146 | E256_147 | E256_148 | E256_149 | E256_150 | E256_151 | E256_152 | E256_153 | E256_154 | E256_155 | E256_156 | E256_157 | E256_158 | E256_159 | E256_160 | E256_161 | E256_162 | E256_163 | E256_164 | E256_165 | E256_166 | E256_167 | E256_168 | E256_169 | E256_170 | E256_171 | E256_172 | E256_173 | E256_174 | E256_175 | E256_176 | E256_177 | E256_178 | E256_179 | E256_180 | E256_181 | E256_182 | E256_183 | E256_184 | E256_185 | E256_186 | E256_187 | E256_188 | E256_189 | E256_190 | E256_191 | E256_192 | E256_193 | E256_194 | E256_195 | E256_196 | E256_197 | E256_198 | E256_199 | E256_200 | E256_201 | E256_202 | E256_203 | E256_204 | E256_205 | E256_206 | E256_207 | E256_208 | E256_209 | E256_210 | E256_211 | E256_212 | E256_213 | E256_214 | E256_215| E256_216 | E256_217 | E256_218 | E256_219 | E256_220 | E256_221 | E256_222 | E256_223 | E256_224 | E256_225 | E256_226 | E256_227 | E256_228 | E256_229 | E256_230 | E256_231 | E256_232 |E256_233 | E256_234 | E256_235 | E256_236 | E256_237 | E256_238 | E256_239 | E256_240 | E256_241 | E256_242 | E256_243 | E256_244 | E256_245 | E256_246 | E256_247 | E256_248 | E256_249 | E256_250 | E256_251 | E256_252 | E256_253 | E256_254 | E256_255 | E256_256 deriving (Show,Generic,Eq,NFData,Enum,Bounded) +data E258 = E258_1 | E258_2 | E258_3 | E258_4 | E258_5 | E258_6 | E258_7 | E258_8 | E258_9 | E258_10 | E258_11 | E258_12 | E258_13 | E258_14 | E258_15 | E258_16 | E258_17 | E258_18 | E258_19 | E258_20 | E258_21 | E258_22 | E258_23 | E258_24 | E258_25 | E258_26 | E258_27 | E258_28 | E258_29 | E258_30 | E258_31 | E258_32 | E258_33 | E258_34 | E258_35 | E258_36 | E258_37 | E258_38 | E258_39 | E258_40 | E258_41 | E258_42 | E258_43 | E258_44 | E258_45 | E258_46 | E258_47 | E258_48 | E258_49 | E258_50 | E258_51 | E258_52 | E258_53 | E258_54 | E258_55 | E258_56 | E258_57 | E258_58 | E258_59 | E258_60 | E258_61 | E258_62 | E258_63 | E258_64 | E258_65 | E258_66 | E258_67 | E258_68 | E258_69 | E258_70 | E258_71 | E258_72 | E258_73 | E258_74 | E258_75 | E258_76 | E258_77 | E258_78 | E258_79 | E258_80 | E258_81 | E258_82 | E258_83 | E258_84 | E258_85 | E258_86 | E258_87 | E258_88 | E258_89 | E258_90 | E258_91 | E258_92 | E258_93 | E258_94 | E258_95 | E258_96 | E258_97 | E258_98 | E258_99 | E258_100 | E258_101 | E258_102 | E258_103 | E258_104 | E258_105 | E258_106 | E258_107 | E258_108 | E258_109 | E258_110 | E258_111 | E258_112 | E258_113 | E258_114 | E258_115 | E258_116 | E258_117 | E258_118 | E258_119 | E258_120 |E258_121 | E258_122 | E258_123 | E258_124 | E258_125 | E258_126 | E258_127 | E258_128 | E258_129 | E258_130 | E258_131 | E258_132 | E258_133 | E258_134 | E258_135 | E258_136 | E258_137 | E258_138 | E258_139 | E258_140 | E258_141 | E258_142 | E258_143 | E258_144 | E258_145 | E258_146 | E258_147 | E258_148 | E258_149 | E258_150 | E258_151 | E258_152| E258_153 | E258_154 | E258_155 | E258_156 | E258_157 | E258_158 | E258_159 | E258_160 | E258_161 | E258_162 | E258_163 | E258_164 | E258_165 | E258_166 | E258_167 | E258_168 | E258_169 | E258_170 | E258_171 | E258_172 | E258_173 | E258_174 | E258_175 | E258_176 | E258_177 | E258_178 | E258_179 | E258_180 | E258_181 | E258_182 | E258_183 | E258_184 | E258_185 | E258_186 | E258_187 | E258_188 | E258_189 | E258_190 | E258_191 | E258_192 | E258_193 | E258_194 | E258_195 | E258_196 | E258_197 | E258_198 | E258_199 | E258_200 | E258_201 | E258_202 | E258_203 | E258_204 | E258_205 | E258_206 | E258_207 | E258_208 | E258_209 | E258_210 | E258_211 | E258_212 | E258_213 | E258_214 | E258_215 | E258_216 | E258_217 | E258_218 | E258_219 | E258_220 | E258_221 | E258_222 | E258_223 | E258_224 | E258_225 | E258_226 | E258_227 | E258_228 | E258_229 | E258_230 | E258_231 | E258_232 | E258_233 | E258_234 | E258_235 | E258_236 | E258_237 | E258_238 | E258_239 | E258_240 | E258_241 | E258_242 | E258_243 | E258_244 | E258_245 | E258_246 | E258_247 | E258_248 | E258_249 | E258_250 | E258_251 | E258_252 | E258_253 | E258_254 | E258_255 | E258_256 | E258_257 | E258_258 deriving (Show,Generic,Eq,NFData,Enum,Bounded) +#endif diff --git a/plutus-core/flat/test/Test/E/Arbitrary.hs b/plutus-core/flat/test/Test/E/Arbitrary.hs new file mode 100644 index 00000000000..0a013c49836 --- /dev/null +++ b/plutus-core/flat/test/Test/E/Arbitrary.hs @@ -0,0 +1,659 @@ +{-# LANGUAGE CPP #-} +module Test.E.Arbitrary where +import Test.E +import Test.Tasty.QuickCheck + +-- GENERATED START + +instance () => Arbitrary E2 where + arbitrary + = do x <- choose (0 :: Int, 1) + case x of + 0 -> return E2_1 + 1 -> return E2_2 + _ -> error "FATAL ERROR: Arbitrary instance, logic bug" + +instance () => Arbitrary E3 where + arbitrary + = do x <- choose (0 :: Int, 2) + case x of + 0 -> return E3_1 + 1 -> return E3_2 + 2 -> return E3_3 + _ -> error "FATAL ERROR: Arbitrary instance, logic bug" + +instance () => Arbitrary E4 where + arbitrary + = do x <- choose (0 :: Int, 3) + case x of + 0 -> return E4_1 + 1 -> return E4_2 + 2 -> return E4_3 + 3 -> return E4_4 + _ -> error "FATAL ERROR: Arbitrary instance, logic bug" + +instance () => Arbitrary E8 where + arbitrary + = do x <- choose (0 :: Int, 7) + case x of + 0 -> return E8_1 + 1 -> return E8_2 + 2 -> return E8_3 + 3 -> return E8_4 + 4 -> return E8_5 + 5 -> return E8_6 + 6 -> return E8_7 + 7 -> return E8_8 + _ -> error "FATAL ERROR: Arbitrary instance, logic bug" + +instance () => Arbitrary E16 where + arbitrary + = do x <- choose (0 :: Int, 15) + case x of + 0 -> return E16_1 + 1 -> return E16_2 + 2 -> return E16_3 + 3 -> return E16_4 + 4 -> return E16_5 + 5 -> return E16_6 + 6 -> return E16_7 + 7 -> return E16_8 + 8 -> return E16_9 + 9 -> return E16_10 + 10 -> return E16_11 + 11 -> return E16_12 + 12 -> return E16_13 + 13 -> return E16_14 + 14 -> return E16_15 + 15 -> return E16_16 + _ -> error "FATAL ERROR: Arbitrary instance, logic bug" + +instance () => Arbitrary E17 where + arbitrary + = do x <- choose (0 :: Int, 16) + case x of + 0 -> return E17_1 + 1 -> return E17_2 + 2 -> return E17_3 + 3 -> return E17_4 + 4 -> return E17_5 + 5 -> return E17_6 + 6 -> return E17_7 + 7 -> return E17_8 + 8 -> return E17_9 + 9 -> return E17_10 + 10 -> return E17_11 + 11 -> return E17_12 + 12 -> return E17_13 + 13 -> return E17_14 + 14 -> return E17_15 + 15 -> return E17_16 + 16 -> return E17_17 + _ -> error "FATAL ERROR: Arbitrary instance, logic bug" + +instance () => Arbitrary E32 where + arbitrary + = do x <- choose (0 :: Int, 31) + case x of + 0 -> return E32_1 + 1 -> return E32_2 + 2 -> return E32_3 + 3 -> return E32_4 + 4 -> return E32_5 + 5 -> return E32_6 + 6 -> return E32_7 + 7 -> return E32_8 + 8 -> return E32_9 + 9 -> return E32_10 + 10 -> return E32_11 + 11 -> return E32_12 + 12 -> return E32_13 + 13 -> return E32_14 + 14 -> return E32_15 + 15 -> return E32_16 + 16 -> return E32_17 + 17 -> return E32_18 + 18 -> return E32_19 + 19 -> return E32_20 + 20 -> return E32_21 + 21 -> return E32_22 + 22 -> return E32_23 + 23 -> return E32_24 + 24 -> return E32_25 + 25 -> return E32_26 + 26 -> return E32_27 + 27 -> return E32_28 + 28 -> return E32_29 + 29 -> return E32_30 + 30 -> return E32_31 + 31 -> return E32_32 + _ -> error "FATAL ERROR: Arbitrary instance, logic bug" + +#ifdef ENUM_LARGE +instance () => Arbitrary E256 where + arbitrary + = do x <- choose (0 :: Int, 255) + case x of + 0 -> return E256_1 + 1 -> return E256_2 + 2 -> return E256_3 + 3 -> return E256_4 + 4 -> return E256_5 + 5 -> return E256_6 + 6 -> return E256_7 + 7 -> return E256_8 + 8 -> return E256_9 + 9 -> return E256_10 + 10 -> return E256_11 + 11 -> return E256_12 + 12 -> return E256_13 + 13 -> return E256_14 + 14 -> return E256_15 + 15 -> return E256_16 + 16 -> return E256_17 + 17 -> return E256_18 + 18 -> return E256_19 + 19 -> return E256_20 + 20 -> return E256_21 + 21 -> return E256_22 + 22 -> return E256_23 + 23 -> return E256_24 + 24 -> return E256_25 + 25 -> return E256_26 + 26 -> return E256_27 + 27 -> return E256_28 + 28 -> return E256_29 + 29 -> return E256_30 + 30 -> return E256_31 + 31 -> return E256_32 + 32 -> return E256_33 + 33 -> return E256_34 + 34 -> return E256_35 + 35 -> return E256_36 + 36 -> return E256_37 + 37 -> return E256_38 + 38 -> return E256_39 + 39 -> return E256_40 + 40 -> return E256_41 + 41 -> return E256_42 + 42 -> return E256_43 + 43 -> return E256_44 + 44 -> return E256_45 + 45 -> return E256_46 + 46 -> return E256_47 + 47 -> return E256_48 + 48 -> return E256_49 + 49 -> return E256_50 + 50 -> return E256_51 + 51 -> return E256_52 + 52 -> return E256_53 + 53 -> return E256_54 + 54 -> return E256_55 + 55 -> return E256_56 + 56 -> return E256_57 + 57 -> return E256_58 + 58 -> return E256_59 + 59 -> return E256_60 + 60 -> return E256_61 + 61 -> return E256_62 + 62 -> return E256_63 + 63 -> return E256_64 + 64 -> return E256_65 + 65 -> return E256_66 + 66 -> return E256_67 + 67 -> return E256_68 + 68 -> return E256_69 + 69 -> return E256_70 + 70 -> return E256_71 + 71 -> return E256_72 + 72 -> return E256_73 + 73 -> return E256_74 + 74 -> return E256_75 + 75 -> return E256_76 + 76 -> return E256_77 + 77 -> return E256_78 + 78 -> return E256_79 + 79 -> return E256_80 + 80 -> return E256_81 + 81 -> return E256_82 + 82 -> return E256_83 + 83 -> return E256_84 + 84 -> return E256_85 + 85 -> return E256_86 + 86 -> return E256_87 + 87 -> return E256_88 + 88 -> return E256_89 + 89 -> return E256_90 + 90 -> return E256_91 + 91 -> return E256_92 + 92 -> return E256_93 + 93 -> return E256_94 + 94 -> return E256_95 + 95 -> return E256_96 + 96 -> return E256_97 + 97 -> return E256_98 + 98 -> return E256_99 + 99 -> return E256_100 + 100 -> return E256_101 + 101 -> return E256_102 + 102 -> return E256_103 + 103 -> return E256_104 + 104 -> return E256_105 + 105 -> return E256_106 + 106 -> return E256_107 + 107 -> return E256_108 + 108 -> return E256_109 + 109 -> return E256_110 + 110 -> return E256_111 + 111 -> return E256_112 + 112 -> return E256_113 + 113 -> return E256_114 + 114 -> return E256_115 + 115 -> return E256_116 + 116 -> return E256_117 + 117 -> return E256_118 + 118 -> return E256_119 + 119 -> return E256_120 + 120 -> return E256_121 + 121 -> return E256_122 + 122 -> return E256_123 + 123 -> return E256_124 + 124 -> return E256_125 + 125 -> return E256_126 + 126 -> return E256_127 + 127 -> return E256_128 + 128 -> return E256_129 + 129 -> return E256_130 + 130 -> return E256_131 + 131 -> return E256_132 + 132 -> return E256_133 + 133 -> return E256_134 + 134 -> return E256_135 + 135 -> return E256_136 + 136 -> return E256_137 + 137 -> return E256_138 + 138 -> return E256_139 + 139 -> return E256_140 + 140 -> return E256_141 + 141 -> return E256_142 + 142 -> return E256_143 + 143 -> return E256_144 + 144 -> return E256_145 + 145 -> return E256_146 + 146 -> return E256_147 + 147 -> return E256_148 + 148 -> return E256_149 + 149 -> return E256_150 + 150 -> return E256_151 + 151 -> return E256_152 + 152 -> return E256_153 + 153 -> return E256_154 + 154 -> return E256_155 + 155 -> return E256_156 + 156 -> return E256_157 + 157 -> return E256_158 + 158 -> return E256_159 + 159 -> return E256_160 + 160 -> return E256_161 + 161 -> return E256_162 + 162 -> return E256_163 + 163 -> return E256_164 + 164 -> return E256_165 + 165 -> return E256_166 + 166 -> return E256_167 + 167 -> return E256_168 + 168 -> return E256_169 + 169 -> return E256_170 + 170 -> return E256_171 + 171 -> return E256_172 + 172 -> return E256_173 + 173 -> return E256_174 + 174 -> return E256_175 + 175 -> return E256_176 + 176 -> return E256_177 + 177 -> return E256_178 + 178 -> return E256_179 + 179 -> return E256_180 + 180 -> return E256_181 + 181 -> return E256_182 + 182 -> return E256_183 + 183 -> return E256_184 + 184 -> return E256_185 + 185 -> return E256_186 + 186 -> return E256_187 + 187 -> return E256_188 + 188 -> return E256_189 + 189 -> return E256_190 + 190 -> return E256_191 + 191 -> return E256_192 + 192 -> return E256_193 + 193 -> return E256_194 + 194 -> return E256_195 + 195 -> return E256_196 + 196 -> return E256_197 + 197 -> return E256_198 + 198 -> return E256_199 + 199 -> return E256_200 + 200 -> return E256_201 + 201 -> return E256_202 + 202 -> return E256_203 + 203 -> return E256_204 + 204 -> return E256_205 + 205 -> return E256_206 + 206 -> return E256_207 + 207 -> return E256_208 + 208 -> return E256_209 + 209 -> return E256_210 + 210 -> return E256_211 + 211 -> return E256_212 + 212 -> return E256_213 + 213 -> return E256_214 + 214 -> return E256_215 + 215 -> return E256_216 + 216 -> return E256_217 + 217 -> return E256_218 + 218 -> return E256_219 + 219 -> return E256_220 + 220 -> return E256_221 + 221 -> return E256_222 + 222 -> return E256_223 + 223 -> return E256_224 + 224 -> return E256_225 + 225 -> return E256_226 + 226 -> return E256_227 + 227 -> return E256_228 + 228 -> return E256_229 + 229 -> return E256_230 + 230 -> return E256_231 + 231 -> return E256_232 + 232 -> return E256_233 + 233 -> return E256_234 + 234 -> return E256_235 + 235 -> return E256_236 + 236 -> return E256_237 + 237 -> return E256_238 + 238 -> return E256_239 + 239 -> return E256_240 + 240 -> return E256_241 + 241 -> return E256_242 + 242 -> return E256_243 + 243 -> return E256_244 + 244 -> return E256_245 + 245 -> return E256_246 + 246 -> return E256_247 + 247 -> return E256_248 + 248 -> return E256_249 + 249 -> return E256_250 + 250 -> return E256_251 + 251 -> return E256_252 + 252 -> return E256_253 + 253 -> return E256_254 + 254 -> return E256_255 + 255 -> return E256_256 + _ -> error "FATAL ERROR: Arbitrary instance, logic bug" + +instance () => Arbitrary E258 where + arbitrary + = do x <- choose (0 :: Int, 257) + case x of + 0 -> return E258_1 + 1 -> return E258_2 + 2 -> return E258_3 + 3 -> return E258_4 + 4 -> return E258_5 + 5 -> return E258_6 + 6 -> return E258_7 + 7 -> return E258_8 + 8 -> return E258_9 + 9 -> return E258_10 + 10 -> return E258_11 + 11 -> return E258_12 + 12 -> return E258_13 + 13 -> return E258_14 + 14 -> return E258_15 + 15 -> return E258_16 + 16 -> return E258_17 + 17 -> return E258_18 + 18 -> return E258_19 + 19 -> return E258_20 + 20 -> return E258_21 + 21 -> return E258_22 + 22 -> return E258_23 + 23 -> return E258_24 + 24 -> return E258_25 + 25 -> return E258_26 + 26 -> return E258_27 + 27 -> return E258_28 + 28 -> return E258_29 + 29 -> return E258_30 + 30 -> return E258_31 + 31 -> return E258_32 + 32 -> return E258_33 + 33 -> return E258_34 + 34 -> return E258_35 + 35 -> return E258_36 + 36 -> return E258_37 + 37 -> return E258_38 + 38 -> return E258_39 + 39 -> return E258_40 + 40 -> return E258_41 + 41 -> return E258_42 + 42 -> return E258_43 + 43 -> return E258_44 + 44 -> return E258_45 + 45 -> return E258_46 + 46 -> return E258_47 + 47 -> return E258_48 + 48 -> return E258_49 + 49 -> return E258_50 + 50 -> return E258_51 + 51 -> return E258_52 + 52 -> return E258_53 + 53 -> return E258_54 + 54 -> return E258_55 + 55 -> return E258_56 + 56 -> return E258_57 + 57 -> return E258_58 + 58 -> return E258_59 + 59 -> return E258_60 + 60 -> return E258_61 + 61 -> return E258_62 + 62 -> return E258_63 + 63 -> return E258_64 + 64 -> return E258_65 + 65 -> return E258_66 + 66 -> return E258_67 + 67 -> return E258_68 + 68 -> return E258_69 + 69 -> return E258_70 + 70 -> return E258_71 + 71 -> return E258_72 + 72 -> return E258_73 + 73 -> return E258_74 + 74 -> return E258_75 + 75 -> return E258_76 + 76 -> return E258_77 + 77 -> return E258_78 + 78 -> return E258_79 + 79 -> return E258_80 + 80 -> return E258_81 + 81 -> return E258_82 + 82 -> return E258_83 + 83 -> return E258_84 + 84 -> return E258_85 + 85 -> return E258_86 + 86 -> return E258_87 + 87 -> return E258_88 + 88 -> return E258_89 + 89 -> return E258_90 + 90 -> return E258_91 + 91 -> return E258_92 + 92 -> return E258_93 + 93 -> return E258_94 + 94 -> return E258_95 + 95 -> return E258_96 + 96 -> return E258_97 + 97 -> return E258_98 + 98 -> return E258_99 + 99 -> return E258_100 + 100 -> return E258_101 + 101 -> return E258_102 + 102 -> return E258_103 + 103 -> return E258_104 + 104 -> return E258_105 + 105 -> return E258_106 + 106 -> return E258_107 + 107 -> return E258_108 + 108 -> return E258_109 + 109 -> return E258_110 + 110 -> return E258_111 + 111 -> return E258_112 + 112 -> return E258_113 + 113 -> return E258_114 + 114 -> return E258_115 + 115 -> return E258_116 + 116 -> return E258_117 + 117 -> return E258_118 + 118 -> return E258_119 + 119 -> return E258_120 + 120 -> return E258_121 + 121 -> return E258_122 + 122 -> return E258_123 + 123 -> return E258_124 + 124 -> return E258_125 + 125 -> return E258_126 + 126 -> return E258_127 + 127 -> return E258_128 + 128 -> return E258_129 + 129 -> return E258_130 + 130 -> return E258_131 + 131 -> return E258_132 + 132 -> return E258_133 + 133 -> return E258_134 + 134 -> return E258_135 + 135 -> return E258_136 + 136 -> return E258_137 + 137 -> return E258_138 + 138 -> return E258_139 + 139 -> return E258_140 + 140 -> return E258_141 + 141 -> return E258_142 + 142 -> return E258_143 + 143 -> return E258_144 + 144 -> return E258_145 + 145 -> return E258_146 + 146 -> return E258_147 + 147 -> return E258_148 + 148 -> return E258_149 + 149 -> return E258_150 + 150 -> return E258_151 + 151 -> return E258_152 + 152 -> return E258_153 + 153 -> return E258_154 + 154 -> return E258_155 + 155 -> return E258_156 + 156 -> return E258_157 + 157 -> return E258_158 + 158 -> return E258_159 + 159 -> return E258_160 + 160 -> return E258_161 + 161 -> return E258_162 + 162 -> return E258_163 + 163 -> return E258_164 + 164 -> return E258_165 + 165 -> return E258_166 + 166 -> return E258_167 + 167 -> return E258_168 + 168 -> return E258_169 + 169 -> return E258_170 + 170 -> return E258_171 + 171 -> return E258_172 + 172 -> return E258_173 + 173 -> return E258_174 + 174 -> return E258_175 + 175 -> return E258_176 + 176 -> return E258_177 + 177 -> return E258_178 + 178 -> return E258_179 + 179 -> return E258_180 + 180 -> return E258_181 + 181 -> return E258_182 + 182 -> return E258_183 + 183 -> return E258_184 + 184 -> return E258_185 + 185 -> return E258_186 + 186 -> return E258_187 + 187 -> return E258_188 + 188 -> return E258_189 + 189 -> return E258_190 + 190 -> return E258_191 + 191 -> return E258_192 + 192 -> return E258_193 + 193 -> return E258_194 + 194 -> return E258_195 + 195 -> return E258_196 + 196 -> return E258_197 + 197 -> return E258_198 + 198 -> return E258_199 + 199 -> return E258_200 + 200 -> return E258_201 + 201 -> return E258_202 + 202 -> return E258_203 + 203 -> return E258_204 + 204 -> return E258_205 + 205 -> return E258_206 + 206 -> return E258_207 + 207 -> return E258_208 + 208 -> return E258_209 + 209 -> return E258_210 + 210 -> return E258_211 + 211 -> return E258_212 + 212 -> return E258_213 + 213 -> return E258_214 + 214 -> return E258_215 + 215 -> return E258_216 + 216 -> return E258_217 + 217 -> return E258_218 + 218 -> return E258_219 + 219 -> return E258_220 + 220 -> return E258_221 + 221 -> return E258_222 + 222 -> return E258_223 + 223 -> return E258_224 + 224 -> return E258_225 + 225 -> return E258_226 + 226 -> return E258_227 + 227 -> return E258_228 + 228 -> return E258_229 + 229 -> return E258_230 + 230 -> return E258_231 + 231 -> return E258_232 + 232 -> return E258_233 + 233 -> return E258_234 + 234 -> return E258_235 + 235 -> return E258_236 + 236 -> return E258_237 + 237 -> return E258_238 + 238 -> return E258_239 + 239 -> return E258_240 + 240 -> return E258_241 + 241 -> return E258_242 + 242 -> return E258_243 + 243 -> return E258_244 + 244 -> return E258_245 + 245 -> return E258_246 + 246 -> return E258_247 + 247 -> return E258_248 + 248 -> return E258_249 + 249 -> return E258_250 + 250 -> return E258_251 + 251 -> return E258_252 + 252 -> return E258_253 + 253 -> return E258_254 + 254 -> return E258_255 + 255 -> return E258_256 + 256 -> return E258_257 + 257 -> return E258_258 + _ -> error "FATAL ERROR: Arbitrary instance, logic bug" +-- GENERATED STOP +#endif diff --git a/plutus-core/flat/test/Test/E/Binary.hs b/plutus-core/flat/test/Test/E/Binary.hs new file mode 100644 index 00000000000..b75eb6fe6f1 --- /dev/null +++ b/plutus-core/flat/test/Test/E/Binary.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE StandaloneDeriving #-} +module Test.E.Binary where + +import Data.Binary +import Test.E + +deriving instance Binary E2 +deriving instance Binary E4 +deriving instance Binary E8 +deriving instance Binary E16 +deriving instance Binary E32 +deriving instance Binary E256 +deriving instance Binary E258 + +-- fs = +-- [ Binary E2_1 +-- , Binary E32_1 +-- , Binary E256_255 +-- , Binary E256_254 +-- , Binary E256_253 +-- , Binary E256_256 +-- ] + + diff --git a/plutus-core/flat/test/Test/E/Flat.hs b/plutus-core/flat/test/Test/E/Flat.hs new file mode 100644 index 00000000000..90dd9815454 --- /dev/null +++ b/plutus-core/flat/test/Test/E/Flat.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE StandaloneDeriving #-} +module Test.E.Flat() where + +import PlutusCore.Flat +import PlutusCore.Flat.Decoder () +import PlutusCore.Flat.Encoder () +import Test.E + +-- t = putStrLn $ gen 4 + +-- Test only, incorrect instances +-- Not faster than generated ones (at least up to E16) +gen :: Int -> String +gen numBits = + let dt = "E"++show n + n = 2 ^ numBits + cs = zip [1..] $ map ((\n -> dt ++ "_" ++ n) . show) [1 .. n] + dec n c = unwords [" ",n,"-> return",c] + in unlines [ + unwords ["instance Flat",dt,"where"] + ," size _ n = n+"++ show numBits + ," encode a = case a of" + ,unlines $ map (\(n,c) -> unwords [" ",c,"-> eBits16",show numBits,show n]) cs + ," decode = do" + ," tag <- dBEBits8 " ++ show numBits + ," case tag of" + ,unlines $ map (\(n,c) -> dec (show n) c) cs + ,dec "_" (snd $ last cs) + ] + + +deriving instance Flat S3 +deriving instance Flat E2 +deriving instance Flat E3 +deriving instance Flat E4 +deriving instance Flat E8 +deriving instance Flat E16 +deriving instance Flat E17 +deriving instance Flat E32 + +#ifdef ENUM_LARGE +deriving instance Flat E256 +deriving instance Flat E258 +#endif + +-- fs = +-- [ flat E2_1,flat E3_1 +-- , flat E4_1 +-- , flat E8_1 +-- , flat E16_1 +-- , flat E32_1 +-- , flat E256_255 +-- , flat E256_254 +-- , flat E256_253 +-- , flat E256_256 +-- ] + + diff --git a/plutus-core/flat/test/TextSize.hs b/plutus-core/flat/test/TextSize.hs new file mode 100644 index 00000000000..faa467be607 --- /dev/null +++ b/plutus-core/flat/test/TextSize.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +import Data.Text +import Data.Text.Internal qualified as TI +import PlutusCore.Flat +import PlutusCore.Flat.Encoder.Size +import PlutusCore.Flat.Instances.Text + +main = do +#if MIN_VERSION_text(2,0,0) + print "Text 2 - UTF8" +#else + print "Text 1 - UTF16" +#endif + -- UTF-8 1 byte UTF-16 1 unit (2 bytes) + info "a" + + -- UTF-8 3 bytes UTF-16 1 unit (2 bytes) + info "是" + + -- UTF-8 4 bytes UTF-16 2 units (4 bytes) + info "\x1F600" + +info t@(TI.Text _ off len) = do + print ("OFFSET",off,"LEN",len,"UTF_8 LEN",sUTF8Max t,"UTF_16 LEN",sUTF16Max t) + --,"FLAT UTF8 BITS",unflat (flat (UTF8Text t)) :: Decoded (SizeOf UTF8Text)) diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index b8983a277eb..7b2ebe45fdd 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -156,7 +156,7 @@ library PlutusCore.Examples.Data.TreeForest PlutusCore.Examples.Data.Vec PlutusCore.Examples.Everything - PlutusCore.Flat + PlutusCore.FlatInstances PlutusCore.FsTree PlutusCore.Mark PlutusCore.MkPlc @@ -318,7 +318,6 @@ library , exceptions , extra , filepath - , flat ^>=0.6 , free , ghc-prim , hashable >=1.4 @@ -333,6 +332,7 @@ library , multiset , nothunks ^>=0.2 , parser-combinators >=0.4.0 + , plutus-core:flat , prettyprinter >=1.1.0.1 , prettyprinter-configurable , primitive @@ -389,11 +389,11 @@ test-suite plutus-core-test , data-default-class , extra , filepath - , flat ^>=0.6 , hedgehog , mmorph , mtl , plutus-core ^>=1.53 + , plutus-core:flat , plutus-core:plutus-core-testlib , prettyprinter , serialise @@ -481,11 +481,11 @@ library untyped-plutus-core-testlib , cardano-crypto-class , data-default-class , dlist - , flat ^>=0.6 , hedgehog , lens , mtl , plutus-core ^>=1.53 + , plutus-core:flat , plutus-core:plutus-core-testlib , pretty-show , prettyprinter @@ -583,7 +583,6 @@ library plutus-ir , dlist , dom-lt , extra - , flat ^>=0.6 , hashable , lens , megaparsec @@ -593,6 +592,7 @@ library plutus-ir , multiset , parser-combinators >=0.4.0 , plutus-core ^>=1.53 + , plutus-core:flat , prettyprinter >=1.1.0.1 , profunctors , semigroupoids @@ -653,12 +653,12 @@ test-suite plutus-ir-test , base >=4.9 && <5 , containers , filepath - , flat ^>=0.6 , hashable , hedgehog , lens , mtl , plutus-core ^>=1.53 + , plutus-core:flat , plutus-core:plutus-core-testlib , plutus-core:plutus-ir , QuickCheck @@ -713,7 +713,6 @@ executable plutus , containers , exceptions , filepath - , flat , lens , megaparsec , microlens @@ -721,6 +720,7 @@ executable plutus , mono-traversable , mtl , plutus-core ^>=1.53 + , plutus-core:flat , plutus-core:plutus-ir , prettyprinter , primitive @@ -755,13 +755,13 @@ library plutus-core-execlib , aeson , base >=4.9 && <5 , bytestring - , flat ^>=0.6 , lens , megaparsec , monoidal-containers , mtl , optparse-applicative , plutus-core ^>=1.53 + , plutus-core:flat , plutus-core:plutus-core-testlib , plutus-core:plutus-ir , prettyprinter @@ -1136,3 +1136,130 @@ test-suite index-envs-test , quickcheck-instances , tasty , tasty-quickcheck + +---------------------------------------------- +-- flat encoding/decoding +---------------------------------------------- + +library flat + import: lang + visibility: public + hs-source-dirs: flat/src + default-language: Haskell2010 + exposed-modules: + PlutusCore.Flat + PlutusCore.Flat.AsBin + PlutusCore.Flat.AsSize + PlutusCore.Flat.Bits + PlutusCore.Flat.Class + PlutusCore.Flat.Data.ByteString.Convert + PlutusCore.Flat.Data.FloatCast + PlutusCore.Flat.Data.ZigZag + PlutusCore.Flat.Decoder + PlutusCore.Flat.Decoder.Prim + PlutusCore.Flat.Decoder.Run + PlutusCore.Flat.Decoder.Strict + PlutusCore.Flat.Decoder.Types + PlutusCore.Flat.Encoder + PlutusCore.Flat.Encoder.Prim + PlutusCore.Flat.Encoder.Size + PlutusCore.Flat.Encoder.Strict + PlutusCore.Flat.Encoder.Types + PlutusCore.Flat.Endian + PlutusCore.Flat.Filler + PlutusCore.Flat.Instances + PlutusCore.Flat.Instances.Array + PlutusCore.Flat.Instances.Base + PlutusCore.Flat.Instances.ByteString + PlutusCore.Flat.Instances.Containers + PlutusCore.Flat.Instances.DList + PlutusCore.Flat.Instances.Extra + PlutusCore.Flat.Instances.Mono + PlutusCore.Flat.Instances.Test + PlutusCore.Flat.Instances.Text + PlutusCore.Flat.Instances.Unordered + PlutusCore.Flat.Instances.Util + PlutusCore.Flat.Instances.Vector + PlutusCore.Flat.Memory + PlutusCore.Flat.Run + PlutusCore.Flat.Tutorial + PlutusCore.Flat.Types + + ghc-options: + -funbox-strict-fields -Wno-orphans -Wno-name-shadowing + -Wno-missing-deriving-strategies -Wno-redundant-constraints + -Wno-identities -Wno-unused-imports + + build-depends: + , array >=0.5.1.0 + , base >=4.9 && <5 + , bytestring >=0.10.6 + , containers + , deepseq >=1.4 + , dlist >=0.6 + , ghc-prim + , hashable >=1.4.0.1 + , list-t >=1.0 + , mono-traversable + , pretty >=1.1.2 + , primitive + , text + , unordered-containers + , vector + +test-suite flat-test + import: lang + type: exitcode-stdio-1.0 + hs-source-dirs: flat/test + default-language: Haskell2010 + main-is: Spec.hs + cpp-options: -DLIST_BIT -DTEST_DECBITS + cpp-options: -DENUM_LARGE + ghc-options: + -Wno-unused-top-binds -Wno-type-defaults -Wno-missing-signatures + -Wno-missing-deriving-strategies -Wno-orphans -Wno-name-shadowing + -Wno-redundant-constraints -Wno-unused-imports + -Wno-incomplete-uni-patterns -Wno-unused-local-binds + -Wno-unused-packages + + other-modules: + Test.Data + Test.Data.Arbitrary + Test.Data.Flat + Test.Data.Values + Test.Data2 + Test.Data2.Flat + Test.E + Test.E.Arbitrary + Test.E.Flat + + build-depends: + , base + , bytestring + , containers + , deepseq + , plutus-core:flat + , QuickCheck + , quickcheck-text + , tasty + , tasty-hunit + , tasty-quickcheck + , text + +-- Test for Flat.AsBin Flat.AsSize and listTDecoder +test-suite flat-big-test + import: lang + type: exitcode-stdio-1.0 + hs-source-dirs: flat/test + main-is: Big.hs + default-language: Haskell2010 + ghc-options: + -Wno-incomplete-uni-patterns -Wno-missing-signatures + -Wno-unused-imports -Wno-name-shadowing + + build-depends: + , base + , bytestring + , list-t + , plutus-core:flat + , timeit diff --git a/plutus-core/plutus-core/src/Codec/Extras/FlatViaSerialise.hs b/plutus-core/plutus-core/src/Codec/Extras/FlatViaSerialise.hs index b35209c8cd4..56dd0296df2 100644 --- a/plutus-core/plutus-core/src/Codec/Extras/FlatViaSerialise.hs +++ b/plutus-core/plutus-core/src/Codec/Extras/FlatViaSerialise.hs @@ -4,7 +4,7 @@ module Codec.Extras.FlatViaSerialise import Codec.Serialise (Serialise, deserialiseOrFail, serialise) import Data.ByteString.Lazy qualified as BSL (toStrict) -import Flat +import PlutusCore.Flat {- Note [Flat serialisation for strict and lazy bytestrings] The `flat` serialisation of a bytestring consists of a sequence of chunks, with each chunk preceded diff --git a/plutus-core/plutus-core/src/Codec/Extras/SerialiseViaFlat.hs b/plutus-core/plutus-core/src/Codec/Extras/SerialiseViaFlat.hs index 9deb7586f28..832f3d50760 100644 --- a/plutus-core/plutus-core/src/Codec/Extras/SerialiseViaFlat.hs +++ b/plutus-core/plutus-core/src/Codec/Extras/SerialiseViaFlat.hs @@ -12,8 +12,8 @@ import Codec.CBOR.Decoding qualified as CBOR import Codec.CBOR.Read qualified as CBOR import Codec.Serialise (Serialise, decode, encode) import Data.Either.Extras (fromRightM) -import Flat qualified -import Flat.Decoder qualified as Flat +import PlutusCore.Flat qualified as Flat +import PlutusCore.Flat.Decoder qualified as Flat import Prettyprinter (Pretty (pretty), (<+>)) {- | Newtype to provide 'Serialise' instances for types with a 'Flat' instance diff --git a/plutus-core/plutus-core/src/Data/Vector/Orphans.hs b/plutus-core/plutus-core/src/Data/Vector/Orphans.hs index ac80f2d91e6..c3ecd4743df 100644 --- a/plutus-core/plutus-core/src/Data/Vector/Orphans.hs +++ b/plutus-core/plutus-core/src/Data/Vector/Orphans.hs @@ -4,8 +4,8 @@ module Data.Vector.Orphans () where import Data.Hashable (Hashable (hashWithSalt)) import Data.Vector.Strict qualified as Strict -import Flat (Flat (..)) -import Flat.Instances.Vector () +import PlutusCore.Flat (Flat (..)) +import PlutusCore.Flat.Instances.Vector () instance (Hashable a) => Hashable (Strict.Vector a) where hashWithSalt = Strict.foldl' hashWithSalt diff --git a/plutus-core/plutus-core/src/PlutusCore.hs b/plutus-core/plutus-core/src/PlutusCore.hs index 1aad79b00e6..7d13586afde 100644 --- a/plutus-core/plutus-core/src/PlutusCore.hs +++ b/plutus-core/plutus-core/src/PlutusCore.hs @@ -130,7 +130,7 @@ import PlutusCore.DeBruijn import PlutusCore.Default import PlutusCore.Error import PlutusCore.Evaluation.Machine.Ck -import PlutusCore.Flat () +import PlutusCore.FlatInstances () import PlutusCore.Name.Unique import PlutusCore.Name.UniqueMap import PlutusCore.Name.UniqueSet diff --git a/plutus-core/plutus-core/src/PlutusCore/Annotation.hs b/plutus-core/plutus-core/src/PlutusCore/Annotation.hs index 09945adf39f..3c6d0b5d963 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Annotation.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Annotation.hs @@ -21,8 +21,8 @@ import Data.List qualified as List import Data.MonoTraversable import Data.Set (Set) import Data.Set qualified as Set -import Flat (Flat (..)) import GHC.Generics +import PlutusCore.Flat (Flat (..)) import Prettyprinter import Text.Megaparsec.Pos as Megaparsec diff --git a/plutus-core/plutus-core/src/PlutusCore/Crypto/BLS12_381/G1.hs b/plutus-core/plutus-core/src/PlutusCore/Crypto/BLS12_381/G1.hs index 9e907bc0bd2..64ae1d58b9d 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Crypto/BLS12_381/G1.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Crypto/BLS12_381/G1.hs @@ -31,7 +31,7 @@ import Data.ByteString (ByteString, length) import Data.Coerce (coerce) import Data.Hashable import Data.Proxy (Proxy (..)) -import Flat +import PlutusCore.Flat import Prettyprinter {- Note [Wrapping the BLS12-381 types in Plutus Core]. In the Haskell bindings diff --git a/plutus-core/plutus-core/src/PlutusCore/Crypto/BLS12_381/G2.hs b/plutus-core/plutus-core/src/PlutusCore/Crypto/BLS12_381/G2.hs index 93804907bd4..4f2e998d36f 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Crypto/BLS12_381/G2.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Crypto/BLS12_381/G2.hs @@ -31,7 +31,7 @@ import Data.ByteString (ByteString, length) import Data.Coerce (coerce) import Data.Hashable import Data.Proxy (Proxy (..)) -import Flat +import PlutusCore.Flat import Prettyprinter {- | See Note [Wrapping the BLS12-381 types in Plutus Core]. -} diff --git a/plutus-core/plutus-core/src/PlutusCore/Crypto/BLS12_381/Pairing.hs b/plutus-core/plutus-core/src/PlutusCore/Crypto/BLS12_381/Pairing.hs index e9e54aa6389..a1aad0a524a 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Crypto/BLS12_381/Pairing.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Crypto/BLS12_381/Pairing.hs @@ -22,7 +22,7 @@ import Text.PrettyBy (PrettyBy, prettyBy) import Control.DeepSeq (NFData, rnf) import Data.Coerce (coerce) import Data.Hashable -import Flat +import PlutusCore.Flat import Prettyprinter {- | This type represents the result of computing a pairing using the Miller diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs index ae61cf21bfc..cc5fbf0b1ef 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs @@ -47,13 +47,13 @@ import Data.Text (Text) import Data.Text.Encoding (decodeUtf8', encodeUtf8) import Data.Vector.Strict (Vector) import Data.Vector.Strict qualified as Vector -import Flat hiding (from, to) -import Flat.Decoder (Get, dBEBits8) -import Flat.Encoder as Flat (Encoding, NumBits, eBits) import GHC.Natural (naturalFromInteger) import GHC.Num.Integer (Integer (..)) import GHC.Types (Int (..)) import NoThunks.Class (NoThunks) +import PlutusCore.Flat hiding (from, to) +import PlutusCore.Flat.Decoder (Get, dBEBits8) +import PlutusCore.Flat.Encoder as Flat (Encoding, NumBits, eBits) import Prettyprinter (viaShow) -- TODO: should we have the commonest built-in functions at the front to have more compact encoding? diff --git a/plutus-core/plutus-core/src/PlutusCore/Flat.hs b/plutus-core/plutus-core/src/PlutusCore/FlatInstances.hs similarity index 99% rename from plutus-core/plutus-core/src/PlutusCore/Flat.hs rename to plutus-core/plutus-core/src/PlutusCore/FlatInstances.hs index 9b9756c6d06..979348fb3b3 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Flat.hs +++ b/plutus-core/plutus-core/src/PlutusCore/FlatInstances.hs @@ -11,7 +11,7 @@ -- | Flat instances for Plutus Core types. Make sure to read Note [Stable -- encoding of TPLC] and Note [Stable encoding of UPLC] before touching anything -- in this file. -module PlutusCore.Flat +module PlutusCore.FlatInstances ( safeEncodeBits ) where @@ -23,9 +23,9 @@ import PlutusCore.Name.Unique import PlutusCore.Value (Value) import Data.Proxy -import Flat -import Flat.Decoder -import Flat.Encoder +import PlutusCore.Flat +import PlutusCore.Flat.Decoder +import PlutusCore.Flat.Encoder import PlutusPrelude import Universe diff --git a/plutus-core/plutus-core/src/PlutusCore/Size.hs b/plutus-core/plutus-core/src/PlutusCore/Size.hs index 752af73cc5e..39493162341 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Size.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Size.hs @@ -19,7 +19,7 @@ import PlutusCore.Core import Control.Lens import Data.ByteString qualified as BS import Data.Monoid -import Flat hiding (to) +import PlutusCore.Flat hiding (to) newtype Size = Size { unSize :: Integer diff --git a/plutus-core/plutus-core/test/Spec.hs b/plutus-core/plutus-core/test/Spec.hs index a9891d50787..a48b48e16ff 100644 --- a/plutus-core/plutus-core/test/Spec.hs +++ b/plutus-core/plutus-core/test/Spec.hs @@ -40,10 +40,10 @@ import Data.Proxy import Data.Text qualified as T import Data.Text.Encoding (encodeUtf8) import Data.Text.IO (readFile) -import Flat qualified import Hedgehog hiding (Var) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range +import PlutusCore.Flat qualified as Flat import Prelude hiding (readFile) import Test.Tasty import Test.Tasty.Golden diff --git a/plutus-core/plutus-ir/src/PlutusIR/Core/Instance/Flat.hs b/plutus-core/plutus-ir/src/PlutusIR/Core/Instance/Flat.hs index 2ba9f91cee7..c4b04e8d12a 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Core/Instance/Flat.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Core/Instance/Flat.hs @@ -7,9 +7,8 @@ module PlutusIR.Core.Instance.Flat () where import PlutusIR.Core.Type import PlutusCore qualified as PLC -import PlutusCore.Flat () - -import Flat (Flat) +import PlutusCore.Flat (Flat) +import PlutusCore.FlatInstances () {- Note [Serialization of PIR] The serialized version of Plutus-IR will be included in the final diff --git a/plutus-core/plutus-ir/src/PlutusIR/Core/Instance/Pretty.hs b/plutus-core/plutus-ir/src/PlutusIR/Core/Instance/Pretty.hs index 0de4ecb6fcd..c40876c21e3 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Core/Instance/Pretty.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Core/Instance/Pretty.hs @@ -11,7 +11,7 @@ module PlutusIR.Core.Instance.Pretty () where import PlutusPrelude import PlutusCore qualified as PLC -import PlutusCore.Flat () +import PlutusCore.FlatInstances () import PlutusCore.Pretty qualified as PLC import PlutusIR.Core.Instance.Pretty.Readable () diff --git a/plutus-core/plutus-ir/src/PlutusIR/Core/Plated.hs b/plutus-core/plutus-ir/src/PlutusIR/Core/Plated.hs index 725de4d5b51..0c741f9fb7e 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Core/Plated.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Core/Plated.hs @@ -37,7 +37,7 @@ import PlutusCore qualified as PLC import PlutusCore.Arity import PlutusCore.Core (tyVarDeclSubkinds, typeSubkinds, typeSubtypes, typeSubtypesDeep, typeUniques, typeUniquesDeep, varDeclSubtypes) -import PlutusCore.Flat () +import PlutusCore.FlatInstances () import PlutusCore.Name.Unique qualified as PLC import PlutusIR.Core.Type diff --git a/plutus-core/plutus-ir/src/PlutusIR/Core/Type.hs b/plutus-core/plutus-ir/src/PlutusIR/Core/Type.hs index a4bfb5aac6a..34b4b98087a 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Core/Type.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Core/Type.hs @@ -36,7 +36,7 @@ import PlutusCore qualified as PLC import PlutusCore.Builtin (HasConstant (..), notAConstant) import PlutusCore.Core (UniOf) import PlutusCore.Evaluation.Machine.ExMemoryUsage -import PlutusCore.Flat () +import PlutusCore.FlatInstances () import PlutusCore.MkPlc (Def (..), TermLike (..), TyVarDecl (..), VarDecl (..)) import PlutusCore.Name.Unique qualified as PLC import PlutusPrelude diff --git a/plutus-core/plutus-ir/test/PlutusIR/Core/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Core/Tests.hs index c3a20e84fb7..b7e3e101c4d 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Core/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Core/Tests.hs @@ -10,7 +10,7 @@ import Test.Tasty import Test.Tasty.Extras import Data.Functor -import Flat +import PlutusCore.Flat test_prettyprinting :: TestTree test_prettyprinting = diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Flat.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Flat.hs index 307163b5907..1510a708cc7 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Flat.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Flat.hs @@ -10,7 +10,6 @@ module UntypedPlutusCore.Core.Instance.Flat where -import PlutusCore.Flat import PlutusCore.Pretty import PlutusCore.Version qualified as PLC import PlutusPrelude @@ -20,10 +19,11 @@ import UntypedPlutusCore.Core.Type import Control.Lens import Control.Monad import Data.Vector qualified as V -import Flat -import Flat.Decoder -import Flat.Encoder -import Flat.Encoder.Strict (sizeListWith) +import PlutusCore.Flat +import PlutusCore.Flat.Decoder +import PlutusCore.Flat.Encoder +import PlutusCore.Flat.Encoder.Strict (sizeListWith) +import PlutusCore.FlatInstances import Universe {- diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Size.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Size.hs index 68bc765b280..50b41d36099 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Size.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Size.hs @@ -11,7 +11,7 @@ import UntypedPlutusCore.Core import Control.Lens import Data.ByteString qualified as BS import Data.Foldable -import Flat hiding (to) +import PlutusCore.Flat hiding (to) -- | Count the number of AST nodes in a term. termSize :: Term name uni fun ann -> Size diff --git a/plutus-core/untyped-plutus-core/test/Spec.hs b/plutus-core/untyped-plutus-core/test/Spec.hs index 2147ee87d00..92f970e147f 100644 --- a/plutus-core/untyped-plutus-core/test/Spec.hs +++ b/plutus-core/untyped-plutus-core/test/Spec.hs @@ -13,7 +13,6 @@ import Evaluation.FreeVars (test_freevars) import Evaluation.Golden (test_golden) import Evaluation.Machines (test_NumberOfStepCounters, test_budget, test_machines, test_tallying) import Evaluation.Regressions (schnorrVerifyRegressions) -import Flat.Spec (test_flat) import Generators.Spec (test_parsing) import Scoping.Spec (test_names) import Transform.CaseOfCase.Spec (test_caseOfCase) @@ -41,7 +40,6 @@ main = do , test_freevars , test_parsing , test_debug - , test_flat , schnorrVerifyRegressions , evalOrder , test_names diff --git a/plutus-core/untyped-plutus-core/testlib/DeBruijn/FlatNatWord.hs b/plutus-core/untyped-plutus-core/testlib/DeBruijn/FlatNatWord.hs index c8bc0d342ba..d99a6a3894d 100644 --- a/plutus-core/untyped-plutus-core/testlib/DeBruijn/FlatNatWord.hs +++ b/plutus-core/untyped-plutus-core/testlib/DeBruijn/FlatNatWord.hs @@ -5,16 +5,16 @@ module DeBruijn.FlatNatWord (test_flatNatWord) where import PlutusCore.DeBruijn -import PlutusCore.Flat () +import PlutusCore.FlatInstances () import Data.Either (isLeft) import Data.Word -import Flat -import Flat.Encoder import GHC.Natural import Hedgehog import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range +import PlutusCore.Flat +import PlutusCore.Flat.Encoder import Test.Tasty import Test.Tasty.Extras import Test.Tasty.Hedgehog diff --git a/plutus-core/untyped-plutus-core/testlib/Flat/Spec.hs b/plutus-core/untyped-plutus-core/testlib/Flat/Spec.hs index 1019fef70bc..7e7117c97ec 100644 --- a/plutus-core/untyped-plutus-core/testlib/Flat/Spec.hs +++ b/plutus-core/untyped-plutus-core/testlib/Flat/Spec.hs @@ -12,9 +12,9 @@ import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as BSL import Data.Char (ord) import Data.Word -import Flat import PlutusCore.Data (Data) import PlutusCore.DeBruijn +import PlutusCore.Flat import PlutusCore.Generators.QuickCheck.Builtin () import Test.Tasty import Test.Tasty.HUnit diff --git a/plutus-core/untyped-plutus-core/testlib/Generators/Spec.hs b/plutus-core/untyped-plutus-core/testlib/Generators/Spec.hs index 684c3f21b3d..78460e2681f 100644 --- a/plutus-core/untyped-plutus-core/testlib/Generators/Spec.hs +++ b/plutus-core/untyped-plutus-core/testlib/Generators/Spec.hs @@ -10,7 +10,6 @@ import PlutusPrelude (display, fold, void, (&&&)) import Control.Lens (view) import Data.Text (Text) import Data.Text qualified as T -import Flat (flat, unflat) import Hedgehog (annotate, annotateShow, failure, property, tripping, (===)) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range @@ -18,6 +17,7 @@ import PlutusCore (Name) import PlutusCore.Annotation (SrcSpan (..)) import PlutusCore.Default (DefaultFun, DefaultUni) import PlutusCore.Error (ParserErrorBundle) +import PlutusCore.Flat (flat, unflat) import PlutusCore.Generators.Hedgehog (forAllPretty) import PlutusCore.Generators.Hedgehog.AST (runAstGen) import PlutusCore.Parser (defaultUni, parseGen) diff --git a/plutus-executables/executables/plc/Main.hs b/plutus-executables/executables/plc/Main.hs index 24ba6bf8086..de9475583d3 100644 --- a/plutus-executables/executables/plc/Main.hs +++ b/plutus-executables/executables/plc/Main.hs @@ -21,8 +21,8 @@ import PlutusPrelude import Control.Monad.Except import Data.ByteString.Lazy qualified as BSL (readFile) -import Flat (unflat) import Options.Applicative +import PlutusCore.Flat (unflat) import System.Exit (exitFailure) import System.IO (hPrint, stderr) diff --git a/plutus-executables/executables/uplc/Main.hs b/plutus-executables/executables/uplc/Main.hs index 480caac171b..9f72bf757a2 100644 --- a/plutus-executables/executables/uplc/Main.hs +++ b/plutus-executables/executables/uplc/Main.hs @@ -35,8 +35,8 @@ import Data.ByteString.Lazy as BSL (readFile) import Data.Foldable import Data.List.Split (splitOn) import Data.Text qualified as T -import Flat (unflat) import Options.Applicative +import PlutusCore.Flat (unflat) import Prettyprinter ((<+>)) import System.Exit (ExitCode (..), exitFailure, exitSuccess, exitWith) import System.IO (hPrint, stderr) diff --git a/plutus-executables/plutus-executables.cabal b/plutus-executables/plutus-executables.cabal index 814bd8f5b45..a6759b674f1 100644 --- a/plutus-executables/plutus-executables.cabal +++ b/plutus-executables/plutus-executables.cabal @@ -89,10 +89,10 @@ executable plc build-depends: , base >=4.9 && <5 , bytestring - , flat ^>=0.6 , mtl , optparse-applicative , plutus-core ^>=1.53 + , plutus-core:flat , plutus-core:plutus-core-execlib executable uplc @@ -105,11 +105,11 @@ executable uplc , bytestring , criterion , deepseq - , flat ^>=0.6 , haskeline , mtl , optparse-applicative , plutus-core ^>=1.53 + , plutus-core:flat , plutus-core:plutus-core-execlib , plutus-metatheory ^>=1.53 , prettyprinter diff --git a/plutus-tx-plugin/plutus-tx-plugin.cabal b/plutus-tx-plugin/plutus-tx-plugin.cabal index 0dc8804c027..237b992ff92 100644 --- a/plutus-tx-plugin/plutus-tx-plugin.cabal +++ b/plutus-tx-plugin/plutus-tx-plugin.cabal @@ -80,12 +80,12 @@ library , containers , either , extra - , flat ^>=0.6 , ghc , lens , megaparsec , mtl , plutus-core ^>=1.53 + , plutus-core:flat , plutus-core:plutus-ir , plutus-metatheory ^>=1.53 , plutus-tx ^>=1.53 @@ -190,11 +190,11 @@ test-suite plutus-tx-plugin-tests , containers , deepseq , filepath - , flat ^>=0.6 , hedgehog , lens , mtl , plutus-core ^>=1.53 + , plutus-core:flat , plutus-core:plutus-core-testlib , plutus-tx ^>=1.53 , plutus-tx-plugin ^>=1.53 diff --git a/plutus-tx-plugin/src/PlutusTx/Plugin.hs b/plutus-tx-plugin/src/PlutusTx/Plugin.hs index f0015455b4c..43fe6d5f4ee 100644 --- a/plutus-tx-plugin/src/PlutusTx/Plugin.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin.hs @@ -66,7 +66,7 @@ import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State import Control.Monad.Writer -import Flat (Flat, flat, unflat) +import PlutusCore.Flat (Flat, flat, unflat) import Data.ByteString qualified as BS import Data.ByteString.Unsafe qualified as BSUnsafe diff --git a/plutus-tx-plugin/test/Blueprint/Tests/Lib.hs b/plutus-tx-plugin/test/Blueprint/Tests/Lib.hs index 440e860dde3..73087822b6b 100644 --- a/plutus-tx-plugin/test/Blueprint/Tests/Lib.hs +++ b/plutus-tx-plugin/test/Blueprint/Tests/Lib.hs @@ -29,8 +29,8 @@ import Data.ByteString.Lazy qualified as LBS import Data.Kind (Type) import Data.Type.Equality ((:~:) (Refl)) import Data.Void (Void) -import Flat qualified import GHC.Generics (Generic) +import PlutusCore.Flat qualified as Flat import PlutusTx.AsData (asData) import PlutusTx.Blueprint.Class (HasBlueprintSchema (..)) import PlutusTx.Blueprint.Definition (HasBlueprintDefinition (..), Unrolled, definitionIdFromTypeK, diff --git a/plutus-tx/plutus-tx.cabal b/plutus-tx/plutus-tx.cabal index 5a19c135541..000388d4d59 100644 --- a/plutus-tx/plutus-tx.cabal +++ b/plutus-tx/plutus-tx.cabal @@ -135,13 +135,13 @@ library , deepseq , deriving-compat , extra - , flat ^>=0.6 , formatting , hashable , lens , memory , mtl , plutus-core ^>=1.53 + , plutus-core:flat , plutus-core:plutus-ir , prettyprinter , serialise @@ -178,11 +178,11 @@ library plutus-tx-testlib build-depends: , base >=4.9 && <5 , bytestring - , flat ^>=0.6 , hedgehog , lens , mtl , plutus-core ^>=1.53 + , plutus-core:flat , plutus-core:plutus-core-testlib , plutus-core:plutus-ir , plutus-tx ^>=1.53 diff --git a/plutus-tx/src/PlutusTx/Code.hs b/plutus-tx/src/PlutusTx/Code.hs index 42fd2b5a234..4f76c276002 100644 --- a/plutus-tx/src/PlutusTx/Code.hs +++ b/plutus-tx/src/PlutusTx/Code.hs @@ -15,10 +15,10 @@ module PlutusTx.Code where import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as BSL -import Flat (Flat (..), unflat) -import Flat.Decoder (DecodeException) import PlutusCore qualified as PLC import PlutusCore.Annotation (SrcSpans) +import PlutusCore.Flat (Flat (..), unflat) +import PlutusCore.Flat.Decoder (DecodeException) import PlutusCore.Pretty (PrettyConst, RenderContext) import PlutusIR qualified as PIR import PlutusTx.Coverage (CoverageIndex) diff --git a/plutus-tx/src/PlutusTx/Coverage.hs b/plutus-tx/src/PlutusTx/Coverage.hs index 58db725b5d4..9a37b1d3284 100644 --- a/plutus-tx/src/PlutusTx/Coverage.hs +++ b/plutus-tx/src/PlutusTx/Coverage.hs @@ -34,7 +34,7 @@ import Control.Lens import Codec.Extras.FlatViaSerialise import Codec.Serialise -import Flat hiding (to) +import PlutusCore.Flat hiding (to) import Control.DeepSeq import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) diff --git a/plutus-tx/testlib/PlutusTx/Test/Golden.hs b/plutus-tx/testlib/PlutusTx/Test/Golden.hs index 8fca6716b00..43d5a671376 100644 --- a/plutus-tx/testlib/PlutusTx/Test/Golden.hs +++ b/plutus-tx/testlib/PlutusTx/Test/Golden.hs @@ -43,11 +43,11 @@ import Control.Monad.Except (runExceptT) import Data.List qualified as List import Data.SatInt (fromSatInt) import Data.Text (Text) -import Flat (Flat) import Language.Haskell.TH qualified as TH import PlutusCore qualified as PLC import PlutusCore.Evaluation.Machine.ExBudget qualified as PLC import PlutusCore.Evaluation.Machine.ExMemory (ExCPU (..), ExMemory (..)) +import PlutusCore.Flat (Flat) import PlutusCore.Pretty (Doc, Pretty (pretty), PrettyBy (prettyBy), PrettyConfigClassic, PrettyConfigName, PrettyUni, Render (render), prettyClassicSimple, prettyPlcClassicSimple, prettyReadable, prettyReadableSimple) diff --git a/plutus-tx/testlib/PlutusTx/Test/Orphans.hs b/plutus-tx/testlib/PlutusTx/Test/Orphans.hs index 2e9fbff323b..b8dc98bb470 100644 --- a/plutus-tx/testlib/PlutusTx/Test/Orphans.hs +++ b/plutus-tx/testlib/PlutusTx/Test/Orphans.hs @@ -21,7 +21,7 @@ import PlutusIR.Transform.RewriteRules qualified as PIR import PlutusPrelude (Default) import PlutusTx.Code (CompiledCodeIn, getPir, getPlcNoAnn) -import Flat (Flat) +import PlutusCore.Flat (Flat) import Test.Tasty.Extras () instance diff --git a/plutus-tx/testlib/PlutusTx/Test/Util/Apply.hs b/plutus-tx/testlib/PlutusTx/Test/Util/Apply.hs index f9bdd5b1a4f..cff57760cf9 100644 --- a/plutus-tx/testlib/PlutusTx/Test/Util/Apply.hs +++ b/plutus-tx/testlib/PlutusTx/Test/Util/Apply.hs @@ -15,8 +15,8 @@ module PlutusTx.Test.Util.Apply ( import Prelude -import Flat (Flat) import PlutusCore qualified as PLC +import PlutusCore.Flat (Flat) import PlutusCore.Pretty (Pretty, PrettyBy, PrettyConst, RenderContext) import PlutusTx.Code