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/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..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, @@ -92,7 +95,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 +116,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 +204,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 +225,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 +236,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" @@ -258,7 +264,7 @@ instance IsList Group where toList (Group l) = l data Type2 - = T2Basic Constrained + = T2Constrained Constrained | T2Literal Ranged | T2Map Map | T2Array Array @@ -343,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 @@ -358,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. @@ -388,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 @@ -409,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 @@ -423,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 @@ -436,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 @@ -482,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 @@ -520,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 @@ -584,7 +641,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 +654,8 @@ k ==> gc = MapEntry { key = k, value = toType0 gc, - quantifier = def + quantifier = def, + description = Nothing } infixl 8 ==> @@ -620,7 +679,8 @@ instance IsGroupOrArrayEntry ArrayEntry where ArrayEntry { key = Nothing, value = toType0 x, - quantifier = def + quantifier = def, + description = Nothing } instance IsGroupOrArrayEntry Type0 where @@ -661,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 @@ -670,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 @@ -897,11 +957,17 @@ 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 - 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 +1026,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 @@ -976,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 @@ -1006,12 +1075,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" @@ -1026,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 @@ -1042,7 +1119,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