Skip to content

Commit 130f5d3

Browse files
SoupstrawSoupstraw
committed
WIP
1 parent adcc5e8 commit 130f5d3

File tree

3 files changed

+129
-53
lines changed

3 files changed

+129
-53
lines changed

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

Lines changed: 16 additions & 45 deletions
Original file line numberDiff line numberDiff line change
@@ -25,7 +25,17 @@ import Codec.CBOR.Cuddle.CDDL (
2525
Value (..),
2626
ValueVariant (..),
2727
)
28-
import Codec.CBOR.Cuddle.CDDL.CTree (CTree, CTreeRoot' (..))
28+
import Codec.CBOR.Cuddle.CDDL.CTree (
29+
CTree,
30+
CTreeRoot' (..),
31+
WrappedTerm,
32+
flattenWrappedList,
33+
pairTermList,
34+
singleTermList,
35+
pattern G,
36+
pattern P,
37+
pattern S,
38+
)
2939
import Codec.CBOR.Cuddle.CDDL.CTree qualified as CTree
3040
import Codec.CBOR.Cuddle.CDDL.CtlOp qualified as CtlOp
3141
import Codec.CBOR.Cuddle.CDDL.Postlude (PTerm (..))
@@ -53,6 +63,7 @@ import System.Random.Stateful (
5363
Random,
5464
RandomGen (..),
5565
StateGenM (..),
66+
StatefulGen (..),
5667
UniformRange (uniformRM),
5768
randomM,
5869
uniformByteStringM,
@@ -207,53 +218,11 @@ genPostlude pt = case pt of
207218
PTNil -> pure TNull
208219
PTUndefined -> pure $ TSimple 23
209220

210-
--------------------------------------------------------------------------------
211-
-- Kinds of terms
212-
--------------------------------------------------------------------------------
213-
214-
data WrappedTerm
215-
= SingleTerm Term
216-
| PairTerm Term Term
217-
| GroupTerm [WrappedTerm]
218-
deriving (Eq, Show)
219-
220-
-- | Recursively flatten wrapped list. That is, expand any groups out to their
221-
-- individual entries.
222-
flattenWrappedList :: [WrappedTerm] -> [WrappedTerm]
223-
flattenWrappedList [] = []
224-
flattenWrappedList (GroupTerm xxs : xs) =
225-
flattenWrappedList xxs <> flattenWrappedList xs
226-
flattenWrappedList (y : xs) = y : flattenWrappedList xs
227-
228-
pattern S :: Term -> WrappedTerm
229-
pattern S t = SingleTerm t
230-
231-
-- | Convert a list of wrapped terms to a list of terms. If any 'PairTerm's are
232-
-- present, we just take their "value" part.
233-
singleTermList :: [WrappedTerm] -> Maybe [Term]
234-
singleTermList [] = Just []
235-
singleTermList (S x : xs) = (x :) <$> singleTermList xs
236-
singleTermList (P _ y : xs) = (y :) <$> singleTermList xs
237-
singleTermList _ = Nothing
238-
239-
pattern P :: Term -> Term -> WrappedTerm
240-
pattern P t1 t2 = PairTerm t1 t2
241-
242-
-- | Convert a list of wrapped terms to a list of pairs of terms, or fail if any
243-
-- 'SingleTerm's are present.
244-
pairTermList :: [WrappedTerm] -> Maybe [(Term, Term)]
245-
pairTermList [] = Just []
246-
pairTermList (P x y : xs) = ((x, y) :) <$> pairTermList xs
247-
pairTermList _ = Nothing
248-
249-
pattern G :: [WrappedTerm] -> WrappedTerm
250-
pattern G xs = GroupTerm xs
251-
252221
--------------------------------------------------------------------------------
253222
-- Generator functions
254223
--------------------------------------------------------------------------------
255224

256-
genForCTree :: RandomGen g => CTree MonoRef -> M g WrappedTerm
225+
genForCTree :: forall g. RandomGen g => CTree MonoRef -> M g WrappedTerm
257226
genForCTree (CTree.Literal v) = S <$> genValue v
258227
genForCTree (CTree.Postlude pt) = S <$> genPostlude pt
259228
genForCTree (CTree.Map nodes) = do
@@ -362,6 +331,7 @@ genForCTree (CTree.Tag tag node) = do
362331
case enc of
363332
S x -> pure $ S $ TTagged tag x
364333
_ -> error "Tag controller does not correspond to a single term"
334+
genForCTree (CTree.WithGen gen _) = gen StateGenM
365335

366336
genForNode :: RandomGen g => CTree.Node MonoRef -> M g WrappedTerm
367337
genForNode = genForCTree <=< resolveIfRef
@@ -446,7 +416,8 @@ generateCBORTerm cddl n stdGen =
446416
genState = GenState {randomSeed = stdGen, depth = 1}
447417
in evalGen (genForName n) genEnv genState
448418

449-
generateCBORTerm' :: RandomGen g => CTreeRoot' Identity MonoRef -> Name -> g -> (Term, g)
419+
generateCBORTerm' ::
420+
(RandomGen g, StatefulGen g (M g)) => CTreeRoot' Identity MonoRef -> Name -> g -> (Term, g)
450421
generateCBORTerm' cddl n stdGen =
451422
let genEnv = GenEnv {cddl}
452423
genState = GenState {randomSeed = stdGen, depth = 1}

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

Lines changed: 47 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,5 @@
11
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE PatternSynonyms #-}
23

34
module Codec.CBOR.Cuddle.CDDL.CTree where
45

@@ -10,11 +11,55 @@ import Codec.CBOR.Cuddle.CDDL (
1011
)
1112
import Codec.CBOR.Cuddle.CDDL.CtlOp
1213
import Codec.CBOR.Cuddle.CDDL.Postlude (PTerm)
14+
import Codec.CBOR.Term (Term)
1315
import Data.Hashable (Hashable)
1416
import Data.List.NonEmpty qualified as NE
1517
import Data.Map.Strict qualified as Map
1618
import Data.Word (Word64)
1719
import GHC.Generics (Generic)
20+
import System.Random.Stateful (StatefulGen)
21+
22+
--------------------------------------------------------------------------------
23+
-- Kinds of terms
24+
--------------------------------------------------------------------------------
25+
26+
data WrappedTerm
27+
= SingleTerm Term
28+
| PairTerm Term Term
29+
| GroupTerm [WrappedTerm]
30+
deriving (Eq, Show, Generic)
31+
32+
-- | Recursively flatten wrapped list. That is, expand any groups out to their
33+
-- individual entries.
34+
flattenWrappedList :: [WrappedTerm] -> [WrappedTerm]
35+
flattenWrappedList [] = []
36+
flattenWrappedList (GroupTerm xxs : xs) =
37+
flattenWrappedList xxs <> flattenWrappedList xs
38+
flattenWrappedList (y : xs) = y : flattenWrappedList xs
39+
40+
pattern S :: Term -> WrappedTerm
41+
pattern S t = SingleTerm t
42+
43+
-- | Convert a list of wrapped terms to a list of terms. If any 'PairTerm's are
44+
-- present, we just take their "value" part.
45+
singleTermList :: [WrappedTerm] -> Maybe [Term]
46+
singleTermList [] = Just []
47+
singleTermList (S x : xs) = (x :) <$> singleTermList xs
48+
singleTermList (P _ y : xs) = (y :) <$> singleTermList xs
49+
singleTermList _ = Nothing
50+
51+
pattern P :: Term -> Term -> WrappedTerm
52+
pattern P t1 t2 = PairTerm t1 t2
53+
54+
-- | Convert a list of wrapped terms to a list of pairs of terms, or fail if any
55+
-- 'SingleTerm's are present.
56+
pairTermList :: [WrappedTerm] -> Maybe [(Term, Term)]
57+
pairTermList [] = Just []
58+
pairTermList (P x y : xs) = ((x, y) :) <$> pairTermList xs
59+
pairTermList _ = Nothing
60+
61+
pattern G :: [WrappedTerm] -> WrappedTerm
62+
pattern G xs = GroupTerm xs
1863

1964
--------------------------------------------------------------------------------
2065

@@ -44,7 +89,7 @@ data CTree f
4489
| Enum (Node f)
4590
| Unwrap (Node f)
4691
| Tag Word64 (Node f)
47-
deriving (Generic)
92+
| WithGen (forall g m. StatefulGen g m => g -> m WrappedTerm) (Node f)
4893

4994
-- | Traverse the CTree, carrying out the given operation at each node
5095
traverseCTree :: Monad m => (Node f -> m (Node g)) -> CTree f -> m (CTree g)
@@ -70,6 +115,7 @@ traverseCTree atNode (Control o t c) = do
70115
traverseCTree atNode (Enum ref) = Enum <$> atNode ref
71116
traverseCTree atNode (Unwrap ref) = Unwrap <$> atNode ref
72117
traverseCTree atNode (Tag i ref) = Tag i <$> atNode ref
118+
traverseCTree atNode (WithGen g ref) = WithGen g <$> atNode ref
73119

74120
type Node f = f (CTree f)
75121

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

Lines changed: 66 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -60,6 +60,7 @@ import Data.Hashable
6060
#if __GLASGOW_HASKELL__ < 910
6161
import Data.List (foldl')
6262
#endif
63+
import Data.Bits (Bits (..))
6364
import Data.List.NonEmpty qualified as NE
6465
import Data.Map.Strict qualified as Map
6566
import Data.Text qualified as T
@@ -132,7 +133,8 @@ data OrRef a
132133

133134
type RefCTree = CTreeRoot OrRef
134135

135-
deriving instance Show (CTree OrRef)
136+
instance Show (CTree OrRef) where
137+
show = showCTree
136138

137139
deriving instance Show (CTreeRoot OrRef)
138140

@@ -340,11 +342,34 @@ data DistRef a
340342

341343
instance Hashable a => Hashable (DistRef a)
342344

343-
deriving instance Show (CTree DistRef)
344-
345-
deriving instance Eq (CTree DistRef)
346-
347-
instance Hashable (CTree DistRef)
345+
instance Show (CTree DistRef) where
346+
show = showCTree
347+
348+
instance Eq (CTree DistRef) where
349+
(==) = eqCTree
350+
351+
instance Hashable (CTree DistRef) where
352+
hashWithSalt salt = \case
353+
CTree.Literal x -> hashWithSalt salt $ hashWithSalt salt x
354+
CTree.Postlude x -> hashWithSalt (salt `xor` 1) $ hashWithSalt salt x
355+
CTree.Map x -> hashWithSalt (salt `xor` 2) $ hashWithSalt salt x
356+
CTree.Array x -> hashWithSalt (salt `xor` 3) $ hashWithSalt salt x
357+
CTree.Choice x -> hashWithSalt (salt `xor` 4) $ hashWithSalt salt x
358+
CTree.Group x -> hashWithSalt (salt `xor` 5) $ hashWithSalt salt x
359+
CTree.Enum x -> hashWithSalt (salt `xor` 6) $ hashWithSalt salt x
360+
CTree.Unwrap x -> hashWithSalt (salt `xor` 7) $ hashWithSalt salt x
361+
CTree.Occur x y -> hashWithSalt (salt `xor` 8) $ hashWithSalt salt x `xor` hashWithSalt (salt `xor` 1) y
362+
CTree.Tag x y -> hashWithSalt (salt `xor` 9) $ hashWithSalt salt x `xor` hashWithSalt (salt `xor` 1) y
363+
CTree.WithGen _ y -> hashWithSalt (salt `xor` 10) $ hashWithSalt (salt `xor` 1) y
364+
CTree.KV x y z ->
365+
hashWithSalt (salt `xor` 11) $
366+
hashWithSalt salt x `xor` hashWithSalt (salt `xor` 1) y `xor` hashWithSalt (salt `xor` 2) z
367+
CTree.Range x y z ->
368+
hashWithSalt (salt `xor` 12) $
369+
hashWithSalt salt x `xor` hashWithSalt (salt `xor` 1) y `xor` hashWithSalt (salt `xor` 2) z
370+
CTree.Control x y z ->
371+
hashWithSalt (salt `xor` 13) $
372+
hashWithSalt salt x `xor` hashWithSalt (salt `xor` 1) y `xor` hashWithSalt (salt `xor` 2) z
348373

349374
deriving instance Show (CTreeRoot DistRef)
350375

@@ -400,7 +425,41 @@ data MonoRef a
400425
| MRuleRef Name
401426
deriving (Functor, Show)
402427

403-
deriving instance Show (CTree MonoRef)
428+
showCTree :: Show (f (CTree f)) => CTree f -> String
429+
showCTree (CTree.Literal x) = "Literal " <> show x
430+
showCTree (CTree.Postlude x) = "Postlude " <> show x
431+
showCTree (CTree.Map x) = "Map " <> show x
432+
showCTree (CTree.Array x) = "Array " <> show x
433+
showCTree (CTree.Choice x) = "Choice " <> show x
434+
showCTree (CTree.Group x) = "Group " <> show x
435+
showCTree (CTree.KV x y z) = "KV " <> show x <> " " <> show y <> " " <> show z
436+
showCTree (CTree.Occur x y) = "Occur " <> show x <> " " <> show y
437+
showCTree (CTree.Range x y z) = "Range " <> show x <> " " <> show y <> " " <> show z
438+
showCTree (CTree.Control x y z) = "Control " <> show x <> " " <> show y <> " " <> show z
439+
showCTree (CTree.Enum x) = "Enum " <> show x
440+
showCTree (CTree.Unwrap x) = "Unwrap " <> show x
441+
showCTree (CTree.Tag x y) = "Tag " <> show x <> " " <> show y
442+
showCTree (CTree.WithGen _ y) = "WithGen " <> show y
443+
444+
eqCTree :: Eq (f (CTree f)) => CTree f -> CTree f -> Bool
445+
eqCTree (CTree.Literal x) (CTree.Literal x') = x == x'
446+
eqCTree (CTree.Postlude x) (CTree.Postlude x') = x == x'
447+
eqCTree (CTree.Map x) (CTree.Map x') = x == x'
448+
eqCTree (CTree.Array x) (CTree.Array x') = x == x'
449+
eqCTree (CTree.Choice x) (CTree.Choice x') = x == x'
450+
eqCTree (CTree.Group x) (CTree.Group x') = x == x'
451+
eqCTree (CTree.KV x y z) (CTree.KV x' y' z') = x == x' && y == y' && z == z'
452+
eqCTree (CTree.Occur x y) (CTree.Occur x' y') = x == x' && y == y'
453+
eqCTree (CTree.Range x y z) (CTree.Range x' y' z') = x == x' && y == y' && z == z'
454+
eqCTree (CTree.Control x y z) (CTree.Control x' y' z') = x == x' && y == y' && z == z'
455+
eqCTree (CTree.Enum x) (CTree.Enum x') = x == x'
456+
eqCTree (CTree.Unwrap x) (CTree.Unwrap x') = x == x'
457+
eqCTree (CTree.Tag x y) (CTree.Tag x' y') = x == x' && y == y'
458+
eqCTree (CTree.WithGen _ y) (CTree.WithGen _ y') = y == y'
459+
eqCTree _ _ = False
460+
461+
instance Show (CTree MonoRef) where
462+
show = showCTree
404463

405464
deriving instance
406465
Show (poly (CTree.Node MonoRef)) =>

0 commit comments

Comments
 (0)