From a81e792cea6ff964e1ea2508659f230d55832405 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Joosep=20J=C3=A4=C3=A4ger?= Date: Fri, 28 Nov 2025 12:55:31 +0200 Subject: [PATCH] Add HasName --- cuddle.cabal | 1 - src/Codec/CBOR/Cuddle/CDDL.hs | 13 +++- src/Codec/CBOR/Cuddle/CDDL/Resolve.hs | 2 +- src/Codec/CBOR/Cuddle/Huddle.hs | 71 ++++++++++++---------- src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs | 10 +-- src/Codec/CBOR/Cuddle/Huddle/Optics.hs | 26 -------- test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs | 28 ++++----- 7 files changed, 68 insertions(+), 83 deletions(-) delete mode 100644 src/Codec/CBOR/Cuddle/Huddle/Optics.hs diff --git a/cuddle.cabal b/cuddle.cabal index 7a4b2ce..a01ccc5 100644 --- a/cuddle.cabal +++ b/cuddle.cabal @@ -52,7 +52,6 @@ library Codec.CBOR.Cuddle.Comments Codec.CBOR.Cuddle.Huddle Codec.CBOR.Cuddle.Huddle.HuddleM - Codec.CBOR.Cuddle.Huddle.Optics Codec.CBOR.Cuddle.IndexMappable Codec.CBOR.Cuddle.Parser Codec.CBOR.Cuddle.Parser.Lexer diff --git a/src/Codec/CBOR/Cuddle/CDDL.hs b/src/Codec/CBOR/Cuddle/CDDL.hs index 8251805..88367b8 100644 --- a/src/Codec/CBOR/Cuddle/CDDL.hs +++ b/src/Codec/CBOR/Cuddle/CDDL.hs @@ -38,6 +38,7 @@ module Codec.CBOR.Cuddle.CDDL ( GrpChoice (..), unwrap, compareRuleName, + HasName (..), -- Extension ForAllExtensions, XCddl, @@ -62,7 +63,7 @@ import Data.TreeDiff (ToExpr) import Data.Word (Word64, Word8) import GHC.Base (Constraint, Type) import GHC.Generics (Generic) -import Optics.Core ((%), (%~), (&)) +import Optics.Core (Lens', lens, (%), (%~), (&)) data family XXTopLevel i @@ -107,7 +108,7 @@ ruleTopLevel _ = Nothing -- | Sort the CDDL Rules on the basis of their names sortCDDL :: CDDL i -> NonEmpty (Rule i) -sortCDDL (CDDL r rs _) = NE.sortBy (compare `on` name . ruleName) $ r :| mapMaybe ruleTopLevel rs +sortCDDL (CDDL r rs _) = NE.sortBy (compare `on` unName . ruleName) $ r :| mapMaybe ruleTopLevel rs fromRules :: Monoid (XCddl i) => NonEmpty (Rule i) -> CDDL i fromRules (x :| xs) = CDDL x (TopLevelRule <$> xs) mempty @@ -155,7 +156,7 @@ deriving instance ForAllExtensions i ToExpr => ToExpr (TopLevel i) -- -- * Rule names (types or groups) do not appear in the actual CBOR -- encoding, but names used as "barewords" in member keys do. -newtype Name = Name {name :: T.Text} +newtype Name = Name {unName :: T.Text} deriving (Generic) deriving (Eq, Ord, Show) deriving newtype (Semigroup, Monoid) @@ -170,6 +171,12 @@ instance CollectComments Name where instance Hashable Name +class HasName a where + nameL :: Lens' a Name + +instance HasName Name where + nameL = lens id const + -- | -- assignt = "=" / "/=" -- assigng = "=" / "//=" diff --git a/src/Codec/CBOR/Cuddle/CDDL/Resolve.hs b/src/Codec/CBOR/Cuddle/CDDL/Resolve.hs index c6de72b..915b63c 100644 --- a/src/Codec/CBOR/Cuddle/CDDL/Resolve.hs +++ b/src/Codec/CBOR/Cuddle/CDDL/Resolve.hs @@ -307,7 +307,7 @@ buildRefCTree rules = PartialCTreeRoot $ uncurry toCTreeRule <$> rules toCTreeMemberKey :: MemberKey CTreePhase -> CTree OrReferenced toCTreeMemberKey (MKValue v) = CTree.Literal v - toCTreeMemberKey (MKBareword n) = CTree.Literal (Value (VText $ name n) mempty) + toCTreeMemberKey (MKBareword n) = CTree.Literal (Value (VText $ unName n) mempty) toCTreeMemberKey (MKType t1) = toCTreeT1 t1 -------------------------------------------------------------------------------- diff --git a/src/Codec/CBOR/Cuddle/Huddle.hs b/src/Codec/CBOR/Cuddle/Huddle.hs index dbb2307..c5f4ccd 100644 --- a/src/Codec/CBOR/Cuddle/Huddle.hs +++ b/src/Codec/CBOR/Cuddle/Huddle.hs @@ -91,6 +91,9 @@ module Codec.CBOR.Cuddle.Huddle ( -- * Generators withGenerator, + -- * Name + HasName (..), + -- * Conversion to CDDL collectFrom, collectFromInit, @@ -99,14 +102,14 @@ module Codec.CBOR.Cuddle.Huddle ( ) where -import Codec.CBOR.Cuddle.CDDL (CDDL, GenericParameter (..), XRule) +import Codec.CBOR.Cuddle.CDDL (CDDL, GenericParameter (..), HasName, Name (..), XRule, nameL) import Codec.CBOR.Cuddle.CDDL qualified as C import Codec.CBOR.Cuddle.CDDL.CBORGenerator (CBORGenerator (..), HasGenerator (..), WrappedTerm) import Codec.CBOR.Cuddle.CDDL.CtlOp qualified as CtlOp import Codec.CBOR.Cuddle.Comments (Comment (..), HasComment (..)) import Codec.CBOR.Cuddle.Comments qualified as C import Control.Monad (when) -import Control.Monad.State (MonadState (get), execState, modify) +import Control.Monad.State (MonadState (get), State, execState, modify) import Data.ByteString (ByteString) import Data.Default.Class (Default (..)) import Data.Function (on) @@ -151,18 +154,15 @@ newtype instance C.XXType2 HuddleStage = HuddleXXType2 Void deriving (Generic, Semigroup, Show, Eq) data Named a = Named - { name :: T.Text + { name :: Name , value :: a , description :: Maybe T.Text } - deriving (Functor, Generic) + deriving (Functor, Generic, Show) -- | Add a description to a rule or group entry, to be included as a comment. -comment :: HasComment a => T.Text -> a -> a -comment desc n = n & commentL %~ (<> Comment desc) - -instance Show (Named a) where - show (Named n _ _) = T.unpack n +comment :: HasComment a => Comment -> a -> a +comment desc n = n & commentL %~ (<> desc) data Rule = Rule { ruleDefinition :: Named Type0 @@ -176,6 +176,9 @@ instance HasGenerator Rule where instance HasComment Rule where commentL = #ruleExtra % #hxrComment +instance HasName Rule where + nameL = #ruleDefinition % nameL + data HuddleItem = HIRule Rule | HIGRule GRuleDef @@ -186,7 +189,7 @@ data HuddleItem data Huddle = Huddle { roots :: [Rule] -- ^ Root elements - , items :: OMap T.Text HuddleItem + , items :: OMap Name HuddleItem } deriving (Generic) @@ -221,7 +224,7 @@ instance IsList Huddle where type Item Huddle = Rule fromList [] = Huddle mempty OMap.empty fromList (r@(Rule x _) : xs) = - (field @"items" %~ (OMap.|> (x ^. field @"name", HIRule r))) $ fromList xs + (#items %~ (OMap.|> (x ^. nameL, HIRule r))) $ fromList xs toList = const [] @@ -437,7 +440,6 @@ 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 @@ -568,9 +570,9 @@ cbor v r@(Rule (Named n _ _) _) = { applyConstraint = \t2 -> C.Type1 t2 - (Just (C.CtrlOp CtlOp.Cbor, C.T2Name (C.Name n) Nothing)) + (Just (C.CtrlOp CtlOp.Cbor, C.T2Name n Nothing)) mempty - , showConstraint = ".cbor " <> T.unpack n + , showConstraint = ".cbor " <> T.unpack (unName n) } [r] @@ -598,7 +600,6 @@ le v bound = data RangeBound = RangeBoundLiteral Literal | RangeBoundRef (Named Type0) - deriving (Show) class IsRangeBound a where toRangeBound :: a -> RangeBound @@ -617,13 +618,12 @@ instance IsRangeBound Rule where data Ranged where Ranged :: - { lb :: RangeBound - , ub :: RangeBound - , bounds :: C.RangeBound + { _lb :: RangeBound + , _ub :: RangeBound + , _bounds :: C.RangeBound } -> Ranged Unranged :: Literal -> Ranged - deriving (Show) -- | Establish a closed range bound. (...) :: (IsRangeBound a, IsRangeBound b) => a -> b -> Ranged @@ -702,7 +702,8 @@ instance IsType0 HuddleItem where toType0 (HIGroup g) = toType0 g toType0 (HIGRule g) = error $ - "Attempt to reference generic rule from HuddleItem not supported: " <> show g + "Attempt to reference generic rule from HuddleItem not supported: " + <> T.unpack (unName (g ^. nameL)) class CanQuantify a where -- | Apply a lower bound @@ -767,12 +768,12 @@ k ==> gc = infixl 8 ==> -- | Assign a rule -(=:=) :: IsType0 a => T.Text -> a -> Rule +(=:=) :: IsType0 a => Name -> a -> Rule n =:= b = Rule (Named n (toType0 b) Nothing) def infixl 1 =:= -(=:~) :: T.Text -> Group -> Named Group +(=:~) :: Name -> Group -> Named Group n =:~ b = Named n b Nothing infixl 1 =:~ @@ -1026,7 +1027,7 @@ hiRule :: HuddleItem -> [Rule] hiRule (HIRule r) = [r] hiRule _ = [] -hiName :: HuddleItem -> T.Text +hiName :: HuddleItem -> Name hiName (HIRule (Rule (Named n _ _) _)) = n hiName (HIGroup (Named n _ _)) = n hiName (HIGRule (Named n _ _)) = n @@ -1049,6 +1050,7 @@ collectFrom topRs = goHuddleItem (HIRule r) = goRule r goHuddleItem (HIGroup g) = goNamedGroup g goHuddleItem (HIGRule (Named _ (GRule _ t0) _)) = goT0 t0 + goRule :: Rule -> State (OMap Name HuddleItem) () goRule r@(Rule (Named n t0 _) _) = do items <- get when (OMap.notMember n items) $ do @@ -1150,10 +1152,10 @@ toCDDL' HuddleConfig {..} hdl = where go _ [] = rs go s (x : xs) - | n `Set.member` s = error . T.unpack $ "Duplicate definitions found for '" <> n <> "'" + | n `Set.member` s = error . T.unpack $ "Duplicate definitions found for '" <> unName n <> "'" | otherwise = go (Set.insert n s) xs where - n = C.name (C.ruleName x) + n = C.ruleName x toCDDLItem (HIRule r) = toCDDLRule r toCDDLItem (HIGroup g) = toCDDLGroup g @@ -1166,7 +1168,7 @@ toCDDL' HuddleConfig {..} hdl = toCDDLRule :: Rule -> C.Rule HuddleStage toCDDLRule (Rule (Named n t0 c) extra) = ( \x -> - C.Rule (C.Name n) Nothing C.AssignEq x (extra & #hxrComment %~ (<> foldMap Comment c)) + C.Rule n Nothing C.AssignEq x (extra & #hxrComment %~ (<> foldMap Comment c)) ) . C.TOGType . C.Type0 @@ -1215,8 +1217,8 @@ toCDDL' HuddleConfig {..} hdl = T2Array x -> C.Type1 (C.T2Array $ arrayToCDDLGroup x) Nothing mempty T2Tagged (Tagged mmin x) -> C.Type1 (C.T2Tag mmin $ toCDDLType0 x) Nothing mempty - T2Ref (Named n _ _) -> C.Type1 (C.T2Name (C.Name n) Nothing) Nothing mempty - T2Group (Named n _ _) -> C.Type1 (C.T2Name (C.Name n) Nothing) Nothing mempty + T2Ref (Named n _ _) -> C.Type1 (C.T2Name n Nothing) Nothing mempty + T2Group (Named n _ _) -> C.Type1 (C.T2Name n Nothing) Nothing mempty T2Generic g -> C.Type1 (toGenericCall g) Nothing mempty T2GenericRef (GRef n) -> C.Type1 (C.T2Name (C.Name n) Nothing) Nothing mempty @@ -1256,7 +1258,7 @@ toCDDL' HuddleConfig {..} hdl = toCDDLConstrainable c = case c of CValue v -> toCDDLPostlude v - CRef r -> C.Name (name r) + CRef r -> name r CGRef (GRef n) -> C.Name n toCDDLRanged :: Ranged -> C.Type1 HuddleStage @@ -1270,12 +1272,12 @@ toCDDL' HuddleConfig {..} hdl = toCDDLRangeBound :: RangeBound -> C.Type2 HuddleStage toCDDLRangeBound (RangeBoundLiteral l) = C.T2Value $ toCDDLValue l - toCDDLRangeBound (RangeBoundRef (Named n _ _)) = C.T2Name (C.Name n) Nothing + toCDDLRangeBound (RangeBoundRef (Named n _ _)) = C.T2Name n Nothing toCDDLGroup :: Named Group -> C.Rule HuddleStage toCDDLGroup (Named n (Group t0s) c) = C.Rule - (C.Name n) + n Nothing C.AssignEq ( C.TOGGroup @@ -1293,13 +1295,13 @@ toCDDL' HuddleConfig {..} hdl = toGenericCall :: GRuleCall -> C.Type2 HuddleStage toGenericCall (Named n gr _) = C.T2Name - (C.Name n) + n (Just . C.GenericArg $ fmap toCDDLType1 (args gr)) toGenRuleDef :: GRuleDef -> C.Rule HuddleStage toGenRuleDef (Named n gr c) = C.Rule - (C.Name n) + n (Just gps) C.AssignEq ( C.TOGType @@ -1314,3 +1316,6 @@ toCDDL' HuddleConfig {..} hdl = withGenerator :: HasGenerator a => (forall g m. StatefulGen g m => g -> m WrappedTerm) -> a -> a withGenerator f = L.set generatorL (Just $ CBORGenerator f) + +instance HasName (Named a) where + nameL = #name diff --git a/src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs b/src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs index 8c6f255..03c33df 100644 --- a/src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs +++ b/src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs @@ -15,25 +15,25 @@ module Codec.CBOR.Cuddle.Huddle.HuddleM ( ) where +import Codec.CBOR.Cuddle.CDDL (Name) import Codec.CBOR.Cuddle.Huddle hiding (binding, (=:=), (=:~)) import Codec.CBOR.Cuddle.Huddle qualified as Huddle import Control.Monad.State.Strict (State, modify, runState) import Data.Default.Class (def) import Data.Generics.Product (HasField (..)) import Data.Map.Ordered.Strict qualified as OMap -import Data.Text qualified as T import Optics.Core (set, (%~), (^.)) type HuddleM = State Huddle -- | Overridden version of assignment which also adds the rule to the state -(=:=) :: IsType0 a => T.Text -> a -> HuddleM Rule +(=:=) :: IsType0 a => Name -> a -> HuddleM Rule n =:= b = let r = n Huddle.=:= b in include r infixl 1 =:= -- | Overridden version of group assignment which adds the rule to the state -(=:~) :: T.Text -> Group -> HuddleM (Named Group) +(=:~) :: Name -> Group -> HuddleM (Named Group) n =:~ b = let r = n Huddle.=:~ b in include r infixl 1 =:~ @@ -46,7 +46,7 @@ binding :: binding fRule = include (Huddle.binding fRule) -- | Renamed version of Huddle's underlying '=:=' for use in generic bindings -(=::=) :: IsType0 a => T.Text -> a -> Rule +(=::=) :: IsType0 a => Name -> a -> Rule n =::= b = n Huddle.=:= b infixl 1 =::= @@ -97,7 +97,7 @@ instance Includable HuddleItem where unsafeIncludeFromHuddle :: Huddle -> - T.Text -> + Name -> HuddleM HuddleItem unsafeIncludeFromHuddle h name = let items = h ^. field @"items" diff --git a/src/Codec/CBOR/Cuddle/Huddle/Optics.hs b/src/Codec/CBOR/Cuddle/Huddle/Optics.hs deleted file mode 100644 index 601d95b..0000000 --- a/src/Codec/CBOR/Cuddle/Huddle/Optics.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE DataKinds #-} - --- | Optics for mutating Huddle rules -module Codec.CBOR.Cuddle.Huddle.Optics (commentL, nameL) where - -import Codec.CBOR.Cuddle.Huddle -import Data.Generics.Product (HasField' (field')) -import Data.Text qualified as T -import Optics.Core - -mcommentL :: - HasField' "description" a (Maybe T.Text) => - Lens a a (Maybe T.Text) (Maybe T.Text) -mcommentL = field' @"description" - --- | Traversal to the comment field of a description. Using this we can for --- example set the comment with 'a & commentL .~ "This is a comment"' -commentL :: - HasField' "description" a (Maybe T.Text) => - AffineTraversal a a T.Text T.Text -commentL = mcommentL % _Just - --- | Lens to the name of a rule (or other named entity). Using this we can --- for example append to the name with 'a & nameL %~ (<> "_1")' -nameL :: Lens (Named a) (Named a) T.Text T.Text -nameL = field' @"name" diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs index 72130fc..7f68490 100644 --- a/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs @@ -195,7 +195,7 @@ type2Spec = describe "type2" $ do ( Just ( MKType ( Type1 - { t1Main = T2Name (Name {name = "int"}) Nothing + { t1Main = T2Name "int" Nothing , t1TyOp = Nothing , t1Comment = mempty } @@ -205,7 +205,7 @@ type2Spec = describe "type2" $ do ( Type0 { t0Type1 = Type1 - { t1Main = T2Name (Name {name = "string"}) Nothing + { t1Main = T2Name "string" Nothing , t1TyOp = Nothing , t1Comment = mempty } @@ -234,7 +234,7 @@ type2Spec = describe "type2" $ do ( Just ( MKType ( Type1 - { t1Main = T2Name (Name {name = "int"}) Nothing + { t1Main = T2Name "int" Nothing , t1TyOp = Nothing , t1Comment = mempty } @@ -244,7 +244,7 @@ type2Spec = describe "type2" $ do ( Type0 { t0Type1 = Type1 - { t1Main = T2Name (Name {name = "string"}) Nothing + { t1Main = T2Name "string" Nothing , t1TyOp = Nothing , t1Comment = mempty } @@ -276,7 +276,7 @@ type2Spec = describe "type2" $ do ( Type0 { t0Type1 = Type1 - { t1Main = T2Name (Name {name = "string"}) Nothing + { t1Main = T2Name "string" Nothing , t1TyOp = Nothing , t1Comment = mempty } @@ -295,7 +295,7 @@ type2Spec = describe "type2" $ do ( Type0 { t0Type1 = Type1 - { t1Main = T2Name (Name {name = "int"}) Nothing + { t1Main = T2Name "int" Nothing , t1TyOp = Nothing , t1Comment = mempty } @@ -314,7 +314,7 @@ type2Spec = describe "type2" $ do ( Type0 { t0Type1 = Type1 - { t1Main = T2Name (Name {name = "bytes"}) Nothing + { t1Main = T2Name "bytes" Nothing , t1TyOp = Nothing , t1Comment = mempty } @@ -345,7 +345,7 @@ type2Spec = describe "type2" $ do ( Type0 { t0Type1 = Type1 - { t1Main = T2Name (Name {name = "int"}) Nothing + { t1Main = T2Name "int" Nothing , t1TyOp = Nothing , t1Comment = mempty } @@ -367,7 +367,7 @@ type2Spec = describe "type2" $ do ( Type0 { t0Type1 = Type1 - { t1Main = T2Name (Name {name = "string"}) Nothing + { t1Main = T2Name "string" Nothing , t1TyOp = Nothing , t1Comment = mempty } @@ -477,7 +477,7 @@ type2Spec = describe "type2" $ do ( Type0 { t0Type1 = Type1 - { t1Main = T2Name (Name {name = "soon"}) Nothing + { t1Main = T2Name "soon" Nothing , t1TyOp = Nothing , t1Comment = mempty } @@ -505,7 +505,7 @@ grpEntrySpec = describe "GroupEntry" $ do ( Type0 { t0Type1 = Type1 - { t1Main = T2Name (Name {name = "int"}) Nothing + { t1Main = T2Name "int" Nothing , t1TyOp = Nothing , t1Comment = mempty } @@ -524,7 +524,7 @@ grpEntrySpec = describe "GroupEntry" $ do ( Type0 { t0Type1 = Type1 - { t1Main = T2Name (Name {name = "int"}) Nothing + { t1Main = T2Name "int" Nothing , t1TyOp = Nothing , t1Comment = mempty } @@ -545,7 +545,7 @@ grpEntrySpec = describe "GroupEntry" $ do Type1 { t1Main = T2Name - (Name {name = "a"}) + "a" ( Just ( GenericArg ( Type1 @@ -647,7 +647,7 @@ qcFoundSpec = Just ( CtrlOp CtlOp.Ge , T2EnumRef - (Name {name = "i"}) + "i" ( Just ( GenericArg ( Type1