Skip to content

Commit 5748c6f

Browse files
SoupstrawSoupstraw
committed
Removed It constructors from references
1 parent 3b684cf commit 5748c6f

File tree

3 files changed

+159
-175
lines changed

3 files changed

+159
-175
lines changed

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

Lines changed: 37 additions & 36 deletions
Original file line numberDiff line numberDiff line change
@@ -24,6 +24,7 @@ import Data.Functor ((<&>))
2424
import Data.Functor.Identity
2525
import Data.IntSet qualified as IS
2626
import Data.List.NonEmpty qualified as NE
27+
import Data.Map.Strict (Map)
2728
import Data.Map.Strict qualified as Map
2829
import Data.Maybe
2930
import Data.Text qualified as T
@@ -34,9 +35,9 @@ import System.Exit
3435
import System.IO
3536
import Text.Regex.TDFA
3637

37-
type CDDL = CTreeRoot' Identity MonoRef
38-
type Rule = Node MonoRef
39-
type ResolvedRule = CTree MonoRef
38+
type CDDL = Map Name Rule
39+
type Rule = Node MonoReferenced
40+
type ResolvedRule = CTree MonoReferenced
4041

4142
data CBORTermResult = CBORTermResult Term CDDLResult
4243
deriving (Show)
@@ -130,13 +131,13 @@ validateCBOR bs rule cddl =
130131

131132
validateCBOR' ::
132133
BS.ByteString -> Name -> CDDL -> CBORTermResult
133-
validateCBOR' bs rule cddl@(CTreeRoot tree) =
134+
validateCBOR' bs rule cddl =
134135
case deserialiseFromBytes decodeTerm (BSL.fromStrict bs) of
135136
Left e -> error $ show e
136137
Right (rest, term) ->
137138
if BSL.null rest
138-
then runReader (validateTerm term (runIdentity $ tree Map.! rule)) cddl
139-
else runReader (validateTerm (TBytes bs) (runIdentity $ tree Map.! rule)) cddl
139+
then runReader (validateTerm term (cddl Map.! rule)) cddl
140+
else runReader (validateTerm (TBytes bs) (cddl Map.! rule)) cddl
140141

141142
--------------------------------------------------------------------------------
142143
-- Terms
@@ -218,12 +219,12 @@ validateInteger i rule =
218219
-- a = <big number>
219220
Literal (Value (VBignum i') _) -> pure $ check $ i == i'
220221
-- a = foo .ctrl bar
221-
Control op tgt ctrl -> ctrlDispatch (validateInteger i) op tgt ctrl (controlInteger i)
222+
Control op tgt ctrl -> ctrlDispatch (validateInteger i) op (MIt tgt) (MIt ctrl) (controlInteger i)
222223
-- a = foo / bar
223-
Choice opts -> validateChoice (validateInteger i) opts
224+
Choice opts -> validateChoice (validateInteger i) (MIt <$> opts)
224225
-- a = x..y
225226
Range low high bound ->
226-
((,) <$> getRule low <*> getRule high)
227+
((,) <$> getRule (MIt low) <*> getRule (MIt high))
227228
<&> check . \case
228229
(Literal (Value (VUInt (fromIntegral -> n)) _), Literal (Value (VUInt (fromIntegral -> m)) _)) -> n <= i && range bound i m
229230
(Literal (Value (VNInt (fromIntegral -> n)) _), Literal (Value (VUInt (fromIntegral -> m)) _)) -> -n <= i && range bound i m
@@ -235,14 +236,14 @@ validateInteger i rule =
235236
(Literal (Value (VNInt (fromIntegral -> n)) _), Literal (Value (VBignum m) _)) -> (-n) <= i && range bound i m
236237
-- a = &(x, y, z)
237238
Enum g ->
238-
getRule g >>= \case
239+
getRule (MIt g) >>= \case
239240
Group g' -> validateInteger i (MIt (Choice (NE.fromList g'))) <&> replaceRule
240241
-- a = x: y
241242
-- Note KV cannot appear on its own, but we will use this when validating
242243
-- lists.
243-
KV _ v _ -> validateInteger i v <&> replaceRule
244-
Tag 2 (MIt (Postlude PTBytes)) -> pure Valid
245-
Tag 3 (MIt (Postlude PTBytes)) -> pure Valid
244+
KV _ v _ -> validateInteger i (MIt v) <&> replaceRule
245+
Tag 2 (Postlude PTBytes) -> pure Valid
246+
Tag 3 (Postlude PTBytes) -> pure Valid
246247
_ -> pure UnapplicableRule
247248

