Introduce HuddleM

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
 
@@ -81,7 +82,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,8 @@ main = do
     [] -> do
       let cw = toCDDL conway
       putDocW 80 $ pretty cw
+      putStrLn "--------------------------------------"
+      putDocW 80 $ pretty (toCDDL Monad.spec)
     _ -> putStrLn "Expected filename"
 
 parseFromFile ::

example/Monad.hs

@@ -0,0 +1,24 @@
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecursiveDo #-}
+module Monad where 
+
+import Codec.CBOR.Cuddle.Huddle.HuddleM
+import Data.Word (Word64)
+
+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 <- binding $ \x -> "set" =::= arr [0 <+ a x]
+
+  setRootRules [transaction]
+  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/HuddleM.hs

@@ -0,0 +1,75 @@
+-- | Monad for declaring Huddle constructs
+module Codec.CBOR.Cuddle.Huddle.HuddleM
+  ( module Huddle,
+    (=:=),
+    (=:~),
+    (=::=),
+    binding,
+    setRootRules,
+    huddleDef,
+    huddleDef',
+    include,
+  )
+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.Text qualified as T
+import Optics.Core (Field2 (..), 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 = (_2 % field @"items") %~ reverse $ 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
+
+instance Includable (Named Group) where
+  include r = modify ((field @"items") %~ (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
+     in do
+          modify (field @"items" %~ (HIGRule grDef :))
+          pure gr