{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}

module Codec.CBOR.Cuddle.CBOR.Validator 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.Postlude
import Codec.CBOR.Cuddle.CDDL.Resolve
import Codec.CBOR.Read
import Codec.CBOR.Term
import Control.Exception
import Control.Monad ((>=>))
import Control.Monad.Reader
import Data.Bifunctor
import Data.Bits hiding (And)
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BSL
import Data.Function ((&))
import Data.Functor ((<&>))
import Data.Functor.Identity
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 GHC.Float
import System.Exit
import System.IO
import Text.Regex.TDFA

type CDDL = CTreeRoot' Identity MonoRef
type Rule = Node MonoRef
type ResolvedRule = CTree MonoRef

data CBORTermResult = CBORTermResult Term 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
      -- | 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 -> IO ()
validateCBOR :: ByteString -> Name -> CDDL -> IO ()
validateCBOR ByteString
bs Name
rule CDDL
cddl =
  ( case ByteString -> Name -> CDDL -> CBORTermResult
validateCBOR' ByteString
bs Name
rule CDDL
cddl of
      ok :: CBORTermResult
ok@(CBORTermResult Term
_ (Valid Rule
_)) -> do
        [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Valid " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ CBORTermResult -> [Char]
forall a. Show a => a -> [Char]
show CBORTermResult
ok
        IO ()
forall a. IO a
exitSuccess
      CBORTermResult
err -> do
        Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ CBORTermResult -> [Char]
forall a. Show a => a -> [Char]
show CBORTermResult
err
        IO ()
forall a. IO a
exitFailure
  )
    IO () -> (PatternMatchFail -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` ( \(PatternMatchFail
e :: PatternMatchFail) ->
                [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
                  [Char]
"You uncovered a path we thought was impossible! Please submit your CDDL and CBOR to `https://github.com/input-output-hk/cuddle/issues` for us to investigate\n"
                    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> PatternMatchFail -> [Char]
forall e. Exception e => e -> [Char]
displayException PatternMatchFail
e
            )

validateCBOR' ::
  BS.ByteString -> Name -> CDDL -> CBORTermResult
validateCBOR' :: ByteString -> Name -> CDDL -> CBORTermResult
validateCBOR' ByteString
bs Name
rule cddl :: CDDL
cddl@(CTreeRoot Map Name (Identity 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) ->
      if ByteString -> Bool
BSL.null ByteString
rest
        then Reader CDDL CBORTermResult -> CDDL -> CBORTermResult
forall r a. Reader r a -> r -> a
runReader (Term -> Rule -> Reader CDDL CBORTermResult
forall (m :: * -> *).
MonadReader CDDL m =>
Term -> Rule -> m CBORTermResult
validateTerm Term
term (Identity Rule -> Rule
forall a. Identity a -> a
runIdentity (Identity Rule -> Rule) -> Identity Rule -> Rule
forall a b. (a -> b) -> a -> b
$ Map Name (Identity Rule)
tree Map Name (Identity Rule) -> Name -> Identity Rule
forall k a. Ord k => Map k a -> k -> a
Map.! Name
rule)) CDDL
cddl
        else Reader CDDL CBORTermResult -> CDDL -> CBORTermResult
forall r a. Reader r a -> r -> a
runReader (Term -> Rule -> Reader CDDL CBORTermResult
forall (m :: * -> *).
MonadReader CDDL m =>
Term -> Rule -> m CBORTermResult
validateTerm (ByteString -> Term
TBytes ByteString
bs) (Identity Rule -> Rule
forall a. Identity a -> a
runIdentity (Identity Rule -> Rule) -> Identity Rule -> Rule
forall a b. (a -> b) -> a -> b
$ Map Name (Identity Rule)
tree Map Name (Identity Rule) -> Name -> Identity Rule
forall k a. Ord k => Map k a -> k -> a
Map.! Name
rule)) CDDL
cddl

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

-- | Core function that validates a CBOR term to a particular rule of the CDDL
-- spec
validateTerm ::
  MonadReader CDDL m =>
  Term -> Rule -> m CBORTermResult
validateTerm :: forall (m :: * -> *).
MonadReader CDDL m =>
Term -> Rule -> m CBORTermResult
validateTerm Term
term Rule
rule =
  let f :: Rule -> m CDDLResult
f = case Term
term of
        TInt Int
i -> Integer -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
Integer -> Rule -> m CDDLResult
validateInteger (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)
        TInteger Integer
i -> Integer -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
Integer -> Rule -> m CDDLResult
validateInteger Integer
i
        TBytes ByteString
b -> ByteString -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
ByteString -> Rule -> m CDDLResult
validateBytes ByteString
b
        TBytesI ByteString
b -> ByteString -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
ByteString -> Rule -> m CDDLResult
validateBytes (ByteString -> ByteString
BSL.toStrict ByteString
b)
        TString Text
s -> Text -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
Text -> Rule -> m CDDLResult
validateText Text
s
        TStringI Text
s -> Text -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
Text -> Rule -> m CDDLResult
validateText (Text -> Text
TL.toStrict Text
s)
        TList [Term]
ts -> [Term] -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
[Term] -> Rule -> m CDDLResult
validateList [Term]
ts
        TListI [Term]
ts -> [Term] -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
[Term] -> Rule -> m CDDLResult
validateList [Term]
ts
        TMap [(Term, Term)]
ts -> [(Term, Term)] -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
[(Term, Term)] -> Rule -> m CDDLResult
validateMap [(Term, Term)]
ts
        TMapI [(Term, Term)]
ts -> [(Term, Term)] -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
[(Term, Term)] -> Rule -> m CDDLResult
validateMap [(Term, Term)]
ts
        TTagged Word64
w Term
t -> Word64 -> Term -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
Word64 -> Term -> Rule -> m CDDLResult
validateTagged Word64
w Term
t
        TBool Bool
b -> Bool -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
Bool -> Rule -> m CDDLResult
validateBool Bool
b
        Term
TNull -> Rule -> m CDDLResult
forall (m :: * -> *). MonadReader CDDL m => Rule -> m CDDLResult
validateNull
        TSimple Word8
s -> Word8 -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
Word8 -> Rule -> m CDDLResult
validateSimple Word8
s
        THalf Float
h -> Float -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
Float -> Rule -> m CDDLResult
validateHalf Float
h
        TFloat Float
h -> Float -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
Float -> Rule -> m CDDLResult
validateFloat Float
h
        TDouble Double
d -> Double -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
Double -> Rule -> m CDDLResult
validateDouble Double
d
   in Term -> CDDLResult -> CBORTermResult
CBORTermResult Term
term (CDDLResult -> CBORTermResult) -> m CDDLResult -> m CBORTermResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rule -> m CDDLResult
f 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 ::
  MonadReader CDDL m =>
  Integer -> Rule -> m CDDLResult
validateInteger :: forall (m :: * -> *).
MonadReader CDDL m =>
Integer -> Rule -> m CDDLResult
validateInteger Integer
i Rule
rule =
  ((Rule -> CDDLResult) -> Rule -> CDDLResult
forall a b. (a -> b) -> a -> b
$ Rule
rule) ((Rule -> CDDLResult) -> CDDLResult)
-> m (Rule -> CDDLResult) -> m CDDLResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
rule m (CTree MonoRef)
-> (CTree MonoRef -> m (Rule -> CDDLResult))
-> m (Rule -> CDDLResult)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      -- 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) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid
      -- a = int
      Postlude PTerm
PTInt -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid
      -- a = uint
      Postlude PTerm
PTUInt -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Rule -> CDDLResult) -> m (Rule -> CDDLResult))
-> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a b. (a -> b) -> a -> b
$ Bool -> Rule -> CDDLResult
check (Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0)
      -- a = nint
      Postlude PTerm
PTNInt -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Rule -> CDDLResult) -> m (Rule -> CDDLResult))
-> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a b. (a -> b) -> a -> b
$ Bool -> Rule -> CDDLResult
check (Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0)
      -- a = x
      Literal (Value (VUInt Word64
i') Comment
_) -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Rule -> CDDLResult) -> m (Rule -> CDDLResult))
-> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a b. (a -> b) -> a -> b
$ Bool -> Rule -> CDDLResult
check (Bool -> Rule -> CDDLResult) -> Bool -> Rule -> CDDLResult
forall a b. (a -> b) -> a -> b
$ 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'
      -- a = -x
      Literal (Value (VNInt Word64
i') Comment
_) -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Rule -> CDDLResult) -> m (Rule -> CDDLResult))
-> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a b. (a -> b) -> a -> b
$ Bool -> Rule -> CDDLResult
check (Bool -> Rule -> CDDLResult) -> Bool -> Rule -> CDDLResult
forall a b. (a -> b) -> a -> b
$ -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'
      -- a = <big number>
      Literal (Value (VBignum Integer
i') Comment
_) -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Rule -> CDDLResult) -> m (Rule -> CDDLResult))
-> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a b. (a -> b) -> a -> b
$ Bool -> Rule -> CDDLResult
check (Bool -> Rule -> CDDLResult) -> Bool -> Rule -> CDDLResult
forall a b. (a -> b) -> a -> b
$ Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
i'
      -- a = foo .ctrl bar
      Control CtlOp
op Rule
tgt Rule
ctrl -> (Rule -> m CDDLResult)
-> CtlOp
-> Rule
-> Rule
-> (CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ()))
-> m (Rule -> CDDLResult)
forall (m :: * -> *).
Monad m =>
(Rule -> m CDDLResult)
-> CtlOp
-> Rule
-> Rule
-> (CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ()))
-> m (Rule -> CDDLResult)
ctrlDispatch (Integer -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
Integer -> Rule -> m CDDLResult
validateInteger Integer
i) CtlOp
op Rule
tgt Rule
ctrl (Integer -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
forall (m :: * -> *).
MonadReader CDDL m =>
Integer -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
controlInteger Integer
i)
      -- a = foo / bar
      Choice NonEmpty Rule
opts -> (Rule -> m CDDLResult) -> NonEmpty Rule -> m (Rule -> CDDLResult)
forall (m :: * -> *).
Monad m =>
(Rule -> m CDDLResult) -> NonEmpty Rule -> m (Rule -> CDDLResult)
validateChoice (Integer -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
Integer -> Rule -> m CDDLResult
validateInteger Integer
i) NonEmpty Rule
opts
      -- a = x..y
      Range Rule
low Rule
high RangeBound
bound ->
        ((,) (CTree MonoRef -> CTree MonoRef -> (CTree MonoRef, CTree MonoRef))
-> m (CTree MonoRef)
-> m (CTree MonoRef -> (CTree MonoRef, CTree MonoRef))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
low m (CTree MonoRef -> (CTree MonoRef, CTree MonoRef))
-> m (CTree MonoRef) -> m (CTree MonoRef, CTree MonoRef)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
high)
          m (CTree MonoRef, CTree MonoRef)
