{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeData #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

module Codec.CBOR.Cuddle.CBOR.Validator (
  validateCBOR,
  CDDLResult (..),
  CBORTermResult (..),
  ValidatorStage,
) where

import Codec.CBOR.Cuddle.CDDL hiding (CDDL, Group, Rule)
import Codec.CBOR.Cuddle.CDDL.CTree
import Codec.CBOR.Cuddle.CDDL.CtlOp
import Codec.CBOR.Cuddle.CDDL.Resolve (MonoReferenced, XXCTree (..))
import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..))
import Codec.CBOR.Read
import Codec.CBOR.Term
import Data.Bits hiding (And)
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BSL
import Data.IntSet qualified as IS
import Data.List.NonEmpty qualified as NE
import Data.Map.Strict qualified as Map
import Data.Maybe
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
import Data.Word
import Debug.Trace (trace, traceShow)
import GHC.Float
import GHC.Stack (HasCallStack)
import Text.Regex.TDFA

type data ValidatorStage

data instance XTerm ValidatorStage = ValidatorXTerm
  deriving (Int -> XTerm ValidatorStage -> ShowS
[XTerm ValidatorStage] -> ShowS
XTerm ValidatorStage -> [Char]
(Int -> XTerm ValidatorStage -> ShowS)
-> (XTerm ValidatorStage -> [Char])
-> ([XTerm ValidatorStage] -> ShowS)
-> Show (XTerm ValidatorStage)
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> XTerm ValidatorStage -> ShowS
showsPrec :: Int -> XTerm ValidatorStage -> ShowS
$cshow :: XTerm ValidatorStage -> [Char]
show :: XTerm ValidatorStage -> [Char]
$cshowList :: [XTerm ValidatorStage] -> ShowS
showList :: [XTerm ValidatorStage] -> ShowS
Show)

newtype instance XXCTree ValidatorStage = VRuleRef Name
  deriving (Int -> Node ValidatorStage -> ShowS
[Node ValidatorStage] -> ShowS
Node ValidatorStage -> [Char]
(Int -> Node ValidatorStage -> ShowS)
-> (Node ValidatorStage -> [Char])
-> ([Node ValidatorStage] -> ShowS)
-> Show (Node ValidatorStage)
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Node ValidatorStage -> ShowS
showsPrec :: Int -> Node ValidatorStage -> ShowS
$cshow :: Node ValidatorStage -> [Char]
show :: Node ValidatorStage -> [Char]
$cshowList :: [Node ValidatorStage] -> ShowS
showList :: [Node ValidatorStage] -> ShowS
Show)

instance IndexMappable CTreeRoot MonoReferenced ValidatorStage where
  mapIndex :: CTreeRoot MonoReferenced -> CTreeRoot ValidatorStage
mapIndex (CTreeRoot Map Name (CTree MonoReferenced)
m) = Map Name Rule -> CTreeRoot ValidatorStage
forall i. Map Name (CTree i) -> CTreeRoot i
CTreeRoot (Map Name Rule -> CTreeRoot ValidatorStage)
-> Map Name Rule -> CTreeRoot ValidatorStage
forall a b. (a -> b) -> a -> b
$ CTree MonoReferenced -> Rule
forall {k} (f :: k -> *) (i :: k) (j :: k).
IndexMappable f i j =>
f i -> f j
mapIndex (CTree MonoReferenced -> Rule)
-> Map Name (CTree MonoReferenced) -> Map Name Rule
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Name (CTree MonoReferenced)
m

instance IndexMappable CTree MonoReferenced ValidatorStage where
  mapIndex :: CTree MonoReferenced -> Rule
mapIndex = (XXCTree MonoReferenced -> Rule)
-> (CTree MonoReferenced -> Rule) -> CTree MonoReferenced -> Rule
forall i j.
(XXCTree i -> CTree j)
-> (CTree i -> CTree j) -> CTree i -> CTree j
foldCTree XXCTree MonoReferenced -> Rule
mapExt CTree MonoReferenced -> Rule
forall {k} (f :: k -> *) (i :: k) (j :: k).
IndexMappable f i j =>
f i -> f j
mapIndex
    where
      mapExt :: XXCTree MonoReferenced -> Rule
mapExt (MRuleRef Name
n) = Node ValidatorStage -> Rule
forall i. XXCTree i -> CTree i
CTreeE (Node ValidatorStage -> Rule) -> Node ValidatorStage -> Rule
forall a b. (a -> b) -> a -> b
$ Name -> Node ValidatorStage
VRuleRef Name
n
      mapExt (MGenerator CBORGenerator
_ CTree MonoReferenced
x) = CTree MonoReferenced -> Rule
forall {k} (f :: k -> *) (i :: k) (j :: k).
IndexMappable f i j =>
f i -> f j
mapIndex CTree MonoReferenced
x

type CDDL = CTreeRoot ValidatorStage
type Rule = CTree ValidatorStage

data CBORTermResult = CBORTermResult
  { CBORTermResult -> Term
ctrTerm :: Term
  , CBORTermResult -> CDDLResult
ctrResult :: CDDLResult
  }
  deriving (Int -> CBORTermResult -> ShowS
[CBORTermResult] -> ShowS
CBORTermResult -> [Char]
(Int -> CBORTermResult -> ShowS)
-> (CBORTermResult -> [Char])
-> ([CBORTermResult] -> ShowS)
-> Show CBORTermResult
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CBORTermResult -> ShowS
showsPrec :: Int -> CBORTermResult -> ShowS
$cshow :: CBORTermResult -> [Char]
show :: CBORTermResult -> [Char]
$cshowList :: [CBORTermResult] -> ShowS
showList :: [CBORTermResult] -> ShowS
Show)

data CDDLResult
  = -- | The rule was valid
    Valid Rule
  | -- | All alternatives failed
    ChoiceFail
      -- | Rule we are trying
      Rule
      -- | The alternatives that arise from said rule
      (NE.NonEmpty Rule)
      -- | For each alternative, the result
      (NE.NonEmpty (Rule, CDDLResult))
  | -- | All expansions failed
    --
    -- An expansion is: Given a CBOR @TList@ of @N@ elements, we will expand the
    -- rules in a list spec to match the number of items in the list.
    ListExpansionFail
      -- | Rule we are trying
      Rule
      -- | List of expansions of rules
      [[Rule]]
      -- | For each expansion, for each of the rules in the expansion, the result
      [[(Rule, CBORTermResult)]]
  | -- | All expansions failed
    --
    -- An expansion is: Given a CBOR @TMap@ of @N@ elements, we will expand the
    -- rules in a map spec to match the number of items in the map.
    MapExpansionFail
      -- | Rule we are trying
      Rule
      -- | List of expansions
      [[Rule]]
      -- | A list of matched items @(key, value, rule)@ and the unmatched item
      [([AMatchedItem], ANonMatchedItem)]
  | -- | The rule was valid but the control failed
    InvalidControl
      -- | Control we are trying
      Rule
      -- | If it is a .cbor, the result of the underlying validation
      (Maybe CBORTermResult)
  | InvalidRule Rule
  | -- | A tagged was invalid
    InvalidTagged
      -- | Rule we are trying
      Rule
      -- | Either the tag is wrong, or the contents are wrong
      (Either Word64 CBORTermResult)
  | -- | The rule we are trying is not applicable to the CBOR term
    UnapplicableRule
      -- | Extra information
      String
      -- | Rule we are trying
      Rule
  deriving (Int -> CDDLResult -> ShowS
[CDDLResult] -> ShowS
CDDLResult -> [Char]
(Int -> CDDLResult -> ShowS)
-> (CDDLResult -> [Char])
-> ([CDDLResult] -> ShowS)
-> Show CDDLResult
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CDDLResult -> ShowS
showsPrec :: Int -> CDDLResult -> ShowS
$cshow :: CDDLResult -> [Char]
show :: CDDLResult -> [Char]
$cshowList :: [CDDLResult] -> ShowS
showList :: [CDDLResult] -> ShowS
Show)

data ANonMatchedItem = ANonMatchedItem
  { ANonMatchedItem -> Term
anmiKey :: Term
  , ANonMatchedItem -> Term
anmiValue :: Term
  , ANonMatchedItem
-> [Either (Rule, CDDLResult) (Rule, CDDLResult, CDDLResult)]
anmiResults :: [Either (Rule, CDDLResult) (Rule, CDDLResult, CDDLResult)]
  -- ^ For all the tried rules, either the key failed or the key succeeded and
  -- the value failed
  }
  deriving (Int -> ANonMatchedItem -> ShowS
[ANonMatchedItem] -> ShowS
ANonMatchedItem -> [Char]
(Int -> ANonMatchedItem -> ShowS)
-> (ANonMatchedItem -> [Char])
-> ([ANonMatchedItem] -> ShowS)
-> Show ANonMatchedItem
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ANonMatchedItem -> ShowS
showsPrec :: Int -> ANonMatchedItem -> ShowS
$cshow :: ANonMatchedItem -> [Char]
show :: ANonMatchedItem -> [Char]
$cshowList :: [ANonMatchedItem] -> ShowS
showList :: [ANonMatchedItem] -> ShowS
Show)

data AMatchedItem = AMatchedItem
  { AMatchedItem -> Term
amiKey :: Term
  , AMatchedItem -> Term
amiValue :: Term
  , AMatchedItem -> Rule
amiRule :: Rule
  }
  deriving (Int -> AMatchedItem -> ShowS
[AMatchedItem] -> ShowS
AMatchedItem -> [Char]
(Int -> AMatchedItem -> ShowS)
-> (AMatchedItem -> [Char])
-> ([AMatchedItem] -> ShowS)
-> Show AMatchedItem
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AMatchedItem -> ShowS
showsPrec :: Int -> AMatchedItem -> ShowS
$cshow :: AMatchedItem -> [Char]
show :: AMatchedItem -> [Char]
$cshowList :: [AMatchedItem] -> ShowS
showList :: [AMatchedItem] -> ShowS
Show)

--------------------------------------------------------------------------------
-- Main entry point

validateCBOR :: BS.ByteString -> Name -> CDDL -> CBORTermResult
validateCBOR :: ByteString -> Name -> CTreeRoot ValidatorStage -> CBORTermResult
validateCBOR ByteString
bs Name
rule cddl :: CTreeRoot ValidatorStage
cddl@(CTreeRoot Map Name Rule
tree) =
  case (forall s. Decoder s Term)
-> ByteString -> Either DeserialiseFailure (ByteString, Term)
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
deserialiseFromBytes Decoder s Term
forall s. Decoder s Term
decodeTerm (ByteString -> ByteString
BSL.fromStrict ByteString
bs) of
    Left DeserialiseFailure
e -> [Char] -> CBORTermResult
forall a. HasCallStack => [Char] -> a
error ([Char] -> CBORTermResult) -> [Char] -> CBORTermResult
forall a b. (a -> b) -> a -> b
$ DeserialiseFailure -> [Char]
forall a. Show a => a -> [Char]
show DeserialiseFailure
e
    Right (ByteString
rest, Term
term)
      | ByteString -> Bool
BSL.null ByteString
rest -> CTreeRoot ValidatorStage -> Term -> Rule -> CBORTermResult
validateTerm CTreeRoot ValidatorStage
cddl Term
term (Map Name Rule
tree Map Name Rule -> Name -> Rule
forall k a. Ord k => Map k a -> k -> a
Map.! Name
rule)
      | Bool
otherwise -> [Char] -> CBORTermResult
forall a. HasCallStack => [Char] -> a
error ([Char] -> CBORTermResult) -> [Char] -> CBORTermResult
forall a b. (a -> b) -> a -> b
$ [Char]
"Leftover bytes in CBOR" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
rest

--------------------------------------------------------------------------------
-- Terms

-- | Core function that validates a CBOR term to a particular rule of the CDDL
-- spec
validateTerm :: CDDL -> Term -> Rule -> CBORTermResult
validateTerm :: CTreeRoot ValidatorStage -> Term -> Rule -> CBORTermResult
validateTerm CTreeRoot ValidatorStage
cddl Term
term Rule
rule =
  Term -> CDDLResult -> CBORTermResult
CBORTermResult Term
term (CDDLResult -> CBORTermResult) -> CDDLResult -> CBORTermResult
forall a b. (a -> b) -> a -> b
$ case Term
term of
    TInt Int
i -> HasCallStack =>
CTreeRoot ValidatorStage -> Integer -> Rule -> CDDLResult
CTreeRoot ValidatorStage -> Integer -> Rule -> CDDLResult
validateInteger CTreeRoot ValidatorStage
cddl (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i) Rule
rRule
    TInteger Integer
i -> HasCallStack =>
CTreeRoot ValidatorStage -> Integer -> Rule -> CDDLResult
CTreeRoot ValidatorStage -> Integer -> Rule -> CDDLResult
validateInteger CTreeRoot ValidatorStage
cddl Integer
i Rule
rRule
    TBytes ByteString
b -> CTreeRoot ValidatorStage -> ByteString -> Rule -> CDDLResult
validateBytes CTreeRoot ValidatorStage
cddl ByteString
b Rule
rRule
    TBytesI ByteString
