Merge pull request #40 from input-output-hk/nc/huddleM

Introduce HuddleM

Author: nc6

CHANGELOG.md

@@ -22,3 +22,10 @@
 ## 0.3.2.0 -- 2024-09-11 
 
 * Leading rather than trailing commas in the pretty printer.
+
+## 0.3.3.0 -- 2024-11-13
+
+* Introduce HuddleM, another way to define a Huddle spec. This allows total 
+  control over the order that items are presented in the CDDL, at the cost 
+  of making it somewhat harder to re-use items (they need to be returned from
+  the monad).

cuddle.cabal

@@ -1,6 +1,6 @@
 cabal-version:   3.4
 name:            cuddle
-version:         0.3.2.1
+version:         0.3.3.0
 synopsis:        CDDL Generator and test utilities
 
 -- description:
@@ -50,6 +50,7 @@ library
     Codec.CBOR.Cuddle.CDDL.Postlude
     Codec.CBOR.Cuddle.CDDL.Resolve
     Codec.CBOR.Cuddle.Huddle
+    Codec.CBOR.Cuddle.Huddle.HuddleM
     Codec.CBOR.Cuddle.Parser
     Codec.CBOR.Cuddle.Pretty
 
@@ -70,6 +71,7 @@ library
     , mtl
     , mutable-containers
     , optics-core
+    , ordered-containers
     , parser-combinators
     , prettyprinter
     , random
@@ -81,7 +83,9 @@ library
 executable example
   import:           warnings, ghc2021
   default-language: Haskell2010
-  other-modules:    Conway
+  other-modules:
+    Conway
+    Monad
 
   -- other-extensions:
   hs-source-dirs:   example

example/Main.hs

@@ -22,6 +22,7 @@ import Prettyprinter.Util (putDocW)
 import System.Environment (getArgs)
 import System.Random (getStdGen)
 import Text.Megaparsec (ParseErrorBundle, Parsec, errorBundlePretty, runParser)
+import qualified Monad
 
 main :: IO ()
 main = do
@@ -65,6 +66,10 @@ main = do
     [] -> do
       let cw = toCDDL conway
       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

@@ -0,0 +1,52 @@
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecursiveDo #-}
+{-# 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]
+  txId <- "txId" =:= VUInt `sized` (2 :: Word64)
+  address <- "address" =:= VBytes `sized` (32 :: Word64)
+  hash32 <- "hash32" =:= VBytes `sized` (32 :: Word64)
+  value <- "value" =:= VUInt
+  set <- include hdl_set
+
+  setRootRules [transaction]
+
+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 ()
+      )

example/cddl-files/basic_assign.cddl

@@ -13,7 +13,7 @@ header_body = [
 ]
 
 $kes_signature = bytes .size 32
-unit_interval<denominator> = [0..denominator, denominator]
+unit_interval<denominator> = [0 .. denominator, denominator]
 
 unit_int = unit_interval<uint>
 
@@ -28,3 +28,8 @@ usz4 = uint .size 4
 usz8 = uint .size 8
 
 group = (usz4, usz8 / mysize, header_body, { * uint => coin })
+
+set<a> = [ * a]
+set2<a> = set<a>
+
+coin_bag = set2<coin>

src/Codec/CBOR/Cuddle/Huddle.hs

@@ -94,15 +94,16 @@ 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.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 (..))
 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 ((/))
 
 data Named a = Named
@@ -131,12 +132,40 @@ data HuddleItem
 data Huddle = Huddle
   { -- | Root elements
     roots :: [Rule],
-    items :: [HuddleItem]
+    items :: OMap T.Text HuddleItem
   }
   deriving (Generic, Show)
 
+-- | 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
+--   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 = 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
+
+  toList = const []
+
 instance Default Huddle where
-  def = Huddle [] []
+  def = Huddle [] OMap.empty
 
 data Choice a
   = NoChoice a
@@ -505,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
@@ -829,17 +865,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 +886,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 +926,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

@@ -0,0 +1,104 @@
+-- | Monad for declaring Huddle constructs
+module Codec.CBOR.Cuddle.Huddle.HuddleM
+  ( module Huddle,
+    (=:=),
+    (=:~),
+    (=::=),
+    binding,
+    setRootRules,
+    huddleDef,
+    huddleDef',
+    include,
+    unsafeIncludeFromHuddle,
+  )
+where
+
+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
+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)
+n =:~ b = let r = n Huddle.=:~ b in include r
+
+infixl 1 =:~
+
+binding ::
+  forall t0.
+  (IsType0 t0) =>
+  (GRef -> Rule) ->
+  HuddleM (t0 -> GRuleCall)
+binding fRule = include (Huddle.binding fRule)
+
+-- | Renamed version of Huddle's underlying '=:=' for use in generic bindings
+(=::=) :: (IsType0 a) => T.Text -> a -> Rule
+n =::= b = n Huddle.=:= b
+
+infixl 1 =::=
+
+setRootRules :: [Rule] -> HuddleM ()
+setRootRules = modify . set (field @"roots")
+
+huddleDef :: HuddleM a -> Huddle
+huddleDef = snd . huddleDef'
+
+huddleDef' :: HuddleM a -> (a, Huddle)
+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" %~ (OMap.|> (r ^. field @"name", HIRule r)))
+      >> pure r
+
+instance Includable (Named Group) where
+  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" %~ (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"