constrained-generators: Improve documentation in a bunch of places

Author: MaximilianAlgehed

docs/constrained-generators/DesignPrinciples.md

@@ -306,6 +306,9 @@ cradle:
     - path: "libs/constrained-generators/src"
       component: "lib:constrained-generators"
 
+    - path: "libs/constrained-generators/examples"
+      component: "constrained-generators:lib:examples"
+
     - path: "libs/constrained-generators/testlib"
       component: "constrained-generators:lib:testlib"
 

hie.yaml

@@ -30,10 +30,15 @@ module Test.Cardano.Ledger.Conformance.ExecSpecRule.Core (
 import Cardano.Ledger.BaseTypes (Globals, Inject (..), ShelleyBase)
 import Cardano.Ledger.Binary (EncCBOR)
 import Cardano.Ledger.Core (Era, EraRule, eraProtVerLow)
-import qualified Constrained.API as CV2 (HasSpec, Specification, genFromSpec, genFromSpecT)
-import Constrained.GenT (GE (..), GenMode (..))
-import qualified Constrained.GenT as CV1 (runGenT)
-import Constrained.Generation (shrinkWithSpec, simplifySpec)
+import Constrained.API (GE (..))
+import qualified Constrained.API as CV2 (
+  HasSpec,
+  Specification,
+  genFromSpec,
+  genFromSpecT,
+  looseGen,
+  shrinkWithSpec,
+ )
 import Control.Monad.Cont (ContT (..))
 import Control.Monad.Trans (MonadTrans (..))
 import Control.State.Transition.Extended (STS (..))
@@ -428,9 +433,8 @@ conformsToImpl = property @(ImpTestM era Property) . (`runContT` pure) $ do
   let
     forAllSpec spec = do
       let
-        simplifiedSpec = simplifySpec spec
-        generator = CV1.runGenT (CV2.genFromSpecT simplifiedSpec) Loose []
-        shrinker (Result x) = pure <$> shrinkWithSpec simplifiedSpec x
+        generator = CV2.looseGen (CV2.genFromSpecT spec)
+        shrinker (Result x) = pure <$> CV2.shrinkWithSpec spec x
         shrinker _ = []
       res :: GE a <- ContT $ \c ->
         pure $ forAllShrinkBlind generator shrinker c

libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/ExecSpecRule/Core.hs

@@ -45,9 +45,7 @@ import Cardano.Ledger.Conway.Scripts ()
 import Cardano.Ledger.Plutus.CostModels (CostModels)
 import Cardano.Ledger.Plutus.ExUnits
 import Cardano.Ledger.Shelley.PParams (ProposedPPUpdates (..))
-import Constrained.API
-import Constrained.GenT
-import Constrained.NumOrd
+import Constrained.API.Extend
 import Control.Monad.Identity (Identity (..))
 import Control.Monad.Trans.Fail.String
 import Data.Maybe

libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances/Basic.hs

@@ -115,8 +115,6 @@ import Cardano.Ledger.UMap
 import Cardano.Ledger.Val (Val)
 import Constrained.API.Extend hiding (Sized)
 import Constrained.API.Extend qualified as C
-import Constrained.GenT (pureGen, vectorOfT)
-import Constrained.Generic
 import Control.DeepSeq (NFData)
 import Crypto.Hash (Blake2b_224)
 import Data.ByteString qualified as BS

libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances/Ledger.hs

@@ -69,7 +69,6 @@ import Cardano.Ledger.Shelley (ShelleyEra)
 import Cardano.Ledger.Shelley.Scripts
 import Cardano.Ledger.Shelley.TxCert
 import Constrained.API
-import Constrained.GenT (pureGen)
 import Control.DeepSeq (NFData (..), deepseq)
 import Control.Monad (replicateM)
 import Data.ByteString (ByteString)

libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/WitnessUniverse.hs

@@ -26,16 +26,6 @@ library
     Constrained.Core
     Constrained.DependencyInjection
     Constrained.Env
-    Constrained.Examples
-    Constrained.Examples.Basic
-    Constrained.Examples.CheatSheet
-    Constrained.Examples.Either
-    Constrained.Examples.Fold
-    Constrained.Examples.List
-    Constrained.Examples.ManualExamples
-    Constrained.Examples.Map
-    Constrained.Examples.Set
-    Constrained.Examples.Tree
     Constrained.FunctionSymbol
     Constrained.GenT
     Constrained.Generation
@@ -45,6 +35,7 @@ library
     Constrained.NumOrd
     Constrained.PrettyUtils
     Constrained.Properties
+    Constrained.Spec.List
     Constrained.Spec.Map
     Constrained.Spec.Set
     Constrained.Spec.SumProd
@@ -76,6 +67,39 @@ library
     random,
     template-haskell,
 
+library examples
+  exposed-modules:
+    Constrained.Examples
+    Constrained.Examples.Basic
+    Constrained.Examples.BinTree
+    Constrained.Examples.CheatSheet
+    Constrained.Examples.Either
+    Constrained.Examples.Fold
+    Constrained.Examples.List
+    Constrained.Examples.ManualExamples
+    Constrained.Examples.Map
+    Constrained.Examples.Set
+    Constrained.Examples.Tree
+
+  hs-source-dirs: examples
+  default-language: Haskell2010
+  ghc-options:
+    -Wall
+    -Wcompat
+    -Wincomplete-record-updates
+    -Wincomplete-uni-patterns
+    -Wpartial-fields
+    -Wredundant-constraints
+    -Wunused-packages
+
+  build-depends:
+    QuickCheck >=2.14,
+    base >=4.18 && <5,
+    constrained-generators,
+    containers,
+    prettyprinter,
+    random,
+
 library testlib
   exposed-modules:
     Test.Minimal.Base
@@ -122,6 +146,7 @@ test-suite constrained
     QuickCheck,
     base,
     constrained-generators,
+    constrained-generators:examples,
     containers,
     hspec,
 

libs/constrained-generators/constrained-generators.cabal

@@ -0,0 +1,87 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Constrained.Examples.BinTree where
+
+import Constrained.API
+import GHC.Generics
+
+------------------------------------------------------------------------
+-- The types
+------------------------------------------------------------------------
+
+data BinTree a
+  = BinTip
+  | BinNode (BinTree a) a (BinTree a)
+  deriving (Ord, Eq, Show, Generic)
+
+------------------------------------------------------------------------
+-- HasSpec for BinTree
+------------------------------------------------------------------------
+
+data BinTreeSpec a = BinTreeSpec (Maybe Integer) (Specification (BinTree a, a, BinTree a))
+  deriving (Show)
+
+instance Forallable (BinTree a) (BinTree a, a, BinTree a) where
+  fromForAllSpec = typeSpec . BinTreeSpec Nothing
+  forAllToList BinTip = []
+  forAllToList (BinNode left a right) = (left, a, right) : forAllToList left ++ forAllToList right
+
+instance HasSpec a => HasSpec (BinTree a) where
+  type TypeSpec (BinTree a) = BinTreeSpec a
+
+  emptySpec = BinTreeSpec Nothing mempty
+
+  combineSpec (BinTreeSpec sz s) (BinTreeSpec sz' s') =
+    typeSpec $ BinTreeSpec (unionWithMaybe min sz sz') (s <> s')
+
+  conformsTo BinTip _ = True
+  conformsTo (BinNode left a right) s@(BinTreeSpec _ es) =
+    and
+      [ (left, a, right) `conformsToSpec` es
+      , left `conformsTo` s
+      , right `conformsTo` s
+      ]
+
+  genFromTypeSpec (BinTreeSpec msz s)
+    | Just sz <- msz, sz <= 0 = pure BinTip
+    | otherwise = do
+        let sz = maybe 20 id msz
+            sz' = sz `div` 2
+        oneofT
+          [ do
+              (left, a, right) <- genFromSpecT @(BinTree a, a, BinTree a) $
+                constrained $ \ctx ->
+                  [ match ctx $ \left _ right ->
+                      [ forAll left (`satisfies` s)
+                      , genHint sz' left
+                      , forAll right (`satisfies` s)
+                      , genHint sz' right
+                      ]
+                  , ctx `satisfies` s
+                  ]
+              pure $ BinNode left a right
+          , pure BinTip
+          ]
+
+  shrinkWithTypeSpec _ BinTip = []
+  shrinkWithTypeSpec s (BinNode left a right) =
+    BinTip
+      : left
+      : right
+      : (BinNode left a <$> shrinkWithTypeSpec s right)
+      ++ ((\l -> BinNode l a right) <$> shrinkWithTypeSpec s left)
+
+  cardinalTypeSpec _ = mempty
+
+  toPreds t (BinTreeSpec msz s) =
+    (forAll t $ \n -> n `satisfies` s)
+      <> maybe mempty (flip genHint t) msz
+
+instance HasSpec a => HasGenHint (BinTree a) where
+  type Hint (BinTree a) = Integer
+  giveHint h = typeSpec $ BinTreeSpec (Just h) mempty