b -> CTreeRoot ValidatorStage -> ByteString -> Rule -> CDDLResult
validateBytes CTreeRoot ValidatorStage
cddl (ByteString -> ByteString
BSL.toStrict ByteString
b) Rule
rRule
    TString Text
s -> CTreeRoot ValidatorStage -> Text -> Rule -> CDDLResult
validateText CTreeRoot ValidatorStage
cddl Text
s Rule
rRule
    TStringI Text
s -> CTreeRoot ValidatorStage -> Text -> Rule -> CDDLResult
validateText CTreeRoot ValidatorStage
cddl (Text -> Text
TL.toStrict Text
s) Rule
rRule
    TList [Term]
ts -> CTreeRoot ValidatorStage -> [Term] -> Rule -> CDDLResult
validateList CTreeRoot ValidatorStage
cddl [Term]
ts Rule
rRule
    TListI [Term]
ts -> CTreeRoot ValidatorStage -> [Term] -> Rule -> CDDLResult
validateList CTreeRoot ValidatorStage
cddl [Term]
ts Rule
rRule
    TMap [(Term, Term)]
ts -> CTreeRoot ValidatorStage -> [(Term, Term)] -> Rule -> CDDLResult
validateMap CTreeRoot ValidatorStage
cddl [(Term, Term)]
ts Rule
rRule
    TMapI [(Term, Term)]
ts -> CTreeRoot ValidatorStage -> [(Term, Term)] -> Rule -> CDDLResult
validateMap CTreeRoot ValidatorStage
cddl [(Term, Term)]
ts Rule
rRule
    TTagged Word64
w Term
t -> CTreeRoot ValidatorStage -> Word64 -> Term -> Rule -> CDDLResult
validateTagged CTreeRoot ValidatorStage
cddl Word64
w Term
t Rule
rRule
    TBool Bool
b -> CTreeRoot ValidatorStage -> Bool -> Rule -> CDDLResult
validateBool CTreeRoot ValidatorStage
cddl Bool
b Rule
rRule
    Term
TNull -> CTreeRoot ValidatorStage -> Rule -> CDDLResult
validateNull CTreeRoot ValidatorStage
cddl Rule
rRule
    TSimple Word8
s -> CTreeRoot ValidatorStage -> Word8 -> Rule -> CDDLResult
validateSimple CTreeRoot ValidatorStage
cddl Word8
s Rule
rRule
    THalf Float
h -> HasCallStack =>
CTreeRoot ValidatorStage -> Float -> Rule -> CDDLResult
CTreeRoot ValidatorStage -> Float -> Rule -> CDDLResult
validateHalf CTreeRoot ValidatorStage
cddl Float
h Rule
rRule
    TFloat Float
h -> HasCallStack =>
CTreeRoot ValidatorStage -> Float -> Rule -> CDDLResult
CTreeRoot ValidatorStage -> Float -> Rule -> CDDLResult
validateFloat CTreeRoot ValidatorStage
cddl Float
h Rule
rRule
    TDouble Double
d -> HasCallStack =>
CTreeRoot ValidatorStage -> Double -> Rule -> CDDLResult
CTreeRoot ValidatorStage -> Double -> Rule -> CDDLResult
validateDouble CTreeRoot ValidatorStage
cddl Double
d Rule
rRule
  where
    rRule :: Rule
rRule = CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
rule

--------------------------------------------------------------------------------
-- Ints and integers

-- | Validation of an Int or Integer. CBOR categorizes every integral in `TInt`
-- or `TInteger` but it can be the case that we are decoding something that is
-- expected to be a `Word64` even if we get a `TInt`.
--
-- > ghci> encodeWord64 15
-- > [TkInt 15]
-- > ghci> encodeWord64 maxBound
-- > [TkInteger 18446744073709551615]
--
-- For this reason, we cannot assume that bounds or literals are going to be
-- Ints, so we convert everything to Integer.
validateInteger :: HasCallStack => CDDL -> Integer -> Rule -> CDDLResult
validateInteger :: HasCallStack =>
CTreeRoot ValidatorStage -> Integer -> Rule -> CDDLResult
validateInteger CTreeRoot ValidatorStage
cddl Integer
i Rule
rule =
  case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
rule of
    -- echo "C24101" | xxd -r -p - example.cbor
    -- echo "foo = int" > a.cddl
    -- cddl a.cddl validate example.cbor
    --
    -- but
    --
    -- echo "C249010000000000000000"| xxd -r -p - example.cbor
    -- echo "foo = int" > a.cddl
    -- cddl a.cddl validate example.cbor
    --
    -- and they are both bigints?

    -- a = any
    Postlude PTerm
PTAny -> Rule -> CDDLResult
Valid Rule
rule
    -- a = int
    Postlude PTerm
PTInt -> Rule -> CDDLResult
Valid Rule
rule
    -- a = uint
    Postlude PTerm
PTUInt -> Bool -> Rule -> CDDLResult
check (Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0) Rule
rule
    -- a = nint
    Postlude PTerm
