Incorporated new Encode and DeCode types. Added a bunch of tests, inc…

…luding ones for Timelocks.

shelley-ma/impl/cardano-ledger-shelley-ma.cabal

@@ -24,9 +24,9 @@ library
     Cardano.Ledger.Mary
     Cardano.Ledger.ShelleyMA.Value
     Cardano.Ledger.ShelleyMA.ValueInternal
+    Cardano.Ledger.ShelleyMA.Timelocks
   other-modules:
     Cardano.Ledger.ShelleyMA
-    Cardano.Ledger.ShelleyMA.Timelocks
 
   -- other-extensions:
   build-depends:

shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Timelocks.hs

@@ -47,10 +47,9 @@ import Shelley.Spec.Ledger.Keys (KeyHash (..), KeyRole (Witness))
 import Shelley.Spec.Ledger.MemoBytes
   ( Mem,
     MemoBytes (..),
-    Symbolic (..),
     memoBytes,
-    (<#>),
-    (<@>),
+    Encode(..),
+    (!>),
   )
 import Shelley.Spec.Ledger.Scripts
   ( MultiSig,
@@ -95,7 +94,7 @@ instance
       0 -> do
         left <- fromCBOR -- this: fromCBOR :: (Decoder s (StrictMaybe SlotNo))
         right <- fromCBOR
-        pure $ (2, pure (Interval' left right)) -- Note the pure lifts from T to (Annotator T)
+        pure $ (3, pure (Interval' left right)) -- Note the pure lifts from T to (Annotator T)
         -- Possible because intervalpair has no memoized
         -- structures that remember their own bytes.
       1 -> do
@@ -134,38 +133,27 @@ pattern Interval ::
 pattern Interval left right <-
   Timelock (Memo (Interval' left right) _)
   where
-    Interval left right =
-      Timelock (memoBytes (Con Interval' 0 <@> left <@> right))
+    Interval left right = Timelock $ memoBytes $ Sum Interval' 0 !> To left !> To right
 
 pattern Multi :: Era era => MultiSig era -> Timelock era
 pattern Multi m <-
   Timelock (Memo (Multi' m) _)
   where
-    Multi m = Timelock (memoBytes (Con Multi' 1 <@> m))
+    Multi m = Timelock $ memoBytes $ Sum Multi' 1 !> To m
 
 pattern TimelockAnd :: Era era => StrictSeq (Timelock era) -> Timelock era
 pattern TimelockAnd ms <-
   Timelock (Memo (TimelockAnd' ms) _)
   where
     TimelockAnd ms =
-      Timelock
-        ( memoBytes
-            ( Con TimelockAnd' 2
-                <#> (encodeFoldable, ms)
-            )
-        )
+      Timelock $ memoBytes $ Sum TimelockAnd' 2 !> E encodeFoldable ms
 
 pattern TimelockOr :: Era era => StrictSeq (Timelock era) -> Timelock era
 pattern TimelockOr ms <-
   Timelock (Memo (TimelockOr' ms) _)
   where
     TimelockOr ms =
-      Timelock
-        ( memoBytes
-            ( Con TimelockOr' 3
-                <#> (encodeFoldable, ms)
-            )
-        )
+      Timelock $ memoBytes (Sum TimelockOr' 3 !> E encodeFoldable ms)
 
 {-# COMPLETE Interval, Multi, TimelockAnd, TimelockOr #-}
 

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/MemoBytes.hs

@@ -9,6 +9,8 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE LambdaCase #-}
 
 -- | MemoBytes is an abstration for a datetype that encodes its own seriialization.
 --   The idea is to use a newtype around a MemoBytes non-memoizing version.
@@ -17,12 +19,14 @@
 --   can be derived for free.
 module Shelley.Spec.Ledger.MemoBytes
   ( MemoBytes (..),
-    Symbolic (..),
-    (<@>),
-    (<#>),
+    Encode(..),
+    Decode(..),
+    (!>),
+    (<!),
     Mem,
-    encodeSym,
-    runSym,
+    encode,
+    runE,
+    decode,
     memoBytes,
     shorten,
     decodeList,
@@ -38,6 +42,7 @@ module Shelley.Spec.Ledger.MemoBytes
   )
 where
 
+-- import Debug.Trace
 import Cardano.Binary
   ( Annotator (..),
     FromCBOR (fromCBOR),
@@ -64,8 +69,11 @@ import Shelley.Spec.Ledger.Serialization
     decodeSet,
     decodeStrictSeq,
     encodeFoldable,
+    decodeRecordNamed,
   )
 import Prelude hiding (span)
+import Codec.CBOR.Decoding(Decoder)
+import Shelley.Spec.Ledger.BaseTypes (invalidKey)
 
 -- ========================================================================
 
@@ -102,53 +110,134 @@ printMemo :: Show t => MemoBytes t -> IO ()
 printMemo x = putStrLn (showMemo x)
 
 -- ===============================================================================
--- A Symbolic encoding is a data structure from which 3 things can be recovered
--- Given:    x :: Symbolic t
+-- Encode and Decode are typed data structures which specify encoders and decoders.
+-- The types keep one from making mistakes, and count the correct number fields
+-- in an encoding and decoding. They are somewhat dual, and are designed that visual
+-- inspection of a Encode and its dual Decode can help the user conclude that the
+-- two are self-consistent. They are also reusable abstractions that can be defined
+-- once, and then used many places.
+--
+-- (Encode t) is a data structure from which 3 things can be recovered
+-- Given:    x :: Encode t
 -- 1) get a value of type t
--- 2) get an Encoding for that value. (Care must be taken that the tags are correct)
+-- 2) get an Encoding for that value, which correctly encodes the number of "fields"
+--    written to the ByteString. Care must still be taken that the tags are correct.
 -- 3) get a (MemoBytes t)
--- The advantage of using Symbolic with a MemoBytes, is we don't have to make a ToCBOR
+-- The advantage of using Encode with a MemoBytes, is we don't have to make a ToCBOR
 -- instance. Instead the "instance" is spread amongst the pattern constuctors by using
--- (memoBytes symbolic) in the where clause of the pattern contructor.
+-- (memoBytes encoding) in the where clause of the pattern contructor.
 -- See some examples in the EXAMPLE Section below.
+--
+-- (Decode t) is dual to (Encode t). A decoder can be extracted from it. And it will
+-- consistently decode it's dual.
+-- ========================================================
 
-data Symbolic t where
-  Con :: t -> Word -> Symbolic t
-  App :: ToCBOR a => Symbolic (a -> t) -> a -> Symbolic t
-  AppE :: Symbolic (a -> t) -> (a -> Encoding, a) -> Symbolic t
+data Encode t where
+  Sum:: t -> Word -> Encode t
+  Rec:: t -> Encode t
+  ApplyE:: Encode(a -> t) -> Encode a -> Encode t
+  To:: ToCBOR a => a -> Encode a
+  E:: (t -> Encoding) -> t -> Encode t
 
-infixl 5 <@>
+infixl 4 !>
+(!>) :: Encode(a -> t) -> Encode a -> Encode t
+x !> y = ApplyE x y
 
-infixl 5 <#>
+runE :: Encode t -> t
+runE (Sum c _) = c
+runE (Rec c) = c
+runE (ApplyE f x) = runE f (runE x)
+runE (To x) = x
+runE (E _ x) = x
 
-(<@>) :: ToCBOR a => Symbolic (a -> t) -> a -> Symbolic t
-x <@> y = App x y
+gsize:: Encode t -> Word
+gsize (Sum _ _) = 0
+gsize (Rec _) = 0
+gsize (To _) = 1
+gsize (E _ _) = 1
+gsize (ApplyE f x) = gsize f + gsize x
 
-(<#>) :: Symbolic (a -> t) -> (a -> Encoding, a) -> Symbolic t
-x <#> y = AppE x y
+encode :: Encode t -> Encoding
+encode sym = encodeHelp 0 sym  where
+   encodeHelp :: Word -> Encode t -> Encoding
+   encodeHelp n (Sum _ tag) = encodeListLen (n+1) <> encodeWord tag
+   encodeHelp n (Rec _) = encodeListLen n
+   encodeHelp _ (To x) = toCBOR x
+   encodeHelp _ (E enc x) = enc x
+   encodeHelp n (ApplyE f x) = encodeHelp (n + gsize x) f <> encodeGroup x
 
-runSym :: Symbolic t -> t
-runSym (Con constr _tag) = constr
-runSym (App f x) = runSym f x
-runSym (AppE f (_e, x)) = runSym f x
+   encodeGroup :: Encode t -> Encoding
+   encodeGroup (Sum _ _) = error ("Sum type encoding a group. Groups must be Record types.")
+   encodeGroup (Rec _) = mempty
+   encodeGroup (To x) = toCBOR x
+   encodeGroup (E enc x) = enc x
+   encodeGroup (ApplyE f x) = encodeGroup f <> encodeGroup x
 
-encodeSym :: Symbolic t -> Encoding
-encodeSym sym = encodeHelp 1 sym
-  where
-    encodeHelp :: Word -> Symbolic t -> Encoding
-    encodeHelp n (Con _constr tag) = encodeListLen n <> encodeWord tag
-    encodeHelp n (App f x) = encodeHelp (n + 1) f <> toCBOR x
-    encodeHelp n (AppE f (encode, x)) = encodeHelp (n + 1) f <> encode x
+memoBytes :: Encode t -> MemoBytes t
+memoBytes t = Memo (runE t) (shorten (toLazyByteString (encode t)))
+
+-- =====================
+
+data Decode t where
+  SumD :: t -> Decode t
+  RecD :: t -> Decode t
+  From :: FromCBOR t => Decode t
+  D :: (forall s . Decoder s t) -> Decode t
+  ApplyD::  Decode (a -> t) -> Decode a -> Decode t
+  Invalid:: Word -> Decode t
+
+infixl 4 <!
+(<!) :: Decode(a -> t) -> Decode a -> Decode t
+x <! y = ApplyD x y
+
+instance Show (Decode t) where
+  show (SumD _) = "SumD"
+  show (RecD _) = "RecD"
+  show (From) = "From"
+  show (D _) = "D"
+  show (ApplyD x y) = "(Apply "++show x++" "++show y++")"
+  show (Invalid n) = "(Invalid "++show n++")"
+
+hsize:: Decode t -> Int
+hsize (SumD _) = 0
+hsize (RecD _) = 0
+hsize From     = 1
+hsize (D _)    = 1
+hsize (ApplyD f x) = hsize f + hsize x
+hsize (Invalid _) = 0
+
+decode :: Decode t -> Decoder s (Int,t)
+decode x = decodeHelp x 0
+
+decodeHelp :: Decode t -> Int -> Decoder s (Int,t)
+decodeHelp (SumD c) n = pure (n+1,c)
+decodeHelp (RecD c) n = decodeRecordNamed "RecD" (const n) (pure(n,c))
+decodeHelp From n = do { x <- fromCBOR; pure(n,x)}
+decodeHelp (D dec) n = do { x <- dec; pure(n,x)}
+decodeHelp (ApplyD c g) n = do
+  (i,f) <- decodeHelp c (n+hsize g)
+  y <- decodeGroup g;
+  pure(i,f y)
+decodeHelp (Invalid k) _ = invalidKey k
+
+decodeGroup :: Decode t ->  Decoder s t
+decodeGroup (SumD _) = error ("Sum type decoding a group. Groups must be records.")
+decodeGroup (RecD c) = pure c
+decodeGroup From = fromCBOR
+decodeGroup (D dec) = dec
+decodeGroup (ApplyD c g) = do
+  f <- decodeGroup c
+  y <- decodeGroup g
+  pure(f y)
+decodeGroup (Invalid k) = invalidKey k
 
-memoBytes :: Symbolic t -> MemoBytes t
-memoBytes t = Memo (runSym t) (shorten (toLazyByteString (encodeSym t)))
 
 -- ===========================================================================================
--- These functions are the analogs to
+-- These functions are the dual analogs to
 -- Shelley.Spec.Ledger.Serialization(decodeList, decodeSeq, decodeStrictSeq, decodeSet)
 -- It is not well documented how to use encodeFoldable.
--- They are provided here as compatible pairs for use with the symbolic constructor AppE (<#>)
--- If we use decodeX in the fromCBOR we must use encodeX in the ToCOBOR or (Symbolic t) values
+-- They are provided here as compatible pairs for use with the (E x) and (D x) constructors
+-- of the Encode and Decode types. (E encodeList xs) and (D (decodeList fromCBOR)) should be duals.
 
 encodeList :: ToCBOR a => [a] -> Encoding
 encodeList = encodeFoldable

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Serialization.hs

@@ -142,7 +142,7 @@ decodeRecordNamed name getRecordSize decode = do
   lenOrIndef <- decodeListLenOrIndef
   x <- decode
   case lenOrIndef of
-    Just n -> matchSize name (getRecordSize x) n
+    Just n -> matchSize (Text.pack "\nRecord " <> name) n (getRecordSize x)
     Nothing -> do
       isBreak <- decodeBreakOr
       unless isBreak $ cborError $ DecoderErrorCustom name "Excess terms in array"
@@ -154,7 +154,7 @@ decodeRecordSum name decode = do
   tag <- decodeWord
   (size, x) <- decode tag -- we decode all the stuff we want
   case lenOrIndef of
-    Just n -> matchSize (Text.pack (name ++ " tag=" ++ show size)) size n
+    Just n -> matchSize (Text.pack ("\nSum "++name ++ "\nreturned=" ++ show size++" actually read= "++show n)) size n
     Nothing -> do
       isBreak <- decodeBreakOr -- if there is stuff left, it is unnecessary extra stuff
       unless isBreak $ cborError $ DecoderErrorCustom (Text.pack name) "Excess terms in array"