From c622080fbe352dd730f6d7592ab188d9bb3a96bd Mon Sep 17 00:00:00 2001 From: Nicholas Clarke Date: Thu, 14 Nov 2024 16:04:30 +0100 Subject: [PATCH] Switch to using an ordered map for Huddle By using an ordered map we allow a lot of information for sorting the entries arising from Huddle, and in particular for _merging_ such entries, where we want to override some definitions. --- cuddle.cabal | 1 + src/Codec/CBOR/Cuddle/Huddle.hs | 47 +++++++++++++++++-------- src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs | 19 +++++++--- test/Test/Codec/CBOR/Cuddle/Huddle.hs | 45 ++++++++++++----------- 4 files changed, 72 insertions(+), 40 deletions(-) diff --git a/cuddle.cabal b/cuddle.cabal index ef3b3a1..159b628 100644 --- a/cuddle.cabal +++ b/cuddle.cabal @@ -71,6 +71,7 @@ library , mtl , mutable-containers , optics-core + , ordered-containers , parser-combinators , prettyprinter , random diff --git a/src/Codec/CBOR/Cuddle/Huddle.hs b/src/Codec/CBOR/Cuddle/Huddle.hs index 9986461..68b7cdc 100644 --- a/src/Codec/CBOR/Cuddle/Huddle.hs +++ b/src/Codec/CBOR/Cuddle/Huddle.hs @@ -94,7 +94,6 @@ import Data.ByteString (ByteString) import Data.Default.Class (Default (..)) import Data.Generics.Product (field, getField) import Data.List.NonEmpty qualified as NE -import Data.Map.Strict qualified as HaskMap import Data.String (IsString (fromString)) import Data.Text qualified as T import Data.Tuple.Optics (Field2 (..)) @@ -102,8 +101,10 @@ import Data.Void (Void) import Data.Word (Word64) import GHC.Exts (IsList (Item, fromList, toList)) import GHC.Generics (Generic) -import Optics.Core (view, (%~), (&), (.~)) +import Optics.Core (view, (%~), (&), (.~), (^.)) import Prelude hiding ((/)) +import Data.Map.Ordered.Strict qualified as OMap +import Data.Map.Ordered.Strict (OMap) data Named a = Named { name :: T.Text, @@ -131,13 +132,31 @@ data HuddleItem data Huddle = Huddle { -- | Root elements roots :: [Rule], - items :: [HuddleItem] + items :: OMap T.Text HuddleItem } deriving (Generic, Show) -instance Default Huddle where - def = Huddle [] [] +-- | This semigroup instance takes the roots from the RHS and uses the +-- RHS to override items on the LHS where they share a name. +-- The value from the RHS is taken, but the index from the LHS is used. +instance Semigroup Huddle where + h1 <> h2 = Huddle { + roots = roots h2, + items = OMap.unionWithL (\_ _ v2 -> v2) (items h1) (items h2) + } + +-- | This instance is mostly used for testing +instance IsList Huddle where + type Item Huddle = Rule + fromList [] = Huddle mempty OMap.empty + fromList (x : xs) = + (field @"items" %~ (OMap.|> (x ^. field @"name", HIRule x))) $ fromList xs + toList = const [] + +instance Default Huddle where + def = Huddle [] OMap.empty + data Choice a = NoChoice a | ChoiceOf a (Choice a) @@ -829,17 +848,17 @@ collectFrom topRs = toHuddle $ execState (traverse goRule topRs) - HaskMap.empty + OMap.empty where toHuddle items = Huddle { roots = topRs, - items = view _2 <$> HaskMap.toList items + items = items } goRule r@(Named n t0 _) = do items <- get - when (HaskMap.notMember n items) $ do - modify (HaskMap.insert n (HIRule r)) + when (OMap.notMember n items) $ do + modify (OMap.|> (n, HIRule r)) goT0 t0 goChoice f (NoChoice x) = f x goChoice f (ChoiceOf x xs) = f x >> goChoice f xs @@ -850,13 +869,13 @@ collectFrom topRs = goT2 (T2Ref n) = goRule n goT2 (T2Group r@(Named n g _)) = do items <- get - when (HaskMap.notMember n items) $ do - modify (HaskMap.insert n (HIGroup r)) + when (OMap.notMember n items) $ do + modify (OMap.|> (n, HIGroup r)) goGroup g goT2 (T2Generic r@(Named n g _)) = do items <- get - when (HaskMap.notMember n items) $ do - modify (HaskMap.insert n (HIGRule $ fmap callToDef r)) + when (OMap.notMember n items) $ do + modify (OMap.|> (n, HIGRule $ fmap callToDef r)) goT0 (body g) -- Note that the parameters here may be different, so this doesn't live -- under the guard @@ -890,7 +909,7 @@ toCDDL' mkPseudoRoot hdl = then (toTopLevelPseudoRoot (roots hdl) NE.<|) else id ) - $ fmap toCDDLItem (NE.fromList $ items hdl) + $ fmap toCDDLItem (NE.fromList $ fmap (view _2) $ toList $ items hdl) where toCDDLItem (HIRule r) = toCDDLRule r toCDDLItem (HIGroup g) = toCDDLGroup g diff --git a/src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs b/src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs index 6f679b3..307e971 100644 --- a/src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs +++ b/src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs @@ -17,8 +17,9 @@ 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 (Field2 (..), set, (%), (%~)) +import Optics.Core (set, (%~), (^.)) type HuddleM = State Huddle @@ -54,22 +55,30 @@ huddleDef :: HuddleM a -> Huddle huddleDef = snd . huddleDef' huddleDef' :: HuddleM a -> (a, Huddle) -huddleDef' mh = (_2 % field @"items") %~ reverse $ runState mh def +huddleDef' mh = runState mh def class Includable a where -- | Include a rule, group, or generic rule defined elsewhere include :: a -> HuddleM a instance Includable Rule where - include r = modify (field @"items" %~ (HIRule r :)) >> pure r + include r = + modify (field @"items" %~ (OMap.|> (r ^. field @"name", HIRule r))) + >> pure r instance Includable (Named Group) where - include r = modify ((field @"items") %~ (HIGroup r :)) >> pure r + include r = + modify + ( (field @"items") + %~ (OMap.|> (r ^. field @"name", HIGroup r)) + ) + >> pure r instance (IsType0 t0) => Includable (t0 -> GRuleCall) where include gr = let fakeT0 = error "Attempting to unwrap fake value in generic call" grDef = callToDef <$> gr fakeT0 + n = grDef ^. field @"name" in do - modify (field @"items" %~ (HIGRule grDef :)) + modify (field @"items" %~ (OMap.|> (n, HIGRule grDef))) pure gr diff --git a/test/Test/Codec/CBOR/Cuddle/Huddle.hs b/test/Test/Codec/CBOR/Cuddle/Huddle.hs index 37429e7..49d6a03 100644 --- a/test/Test/Codec/CBOR/Cuddle/Huddle.hs +++ b/test/Test/Codec/CBOR/Cuddle/Huddle.hs @@ -6,7 +6,7 @@ module Test.Codec.CBOR.Cuddle.Huddle where -import Codec.CBOR.Cuddle.CDDL (CDDL) +import Codec.CBOR.Cuddle.CDDL (CDDL, sortCDDL) import Codec.CBOR.Cuddle.Huddle import Codec.CBOR.Cuddle.Parser import Data.Text qualified as T @@ -26,37 +26,37 @@ huddleSpec = describe "huddle" $ do basicAssign :: Spec basicAssign = describe "basic assignment" $ do it "Can assign a primitive" $ - toCDDLNoRoot ["port" =:= VUInt] + toSortedCDDL ["port" =:= VUInt] `shouldMatchParseCDDL` "port = uint" it "Can assign an int" $ - toCDDLNoRoot ["one" =:= (int 1)] + toSortedCDDL ["one" =:= (int 1)] `shouldMatchParseCDDL` "one = 1" -- it "Can assign a float" $ - -- toCDDLNoRoot ["onepointone" =:= (1.1 :: Float)] + -- toSortedCDDL ["onepointone" =:= (1.1 :: Float)] -- `shouldMatchParseCDDL` "onepointone = 1.1" it "Can assign a text string" $ - toCDDLNoRoot ["hello" =:= ("Hello World" :: T.Text)] + toSortedCDDL ["hello" =:= ("Hello World" :: T.Text)] `shouldMatchParseCDDL` "hello = \"Hello World\"" it "Can handle multiple assignments" $ - toCDDLNoRoot ["age" =:= VUInt, "location" =:= VText] + toSortedCDDL ["age" =:= VUInt, "location" =:= VText] `shouldMatchParseCDDL` "age = uint\n location = text" arraySpec :: Spec arraySpec = describe "Arrays" $ do it "Can assign a small array" $ - toCDDLNoRoot ["asl" =:= arr [a VUInt, a VBool, a VText]] + toSortedCDDL ["asl" =:= arr [a VUInt, a VBool, a VText]] `shouldMatchParseCDDL` "asl = [ uint, bool, text ]" it "Can quantify an upper bound" $ - toCDDLNoRoot ["age" =:= arr [a VUInt +> 64]] + toSortedCDDL ["age" =:= arr [a VUInt +> 64]] `shouldMatchParseCDDL` "age = [ *64 uint ]" it "Can quantify an optional" $ - toCDDLNoRoot ["age" =:= arr [0 <+ a VUInt +> 1]] + toSortedCDDL ["age" =:= arr [0 <+ a VUInt +> 1]] `shouldMatchParseCDDL` "age = [ ? uint ]" it "Can handle a choice" $ - toCDDLNoRoot ["ageOrSex" =:= arr [a VUInt] / arr [a VBool]] + toSortedCDDL ["ageOrSex" =:= arr [a VUInt] / arr [a VBool]] `shouldMatchParseCDDL` "ageOrSex = [ uint // bool ]" it "Can handle choices of groups" $ - toCDDLNoRoot + toSortedCDDL [ "asl" =:= arr [a VUInt, a VBool, a VText] / arr @@ -69,19 +69,19 @@ arraySpec = describe "Arrays" $ do mapSpec :: Spec mapSpec = describe "Maps" $ do it "Can assign a small map" $ - toCDDLNoRoot ["asl" =:= mp ["age" ==> VUInt, "sex" ==> VBool, "location" ==> VText]] + toSortedCDDL ["asl" =:= mp ["age" ==> VUInt, "sex" ==> VBool, "location" ==> VText]] `shouldMatchParseCDDL` "asl = { age : uint, sex : bool, location : text }" it "Can quantify a lower bound" $ - toCDDLNoRoot ["age" =:= mp [0 <+ "years" ==> VUInt]] + toSortedCDDL ["age" =:= mp [0 <+ "years" ==> VUInt]] `shouldMatchParseCDDL` "age = { * years : uint }" it "Can quantify an upper bound" $ - toCDDLNoRoot ["age" =:= mp ["years" ==> VUInt +> 64]] + toSortedCDDL ["age" =:= mp ["years" ==> VUInt +> 64]] `shouldMatchParseCDDL` "age = { *64 years : uint }" it "Can handle a choice" $ - toCDDLNoRoot ["ageOrSex" =:= mp ["age" ==> VUInt] / mp ["sex" ==> VBool]] + toSortedCDDL ["ageOrSex" =:= mp ["age" ==> VUInt] / mp ["sex" ==> VBool]] `shouldMatchParseCDDL` "ageOrSex = { age : uint // sex : bool }" it "Can handle a choice with an entry" $ - toCDDLNoRoot ["mir" =:= arr [a (int 0 / int 1), a $ mp [0 <+ "test" ==> VUInt]]] + toSortedCDDL ["mir" =:= arr [a (int 0 / int 1), a $ mp [0 <+ "test" ==> VUInt]]] `shouldMatchParseCDDL` "mir = [ 0 / 1, { * test : uint }]" nestedSpec :: Spec @@ -89,11 +89,11 @@ nestedSpec = describe "Nesting" $ it "Handles references" $ let headerBody = "header_body" =:= arr ["block_number" ==> VUInt, "slot" ==> VUInt] - in toCDDLNoRoot + in toSortedCDDL [ headerBody, "header" =:= arr [a headerBody, "body_signature" ==> VBytes] ] - `shouldMatchParseCDDL` "header_body = [block_number : uint, slot : uint]\n header = [header_body, body_signature : bytes]" + `shouldMatchParseCDDL` "header = [header_body, body_signature : bytes]\n header_body = [block_number : uint, slot : uint]" genericSpec :: Spec genericSpec = @@ -105,11 +105,11 @@ genericSpec = dict = binding2 $ \k v -> "dict" =:= mp [0 <+ asKey k ==> v] in do it "Should bind a single parameter" $ - toCDDLNoRoot (collectFrom ["intset" =:= set VUInt]) + toSortedCDDL (collectFrom ["intset" =:= set VUInt]) `shouldMatchParseCDDL` "intset = set\n set = [* a0]" it "Should bind two parameters" $ - toCDDLNoRoot (collectFrom ["mymap" =:= dict VUInt VText]) - `shouldMatchParseCDDL` "mymap = dict\n dict = {* a0 => b0}" + toSortedCDDL (collectFrom ["mymap" =:= dict VUInt VText]) + `shouldMatchParseCDDL` "dict = {* a0 => b0}\n mymap = dict" -------------------------------------------------------------------------------- -- Helper functions @@ -128,3 +128,6 @@ shouldMatchParseCDDL :: String -> Expectation shouldMatchParseCDDL x = shouldMatchParse x pCDDL + +toSortedCDDL :: Huddle -> CDDL +toSortedCDDL = sortCDDL . toCDDLNoRoot