-> ((CTree MonoRef, CTree MonoRef) -> Rule -> CDDLResult)
-> m (Rule -> CDDLResult)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bool -> Rule -> CDDLResult
check (Bool -> Rule -> CDDLResult)
-> ((CTree MonoRef, CTree MonoRef) -> Bool)
-> (CTree MonoRef, CTree MonoRef)
-> Rule
-> CDDLResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
            (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
      -- a = &(x, y, z)
      Enum Rule
g ->
        Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
g m (CTree MonoRef)
-> (CTree MonoRef -> m (Rule -> CDDLResult))
-> m (Rule -> CDDLResult)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Group [Rule]
g' -> Integer -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
Integer -> Rule -> m CDDLResult
validateInteger Integer
i (CTree MonoRef -> Rule
forall a. a -> MonoRef a
MIt (NonEmpty Rule -> CTree MonoRef
forall (f :: * -> *). NonEmpty (Node f) -> CTree f
Choice ([Rule] -> NonEmpty Rule
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList [Rule]
g'))) m CDDLResult
-> (CDDLResult -> Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> CDDLResult -> Rule -> CDDLResult
replaceRule
      -- a = x: y
      -- Note KV cannot appear on its own, but we will use this when validating
      -- lists.
      KV Rule
_ Rule
v Bool
_ -> Integer -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
Integer -> Rule -> m CDDLResult
validateInteger Integer
i Rule
v m CDDLResult
-> (CDDLResult -> Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> CDDLResult -> Rule -> CDDLResult
replaceRule
      Tag Word64
2 (MIt (Postlude PTerm
PTBytes)) -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid
      Tag Word64
3 (MIt (Postlude PTerm
PTBytes)) -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid
      CTree MonoRef
_ -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
UnapplicableRule

-- | Controls for an Integer
controlInteger ::
  forall m. MonadReader CDDL m => Integer -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
controlInteger :: forall (m :: * -> *).
MonadReader CDDL m =>
Integer -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
controlInteger Integer
i CtlOp
Size Rule
ctrl =
  Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
ctrl m (CTree MonoRef)
-> (CTree MonoRef -> Either (Maybe CBORTermResult) ())
-> m (Either (Maybe CBORTermResult) ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    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
controlInteger Integer
i CtlOp
Bits Rule
ctrl = do
  [Word64]
indices <-
    Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
ctrl m (CTree MonoRef) -> (CTree MonoRef -> m [Word64]) -> m [Word64]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Literal (Value (VUInt Word64
i') Comment
_) -> [Word64] -> m [Word64]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Word64
i']
      Choice NonEmpty Rule
nodes -> NonEmpty Rule -> m [Word64]
forall (m :: * -> *).
MonadReader CDDL m =>
NonEmpty Rule -> m [Word64]
getIndicesOfChoice NonEmpty Rule
nodes
      Range Rule
ff Rule
tt RangeBound
incl -> Rule -> Rule -> RangeBound -> m [Word64]
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> Rule -> RangeBound -> m [Word64]
getIndicesOfRange Rule
ff Rule
tt RangeBound
incl
      Enum Rule
g -> Rule -> m [Word64]
forall (m :: * -> *). MonadReader CDDL m => Rule -> m [Word64]
getIndicesOfEnum Rule
g
  Either (Maybe CBORTermResult) ()
-> m (Either (Maybe CBORTermResult) ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Maybe CBORTermResult) ()
 -> m (Either (Maybe CBORTermResult) ()))
-> Either (Maybe CBORTermResult) ()
-> m (Either (Maybe CBORTermResult) ())
forall a b. (a -> b) -> a -> b
$ 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 Integer
i CtlOp
Lt Rule
ctrl =
  Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
ctrl
    m (CTree MonoRef)
-> (CTree MonoRef -> Either (Maybe CBORTermResult) ())
-> m (Either (Maybe CBORTermResult) ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> (CTree MonoRef -> Bool)
-> CTree MonoRef
-> Either (Maybe CBORTermResult) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      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'
controlInteger Integer
i CtlOp
Gt Rule
ctrl =
  Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
ctrl
    m (CTree MonoRef)
-> (CTree MonoRef -> Either (Maybe CBORTermResult) ())
-> m (Either (Maybe CBORTermResult) ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> (CTree MonoRef -> Bool)
-> CTree MonoRef
-> Either (Maybe CBORTermResult) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      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'
controlInteger Integer
i CtlOp
Le Rule
ctrl =
  Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
ctrl
    m (CTree MonoRef)
-> (CTree MonoRef -> Either (Maybe CBORTermResult) ())
-> m (Either (Maybe CBORTermResult) ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> (CTree MonoRef -> Bool)
-> CTree MonoRef
-> Either (Maybe CBORTermResult) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      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'
controlInteger Integer
i CtlOp
Ge Rule
ctrl =
  Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
ctrl
    m (CTree MonoRef)
-> (CTree MonoRef -> Either (Maybe CBORTermResult) ())
-> m (Either (Maybe CBORTermResult) ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> (CTree MonoRef -> Bool)
-> CTree MonoRef
-> Either (Maybe CBORTermResult) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      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'
controlInteger Integer
i CtlOp
Eq Rule
ctrl =
  Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
ctrl
    m (CTree MonoRef)
-> (CTree MonoRef -> Either (Maybe CBORTermResult) ())
-> m (Either (Maybe CBORTermResult) ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> (CTree MonoRef -> Bool)
-> CTree MonoRef
-> Either (Maybe CBORTermResult) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      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'
controlInteger Integer
i CtlOp
Ne Rule
ctrl =
  Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
ctrl
    m (CTree MonoRef)
-> (CTree MonoRef -> Either (Maybe CBORTermResult) ())
-> m (Either (Maybe CBORTermResult) ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> (CTree MonoRef -> Bool)
-> CTree MonoRef
-> Either (Maybe CBORTermResult) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      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'

--------------------------------------------------------------------------------
-- 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 ::
  MonadReader CDDL m =>
  Float -> Rule -> m CDDLResult
validateHalf :: forall (m :: * -> *).
MonadReader CDDL m =>
Float -> Rule -> m CDDLResult
validateHalf Float
f Rule
rule =
  ((Rule -> CDDLResult) -> Rule -> CDDLResult
forall a b. (a -> b) -> a -> b
$ Rule
rule) ((Rule -> CDDLResult) -> CDDLResult)
-> m (Rule -> CDDLResult) -> m CDDLResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
rule m (CTree MonoRef)
-> (CTree MonoRef -> m (Rule -> CDDLResult))
-> m (Rule -> CDDLResult)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      -- a = any
      Postlude PTerm
PTAny -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid
      -- a = float16
      Postlude PTerm
PTHalf -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid
      -- a = 0.5
      Literal (Value (VFloat16 Float
f') Comment
_) -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Rule -> CDDLResult) -> m (Rule -> CDDLResult))
-> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a b. (a -> b) -> a -> b
$ 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 -> m CDDLResult) -> NonEmpty Rule -> m (Rule -> CDDLResult)
forall (m :: * -> *).
Monad m =>
(Rule -> m CDDLResult) -> NonEmpty Rule -> m (Rule -> CDDLResult)
validateChoice (Float -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
Float -> Rule -> m CDDLResult
validateHalf Float
f) NonEmpty Rule
opts
      -- a = foo .ctrl bar
      Control CtlOp
op Rule
tgt Rule
ctrl -> (Rule -> m CDDLResult)
-> CtlOp
-> Rule
-> Rule
-> (CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ()))
-> m (Rule -> CDDLResult)
forall (m :: * -> *).
Monad m =>
(Rule -> m CDDLResult)
-> CtlOp
-> Rule
-> Rule
-> (CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ()))
-> m (Rule -> CDDLResult)
ctrlDispatch (Float -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
Float -> Rule -> m CDDLResult
validateHalf Float
f) CtlOp
op Rule
tgt Rule
ctrl (Float -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
forall (m :: * -> *).
MonadReader CDDL m =>
Float -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
controlHalf Float
f)
      -- a = x..y
      Range Rule
low Rule
high RangeBound
bound ->
        ((,) (CTree MonoRef -> CTree MonoRef -> (CTree MonoRef, CTree MonoRef))
-> m (CTree MonoRef)
-> m (CTree MonoRef -> (CTree MonoRef, CTree MonoRef))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
low m (CTree MonoRef -> (CTree MonoRef, CTree MonoRef))
-> m (CTree MonoRef) -> m (CTree MonoRef, CTree MonoRef)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
high)
          m (CTree MonoRef, CTree MonoRef)
-> ((CTree MonoRef, CTree MonoRef) -> Rule -> CDDLResult)
-> m (Rule -> CDDLResult)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bool -> Rule -> CDDLResult
check (Bool -> Rule -> CDDLResult)
-> ((CTree MonoRef, CTree MonoRef) -> Bool)
-> (CTree MonoRef, CTree MonoRef)
-> Rule
-> CDDLResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
            (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
      CTree MonoRef
_ -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
UnapplicableRule

-- | Controls for `Float16`
controlHalf :: MonadReader CDDL m => Float -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
controlHalf :: forall (m :: * -> *).
MonadReader CDDL m =>
Float -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
controlHalf Float
f CtlOp
Eq Rule
ctrl =
  Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
ctrl
    m (CTree MonoRef)
-> (CTree MonoRef -> Either (Maybe CBORTermResult) ())
-> m (Either (Maybe CBORTermResult) ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> (CTree MonoRef -> Bool)
-> CTree MonoRef
-> Either (Maybe CBORTermResult) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      Literal (Value (VFloat16 Float
f') Comment
_) -> Float
f Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
f'
controlHalf Float
f CtlOp
Ne Rule
ctrl =
  Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
ctrl
    m (CTree MonoRef)
-> (CTree MonoRef -> Either (Maybe CBORTermResult) ())
-> m (Either (Maybe CBORTermResult) ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> (CTree MonoRef -> Bool)
-> CTree MonoRef
-> Either (Maybe CBORTermResult) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      Literal (Value (VFloat16 Float
f') Comment
_) -> Float
f Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
/= Float
f'

-- | Validating a `Float32`
validateFloat ::
  MonadReader CDDL m =>
  Float -> Rule -> m CDDLResult
validateFloat :: forall (m :: * -> *).
MonadReader CDDL m =>
Float -> Rule -> m CDDLResult
validateFloat Float
f Rule
rule =
  ((Rule -> CDDLResult) -> Rule -> CDDLResult
forall a b. (a -> b) -> a -> b
$ Rule
rule) ((Rule -> CDDLResult) -> CDDLResult)
-> m (Rule -> CDDLResult) -> m CDDLResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
rule m (CTree MonoRef)
-> (CTree MonoRef -> m (Rule -> CDDLResult))
-> m (Rule -> CDDLResult)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      -- a = any
      Postlude PTerm
PTAny -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid
      -- a = float32
      Postlude PTerm
PTFloat -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid
      -- a = 0.000000005
      -- TODO: it is unclear if smaller floats should also validate
      Literal (Value (VFloat32 Float
f') Comment
_) -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Rule -> CDDLResult) -> m (Rule -> CDDLResult))
-> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a b. (a -> b) -> a -> b
$ 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 -> m CDDLResult) -> NonEmpty Rule -> m (Rule -> CDDLResult)
forall (m :: * -> *).
Monad m =>
(Rule -> m CDDLResult) -> NonEmpty Rule -> m (Rule -> CDDLResult)
validateChoice (Float -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
Float -> Rule -> m CDDLResult
validateFloat Float
f) NonEmpty Rule
opts
      -- a = foo .ctrl bar
      Control CtlOp
op Rule
tgt Rule
ctrl -> (Rule -> m CDDLResult)
-> CtlOp
-> Rule
-> Rule
-> (CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ()))
-> m (Rule -> CDDLResult)
forall (m :: * -> *).
Monad m =>
(Rule -> m CDDLResult)
-> CtlOp
-> Rule
-> Rule
-> (CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ()))
-> m (Rule -> CDDLResult)
ctrlDispatch (Float -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
Float -> Rule -> m CDDLResult
validateFloat Float
f) CtlOp
op Rule
tgt Rule
ctrl (Float -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
forall (m :: * -> *).
MonadReader CDDL m =>
Float -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
controlFloat Float
f)
      -- a = x..y
      -- TODO it is unclear if this should mix floating point types too
      Range Rule
low Rule
high RangeBound
bound ->
        ((,) (CTree MonoRef -> CTree MonoRef -> (CTree MonoRef, CTree MonoRef))
-> m (CTree MonoRef)
-> m (CTree MonoRef -> (CTree MonoRef, CTree MonoRef))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
low m (CTree MonoRef -> (CTree MonoRef, CTree MonoRef))
-> m (CTree MonoRef) -> m (CTree MonoRef, CTree MonoRef)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
high)
          m (CTree MonoRef, CTree MonoRef)
-> ((CTree MonoRef, CTree MonoRef) -> Rule -> CDDLResult)
-> m (Rule -> CDDLResult)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bool -> Rule -> CDDLResult
check (Bool -> Rule -> CDDLResult)
-> ((CTree MonoRef, CTree MonoRef) -> Bool)
-> (CTree MonoRef, CTree MonoRef)
-> Rule
-> CDDLResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
            (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
      CTree MonoRef
_ -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
UnapplicableRule

-- | Controls for `Float32`
controlFloat :: MonadReader CDDL m => Float -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
controlFloat :: forall (m :: * -> *).
MonadReader CDDL m =>
Float -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
controlFloat Float
f CtlOp
Eq Rule
ctrl =
  Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
ctrl
    m (CTree MonoRef)
-> (CTree MonoRef -> Either (Maybe CBORTermResult) ())
-> m (Either (Maybe CBORTermResult) ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> (CTree MonoRef -> Bool)
-> CTree MonoRef
-> Either (Maybe CBORTermResult) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      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'
controlFloat Float
f CtlOp
Ne Rule
ctrl =
  Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
ctrl
    m (CTree MonoRef)
-> (CTree MonoRef -> Either (Maybe CBORTermResult) ())
-> m (Either (Maybe CBORTermResult) ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> (CTree MonoRef -> Bool)
-> CTree MonoRef
-> Either (Maybe CBORTermResult) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      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'

-- | Validating a `Float64`
validateDouble ::
  MonadReader CDDL m =>
  Double -> Rule -> m CDDLResult
validateDouble :: forall (m :: * -> *).
MonadReader CDDL m =>
Double -> Rule -> m CDDLResult
validateDouble Double
f Rule
rule =
  ((Rule -> CDDLResult) -> Rule -> CDDLResult
forall a b. (a -> b) -> a -> b
$ Rule
rule) ((Rule -> CDDLResult) -> CDDLResult)
-> m (Rule -> CDDLResult) -> m CDDLResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
rule m (CTree MonoRef)
-> (CTree MonoRef -> m (Rule -> CDDLResult))
-> m (Rule -> CDDLResult)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      -- a = any
      Postlude PTerm
PTAny -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid
      -- a = float64
      Postlude PTerm
PTDouble -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid
      -- a = 0.0000000000000000000000000000000000000000000005
      -- TODO: it is unclear if smaller floats should also validate
      Literal (Value (VFloat64 Double
f') Comment
_) -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Rule -> CDDLResult) -> m (Rule -> CDDLResult))
-> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a b. (a -> b) -> a -> b
$ 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 -> m CDDLResult) -> NonEmpty Rule -> m (Rule -> CDDLResult)
forall (m :: * -> *).
Monad m =>
(Rule -> m CDDLResult) -> NonEmpty Rule -> m (Rule -> CDDLResult)
validateChoice (Double -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
Double -> Rule -> m CDDLResult
validateDouble Double
f) NonEmpty Rule
opts
      -- a = foo .ctrl bar
      Control CtlOp
op Rule
tgt Rule
ctrl -> (Rule -> m CDDLResult)
-> CtlOp
-> Rule
-> Rule
-> (CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ()))
-> m (Rule -> CDDLResult)
forall (m :: * -> *).
Monad m =>
(Rule -> m CDDLResult)
-> CtlOp
-> Rule
-> Rule
-> (CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ()))
-> m (Rule -> CDDLResult)
ctrlDispatch (Double -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
Double -> Rule -> m CDDLResult
validateDouble Double
f) CtlOp
op Rule
tgt Rule
ctrl (Double -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
forall (m :: * -> *).
MonadReader CDDL m =>
Double -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
controlDouble Double
f)
      -- a = x..y
      -- TODO it is unclear if this should mix floating point types too
      Range Rule
low Rule
high RangeBound
bound ->
        ((,) (CTree MonoRef -> CTree MonoRef -> (CTree MonoRef, CTree MonoRef))
-> m (CTree MonoRef)
-> m (CTree MonoRef -> (CTree MonoRef, CTree MonoRef))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
low m (CTree MonoRef -> (CTree MonoRef, CTree MonoRef))
-> m (CTree MonoRef) -> m (CTree MonoRef, CTree MonoRef)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
high)
          m (CTree MonoRef, CTree MonoRef)
-> ((CTree MonoRef, CTree MonoRef) -> Rule -> CDDLResult)
-> m (Rule -> CDDLResult)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bool -> Rule -> CDDLResult
check (Bool -> Rule -> CDDLResult)
-> ((CTree MonoRef, CTree MonoRef) -> Bool)
-> (CTree MonoRef, CTree MonoRef)
-> Rule
-> CDDLResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
            (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
      CTree MonoRef
_ -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
UnapplicableRule

-- | Controls for `Float64`
controlDouble ::
  MonadReader CDDL m => Double -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
controlDouble :: forall (m :: * -> *).
MonadReader CDDL m =>
Double -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
controlDouble Double
f CtlOp
Eq Rule
ctrl =
  Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
ctrl
    m (CTree MonoRef)
-> (CTree MonoRef -> Either (Maybe CBORTermResult) ())
-> m (Either (Maybe CBORTermResult) ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> (CTree MonoRef -> Bool)
-> CTree MonoRef
-> Either (Maybe CBORTermResult) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      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'
controlDouble Double
f CtlOp
Ne Rule
ctrl =
  Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
ctrl
    m (CTree MonoRef)
-> (CTree MonoRef -> Either (Maybe CBORTermResult) ())
-> m (Either (Maybe CBORTermResult) ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> (CTree MonoRef -> Bool)
-> CTree MonoRef
-> Either (Maybe CBORTermResult) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      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'

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

-- | Validating a boolean
validateBool ::
  MonadReader CDDL m =>
  Bool -> Rule -> m CDDLResult
validateBool :: forall (m :: * -> *).
MonadReader CDDL m =>
Bool -> Rule -> m CDDLResult
validateBool Bool
b Rule
rule =
  ((Rule -> CDDLResult) -> Rule -> CDDLResult
forall a b. (a -> b) -> a -> b
$ Rule
rule) ((Rule -> CDDLResult) -> CDDLResult)
-> m (Rule -> CDDLResult) -> m CDDLResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
rule m (CTree MonoRef)
-> (CTree MonoRef -> m (Rule -> CDDLResult))
-> m (Rule -> CDDLResult)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      -- a = any
      Postlude PTerm
PTAny -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid
      -- a = bool
      Postlude PTerm
PTBool -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid
      -- a = true
      Literal (Value (VBool Bool
b') Comment
_) -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Rule -> CDDLResult) -> m (Rule -> CDDLResult))
-> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a b. (a -> b) -> a -> b
$ 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 -> m CDDLResult)
-> CtlOp
-> Rule
-> Rule
-> (CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ()))
-> m (Rule -> CDDLResult)
forall (m :: * -> *).
Monad m =>
(Rule -> m CDDLResult)
-> CtlOp
-> Rule
-> Rule
-> (CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ()))
-> m (Rule -> CDDLResult)
ctrlDispatch (Bool -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
Bool -> Rule -> m CDDLResult
validateBool Bool
b) CtlOp
op Rule
tgt Rule
ctrl (Bool -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
forall (m :: * -> *).
MonadReader CDDL m =>
Bool -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
controlBool Bool
b)
      -- a = foo / bar
      Choice NonEmpty Rule
opts -> (Rule -> m CDDLResult) -> NonEmpty Rule -> m (Rule -> CDDLResult)
forall (m :: * -> *).
Monad m =>
(Rule -> m CDDLResult) -> NonEmpty Rule -> m (Rule -> CDDLResult)
validateChoice (Bool -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
Bool -> Rule -> m CDDLResult
validateBool Bool
b) NonEmpty Rule
opts
      CTree MonoRef
_ -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
UnapplicableRule

-- | Controls for `Bool`
controlBool :: MonadReader CDDL m => Bool -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
controlBool :: forall (m :: * -> *).
MonadReader CDDL m =>
Bool -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
controlBool Bool
b CtlOp
Eq Rule
ctrl =
  Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
ctrl
    m (CTree MonoRef)
-> (CTree MonoRef -> Either (Maybe CBORTermResult) ())
-> m (Either (Maybe CBORTermResult) ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> (CTree MonoRef -> Bool)
-> CTree MonoRef
-> Either (Maybe CBORTermResult) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      Literal (Value (VBool Bool
b') Comment
_) -> Bool
b Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
b'
controlBool Bool
b CtlOp
Ne Rule
ctrl =
  Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
ctrl
    m (CTree MonoRef)
-> (CTree MonoRef -> Either (Maybe CBORTermResult) ())
-> m (Either (Maybe CBORTermResult) ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> (CTree MonoRef -> Bool)
-> CTree MonoRef
-> Either (Maybe CBORTermResult) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      Literal (Value (VBool Bool
b') Comment
_) -> Bool
b Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool
b'

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

-- | Validating a `TSimple`. It is unclear if this is used for anything else than undefined.
validateSimple ::
  MonadReader CDDL m =>
  Word8 -> Rule -> m CDDLResult
validateSimple :: forall (m :: * -> *).
MonadReader CDDL m =>
Word8 -> Rule -> m CDDLResult
validateSimple Word8
23 Rule
rule =
  ((Rule -> CDDLResult) -> Rule -> CDDLResult
forall a b. (a -> b) -> a -> b
$ Rule
rule) ((Rule -> CDDLResult) -> CDDLResult)
-> m (Rule -> CDDLResult) -> m CDDLResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
rule m (CTree MonoRef)
-> (CTree MonoRef -> m (Rule -> CDDLResult))
-> m (Rule -> CDDLResult)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      -- a = any
      Postlude PTerm
PTAny -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid
      -- a = undefined
      Postlude PTerm
PTUndefined -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid
      -- a = foo / bar
      Choice NonEmpty Rule
opts -> (Rule -> m CDDLResult) -> NonEmpty Rule -> m (Rule -> CDDLResult)
forall (m :: * -> *).
Monad m =>
(Rule -> m CDDLResult) -> NonEmpty Rule -> m (Rule -> CDDLResult)
validateChoice (Word8 -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
Word8 -> Rule -> m CDDLResult
validateSimple Word8
23) NonEmpty Rule
opts
      CTree MonoRef
_ -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
UnapplicableRule
validateSimple Word8
n Rule
_ = [Char] -> m CDDLResult
forall a. HasCallStack => [Char] -> a
error ([Char] -> m CDDLResult) -> [Char] -> m 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 ::
  MonadReader CDDL m => Rule -> m CDDLResult
validateNull :: forall (m :: * -> *). MonadReader CDDL m => Rule -> m CDDLResult
validateNull Rule
rule =
  ((Rule -> CDDLResult) -> Rule -> CDDLResult
forall a b. (a -> b) -> a -> b
$ Rule
rule) ((Rule -> CDDLResult) -> CDDLResult)
-> m (Rule -> CDDLResult) -> m CDDLResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
rule m (CTree MonoRef)
-> (CTree MonoRef -> m (Rule -> CDDLResult))
-> m (Rule -> CDDLResult)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      -- a = any
      Postlude PTerm
PTAny -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid
      -- a = nil
      Postlude PTerm
PTNil -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid
      Choice NonEmpty Rule
opts -> (Rule -> m CDDLResult) -> NonEmpty Rule -> m (Rule -> CDDLResult)
forall (m :: * -> *).
Monad m =>
(Rule -> m CDDLResult) -> NonEmpty Rule -> m (Rule -> CDDLResult)
validateChoice Rule -> m CDDLResult
forall (m :: * -> *). MonadReader CDDL m => Rule -> m CDDLResult
validateNull NonEmpty Rule
opts
      CTree MonoRef
_ -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
UnapplicableRule

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

-- | Validating a byte sequence
validateBytes ::
  MonadReader CDDL m =>
  BS.ByteString -> Rule -> m CDDLResult
validateBytes :: forall (m :: * -> *).
MonadReader CDDL m =>
ByteString -> Rule -> m CDDLResult
validateBytes ByteString
bs Rule
rule =
  ((Rule -> CDDLResult) -> Rule -> CDDLResult
forall a b. (a -> b) -> a -> b
$ Rule
rule) ((Rule -> CDDLResult) -> CDDLResult)
-> m (Rule -> CDDLResult) -> m CDDLResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
rule m (CTree MonoRef)
-> (CTree MonoRef -> m (Rule -> CDDLResult))
-> m (Rule -> CDDLResult)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      -- a = any
      Postlude PTerm
PTAny -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid
      -- a = bytes
      Postlude PTerm
PTBytes -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid
      -- a = h'123456'
      Literal (Value (VBytes ByteString
bs') Comment
_) -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Rule -> CDDLResult) -> m (Rule -> CDDLResult))
-> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a b. (a -> b) -> a -> b
$ Bool -> Rule -> CDDLResult
check (Bool -> Rule -> CDDLResult) -> Bool -> Rule -> CDDLResult
forall a b. (a -> b) -> a -> b
$ ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
bs'
      -- a = foo .ctrl bar
      Control CtlOp
op Rule
tgt Rule
ctrl -> (Rule -> m CDDLResult)
-> CtlOp
-> Rule
-> Rule
-> (CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ()))
-> m (Rule -> CDDLResult)
forall (m :: * -> *).
Monad m =>
(Rule -> m CDDLResult)
-> CtlOp
-> Rule
-> Rule
-> (CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ()))
-> m (Rule -> CDDLResult)
ctrlDispatch (ByteString -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
ByteString -> Rule -> m CDDLResult
validateBytes ByteString
bs) CtlOp
op Rule
tgt Rule
ctrl (ByteString -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
forall (m :: * -> *).
MonadReader CDDL m =>
ByteString -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
controlBytes ByteString
bs)
      -- a = foo / bar
      Choice NonEmpty Rule
opts -> (Rule -> m CDDLResult) -> NonEmpty Rule -> m (Rule -> CDDLResult)
forall (m :: * -> *).
Monad m =>
(Rule -> m CDDLResult) -> NonEmpty Rule -> m (Rule -> CDDLResult)
validateChoice (ByteString -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
ByteString -> Rule -> m CDDLResult
validateBytes ByteString
bs) NonEmpty Rule
opts
      CTree MonoRef
_ -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
UnapplicableRule

-- | Controls for byte strings
controlBytes ::
  forall m.
  MonadReader CDDL m => BS.ByteString -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
controlBytes :: forall (m :: * -> *).
MonadReader CDDL m =>
ByteString -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
controlBytes ByteString
bs CtlOp
Size Rule
ctrl =
  Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
ctrl m (CTree MonoRef)
-> (CTree MonoRef -> m (Either (Maybe CBORTermResult) ()))
-> m (Either (Maybe CBORTermResult) ())
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Literal (Value (VUInt (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
sz)) Comment
_) -> Either (Maybe CBORTermResult) ()
-> m (Either (Maybe CBORTermResult) ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Maybe CBORTermResult) ()
 -> m (Either (Maybe CBORTermResult) ()))
-> Either (Maybe CBORTermResult) ()
-> m (Either (Maybe CBORTermResult) ())
forall a b. (a -> b) -> a -> b
$ 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 ((,) (CTree MonoRef -> CTree MonoRef -> (CTree MonoRef, CTree MonoRef))
-> m (CTree MonoRef)
-> m (CTree MonoRef -> (CTree MonoRef, CTree MonoRef))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
low m (CTree MonoRef -> (CTree MonoRef, CTree MonoRef))
-> m (CTree MonoRef) -> m (CTree MonoRef, CTree MonoRef)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
high)
            m (CTree MonoRef, CTree MonoRef)
-> ((CTree MonoRef, CTree MonoRef)
    -> Either (Maybe CBORTermResult) ())
-> m (Either (Maybe CBORTermResult) ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> ((CTree MonoRef, CTree MonoRef) -> Bool)
-> (CTree MonoRef, CTree MonoRef)
-> Either (Maybe CBORTermResult) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
              (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
controlBytes ByteString
bs CtlOp
Bits Rule
ctrl = do
  [Word64]
indices <-
    Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
ctrl m (CTree MonoRef) -> (CTree MonoRef -> m [Word64]) -> m [Word64]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Literal (Value (VUInt Word64
i') Comment
_) -> [Word64] -> m [Word64]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Word64
i']
      Choice NonEmpty Rule
nodes -> NonEmpty Rule -> m [Word64]
forall (m :: * -> *).
MonadReader CDDL m =>
NonEmpty Rule -> m [Word64]
getIndicesOfChoice NonEmpty Rule
nodes
      Range Rule
ff Rule
tt RangeBound
incl -> Rule -> Rule -> RangeBound -> m [Word64]
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> Rule -> RangeBound -> m [Word64]
getIndicesOfRange Rule
ff Rule
tt RangeBound
incl
      Enum Rule
g -> Rule -> m [Word64]
forall (m :: * -> *). MonadReader CDDL m => Rule -> m [Word64]
getIndicesOfEnum Rule
g
  Either (Maybe CBORTermResult) ()
-> m (Either (Maybe CBORTermResult) ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Maybe CBORTermResult) ()
 -> m (Either (Maybe CBORTermResult) ()))
-> Either (Maybe CBORTermResult) ()
-> m (Either (Maybe CBORTermResult) ())
forall a b. (a -> b) -> a -> b
$ 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 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) ->
      Term -> Rule -> m CBORTermResult
forall (m :: * -> *).
MonadReader CDDL m =>
Term -> Rule -> m CBORTermResult
validateTerm Term
term Rule
ctrl m CBORTermResult
-> (CBORTermResult -> m (Either (Maybe CBORTermResult) ()))
-> m (Either (Maybe CBORTermResult) ())
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        CBORTermResult Term
_ (Valid Rule
_) -> Either (Maybe CBORTermResult) ()
-> m (Either (Maybe CBORTermResult) ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Maybe CBORTermResult) ()
 -> m (Either (Maybe CBORTermResult) ()))
-> Either (Maybe CBORTermResult) ()
-> m (Either (Maybe CBORTermResult) ())
forall a b. (a -> b) -> a -> b
$ () -> Either (Maybe CBORTermResult) ()
forall a b. b -> Either a b
Right ()
        CBORTermResult
err -> Either (Maybe CBORTermResult) ()
-> m (Either (Maybe CBORTermResult) ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Maybe CBORTermResult) ()
 -> m (Either (Maybe CBORTermResult) ()))
-> Either (Maybe CBORTermResult) ()
-> m (Either (Maybe CBORTermResult) ())
forall a b. (a -> b) -> a -> b
$ 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
controlBytes 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) ->
      Term -> Rule -> m CBORTermResult
forall (m :: * -> *).
MonadReader CDDL m =>
Term -> Rule -> m CBORTermResult
validateTerm ([Term] -> Term
TList [Term]
terms) (CTree MonoRef -> Rule
forall a. a -> MonoRef a
MIt ([Rule] -> CTree MonoRef
forall (f :: * -> *). [Node f] -> CTree f
Array [CTree MonoRef -> Rule
forall a. a -> MonoRef a
MIt (Rule -> OccurrenceIndicator -> CTree MonoRef
forall (f :: * -> *). Node f -> OccurrenceIndicator -> CTree f
Occur Rule
ctrl OccurrenceIndicator
OIZeroOrMore)])) m CBORTermResult
-> (CBORTermResult -> m (Either (Maybe CBORTermResult) ()))
-> m (Either (Maybe CBORTermResult) ())
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        CBORTermResult Term
_ (Valid Rule
_) -> Either (Maybe CBORTermResult) ()
-> m (Either (Maybe CBORTermResult) ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Maybe CBORTermResult) ()
 -> m (Either (Maybe CBORTermResult) ()))
-> Either (Maybe CBORTermResult) ()
-> m (Either (Maybe CBORTermResult) ())
forall a b. (a -> b) -> a -> b
$ () -> Either (Maybe CBORTermResult) ()
forall a b. b -> Either a b
Right ()
        CBORTermResult Term
_ CDDLResult
err -> [Char] -> m (Either (Maybe CBORTermResult) ())
forall a. HasCallStack => [Char] -> a
error ([Char] -> m (Either (Maybe CBORTermResult) ()))
-> [Char] -> m (Either (Maybe CBORTermResult) ())
forall a b. (a -> b) -> a -> b
$ CDDLResult -> [Char]
forall a. Show a => a -> [Char]
show CDDLResult
err

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

-- | Validating text strings
validateText ::
  MonadReader CDDL m =>
  T.Text -> Rule -> m CDDLResult
validateText :: forall (m :: * -> *).
MonadReader CDDL m =>
Text -> Rule -> m CDDLResult
validateText Text
txt Rule
rule =
  ((Rule -> CDDLResult) -> Rule -> CDDLResult
forall a b. (a -> b) -> a -> b
$ Rule
rule) ((Rule -> CDDLResult) -> CDDLResult)
-> m (Rule -> CDDLResult) -> m CDDLResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
rule m (CTree MonoRef)
-> (CTree MonoRef -> m (Rule -> CDDLResult))
-> m (Rule -> CDDLResult)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      -- a = any
      Postlude PTerm
PTAny -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid
      -- a = text
      Postlude PTerm
PTText -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid
      -- a = "foo"
      Literal (Value (VText Text
txt') Comment
_) -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Rule -> CDDLResult) -> m (Rule -> CDDLResult))
-> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a b. (a -> b) -> a -> b
$ Bool -> Rule -> CDDLResult
check (Bool -> Rule -> CDDLResult) -> Bool -> Rule -> CDDLResult
forall a b. (a -> b) -> a -> b
$ Text
txt Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
txt'
      -- a = foo .ctrl bar
      Control CtlOp
op Rule
tgt Rule
ctrl -> (Rule -> m CDDLResult)
-> CtlOp
-> Rule
-> Rule
-> (CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ()))
-> m (Rule -> CDDLResult)
forall (m :: * -> *).
Monad m =>
(Rule -> m CDDLResult)
-> CtlOp
-> Rule
-> Rule
-> (CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ()))
-> m (Rule -> CDDLResult)
ctrlDispatch (Text -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
Text -> Rule -> m CDDLResult
validateText Text
txt) CtlOp
op Rule
tgt Rule
ctrl (Text -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
forall (m :: * -> *).
MonadReader CDDL m =>
Text -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
controlText Text
txt)
      -- a = foo / bar
      Choice NonEmpty Rule
opts -> (Rule -> m CDDLResult) -> NonEmpty Rule -> m (Rule -> CDDLResult)
forall (m :: * -> *).
Monad m =>
(Rule -> m CDDLResult) -> NonEmpty Rule -> m (Rule -> CDDLResult)
validateChoice (Text -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
Text -> Rule -> m CDDLResult
validateText Text
txt) NonEmpty Rule
opts
      CTree MonoRef
_ -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
UnapplicableRule

-- | Controls for text strings
controlText :: MonadReader CDDL m => T.Text -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
controlText :: forall (m :: * -> *).
MonadReader CDDL m =>
Text -> CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
controlText Text
bs CtlOp
Size Rule
ctrl =
  Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
ctrl m (CTree MonoRef)
-> (CTree MonoRef -> m (Either (Maybe CBORTermResult) ()))
-> m (Either (Maybe CBORTermResult) ())
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Literal (Value (VUInt (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
sz)) Comment
_) -> Either (Maybe CBORTermResult) ()
-> m (Either (Maybe CBORTermResult) ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Maybe CBORTermResult) ()
 -> m (Either (Maybe CBORTermResult) ()))
-> Either (Maybe CBORTermResult) ()
-> m (Either (Maybe CBORTermResult) ())
forall a b. (a -> b) -> a -> b
$ 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 ->
      ((,) (CTree MonoRef -> CTree MonoRef -> (CTree MonoRef, CTree MonoRef))
-> m (CTree MonoRef)
-> m (CTree MonoRef -> (CTree MonoRef, CTree MonoRef))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
ff m (CTree MonoRef -> (CTree MonoRef, CTree MonoRef))
-> m (CTree MonoRef) -> m (CTree MonoRef, CTree MonoRef)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
tt)
        m (CTree MonoRef, CTree MonoRef)
-> ((CTree MonoRef, CTree MonoRef)
    -> Either (Maybe CBORTermResult) ())
-> m (Either (Maybe CBORTermResult) ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> ((CTree MonoRef, CTree MonoRef) -> Bool)
-> (CTree MonoRef, CTree MonoRef)
-> Either (Maybe CBORTermResult) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
          (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)
controlText Text
s CtlOp
Regexp Rule
ctrl =
  Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
ctrl
    m (CTree MonoRef)
-> (CTree MonoRef -> Either (Maybe CBORTermResult) ())
-> m (Either (Maybe CBORTermResult) ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bool -> Either (Maybe CBORTermResult) ()
boolCtrl (Bool -> Either (Maybe CBORTermResult) ())
-> (CTree MonoRef -> Bool)
-> CTree MonoRef
-> Either (Maybe CBORTermResult) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      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'

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

-- | Validating a `TTagged`
validateTagged ::
  MonadReader CDDL m =>
  Word64 -> Term -> Rule -> m CDDLResult
validateTagged :: forall (m :: * -> *).
MonadReader CDDL m =>
Word64 -> Term -> Rule -> m CDDLResult
validateTagged Word64
tag Term
term Rule
rule =
  ((Rule -> CDDLResult) -> Rule -> CDDLResult
forall a b. (a -> b) -> a -> b
$ Rule
rule) ((Rule -> CDDLResult) -> CDDLResult)
-> m (Rule -> CDDLResult) -> m CDDLResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
rule m (CTree MonoRef)
-> (CTree MonoRef -> m (Rule -> CDDLResult))
-> m (Rule -> CDDLResult)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Postlude PTerm
PTAny -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid
      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
            m CDDL
forall r (m :: * -> *). MonadReader r m => m r
ask m CDDL
-> (CDDL -> m (Rule -> CDDLResult)) -> m (Rule -> CDDLResult)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CDDL
cddl ->
              case Reader CDDL CBORTermResult -> CDDL -> CBORTermResult
forall r a. Reader r a -> r -> a
runReader (Term -> Rule -> Reader CDDL CBORTermResult
forall (m :: * -> *).
MonadReader CDDL m =>
Term -> Rule -> m CBORTermResult
validateTerm Term
term Rule
rule') CDDL
cddl of
                CBORTermResult Term
_ (Valid Rule
_) -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid
                CBORTermResult
err -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Rule -> CDDLResult) -> m (Rule -> CDDLResult))
-> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a b. (a -> b) -> a -> b
$ \Rule
r -> Rule -> Either Word64 CBORTermResult -> CDDLResult
InvalidTagged Rule
r (CBORTermResult -> Either Word64 CBORTermResult
forall a b. b -> Either a b
Right CBORTermResult
err)
          else (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Rule -> CDDLResult) -> m (Rule -> CDDLResult))
-> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a b. (a -> b) -> a -> b
$ \Rule
r -> Rule -> Either Word64 CBORTermResult -> CDDLResult
InvalidTagged Rule
r (Word64 -> Either Word64 CBORTermResult
forall a b. a -> Either a b
Left Word64
tag)
      Choice NonEmpty Rule
opts -> (Rule -> m CDDLResult) -> NonEmpty Rule -> m (Rule -> CDDLResult)
forall (m :: * -> *).
Monad m =>
(Rule -> m CDDLResult) -> NonEmpty Rule -> m (Rule -> CDDLResult)
validateChoice (Word64 -> Term -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
Word64 -> Term -> Rule -> m CDDLResult
validateTagged Word64
tag Term
term) NonEmpty Rule
opts
      CTree MonoRef
_ -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
UnapplicableRule

--------------------------------------------------------------------------------
-- Collection helpers

-- | Groups might contain enums, or unwraps inside. This resolves all those to
-- the top level of the group.
flattenGroup :: CDDL -> [Rule] -> [Rule]
flattenGroup :: CDDL -> [Rule] -> [Rule]
flattenGroup CDDL
cddl [Rule]
nodes =
  [[Rule]] -> [Rule]
forall a. Monoid a => [a] -> a
mconcat
    [ case CDDL -> Rule -> CTree MonoRef
resolveIfRef CDDL
cddl Rule
rule of
        Literal {} -> [Rule
rule]
        Postlude {} -> [Rule
rule]
        Map {} -> [Rule
rule]
        Array {} -> [Rule
rule]
        Choice {} -> [Rule
rule]
        KV {} -> [Rule
rule]
        Occur {} -> [Rule
rule]
        Range {} -> [Rule
rule]
        Control {} -> [Rule
rule]
        Enum Rule
e -> case CDDL -> Rule -> CTree MonoRef
resolveIfRef CDDL
cddl Rule
e of
          Group [Rule]
g -> CDDL -> [Rule] -> [Rule]
flattenGroup CDDL
cddl [Rule]
g
          CTree MonoRef
_ -> [Char] -> [Rule]
forall a. HasCallStack => [Char] -> a
error [Char]
"Malformed cddl"
        Unwrap Rule
g -> case CDDL -> Rule -> CTree MonoRef
resolveIfRef CDDL
cddl Rule
g of
          Map [Rule]
n -> CDDL -> [Rule] -> [Rule]
flattenGroup CDDL
cddl [Rule]
n
          Array [Rule]
n -> CDDL -> [Rule] -> [Rule]
flattenGroup CDDL
cddl [Rule]
n
          Tag Word64
_ Rule
n -> [Rule
n]
          CTree MonoRef
_ -> [Char] -> [Rule]
forall a. HasCallStack => [Char] -> a
error [Char]
"Malformed cddl"
        Tag {} -> [Rule
rule]
        Group [Rule]
g -> CDDL -> [Rule] -> [Rule]
flattenGroup CDDL
cddl [Rule]
g
    | Rule
rule <- [Rule]
nodes
    ]

-- | Expand rules to reach exactly the wanted length, which must be the number
-- of items in the container. For example, if we want to validate 3 elements,
-- and we have the following CDDL:
--
-- > a = [* int, * bool]
--
-- this will be expanded to `[int, int, int], [int, int, bool], [int, bool,
-- bool], [bool, bool, bool]`.
--
-- Essentially the rules we will parse is the choice among the expansions of the
-- original rules.
expandRules :: Int -> [Rule] -> Reader CDDL [[Rule]]
expandRules :: Int -> [Rule] -> Reader CDDL [[Rule]]
expandRules Int
remainingLen []
  | Int
remainingLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 = [[Rule]] -> Reader CDDL [[Rule]]
forall a. a -> ReaderT CDDL Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
expandRules Int
_ [] = [[Rule]] -> Reader CDDL [[Rule]]
forall a. a -> ReaderT CDDL Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[]]
expandRules Int
remainingLen [Rule]
_
  | Int
remainingLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = [[Rule]] -> Reader CDDL [[Rule]]
forall a. a -> ReaderT CDDL Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  | Int
remainingLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = [[Rule]] -> Reader CDDL [[Rule]]
forall a. a -> ReaderT CDDL Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[]]
expandRules Int
remainingLen (Rule
x : [Rule]
xs) = do
  [[Rule]]
y <- Int -> Rule -> Reader CDDL [[Rule]]
expandRule Int
remainingLen Rule
x
  [[[Rule]]] -> [[Rule]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    ([[[Rule]]] -> [[Rule]])
-> ReaderT CDDL Identity [[[Rule]]] -> Reader CDDL [[Rule]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Rule] -> Reader CDDL [[Rule]])
-> [[Rule]] -> ReaderT CDDL Identity [[[Rule]]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM
      ( \[Rule]
y' -> do
          [[Rule]]
suffixes <- Int -> [Rule] -> Reader CDDL [[Rule]]
expandRules (Int
remainingLen Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Rule] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Rule]
y') [Rule]
xs
          [[Rule]] -> Reader CDDL [[Rule]]
forall a. a -> ReaderT CDDL Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Rule]
y' [Rule] -> [Rule] -> [Rule]
forall a. [a] -> [a] -> [a]
++ [Rule]
ys' | [Rule]
ys' <- [[Rule]]
suffixes]
      )
      [[Rule]]
