Tools for extending Huddle specifications

We add some tools to allow extending Huddle specifications using the
semigroup instance established:

- We allow one to reference a HuddleItem (which is a rule, a group, or
a generic def) as a Type0.
- We then allow one to reference (by name) a HuddleItem from an existing
spec.

These two combined allow us to (somewhat) "extend" a specification in a
nice manner - we can reference items from the previous spec by their
name, and then selectively override things using the semigroup instance
(but respecting the original ordering).

There are two "disappointments" involved in this, however:
- Since the items from a previous spec are referenced by name, we lose
the type-safety provided by the Haskell compiler. It's quite possible to
refer to an item that doesn't exist, and you won't find out until
runtime.
- The whole thing falls apart for generic rules. When calling a generic
rule in the usual way, we do two things:
  - Apply the actual argument and turn it into a 'GRuleCall' which we
return to the call site.
  - Discard the argument, create an appropriate number of fresh names
and insert this into Huddle as a 'GRuleDef'. This crucially ignores any
actual arguments, which is why we can pass an error as a fake argument
in the Includable instance for HuddleM and have it all work.
  Unfortunately, what we cannot do is go from the 'GRuleDef' and extract
from it the fact that, on the Haskell side, this is a function (with an
unknown number of parameters). Which is very annoying.

I have some ideas about resolving this second issue in a
slightly-less-horrible way; they will follow in a subsequent commit.

Author: nc6

example/Main.hs

@@ -68,6 +68,8 @@ main = do
       putDocW 80 $ pretty cw
       putStrLn "--------------------------------------"
       putDocW 80 $ pretty (toCDDL Monad.spec)
+      putStrLn "--------------------------------------"
+      putDocW 80 $ pretty (toCDDL Monad.spec2)
     _ -> putStrLn "Expected filename"
 
 parseFromFile ::

example/Monad.hs

@@ -1,24 +1,52 @@
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecursiveDo #-}
-module Monad where 
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# HLINT ignore "Use camelCase" #-}
 
+module Monad where
+
+import Codec.CBOR.Cuddle.Huddle qualified as Huddle
 import Codec.CBOR.Cuddle.Huddle.HuddleM
 import Data.Word (Word64)
 
+hdl_set :: (IsType0 t0) => t0 -> GRuleCall
+hdl_set = Huddle.binding $ \x -> "set" Huddle.=:= arr [0 <+ a x]
+
 spec :: Huddle
-spec = huddleDef $ mdo 
-  transaction <- "transaction" =:= mp 
-    [ idx 0 ==> set txIn,
-      idx 1 ==> set txOut
-    ]
-  txIn <- "txIn" =:= arr [ "transaction_id" ==> hash32, "index" ==> txId]
-  txOut <- "txOut" =:= arr [ idx 0 ==> address, idx 1 ==> value]
+spec = huddleDef $ mdo
+  transaction <-
+    "transaction"
+      =:= mp
+        [ idx 0 ==> set txIn,
+          idx 1 ==> set txOut
+        ]
+  txIn <- "txIn" =:= arr ["transaction_id" ==> hash32, "index" ==> txId]
+  txOut <- "txOut" =:= arr [idx 0 ==> address, idx 1 ==> value]
   txId <- "txId" =:= VUInt `sized` (2 :: Word64)
   address <- "address" =:= VBytes `sized` (32 :: Word64)
   hash32 <- "hash32" =:= VBytes `sized` (32 :: Word64)
-  value <- "value" =:= VUInt 
-  set <- binding $ \x -> "set" =::= arr [0 <+ a x]
+  value <- "value" =:= VUInt
+  set <- include hdl_set
 
   setRootRules [transaction]
-  pure ()
+
+spec2 :: Huddle
+spec2 =
+  spec
+    <> huddleDef
+      ( mdo
+          set <- include hdl_set
+          txIn <- unsafeIncludeFromHuddle spec "txIn"
+          txOut <- unsafeIncludeFromHuddle spec "txOut"
+          _transaction <-
+            "transaction"
+              =:= mp
+                [ idx 0 ==> set txIn,
+                  idx 1 ==> set txOut,
+                  idx 2 ==> metadata
+                ]
+          metadata <- "metadata" =:= VBytes
+          _value <- "value" =:= mp ["token" ==> VText, "quantity" ==> VUInt]
+          pure ()
+      )

src/Codec/CBOR/Cuddle/Huddle.hs

@@ -94,6 +94,8 @@ 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.Ordered.Strict (OMap)
+import Data.Map.Ordered.Strict qualified as OMap
 import Data.String (IsString (fromString))
 import Data.Text qualified as T
 import Data.Tuple.Optics (Field2 (..))
@@ -103,8 +105,6 @@ import GHC.Exts (IsList (Item, fromList, toList))
 import GHC.Generics (Generic)
 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,
@@ -136,32 +136,37 @@ data Huddle = Huddle
   }
   deriving (Generic, Show)
 
--- | 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.
+-- | This semigroup instance:
+--   - Takes takes the roots from the RHS unless they are empty, in which case
+--     it takes the roots from the LHS
+--   - 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 
+--   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)
-  }
+instance Semigroup Huddle where
+  h1 <> h2 =
+    Huddle
+      { roots = case roots h2 of
+          [] -> roots h1
+          xs -> xs,
+        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 
+  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 
-  
+  def = Huddle [] OMap.empty
+
 data Choice a
   = NoChoice a
   | ChoiceOf a (Choice a)
@@ -529,6 +534,13 @@ instance IsType0 GRef where
 instance (IsType0 a) => IsType0 (Tagged a) where
   toType0 = NoChoice . T2Tagged . fmap toType0
 
+instance IsType0 HuddleItem where
+  toType0 (HIRule r) = toType0 r
+  toType0 (HIGroup g) = toType0 g
+  toType0 (HIGRule g) =
+    error $
+      "Attempt to reference generic rule from HuddleItem not supported: " <> show g
+
 class CanQuantify a where
   -- | Apply a lower bound
   (<+) :: Word64 -> a -> a

src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs

@@ -9,6 +9,7 @@ module Codec.CBOR.Cuddle.Huddle.HuddleM
     huddleDef,
     huddleDef',
     include,
+    unsafeIncludeFromHuddle,
   )
 where
 
@@ -82,3 +83,22 @@ instance (IsType0 t0) => Includable (t0 -> GRuleCall) where
      in do
           modify (field @"items" %~ (OMap.|> (n, HIGRule grDef)))
           pure gr
+
+instance Includable HuddleItem where
+  include x@(HIRule r) = include r >> pure x
+  include x@(HIGroup g) = include g >> pure x
+  include x@(HIGRule g) =
+    let n = g ^. field @"name"
+     in do
+          modify (field @"items" %~ (OMap.|> (n, x)))
+          pure x
+
+unsafeIncludeFromHuddle ::
+  Huddle ->
+  T.Text -> 
+  HuddleM HuddleItem
+unsafeIncludeFromHuddle h name =
+  let items = h ^. field @"items"
+   in case OMap.lookup name items  of
+        Just v -> include v
+        Nothing -> error $ show name <> " was not found in Huddle spec"