PTNInt -> Bool -> Rule -> CDDLResult
check (Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0) Rule
rule
    -- a = x
    Literal (Value (VUInt Word64
i') Comment
_) -> Bool -> Rule -> CDDLResult
check (Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i') Rule
rule
    -- a = -x
    Literal (Value (VNInt Word64
i') Comment
_) -> Bool -> Rule -> CDDLResult
check (-Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i') Rule
rule
    -- a = <big number>
    Literal (Value (VBignum Integer
i') Comment
_) -> Bool -> Rule -> CDDLResult
check (Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
i') Rule
rule
    -- a = foo .ctrl bar
    Control CtlOp
op Rule
tgt Rule
ctrl -> (Rule -> CDDLResult)
-> CtlOp
-> Rule
-> Rule
-> (CtlOp -> Rule -> Either (Maybe CBORTermResult) ())
-> Rule
-> CDDLResult
ctrlDispatch (HasCallStack =>
CTreeRoot ValidatorStage -> Integer -> Rule -> CDDLResult
CTreeRoot ValidatorStage -> Integer -> Rule -> CDDLResult
validateInteger CTreeRoot ValidatorStage
cddl Integer
i) CtlOp
op Rule
tgt Rule
ctrl (HasCallStack =>
CTreeRoot ValidatorStage
-> Integer -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
CTreeRoot ValidatorStage
-> Integer -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
controlInteger CTreeRoot ValidatorStage
cddl Integer
i) Rule
rule
    -- a = foo / bar
    Choice NonEmpty Rule
opts -> (Rule -> CDDLResult) -> NonEmpty Rule -> Rule -> CDDLResult
validateChoice (HasCallStack =>
CTreeRoot ValidatorStage -> Integer -> Rule -> CDDLResult
CTreeRoot ValidatorStage -> Integer -> Rule -> CDDLResult
validateInteger CTreeRoot ValidatorStage
cddl Integer
i) NonEmpty Rule
opts Rule
rule
    -- a = x..y
    Range Rule
low Rule
high RangeBound
bound ->
      Bool -> Rule -> CDDLResult
check
        ( case (CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
low, CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
high) of
            (Literal (Value (VUInt (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Integer
n)) Comment
_), Literal (Value (VUInt (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Integer
m)) Comment
_)) -> Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
i Bool -> Bool -> Bool
&& RangeBound -> Integer -> Integer -> Bool
forall a. Ord a => RangeBound -> a -> a -> Bool
range RangeBound
bound Integer
i Integer
m
            (Literal (Value (VNInt (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Integer
n)) Comment
_), Literal (Value (VUInt (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Integer
m)) Comment
_)) -> -Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
i Bool -> Bool -> Bool
&& RangeBound -> Integer -> Integer -> Bool
forall a. Ord a => RangeBound -> a -> a -> Bool
range RangeBound
bound Integer
i Integer
m
            (Literal (Value (VNInt (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Integer
n)) Comment
_), Literal (Value (VNInt (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Integer
m)) Comment
_)) -> -Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
i Bool -> Bool -> Bool
&& RangeBound -> Integer -> Integer -> Bool
forall a. Ord a => RangeBound -> a -> a -> Bool
range RangeBound
bound Integer
i (-Integer
m)
            (Literal (Value VUInt {} Comment
_), Literal (Value VNInt {} Comment
_)) -> Bool
False
            (Literal (Value (VBignum Integer
n) Comment
_), Literal (Value (VUInt (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Integer
m)) Comment
_)) -> Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
i Bool -> Bool -> Bool
&& RangeBound -> Integer -> Integer -> Bool
forall a. Ord a => RangeBound -> a -> a -> Bool
range RangeBound
bound Integer
i Integer
m
            (Literal (Value (VBignum Integer
n) Comment
_), Literal (Value (VNInt (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Integer
m)) Comment
_)) -> Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
i Bool -> Bool -> Bool
&& RangeBound -> Integer -> Integer -> Bool
forall a. Ord a => RangeBound -> a -> a -> Bool
range RangeBound
bound Integer
i (-Integer
m)
            (Literal (Value (VUInt (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Integer
n)) Comment
_), Literal (Value (VBignum Integer
m) Comment
_)) -> Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
i Bool -> Bool -> Bool
&& RangeBound -> Integer -> Integer -> Bool
forall a. Ord a => RangeBound -> a -> a -> Bool
range RangeBound
bound Integer
i Integer
m
            (Literal (Value (VNInt (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Integer
n)) Comment
_), Literal (Value (VBignum Integer
m) Comment
_)) -> (-Integer
n) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
i Bool -> Bool -> Bool
&& RangeBound -> Integer -> Integer -> Bool
forall a. Ord a => RangeBound -> a -> a -> Bool
range RangeBound
bound Integer
i Integer
m
            (Rule, Rule)
x -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error ([Char] -> Bool) -> [Char] -> Bool
forall a b. (a -> b) -> a -> b
$ [Char]
"Unable to validate range: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Rule, Rule) -> [Char]
forall a. Show a => a -> [Char]
show (Rule, Rule)
x
        )
        Rule
rule
    -- a = &(x, y, z)
    Enum Rule
g ->
      case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
g of
        Group [Rule]
g' -> CDDLResult -> Rule -> CDDLResult
replaceRule (HasCallStack =>
CTreeRoot ValidatorStage -> Integer -> Rule -> CDDLResult
CTreeRoot ValidatorStage -> Integer -> Rule -> CDDLResult
validateInteger CTreeRoot ValidatorStage
cddl Integer
i (NonEmpty Rule -> Rule
forall i. NonEmpty (CTree i) -> CTree i
Choice ([Rule] -> NonEmpty Rule
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList [Rule]
g'))) Rule
rule
        Rule
_ -> [Char] -> CDDLResult
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"
    -- a = x: y
    -- Note KV cannot appear on its own, but we will use this when validating
    -- lists.
    KV Rule
_ Rule
v Bool
_ -> CDDLResult -> Rule -> CDDLResult
replaceRule (HasCallStack =>
CTreeRoot ValidatorStage -> Integer -> Rule -> CDDLResult
CTreeRoot ValidatorStage -> Integer -> Rule -> CDDLResult
validateInteger CTreeRoot ValidatorStage
cddl Integer
i Rule
v) Rule
rule
    Tag Word64
2 Rule
x -> Rule -> CDDLResult
validateBigInt Rule
x
    Tag Word64
3 Rule
x -> Rule -> CDDLResult
validateBigInt Rule
x
    Rule
_ -> [Char] -> Rule -> CDDLResult
UnapplicableRule [Char]
"validateInteger" Rule
rule
  where
    validateBigInt :: Rule -> CDDLResult
validateBigInt Rule
x = case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
x of
      Postlude PTerm
PTBytes -> Rule -> CDDLResult
Valid Rule
rule
      Control CtlOp
op tgt :: Rule
tgt@(Postlude PTerm
PTBytes) Rule
ctrl ->
        (Rule -> CDDLResult)
-> CtlOp
-> Rule
-> Rule
-> (CtlOp -> Rule -> Either (Maybe CBORTermResult) ())
-> Rule
-> CDDLResult
ctrlDispatch (CTreeRoot ValidatorStage -> ByteString -> Rule -> CDDLResult
validateBytes CTreeRoot ValidatorStage
cddl ByteString
bs) CtlOp
op Rule
tgt Rule
ctrl (HasCallStack =>
CTreeRoot ValidatorStage
-> ByteString -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
CTreeRoot ValidatorStage
-> ByteString -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
controlBytes CTreeRoot ValidatorStage
cddl ByteString
bs) Rule
rule
        where
          -- TODO figure out a way to turn Integer into bytes or figure out why
          -- tagged bigints are decoded as integers in the first place
          bs :: ByteString
bs = ByteString
forall a. Monoid a => a
mempty
      Rule
e -> [Char] -> CDDLResult
forall a. HasCallStack => [Char] -> a
error ([Char] -> CDDLResult) -> [Char] -> CDDLResult
forall a b. (a -> b) -> a -> b
$ [Char]
"Not yet implemented" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Rule -> [Char]
forall a. Show a => a -> [Char]
show Rule
e

-- | Controls for an Integer
controlInteger ::
  HasCallStack => CDDL -> Integer -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
controlInteger :: HasCallStack =>
CTreeRoot ValidatorStage
-> Integer -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
controlInteger CTreeRoot ValidatorStage
cddl Integer
i CtlOp
Size Rule
ctrl =
  case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
ctrl of
    Literal (Value (VUInt Word64
sz) Comment
_) ->
      Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> Bool -> Either (Maybe CBORTermResult) ()
forall a b. (a -> b) -> a -> b
$ Integer
0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
i Bool -> Bool -> Bool
&& Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
256 Integer -> Word64 -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Word64
sz
    Rule
_ -> [Char] -> Either (Maybe CBORTermResult) ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"
controlInteger CTreeRoot ValidatorStage
cddl Integer
i CtlOp
Bits Rule
ctrl = do
  let
    indices :: [Word64]
indices = case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
ctrl of
      Literal (Value (VUInt Word64
i') Comment
_) -> [Word64
i']
      Choice NonEmpty Rule
nodes -> CTreeRoot ValidatorStage -> NonEmpty Rule -> [Word64]
getIndicesOfChoice CTreeRoot ValidatorStage
cddl NonEmpty Rule
nodes
      Range Rule
ff Rule
tt RangeBound
incl -> CTreeRoot ValidatorStage -> Rule -> Rule -> RangeBound -> [Word64]
getIndicesOfRange CTreeRoot ValidatorStage
cddl Rule
ff Rule
tt RangeBound
incl
      Enum Rule
g -> CTreeRoot ValidatorStage -> Rule -> [Word64]
getIndicesOfEnum CTreeRoot ValidatorStage
cddl Rule
g
      Rule
_ -> [Char] -> [Word64]
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"
  Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> Bool -> Either (Maybe CBORTermResult) ()
forall a b. (a -> b) -> a -> b
$ IntSet -> Integer -> Int -> Bool
forall {t}. (Num t, Bits t) => IntSet -> t -> Int -> Bool
go ([Int] -> IntSet
IS.fromList ((Word64 -> Int) -> [Word64] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Word64]
indices)) Integer
i Int
0
  where
    go :: IntSet -> t -> Int -> Bool
go IntSet
_ t
0 Int
_ = Bool
True
    go IntSet
indices t
n Int
idx =
      let bitSet :: Bool
bitSet = t -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit t
n Int
0
          allowed :: Bool
allowed = Bool -> Bool
not Bool
bitSet Bool -> Bool -> Bool
|| Int -> IntSet -> Bool
IS.member Int
idx IntSet
indices
       in (Bool
allowed Bool -> Bool -> Bool
&& IntSet -> t -> Int -> Bool
go IntSet
indices (t -> Int -> t
forall a. Bits a => a -> Int -> a
shiftR t
n Int
1) (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
controlInteger CTreeRoot ValidatorStage
cddl Integer
i CtlOp
Lt Rule
ctrl =
  Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> Bool -> Either (Maybe CBORTermResult) ()
forall a b. (a -> b) -> a -> b
$ case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
ctrl of
    Literal (Value (VUInt Word64
i') Comment
_) -> Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i'
    Literal (Value (VNInt Word64
i') Comment
_) -> Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< -Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i'
    Literal (Value (VBignum Integer
i') Comment
_) -> Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
i'
    Rule
_ -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"
controlInteger CTreeRoot ValidatorStage
cddl Integer
i CtlOp
Gt Rule
ctrl =
  Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> Bool -> Either (Maybe CBORTermResult) ()
forall a b. (a -> b) -> a -> b
$ case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
ctrl of
    Literal (Value (VUInt Word64
i') Comment
_) -> Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i'
    Literal (Value (VNInt Word64
i') Comment
_) -> Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> -Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i'
    Literal (Value (VBignum Integer
i') Comment
_) -> Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
i'
    Rule
_ -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"
controlInteger CTreeRoot ValidatorStage
cddl Integer
i CtlOp
Le Rule
ctrl =
  Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> Bool -> Either (Maybe CBORTermResult) ()
forall a b. (a -> b) -> a -> b
$ case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
ctrl of
    Literal (Value (VUInt Word64
i') Comment
_) -> Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i'
    Literal (Value (VNInt Word64
i') Comment
_) -> Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= -Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i'
    Literal (Value (VBignum Integer
i') Comment
_) -> Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
i'
    Rule
_ -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"
controlInteger CTreeRoot ValidatorStage
cddl Integer
i CtlOp
Ge Rule
ctrl =
  Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> Bool -> Either (Maybe CBORTermResult) ()
forall a b. (a -> b) -> a -> b
$ case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
ctrl of
    Literal (Value (VUInt Word64
i') Comment
_) -> Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i'
    Literal (Value (VNInt Word64
i') Comment
_) -> Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= -Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i'
    Literal (Value (VBignum Integer
i') Comment
_) -> Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
i'
    Rule
_ -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"
controlInteger CTreeRoot ValidatorStage
cddl Integer
i CtlOp
Eq Rule
ctrl =
  Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> Bool -> Either (Maybe CBORTermResult) ()
forall a b. (a -> b) -> a -> b
$ case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
ctrl of
    Literal (Value (VUInt Word64
i') Comment
_) -> Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i'
    Literal (Value (VNInt Word64
i') Comment
_) -> Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== -Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i'
    Literal (Value (VBignum Integer
i') Comment
_) -> Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
i'
    Rule
_ -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"
controlInteger CTreeRoot ValidatorStage
cddl Integer
i CtlOp
Ne Rule
ctrl =
  Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> Bool -> Either (Maybe CBORTermResult) ()
forall a b. (a -> b) -> a -> b
$ case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
ctrl of
    Literal (Value (VUInt Word64
i') Comment
_) -> Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i'
    Literal (Value (VNInt Word64
i') Comment
_) -> Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= -Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i'
    Literal (Value (VBignum Integer
i') Comment
_) -> Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
i'
    Rule
_ -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"
controlInteger CTreeRoot ValidatorStage
_ Integer
_ CtlOp
_ Rule
_ = [Char] -> Either (Maybe CBORTermResult) ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"

--------------------------------------------------------------------------------
-- Floating point (Float16, Float32, Float64)
--
-- As opposed to Integral types, there seems to be no ambiguity when encoding
-- and decoding floating-point numbers.

-- | Validating a `Float16`
validateHalf :: HasCallStack => CDDL -> Float -> Rule -> CDDLResult
validateHalf :: HasCallStack =>
CTreeRoot ValidatorStage -> Float -> Rule -> CDDLResult
validateHalf CTreeRoot ValidatorStage
cddl Float
f Rule
rule =
  case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
rule of
    -- a = any
    Postlude PTerm
PTAny -> Rule -> CDDLResult
Valid Rule
rule
    -- a = float16
    Postlude PTerm
PTHalf -> Rule -> CDDLResult
Valid Rule
rule
    -- a = 0.5
    Literal (Value (VFloat16 Float
f') Comment
_) -> Bool -> Rule -> CDDLResult
check (Float
f Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
f') Rule
rule
    -- a = foo / bar
    Choice NonEmpty Rule
opts -> (Rule -> CDDLResult) -> NonEmpty Rule -> Rule -> CDDLResult
validateChoice (HasCallStack =>
CTreeRoot ValidatorStage -> Float -> Rule -> CDDLResult
CTreeRoot ValidatorStage -> Float -> Rule -> CDDLResult
validateHalf CTreeRoot ValidatorStage
cddl Float
f) NonEmpty Rule
opts Rule
rule
    -- a = foo .ctrl bar
    Control CtlOp
op Rule
tgt Rule
ctrl -> (Rule -> CDDLResult)
-> CtlOp
-> Rule
-> Rule
-> (CtlOp -> Rule -> Either (Maybe CBORTermResult) ())
-> Rule
-> CDDLResult
ctrlDispatch (HasCallStack =>
CTreeRoot ValidatorStage -> Float -> Rule -> CDDLResult
CTreeRoot ValidatorStage -> Float -> Rule -> CDDLResult
validateHalf CTreeRoot ValidatorStage
cddl Float
f) CtlOp
op Rule
tgt Rule
ctrl (HasCallStack =>
CTreeRoot ValidatorStage
-> Float -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
CTreeRoot ValidatorStage
-> Float -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
controlHalf CTreeRoot ValidatorStage
cddl Float
f) Rule
rule
    -- a = x..y
    Range Rule
low Rule
high RangeBound
bound ->
      Bool -> Rule -> CDDLResult
check
        ( case (CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
low, CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
high) of
            (Literal (Value (VFloat16 Float
n) Comment
_), Literal (Value (VFloat16 Float
m) Comment
_)) -> Float
n Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
f Bool -> Bool -> Bool
&& RangeBound -> Float -> Float -> Bool
forall a. Ord a => RangeBound -> a -> a -> Bool
range RangeBound
bound Float
f Float
m
            (Rule, Rule)
_ -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"
        )
        Rule
rule
    Rule
_ -> [Char] -> Rule -> CDDLResult
UnapplicableRule [Char]
"validateHalf" Rule
rule

-- | Controls for `Float16`
controlHalf :: HasCallStack => CDDL -> Float -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
controlHalf :: HasCallStack =>
CTreeRoot ValidatorStage
-> Float -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
controlHalf CTreeRoot ValidatorStage
cddl Float
f CtlOp
Eq Rule
ctrl =
  Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> Bool -> Either (Maybe CBORTermResult) ()
forall a b. (a -> b) -> a -> b
$ case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
ctrl of
    Literal (Value (VFloat16 Float
f') Comment
_) -> Float
f Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
f'
    Rule
_ -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"
controlHalf CTreeRoot ValidatorStage
cddl Float
f CtlOp
Ne Rule
ctrl =
  Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> Bool -> Either (Maybe CBORTermResult) ()
forall a b. (a -> b) -> a -> b
$ case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
ctrl of
    Literal (Value (VFloat16 Float
f') Comment
_) -> Float
f Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
/= Float
f'
    Rule
_ -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"
controlHalf CTreeRoot ValidatorStage
_ Float
_ CtlOp
_ Rule
_ = [Char] -> Either (Maybe CBORTermResult) ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"

-- | Validating a `Float32`
validateFloat :: HasCallStack => CDDL -> Float -> Rule -> CDDLResult
validateFloat :: HasCallStack =>
CTreeRoot ValidatorStage -> Float -> Rule -> CDDLResult
validateFloat CTreeRoot ValidatorStage
cddl Float
f Rule
rule =
  ((Rule -> CDDLResult) -> Rule -> CDDLResult
forall a b. (a -> b) -> a -> b
$ Rule
rule) ((Rule -> CDDLResult) -> CDDLResult)
-> (Rule -> CDDLResult) -> CDDLResult
forall a b. (a -> b) -> a -> b
$ do
    case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
rule of
      -- a = any
      Postlude PTerm
PTAny -> Rule -> CDDLResult
Valid
      -- a = float32
      Postlude PTerm
PTFloat -> Rule -> CDDLResult
Valid
      -- a = 0.000000005
      -- TODO: it is unclear if smaller floats should also validate
      Literal (Value (VFloat32 Float
f') Comment
_) -> Bool -> Rule -> CDDLResult
check (Bool -> Rule -> CDDLResult) -> Bool -> Rule -> CDDLResult
forall a b. (a -> b) -> a -> b
$ Float
f Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
f'
      -- a = foo / bar
      Choice NonEmpty Rule
opts -> (Rule -> CDDLResult) -> NonEmpty Rule -> Rule -> CDDLResult
validateChoice (HasCallStack =>
CTreeRoot ValidatorStage -> Float -> Rule -> CDDLResult
CTreeRoot ValidatorStage -> Float -> Rule -> CDDLResult
validateFloat CTreeRoot ValidatorStage
cddl Float
f) NonEmpty Rule
opts
      -- a = foo .ctrl bar
      Control CtlOp
op Rule
tgt Rule
ctrl -> (Rule -> CDDLResult)
-> CtlOp
-> Rule
-> Rule
-> (CtlOp -> Rule -> Either (Maybe CBORTermResult) ())
-> Rule
-> CDDLResult
ctrlDispatch (HasCallStack =>
CTreeRoot ValidatorStage -> Float -> Rule -> CDDLResult
CTreeRoot ValidatorStage -> Float -> Rule -> CDDLResult
validateFloat CTreeRoot ValidatorStage
cddl Float
f) CtlOp
op Rule
tgt Rule
ctrl (HasCallStack =>
CTreeRoot ValidatorStage
-> Float -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
CTreeRoot ValidatorStage
-> Float -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
controlFloat CTreeRoot ValidatorStage
cddl Float
f)
      -- a = x..y
      -- TODO it is unclear if this should mix floating point types too
      Range Rule
low Rule
high RangeBound
bound ->
        Bool -> Rule -> CDDLResult
check (Bool -> Rule -> CDDLResult) -> Bool -> Rule -> CDDLResult
forall a b. (a -> b) -> a -> b
$ case (CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
low, CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
high) of
          (Literal (Value (VFloat16 Float
n) Comment
_), Literal (Value (VFloat16 Float
m) Comment
_)) -> Float
n Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
f Bool -> Bool -> Bool
&& RangeBound -> Float -> Float -> Bool
forall a. Ord a => RangeBound -> a -> a -> Bool
range RangeBound
bound Float
f Float
m
          (Literal (Value (VFloat32 Float
n) Comment
_), Literal (Value (VFloat32 Float
m) Comment
_)) -> Float
n Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
f Bool -> Bool -> Bool
&& RangeBound -> Float -> Float -> Bool
forall a. Ord a => RangeBound -> a -> a -> Bool
range RangeBound
bound Float
f Float
m
          (Rule, Rule)
_ -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"
      Rule
_ -> [Char] -> Rule -> CDDLResult
UnapplicableRule [Char]
"validateFloat"

-- | Controls for `Float32`
controlFloat :: HasCallStack => CDDL -> Float -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
controlFloat :: HasCallStack =>
CTreeRoot ValidatorStage
-> Float -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
controlFloat CTreeRoot ValidatorStage
cddl Float
f CtlOp
Eq Rule
ctrl =
  Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> Bool -> Either (Maybe CBORTermResult) ()
forall a b. (a -> b) -> a -> b
$ case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
ctrl of
    Literal (Value (VFloat16 Float
f') Comment
_) -> Float
f Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
f'
    Literal (Value (VFloat32 Float
f') Comment
_) -> Float
f Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
f'
    Rule
_ -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"
controlFloat CTreeRoot ValidatorStage
cddl Float
f CtlOp
Ne Rule
ctrl =
  Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> Bool -> Either (Maybe CBORTermResult) ()
forall a b. (a -> b) -> a -> b
$ case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
ctrl of
    Literal (Value (VFloat16 Float
f') Comment
_) -> Float
f Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
/= Float
f'
    Literal (Value (VFloat32 Float
f') Comment
_) -> Float
f Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
/= Float
f'
    Rule
_ -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"
controlFloat CTreeRoot ValidatorStage
_ Float
_ CtlOp
_ Rule
_ = [Char] -> Either (Maybe CBORTermResult) ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"

-- | Validating a `Float64`
validateDouble :: HasCallStack => CDDL -> Double -> Rule -> CDDLResult
validateDouble :: HasCallStack =>
CTreeRoot ValidatorStage -> Double -> Rule -> CDDLResult
validateDouble CTreeRoot ValidatorStage
cddl Double
f Rule
rule =
  ((Rule -> CDDLResult) -> Rule -> CDDLResult
forall a b. (a -> b) -> a -> b
$ Rule
rule) ((Rule -> CDDLResult) -> CDDLResult)
-> (Rule -> CDDLResult) -> CDDLResult
forall a b. (a -> b) -> a -> b
$ do
    case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
rule of
      -- a = any
      Postlude PTerm
PTAny -> Rule -> CDDLResult
Valid
      -- a = float64
      Postlude PTerm
PTDouble -> Rule -> CDDLResult
Valid
      -- a = 0.0000000000000000000000000000000000000000000005
      -- TODO: it is unclear if smaller floats should also validate
      Literal (Value (VFloat64 Double
f') Comment
_) -> Bool -> Rule -> CDDLResult
check (Bool -> Rule -> CDDLResult) -> Bool -> Rule -> CDDLResult
forall a b. (a -> b) -> a -> b
$ Double
f Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
f'
      -- a = foo / bar
      Choice NonEmpty Rule
opts -> (Rule -> CDDLResult) -> NonEmpty Rule -> Rule -> CDDLResult
validateChoice (HasCallStack =>
CTreeRoot ValidatorStage -> Double -> Rule -> CDDLResult
CTreeRoot ValidatorStage -> Double -> Rule -> CDDLResult
validateDouble CTreeRoot ValidatorStage
cddl Double
f) NonEmpty Rule
opts
      -- a = foo .ctrl bar
      Control CtlOp
op Rule
tgt Rule
ctrl -> (Rule -> CDDLResult)
-> CtlOp
-> Rule
-> Rule
-> (CtlOp -> Rule -> Either (Maybe CBORTermResult) ())
-> Rule
-> CDDLResult
ctrlDispatch (HasCallStack =>
CTreeRoot ValidatorStage -> Double -> Rule -> CDDLResult
CTreeRoot ValidatorStage -> Double -> Rule -> CDDLResult
validateDouble CTreeRoot ValidatorStage
cddl Double
f) CtlOp
op Rule
tgt Rule
ctrl (HasCallStack =>
CTreeRoot ValidatorStage
-> Double -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
CTreeRoot ValidatorStage
-> Double -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
controlDouble CTreeRoot ValidatorStage
cddl Double
f)
      -- a = x..y
      -- TODO it is unclear if this should mix floating point types too
      Range Rule
low Rule
high RangeBound
bound ->
        Bool -> Rule -> CDDLResult
check (Bool -> Rule -> CDDLResult) -> Bool -> Rule -> CDDLResult
forall a b. (a -> b) -> a -> b
$ case (CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
low, CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
high) of
          (Literal (Value (VFloat16 (Float -> Double
float2Double -> Double
n)) Comment
_), Literal (Value (VFloat16 (Float -> Double
float2Double -> Double
m)) Comment
_)) -> Double
n Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
f Bool -> Bool -> Bool
&& RangeBound -> Double -> Double -> Bool
forall a. Ord a => RangeBound -> a -> a -> Bool
range RangeBound
bound Double
f Double
m
          (Literal (Value (VFloat32 (Float -> Double
float2Double -> Double
n)) Comment
_), Literal (Value (VFloat32 (Float -> Double
float2Double -> Double
m)) Comment
_)) -> Double
n Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
f Bool -> Bool -> Bool
&& RangeBound -> Double -> Double -> Bool
forall a. Ord a => RangeBound -> a -> a -> Bool
range RangeBound
bound Double
f Double
m
          (Literal (Value (VFloat64 Double
n) Comment
_), Literal (Value (VFloat64 Double
m) Comment
_)) -> Double
n Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
f Bool -> Bool -> Bool
&& RangeBound -> Double -> Double -> Bool
forall a. Ord a => RangeBound -> a -> a -> Bool
range RangeBound
bound Double
f Double
m
          (Rule, Rule)
_ -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"
      Rule
_ -> [Char] -> Rule -> CDDLResult
UnapplicableRule [Char]
"validateDouble"

-- | Controls for `Float64`
controlDouble :: HasCallStack => CDDL -> Double -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
controlDouble :: HasCallStack =>
CTreeRoot ValidatorStage
-> Double -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
controlDouble CTreeRoot ValidatorStage
cddl Double
f CtlOp
Eq Rule
ctrl =
  Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> Bool -> Either (Maybe CBORTermResult) ()
forall a b. (a -> b) -> a -> b
$ case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
ctrl of
    Literal (Value (VFloat16 Float
f') Comment
_) -> Double
f Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Float -> Double
float2Double Float
f'
    Literal (Value (VFloat32 Float
f') Comment
_) -> Double
f Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Float -> Double
float2Double Float
f'
    Literal (Value (VFloat64 Double
f') Comment
_) -> Double
f Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
f'
    Rule
_ -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"
controlDouble CTreeRoot ValidatorStage
cddl Double
f CtlOp
Ne Rule
ctrl =
  Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> Bool -> Either (Maybe CBORTermResult) ()
forall a b. (a -> b) -> a -> b
$ case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
ctrl of
    Literal (Value (VFloat16 Float
f') Comment
_) -> Double
f Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Float -> Double
float2Double Float
f'
    Literal (Value (VFloat32 Float
f') Comment
_) -> Double
f Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Float -> Double
float2Double Float
f'
    Literal (Value (VFloat64 Double
f') Comment
_) -> Double
f Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
f'
    Rule
_ -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"
controlDouble CTreeRoot ValidatorStage
_ Double
_ CtlOp
_ Rule
_ = [Char] -> Either (Maybe CBORTermResult) ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implmented"

--------------------------------------------------------------------------------
-- Bool

-- | Validating a boolean
validateBool :: CDDL -> Bool -> Rule -> CDDLResult
validateBool :: CTreeRoot ValidatorStage -> Bool -> Rule -> CDDLResult
validateBool CTreeRoot ValidatorStage
cddl Bool
b Rule
rule =
  ((Rule -> CDDLResult) -> Rule -> CDDLResult
forall a b. (a -> b) -> a -> b
$ Rule
rule) ((Rule -> CDDLResult) -> CDDLResult)
-> (Rule -> CDDLResult) -> CDDLResult
forall a b. (a -> b) -> a -> b
$ do
    case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
rule of
      -- a = any
      Postlude PTerm
PTAny -> Rule -> CDDLResult
Valid
      -- a = bool
      Postlude PTerm
PTBool -> Rule -> CDDLResult
Valid
      -- a = true
      Literal (Value (VBool Bool
b') Comment
_) -> Bool -> Rule -> CDDLResult
check (Bool -> Rule -> CDDLResult) -> Bool -> Rule -> CDDLResult
forall a b. (a -> b) -> a -> b
$ Bool
b Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
b'
      -- a = foo .ctrl bar
      Control CtlOp
op Rule
tgt Rule
ctrl -> (Rule -> CDDLResult)
-> CtlOp
-> Rule
-> Rule
-> (CtlOp -> Rule -> Either (Maybe CBORTermResult) ())
-> Rule
-> CDDLResult
ctrlDispatch (CTreeRoot ValidatorStage -> Bool -> Rule -> CDDLResult
validateBool CTreeRoot ValidatorStage
cddl Bool
b) CtlOp
op Rule
tgt Rule
ctrl (HasCallStack =>
CTreeRoot ValidatorStage
-> Bool -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
CTreeRoot ValidatorStage
-> Bool -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
controlBool CTreeRoot ValidatorStage
cddl Bool
b)
      -- a = foo / bar
      Choice NonEmpty Rule
opts -> (Rule -> CDDLResult) -> NonEmpty Rule -> Rule -> CDDLResult
validateChoice (CTreeRoot ValidatorStage -> Bool -> Rule -> CDDLResult
validateBool CTreeRoot ValidatorStage
cddl Bool
b) NonEmpty Rule
opts
      Rule
_ -> [Char] -> Rule -> CDDLResult
UnapplicableRule [Char]
"validateBool"

-- | Controls for `Bool`
controlBool :: HasCallStack => CDDL -> Bool -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
controlBool :: HasCallStack =>
CTreeRoot ValidatorStage
-> Bool -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
controlBool CTreeRoot ValidatorStage
cddl Bool
b CtlOp
Eq Rule
ctrl =
  Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> Bool -> Either (Maybe CBORTermResult) ()
forall a b. (a -> b) -> a -> b
$ case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
ctrl of
    Literal (Value (VBool Bool
b') Comment
_) -> Bool
b Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
b'
    Rule
_ -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"
controlBool CTreeRoot ValidatorStage
cddl Bool
b CtlOp
Ne Rule
ctrl =
  Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> Bool -> Either (Maybe CBORTermResult) ()
forall a b. (a -> b) -> a -> b
$ case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
ctrl of
    Literal (Value (VBool Bool
b') Comment
_) -> Bool
b Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool
b'
    Rule
_ -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"
controlBool CTreeRoot ValidatorStage
_ Bool
_ CtlOp
_ Rule
_ = [Char] -> Either (Maybe CBORTermResult) ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"

--------------------------------------------------------------------------------
-- Simple

-- | Validating a `TSimple`. It is unclear if this is used for anything else than undefined.
validateSimple :: CDDL -> Word8 -> Rule -> CDDLResult
validateSimple :: CTreeRoot ValidatorStage -> Word8 -> Rule -> CDDLResult
validateSimple CTreeRoot ValidatorStage
cddl Word8
23 Rule
rule =
  do
    case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
rule of
      -- a = any
      Postlude PTerm
PTAny -> Rule -> CDDLResult
Valid Rule
rule
      -- a = undefined
      Postlude PTerm
PTUndefined -> Rule -> CDDLResult
Valid Rule
rule
      -- a = foo / bar
      Choice NonEmpty Rule
opts -> (Rule -> CDDLResult) -> NonEmpty Rule -> Rule -> CDDLResult
validateChoice (CTreeRoot ValidatorStage -> Word8 -> Rule -> CDDLResult
validateSimple CTreeRoot ValidatorStage
cddl Word8
23) NonEmpty Rule
opts Rule
rule
      Rule
_ -> [Char] -> Rule -> CDDLResult
UnapplicableRule [Char]
"validateSimple" Rule
rule
validateSimple CTreeRoot ValidatorStage
_ Word8
n Rule
_ = [Char] -> CDDLResult
forall a. HasCallStack => [Char] -> a
error ([Char] -> CDDLResult) -> [Char] -> CDDLResult
forall a b. (a -> b) -> a -> b
$ [Char]
"Found simple different to 23! please report this somewhere! Found: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word8 -> [Char]
forall a. Show a => a -> [Char]
show Word8
n

--------------------------------------------------------------------------------
-- Null/nil

-- | Validating nil
validateNull :: CDDL -> Rule -> CDDLResult
validateNull :: CTreeRoot ValidatorStage -> Rule -> CDDLResult
validateNull CTreeRoot ValidatorStage
cddl Rule
rule =
  case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
rule of
    -- a = any
    Postlude PTerm
PTAny -> Rule -> CDDLResult
Valid Rule
rule
    -- a = nil
    Postlude PTerm
PTNil -> Rule -> CDDLResult
Valid Rule
rule
    Choice NonEmpty Rule
opts -> (Rule -> CDDLResult) -> NonEmpty Rule -> Rule -> CDDLResult
validateChoice (CTreeRoot ValidatorStage -> Rule -> CDDLResult
validateNull CTreeRoot ValidatorStage
cddl) NonEmpty Rule
opts Rule
rule
    Rule
_ -> [Char] -> Rule -> CDDLResult
UnapplicableRule [Char]
"validateNull" Rule
rule

--------------------------------------------------------------------------------
-- Bytes

-- | Validating a byte sequence
validateBytes :: CDDL -> BS.ByteString -> Rule -> CDDLResult
validateBytes :: CTreeRoot ValidatorStage -> ByteString -> Rule -> CDDLResult
validateBytes CTreeRoot ValidatorStage
cddl ByteString
bs Rule
rule =
  case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
rule of
    -- a = any
    Postlude PTerm
PTAny -> Rule -> CDDLResult
Valid Rule
rule
    -- a = bytes
    Postlude PTerm
PTBytes -> Rule -> CDDLResult
Valid Rule
rule
    -- a = h'123456'
    Literal (Value (VBytes ByteString
bs') Comment
_) -> Bool -> Rule -> CDDLResult
check (ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
bs') Rule
rule
    -- a = foo .ctrl bar
    Control CtlOp
op Rule
tgt Rule
ctrl -> (Rule -> CDDLResult)
-> CtlOp
-> Rule
-> Rule
-> (CtlOp -> Rule -> Either (Maybe CBORTermResult) ())
-> Rule
-> CDDLResult
ctrlDispatch (CTreeRoot ValidatorStage -> ByteString -> Rule -> CDDLResult
validateBytes CTreeRoot ValidatorStage
cddl ByteString
bs) CtlOp
op Rule
tgt Rule
ctrl (HasCallStack =>
CTreeRoot ValidatorStage
-> ByteString -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
CTreeRoot ValidatorStage
-> ByteString -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
controlBytes CTreeRoot ValidatorStage
cddl ByteString
bs) Rule
rule
    -- a = foo / bar
    Choice NonEmpty Rule
opts -> (Rule -> CDDLResult) -> NonEmpty Rule -> Rule -> CDDLResult
validateChoice (CTreeRoot ValidatorStage -> ByteString -> Rule -> CDDLResult
validateBytes CTreeRoot ValidatorStage
cddl ByteString
bs) NonEmpty Rule
opts Rule
rule
    Rule
_ -> [Char] -> Rule -> CDDLResult
UnapplicableRule [Char]
"validateBytes" Rule
rule

-- | Controls for byte strings
controlBytes ::
  HasCallStack =>
  CDDL ->
  BS.ByteString ->
  CtlOp ->
  Rule ->
  Either (Maybe CBORTermResult) ()
controlBytes :: HasCallStack =>
CTreeRoot ValidatorStage
-> ByteString -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
controlBytes CTreeRoot ValidatorStage
cddl ByteString
bs CtlOp
Size Rule
ctrl =
  case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
ctrl of
    Literal (Value (VUInt (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
sz)) Comment
_) -> Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> Bool -> Either (Maybe CBORTermResult) ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
sz
    Range Rule
low Rule
high RangeBound
bound ->
      let i :: Int
i = ByteString -> Int
BS.length ByteString
bs
       in Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> Bool -> Either (Maybe CBORTermResult) ()
forall a b. (a -> b) -> a -> b
$ case (CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
low, CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
high) of
            (Literal (Value (VUInt (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
n)) Comment
_), Literal (Value (VUInt (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
m)) Comment
_)) -> Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i Bool -> Bool -> Bool
&& RangeBound -> Int -> Int -> Bool
forall a. Ord a => RangeBound -> a -> a -> Bool
range RangeBound
bound Int
i Int
m
            (Literal (Value (VNInt (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
n)) Comment
_), Literal (Value (VUInt (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
m)) Comment
_)) -> -Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i Bool -> Bool -> Bool
&& RangeBound -> Int -> Int -> Bool
forall a. Ord a => RangeBound -> a -> a -> Bool
range RangeBound
bound Int
i Int
m
            (Literal (Value (VNInt (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
n)) Comment
_), Literal (Value (VNInt (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
m)) Comment
_)) -> -Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i Bool -> Bool -> Bool
&& RangeBound -> Int -> Int -> Bool
forall a. Ord a => RangeBound -> a -> a -> Bool
range RangeBound
bound Int
i (-Int
m)
            (Literal (Value VUInt {} Comment
_), Literal (Value VNInt {} Comment
_)) -> Bool
False
            (Rule, Rule)
_ -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"
    Rule
_ -> [Char] -> Either (Maybe CBORTermResult) ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"
controlBytes CTreeRoot ValidatorStage
cddl ByteString
bs CtlOp
Bits Rule
ctrl = do
  let
    indices :: [Word64]
indices =
      case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
ctrl of
        Literal (Value (VUInt Word64
i') Comment
_) -> [Word64
i']
        Choice NonEmpty Rule
nodes -> CTreeRoot ValidatorStage -> NonEmpty Rule -> [Word64]
getIndicesOfChoice CTreeRoot ValidatorStage
cddl NonEmpty Rule
nodes
        Range Rule
ff Rule
tt RangeBound
incl -> CTreeRoot ValidatorStage -> Rule -> Rule -> RangeBound -> [Word64]
getIndicesOfRange CTreeRoot ValidatorStage
cddl Rule
ff Rule
tt RangeBound
incl
        Enum Rule
g -> CTreeRoot ValidatorStage -> Rule -> [Word64]
getIndicesOfEnum CTreeRoot ValidatorStage
cddl Rule
g
        Rule
_ -> [Char] -> [Word64]
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"
  Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> Bool -> Either (Maybe CBORTermResult) ()
forall a b. (a -> b) -> a -> b
$ [Int] -> Bool
bitsControlCheck ((Word64 -> Int) -> [Word64] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Word64]
indices)
  where
    bitsControlCheck :: [Int] -> Bool
    bitsControlCheck :: [Int] -> Bool
bitsControlCheck [Int]
allowedBits =
      let allowedSet :: IntSet
allowedSet = [Int] -> IntSet
IS.fromList [Int]
allowedBits
          totalBits :: Int
totalBits = ByteString -> Int
BS.length ByteString
bs Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8
          isAllowedBit :: Int -> Bool
isAllowedBit Int
n =
            let byteIndex :: Int
byteIndex = Int
n Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
3
                bitIndex :: Int
bitIndex = Int
n Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
7
             in case ByteString -> Int -> Maybe Word8
BS.indexMaybe ByteString
bs Int
byteIndex of
                  Just Word8
byte -> Bool -> Bool
not (Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
byte Int
bitIndex) Bool -> Bool -> Bool
|| Int -> IntSet -> Bool
IS.member Int
n IntSet
allowedSet
                  Maybe Word8
Nothing -> Bool
True
       in (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Int -> Bool
isAllowedBit [Int
0 .. Int
totalBits Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
controlBytes CTreeRoot ValidatorStage
cddl ByteString
bs CtlOp
Cbor Rule
ctrl =
  case (forall s. Decoder s Term)
-> ByteString -> Either DeserialiseFailure (ByteString, Term)
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
deserialiseFromBytes Decoder s Term
forall s. Decoder s Term
decodeTerm (ByteString -> ByteString
BSL.fromStrict ByteString
bs) of
    Right (ByteString -> Bool
BSL.null -> Bool
True, Term
term) ->
      case CTreeRoot ValidatorStage -> Term -> Rule -> CBORTermResult
validateTerm CTreeRoot ValidatorStage
cddl Term
term Rule
ctrl of
        CBORTermResult Term
_ (Valid Rule
_) -> () -> Either (Maybe CBORTermResult) ()
forall a b. b -> Either a b
Right ()
        CBORTermResult
err -> Maybe CBORTermResult -> Either (Maybe CBORTermResult) ()
forall a b. a -> Either a b
Left (Maybe CBORTermResult -> Either (Maybe CBORTermResult) ())
-> Maybe CBORTermResult -> Either (Maybe CBORTermResult) ()
forall a b. (a -> b) -> a -> b
$ CBORTermResult -> Maybe CBORTermResult
forall a. a -> Maybe a
Just CBORTermResult
err
    Either DeserialiseFailure (ByteString, Term)
_ -> [Char] -> Either (Maybe CBORTermResult) ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"
controlBytes CTreeRoot ValidatorStage
cddl ByteString
bs CtlOp
Cborseq Rule
ctrl =
  case (forall s. Decoder s Term)
-> ByteString -> Either DeserialiseFailure (ByteString, Term)
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
deserialiseFromBytes Decoder s Term
forall s. Decoder s Term
decodeTerm (ByteString -> ByteString
BSL.fromStrict (ByteString -> Word8 -> ByteString
BS.snoc (Word8 -> ByteString -> ByteString
BS.cons Word8
0x9f ByteString
bs) Word8
0xff)) of
    Right (ByteString -> Bool
BSL.null -> Bool
True, TListI [Term]
terms) ->
      case CTreeRoot ValidatorStage -> Term -> Rule -> CBORTermResult
validateTerm CTreeRoot ValidatorStage
cddl ([Term] -> Term
TList [Term]
terms) ([Rule] -> Rule
forall i. [CTree i] -> CTree i
Array [Rule -> OccurrenceIndicator -> Rule
forall i. CTree i -> OccurrenceIndicator -> CTree i
Occur Rule
ctrl OccurrenceIndicator
OIZeroOrMore]) of
        CBORTermResult Term
_ (Valid Rule
_) -> () -> Either (Maybe CBORTermResult) ()
forall a b. b -> Either a b
Right ()
        CBORTermResult Term
_ CDDLResult
err -> [Char] -> Either (Maybe CBORTermResult) ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> Either (Maybe CBORTermResult) ())
-> [Char] -> Either (Maybe CBORTermResult) ()
forall a b. (a -> b) -> a -> b
$ CDDLResult -> [Char]
forall a. Show a => a -> [Char]
show CDDLResult
err
    Either DeserialiseFailure (ByteString, Term)
_ -> [Char] -> Either (Maybe CBORTermResult) ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"
controlBytes CTreeRoot ValidatorStage
_ ByteString
_ CtlOp
_ Rule
_ = [Char] -> Either (Maybe CBORTermResult) ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implmented"

--------------------------------------------------------------------------------
-- Text

-- | Validating text strings
validateText :: CDDL -> T.Text -> Rule -> CDDLResult
validateText :: CTreeRoot ValidatorStage -> Text -> Rule -> CDDLResult
validateText CTreeRoot ValidatorStage
cddl Text
txt Rule
rule =
  case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
rule of
    -- a = any
    Postlude PTerm
PTAny -> Rule -> CDDLResult
Valid Rule
rule
    -- a = text
    Postlude PTerm
PTText -> Rule -> CDDLResult
Valid Rule
rule
    -- a = "foo"
    Literal (Value (VText Text
txt') Comment
_) -> Bool -> Rule -> CDDLResult
check (Text
txt Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
txt') Rule
rule
    -- a = foo .ctrl bar
    Control CtlOp
op Rule
tgt Rule
ctrl -> (Rule -> CDDLResult)
-> CtlOp
-> Rule
-> Rule
-> (CtlOp -> Rule -> Either (Maybe CBORTermResult) ())
-> Rule
-> CDDLResult
ctrlDispatch (CTreeRoot ValidatorStage -> Text -> Rule -> CDDLResult
validateText CTreeRoot ValidatorStage
cddl Text
txt) CtlOp
op Rule
tgt Rule
ctrl (HasCallStack =>
CTreeRoot ValidatorStage
-> Text -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
CTreeRoot ValidatorStage
-> Text -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
controlText CTreeRoot ValidatorStage
cddl Text
txt) Rule
rule
    -- a = foo / bar
    Choice NonEmpty Rule
opts -> (Rule -> CDDLResult) -> NonEmpty Rule -> Rule -> CDDLResult
validateChoice (CTreeRoot ValidatorStage -> Text -> Rule -> CDDLResult
validateText CTreeRoot ValidatorStage
cddl Text
txt) NonEmpty Rule
opts Rule
rule
    Rule
_ -> [Char] -> Rule -> CDDLResult
UnapplicableRule [Char]
"validateText" Rule
rule

-- | Controls for text strings
controlText :: HasCallStack => CDDL -> T.Text -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
controlText :: HasCallStack =>
CTreeRoot ValidatorStage
-> Text -> CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
controlText CTreeRoot ValidatorStage
cddl Text
bs CtlOp
Size Rule
ctrl =
  case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
ctrl of
    Literal (Value (VUInt (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
sz)) Comment
_) -> Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> Bool -> Either (Maybe CBORTermResult) ()
forall a b. (a -> b) -> a -> b
$ Text -> Int
T.length Text
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
sz
    Range Rule
ff Rule
tt RangeBound
bound ->
      Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> Bool -> Either (Maybe CBORTermResult) ()
forall a b. (a -> b) -> a -> b
$ case (CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
ff, CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
tt) of
        (Literal (Value (VUInt (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
n)) Comment
_), Literal (Value (VUInt (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
m)) Comment
_)) -> Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Text -> Int
T.length Text
bs Bool -> Bool -> Bool
&& RangeBound -> Int -> Int -> Bool
forall a. Ord a => RangeBound -> a -> a -> Bool
range RangeBound
bound (Text -> Int
T.length Text
bs) Int
m
        (Literal (Value (VNInt (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
n)) Comment
_), Literal (Value (VUInt (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
m)) Comment
_)) -> -Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Text -> Int
T.length Text
bs Bool -> Bool -> Bool
&& RangeBound -> Int -> Int -> Bool
forall a. Ord a => RangeBound -> a -> a -> Bool
range RangeBound
bound (Text -> Int
T.length Text
bs) Int
m
        (Literal (Value (VNInt (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
n)) Comment
_), Literal (Value (VNInt (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
m)) Comment
_)) -> -Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Text -> Int
T.length Text
bs Bool -> Bool -> Bool
&& RangeBound -> Int -> Int -> Bool
forall a. Ord a => RangeBound -> a -> a -> Bool
range RangeBound
bound (Text -> Int
T.length Text
bs) (-Int
m)
        (Rule, Rule)
_ -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"
    Rule
_ -> [Char] -> Either (Maybe CBORTermResult) ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"
controlText CTreeRoot ValidatorStage
cddl Text
s CtlOp
Regexp Rule
ctrl =
  Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> Bool -> Either (Maybe CBORTermResult) ()
forall a b. (a -> b) -> a -> b
$ case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
ctrl of
    Literal (Value (VText Text
rxp) Comment
_) -> case Text
s Text -> Text -> (Text, Text, Text)
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ Text
rxp :: (T.Text, T.Text, T.Text) of
      (Text
"", Text
s', Text
"") -> Text
s Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
s'
      (Text, Text, Text)
_ -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"
    Rule
_ -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"
controlText CTreeRoot ValidatorStage
_ Text
_ CtlOp
_ Rule
_ = [Char] -> Either (Maybe CBORTermResult) ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"

--------------------------------------------------------------------------------
-- Tagged values

-- | Validating a `TTagged`
validateTagged :: CDDL -> Word64 -> Term -> Rule -> CDDLResult
validateTagged :: CTreeRoot ValidatorStage -> Word64 -> Term -> Rule -> CDDLResult
validateTagged CTreeRoot ValidatorStage
cddl Word64
tag Term
term Rule
rule =
  case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
rule of
    Postlude PTerm
PTAny -> Rule -> CDDLResult
Valid Rule
rule
    Tag Word64
tag' Rule
rule' ->
      -- If the tag does not match, this is a direct fail
      if Word64
tag Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
tag'
        then case CTreeRoot ValidatorStage -> Term -> Rule -> CBORTermResult
validateTerm CTreeRoot ValidatorStage
cddl Term
term Rule
rule' of
          CBORTermResult Term
_ (Valid Rule
_) -> Rule -> CDDLResult
Valid Rule
rule
          CBORTermResult
err -> Rule -> Either Word64 CBORTermResult -> CDDLResult
InvalidTagged Rule
rule (CBORTermResult -> Either Word64 CBORTermResult
forall a b. b -> Either a b
Right CBORTermResult
err)
        else Rule -> Either Word64 CBORTermResult -> CDDLResult
InvalidTagged Rule
rule (Word64 -> Either Word64 CBORTermResult
forall a b. a -> Either a b
Left Word64
tag)
    Choice NonEmpty Rule
opts -> (Rule -> CDDLResult) -> NonEmpty Rule -> Rule -> CDDLResult
validateChoice (CTreeRoot ValidatorStage -> Word64 -> Term -> Rule -> CDDLResult
validateTagged CTreeRoot ValidatorStage
cddl Word64
tag Term
term) NonEmpty Rule
opts Rule
rule
    Rule
_ -> [Char] -> Rule -> CDDLResult
UnapplicableRule [Char]
"validateTagged" Rule
rule

-- --------------------------------------------------------------------------------
-- -- Lists

isWithinBoundsInclusive :: Ord a => a -> Maybe a -> Maybe a -> Bool
isWithinBoundsInclusive :: forall a. Ord a => a -> Maybe a -> Maybe a -> Bool
isWithinBoundsInclusive a
x Maybe a
lb Maybe a
ub = Bool -> (a -> Bool) -> Maybe a -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (a
x >=) Maybe a
lb Bool -> Bool -> Bool
&& Bool -> (a -> Bool) -> Maybe a -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (a
x <=) Maybe a
ub

isOptional :: CTree i -> Bool
isOptional :: forall i. CTree i -> Bool
isOptional (Occur CTree i
_ OccurrenceIndicator
oi) = case OccurrenceIndicator
oi of
  OccurrenceIndicator
OIOptional -> Bool
True
  OccurrenceIndicator
OIZeroOrMore -> Bool
True
  OIBounded Maybe Word64
lb Maybe Word64
ub -> Word64 -> Maybe Word64 -> Maybe Word64 -> Bool
forall a. Ord a => a -> Maybe a -> Maybe a -> Bool
isWithinBoundsInclusive Word64
0 Maybe Word64
lb Maybe Word64
ub
  OccurrenceIndicator
_ -> Bool
False
isOptional CTree i
_ = Bool
False

decrementBounds :: Maybe Word64 -> Maybe Word64 -> OccurrenceIndicator
decrementBounds :: Maybe Word64 -> Maybe Word64 -> OccurrenceIndicator
decrementBounds Maybe Word64
lb Maybe Word64
ub = Maybe Word64 -> Maybe Word64 -> OccurrenceIndicator
OIBounded (Word64 -> Word64
forall {a}. (Eq a, Num a, Enum a) => a -> a
clampedPred (Word64 -> Word64) -> Maybe Word64 -> Maybe Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Word64
lb) (Word64 -> Word64
forall {a}. (Eq a, Num a, Enum a) => a -> a
clampedPred (Word64 -> Word64) -> Maybe Word64 -> Maybe Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Word64
ub)
  where
    clampedPred :: a -> a
clampedPred a
0 = a
0
    clampedPred a
x = a -> a
forall a. Enum a => a -> a
pred a
x

validateList :: CDDL -> [Term] -> Rule -> CDDLResult
validateList :: CTreeRoot ValidatorStage -> [Term] -> Rule -> CDDLResult
validateList CTreeRoot ValidatorStage
cddl [Term]
terms Rule
rule =
  case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
rule of
    Postlude PTerm
PTAny -> Rule -> CDDLResult
Valid Rule
rule
    Array [Rule]
rules -> [Term] -> [Rule] -> CDDLResult
validate [Term]
terms [Rule]
rules
    Choice NonEmpty Rule
opts -> (Rule -> CDDLResult) -> NonEmpty Rule -> Rule -> CDDLResult
validateChoice (CTreeRoot ValidatorStage -> [Term] -> Rule -> CDDLResult
validateList CTreeRoot ValidatorStage
cddl [Term]
terms) NonEmpty Rule
opts Rule
rule
    Rule
r -> [Char] -> Rule -> CDDLResult
UnapplicableRule [Char]
"validateList" Rule
r
  where
    validate :: [Term] -> [CTree ValidatorStage] -> CDDLResult
    validate :: [Term] -> [Rule] -> CDDLResult
validate [] [] = Rule -> CDDLResult
Valid Rule
rule
    validate [Term]
_ [] = Rule -> [[Rule]] -> [[(Rule, CBORTermResult)]] -> CDDLResult
ListExpansionFail Rule
rule [] []
    validate [] (Rule
r : [Rule]
rs)
      | Rule -> Bool
forall i. CTree i -> Bool
isOptional Rule
r = [Term] -> [Rule] -> CDDLResult
validate [] [Rule]
rs
      | Bool
otherwise = [Char] -> Rule -> CDDLResult
UnapplicableRule [Char]
"validateList" Rule
r
    validate (Term
t : [Term]
ts) (Rule
r : [Rule]
rs) = case Rule
r of
      Occur Rule
ct OccurrenceIndicator
oi -> case OccurrenceIndicator
oi of
        OccurrenceIndicator
OIOptional
          | (Valid {}, [Term]
leftover) <- [Term] -> Rule -> (CDDLResult, [Term])
validateTermInList (Term
t Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
: [Term]
ts) Rule
ct
          , res :: CDDLResult
res@Valid {} <- [Term] -> [Rule] -> CDDLResult
validate [Term]
leftover [Rule]
rs ->
              CDDLResult
res
          | Bool
otherwise -> [Term] -> [Rule] -> CDDLResult
validate (Term
t Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
: [Term]
ts) [Rule]
rs
        OccurrenceIndicator
OIZeroOrMore
          | (Valid {}, [Term]
leftover) <- [Term] -> Rule -> (CDDLResult, [Term])
validateTermInList (Term
t Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
: [Term]
ts) Rule
ct
          , res :: CDDLResult
res@Valid {} <- [Term] -> [Rule] -> CDDLResult
validate [Term]
leftover (Rule
r Rule -> [Rule] -> [Rule]
forall a. a -> [a] -> [a]
: [Rule]
rs) ->
              CDDLResult
res
          | Bool
otherwise -> [Term] -> [Rule] -> CDDLResult
validate (Term
t Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
: [Term]
ts) [Rule]
rs
        OccurrenceIndicator
OIOneOrMore -> case [Term] -> Rule -> (CDDLResult, [Term])
validateTermInList (Term
t Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
: [Term]
ts) Rule
ct of
          (Valid {}, [Term]
leftover) -> [Term] -> [Rule] -> CDDLResult
validate [Term]
leftover (Rule -> OccurrenceIndicator -> Rule
forall i. CTree i -> OccurrenceIndicator -> CTree i
Occur Rule
ct OccurrenceIndicator
OIZeroOrMore Rule -> [Rule] -> [Rule]
forall a. a -> [a] -> [a]
: [Rule]
rs)
          (CDDLResult
err, [Term]
_) -> CDDLResult
err
        OIBounded Maybe Word64
_ (Just Word64
ub) | Word64
ub Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
0 -> [Char] -> CDDLResult -> CDDLResult
forall a. [Char] -> a -> a
trace ([Char]
"out of bounds: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
ub) (CDDLResult -> CDDLResult) -> CDDLResult -> CDDLResult
forall a b. (a -> b) -> a -> b
$ Rule -> [[Rule]] -> [[(Rule, CBORTermResult)]] -> CDDLResult
ListExpansionFail Rule
rule [] []
        OIBounded Maybe Word64
lb Maybe Word64
ub
          | (Valid {}, [Term]
leftover) <- [Term] -> Rule -> (CDDLResult, [Term])
validateTermInList (Term
t Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
: [Term]
ts) Rule
ct ->
              [Term] -> [Rule] -> CDDLResult
validate [Term]
leftover (Rule -> OccurrenceIndicator -> Rule
forall i. CTree i -> OccurrenceIndicator -> CTree i
Occur Rule
ct (Maybe Word64 -> Maybe Word64 -> OccurrenceIndicator
decrementBounds Maybe Word64
lb Maybe Word64
ub) Rule -> [Rule] -> [Rule]
forall a. a -> [a] -> [a]
: [Rule]
rs)
          | Word64 -> Maybe Word64 -> Maybe Word64 -> Bool
forall a. Ord a => a -> Maybe a -> Maybe a -> Bool
isWithinBoundsInclusive Word64
0 Maybe Word64
lb Maybe Word64
ub ->
              [Term] -> [Rule] -> CDDLResult
validate (Term
t Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
: [Term]
ts) [Rule]
rs
          | Bool
otherwise -> [Char] -> CDDLResult -> CDDLResult
forall a. [Char] -> a -> a
trace [Char]
"foo" (CDDLResult -> CDDLResult) -> CDDLResult -> CDDLResult
forall a b. (a -> b) -> a -> b
$ [Char] -> Rule -> CDDLResult
UnapplicableRule [Char]
"validateList" Rule
r
      Rule
_ -> case [Term] -> Rule -> (CDDLResult, [Term])
validateTermInList (Term
t Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
: [Term]
ts) (CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
r) of
        (Valid {}, [Term]
leftover) -> [Term] -> [Rule] -> CDDLResult
validate [Term]
leftover [Rule]
rs
        (CDDLResult
err, [Term]
_) -> CDDLResult
err

    validateTermInList :: [Term] -> Rule -> (CDDLResult, [Term])
validateTermInList [Term]
ts (KV Rule
_ Rule
v Bool
_) = [Term] -> Rule -> (CDDLResult, [Term])
validateTermInList [Term]
ts Rule
v
    validateTermInList [Term]
ts (Group [Rule]
grp) = case [Rule]
grp of
      (CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl -> Rule
g) : [Rule]
gs
        | (Valid {}, [Term]
leftover) <- [Term] -> Rule -> (CDDLResult, [Term])
validateTermInList [Term]
ts Rule
g -> [Term] -> Rule -> (CDDLResult, [Term])
validateTermInList [Term]
leftover ([Rule] -> Rule
forall i. [CTree i] -> CTree i
Group [Rule]
gs)
        | Bool
otherwise -> ([Char] -> Rule -> CDDLResult
UnapplicableRule [Char]
"validateTermInList group" Rule
g, [Term]
ts)
      [] -> (Rule -> CDDLResult
Valid Rule
rule, [Term]
ts)
    validateTermInList (Term
t : [Term]
ts) Rule
r =
      let CBORTermResult Term
_ CDDLResult
res = CTreeRoot ValidatorStage -> Term -> Rule -> CBORTermResult
validateTerm CTreeRoot ValidatorStage
cddl Term
t Rule
r
       in (CDDLResult
res, [Term]
ts)
    validateTermInList [] Rule
g = ([Term] -> [Rule] -> CDDLResult
validate [] [Rule
g], [])

--------------------------------------------------------------------------------
-- Maps

validateMap :: CDDL -> [(Term, Term)] -> Rule -> CDDLResult
validateMap :: CTreeRoot ValidatorStage -> [(Term, Term)] -> Rule -> CDDLResult
validateMap CTreeRoot ValidatorStage
cddl [(Term, Term)]
terms Rule
rule =
  case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
rule of
    Postlude PTerm
PTAny -> Rule -> CDDLResult
Valid Rule
rule
    Map [Rule]
rules -> [Rule] -> [(Term, Term)] -> [Rule] -> CDDLResult
validate [] [(Term, Term)]
terms [Rule]
rules
    Choice NonEmpty Rule
opts -> (Rule -> CDDLResult) -> NonEmpty Rule -> Rule -> CDDLResult
validateChoice (CTreeRoot ValidatorStage -> [(Term, Term)] -> Rule -> CDDLResult
validateMap CTreeRoot ValidatorStage
cddl [(Term, Term)]
terms) NonEmpty Rule
opts Rule
rule
    Rule
r -> [Char] -> Rule -> CDDLResult
UnapplicableRule [Char]
"validateMap" Rule
r
  where
    validate :: [Rule] -> [(Term, Term)] -> [Rule] -> CDDLResult
    validate :: [Rule] -> [(Term, Term)] -> [Rule] -> CDDLResult
validate [] [] [] = Rule -> CDDLResult
Valid Rule
rule
    validate [Rule]
exhausted [(Term, Term)]
_ [] = [Char] -> CDDLResult -> CDDLResult
forall a. [Char] -> a -> a
trace ([[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ Rule -> [Char]
forall a. Show a => a -> [Char]
show (Rule -> [Char]) -> [Rule] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Rule]
exhausted) (CDDLResult -> CDDLResult) -> CDDLResult -> CDDLResult
forall a b. (a -> b) -> a -> b
$ Rule
-> [[Rule]] -> [([AMatchedItem], ANonMatchedItem)] -> CDDLResult
MapExpansionFail Rule
rule [] []
    validate [] [] (Rule
r : [Rule]
rs)
      | Rule -> Bool
forall i. CTree i -> Bool
isOptional Rule
r = [Rule] -> [(Term, Term)] -> [Rule] -> CDDLResult
validate [] [] [Rule]
rs
      | Bool
otherwise = [Char] -> Rule -> CDDLResult
UnapplicableRule [Char]
"validateMap" Rule
r
    validate [Rule]
exhausted ((Term
k, Term
v) : [(Term, Term)]
ts) (Rule
r : [Rule]
rs) = case Rule
r of
      Occur Rule
ct OccurrenceIndicator
oi -> case OccurrenceIndicator
oi of
        OccurrenceIndicator
OIOptional
          | (Valid {}, [(Term, Term)]
leftover) <- [(Term, Term)] -> Rule -> (CDDLResult, [(Term, Term)])
validateKVInMap ((Term
k, Term
v) (Term, Term) -> [(Term, Term)] -> [(Term, Term)]
forall a. a -> [a] -> [a]
: [(Term, Term)]
ts) Rule
ct
          , res :: CDDLResult
res@Valid {} <- [Rule] -> [(Term, Term)] -> [Rule] -> CDDLResult
validate [] [(Term, Term)]
leftover ([Rule]
exhausted [Rule] -> [Rule] -> [Rule]
forall a. Semigroup a => a -> a -> a
<> [Rule]
rs) ->
              CDDLResult
res
          | Bool
otherwise -> [Rule] -> [(Term, Term)] -> [Rule] -> CDDLResult
validate (Rule
r Rule -> [Rule] -> [Rule]
forall a. a -> [a] -> [a]
: [Rule]
exhausted) ((Term
k, Term
v) (Term, Term) -> [(Term, Term)] -> [(Term, Term)]
forall a. a -> [a] -> [a]
: [(Term, Term)]
ts) [Rule]
rs
        OccurrenceIndicator
OIZeroOrMore
          | (Valid {}, [(Term, Term)]
leftover) <- [(Term, Term)] -> Rule -> (CDDLResult, [(Term, Term)])
validateKVInMap ((Term
k, Term
v) (Term, Term) -> [(Term, Term)] -> [(Term, Term)]
forall a. a -> [a] -> [a]
: [(Term, Term)]
ts) Rule
ct
          , res :: CDDLResult
res@Valid {} <- [Rule] -> [(Term, Term)] -> [Rule] -> CDDLResult
validate [] [(Term, Term)]
leftover (Rule
r Rule -> [Rule] -> [Rule]
forall a. a -> [a] -> [a]
: [Rule]
exhausted [Rule] -> [Rule] -> [Rule]
forall a. Semigroup a => a -> a -> a
<> [Rule]
rs) ->
              CDDLResult
res
          | Bool
otherwise -> [Rule] -> [(Term, Term)] -> [Rule] -> CDDLResult
validate (Rule
r Rule -> [Rule] -> [Rule]
forall a. a -> [a] -> [a]
: [Rule]
exhausted) ((Term
k, Term
v) (Term, Term) -> [(Term, Term)] -> [(Term, Term)]
forall a. a -> [a] -> [a]
: [(Term, Term)]
ts) [Rule]
rs
        OccurrenceIndicator
OIOneOrMore -> case [(Term, Term)] -> Rule -> (CDDLResult, [(Term, Term)])
validateKVInMap ((Term
k, Term
v) (Term, Term) -> [(Term, Term)] -> [(Term, Term)]
forall a. a -> [a] -> [a]
: [(Term, Term)]
ts) Rule
ct of
          (Valid {}, [(Term, Term)]
leftover) -> [Rule] -> [(Term, Term)] -> [Rule] -> CDDLResult
validate [] [(Term, Term)]
leftover (Rule -> OccurrenceIndicator -> Rule
forall i. CTree i -> OccurrenceIndicator -> CTree i
Occur Rule
ct OccurrenceIndicator
OIZeroOrMore Rule -> [Rule] -> [Rule]
forall a. a -> [a] -> [a]
: [Rule]
exhausted [Rule] -> [Rule] -> [Rule]
forall a. Semigroup a => a -> a -> a
<> [Rule]
rs)
          (CDDLResult
err, [(Term, Term)]
_) -> CDDLResult
err
        OIBounded Maybe Word64
_ (Just Word64
ub) | Word64
0 Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
ub -> Word64 -> CDDLResult -> CDDLResult
forall a b. Show a => a -> b -> b
traceShow Word64
ub (CDDLResult -> CDDLResult) -> CDDLResult -> CDDLResult
forall a b. (a -> b) -> a -> b
$ Rule
-> [[Rule]] -> [([AMatchedItem], ANonMatchedItem)] -> CDDLResult
MapExpansionFail Rule
rule [] []
        OIBounded Maybe Word64
lb Maybe Word64
ub
          | (Valid {}, [(Term, Term)]
leftover) <- [(Term, Term)] -> Rule -> (CDDLResult, [(Term, Term)])
validateKVInMap ((Term
k, Term
v) (Term, Term) -> [(Term, Term)] -> [(Term, Term)]
forall a. a -> [a] -> [a]
: [(Term, Term)]
ts) Rule
ct
          , Bool -> Bool
not (Word64 -> Maybe Word64 -> Maybe Word64 -> Bool
forall a. Ord a => a -> Maybe a -> Maybe a -> Bool
isWithinBoundsInclusive Word64
0 Maybe Word64
lb Maybe Word64
ub) ->
              [Rule] -> [(Term, Term)] -> [Rule] -> CDDLResult
validate [] [(Term, Term)]
leftover (Rule -> OccurrenceIndicator -> Rule
forall i. CTree i -> OccurrenceIndicator -> CTree i
Occur Rule
ct (Maybe Word64 -> Maybe Word64 -> OccurrenceIndicator
decrementBounds Maybe Word64
lb Maybe Word64
ub) Rule -> [Rule] -> [Rule]
forall a. a -> [a] -> [a]
: [Rule]
exhausted [Rule] -> [Rule] -> [Rule]
forall a. Semigroup a => a -> a -> a
<> [Rule]
rs)
          | Word64 -> Maybe Word64 -> Maybe Word64 -> Bool
forall a. Ord a => a -> Maybe a -> Maybe a -> Bool
isWithinBoundsInclusive Word64
0 Maybe Word64
lb Maybe Word64
ub Bool -> Bool -> Bool
&& Bool -> Bool
not ([(Term, Term)] -> Rule -> Bool
isValidTerm ((Term
k, Term
v) (Term, Term) -> [(Term, Term)] -> [(Term, Term)]
forall a. a -> [a] -> [a]
: [(Term, Term)]
ts) Rule
ct) ->
              [Rule] -> [(Term, Term)] -> [Rule] -> CDDLResult
validate (Rule
r Rule -> [Rule] -> [Rule]
forall a. a -> [a] -> [a]
: [Rule]
exhausted) ((Term
k, Term
v) (Term, Term) -> [(Term, Term)] -> [(Term, Term)]
forall a. a -> [a] -> [a]
: [(Term, Term)]
ts) [Rule]
rs
          | Bool
otherwise -> [Char] -> Rule -> CDDLResult
UnapplicableRule [Char]
"validateMap" Rule
r
      Rule
_ -> case [(Term, Term)] -> Rule -> (CDDLResult, [(Term, Term)])
validateKVInMap ((Term
k, Term
v) (Term, Term) -> [(Term, Term)] -> [(Term, Term)]
forall a. a -> [a] -> [a]
: [(Term, Term)]
ts) Rule
r of
        (Valid {}, [(Term, Term)]
leftover) -> [Rule] -> [(Term, Term)] -> [Rule] -> CDDLResult
validate [] [(Term, Term)]
leftover ([Rule]
exhausted [Rule] -> [Rule] -> [Rule]
forall a. Semigroup a => a -> a -> a
<> [Rule]
rs)
        (CDDLResult
err, [(Term, Term)]
_) -> CDDLResult
err
    validate [Rule]
_ [(Term, Term)]
_ [Rule]
_ = [Char] -> CDDLResult
forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible happened"

    validateKVInMap :: [(Term, Term)] -> Rule -> (CDDLResult, [(Term, Term)])
validateKVInMap ((Term
tk, Term
tv) : [(Term, Term)]
ts) (KV Rule
k Rule
v Bool
_) = case (CTreeRoot ValidatorStage -> Term -> Rule -> CBORTermResult
validateTerm CTreeRoot ValidatorStage
cddl Term
tk Rule
k, CTreeRoot ValidatorStage -> Term -> Rule -> CBORTermResult
validateTerm CTreeRoot ValidatorStage
cddl Term
tv Rule
v) of
      (CBORTermResult Term
_ Valid {}, CBORTermResult Term
_ x :: CDDLResult
x@Valid {}) -> (CDDLResult
x, [(Term, Term)]
ts)
      (CBORTermResult Term
_ Valid {}, CBORTermResult Term
_ CDDLResult
err) -> (CDDLResult
err, [(Term, Term)]
ts)
      (CBORTermResult Term
_ CDDLResult
err, CBORTermResult
_) -> (CDDLResult
err, [(Term, Term)]
ts)
    validateKVInMap [] Rule
_ = [Char] -> (CDDLResult, [(Term, Term)])
forall a. HasCallStack => [Char] -> a
error [Char]
"No remaining KV pairs"
    validateKVInMap [(Term, Term)]
_ Rule
x = [Char] -> (CDDLResult, [(Term, Term)])
forall a. HasCallStack => [Char] -> a
error ([Char] -> (CDDLResult, [(Term, Term)]))
-> [Char] -> (CDDLResult, [(Term, Term)])
forall a b. (a -> b) -> a -> b
$ [Char]
"Unexpected value in map: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Rule -> [Char]
forall a. Show a => a -> [Char]
show Rule
x
    isValidTerm :: [(Term, Term)] -> Rule -> Bool
isValidTerm [(Term, Term)]
ts Rule
r = case [(Term, Term)] -> Rule -> (CDDLResult, [(Term, Term)])
validateKVInMap [(Term, Term)]
ts Rule
r of
      (Valid {}, [(Term, Term)]
_) -> Bool
True
      (CDDLResult, [(Term, Term)])
_ -> Bool
False

--------------------------------------------------------------------------------
-- Choices

validateChoice :: (Rule -> CDDLResult) -> NE.NonEmpty Rule -> Rule -> CDDLResult
validateChoice :: (Rule -> CDDLResult) -> NonEmpty Rule -> Rule -> CDDLResult
validateChoice Rule -> CDDLResult
v NonEmpty Rule
rules = NonEmpty Rule -> Rule -> CDDLResult
go NonEmpty Rule
rules
  where
    go :: NE.NonEmpty Rule -> Rule -> CDDLResult
    go :: NonEmpty Rule -> Rule -> CDDLResult
go (Rule
choice NE.:| [Rule]
xs) Rule
rule = do
      case Rule -> CDDLResult
v Rule
choice of
        Valid Rule
_ -> Rule -> CDDLResult
Valid Rule
rule
        CDDLResult
err -> case [Rule] -> Maybe (NonEmpty Rule)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Rule]
xs of
          Maybe (NonEmpty Rule)
Nothing -> Rule -> NonEmpty Rule -> NonEmpty (Rule, CDDLResult) -> CDDLResult
ChoiceFail Rule
rule NonEmpty Rule
rules ((Rule
choice, CDDLResult
err) (Rule, CDDLResult)
-> [(Rule, CDDLResult)] -> NonEmpty (Rule, CDDLResult)
forall a. a -> [a] -> NonEmpty a
NE.:| [])
          Just NonEmpty Rule
choices ->
            case NonEmpty Rule -> Rule -> CDDLResult
go NonEmpty Rule
choices Rule
rule of
              Valid Rule
_ -> Rule -> CDDLResult
Valid Rule
rule
              ChoiceFail Rule
_ NonEmpty Rule
_ NonEmpty (Rule, CDDLResult)
errors -> Rule -> NonEmpty Rule -> NonEmpty (Rule, CDDLResult) -> CDDLResult
ChoiceFail Rule
rule NonEmpty Rule
rules ((Rule
choice, CDDLResult
err) (Rule, CDDLResult)
-> NonEmpty (Rule, CDDLResult) -> NonEmpty (Rule, CDDLResult)
forall a. a -> NonEmpty a -> NonEmpty a
NE.<| NonEmpty (Rule, CDDLResult)
errors)
              CDDLResult
_ -> [Char] -> CDDLResult
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"

--------------------------------------------------------------------------------
-- Control helpers

-- | Validate both rules
ctrlAnd :: (Rule -> CDDLResult) -> Rule -> Rule -> Rule -> CDDLResult
ctrlAnd :: (Rule -> CDDLResult) -> Rule -> Rule -> Rule -> CDDLResult
ctrlAnd Rule -> CDDLResult
v Rule
tgt Rule
ctrl Rule
rule =
  case Rule -> CDDLResult
v Rule
tgt of
    Valid Rule
_ ->
      case Rule -> CDDLResult
v Rule
ctrl of
        Valid Rule
_ -> Rule -> CDDLResult
Valid Rule
rule
        CDDLResult
_ -> Rule -> Maybe CBORTermResult -> CDDLResult
InvalidControl Rule
rule Maybe CBORTermResult
forall a. Maybe a
Nothing
    CDDLResult
_ -> Rule -> CDDLResult
InvalidRule Rule
rule

-- | Dispatch to the appropriate control
ctrlDispatch ::
  (Rule -> CDDLResult) ->
  CtlOp ->
  Rule ->
  Rule ->
  (CtlOp -> Rule -> Either (Maybe CBORTermResult) ()) ->
  Rule ->
  CDDLResult
ctrlDispatch :: (Rule -> CDDLResult)
-> CtlOp
-> Rule
-> Rule
-> (CtlOp -> Rule -> Either (Maybe CBORTermResult) ())
-> Rule
-> CDDLResult
ctrlDispatch Rule -> CDDLResult
v CtlOp
And Rule
tgt Rule
ctrl CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
_ Rule
rule = (Rule -> CDDLResult) -> Rule -> Rule -> Rule -> CDDLResult
ctrlAnd Rule -> CDDLResult
v Rule
tgt Rule
ctrl Rule
rule
ctrlDispatch Rule -> CDDLResult
v CtlOp
Within Rule
tgt Rule
ctrl CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
_ Rule
rule = (Rule -> CDDLResult) -> Rule -> Rule -> Rule -> CDDLResult
ctrlAnd Rule -> CDDLResult
v Rule
tgt Rule
ctrl Rule
rule
ctrlDispatch Rule -> CDDLResult
v CtlOp
op Rule
tgt Rule
ctrl CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
vctrl Rule
rule =
  case Rule -> CDDLResult
v Rule
tgt of
    Valid Rule
_ ->
      case CtlOp -> Rule -> Either (Maybe CBORTermResult) ()
vctrl CtlOp
op Rule
ctrl of
        Left Maybe CBORTermResult
err -> Rule -> Maybe CBORTermResult -> CDDLResult
InvalidControl Rule
rule Maybe CBORTermResult
err
        Right () -> Rule -> CDDLResult
Valid Rule
rule
    CDDLResult
_ -> Rule -> CDDLResult
InvalidRule Rule
rule

-- | A boolean control
boolCtrl :: Bool -> Either (Maybe CBORTermResult) ()
boolCtrl :: Bool -> Either (Maybe CBORTermResult) ()
boolCtrl Bool
c = if Bool
c then () -> Either (Maybe CBORTermResult) ()
forall a b. b -> Either a b
Right () else Maybe CBORTermResult -> Either (Maybe CBORTermResult) ()
forall a b. a -> Either a b
Left Maybe CBORTermResult
forall a. Maybe a
Nothing

--------------------------------------------------------------------------------
-- Bits control

getIndicesOfChoice :: CDDL -> NE.NonEmpty Rule -> [Word64]
getIndicesOfChoice :: CTreeRoot ValidatorStage -> NonEmpty Rule -> [Word64]
getIndicesOfChoice CTreeRoot ValidatorStage
cddl =
  (Rule -> [Word64]) -> NonEmpty Rule -> [Word64]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Rule -> [Word64]) -> NonEmpty Rule -> [Word64])
-> (Rule -> [Word64]) -> NonEmpty Rule -> [Word64]
forall a b. (a -> b) -> a -> b
$ \case
    Literal (Value (VUInt Word64
v) Comment
_) -> [Word64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
v]
    KV Rule
_ Rule
v Bool
_ ->
      case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
v of
        Literal (Value (VUInt Word64
v') Comment
_) -> [Word64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
v']
        Rule
somethingElse ->
          [Char] -> [Word64]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Word64]) -> [Char] -> [Word64]
forall a b. (a -> b) -> a -> b
$
            [Char]
"Malformed value in KV in choice in .bits: "
              [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Rule -> [Char]
forall a. Show a => a -> [Char]
show Rule
somethingElse
    Range Rule
ff Rule
tt RangeBound
incl -> CTreeRoot ValidatorStage -> Rule -> Rule -> RangeBound -> [Word64]
getIndicesOfRange CTreeRoot ValidatorStage
cddl Rule
ff Rule
tt RangeBound
incl
    Enum Rule
g -> CTreeRoot ValidatorStage -> Rule -> [Word64]
getIndicesOfEnum CTreeRoot ValidatorStage
cddl Rule
g
    Rule
somethingElse ->
      [Char] -> [Word64]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Word64]) -> [Char] -> [Word64]
forall a b. (a -> b) -> a -> b
$
        [Char]
"Malformed alternative in choice in .bits: "
          [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Rule -> [Char]
forall a. Show a => a -> [Char]
show Rule
somethingElse

getIndicesOfRange :: CDDL -> Rule -> Rule -> RangeBound -> [Word64]
getIndicesOfRange :: CTreeRoot ValidatorStage -> Rule -> Rule -> RangeBound -> [Word64]
getIndicesOfRange CTreeRoot ValidatorStage
cddl Rule
ff Rule
tt RangeBound
incl =
  case (CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
ff, CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
tt) of
    (Literal (Value (VUInt Word64
ff') Comment
_), Literal (Value (VUInt Word64
tt') Comment
_)) ->
      case RangeBound
incl of
        RangeBound
ClOpen -> [Word64] -> [Word64]
forall a. HasCallStack => [a] -> [a]
init [Word64]
rng
        RangeBound
Closed -> [Word64]
rng
      where
        rng :: [Word64]
rng = [Word64
ff' .. Word64
tt']
    (Rule, Rule)
somethingElse -> [Char] -> [Word64]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Word64]) -> [Char] -> [Word64]
forall a b. (a -> b) -> a -> b
$ [Char]
"Malformed range in .bits: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Rule, Rule) -> [Char]
forall a. Show a => a -> [Char]
show (Rule, Rule)
somethingElse

getIndicesOfEnum :: CDDL -> Rule -> [Word64]
getIndicesOfEnum :: CTreeRoot ValidatorStage -> Rule -> [Word64]
getIndicesOfEnum CTreeRoot ValidatorStage
cddl Rule
g =
  case CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
cddl Rule
g of
    Group [Rule]
g' -> CTreeRoot ValidatorStage -> NonEmpty Rule -> [Word64]
getIndicesOfChoice CTreeRoot ValidatorStage
cddl (Maybe (NonEmpty Rule) -> NonEmpty Rule
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (NonEmpty Rule) -> NonEmpty Rule)
-> Maybe (NonEmpty Rule) -> NonEmpty Rule
forall a b. (a -> b) -> a -> b
$ [Rule] -> Maybe (NonEmpty Rule)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Rule]
g')
    Rule
somethingElse -> [Char] -> [Word64]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Word64]) -> [Char] -> [Word64]
forall a b. (a -> b) -> a -> b
$ [Char]
"Malformed enum in .bits: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Rule -> [Char]
forall a. Show a => a -> [Char]
show Rule
somethingElse

--------------------------------------------------------------------------------
-- Resolving rules from the CDDL spec

resolveIfRef :: CDDL -> Rule -> Rule
resolveIfRef :: CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef ct :: CTreeRoot ValidatorStage
ct@(CTreeRoot Map Name Rule
cddl) (CTreeE (VRuleRef Name
n)) = do
  case Name -> Map Name Rule -> Maybe Rule
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name Rule
cddl of
    Maybe Rule
Nothing -> [Char] -> Rule
forall a. HasCallStack => [Char] -> a
error ([Char] -> Rule) -> [Char] -> Rule
forall a b. (a -> b) -> a -> b
$ [Char]
"Unbound reference: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name -> [Char]
forall a. Show a => a -> [Char]
show Name
n
    Just Rule
val -> CTreeRoot ValidatorStage -> Rule -> Rule
resolveIfRef CTreeRoot ValidatorStage
ct Rule
val
resolveIfRef CTreeRoot ValidatorStage
_ Rule
r = Rule
r

--------------------------------------------------------------------------------
-- Utils

replaceRule :: CDDLResult -> Rule -> CDDLResult
replaceRule :: CDDLResult -> Rule -> CDDLResult
replaceRule (ChoiceFail Rule
_ NonEmpty Rule
a NonEmpty (Rule, CDDLResult)
b) Rule
r = Rule -> NonEmpty Rule -> NonEmpty (Rule, CDDLResult) -> CDDLResult
ChoiceFail Rule
r NonEmpty Rule
a NonEmpty (Rule, CDDLResult)
b
replaceRule (ListExpansionFail Rule
_ [[Rule]]
a [[(Rule, CBORTermResult)]]
b) Rule
r = Rule -> [[Rule]] -> [[(Rule, CBORTermResult)]] -> CDDLResult
ListExpansionFail Rule
r [[Rule]]
a [[(Rule, CBORTermResult)]]
b
replaceRule (MapExpansionFail Rule
_ [[Rule]]
a [([AMatchedItem], ANonMatchedItem)]
b) Rule
r = Rule
-> [[Rule]] -> [([AMatchedItem], ANonMatchedItem)] -> CDDLResult
MapExpansionFail Rule
r [[Rule]]
a [([AMatchedItem], ANonMatchedItem)]
b
replaceRule (InvalidTagged Rule
_ Either Word64 CBORTermResult
a) Rule
r = Rule -> Either Word64 CBORTermResult -> CDDLResult
InvalidTagged Rule
r Either Word64 CBORTermResult
a
replaceRule InvalidRule {} Rule
r = Rule -> CDDLResult
InvalidRule Rule
r
replaceRule (InvalidControl Rule
_ Maybe CBORTermResult
a) Rule
r = Rule -> Maybe CBORTermResult -> CDDLResult
InvalidControl Rule
r Maybe CBORTermResult
a
replaceRule (UnapplicableRule [Char]
m Rule
_) Rule
r = [Char] -> Rule -> CDDLResult
UnapplicableRule [Char]
m Rule
r
replaceRule Valid {} Rule
r = Rule -> CDDLResult
Valid Rule
r

check :: Bool -> Rule -> CDDLResult
check :: Bool -> Rule -> CDDLResult
check Bool
c = if Bool
c then Rule -> CDDLResult
Valid else Rule -> CDDLResult
InvalidRule

range :: Ord a => RangeBound -> a -> a -> Bool
range :: forall a. Ord a => RangeBound -> a -> a -> Bool
range RangeBound
Closed = a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<=)
range RangeBound
ClOpen = a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<)