y

expandRule :: Int -> Rule -> Reader CDDL [[Rule]]
expandRule :: Int -> Rule -> Reader CDDL [[Rule]]
expandRule Int
maxLen Rule
_
  | Int
maxLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = [[Rule]] -> Reader CDDL [[Rule]]
forall a. a -> ReaderT CDDL Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
expandRule Int
maxLen Rule
rule =
  Rule -> ReaderT CDDL Identity (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
rule ReaderT CDDL Identity (CTree MonoRef)
-> (CTree MonoRef -> Reader CDDL [[Rule]]) -> Reader CDDL [[Rule]]
forall a b.
ReaderT CDDL Identity a
-> (a -> ReaderT CDDL Identity b) -> ReaderT CDDL Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Occur Rule
o OccurrenceIndicator
OIOptional -> [[Rule]] -> Reader CDDL [[Rule]]
forall a. a -> ReaderT CDDL Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Rule]] -> Reader CDDL [[Rule]])
-> [[Rule]] -> Reader CDDL [[Rule]]
forall a b. (a -> b) -> a -> b
$ [] [Rule] -> [[Rule]] -> [[Rule]]
forall a. a -> [a] -> [a]
: [[Rule
o] | Int
maxLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0]
    Occur Rule
o OccurrenceIndicator
OIZeroOrMore -> ([] :) ([[Rule]] -> [[Rule]])
-> Reader CDDL [[Rule]] -> Reader CDDL [[Rule]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Rule -> Reader CDDL [[Rule]]
expandRule Int
maxLen (CTree MonoRef -> Rule
forall a. a -> MonoRef a
MIt (Rule -> OccurrenceIndicator -> CTree MonoRef
forall (f :: * -> *). Node f -> OccurrenceIndicator -> CTree f
Occur Rule
o OccurrenceIndicator
OIOneOrMore))
    Occur Rule
o OccurrenceIndicator
OIOneOrMore ->
      if Int
maxLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
        then ([Rule
o] :) ([[Rule]] -> [[Rule]])
-> ([[Rule]] -> [[Rule]]) -> [[Rule]] -> [[Rule]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Rule] -> [Rule]) -> [[Rule]] -> [[Rule]]
forall a b. (a -> b) -> [a] -> [b]
map (Rule
o :) ([[Rule]] -> [[Rule]])
-> Reader CDDL [[Rule]] -> Reader CDDL [[Rule]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Rule -> Reader CDDL [[Rule]]
expandRule (Int
maxLen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (CTree MonoRef -> Rule
forall a. a -> MonoRef a
MIt (Rule -> OccurrenceIndicator -> CTree MonoRef
forall (f :: * -> *). Node f -> OccurrenceIndicator -> CTree f
Occur Rule
o OccurrenceIndicator
OIOneOrMore))
        else [[Rule]] -> Reader CDDL [[Rule]]
forall a. a -> ReaderT CDDL Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Occur Rule
o (OIBounded Maybe Word64
low Maybe Word64
high) -> case (Maybe Word64
low, Maybe Word64
high) of
      (Maybe Word64
Nothing, Maybe Word64
Nothing) -> Int -> Rule -> Reader CDDL [[Rule]]
expandRule Int
maxLen (CTree MonoRef -> Rule
forall a. a -> MonoRef a
MIt (Rule -> OccurrenceIndicator -> CTree MonoRef
forall (f :: * -> *). Node f -> OccurrenceIndicator -> CTree f
Occur Rule
o OccurrenceIndicator
OIZeroOrMore))
      (Just (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
low'), Maybe Word64
Nothing) ->
        if Int
maxLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
low'
          then ([Rule] -> [Rule]) -> [[Rule]] -> [[Rule]]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Rule -> [Rule]
forall a. Int -> a -> [a]
replicate Int
low' Rule
o ++) ([[Rule]] -> [[Rule]])
-> Reader CDDL [[Rule]] -> Reader CDDL [[Rule]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Rule -> Reader CDDL [[Rule]]
expandRule (Int
maxLen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
low') (CTree MonoRef -> Rule
forall a. a -> MonoRef a
MIt (Rule -> OccurrenceIndicator -> CTree MonoRef
forall (f :: * -> *). Node f -> OccurrenceIndicator -> CTree f
Occur Rule
o OccurrenceIndicator
OIZeroOrMore))
          else [[Rule]] -> Reader CDDL [[Rule]]
forall a. a -> ReaderT CDDL Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      (Maybe Word64
Nothing, Just (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
high')) ->
        [[Rule]] -> Reader CDDL [[Rule]]
forall a. a -> ReaderT CDDL Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Int -> Rule -> [Rule]
forall a. Int -> a -> [a]
replicate Int
n Rule
o | Int
n <- [Int
0 .. Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
maxLen Int
high']]
      (Just (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
low'), Just (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
high')) ->
        if Int
maxLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
low'
          then [[Rule]] -> Reader CDDL [[Rule]]
forall a. a -> ReaderT CDDL Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Int -> Rule -> [Rule]
forall a. Int -> a -> [a]
replicate Int
n Rule
o | Int
n <- [Int
low' .. Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
maxLen Int
high']]
          else [[Rule]] -> Reader CDDL [[Rule]]
forall a. a -> ReaderT CDDL Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    CTree MonoRef
_ -> [[Rule]] -> Reader CDDL [[Rule]]
forall a. a -> ReaderT CDDL Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Rule
rule | Int
maxLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0]]

-- | Which rules are optional?
isOptional :: MonadReader CDDL m => Rule -> m Bool
isOptional :: forall (m :: * -> *). MonadReader CDDL m => Rule -> m Bool
isOptional Rule
rule =
  Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
rule
    m (CTree MonoRef) -> (CTree MonoRef -> Bool) -> m Bool
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
      Occur Rule
_ OccurrenceIndicator
OIOptional -> Bool
True
      Occur Rule
_ OccurrenceIndicator
OIZeroOrMore -> Bool
True
      Occur Rule
_ (OIBounded Maybe Word64
Nothing Maybe Word64
_) -> Bool
True
      Occur Rule
_ (OIBounded (Just Word64
0) Maybe Word64
_) -> Bool
True
      CTree MonoRef
_ -> Bool
False

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

validateListWithExpandedRules ::
  forall m.
  MonadReader CDDL m =>
  [Term] -> [Rule] -> m [(Rule, CBORTermResult)]
validateListWithExpandedRules :: forall (m :: * -> *).
MonadReader CDDL m =>
[Term] -> [Rule] -> m [(Rule, CBORTermResult)]
validateListWithExpandedRules [Term]
terms [Rule]
rules =
  [(Term, Rule)] -> m [(Rule, CBORTermResult)]
go ([Term] -> [Rule] -> [(Term, Rule)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Term]
terms [Rule]
rules)
  where
    go ::
      [(Term, Rule)] -> m [(Rule, CBORTermResult)]
    go :: [(Term, Rule)] -> m [(Rule, CBORTermResult)]
go [] = [(Rule, CBORTermResult)] -> m [(Rule, CBORTermResult)]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    go ((Term
t, Rule
r) : [(Term, Rule)]
ts) =
      Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
r m (CTree MonoRef)
-> (CTree MonoRef -> m [(Rule, CBORTermResult)])
-> m [(Rule, CBORTermResult)]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        -- Should the rule be a KV, then we validate the rule for the value
        KV Rule
_ Rule
v Bool
_ ->
          -- We need to do this juggling because validateTerm has a different
          -- error type
          m CDDL
forall r (m :: * -> *). MonadReader r m => m r
ask m CDDL
-> (CDDL -> m [(Rule, CBORTermResult)])
-> m [(Rule, CBORTermResult)]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CDDL
cddl ->
            case Reader CDDL CBORTermResult -> CDDL -> CBORTermResult
forall r a. Reader r a -> r -> a
runReader (Term -> Rule -> Reader CDDL CBORTermResult
forall (m :: * -> *).
MonadReader CDDL m =>
Term -> Rule -> m CBORTermResult
validateTerm Term
t Rule
v) CDDL
cddl of
              ok :: CBORTermResult
ok@(CBORTermResult Term
_ (Valid Rule
_)) -> ((Rule
r, CBORTermResult
ok) :) ([(Rule, CBORTermResult)] -> [(Rule, CBORTermResult)])
-> m [(Rule, CBORTermResult)] -> m [(Rule, CBORTermResult)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Term, Rule)] -> m [(Rule, CBORTermResult)]
go [(Term, Rule)]
ts
              CBORTermResult
err -> [(Rule, CBORTermResult)] -> m [(Rule, CBORTermResult)]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Rule
r, CBORTermResult
err)]
        CTree MonoRef
_ ->
          m CDDL
forall r (m :: * -> *). MonadReader r m => m r
ask m CDDL
-> (CDDL -> m [(Rule, CBORTermResult)])
-> m [(Rule, CBORTermResult)]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CDDL
cddl ->
            case Reader CDDL CBORTermResult -> CDDL -> CBORTermResult
forall r a. Reader r a -> r -> a
runReader (Term -> Rule -> Reader CDDL CBORTermResult
forall (m :: * -> *).
MonadReader CDDL m =>
Term -> Rule -> m CBORTermResult
validateTerm Term
t Rule
r) CDDL
cddl of
              ok :: CBORTermResult
ok@(CBORTermResult Term
_ (Valid Rule
_)) -> ((Rule
r, CBORTermResult
ok) :) ([(Rule, CBORTermResult)] -> [(Rule, CBORTermResult)])
-> m [(Rule, CBORTermResult)] -> m [(Rule, CBORTermResult)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Term, Rule)] -> m [(Rule, CBORTermResult)]
go [(Term, Rule)]
ts
              CBORTermResult
err -> [(Rule, CBORTermResult)] -> m [(Rule, CBORTermResult)]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Rule
r, CBORTermResult
err)]

validateExpandedList ::
  forall m.
  MonadReader CDDL m =>
  [Term] ->
  [[Rule]] ->
  m (Rule -> CDDLResult)
validateExpandedList :: forall (m :: * -> *).
MonadReader CDDL m =>
[Term] -> [[Rule]] -> m (Rule -> CDDLResult)
validateExpandedList [Term]
terms [[Rule]]
rules = [[Rule]] -> m (Rule -> CDDLResult)
go [[Rule]]
rules
  where
    go :: [[Rule]] -> m (Rule -> CDDLResult)
    go :: [[Rule]] -> m (Rule -> CDDLResult)
go [] = (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Rule -> CDDLResult) -> m (Rule -> CDDLResult))
-> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a b. (a -> b) -> a -> b
$ \Rule
r -> Rule -> [[Rule]] -> [[(Rule, CBORTermResult)]] -> CDDLResult
ListExpansionFail Rule
r [[Rule]]
rules []
    go ([Rule]
choice : [[Rule]]
choices) = do
      [(Rule, CBORTermResult)]