248249
-- | Controls for an Integer
@@ -256,9 +257,9 @@ controlInteger i Bits ctrl = do
256257
indices <-
257258
getRule ctrl >>= \case
258259
Literal (Value (VUInt i') _) -> pure [i']
259-
Choice nodes -> getIndicesOfChoice nodes
260-
Range ff tt incl -> getIndicesOfRange ff tt incl
261-
Enum g -> getIndicesOfEnum g
260+
Choice nodes -> getIndicesOfChoice (MIt <$> nodes)
261+
Range ff tt incl -> getIndicesOfRange (MIt ff) (MIt tt) incl
262+
Enum g -> getIndicesOfEnum $ MIt g
262263
pure $ boolCtrl $ go (IS.fromList (map fromIntegral indices)) i 0
263264
where
264265
go _ 0 _ = True
@@ -325,12 +326,12 @@ validateHalf f rule =
325326
-- a = 0.5
326327
Literal (Value (VFloat16 f') _) -> pure $ check $ f == f'
327328
-- a = foo / bar
328-
Choice opts -> validateChoice (validateHalf f) opts
329+
Choice opts -> validateChoice (validateHalf f) (MIt <$> opts)
329330
-- a = foo .ctrl bar
330-
Control op tgt ctrl -> ctrlDispatch (validateHalf f) op tgt ctrl (controlHalf f)
331+
Control op tgt ctrl -> ctrlDispatch (validateHalf f) op (MIt tgt) (MIt ctrl) (controlHalf f)
331332
-- a = x..y
332333
Range low high bound ->
333-
((,) <$> getRule low <*> getRule high)
334+
((,) <$> getRule (MIt low) <*> getRule (MIt high))
334335
<&> check . \case
335336
(Literal (Value (VFloat16 n) _), Literal (Value (VFloat16 m) _)) -> n <= f && range bound f m
336337
_ -> pure UnapplicableRule
@@ -363,13 +364,13 @@ validateFloat f rule =
363364
-- TODO: it is unclear if smaller floats should also validate
364365
Literal (Value (VFloat32 f') _) -> pure $ check $ f == f'
365366
-- a = foo / bar
366-
Choice opts -> validateChoice (validateFloat f) opts
367+
Choice opts -> validateChoice (validateFloat f) (MIt <$> opts)
367368
-- a = foo .ctrl bar
368-
Control op tgt ctrl -> ctrlDispatch (validateFloat f) op tgt ctrl (controlFloat f)
369+
Control op tgt ctrl -> ctrlDispatch (validateFloat f) op (MIt tgt) (MIt ctrl) (controlFloat f)
369370
-- a = x..y
370371
-- TODO it is unclear if this should mix floating point types too
371372
Range low high bound ->
372-
((,) <$> getRule low <*> getRule high)
373+
((,) <$> getRule (MIt low) <*> getRule (MIt high))
373374
<&> check . \case
374375
(Literal (Value (VFloat16 n) _), Literal (Value (VFloat16 m) _)) -> n <= f && range bound f m
375376
(Literal (Value (VFloat32 n) _), Literal (Value (VFloat32 m) _)) -> n <= f && range bound f m
@@ -405,13 +406,13 @@ validateDouble f rule =
405406
-- TODO: it is unclear if smaller floats should also validate
406407
Literal (Value (VFloat64 f') _) -> pure $ check $ f == f'
407408
-- a = foo / bar
408-
Choice opts -> validateChoice (validateDouble f) opts
409+
Choice opts -> validateChoice (validateDouble f) (MIt <$> opts)
409410
-- a = foo .ctrl bar
410-
Control op tgt ctrl -> ctrlDispatch (validateDouble f) op tgt ctrl (controlDouble f)
411+
Control op tgt ctrl -> ctrlDispatch (validateDouble f) op (MIt tgt) (MIt ctrl) (controlDouble f)
411412
-- a = x..y
412413
-- TODO it is unclear if this should mix floating point types too
413414
Range low high bound ->
414-
((,) <$> getRule low <*> getRule high)
415+
((,) <$> getRule (MIt low) <*> getRule (MIt high))
415416
<&> check . \case
416417
(Literal (Value (VFloat16 (float2Double -> n)) _), Literal (Value (VFloat16 (float2Double -> m)) _)) -> n <= f && range bound f m
417418
(Literal (Value (VFloat32 (float2Double -> n)) _), Literal (Value (VFloat32 (float2Double -> m)) _)) -> n <= f && range bound f m
@@ -453,9 +454,9 @@ validateBool b rule =
453454
-- a = true
454455
Literal (Value (VBool b') _) -> pure $ check $ b == b'
455456
-- a = foo .ctrl bar
456-
Control op tgt ctrl -> ctrlDispatch (validateBool b) op tgt ctrl (controlBool b)
457+
Control op tgt ctrl -> ctrlDispatch (validateBool b) op (MIt tgt) (MIt ctrl) (controlBool b)
457458
-- a = foo / bar
458-
Choice opts -> validateChoice (validateBool b) opts
459+
Choice opts -> validateChoice (validateBool b) $ MIt <$> opts
459460
_ -> pure UnapplicableRule
460461

461462
-- | Controls for `Bool`
@@ -486,7 +487,7 @@ validateSimple 23 rule =
486487
-- a = undefined
487488
Postlude PTUndefined -> pure Valid
488489
-- a = foo / bar
489-
Choice opts -> validateChoice (validateSimple 23) opts
490+
Choice opts -> validateChoice (validateSimple 23) $ MIt <$> opts
490491
_ -> pure UnapplicableRule
491492
validateSimple n _ = error $ "Found simple different to 23! please report this somewhere! Found: " <> show n
492493

@@ -503,7 +504,7 @@ validateNull rule =
503504
Postlude PTAny -> pure Valid
504505
-- a = nil
505506
Postlude PTNil -> pure Valid
506-
Choice opts -> validateChoice validateNull opts
507+
Choice opts -> validateChoice validateNull $ MIt <$> opts
507508
_ -> pure UnapplicableRule
508509

509510
--------------------------------------------------------------------------------
@@ -525,9 +526,9 @@ validateBytes bs rule =
525526
-- a = h'123456'
526527
Literal (Value (VBytes bs') _) -> pure $ check $ bs == bs'
527528
-- a = foo .ctrl bar
528-
Control op tgt ctrl -> ctrlDispatch (validateBytes bs) op tgt ctrl (controlBytes bs)
529+
Control op tgt ctrl -> ctrlDispatch (validateBytes bs) op (MIt tgt) (MIt ctrl) (controlBytes bs)
529530
-- a = foo / bar
530-
Choice opts -> validateChoice (validateBytes bs) opts
531+
Choice opts -> validateChoice (validateBytes bs) (MIt <$> opts)
531532
_ -> pure UnapplicableRule
532533

533534
-- | Controls for byte strings
@@ -543,7 +544,7 @@ controlBytes bs Size ctrl =
543544
Literal (Value (VUInt (fromIntegral -> sz)) _) -> pure $ boolCtrl $ BS.length bs == sz
544545
Range low high bound ->
545546
let i = BS.length bs
546-
in ((,) <$> getRule low <*> getRule high)
547+
in ((,) <$> getRule (MIt low) <*> getRule (MIt high))
547548
<&> boolCtrl . \case
548549
(Literal (Value (VUInt (fromIntegral -> n)) _), Literal (Value (VUInt (fromIntegral -> m)) _)) -> n <= i && range bound i m
549550
(Literal (Value (VNInt (fromIntegral -> n)) _), Literal (Value (VUInt (fromIntegral -> m)) _)) -> -n <= i && range bound i m
@@ -553,9 +554,9 @@ controlBytes bs Bits ctrl = do
553554
indices <-
554555
getRule ctrl >>= \case
555556
Literal (Value (VUInt i') _) -> pure [i']
556-
Choice nodes -> getIndicesOfChoice nodes
557-
Range ff tt incl -> getIndicesOfRange ff tt incl
558-
Enum g -> getIndicesOfEnum g
557+
Choice nodes -> getIndicesOfChoice $ MIt <$> nodes
558+
Range ff tt incl -> getIndicesOfRange (MIt ff) (MIt tt) incl
559+
Enum g -> getIndicesOfEnum $ MIt g
559560
pure $ boolCtrl $ bitsControlCheck (map fromIntegral indices)
560561
where
561562
bitsControlCheck :: [Int] -> Bool
@@ -578,7 +579,7 @@ controlBytes bs Cbor ctrl =
578579
controlBytes bs Cborseq ctrl =
579580
case deserialiseFromBytes decodeTerm (BSL.fromStrict (BS.snoc (BS.cons 0x9f bs) 0xff)) of
580581
Right (BSL.null -> True, TListI terms) ->
581-
validateTerm (TList terms) (MIt (Array [MIt (Occur ctrl OIZeroOrMore)])) >>= \case
582+
validateTerm (TList terms) (MIt (Array [Occur ctrl OIZeroOrMore])) >>= \case
582583
CBORTermResult _ (Valid _) -> pure $ Right ()
583584
CBORTermResult _ err -> error $ show err
584585

‎src/Codec/CBOR/Cuddle/CDDL/CTree.hs‎

Lines changed: 6 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -29,17 +29,17 @@ import GHC.Generics (Generic)
2929

3030
type family CTreeExt i
3131

32-
data Parametrisation a = Parametrisation
32+
data ProvidedParameters a = ProvidedParameters
3333
{ parameters :: [Name]
3434
, underlying :: a
3535
}
3636
deriving (Generic, Functor, Show, Eq, Foldable, Traversable)
3737

38-
instance Hashable a => Hashable (Parametrisation a)
38+
instance Hashable a => Hashable (ProvidedParameters a)
3939

4040
data Parametrised
4141

42-
type instance CTreeExt Parametrised = Parametrisation (CTree Parametrised)
42+
type instance CTreeExt Parametrised = ProvidedParameters (CTree Parametrised)
4343

4444
-- | CDDL Tree, parametrised over a functor
4545
--
@@ -64,7 +64,7 @@ data CTree i
6464

6565
-- | Traverse the CTree, carrying out the given operation at each node
6666
traverseCTree ::
67-
Monad m => (CTreeExt i -> m (CTreeExt j)) -> (CTree i -> m (CTree j)) -> CTree i -> m (CTree j)
67+
Monad m => (CTreeExt i -> m (CTree j)) -> (CTree i -> m (CTree j)) -> CTree i -> m (CTree j)
6868
traverseCTree _ _ (Literal a) = pure $ Literal a
6969
traverseCTree _ _ (Postlude a) = pure $ Postlude a
7070
traverseCTree _ atNode (Map xs) = Map <$> traverse atNode xs
@@ -87,9 +87,9 @@ traverseCTree _ atNode (Control o t c) = do
8787
traverseCTree _ atNode (Enum ref) = Enum <$> atNode ref
8888
traverseCTree _ atNode (Unwrap ref) = Unwrap <$> atNode ref
8989
traverseCTree _ atNode (Tag i ref) = Tag i <$> atNode ref
90-
traverseCTree atExt _ (CTreeE x) = CTreeE <$> atExt x
90+
traverseCTree atExt _ (CTreeE x) = atExt x
9191

9292
type Node i = CTreeExt i
9393

94-
newtype CTreeRoot i = CTreeRoot (Map.Map Name (Parametrisation (Node i)))
94+
newtype CTreeRoot i = CTreeRoot (Map.Map Name (ProvidedParameters (CTree i)))
9595
deriving (Generic)

0 commit comments

Comments
 (0)