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.

Author: nc6

cuddle.cabal

@@ -71,6 +71,7 @@ library
     , mtl
     , mutable-containers
     , optics-core
+    , ordered-containers
     , parser-combinators
     , prettyprinter
     , random

src/Codec/CBOR/Cuddle/Huddle.hs

@@ -94,16 +94,17 @@ 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 (..))
 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,36 @@ 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.
+--
+--   Note that this allows replacing items in the middle of a tree without 
+--   updating higher-level items which make use of them - that is, we do not
+--   need to "close over" higher-level terms, since by the time they have been
+--   built into a huddle structure, the references have been converted to keys.
+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 +853,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 +874,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 +914,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

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

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,31 +69,31 @@ 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
 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<uint>\n set<a0> = [* a0]"
           it "Should bind two parameters" $
-            toCDDLNoRoot (collectFrom ["mymap" =:= dict VUInt VText])
-              `shouldMatchParseCDDL` "mymap = dict<uint, text>\n dict<a0, b0> = {* a0 => b0}"
+            toSortedCDDL (collectFrom ["mymap" =:= dict VUInt VText])
+              `shouldMatchParseCDDL` "dict<a0, b0> = {* a0 => b0}\n mymap = dict<uint, text>"
 
 --------------------------------------------------------------------------------
 -- Helper functions
@@ -128,3 +128,6 @@ shouldMatchParseCDDL ::
   String ->
   Expectation
 shouldMatchParseCDDL x = shouldMatchParse x pCDDL
+
+toSortedCDDL :: Huddle -> CDDL
+toSortedCDDL = sortCDDL . toCDDLNoRoot