res <- [Term] -> [Rule] -> m [(Rule, CBORTermResult)]
forall (m :: * -> *).
MonadReader CDDL m =>
[Term] -> [Rule] -> m [(Rule, CBORTermResult)]
validateListWithExpandedRules [Term]
terms [Rule]
choice
      case [(Rule, CBORTermResult)]
res of
        [] -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid
        [(Rule, CBORTermResult)]
_ -> case [(Rule, CBORTermResult)] -> (Rule, CBORTermResult)
forall a. HasCallStack => [a] -> a
last [(Rule, CBORTermResult)]
res of
          (Rule
_, CBORTermResult Term
_ (Valid Rule
_)) -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid
          (Rule, CBORTermResult)
_ ->
            [[Rule]] -> m (Rule -> CDDLResult)
go [[Rule]]
choices
              m (Rule -> CDDLResult)
-> ((Rule -> CDDLResult) -> m (Rule -> CDDLResult))
-> m (Rule -> CDDLResult)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ( \case
                      Valid Rule
_ -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid
                      ListExpansionFail Rule
_ [[Rule]]
_ [[(Rule, CBORTermResult)]]
errors -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Rule -> CDDLResult) -> m (Rule -> CDDLResult))
-> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a b. (a -> b) -> a -> b
$ \Rule
r -> Rule -> [[Rule]] -> [[(Rule, CBORTermResult)]] -> CDDLResult
ListExpansionFail Rule
r [[Rule]]
rules ([(Rule, CBORTermResult)]
res [(Rule, CBORTermResult)]
-> [[(Rule, CBORTermResult)]] -> [[(Rule, CBORTermResult)]]
forall a. a -> [a] -> [a]
: [[(Rule, CBORTermResult)]]
errors)
                  )
                (CDDLResult -> m (Rule -> CDDLResult))
