diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,62 +1,70 @@ -# Revision history for cuddle +# Changelog for `cuddle` -## 0.1.0.0 -- YYYY-mm-dd +## 1.0.0.0 -* First version. Released on an unsuspecting world. +* First official release to Hackage +* Added one more parameter to `BindingEnv` -## 0.3.0.0 --2024-07-25 +## 0.5.0.0 -* Rationalise the choice operators. Drop (//) and provide detailed comments - explaining the use of (/). +* Implement a validator for CBOR terms. -## 0.3.0.1 -- 2024-07-31 +## 0.4.0.0 -* Improvements in the pretty printer - various groups should be formatted more - cleanly +* Rewrote the prettyprinter to make the output more human-readable. +* Added `collectFromInit` to make it possible to specify the order of + definitions manually. `collectFrom` and `collectFromInit` now expect + `HuddleItem`s in their arguments +* More Huddle terms now accept comments (e.g. `ArrayEntry`, `ArrayChoice`) +* Parser now preserves most comments. -## 0.3.1.0 -- 2024-08-15 +## 0.3.6.0 -* `collectFrom` now adds a first definition in the generated Huddle referencing - the top level elements, to be compatible with the CDDL spec. +* Support having keys in group entries. This is needed when using a group to + define a map, or when wishing to include keys in for-use-in-array groups for + documentation purposes. This may introduce problems with existing specifications + where some type hints (using 'a') are needed to properly type entries in groups, + where previously they were unambiguous. -## 0.3.2.0 -- 2024-09-11 + Note that it is not yet supported to use a group inside a map, where the + issue of merging keys arises. -* Leading rather than trailing commas in the pretty printer. +## O.3.5.0 -## 0.3.3.0 -- 2024-11-13 +* Add support for constraints on references and generic references. +* Add support for using references as range bounds. Note that this breaks + backwards compatibility - because the range arguments are now more generic, + additional hints are required to type literal numerics correctly. Typically + this is most easily fixed by adding a call `int` for any numeric literals in + ranges. An example is shown in `example/Conway.hs` +## 0.3.3.0 + * 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). -## O.3.5.0 -- 2024-11-25 +## 0.3.2.0 -* Add support for constraints on references and generic references. -* Add support for using references as range bounds. Note that this breaks - backwards compatibility - because the range arguments are now more generic, - additional hints are required to type literal numerics correctly. Typically - this is most easily fixed by adding a call `int` for any numeric literals in - ranges. An example is shown in `example/Conway.hs` +* Leading rather than trailing commas in the pretty printer. -## 0.3.6.0 -- 2024-12-02 -* Support having keys in group entries. This is needed when using a group to - define a map, or when wishing to include keys in for-use-in-array groups for - documentation purposes. This may introduce problems with existing specifications - where some type hints (using 'a') are needed to properly type entries in groups, - where previously they were unambiguous. +## 0.3.1.0 - Note that it is not yet supported to use a group inside a map, where the - issue of merging keys arises. +* `collectFrom` now adds a first definition in the generated Huddle referencing + the top level elements, to be compatible with the CDDL spec. -## 0.4.0.0 -- 2025-05-02 -* Rewrote the prettyprinter to make the output more human-readable. -* Added `collectFromInit` to make it possible to specify the order of - definitions manually. `collectFrom` and `collectFromInit` now expect - `HuddleItem`s in their arguments -* More Huddle terms now accept comments (e.g. `ArrayEntry`, `ArrayChoice`) -* Parser now preserves most comments. +## 0.3.0.1 -## 0.5.0.0 -- 2025-06-03 +* Improvements in the pretty printer - various groups should be formatted more + cleanly -* Implement a validator for CBOR terms. +## 0.3.0.0 + +* Rationalise the choice operators. Drop (//) and provide detailed comments + explaining the use of (/). + +## 0.1.0.0 + +* First version. Released on an unsuspecting world. + diff --git a/cuddle.cabal b/cuddle.cabal --- a/cuddle.cabal +++ b/cuddle.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: cuddle -version: 0.5.0.0 +version: 1.0.0.0 synopsis: CDDL Generator and test utilities description: Cuddle is a library for generating and manipulating [CDDL](https://datatracker.ietf.org/doc/html/rfc8610). @@ -16,7 +16,7 @@ license: Apache-2.0 license-file: LICENSE author: IOG Ledger Team -maintainer: nicholas.clarke@iohk.io, hackage@iohk.io +maintainer: hackage@iohk.io copyright: 2025 Input Output Global Inc (IOG) category: Codec build-type: Simple @@ -63,29 +63,29 @@ Codec.CBOR.Cuddle.Pretty.Utils build-depends: - base >=4.18 && <4.22, - base16-bytestring ^>=1.0.2, - boxes ^>=0.1.5, - bytestring >=0.11.4 && <0.13, - capability ^>=0.5, - cborg ^>=0.2.10, - containers >=0.6.7 && <0.8, - data-default-class ^>=0.2, - foldable1-classes-compat ^>=0.1.1, - generic-optics ^>=2.2.1, - hashable ^>=1.5, - megaparsec ^>=9.7, - mtl ^>=2.3.1, - mutable-containers ^>=0.3.4, - optics-core ^>=0.4.1, - ordered-containers ^>=0.2.4, - parser-combinators ^>=1.3, - prettyprinter ^>=1.7.1, - random <1.3, - regex-tdfa ^>=1.3.2, - scientific ^>=0.3.8, - text >=2.0.2 && <2.2, - tree-diff ^>=0.3.4, + base >=4.18 && <5, + base16-bytestring >=1.0.2, + boxes >=0.1.5, + bytestring >=0.11.4, + capability >=0.5, + cborg >=0.2.10, + containers >=0.6.7, + data-default-class >=0.2, + foldable1-classes-compat >=0.1.1, + generic-optics >=2.2.1, + hashable >=1.4, + megaparsec >=9.5, + mtl >=2.3.1, + mutable-containers >=0.3.4, + optics-core >=0.4.1, + ordered-containers >=0.2.4, + parser-combinators >=1.3, + prettyprinter >=1.7.1, + random >=1.2, + regex-tdfa >=1.3.2, + scientific >=0.3.7, + text >=2.0.2, + tree-diff >=0.3, hs-source-dirs: src default-language: GHC2021 @@ -126,7 +126,7 @@ cuddle, megaparsec, mtl, - optparse-applicative ^>=0.19, + optparse-applicative >=0.18, prettyprinter, random, text, @@ -145,16 +145,16 @@ hs-source-dirs: test main-is: Main.hs build-depends: - HUnit ^>=1.6.2, - QuickCheck ^>=2.15, + HUnit >=1.6.2, + QuickCheck >=2.14, base, bytestring, cuddle, data-default-class, - hspec ^>=2.11, - hspec-megaparsec ^>=2.2, + hspec >=2.11, + hspec-megaparsec >=2.2, megaparsec, prettyprinter, - string-qq ^>=0.0.6, + string-qq >=0.0.6, text, tree-diff, diff --git a/src/Codec/CBOR/Cuddle/CBOR/Gen.hs b/src/Codec/CBOR/Cuddle/CBOR/Gen.hs --- a/src/Codec/CBOR/Cuddle/CBOR/Gen.hs +++ b/src/Codec/CBOR/Cuddle/CBOR/Gen.hs @@ -1,19 +1,24 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} +#if MIN_VERSION_random(1,3,0) +{-# OPTIONS_GHC -Wno-deprecations #-} -- Due to usage of `split` +#endif -- | Generate example CBOR given a CDDL specification module Codec.CBOR.Cuddle.CBOR.Gen (generateCBORTerm, generateCBORTerm') where import Capability.Reader import Capability.Sink (HasSink) import Capability.Source (HasSource, MonadState (..)) -import Capability.State (HasState, get, modify, state) +import Capability.State (HasState, get, modify) import Codec.CBOR.Cuddle.CDDL ( Name (..), OccurrenceIndicator (..), @@ -31,6 +36,7 @@ import Control.Monad (join, replicateM, (<=<)) import Control.Monad.Reader (Reader, runReader) import Control.Monad.State.Strict (StateT, runStateT) +import Control.Monad.State.Strict qualified as MTL import Data.Bifunctor (second) import Data.ByteString (ByteString) import Data.ByteString.Base16 qualified as Base16 @@ -45,24 +51,25 @@ import GHC.Generics (Generic) import System.Random.Stateful ( Random, - RandomGen (genShortByteString, genWord32, genWord64), - RandomGenM, - StatefulGen (..), + RandomGen (..), + StateGenM (..), UniformRange (uniformRM), - applyRandomGenM, randomM, uniformByteStringM, ) +#if MIN_VERSION_random(1,3,0) +import System.Random.Stateful ( + SplitGen (..) + ) +#endif -------------------------------------------------------------------------------- -- Generator infrastructure -------------------------------------------------------------------------------- -- | Generator context, parametrised over the type of the random seed -data GenEnv g = GenEnv +newtype GenEnv = GenEnv { cddl :: CTreeRoot' Identity MonoRef - , fakeSeed :: CapGenM g - -- ^ Access the "fake" seed, necessary to recursively call generators } deriving (Generic) @@ -77,20 +84,42 @@ } deriving (Generic) -newtype M g a = M {runM :: StateT (GenState g) (Reader (GenEnv g)) a} - deriving (Functor, Applicative, Monad) +instance RandomGen g => RandomGen (GenState g) where + genWord8 = withRandomSeed genWord8 + genWord16 = withRandomSeed genWord16 + genWord32 = withRandomSeed genWord32 + genWord64 = withRandomSeed genWord64 + split = splitGenStateWith split + +#if MIN_VERSION_random(1,3,0) +instance SplitGen g => SplitGen (GenState g) where + splitGen = splitGenStateWith splitGen +#endif + +splitGenStateWith :: (g -> (g, g)) -> GenState g -> (GenState g, GenState g) +splitGenStateWith f s = + case f (randomSeed s) of + (gen', gen) -> (s {randomSeed = gen'}, s {randomSeed = gen}) + +withRandomSeed :: (t -> (a, g)) -> GenState t -> (a, GenState g) +withRandomSeed f s = + case f (randomSeed s) of + (r, gen) -> (r, s {randomSeed = gen}) + +newtype M g a = M {runM :: StateT (GenState g) (Reader GenEnv) a} + deriving (Functor, Applicative, Monad, MTL.MonadState (GenState g)) deriving (HasSource "randomSeed" g, HasSink "randomSeed" g, HasState "randomSeed" g) via Field "randomSeed" () - (MonadState (StateT (GenState g) (Reader (GenEnv g)))) + (MonadState (StateT (GenState g) (Reader GenEnv))) deriving (HasSource "depth" Int, HasSink "depth" Int, HasState "depth" Int) via Field "depth" () - (MonadState (StateT (GenState g) (Reader (GenEnv g)))) + (MonadState (StateT (GenState g) (Reader GenEnv))) deriving ( HasSource "cddl" (CTreeRoot' Identity MonoRef) , HasReader "cddl" (CTreeRoot' Identity MonoRef) @@ -98,42 +127,20 @@ via Field "cddl" () - (Lift (StateT (GenState g) (MonadReader (Reader (GenEnv g))))) - deriving - (HasSource "fakeSeed" (CapGenM g), HasReader "fakeSeed" (CapGenM g)) - via Field - "fakeSeed" - () - (Lift (StateT (GenState g) (MonadReader (Reader (GenEnv g))))) - --- | Opaque type carrying the type of a pure PRNG inside a capability-style --- state monad. -data CapGenM g = CapGenM - -instance RandomGen g => StatefulGen (CapGenM g) (M g) where - uniformWord64 _ = state @"randomSeed" genWord64 - uniformWord32 _ = state @"randomSeed" genWord32 - - uniformShortByteString n _ = state @"randomSeed" (genShortByteString n) - -instance RandomGen r => RandomGenM (CapGenM r) r (M r) where - applyRandomGenM f _ = state @"randomSeed" f + (Lift (StateT (GenState g) (MonadReader (Reader GenEnv)))) -runGen :: M g a -> GenEnv g -> GenState g -> (a, GenState g) +runGen :: M g a -> GenEnv -> GenState g -> (a, GenState g) runGen m env st = runReader (runStateT (runM m) st) env -evalGen :: M g a -> GenEnv g -> GenState g -> a +evalGen :: M g a -> GenEnv -> GenState g -> a evalGen m env = fst . runGen m env -asksM :: forall tag r m a. HasReader tag r m => (r -> m a) -> m a -asksM f = f =<< ask @tag - -------------------------------------------------------------------------------- -- Wrappers around some Random function in Gen -------------------------------------------------------------------------------- genUniformRM :: forall a g. (UniformRange a, RandomGen g) => (a, a) -> M g a -genUniformRM = asksM @"fakeSeed" . uniformRM +genUniformRM r = uniformRM r (StateGenM @(GenState g)) -- | Generate a random number in a given range, biased increasingly towards the -- lower end as the depth parameter increases. @@ -143,9 +150,8 @@ (a, a) -> M g a genDepthBiasedRM bounds = do - fs <- ask @"fakeSeed" d <- get @"depth" - samples <- replicateM d (uniformRM bounds fs) + samples <- replicateM d (genUniformRM bounds) pure $ minimum samples -- | Generates a bool, increasingly likely to be 'False' as the depth increases. @@ -155,10 +161,10 @@ and <$> replicateM d genRandomM genRandomM :: forall g a. (Random a, RandomGen g) => M g a -genRandomM = asksM @"fakeSeed" randomM +genRandomM = randomM (StateGenM @(GenState g)) genBytes :: forall g. RandomGen g => Int -> M g ByteString -genBytes n = asksM @"fakeSeed" $ uniformByteStringM n +genBytes n = uniformByteStringM n (StateGenM @(GenState g)) genText :: forall g. RandomGen g => Int -> M g Text genText n = pure $ T.pack . take n . join $ repeat ['a' .. 'z'] @@ -436,12 +442,12 @@ generateCBORTerm :: RandomGen g => CTreeRoot' Identity MonoRef -> Name -> g -> Term generateCBORTerm cddl n stdGen = - let genEnv = GenEnv {cddl, fakeSeed = CapGenM} + let genEnv = GenEnv {cddl} genState = GenState {randomSeed = stdGen, depth = 1} in evalGen (genForName n) genEnv genState generateCBORTerm' :: RandomGen g => CTreeRoot' Identity MonoRef -> Name -> g -> (Term, g) generateCBORTerm' cddl n stdGen = - let genEnv = GenEnv {cddl, fakeSeed = CapGenM} + let genEnv = GenEnv {cddl} genState = GenState {randomSeed = stdGen, depth = 1} in second randomSeed $ runGen (genForName n) genEnv genState