{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Test.Cardano.Ledger.Binary.Cuddle (
  specWithHuddle,
  huddleRoundTripCborSpec,
  huddleRoundTripAnnCborSpec,
  writeSpec,
) where

import Cardano.Ledger.Binary (
  Annotator,
  DecCBOR,
  EncCBOR,
  Version,
  decodeFullAnnotator,
  decodeFullDecoder,
  toPlainEncoding,
 )
import Cardano.Ledger.Binary.Decoding (label)
import qualified Codec.CBOR.Cuddle.CBOR.Gen as Cuddle
import qualified Codec.CBOR.Cuddle.CDDL as Cuddle
import qualified Codec.CBOR.Cuddle.CDDL.CTree as Cuddle
import qualified Codec.CBOR.Cuddle.CDDL.Resolve as Cuddle
import qualified Codec.CBOR.Cuddle.Huddle as Cuddle
import Codec.CBOR.Cuddle.Pretty ()
import qualified Codec.CBOR.Encoding as CBOR
import qualified Codec.CBOR.Pretty as CBOR
import qualified Codec.CBOR.Term as CBOR
import qualified Codec.CBOR.Write as CBOR
import Data.Data (Proxy (..))
import Data.Foldable (traverse_)
import Data.Functor.Identity (Identity)
import Data.List (unfoldr)
import qualified Data.Text as T
import GHC.Stack (HasCallStack)
import Prettyprinter (Pretty (pretty))
import Prettyprinter.Render.Text (hPutDoc)
import System.IO (IOMode (..), hPutStrLn, withFile)
import Test.Cardano.Ledger.Binary.RoundTrip (
  RoundTripFailure (RoundTripFailure),
  Trip (..),
  cborTrip,
  decodeAnnExtra,
  embedTripLabelExtra,
 )
import Test.Hspec (
  Expectation,
  Spec,
  SpecWith,
  beforeAll,
  expectationFailure,
  it,
  shouldBe,
 )
import Test.Hspec.Core.Spec (Example (..), paramsQuickCheckArgs)
import Test.QuickCheck (Args (replay))
import Test.QuickCheck.Random (QCGen, mkQCGen)

data CuddleData = CuddleData
  { CuddleData -> CTreeRoot' Identity MonoRef
cddl :: !(Cuddle.CTreeRoot' Identity Cuddle.MonoRef)
  , CuddleData -> Int
numExamples :: !Int
  }

newtype Seeded a = Seeded
  { forall a. Seeded a -> QCGen -> a
runSeeded :: QCGen -> a
  }

instance Example (a -> Seeded Expectation) where
  type Arg (a -> Seeded Expectation) = a
  evaluateExample :: (a -> Seeded Expectation)
-> Params
-> (ActionWith (Arg (a -> Seeded Expectation)) -> Expectation)
-> ProgressCallback
-> IO Result
evaluateExample a -> Seeded Expectation
e Params
params ActionWith (Arg (a -> Seeded Expectation)) -> Expectation
hook =
    let qcGen :: QCGen
qcGen = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int -> QCGen
mkQCGen Int
0) forall a b. (a, b) -> a
fst (Args -> Maybe (QCGen, Int)
replay forall a b. (a -> b) -> a -> b
$ Params -> Args
paramsQuickCheckArgs Params
params)
        example :: a -> Expectation
example a
a = forall a. Seeded a -> QCGen -> a
runSeeded (a -> Seeded Expectation
e a
a) QCGen
qcGen
     in forall e.
Example e =>
e
-> Params
-> (ActionWith (Arg e) -> Expectation)
-> ProgressCallback
-> IO Result
evaluateExample a -> Expectation
example Params
params ActionWith (Arg (a -> Seeded Expectation)) -> Expectation
hook

huddleRoundTripCborSpec ::
  forall a.
  (HasCallStack, Eq a, Show a, EncCBOR a, DecCBOR a) =>
  -- | Serialization version
  Version ->
  -- | Name of the CDDL rule to test
  T.Text ->
  SpecWith CuddleData
huddleRoundTripCborSpec :: forall a.
(HasCallStack, Eq a, Show a, EncCBOR a, DecCBOR a) =>
Version -> Text -> SpecWith CuddleData
huddleRoundTripCborSpec Version
version Text
ruleName =
  let lbl :: Text
lbl = forall a. DecCBOR a => Proxy a -> Text
label forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @a
      trip :: Trip a a
trip = forall a b. (EncCBOR a, DecCBOR b) => Trip a b
cborTrip @a
   in forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it (Text -> String
T.unpack Text
ruleName forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
lbl) forall a b. (a -> b) -> a -> b
$
        \CuddleData
cddlData ->
          CuddleData -> Name -> (Term -> Expectation) -> Seeded Expectation
withGenTerm CuddleData
cddlData (Text -> Name
Cuddle.Name Text
ruleName) forall a b. (a -> b) -> a -> b
$
            forall a.
(HasCallStack, Show a, Eq a) =>
Text -> Version -> Version -> Trip a a -> Term -> Expectation
roundTripExample Text
lbl Version
version Version
version Trip a a
trip

huddleRoundTripAnnCborSpec ::
  forall a.
  (HasCallStack, Eq a, Show a, EncCBOR a, DecCBOR (Annotator a)) =>
  -- | Serialization version
  Version ->
  -- | Name of the CDDL rule to test
  T.Text ->
  SpecWith CuddleData
huddleRoundTripAnnCborSpec :: forall a.
(HasCallStack, Eq a, Show a, EncCBOR a, DecCBOR (Annotator a)) =>
Version -> Text -> SpecWith CuddleData
huddleRoundTripAnnCborSpec Version
version Text
ruleName =
  let lbl :: Text
lbl = forall a. DecCBOR a => Proxy a -> Text
label forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @(Annotator a)
      trip :: Trip a (Annotator a)
trip = forall a b. (EncCBOR a, DecCBOR b) => Trip a b
cborTrip @a
   in forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it (Text -> String
T.unpack Text
ruleName forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
lbl) forall a b. (a -> b) -> a -> b
$
        \CuddleData
cddlData ->
          CuddleData -> Name -> (Term -> Expectation) -> Seeded Expectation
withGenTerm CuddleData
cddlData (Text -> Name
Cuddle.Name Text
ruleName) forall a b. (a -> b) -> a -> b
$
            forall a.
(HasCallStack, Show a, Eq a) =>
Text
-> Version
-> Version
-> Trip a (Annotator a)
-> Term
-> Expectation
roundTripAnnExample Text
lbl Version
version Version
version Trip a (Annotator a)
trip

specWithHuddle :: Cuddle.Huddle -> Int -> SpecWith CuddleData -> Spec
specWithHuddle :: Huddle -> Int -> SpecWith CuddleData -> Spec
specWithHuddle Huddle
h Int
numExamples =
  forall a. HasCallStack => IO a -> SpecWith a -> Spec
beforeAll forall a b. (a -> b) -> a -> b
$
    let cddl :: CDDL
cddl = Huddle -> CDDL
Cuddle.toCDDL Huddle
h
        rCddl :: Either NameResolutionFailure (CTreeRoot' Identity MonoRef)
rCddl = CDDL -> Either NameResolutionFailure (CTreeRoot' Identity MonoRef)
Cuddle.fullResolveCDDL CDDL
cddl
     in case Either NameResolutionFailure (CTreeRoot' Identity MonoRef)
rCddl of
          Right CTreeRoot' Identity MonoRef
ct ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
              CuddleData
                { cddl :: CTreeRoot' Identity MonoRef
cddl = CTreeRoot' Identity MonoRef
ct
                , numExamples :: Int
numExamples = Int
numExamples
                }
          Left NameResolutionFailure
nrf -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show NameResolutionFailure
nrf

withGenTerm :: CuddleData -> Cuddle.Name -> (CBOR.Term -> Expectation) -> Seeded Expectation
withGenTerm :: CuddleData -> Name -> (Term -> Expectation) -> Seeded Expectation
withGenTerm CuddleData
cd Name
n Term -> Expectation
withTerm = forall a. (QCGen -> a) -> Seeded a
Seeded forall a b. (a -> b) -> a -> b
$ \QCGen
gen ->
  let terms :: [Term]
terms =
        forall a. Int -> [a] -> [a]
take (CuddleData -> Int
numExamples CuddleData
cd) forall a b. (a -> b) -> a -> b
$
          forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall g.
RandomGen g =>
CTreeRoot' Identity MonoRef -> Name -> g -> (Term, g)
Cuddle.generateCBORTerm' (CuddleData -> CTreeRoot' Identity MonoRef
cddl CuddleData
cd) Name
n) QCGen
gen
   in forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Term -> Expectation
withTerm [Term]
terms

-- | Verify that random data generated is:
--
-- * Decoded successfully into a Haskell type using the decoder in `Trip` and the version
--   supplied
--
-- * When reencoded conforms produces a valid `FlatTerm`
--
-- * When decoded again from the bytes produced by the encoder matches the type exactly
--   when it was decoded from random bytes
roundTripExample ::
  (HasCallStack, Show a, Eq a) =>
  T.Text ->
  -- | Version to use for decoding
  Version ->
  -- | Version to use for encoding
  Version ->
  -- | Decode/encoder that needs tsting
  Trip a a ->
  -- | Randomly generated data and the CDDL spec
  CBOR.Term ->
  Expectation
roundTripExample :: forall a.
(HasCallStack, Show a, Eq a) =>
Text -> Version -> Version -> Trip a a -> Term -> Expectation
roundTripExample Text
lbl Version
encVersion Version
decVersion trip :: Trip a a
trip@Trip {forall s. Decoder s a
tripDecoder :: forall a b. Trip a b -> forall s. Decoder s b
tripDecoder :: forall s. Decoder s a
tripDecoder} Term
term =
  let
    encoding :: Encoding
encoding = Term -> Encoding
CBOR.encodeTerm Term
term
    initCborBytes :: ByteString
initCborBytes = Encoding -> ByteString
CBOR.toLazyByteString Encoding
encoding
    mkFailure :: Maybe ByteString
-> Maybe String
-> Maybe DecoderError
-> Maybe DecoderError
-> RoundTripFailure
mkFailure =
      Version
-> Version
-> Encoding
-> ByteString
-> Maybe ByteString
-> Maybe String
-> Maybe DecoderError
-> Maybe DecoderError
-> RoundTripFailure
RoundTripFailure Version
encVersion Version
decVersion Encoding
encoding ByteString
initCborBytes
   in
    case forall a.
Version
-> Text
-> (forall s. Decoder s a)
-> ByteString
-> Either DecoderError a
decodeFullDecoder Version
decVersion Text
lbl forall s. Decoder s a
tripDecoder ByteString
initCborBytes of
      Left DecoderError
decErr -> HasCallStack => Encoding -> RoundTripFailure -> Expectation
cddlFailure Encoding
encoding forall a b. (a -> b) -> a -> b
$ Maybe ByteString
-> Maybe String
-> Maybe DecoderError
-> Maybe DecoderError
-> RoundTripFailure
mkFailure forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just DecoderError
decErr)
      Right a
val ->
        case forall a b.
Eq b =>
Text
-> Version
-> Version
-> Trip a b
-> a
-> Either RoundTripFailure (b, Encoding, ByteString)
embedTripLabelExtra Text
lbl Version
encVersion Version
decVersion Trip a a
trip a
val of
          Right (a
val', Encoding
_encoding, ByteString
_encodedBytes) ->
            a
val' forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` a
val
          Left RoundTripFailure
embedErr -> HasCallStack => Encoding -> RoundTripFailure -> Expectation
cddlFailure Encoding
encoding RoundTripFailure
embedErr

-- | Same as `roundTripExample`, but works for decoders that are wrapped into
-- `Annotator`
roundTripAnnExample ::
  (HasCallStack, Show a, Eq a) =>
  T.Text ->
  -- | Version to use for decoding
  Version ->
  -- | Version to use for encoding
  Version ->
  -- | Decode/encoder that needs tsting
  Trip a (Annotator a) ->
  -- | Randomly generated data and the CDDL spec
  CBOR.Term ->
  Expectation
roundTripAnnExample :: forall a.
(HasCallStack, Show a, Eq a) =>
Text
-> Version
-> Version
-> Trip a (Annotator a)
-> Term
-> Expectation
roundTripAnnExample Text
lbl Version
encVersion Version
decVersion Trip {a -> Encoding
tripEncoder :: forall a b. Trip a b -> a -> Encoding
tripEncoder :: a -> Encoding
tripEncoder, forall s. Decoder s (Annotator a)
tripDecoder :: forall s. Decoder s (Annotator a)
tripDecoder :: forall a b. Trip a b -> forall s. Decoder s b
tripDecoder} Term
term =
  let
    encoding :: Encoding
encoding = Term -> Encoding
CBOR.encodeTerm Term
term
    initCborBytes :: ByteString
initCborBytes = Encoding -> ByteString
CBOR.toLazyByteString Encoding
encoding
    mkFailure :: Maybe ByteString
-> Maybe String
-> Maybe DecoderError
-> Maybe DecoderError
-> RoundTripFailure
mkFailure =
      Version
-> Version
-> Encoding
-> ByteString
-> Maybe ByteString
-> Maybe String
-> Maybe DecoderError
-> Maybe DecoderError
-> RoundTripFailure
RoundTripFailure Version
encVersion Version
decVersion Encoding
encoding ByteString
initCborBytes
   in
    case forall a.
Version
-> Text
-> (forall s. Decoder s (Annotator a))
-> ByteString
-> Either DecoderError a
decodeFullAnnotator Version
decVersion Text
lbl forall s. Decoder s (Annotator a)
tripDecoder ByteString
initCborBytes of
      Left DecoderError
decErr -> HasCallStack => Encoding -> RoundTripFailure -> Expectation
cddlFailure Encoding
encoding forall a b. (a -> b) -> a -> b
$ Maybe ByteString
-> Maybe String
-> Maybe DecoderError
-> Maybe DecoderError
-> RoundTripFailure
mkFailure forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just DecoderError
decErr)
      Right a