-> ((Rule -> CDDLResult) -> CDDLResult)
-> (Rule -> CDDLResult)
-> m (Rule -> CDDLResult)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Rule -> CDDLResult) -> Rule -> CDDLResult
forall a b. (a -> b) -> a -> b
$ Rule
dummyRule)

validateList ::
  MonadReader CDDL m => [Term] -> Rule -> m CDDLResult
validateList :: forall (m :: * -> *).
MonadReader CDDL m =>
[Term] -> Rule -> m CDDLResult
validateList [Term]
terms Rule
rule =
  ((Rule -> CDDLResult) -> Rule -> CDDLResult
forall a b. (a -> b) -> a -> b
$ Rule
rule) ((Rule -> CDDLResult) -> CDDLResult)
-> m (Rule -> CDDLResult) -> m CDDLResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
rule m (CTree MonoRef)
-> (CTree MonoRef -> m (Rule -> CDDLResult))
-> m (Rule -> CDDLResult)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Postlude PTerm
PTAny -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid
      Array [Rule]
rules ->
        case [Term]
terms of
          [] -> m Bool
-> m (Rule -> CDDLResult)
-> m (Rule -> CDDLResult)
-> m (Rule -> CDDLResult)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> m [Bool] -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Rule -> m Bool) -> [Rule] -> m [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Rule -> m Bool
forall (m :: * -> *). MonadReader CDDL m => Rule -> m Bool
isOptional [Rule]
rules) ((Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid) ((Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
InvalidRule)
          [Term]
_ ->
            m CDDL
forall r (m :: * -> *). MonadReader r m => m r
ask m CDDL
-> (CDDL -> m (Rule -> CDDLResult)) -> m (Rule -> CDDLResult)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CDDL
cddl ->
              let sequencesOfRules :: [[Rule]]
sequencesOfRules =
                    Reader CDDL [[Rule]] -> CDDL -> [[Rule]]
forall r a. Reader r a -> r -> a
runReader (Int -> [Rule] -> Reader CDDL [[Rule]]
expandRules ([Term] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Term]
terms) ([Rule] -> Reader CDDL [[Rule]]) -> [Rule] -> Reader CDDL [[Rule]]
forall a b. (a -> b) -> a -> b
$ CDDL -> [Rule] -> [Rule]
flattenGroup CDDL
cddl [Rule]
rules) CDDL
cddl
               in [Term] -> [[Rule]] -> m (Rule -> CDDLResult)
forall (m :: * -> *).
MonadReader CDDL m =>
[Term] -> [[Rule]] -> m (Rule -> CDDLResult)
validateExpandedList [Term]
terms [[Rule]]
sequencesOfRules
      Choice NonEmpty Rule
opts -> (Rule -> m CDDLResult) -> NonEmpty Rule -> m (Rule -> CDDLResult)
forall (m :: * -> *).
Monad m =>
(Rule -> m CDDLResult) -> NonEmpty Rule -> m (Rule -> CDDLResult)
validateChoice ([Term] -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
[Term] -> Rule -> m CDDLResult
validateList [Term]
terms) NonEmpty Rule
opts
      CTree MonoRef
_ -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
UnapplicableRule

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

validateMapWithExpandedRules ::
  forall m.
  MonadReader CDDL m =>
  [(Term, Term)] -> [Rule] -> m ([AMatchedItem], Maybe ANonMatchedItem)
validateMapWithExpandedRules :: forall (m :: * -> *).
MonadReader CDDL m =>
[(Term, Term)]
-> [Rule] -> m ([AMatchedItem], Maybe ANonMatchedItem)
validateMapWithExpandedRules =
  [(Term, Term)]
-> [Rule] -> m ([AMatchedItem], Maybe ANonMatchedItem)
go
  where
    go ::
      [(Term, Term)] ->
      [Rule] ->
      m ([AMatchedItem], Maybe ANonMatchedItem)
    go :: [(Term, Term)]
-> [Rule] -> m ([AMatchedItem], Maybe ANonMatchedItem)
go [] [] = ([AMatchedItem], Maybe ANonMatchedItem)
-> m ([AMatchedItem], Maybe ANonMatchedItem)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Maybe ANonMatchedItem
forall a. Maybe a
Nothing)
    go ((Term
tk, Term
tv) : [(Term, Term)]
ts) [Rule]
rs = do
      Term
-> Term
-> [Rule]
-> m (Either ANonMatchedItem (AMatchedItem, [Rule]))
go' Term
tk Term
tv [Rule]
rs m (Either ANonMatchedItem (AMatchedItem, [Rule]))
-> (Either ANonMatchedItem (AMatchedItem, [Rule])
    -> m ([AMatchedItem], Maybe ANonMatchedItem))
-> m ([AMatchedItem], Maybe ANonMatchedItem)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left ANonMatchedItem
tt -> ([AMatchedItem], Maybe ANonMatchedItem)
-> m ([AMatchedItem], Maybe ANonMatchedItem)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], ANonMatchedItem -> Maybe ANonMatchedItem
forall a. a -> Maybe a
Just ANonMatchedItem
tt)
        Right (AMatchedItem
res, [Rule]
rs') ->
          ([AMatchedItem] -> [AMatchedItem])
-> ([AMatchedItem], Maybe ANonMatchedItem)
-> ([AMatchedItem], Maybe ANonMatchedItem)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (AMatchedItem
res :) (([AMatchedItem], Maybe ANonMatchedItem)
 -> ([AMatchedItem], Maybe ANonMatchedItem))
-> m ([AMatchedItem], Maybe ANonMatchedItem)
-> m ([AMatchedItem], Maybe ANonMatchedItem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Term, Term)]
-> [Rule] -> m ([AMatchedItem], Maybe ANonMatchedItem)
go [(Term, Term)]
ts [Rule]
rs'

    -- For each pair of terms, try to find some rule that can be applied here,
    -- and returns the others if there is a succesful match.
    go' :: Term -> Term -> [Rule] -> m (Either ANonMatchedItem (AMatchedItem, [Rule]))
    go' :: Term
-> Term
-> [Rule]
-> m (Either ANonMatchedItem (AMatchedItem, [Rule]))
go' Term
tk Term
tv [] = Either ANonMatchedItem (AMatchedItem, [Rule])
-> m (Either ANonMatchedItem (AMatchedItem, [Rule]))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ANonMatchedItem (AMatchedItem, [Rule])
 -> m (Either ANonMatchedItem (AMatchedItem, [Rule])))
