Begin validating CBOR

cuddle.cabal

@@ -44,6 +44,7 @@ library
     import:           warnings, ghc2021
     exposed-modules:
         Codec.CBOR.Cuddle.CBOR.Gen
+        Codec.CBOR.Cuddle.CBOR.Validate
         Codec.CBOR.Cuddle.CDDL
         Codec.CBOR.Cuddle.CDDL.CtlOp
         Codec.CBOR.Cuddle.CDDL.CTree

src/Codec/CBOR/Cuddle/CBOR/Validate.hs

@@ -0,0 +1,60 @@
+{-# LANGUAGE ViewPatterns #-}
+
+module Codec.CBOR.Cuddle.CBOR.Validate where
+
+import Codec.CBOR.Cuddle.CDDL
+import Codec.CBOR.Cuddle.CDDL.CTree (CTree)
+import Codec.CBOR.Cuddle.CDDL.CTree qualified as CTree
+import Codec.CBOR.Cuddle.CDDL.Postlude (PTerm (..))
+import Codec.CBOR.Cuddle.CDDL.Resolve (MonoRef)
+import Codec.CBOR.Term (Term (..))
+import Data.ByteString.Lazy qualified as BL
+import Data.Functor.Compose (Compose)
+import Data.Functor.Identity (Identity)
+import Data.Text.Lazy qualified as LT
+
+data ValidationResult f
+  = Matches f Term
+  | NotMatches f Term
+  deriving (Functor)
+
+validateLiteral :: Value -> Term -> ValidationResult Value
+validateLiteral v t = case (v, t) of
+  (valueInteger -> n, termInteger -> m) | n == m -> Matches v t
+  (VFloat16 n, THalf m) | n == m -> Matches v t
+  (VFloat32 n, TFloat m) | n == m -> Matches v t
+  (VFloat64 n, TDouble m) | n == m -> Matches v t
+  (VText r, TString s) | r == s -> Matches v t
+  (VText r, TStringI s) | r == LT.toStrict s -> Matches v t
+  (VBytes r, TBytes s) | r == s -> Matches v t
+  (VBytes r, TBytesI s) | r == BL.toStrict s -> Matches v t
+  _ -> NotMatches v t
+  where
+    -- Interpret a term as an integer type for comparison
+    termInteger (TInt n) = Just $ fromIntegral n
+    termInteger (TInteger n) = Just n
+    termInteger _ = Nothing
+    -- Interpret a value as an integer for comparison
+    valueInteger (VUInt n) = Just $ fromIntegral n
+    valueInteger (VNInt n) = Just $ fromIntegral n
+    valueInteger (VBignum n) = Just n
+    valueInteger _ = Nothing
+
+validatePTerm :: PTerm -> Term -> ValidationResult PTerm
+validatePTerm v t = case (v, t) of
+  (PTBool, TBool _) -> Matches v t
+  (PTUInt, TInt _) -> Matches v t
+  (PTUInt, TInteger _) -> Matches v t
+  (PTNInt, TInt n) | n < 0 -> Matches v t
+  (PTNInt, TInteger n) | n < 0 -> Matches v t
+  (PTInt, TInt _) -> Matches v t
+  (PTInt, TInteger _) -> Matches v t
+  (PTHalf, THalf _) -> Matches v t
+  (PTFloat, TFloat _) -> Matches v t
+  (PTDouble, TDouble _) -> Matches v t
+  (PTBytes, TBytes _) -> Matches v t
+  (PTBytes, TBytesI _) -> Matches v t
+  (PTText, TString _) -> Matches v t
+  (PTAny, _) -> Matches v t
+  (PTNil, _) -> NotMatches v t
+  _ -> NotMatches v t