val ->
        let enc :: Encoding
enc = Version -> Encoding -> Encoding
toPlainEncoding Version
encVersion forall a b. (a -> b) -> a -> b
$ a -> Encoding
tripEncoder a
val
         in case forall t.
Text
-> Version
-> Version
-> (forall s. Decoder s (Annotator t))
-> Encoding
-> Either RoundTripFailure (t, ByteString)
decodeAnnExtra Text
lbl Version
encVersion Version
decVersion forall s. Decoder s (Annotator a)
tripDecoder Encoding
enc of
              Right (a
val', ByteString
_encodedBytes) ->
                a
val' forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` a
val
              Left RoundTripFailure
embedErr -> HasCallStack => Encoding -> RoundTripFailure -> Expectation
cddlFailure Encoding
encoding RoundTripFailure
embedErr

cddlFailure :: HasCallStack => CBOR.Encoding -> RoundTripFailure -> Expectation
cddlFailure :: HasCallStack => Encoding -> RoundTripFailure -> Expectation
cddlFailure Encoding
encoding RoundTripFailure
err =
  HasCallStack => String -> Expectation
expectationFailure forall a b. (a -> b) -> a -> b
$
    [String] -> String
unlines
      [ String
"Failed Cddl RoundTrip verification:"
      , forall a. Show a => a -> String
show RoundTripFailure
err
      , String
"Generated diag: " forall a. Semigroup a => a -> a -> a
<> Encoding -> String
CBOR.prettyHexEnc Encoding
encoding
      ]

--------------------------------------------------------------------------------
-- Writing specs to a file
--------------------------------------------------------------------------------

-- | Write a Huddle specification to a file at the given path
writeSpec :: Cuddle.Huddle -> FilePath -> IO ()
writeSpec :: Huddle -> String -> Expectation
writeSpec Huddle
hddl String
path =
  let cddl :: CDDL
cddl = Huddle -> CDDL
Cuddle.toCDDL Huddle
hddl
      preface :: String
preface = String
"; This file was auto-generated from huddle. Please do not modify it directly!"
   in forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
path IOMode
WriteMode forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
        Handle -> String -> Expectation
hPutStrLn Handle
h String
preface
        forall ann. Handle -> Doc ann -> Expectation
hPutDoc Handle
h (forall a ann. Pretty a => a -> Doc ann
pretty CDDL
cddl)
        -- Write an empty line at the end of the file
        Handle -> String -> Expectation
hPutStrLn Handle
h String
""