-> Either ANonMatchedItem (AMatchedItem, [Rule])
-> m (Either ANonMatchedItem (AMatchedItem, [Rule]))
forall a b. (a -> b) -> a -> b
$ ANonMatchedItem -> Either ANonMatchedItem (AMatchedItem, [Rule])
forall a b. a -> Either a b
Left (ANonMatchedItem -> Either ANonMatchedItem (AMatchedItem, [Rule]))
-> ANonMatchedItem -> Either ANonMatchedItem (AMatchedItem, [Rule])
forall a b. (a -> b) -> a -> b
$ Term
-> Term
-> [Either (Rule, CDDLResult) (Rule, CDDLResult, CDDLResult)]
-> ANonMatchedItem
ANonMatchedItem Term
tk Term
tv []
    go' Term
tk Term
tv (Rule
r : [Rule]
rs) =
      Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
r m (CTree MonoRef)
-> (CTree MonoRef
    -> m (Either ANonMatchedItem (AMatchedItem, [Rule])))
-> m (Either ANonMatchedItem (AMatchedItem, [Rule]))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        KV Rule
k Rule
v Bool
_ ->
          m CDDL
forall r (m :: * -> *). MonadReader r m => m r
ask m CDDL
-> (CDDL -> m (Either ANonMatchedItem (AMatchedItem, [Rule])))
-> m (Either ANonMatchedItem (AMatchedItem, [Rule]))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CDDL
cddl ->
            case Reader CDDL CBORTermResult -> CDDL -> CBORTermResult
forall r a. Reader r a -> r -> a
runReader (Term -> Rule -> Reader CDDL CBORTermResult
forall (m :: * -> *).
MonadReader CDDL m =>
Term -> Rule -> m CBORTermResult
validateTerm Term
tk Rule
k) CDDL
cddl of
              CBORTermResult Term
_ r1 :: CDDLResult
r1@(Valid Rule
_) -> case Reader CDDL CBORTermResult -> CDDL -> CBORTermResult
forall r a. Reader r a -> r -> a
runReader (Term -> Rule -> Reader CDDL CBORTermResult
forall (m :: * -> *).
MonadReader CDDL m =>
Term -> Rule -> m CBORTermResult
validateTerm Term
tv Rule
v) CDDL
cddl of
                CBORTermResult Term
_ (Valid Rule
_) -> Either ANonMatchedItem (AMatchedItem, [Rule])
-> m (Either ANonMatchedItem (AMatchedItem, [Rule]))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((AMatchedItem, [Rule])
-> Either ANonMatchedItem (AMatchedItem, [Rule])
forall a b. b -> Either a b
Right (Term -> Term -> Rule -> AMatchedItem
AMatchedItem Term
tk Term
tv Rule
r, [Rule]
rs))
                CBORTermResult Term
_ CDDLResult
r2 ->
                  (ANonMatchedItem -> ANonMatchedItem)
-> ((AMatchedItem, [Rule]) -> (AMatchedItem, [Rule]))
-> Either ANonMatchedItem (AMatchedItem, [Rule])
-> Either ANonMatchedItem (AMatchedItem, [Rule])
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (\ANonMatchedItem
anmi -> ANonMatchedItem
anmi {anmiResults = Right (r, r1, r2) : anmiResults anmi}) (([Rule] -> [Rule])
-> (AMatchedItem, [Rule]) -> (AMatchedItem, [Rule])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Rule
r :))
                    (Either ANonMatchedItem (AMatchedItem, [Rule])
 -> Either ANonMatchedItem (AMatchedItem, [Rule]))
-> m (Either ANonMatchedItem (AMatchedItem, [Rule]))
-> m (Either ANonMatchedItem (AMatchedItem, [Rule]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term
-> Term
-> [Rule]
-> m (Either ANonMatchedItem (AMatchedItem, [Rule]))
go' Term
tk Term
tv [Rule]
rs
              CBORTermResult Term
_ CDDLResult
r1 ->
                (ANonMatchedItem -> ANonMatchedItem)
-> ((AMatchedItem, [Rule]) -> (AMatchedItem, [Rule]))
-> Either ANonMatchedItem (AMatchedItem, [Rule])
-> Either ANonMatchedItem (AMatchedItem, [Rule])
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (\ANonMatchedItem
anmi -> ANonMatchedItem
anmi {anmiResults = Left (r, r1) : anmiResults anmi}) (([Rule] -> [Rule])
-> (AMatchedItem, [Rule]) -> (AMatchedItem, [Rule])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Rule
r :))
                  (Either ANonMatchedItem (AMatchedItem, [Rule])
 -> Either ANonMatchedItem (AMatchedItem, [Rule]))
-> m (Either ANonMatchedItem (AMatchedItem, [Rule]))
-> m (Either ANonMatchedItem (AMatchedItem, [Rule]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term
-> Term
-> [Rule]
-> m (Either ANonMatchedItem (AMatchedItem, [Rule]))
go' Term
tk Term
tv [Rule]
rs

validateExpandedMap ::
  forall m.
  MonadReader CDDL m =>
  [(Term, Term)] ->
  [[Rule]] ->
  m (Rule -> CDDLResult)
validateExpandedMap :: forall (m :: * -> *).
MonadReader CDDL m =>
[(Term, Term)] -> [[Rule]] -> m (Rule -> CDDLResult)
validateExpandedMap [(Term, Term)]
terms [[Rule]]
rules = [[Rule]] -> m (Rule -> CDDLResult)
go [[Rule]]
rules
  where
    go :: [[Rule]] -> m (Rule -> CDDLResult)
    go :: [[Rule]] -> m (Rule -> CDDLResult)
go [] = (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Rule -> CDDLResult) -> m (Rule -> CDDLResult))
-> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a b. (a -> b) -> a -> b
$ \Rule
r -> Rule
-> [[Rule]] -> [([AMatchedItem], ANonMatchedItem)] -> CDDLResult
MapExpansionFail Rule
r [[Rule]]
rules []
    go ([Rule]
choice : [[Rule]]
choices) = do
      ([AMatchedItem], Maybe ANonMatchedItem)
res <- [(Term, Term)]
-> [Rule] -> m ([AMatchedItem], Maybe ANonMatchedItem)
forall (m :: * -> *).
MonadReader CDDL m =>
[(Term, Term)]
-> [Rule] -> m ([AMatchedItem], Maybe ANonMatchedItem)
validateMapWithExpandedRules [(Term, Term)]
terms [Rule]
choice
      case ([AMatchedItem], Maybe ANonMatchedItem)
res of
        ([AMatchedItem]
_, Maybe ANonMatchedItem
Nothing) -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid
        ([AMatchedItem]
matches, Just ANonMatchedItem
notMatched) ->
          [[Rule]] -> m (Rule -> CDDLResult)
go [[Rule]]
choices
            m (Rule -> CDDLResult)
-> ((Rule -> CDDLResult) -> m (Rule -> CDDLResult))
-> m (Rule -> CDDLResult)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ( \case
                    Valid Rule
_ -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid
                    MapExpansionFail Rule
_ [[Rule]]
_ [([AMatchedItem], ANonMatchedItem)]
errors ->
                      (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Rule -> CDDLResult) -> m (Rule -> CDDLResult))
-> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a b. (a -> b) -> a -> b
$ \Rule
r -> Rule
-> [[Rule]] -> [([AMatchedItem], ANonMatchedItem)] -> CDDLResult
MapExpansionFail Rule
r [[Rule]]
rules (([AMatchedItem]
matches, ANonMatchedItem
notMatched) ([AMatchedItem], ANonMatchedItem)
-> [([AMatchedItem], ANonMatchedItem)]
-> [([AMatchedItem], ANonMatchedItem)]
forall a. a -> [a] -> [a]
: [([AMatchedItem], ANonMatchedItem)]
errors)
                )
              (CDDLResult -> m (Rule -> CDDLResult))
-> ((Rule -> CDDLResult) -> CDDLResult)
-> (Rule -> CDDLResult)
-> m (Rule -> CDDLResult)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Rule -> CDDLResult) -> Rule -> CDDLResult
forall a b. (a -> b) -> a -> b
$ Rule
dummyRule)

validateMap ::
  MonadReader CDDL m =>
  [(Term, Term)] -> Rule -> m CDDLResult
validateMap :: forall (m :: * -> *).
MonadReader CDDL m =>
[(Term, Term)] -> Rule -> m CDDLResult
validateMap [(Term, Term)]
terms Rule
rule =
  ((Rule -> CDDLResult) -> Rule -> CDDLResult
forall a b. (a -> b) -> a -> b
$ Rule
rule) ((Rule -> CDDLResult) -> CDDLResult)
-> m (Rule -> CDDLResult) -> m CDDLResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
rule m (CTree MonoRef)
-> (CTree MonoRef -> m (Rule -> CDDLResult))
-> m (Rule -> CDDLResult)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Postlude PTerm
PTAny -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid
      Map [Rule]
rules ->
        case [(Term, Term)]
terms of
          [] -> m Bool
-> m (Rule -> CDDLResult)
-> m (Rule -> CDDLResult)
-> m (Rule -> CDDLResult)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> m [Bool] -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Rule -> m Bool) -> [Rule] -> m [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Rule -> m Bool
forall (m :: * -> *). MonadReader CDDL m => Rule -> m Bool
isOptional [Rule]
rules) ((Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid) ((Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
InvalidRule)
          [(Term, Term)]
_ ->
            m CDDL
forall r (m :: * -> *). MonadReader r m => m r
ask m CDDL
-> (CDDL -> m (Rule -> CDDLResult)) -> m (Rule -> CDDLResult)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CDDL
cddl ->
              let sequencesOfRules :: [[Rule]]
sequencesOfRules =
                    Reader CDDL [[Rule]] -> CDDL -> [[Rule]]
forall r a. Reader r a -> r -> a
runReader (Int -> [Rule] -> Reader CDDL [[Rule]]
expandRules ([(Term, Term)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Term, Term)]
terms) ([Rule] -> Reader CDDL [[Rule]]) -> [Rule] -> Reader CDDL [[Rule]]
forall a b. (a -> b) -> a -> b
$ CDDL -> [Rule] -> [Rule]
flattenGroup CDDL
cddl [Rule]
rules) CDDL
cddl
               in [(Term, Term)] -> [[Rule]] -> m (Rule -> CDDLResult)
forall (m :: * -> *).
MonadReader CDDL m =>
[(Term, Term)] -> [[Rule]] -> m (Rule -> CDDLResult)
validateExpandedMap [(Term, Term)]
terms [[Rule]]
sequencesOfRules
      Choice NonEmpty Rule
opts -> (Rule -> m CDDLResult) -> NonEmpty Rule -> m (Rule -> CDDLResult)
forall (m :: * -> *).
Monad m =>
(Rule -> m CDDLResult) -> NonEmpty Rule -> m (Rule -> CDDLResult)
validateChoice ([(Term, Term)] -> Rule -> m CDDLResult
forall (m :: * -> *).
MonadReader CDDL m =>
[(Term, Term)] -> Rule -> m CDDLResult
validateMap [(Term, Term)]
terms) NonEmpty Rule
opts
      CTree MonoRef
_ -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
UnapplicableRule

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

validateChoice ::
  forall m. Monad m => (Rule -> m CDDLResult) -> NE.NonEmpty Rule -> m (Rule -> CDDLResult)
validateChoice :: forall (m :: * -> *).
Monad m =>
(Rule -> m CDDLResult) -> NonEmpty Rule -> m (Rule -> CDDLResult)
validateChoice Rule -> m CDDLResult
v NonEmpty Rule
rules = NonEmpty Rule -> m (Rule -> CDDLResult)
go NonEmpty Rule
rules
  where
    go :: NE.NonEmpty Rule -> m (Rule -> CDDLResult)
    go :: NonEmpty Rule -> m (Rule -> CDDLResult)
go (Rule
choice NE.:| [Rule]
xs) = do
      Rule -> m CDDLResult
v Rule
choice m CDDLResult
-> (CDDLResult -> m (Rule -> CDDLResult)) -> m (Rule -> CDDLResult)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Valid Rule
_ -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid
        CDDLResult
err -> case [Rule] -> Maybe (NonEmpty Rule)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Rule]
xs of
          Maybe (NonEmpty Rule)
Nothing -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Rule -> CDDLResult) -> m (Rule -> CDDLResult))
-> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a b. (a -> b) -> a -> b
$ \Rule
r -> Rule -> NonEmpty Rule -> NonEmpty (Rule, CDDLResult) -> CDDLResult
ChoiceFail Rule
r 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 ->
            NonEmpty Rule -> m (Rule -> CDDLResult)
go NonEmpty Rule
choices
              m (Rule -> CDDLResult)
