From 6d182e76be31e7ac6bcef8dae7c05c70bb36f208 Mon Sep 17 00:00:00 2001 From: Nicholas Clarke Date: Wed, 13 Nov 2024 14:23:16 +0100 Subject: [PATCH 1/3] Introduce HuddleM This is an attempt at addressing #35. We provide a monad for specifying Huddle definitions, which will collect them in definition order. This allows a fairly convenient way to put together a specification, at the cost of it being trickier to re-use definitions elsewhere, since they need to be returned from the monad. --- CHANGELOG.md | 7 +++ cuddle.cabal | 7 ++- example/Main.hs | 3 + example/Monad.hs | 24 ++++++++ example/cddl-files/basic_assign.cddl | 7 ++- src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs | 75 +++++++++++++++++++++++++ 6 files changed, 120 insertions(+), 3 deletions(-) create mode 100644 example/Monad.hs create mode 100644 src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index 3f2f9ff..7ac18ea 100644 --- a/CHANGELOG.md +++ b/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). diff --git a/cuddle.cabal b/cuddle.cabal index f1b36fc..ef3b3a1 100644 --- a/cuddle.cabal +++ b/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 diff --git a/example/Main.hs b/example/Main.hs index 61aca91..cc30956 100644 --- a/example/Main.hs +++ b/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 :: diff --git a/example/Monad.hs b/example/Monad.hs new file mode 100644 index 0000000..43b9525 --- /dev/null +++ b/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 () diff --git a/example/cddl-files/basic_assign.cddl b/example/cddl-files/basic_assign.cddl index aef553d..e827347 100644 --- a/example/cddl-files/basic_assign.cddl +++ b/example/cddl-files/basic_assign.cddl @@ -13,7 +13,7 @@ header_body = [ ] $kes_signature = bytes .size 32 -unit_interval = [0..denominator, denominator] +unit_interval = [0 .. denominator, denominator] unit_int = unit_interval @@ -28,3 +28,8 @@ usz4 = uint .size 4 usz8 = uint .size 8 group = (usz4, usz8 / mysize, header_body, { * uint => coin }) + +set = [ * a] +set2 = set + +coin_bag = set2 diff --git a/src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs b/src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs new file mode 100644 index 0000000..6f679b3 --- /dev/null +++ b/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 From 3358bdd4444a1b65d4f2cb28258e790440490e97 Mon Sep 17 00:00:00 2001 From: Nicholas Clarke Date: Thu, 14 Nov 2024 16:04:30 +0100 Subject: [PATCH 2/3] 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 | 52 ++++++++++++++++++------- src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs | 19 ++++++--- test/Test/Codec/CBOR/Cuddle/Huddle.hs | 45 +++++++++++---------- 4 files changed, 77 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..4511cef 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,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 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 From 8c66e35ded04866ad477af0474a79d67392e74d6 Mon Sep 17 00:00:00 2001 From: Nicholas Clarke Date: Fri, 15 Nov 2024 18:04:12 +0100 Subject: [PATCH 3/3] 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. --- example/Main.hs | 2 + example/Monad.hs | 50 +++++++++++++++++++------ src/Codec/CBOR/Cuddle/Huddle.hs | 44 ++++++++++++++-------- src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs | 20 ++++++++++ 4 files changed, 89 insertions(+), 27 deletions(-) diff --git a/example/Main.hs b/example/Main.hs index cc30956..1c9c9cf 100644 --- a/example/Main.hs +++ b/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 :: diff --git a/example/Monad.hs b/example/Monad.hs index 43b9525..39f712a 100644 --- a/example/Monad.hs +++ b/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 () + ) diff --git a/src/Codec/CBOR/Cuddle/Huddle.hs b/src/Codec/CBOR/Cuddle/Huddle.hs index 4511cef..7322c87 100644 --- a/src/Codec/CBOR/Cuddle/Huddle.hs +++ b/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 diff --git a/src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs b/src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs index 307e971..8a63be5 100644 --- a/src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs +++ b/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"