From 779885b684edc3e1e1b0d07ad6d0d5670beeb397 Mon Sep 17 00:00:00 2001 From: Nicholas Clarke Date: Fri, 22 Nov 2024 12:02:46 +0100 Subject: [PATCH 1/2] Allow comments on group entries This addresses part of #36 - comments are still not supported _everywhere_, but they are allowed on group entries, which represent the area (other than top-level rules) where comments are the most useful. The same "comment" syntax is used as with top-level rules. Note that this does not (yet) work within groups - that will be addressed as part of #32. As yet, the parser still does not deal with comments, or attribute them to any entity. The tests are likewise oblivious to comments. But this does allow Huddle to define comments and have them reflected in the generated CDDL, which was the principal outcome. --- example/Monad.hs | 6 +- src/Codec/CBOR/Cuddle/CDDL.hs | 2 +- src/Codec/CBOR/Cuddle/CDDL/Resolve.hs | 19 +++-- src/Codec/CBOR/Cuddle/Huddle.hs | 63 ++++++++------ src/Codec/CBOR/Cuddle/Parser.hs | 6 +- test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs | 7 +- test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs | 99 ++++++++++++---------- 7 files changed, 116 insertions(+), 86 deletions(-) diff --git a/example/Monad.hs b/example/Monad.hs index 39f712a..77e6813 100644 --- a/example/Monad.hs +++ b/example/Monad.hs @@ -42,9 +42,9 @@ spec2 = _transaction <- "transaction" =:= mp - [ idx 0 ==> set txIn, - idx 1 ==> set txOut, - idx 2 ==> metadata + [ comment "Transaction inputs" $ idx 0 ==> set txIn, + comment "Transaction outputs" $ idx 1 ==> set txOut, + comment "Metadata" $ idx 2 ==> metadata ] metadata <- "metadata" =:= VBytes _value <- "value" =:= mp ["token" ==> VText, "quantity" ==> VUInt] diff --git a/src/Codec/CBOR/Cuddle/CDDL.hs b/src/Codec/CBOR/Cuddle/CDDL.hs index e8b5826..60ea4f9 100644 --- a/src/Codec/CBOR/Cuddle/CDDL.hs +++ b/src/Codec/CBOR/Cuddle/CDDL.hs @@ -274,7 +274,7 @@ instance Hashable OccurrenceIndicator newtype Group = Group (NE.NonEmpty GrpChoice) deriving (Eq, Generic, Show, Semigroup) -type GrpChoice = [GroupEntry] +type GrpChoice = [WithComments GroupEntry] -- | -- A group entry can be given by a value type, which needs to be matched diff --git a/src/Codec/CBOR/Cuddle/CDDL/Resolve.hs b/src/Codec/CBOR/Cuddle/CDDL/Resolve.hs index d88921e..0a5c217 100644 --- a/src/Codec/CBOR/Cuddle/CDDL/Resolve.hs +++ b/src/Codec/CBOR/Cuddle/CDDL/Resolve.hs @@ -193,6 +193,9 @@ buildRefCTree rules = CTreeRoot $ fmap toCTreeRule rules It $ CTree.Postlude PTAny toCTreeT2 T2Any = It $ CTree.Postlude PTAny + toCTreeGroupEntryNC :: WithComments GroupEntry -> CTree.Node OrRef + toCTreeGroupEntryNC = toCTreeGroupEntry . stripComment + toCTreeGroupEntry :: GroupEntry -> CTree.Node OrRef toCTreeGroupEntry (GEType (Just occi) mmkey t0) = It $ @@ -223,18 +226,18 @@ buildRefCTree rules = CTreeRoot $ fmap toCTreeRule rules -- choice options toCTreeEnum :: Group -> CTree.Node OrRef toCTreeEnum (Group (a NE.:| [])) = - It . CTree.Enum . It . CTree.Group $ fmap toCTreeGroupEntry a + It . CTree.Enum . It . CTree.Group $ fmap toCTreeGroupEntryNC a toCTreeEnum (Group xs) = It . CTree.Choice $ - fmap (It . CTree.Enum . It . CTree.Group . fmap toCTreeGroupEntry) xs + fmap (It . CTree.Enum . It . CTree.Group . fmap toCTreeGroupEntryNC) xs -- Embed a group in another group, again floating out the choice options groupToGroup :: Group -> CTree.Node OrRef groupToGroup (Group (a NE.:| [])) = - It . CTree.Group $ fmap toCTreeGroupEntry a + It . CTree.Group $ fmap toCTreeGroupEntryNC a groupToGroup (Group xs) = It . CTree.Choice $ - fmap (It . CTree.Group . fmap toCTreeGroupEntry) xs + fmap (It . CTree.Group . fmap toCTreeGroupEntryNC) xs toKVPair :: Maybe MemberKey -> Type0 -> CTree.Node OrRef toKVPair Nothing t0 = toCTreeT0 t0 @@ -249,20 +252,20 @@ buildRefCTree rules = CTreeRoot $ fmap toCTreeRule rules -- Interpret a group as a map. Note that we float out the choice options toCTreeMap :: Group -> CTree.Node OrRef - toCTreeMap (Group (a NE.:| [])) = It . CTree.Map $ fmap toCTreeGroupEntry a + toCTreeMap (Group (a NE.:| [])) = It . CTree.Map $ fmap toCTreeGroupEntryNC a toCTreeMap (Group xs) = It . CTree.Choice - $ fmap (It . CTree.Map . fmap toCTreeGroupEntry) xs + $ fmap (It . CTree.Map . fmap toCTreeGroupEntryNC) xs -- Interpret a group as an array. Note that we float out the choice -- options toCTreeArray :: Group -> CTree.Node OrRef toCTreeArray (Group (a NE.:| [])) = - It . CTree.Array $ fmap toCTreeGroupEntry a + It . CTree.Array $ fmap toCTreeGroupEntryNC a toCTreeArray (Group xs) = It . CTree.Choice $ - fmap (It . CTree.Array . fmap toCTreeGroupEntry) xs + fmap (It . CTree.Array . fmap toCTreeGroupEntryNC) xs toCTreeMemberKey :: MemberKey -> CTree.Node OrRef toCTreeMemberKey (MKValue v) = It $ CTree.Literal v diff --git a/src/Codec/CBOR/Cuddle/Huddle.hs b/src/Codec/CBOR/Cuddle/Huddle.hs index 7322c87..e91ba1f 100644 --- a/src/Codec/CBOR/Cuddle/Huddle.hs +++ b/src/Codec/CBOR/Cuddle/Huddle.hs @@ -92,7 +92,7 @@ import Control.Monad (when) import Control.Monad.State (MonadState (get), execState, modify) import Data.ByteString (ByteString) import Data.Default.Class (Default (..)) -import Data.Generics.Product (field, getField) +import Data.Generics.Product (HasField' (field'), field, getField) import Data.List.NonEmpty qualified as NE import Data.Map.Ordered.Strict (OMap) import Data.Map.Ordered.Strict qualified as OMap @@ -113,9 +113,9 @@ data Named a = Named } deriving (Functor, Generic) --- | Add a description to a rule, to be included as a comment. -comment :: T.Text -> Named a -> Named a -comment desc n = n & field @"description" .~ Just desc +-- | Add a description to a rule or group entry, to be included as a comment. +comment :: (HasField' "description" a (Maybe T.Text)) => T.Text -> a -> a +comment desc n = n & field' @"description" .~ Just desc instance Show (Named a) where show (Named n _ _) = T.unpack n @@ -201,7 +201,8 @@ asKey r = case toType0 r of data MapEntry = MapEntry { key :: Key, value :: Type0, - quantifier :: Occurs + quantifier :: Occurs, + description :: Maybe T.Text } deriving (Generic, Show) @@ -221,7 +222,8 @@ data ArrayEntry = ArrayEntry -- here because they can be illustrative in the generated CDDL. key :: Maybe Key, value :: Type0, - quantifier :: Occurs + quantifier :: Occurs, + description :: Maybe T.Text } deriving (Generic, Show) @@ -231,6 +233,7 @@ instance Num ArrayEntry where Nothing (NoChoice . T2Literal . Unranged $ LInt (fromIntegral i)) def + Nothing (+) = error "Cannot treat ArrayEntry as a number" (*) = error "Cannot treat ArrayEntry as a number" abs = error "Cannot treat ArrayEntry as a number" @@ -584,7 +587,8 @@ instance IsEntryLike ArrayEntry where { key = Just $ getField @"key" me, value = getField @"value" me, - quantifier = getField @"quantifier" me + quantifier = getField @"quantifier" me, + description = Nothing } instance IsEntryLike Type0 where @@ -596,7 +600,8 @@ k ==> gc = MapEntry { key = k, value = toType0 gc, - quantifier = def + quantifier = def, + description = Nothing } infixl 8 ==> @@ -620,7 +625,8 @@ instance IsGroupOrArrayEntry ArrayEntry where ArrayEntry { key = Nothing, value = toType0 x, - quantifier = def + quantifier = def, + description = Nothing } instance IsGroupOrArrayEntry Type0 where @@ -899,9 +905,9 @@ collectFrom topRs = mapM_ goT2 $ args g goT2 (T2Basic (Constrained _ _ refs)) = mapM_ goRule refs goT2 _ = pure () - goArrayEntry (ArrayEntry (Just k) t0 _) = goKey k >> goT0 t0 - goArrayEntry (ArrayEntry Nothing t0 _) = goT0 t0 - goMapEntry (MapEntry k t0 _) = goKey k >> goT0 t0 + goArrayEntry (ArrayEntry (Just k) t0 _ _) = goKey k >> goT0 t0 + goArrayEntry (ArrayEntry Nothing t0 _ _) = goT0 t0 + goMapEntry (MapEntry k t0 _ _) = goKey k >> goT0 t0 goKey (TypeKey k) = goT2 k goKey _ = pure () goGroup (Group g) = mapM_ goT0 g @@ -960,12 +966,15 @@ toCDDL' mkPseudoRoot hdl = mapChoiceToCDDL :: MapChoice -> C.GrpChoice mapChoiceToCDDL (MapChoice entries) = fmap mapEntryToCDDL entries - mapEntryToCDDL :: MapEntry -> C.GroupEntry - mapEntryToCDDL (MapEntry k v occ) = - C.GEType - (toOccurrenceIndicator occ) - (Just $ toMemberKey k) - (toCDDLType0 v) + mapEntryToCDDL :: MapEntry -> C.WithComments C.GroupEntry + mapEntryToCDDL (MapEntry k v occ cmnt) = + C.WithComments + ( C.GEType + (toOccurrenceIndicator occ) + (Just $ toMemberKey k) + (toCDDLType0 v) + ) + (fmap C.Comment cmnt) toOccurrenceIndicator :: Occurs -> Maybe C.OccurrenceIndicator toOccurrenceIndicator (Occurs Nothing Nothing) = Nothing @@ -1006,13 +1015,15 @@ toCDDL' mkPseudoRoot hdl = arrayChoiceToCDDL :: ArrayChoice -> C.GrpChoice arrayChoiceToCDDL (ArrayChoice entries) = fmap arrayEntryToCDDL entries - arrayEntryToCDDL :: ArrayEntry -> C.GroupEntry - arrayEntryToCDDL (ArrayEntry k v occ) = - C.GEType - (toOccurrenceIndicator occ) - (fmap toMemberKey k) - (toCDDLType0 v) - + arrayEntryToCDDL :: ArrayEntry -> C.WithComments C.GroupEntry + arrayEntryToCDDL (ArrayEntry k v occ cmnt) = + C.WithComments + ( C.GEType + (toOccurrenceIndicator occ) + (fmap toMemberKey k) + (toCDDLType0 v) + ) + (fmap C.Comment cmnt) toCDDLPostlude :: Value a -> C.Name toCDDLPostlude VBool = C.Name "bool" toCDDLPostlude VUInt = C.Name "uint" @@ -1042,7 +1053,7 @@ toCDDL' mkPseudoRoot hdl = . C.GEGroup Nothing . C.Group . (NE.:| []) - $ fmap (C.GEType Nothing Nothing . toCDDLType0) t0s + $ fmap (C.noComment . C.GEType Nothing Nothing . toCDDLType0) t0s ) (fmap C.Comment c) diff --git a/src/Codec/CBOR/Cuddle/Parser.hs b/src/Codec/CBOR/Cuddle/Parser.hs index da9f4ec..2249f71 100644 --- a/src/Codec/CBOR/Cuddle/Parser.hs +++ b/src/Codec/CBOR/Cuddle/Parser.hs @@ -122,7 +122,11 @@ pGroup :: Parser Group pGroup = Group <$> NE.sepBy1 (space *> pGrpChoice <* space) (string "//") pGrpChoice :: Parser GrpChoice -pGrpChoice = many ((space *> pGrpEntry <* space) <* optional (char ',')) +pGrpChoice = + many + ( (space *> (noComment <$> pGrpEntry) <* space) + <* optional (char ',') + ) pGrpEntry :: Parser GroupEntry pGrpEntry = diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs index d0e3494..6dbb785 100644 --- a/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs @@ -167,7 +167,7 @@ instance Arbitrary Group where shrink (Group gr) = Group <$> shrinkNE gr genGrpChoice :: Gen GrpChoice -genGrpChoice = listOf' genGroupEntry +genGrpChoice = listOf' (noComment <$> genGroupEntry) genGroupEntry :: Gen GroupEntry genGroupEntry = @@ -241,6 +241,11 @@ instance Arbitrary CtlOp where arbitrary = genCtlOp shrink = genericShrink +instance Arbitrary a => Arbitrary (WithComments a) where + arbitrary = noComment <$> arbitrary + shrink (WithComments x _) = noComment <$> shrink x + + -------------------------------------------------------------------------------- -- Utility -------------------------------------------------------------------------------- diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs index dc0faee..4c1fbd5 100644 --- a/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs @@ -161,10 +161,11 @@ type2Spec = describe "type2" $ do `shouldParse` T2Map ( Group ( (NE.:| []) - [ GEType - Nothing - (Just (MKType (Type1 (T2Name (Name "int") Nothing) Nothing))) - (Type0 ((NE.:| []) (Type1 (T2Name (Name "string") Nothing) Nothing))) + [ noComment $ + GEType + Nothing + (Just (MKType (Type1 (T2Name (Name "int") Nothing) Nothing))) + (Type0 ((NE.:| []) (Type1 (T2Name (Name "string") Nothing) Nothing))) ] ) ) @@ -173,10 +174,11 @@ type2Spec = describe "type2" $ do `shouldParse` T2Map ( Group ( (NE.:| []) - [ GEType - (Just OIZeroOrMore) - (Just (MKType (Type1 (T2Name (Name "int") Nothing) Nothing))) - (Type0 ((NE.:| []) (Type1 (T2Name (Name "string") Nothing) Nothing))) + [ noComment $ + GEType + (Just OIZeroOrMore) + (Just (MKType (Type1 (T2Name (Name "int") Nothing) Nothing))) + (Type0 ((NE.:| []) (Type1 (T2Name (Name "string") Nothing) Nothing))) ] ) ) @@ -185,27 +187,29 @@ type2Spec = describe "type2" $ do parse pType2 "" "[int // string]" `shouldParse` T2Array ( Group - ( [ GEType - Nothing - Nothing - ( Type0 - ( Type1 - (T2Name (Name "int") Nothing) - Nothing - NE.:| [] - ) - ) - ] - NE.:| [ [ GEType - Nothing + ( [ noComment $ + GEType + Nothing + Nothing + ( Type0 + ( Type1 + (T2Name (Name "int") Nothing) Nothing - ( Type0 - ( Type1 - (T2Name (Name "string") Nothing) - Nothing - NE.:| [] - ) - ) + NE.:| [] + ) + ) + ] + NE.:| [ [ noComment $ + GEType + Nothing + Nothing + ( Type0 + ( Type1 + (T2Name (Name "string") Nothing) + Nothing + NE.:| [] + ) + ) ] ] ) @@ -215,15 +219,17 @@ type2Spec = describe "type2" $ do parse pType2 "" "[0 // 1]" `shouldParse` T2Array ( Group - ( [ GEType - Nothing - Nothing - (Type0 ((NE.:| []) (Type1 (T2Value (VUInt 0)) Nothing))) + ( [ noComment $ + GEType + Nothing + Nothing + (Type0 ((NE.:| []) (Type1 (T2Value (VUInt 0)) Nothing))) ] - NE.:| [ [ GEType - Nothing - Nothing - (Type0 ((NE.:| []) (Type1 (T2Value (VUInt 1)) Nothing))) + NE.:| [ [ noComment $ + GEType + Nothing + Nothing + (Type0 ((NE.:| []) (Type1 (T2Value (VUInt 1)) Nothing))) ] ] ) @@ -293,16 +299,17 @@ grpChoiceSpec :: SpecWith () grpChoiceSpec = describe "GroupChoice" $ do it "Should parse part of a group alternative" $ parse pGrpChoice "" "int // string" - `shouldParse` [ GEType - Nothing - Nothing - ( Type0 - ( Type1 - (T2Name (Name "int") Nothing) - Nothing - NE.:| [] - ) - ) + `shouldParse` [ noComment $ + GEType + Nothing + Nothing + ( Type0 + ( Type1 + (T2Name (Name "int") Nothing) + Nothing + NE.:| [] + ) + ) ] type1Spec :: Spec From 0be7c54249f0163f1a011b170f543276c2433489 Mon Sep 17 00:00:00 2001 From: Nicholas Clarke Date: Fri, 22 Nov 2024 16:36:46 +0100 Subject: [PATCH 2/2] Support constraining reference types Before this commit, it wasn't possible to apply constraints (e.g. '.size') to references, only directly to Value types. This gives us some nice type safety (you can't apply '.cbor' to an integer, for example), it also doesn't allow us to constrain types which are passed as generic parameters, or where we genuinely want to constrain another rule. This commit changes that by allowing references (both direct and generic) to be constrained. Obviously we don't have any guarantees here that what we are constraining makes sense, but we never had that in CDDL anyway. And we retain the type safety for anything that _isn't_ a reference. This resolves issue #31 --- cuddle.cabal | 2 +- example/Conway.hs | 9 +-- src/Codec/CBOR/Cuddle/Huddle.hs | 112 +++++++++++++++++++++++++------- 3 files changed, 95 insertions(+), 28 deletions(-) diff --git a/cuddle.cabal b/cuddle.cabal index 159b628..a477f95 100644 --- a/cuddle.cabal +++ b/cuddle.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: cuddle -version: 0.3.3.0 +version: 0.3.4.0 synopsis: CDDL Generator and test utilities -- description: diff --git a/example/Conway.hs b/example/Conway.hs index 1e9bf70..90ad50e 100644 --- a/example/Conway.hs +++ b/example/Conway.hs @@ -956,13 +956,14 @@ bounded_bytes = "bounded_bytes" =:= VBytes `sized` (0 :: Word64, 64 :: Word64) -- a type for distinct values. -- The type parameter must support .size, for example: bytes or uint -distinct :: (IsSizeable s) => Value s -> Rule -distinct x = - "distinct_" - <> T.pack (show x) + +distinct :: (IsType0 a, IsConstrainable a b) => a -> GRuleCall +distinct = binding $ \x -> + "distinct" =:= (x `sized` (8 :: Word64)) / (x `sized` (16 :: Word64)) / (x `sized` (20 :: Word64)) / (x `sized` (24 :: Word64)) / (x `sized` (30 :: Word64)) / (x `sized` (32 :: Word64)) + diff --git a/src/Codec/CBOR/Cuddle/Huddle.hs b/src/Codec/CBOR/Cuddle/Huddle.hs index e91ba1f..492d34e 100644 --- a/src/Codec/CBOR/Cuddle/Huddle.hs +++ b/src/Codec/CBOR/Cuddle/Huddle.hs @@ -1,8 +1,10 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -59,6 +61,7 @@ module Codec.CBOR.Cuddle.Huddle text, -- * Ctl operators + IsConstrainable, IsSizeable, sized, cbor, @@ -261,7 +264,7 @@ instance IsList Group where toList (Group l) = l data Type2 - = T2Basic Constrained + = T2Constrained Constrained | T2Literal Ranged | T2Map Map | T2Array Array @@ -346,11 +349,27 @@ inferInteger i -- Constraints and Ranges -------------------------------------------------------------------------------- --- | We only allow constraining basic values. +-- | A reference can be to any type, so we allow it to inhabit all +type AnyRef a = Named Type0 + +data Constrainable a + = CValue (Value a) + | CRef (AnyRef a) + | CGRef GRef + deriving (Show) + +-- | Uninhabited type used as marker for the type of thing a CRef sizes +data CRefType + +-- | Uninhabited type used as marker for the type of thing a CGRef sizes +data CGRefType + +-- | We only allow constraining basic values, or references. Of course, we +-- can't check what the references refer to. data Constrained where Constrained :: forall a. - { value :: Value a, + { value :: Constrainable a, constraint :: ValueConstraint a, -- | Sometimes constraints reference rules. In this case we need to -- collect the references in order to traverse them when collecting all @@ -361,8 +380,20 @@ data Constrained where deriving instance Show Constrained +class IsConstrainable a x | a -> x where + toConstrainable :: a -> Constrainable x + +instance IsConstrainable (AnyRef a) CRefType where + toConstrainable = CRef + +instance IsConstrainable (Value a) a where + toConstrainable = CValue + +instance IsConstrainable GRef CGRefType where + toConstrainable = CGRef + unconstrained :: Value a -> Constrained -unconstrained v = Constrained v def [] +unconstrained v = Constrained (CValue v) def [] -- | A constraint on a 'Value' is something applied via CtlOp or RangeOp on a -- Type2, forming a Type1. @@ -391,6 +422,10 @@ instance IsSizeable ByteString instance IsSizeable T.Text +instance IsSizeable CRefType + +instance IsSizeable CGRefType + -- | Things which can be used on the RHS of the '.size' operator. class IsSize a where sizeAsCDDL :: a -> C.Type2 @@ -412,11 +447,20 @@ instance IsSize (Word64, Word64) where ) sizeAsString (x, y) = show x <> ".." <> show y --- | Declare a size constraint on an int-style type. -sized :: (IsSizeable a, IsSize s) => Value a -> s -> Constrained +-- | Declare a size constraint on an int-style type or reference. +-- Since 0.3.4 this has worked for reference types as well as values. +sized :: + forall c a s. + ( IsSizeable a, + IsSize s, + IsConstrainable c a + ) => + c -> + s -> + Constrained sized v sz = Constrained - v + (toConstrainable @c @a v) ValueConstraint { applyConstraint = \t2 -> C.Type1 @@ -426,10 +470,15 @@ sized v sz = } [] -cbor :: Value ByteString -> Rule -> Constrained +class IsCborable a +instance IsCborable ByteString +instance IsCborable CRef +instance IsCborable CGRef + +cbor :: (IsCborable b, IsConstrainable c b) => c -> Rule -> Constrained cbor v r@(Named n _ _) = Constrained - v + (toConstrainable v) ValueConstraint { applyConstraint = \t2 -> C.Type1 @@ -439,10 +488,15 @@ cbor v r@(Named n _ _) = } [r] -le :: Value Int -> Word64 -> Constrained +class IsComparable a +instance IsComparable Int +instance IsComparable CRef +instance IsComparable CGRef + +le :: (IsComparable a, IsConstrainable c a) => c -> Word64 -> Constrained le v bound = Constrained - v + (toConstrainable v) ValueConstraint { applyConstraint = \t2 -> C.Type1 @@ -485,7 +539,7 @@ instance IsType0 (Choice Type2) where toType0 = id instance IsType0 Constrained where - toType0 = NoChoice . T2Basic + toType0 = NoChoice . T2Constrained instance IsType0 Map where toType0 = NoChoice . T2Map @@ -523,7 +577,7 @@ instance IsType0 Double where toType0 = NoChoice . T2Literal . Unranged . LDouble instance IsType0 (Value a) where - toType0 = NoChoice . T2Basic . unconstrained + toType0 = NoChoice . T2Constrained . unconstrained instance IsType0 (Named Group) where toType0 = NoChoice . T2Group @@ -667,7 +721,7 @@ instance IsChoosable ByteString Type2 where toChoice = toChoice . T2Literal . Unranged . LBytes instance IsChoosable Constrained Type2 where - toChoice = toChoice . T2Basic + toChoice = toChoice . T2Constrained instance (IsType0 a) => IsChoosable (Tagged a) Type2 where toChoice = toChoice . T2Tagged . fmap toType0 @@ -676,7 +730,7 @@ instance IsChoosable Literal Type2 where toChoice = toChoice . T2Literal . Unranged instance IsChoosable (Value a) Type2 where - toChoice = toChoice . T2Basic . unconstrained + toChoice = toChoice . T2Constrained . unconstrained instance IsChoosable (Named Group) Type2 where toChoice = toChoice . T2Group @@ -903,7 +957,13 @@ collectFrom topRs = -- Note that the parameters here may be different, so this doesn't live -- under the guard mapM_ goT2 $ args g - goT2 (T2Basic (Constrained _ _ refs)) = mapM_ goRule refs + goT2 (T2Constrained (Constrained c _ refs)) = + ( case c of + CValue _ -> pure () + CRef r -> goRule r + CGRef _ -> pure () + ) + >> mapM_ goRule refs goT2 _ = pure () goArrayEntry (ArrayEntry (Just k) t0 _ _) = goKey k >> goT0 t0 goArrayEntry (ArrayEntry Nothing t0 _ _) = goT0 t0 @@ -985,9 +1045,9 @@ toCDDL' mkPseudoRoot hdl = toCDDLType1 :: Type2 -> C.Type1 toCDDLType1 = \case - T2Basic (Constrained x constr _) -> + T2Constrained (Constrained x constr _) -> -- TODO Need to handle choices at the top level - applyConstraint constr (C.T2Name (toCDDLPostlude x) Nothing) + applyConstraint constr (C.T2Name (toCDDLConstrainable x) Nothing) T2Literal l -> toCDDLRanged l T2Map m -> C.Type1 @@ -1017,13 +1077,14 @@ toCDDL' mkPseudoRoot hdl = arrayEntryToCDDL :: ArrayEntry -> C.WithComments C.GroupEntry arrayEntryToCDDL (ArrayEntry k v occ cmnt) = - C.WithComments - ( C.GEType - (toOccurrenceIndicator occ) - (fmap toMemberKey k) - (toCDDLType0 v) + C.WithComments + ( C.GEType + (toOccurrenceIndicator occ) + (fmap toMemberKey k) + (toCDDLType0 v) ) (fmap C.Comment cmnt) + toCDDLPostlude :: Value a -> C.Name toCDDLPostlude VBool = C.Name "bool" toCDDLPostlude VUInt = C.Name "uint" @@ -1037,6 +1098,11 @@ toCDDL' mkPseudoRoot hdl = toCDDLPostlude VAny = C.Name "any" toCDDLPostlude VNil = C.Name "nil" + toCDDLConstrainable c = case c of + CValue v -> toCDDLPostlude v + CRef r -> C.Name $ name r + CGRef (GRef n) -> C.Name n + toCDDLRanged :: Ranged -> C.Type1 toCDDLRanged (Unranged x) = C.Type1 (C.T2Value $ toCDDLValue x) Nothing