-> ((Rule -> CDDLResult) -> m (Rule -> CDDLResult))
-> m (Rule -> CDDLResult)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ( \case
                      Valid Rule
_ -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
Valid
                      ChoiceFail Rule
_ NonEmpty Rule
_ NonEmpty (Rule, CDDLResult)
errors -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Rule -> CDDLResult) -> m (Rule -> CDDLResult))
-> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a b. (a -> b) -> a -> b
$ \Rule
r -> Rule -> NonEmpty Rule -> NonEmpty (Rule, CDDLResult) -> CDDLResult
ChoiceFail Rule
r 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 -> m (Rule -> CDDLResult))
-> ((Rule -> CDDLResult) -> CDDLResult)
-> (Rule -> CDDLResult)
-> m (Rule -> CDDLResult)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Rule -> CDDLResult) -> Rule -> CDDLResult
forall a b. (a -> b) -> a -> b
$ Rule
dummyRule)

dummyRule :: Rule
dummyRule :: Rule
dummyRule = Name -> Rule
forall a. Name -> MonoRef a
MRuleRef (Text -> Comment -> Name
Name Text
"dummy" Comment
forall a. Monoid a => a
mempty)

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

-- | Validate both rules
ctrlAnd ::
  Monad m =>
  (Rule -> m CDDLResult) -> Rule -> Rule -> m (Rule -> CDDLResult)
ctrlAnd :: forall (m :: * -> *).
Monad m =>
(Rule -> m CDDLResult) -> Rule -> Rule -> m (Rule -> CDDLResult)
ctrlAnd Rule -> m CDDLResult
v Rule
tgt Rule
ctrl =
  Rule -> m CDDLResult
v Rule
tgt m CDDLResult
-> (CDDLResult -> m (Rule -> CDDLResult)) -> m (Rule -> CDDLResult)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Valid Rule
_ ->
      Rule -> m CDDLResult
v Rule
ctrl m CDDLResult
-> (CDDLResult -> Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
        Valid Rule
_ -> Rule -> CDDLResult
Valid
        CDDLResult
_ -> (Rule -> Maybe CBORTermResult -> CDDLResult)
-> Maybe CBORTermResult -> Rule -> CDDLResult
forall a b c. (a -> b -> c) -> b -> a -> c
flip Rule -> Maybe CBORTermResult -> CDDLResult
InvalidControl Maybe CBORTermResult
forall a. Maybe a
Nothing
    CDDLResult
_ -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
InvalidRule

-- | Dispatch to the appropriate control
ctrlDispatch ::
  Monad m =>
  (Rule -> m CDDLResult) ->
  CtlOp ->
  Rule ->
  Rule ->
  (CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())) ->
  m (Rule -> CDDLResult)
ctrlDispatch :: forall (m :: * -> *).
Monad m =>
(Rule -> m CDDLResult)
-> CtlOp
-> Rule
-> Rule
-> (CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ()))
-> m (Rule -> CDDLResult)
ctrlDispatch Rule -> m CDDLResult
v CtlOp
And Rule
tgt Rule
ctrl CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
_ = (Rule -> m CDDLResult) -> Rule -> Rule -> m (Rule -> CDDLResult)
forall (m :: * -> *).
Monad m =>
(Rule -> m CDDLResult) -> Rule -> Rule -> m (Rule -> CDDLResult)
ctrlAnd Rule -> m CDDLResult
v Rule
tgt Rule
ctrl
ctrlDispatch Rule -> m CDDLResult
v CtlOp
Within Rule
tgt Rule
ctrl CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
_ = (Rule -> m CDDLResult) -> Rule -> Rule -> m (Rule -> CDDLResult)
forall (m :: * -> *).
Monad m =>
(Rule -> m CDDLResult) -> Rule -> Rule -> m (Rule -> CDDLResult)
ctrlAnd Rule -> m CDDLResult
v Rule
tgt Rule
ctrl
ctrlDispatch Rule -> m CDDLResult
v CtlOp
op Rule
tgt Rule
ctrl CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
vctrl =
  Rule -> m CDDLResult
v Rule
tgt m CDDLResult
-> (CDDLResult -> m (Rule -> CDDLResult)) -> m (Rule -> CDDLResult)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Valid Rule
_ ->
      CtlOp -> Rule -> m (Either (Maybe CBORTermResult) ())
vctrl CtlOp
op Rule
ctrl m (Either (Maybe CBORTermResult) ())
-> (Either (Maybe CBORTermResult) () -> Rule -> CDDLResult)
-> m (Rule -> CDDLResult)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
        Left Maybe CBORTermResult
err -> (Rule -> Maybe CBORTermResult -> CDDLResult)
-> Maybe CBORTermResult -> Rule -> CDDLResult
forall a b c. (a -> b -> c) -> b -> a -> c
flip Rule -> Maybe CBORTermResult -> CDDLResult
InvalidControl Maybe CBORTermResult
err
        Right () -> Rule -> CDDLResult
Valid
    CDDLResult
_ -> (Rule -> CDDLResult) -> m (Rule -> CDDLResult)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule -> CDDLResult
InvalidRule

-- | 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 :: MonadReader CDDL m => NE.NonEmpty Rule -> m [Word64]
getIndicesOfChoice :: forall (m :: * -> *).
MonadReader CDDL m =>
NonEmpty Rule -> m [Word64]
getIndicesOfChoice NonEmpty Rule
nodes =
  [[Word64]] -> [Word64]
forall a. Monoid a => [a] -> a
mconcat
    ([[Word64]] -> [Word64])
-> (NonEmpty [Word64] -> [[Word64]])
-> NonEmpty [Word64]
-> [Word64]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty [Word64] -> [[Word64]]
forall a. NonEmpty a -> [a]
NE.toList
    (NonEmpty [Word64] -> [Word64])
-> m (NonEmpty [Word64]) -> m [Word64]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Rule -> m [Word64]) -> NonEmpty Rule -> m (NonEmpty [Word64])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM
      ( Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule
          (Rule -> m (CTree MonoRef))
-> (CTree MonoRef -> m [Word64]) -> Rule -> m [Word64]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> ( \case
                  Literal (Value (VUInt Word64
v) Comment
_) -> [Word64] -> m [Word64]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Word64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
v]
                  KV Rule
_ Rule
v Bool
_ ->
                    Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
v
                      m (CTree MonoRef) -> (CTree MonoRef -> m [Word64]) -> m [Word64]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                        Literal (Value (VUInt Word64
v') Comment
_) -> [Word64] -> m [Word64]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Word64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
v']
                        CTree MonoRef
somethingElse ->
                          [Char] -> m [Word64]
forall a. HasCallStack => [Char] -> a
error ([Char] -> m [Word64]) -> [Char] -> m [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
<> CTree MonoRef -> [Char]
forall a. Show a => a -> [Char]
show CTree MonoRef
somethingElse
                  Range Rule
ff Rule
tt RangeBound
incl -> Rule -> Rule -> RangeBound -> m [Word64]
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> Rule -> RangeBound -> m [Word64]
getIndicesOfRange Rule
ff Rule
tt RangeBound
incl
                  Enum Rule
g -> Rule -> m [Word64]
forall (m :: * -> *). MonadReader CDDL m => Rule -> m [Word64]
getIndicesOfEnum Rule
g
                  CTree MonoRef
somethingElse ->
                    [Char] -> m [Word64]
forall a. HasCallStack => [Char] -> a
error ([Char] -> m [Word64]) -> [Char] -> m [Word64]
forall a b. (a -> b) -> a -> b
$
                      [Char]
"Malformed alternative in choice in .bits: "
                        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> CTree MonoRef -> [Char]
forall a. Show a => a -> [Char]
show CTree MonoRef
somethingElse
              )
      )
      NonEmpty Rule
nodes

getIndicesOfRange :: MonadReader CDDL m => Rule -> Rule -> RangeBound -> m [Word64]
getIndicesOfRange :: forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> Rule -> RangeBound -> m [Word64]
getIndicesOfRange Rule
ff Rule
tt RangeBound
incl =
  ((,) (CTree MonoRef -> CTree MonoRef -> (CTree MonoRef, CTree MonoRef))
-> m (CTree MonoRef)
-> m (CTree MonoRef -> (CTree MonoRef, CTree MonoRef))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
ff m (CTree MonoRef -> (CTree MonoRef, CTree MonoRef))
-> m (CTree MonoRef) -> m (CTree MonoRef, CTree MonoRef)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
tt) m (CTree MonoRef, CTree MonoRef)
-> ((CTree MonoRef, CTree MonoRef) -> m [Word64]) -> m [Word64]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (Literal (Value (VUInt Word64
ff') Comment
_), Literal (Value (VUInt Word64
tt') Comment
_)) ->
      [Word64] -> m [Word64]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Word64] -> m [Word64]) -> [Word64] -> m [Word64]
forall a b. (a -> b) -> a -> b
$
        [Word64
ff' .. Word64
tt'] [Word64] -> ([Word64] -> [Word64]) -> [Word64]
forall a b. a -> (a -> b) -> b
& case RangeBound
incl of
          RangeBound
ClOpen -> [Word64] -> [Word64]
forall a. HasCallStack => [a] -> [a]
init
          RangeBound
Closed -> [Word64] -> [Word64]
forall a. a -> a
id
    (CTree MonoRef, CTree MonoRef)
somethingElse -> [Char] -> m [Word64]
forall a. HasCallStack => [Char] -> a
error ([Char] -> m [Word64]) -> [Char] -> m [Word64]
forall a b. (a -> b) -> a -> b
$ [Char]
"Malformed range in .bits: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> (CTree MonoRef, CTree MonoRef) -> [Char]
forall a. Show a => a -> [Char]
show (CTree MonoRef, CTree MonoRef)
somethingElse

getIndicesOfEnum :: MonadReader CDDL m => Rule -> m [Word64]
getIndicesOfEnum :: forall (m :: * -> *). MonadReader CDDL m => Rule -> m [Word64]
getIndicesOfEnum Rule
g =
  Rule -> m (CTree MonoRef)
forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
g m (CTree MonoRef) -> (CTree MonoRef -> m [Word64]) -> m [Word64]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Group [Rule]
g' -> NonEmpty Rule -> m [Word64]
forall (m :: * -> *).
MonadReader CDDL m =>
NonEmpty Rule -> m [Word64]
getIndicesOfChoice (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')
    CTree MonoRef
somethingElse -> [Char] -> m [Word64]
forall a. HasCallStack => [Char] -> a
error ([Char] -> m [Word64]) -> [Char] -> m [Word64]
forall a b. (a -> b) -> a -> b
$ [Char]
"Malformed enum in .bits: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> CTree MonoRef -> [Char]
forall a. Show a => a -> [Char]
show CTree MonoRef
somethingElse

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

resolveIfRef :: CDDL -> Rule -> ResolvedRule
resolveIfRef :: CDDL -> Rule -> CTree MonoRef
resolveIfRef CDDL
_ (MIt CTree MonoRef
aa) = CTree MonoRef
aa
resolveIfRef ct :: CDDL
ct@(CTreeRoot Map Name (Identity Rule)
cddl) (MRuleRef Name
n) = do
  case Name -> Map Name (Identity Rule) -> Maybe (Identity Rule)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name (Identity Rule)
cddl of
    Maybe (Identity Rule)
Nothing -> [Char] -> CTree MonoRef
forall a. HasCallStack => [Char] -> a
error ([Char] -> CTree MonoRef) -> [Char] -> CTree MonoRef
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 Identity Rule
val -> CDDL -> Rule -> CTree MonoRef
resolveIfRef CDDL
ct (Rule -> CTree MonoRef) -> Rule -> CTree MonoRef
forall a b. (a -> b) -> a -> b
$ Identity Rule -> Rule
forall a. Identity a -> a
runIdentity Identity Rule
val

getRule :: MonadReader CDDL m => Rule -> m ResolvedRule
getRule :: forall (m :: * -> *).
MonadReader CDDL m =>
Rule -> m (CTree MonoRef)
getRule Rule
rule = (CDDL -> CTree MonoRef) -> m (CTree MonoRef)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (CDDL -> Rule -> CTree MonoRef
`resolveIfRef` Rule
rule)

--------------------------------------------------------------------------------
-- 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 {} Rule
r = Rule -> CDDLResult
UnapplicableRule Rule
r
replaceRule Valid {} Rule
r = Rule -> CDDLResult
Valid Rule
r

ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM :: forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM m Bool
b m a
t m a
f = do Bool
b' <- m Bool
b; if Bool
b' then m a
t else m a
f

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
(<)