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..159b628 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 @@ -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 diff --git a/example/Main.hs b/example/Main.hs index 61aca91..1c9c9cf 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,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 :: diff --git a/example/Monad.hs b/example/Monad.hs new file mode 100644 index 0000000..39f712a --- /dev/null +++ b/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 () + ) 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.hs b/src/Codec/CBOR/Cuddle/Huddle.hs index 9986461..7322c87 100644 --- a/src/Codec/CBOR/Cuddle/Huddle.hs +++ b/src/Codec/CBOR/Cuddle/Huddle.hs @@ -94,7 +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.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 (..)) @@ -102,7 +103,7 @@ 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 diff --git a/src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs b/src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs new file mode 100644 index 0000000..8a63be5 --- /dev/null +++ b/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" 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