Improve .cbor control validation failure message

Author: Soupstraw

golden/cborControlBad.txt

@@ -0,0 +1,2 @@
+unsatisfied control:
+  .cbor simpleRule

src/Codec/CBOR/Cuddle/CBOR/Validator.hs

@@ -624,7 +624,7 @@ controlBytes cddl bs Bits ctrl = do
 controlBytes cddl bs Cbor ctrl =
   case deserialiseFromBytes decodeTerm (BSL.fromStrict bs) of
     Right (BSL.null -> True, term) -> isValid $ validateTerm cddl term ctrl
-    _ -> error "Not yet implemented"
+    _ -> False
 controlBytes cddl bs Cborseq ctrl =
   case deserialiseFromBytes decodeTerm (BSL.fromStrict (BS.snoc (BS.cons 0x9f bs) 0xff)) of
     Right (BSL.null -> True, TListI terms) -> isValid $ validateTerm cddl (TList terms) (Array [Occur ctrl OIZeroOrMore])

test/Test/Codec/CBOR/Cuddle/CDDL/Examples/Huddle.hs

@@ -6,8 +6,8 @@ module Test.Codec.CBOR.Cuddle.CDDL.Examples.Huddle (
   huddleArray,
   huddleMap,
   huddleRangeMap,
-  simpleRule,
-  simpleTermExample,
+  customGenRule,
+  customGenExample,
   refTermExample,
   bytesExample,
   opCertExample,
@@ -17,6 +17,7 @@ module Test.Codec.CBOR.Cuddle.CDDL.Examples.Huddle (
   rangeMapExample,
   optionalMapExample,
   choicesExample,
+  cborControlExample,
 ) where
 
 import Codec.CBOR.Cuddle.CDDL (Name)
@@ -95,18 +96,21 @@ huddleRangeMap =
     ]
 
 simpleRule :: Name -> Rule
-simpleRule n = withGenerator (\_ -> S . C.TInt <$> choose (4, 6)) $ n =:= arr [1, 2, 3]
+simpleRule n = n =:= arr [1, 2, 3]
 
-simpleTermExample :: Huddle
-simpleTermExample =
+customGenRule :: Name -> Rule
+customGenRule = withGenerator (\_ -> S . C.TInt <$> choose (4, 6)) . simpleRule
+
+customGenExample :: Huddle
+customGenExample =
   collectFrom
-    [ HIRule $ simpleRule "root"
+    [ HIRule $ customGenRule "root"
     ]
 
 refTermExample :: Huddle
 refTermExample =
   collectFrom
-    [ HIRule $ "root" =:= arr [0, a $ simpleRule "bar"]
+    [ HIRule $ "root" =:= arr [0, a $ customGenRule "bar"]
     ]
 
 bytesExample :: Huddle
@@ -177,3 +181,12 @@ choicesExample =
           H./ arr [1, a VBool, 6]
           H./ arr [1, a VText]
     ]
+
+cborControlExample :: Huddle
+cborControlExample =
+  collectFrom
+    [ HIRule $
+        "root"
+          =:= VBytes
+          `H.cbor` simpleRule "simpleRule"
+    ]

test/Test/Codec/CBOR/Cuddle/CDDL/GeneratorSpec.hs

@@ -20,12 +20,12 @@ import Data.Text.Lazy qualified as TL
 import Test.AntiGen (runAntiGen, zapAntiGen)
 import Test.Codec.CBOR.Cuddle.CDDL.Examples.Huddle (
   bytesExample,
+  customGenExample,
   opCertExample,
   optionalMapExample,
   rangeListExample,
   rangeMapExample,
   refTermExample,
-  simpleTermExample,
   sizeBytesExample,
   sizeTextExample,
  )
@@ -66,7 +66,7 @@ spec :: Spec
 spec = do
   describe "Negative generator" $ do
     describe "Zapped value fails to validate" $ do
-      zapInvalidatesHuddle "simpleTerm" simpleTermExample
+      zapInvalidatesHuddle "customGen" customGenExample
       zapInvalidatesHuddle "refTerm" refTermExample
       zapInvalidatesHuddle "opCert" opCertExample
       zapInvalidatesHuddle "sizeText" sizeTextExample
@@ -77,7 +77,7 @@ spec = do
 
   describe "Custom generators" $ do
     describe "Huddle" $ do
-      simpleTermExampleCddl <- tryResolveHuddle simpleTermExample
+      simpleTermExampleCddl <- tryResolveHuddle customGenExample
       prop "If a term has a custom generator then it is used" $ do
         res <- generateCDDL $ mapIndex simpleTermExampleCddl
         pure $

test/Test/Codec/CBOR/Cuddle/CDDL/Validator/Golden.hs

@@ -14,6 +14,7 @@ import Codec.CBOR.Cuddle.CDDL.Resolve (fullResolveCDDL)
 import Codec.CBOR.Cuddle.Huddle (Huddle, toCDDL)
 import Codec.CBOR.Cuddle.IndexMappable (mapCDDLDropExt, mapIndex)
 import Codec.CBOR.Term (Term (..), encodeTerm)
+import Codec.CBOR.Write (toStrictByteString)
 import Codec.CBOR.Write qualified as CBOR
 import Control.Monad ((<=<))
 import Data.Either (fromRight)
@@ -24,6 +25,7 @@ import Prettyprinter (defaultLayoutOptions, layoutPretty)
 import Prettyprinter.Render.Terminal qualified as Ansi
 import System.FilePath ((</>))
 import Test.Codec.CBOR.Cuddle.CDDL.Examples.Huddle (
+  cborControlExample,
   choicesExample,
   huddleRangeArray,
   refTermExample,
@@ -60,6 +62,9 @@ choiceAlmostSecond =
     , TInt 1
     ]
 
+cborControlBad :: Term
+cborControlBad = TBytes . toStrictByteString $ encodeTerm (TList [TInt 1, TInt 2, TInt 4])
+
 validatorPrettyGolden :: String -> Huddle -> Name -> Term -> Spec
 validatorPrettyGolden testName huddle n term =
   it testName $
@@ -102,3 +107,8 @@ spec = describe "golden" $ do
       choicesExample
       "root"
       choiceAlmostSecond
+    validatorPrettyGolden
+      "cborControlBad"
+      cborControlExample
+      "root"
+      cborControlBad