Sampler size tests.

generic-boltzmann-brain.cabal

@@ -83,101 +83,21 @@ library generic-boltzmann-brain-internal
     , vector >=0.12.3.1
   default-language: Haskell2010
 
-executable binTreeProfile
-  main-is: BinTreeProfile.hs
-  other-modules:
-      BinTree
-      Paths_generic_boltzmann_brain
-  hs-source-dirs:
-      profile/BinTree
-  default-extensions:
-      NumericUnderscores LambdaCase BangPatterns DerivingVia FlexibleInstances UndecidableInstances TypeApplications ScopedTypeVariables Rank2Types
-  ghc-options: -O2 -Wall -Wcompat -Wmissing-export-lists -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-name-shadowing -fwarn-missing-signatures -ddump-splices
-  build-depends:
-      QuickCheck >=2.14.2
-    , base >=4.7 && <5
-    , containers >=0.6.4
-    , data-default >=0.7.1.1
-    , generic-boltzmann-brain
-    , mtl >=2.2.2
-    , paganini-hs >=0.3.0.0
-    , random >=1.2.0
-    , splitmix >=0.1.0.4
-    , template-haskell >=2.17.0.0
-    , th-abstraction >=0.4.3.0
-    , th-lift >=0.8.2
-    , th-lift-instances >=0.1.18
-    , transformers >=0.5.6
-    , vector >=0.12.3.1
-  default-language: Haskell2010
-
-executable lambdaProfile
-  main-is: LambdaProfile.hs
-  other-modules:
-      Lambda
-      Paths_generic_boltzmann_brain
-  hs-source-dirs:
-      profile/Lambda
-  default-extensions:
-      NumericUnderscores LambdaCase BangPatterns DerivingVia FlexibleInstances UndecidableInstances TypeApplications ScopedTypeVariables Rank2Types
-  ghc-options: -O2 -Wall -Wcompat -Wmissing-export-lists -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-name-shadowing -fwarn-missing-signatures -ddump-splices
-  build-depends:
-      QuickCheck >=2.14.2
-    , base >=4.7 && <5
-    , containers >=0.6.4
-    , data-default >=0.7.1.1
-    , generic-boltzmann-brain
-    , mtl >=2.2.2
-    , paganini-hs >=0.3.0.0
-    , random >=1.2.0
-    , splitmix >=0.1.0.4
-    , template-haskell >=2.17.0.0
-    , th-abstraction >=0.4.3.0
-    , th-lift >=0.8.2
-    , th-lift-instances >=0.1.18
-    , transformers >=0.5.6
-    , vector >=0.12.3.1
-  default-language: Haskell2010
-
-executable treeProfile
-  main-is: TreeProfile.hs
-  other-modules:
-      Tree
-      Paths_generic_boltzmann_brain
-  hs-source-dirs:
-      profile/Tree
-  default-extensions:
-      NumericUnderscores LambdaCase BangPatterns DerivingVia FlexibleInstances UndecidableInstances TypeApplications ScopedTypeVariables Rank2Types
-  ghc-options: -O2 -Wall -Wcompat -Wmissing-export-lists -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-name-shadowing -fwarn-missing-signatures -ddump-splices
-  build-depends:
-      QuickCheck >=2.14.2
-    , base >=4.7 && <5
-    , containers >=0.6.4
-    , data-default >=0.7.1.1
-    , generic-boltzmann-brain
-    , mtl >=2.2.2
-    , paganini-hs >=0.3.0.0
-    , random >=1.2.0
-    , splitmix >=0.1.0.4
-    , template-haskell >=2.17.0.0
-    , th-abstraction >=0.4.3.0
-    , th-lift >=0.8.2
-    , th-lift-instances >=0.1.18
-    , transformers >=0.5.6
-    , vector >=0.12.3.1
-  default-language: Haskell2010
-
 test-suite generic-boltzmann-brain-test
   type: exitcode-stdio-1.0
   main-is: Spec.hs
   other-modules:
+      Test.Samplers.BinTree
+      Test.Samplers.Lambda
+      Test.Samplers.Tree
       Test.Unit.BuffonMachine
+      Test.Unit.Sampler
       Paths_generic_boltzmann_brain
   hs-source-dirs:
       test
   default-extensions:
       NumericUnderscores LambdaCase BangPatterns DerivingVia FlexibleInstances UndecidableInstances TypeApplications ScopedTypeVariables Rank2Types
-  ghc-options: -O2 -Wall -Wcompat -Wmissing-export-lists -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-name-shadowing -fwarn-missing-signatures
+  ghc-options: -O2 -Wall -Wcompat -Wmissing-export-lists -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-name-shadowing -fwarn-missing-signatures -ddump-splices
   build-depends:
       QuickCheck >=2.14.2
     , base >=4.7 && <5

hie.yaml

@@ -3,32 +3,8 @@ cradle:
     - path: "./src"
       component: "generic-boltzmann-brain:lib"
 
-    - path: "./profile/BinTree/BinTreeProfile.hs"
+    - path: "./internal"
-      component: "generic-boltzmann-brain:exe:binTreeProfile"
+      component: "generic-boltzmann-brain:lib:generic-boltzmann-brain-internal"
-
-    - path: "./profile/BinTree/BinTree.hs"
-      component: "generic-boltzmann-brain:exe:binTreeProfile"
-
-    - path: "./profile/BinTree/Paths_generic_boltzmann_brain.hs"
-      component: "generic-boltzmann-brain:exe:binTreeProfile"
-
-    - path: "./profile/Lambda/LambdaProfile.hs"
-      component: "generic-boltzmann-brain:exe:lambdaProfile"
-
-    - path: "./profile/Lambda/Lambda.hs"
-      component: "generic-boltzmann-brain:exe:lambdaProfile"
-
-    - path: "./profile/Lambda/Paths_generic_boltzmann_brain.hs"
-      component: "generic-boltzmann-brain:exe:lambdaProfile"
-
-    - path: "./profile/Tree/TreeProfile.hs"
-      component: "generic-boltzmann-brain:exe:treeProfile"
-
-    - path: "./profile/Tree/Tree.hs"
-      component: "generic-boltzmann-brain:exe:treeProfile"
-
-    - path: "./profile/Tree/Paths_generic_boltzmann_brain.hs"
-      component: "generic-boltzmann-brain:exe:treeProfile"
 
     - path: "./test"
       component: "generic-boltzmann-brain:test:generic-boltzmann-brain-test"

internal/Data/Boltzmann/Sampler.hs

@@ -10,15 +10,19 @@ module Data.Boltzmann.Sampler (
   BoltzmannSampler (..),
 
   -- * Rejection samplers
+  LowerBound (..),
+  UpperBound (..),
   rejectionSampler,
   toleranceRejectionSampler,
 
   -- * Other utilities
-  hoistBoltzmannSampler,
+  hoistRejectionSampler,
+  hoistToleranceRejectionSampler,
 ) where
 
 import Control.Monad.Trans.Maybe (MaybeT, runMaybeT)
 import Data.Boltzmann.BuffonMachine (BuffonMachine, eval)
+import Data.Coerce (coerce)
 import System.Random (RandomGen)
 import Test.QuickCheck (Gen)
 import Test.QuickCheck.Gen (Gen (MkGen))
@@ -31,16 +35,27 @@ class BoltzmannSampler a where
   --  the given upper bound parameter, @Nothing@ is returned instead.
   sample :: RandomGen g => Int -> MaybeT (BuffonMachine g) (a, Int)
 
+-- | Lower bound for rejection samplers.
+newtype LowerBound = MkLowerBound Int
+  deriving (Show)
+
+-- | Upper bound for rejection samplers.
+newtype UpperBound = MkUpperBound Int
+  deriving (Show)
+
 -- |
 --  Rejection sampler for type @a@. Given lower and upper bound @lb@ and @ub@
 --  generates a random objects of size on between @lb@ and @ub@.
 rejectionSampler ::
-  (RandomGen g, BoltzmannSampler a) => Int -> Int -> BuffonMachine g a
+  (RandomGen g, BoltzmannSampler a) =>
+  LowerBound ->
+  UpperBound ->
+  BuffonMachine g a
 rejectionSampler lb ub = do
-  runMaybeT (sample ub)
+  runMaybeT (sample $ coerce ub)
     >>= ( \case
             Just (obj, s) ->
-              if lb <= s && s <= ub
+              if coerce lb <= s && s <= coerce ub
                 then pure obj
                 else rejectionSampler lb ub
             Nothing -> rejectionSampler lb ub
@@ -48,19 +63,31 @@ rejectionSampler lb ub = do
 
 -- |
 --  Rejection sampler for type @a@ which uses a given @eps@ parameter to
---  determine the admissible size window @[(1-eps) N, (1+eps) N]@ for a
+--  determine the admissible size window @[(1-eps) n, (1+eps) n]@ centered
---  sampler centered around the target mean size @N@.
+--  around the given size @n@.
 toleranceRejectionSampler ::
   (RandomGen g, BoltzmannSampler a) => Int -> Double -> BuffonMachine g a
 toleranceRejectionSampler n eps = rejectionSampler lb ub
   where
-    lb = floor $ (1 - eps) * fromIntegral n
+    lb = MkLowerBound $ floor $ (1 - eps) * fromIntegral n
-    ub = ceiling $ (1 + eps) * fromIntegral n
+    ub = MkUpperBound $ ceiling $ (1 + eps) * fromIntegral n
 
 -- |
---  Hoists a given Boltzmann sampler for @a@ into
+--  Using the given tolerance, hoists a tolerance rejection sampler
---  a Quickcheck generator @Gen a@.
+--  for @a@ to a Quickcheck generator @Gen a@.
-hoistBoltzmannSampler :: BoltzmannSampler a => Gen a
+hoistRejectionSampler ::
-hoistBoltzmannSampler = MkGen $ \(QCGen g) n ->
+  BoltzmannSampler a =>
-  let machine = rejectionSampler 0 n
+  (Int -> (LowerBound, UpperBound)) ->
+  Gen a
+hoistRejectionSampler genBounds = MkGen $ \(QCGen g) n ->
+  let (lb, ub) = genBounds n
+      machine = rejectionSampler lb ub
+   in eval machine g
+
+-- |
+--  Using the given tolerance, hoists a tolerance rejection sampler
+--  for @a@ to a Quickcheck generator @Gen a@.
+hoistToleranceRejectionSampler :: BoltzmannSampler a => Double -> Gen a
+hoistToleranceRejectionSampler eps = MkGen $ \(QCGen g) n ->
+  let machine = toleranceRejectionSampler n eps
    in eval machine g

internal/Data/Boltzmann/System/TH.hs

@@ -46,7 +46,7 @@ import Data.Boltzmann.System (
 import Data.Coerce (coerce)
 import Data.Default (def)
 import Data.Functor ((<&>))
-import Language.Haskell.TH (Exp (LamCaseE), Name, Q, Type (ListT))
+import Language.Haskell.TH (Exp (LamCaseE), Name, Q, Type (ArrowT, ListT))
 import Language.Haskell.TH.Datatype (
   ConstructorInfo (constructorFields, constructorName),
   DatatypeInfo (datatypeCons),
@@ -114,6 +114,34 @@ mkCoerce tv = do
       Plain tn -> ConT $ coerce tn
       List tn -> AppT ListT (ConT $ coerce tn)
 
+toTypeVariant :: Type -> SamplerGen TypeVariant
+toTypeVariant (ConT tn) = pure . Plain $ coerce tn
+toTypeVariant (AppT ListT (ConT tn)) = pure . List $ coerce tn
+toTypeVariant typ = fail $ "Unsupported type " ++ show typ
+
+mkConstrCoerce :: TypeVariant -> ConstructorInfo -> SamplerGen Exp
+mkConstrCoerce tv info = do
+  typeVariants <- mapM toTypeVariant (constructorFields info)
+  let constrType = foldr arr (convert tv) (map convert typeVariants)
+
+  typSynonym <- findTypeSyn tv
+  synonyms <- mapM findTypeSyn typeVariants
+  let constrSynType = foldr arr typSynonym synonyms
+
+  let fromType = constrType
+      toType = constrSynType
+
+  coerce' <- lift [|coerce|]
+  pure $ AppTypeE (AppTypeE coerce' fromType) toType
+  where
+    convert :: TypeVariant -> Type
+    convert = \case
+      Plain tn -> ConT $ coerce tn
+      List tn -> AppT ListT (ConT $ coerce tn)
+
+    arr :: Type -> Type -> Type
+    arr a = AppT (AppT ArrowT a)
+
 mkPat :: String -> Q Pat
 mkPat = pure . VarP . mkName
 
@@ -125,12 +153,12 @@ mkCon = pure . ConE . coerce
 
 mkCaseConstr :: TypeVariant -> SamplerGen Exp
 mkCaseConstr = \case
-  Plain tn -> do
+  tv@(Plain tn) -> do
     typInfo <- lift $ reifyDatatype (coerce tn)
     let constrInfo = datatypeCons typInfo
         constrGroup = zip constrInfo [0 :: Integer ..]
 
-    caseMatches <- mapM (mkCaseMatch tn) constrGroup
+    caseMatches <- mapM (mkCaseMatch tv) constrGroup
     pure $ LamCaseE caseMatches
   tv -> do
     coerceExp <- mkCoerce tv
@@ -144,10 +172,10 @@ mkCaseConstr = \case
             pure ($(pure coerceExp) (x : xs), w + ws)
         |]
 
-mkCaseMatch :: TypeName -> (ConstructorInfo, Integer) -> SamplerGen Match
+mkCaseMatch :: TypeVariant -> (ConstructorInfo, Integer) -> SamplerGen Match
-mkCaseMatch typ (constr, idx) = do
+mkCaseMatch tv (constr, idx) = do
   let n' = LitP $ IntegerL idx
-  conExpr <- mkConExpr typ constr
+  conExpr <- mkConExpr tv constr
   pure $ Match n' (NormalB conExpr) []
 
 data ArgExp = ArgExp
@@ -209,24 +237,23 @@ mkArgExpr constr = do
       name <- lift $ newName s
       pure (VarP name, VarE name)
 
-mkConExpr :: TypeName -> ConstructorInfo -> SamplerGen Exp
+mkConExpr :: TypeVariant -> ConstructorInfo -> SamplerGen Exp
-mkConExpr typ constr = do
+mkConExpr tv constr = do
   ArgExp {..} <- mkArgExpr constr
   let constrName = MkConstructorName (constructorName constr)
   constrWeight <- getWeight $ coerce constrName
 
   constrExp <- lift $ mkCon constrName
-  exp <- lift . pure $ foldl AppE constrExp args
+  coercedConstrExp <- mkConstrCoerce tv constr
+  exp <- lift . pure $ foldl AppE (AppE coercedConstrExp constrExp) args
 
-  coerceExp <- mkCoerce (Plain typ) -- TODO(mbendkowski): FIX
-  object <- lift [|$(pure coerceExp) $(pure exp)|]
   weightExp <- lift [|$(Lift.lift constrWeight) + $(pure weight)|]
 
-  pureExp <- lift [|pure ($(pure object), $(pure weightExp))|]
+  pureExp <- lift [|pure ($(pure exp), $(pure weightExp))|]
   pure $ DoE Nothing (stmts <> [NoBindS pureExp])
 
 mkGuard :: SamplerGen Exp
-mkGuard = lift [|guard ($(mkVar "ub") > 0)|]
+mkGuard = lift [|guard ($(mkVar "ub") >= 0)|]
 
 mkChoice :: TypeVariant -> SamplerGen Exp
 mkChoice typ = do

package.yaml

@@ -83,86 +83,6 @@ internal-libraries:
       ScopedTypeVariables
      Rank2Types
 
-executables:
-  binTreeProfile:
-    main:        BinTreeProfile.hs
-    source-dirs: profile/BinTree
-    ghc-options:
-    - -O2
-    - -Wall
-    - -Wcompat
-    - -Wmissing-export-lists
-    - -Wincomplete-record-updates
-    - -Wincomplete-uni-patterns
-    - -Wredundant-constraints
-    - -Wno-name-shadowing
-    - -fwarn-missing-signatures
-    - -ddump-splices
-    dependencies:
-    - generic-boltzmann-brain
-    default-extensions:
-      NumericUnderscores
-      LambdaCase
-      BangPatterns
-      DerivingVia
-      FlexibleInstances
-      UndecidableInstances
-      TypeApplications
-      ScopedTypeVariables
-      Rank2Types
-  treeProfile:
-    main:        TreeProfile.hs
-    source-dirs: profile/Tree
-    ghc-options:
-    - -O2
-    - -Wall
-    - -Wcompat
-    - -Wmissing-export-lists
-    - -Wincomplete-record-updates
-    - -Wincomplete-uni-patterns
-    - -Wredundant-constraints
-    - -Wno-name-shadowing
-    - -fwarn-missing-signatures
-    - -ddump-splices
-    dependencies:
-    - generic-boltzmann-brain
-    default-extensions:
-      NumericUnderscores
-      LambdaCase
-      BangPatterns
-      DerivingVia
-      FlexibleInstances
-      UndecidableInstances
-      TypeApplications
-      ScopedTypeVariables
-      Rank2Types
-  lambdaProfile:
-    main:        LambdaProfile.hs
-    source-dirs: profile/Lambda
-    ghc-options:
-    - -O2
-    - -Wall
-    - -Wcompat
-    - -Wmissing-export-lists
-    - -Wincomplete-record-updates
-    - -Wincomplete-uni-patterns
-    - -Wredundant-constraints
-    - -Wno-name-shadowing
-    - -fwarn-missing-signatures
-    - -ddump-splices
-    dependencies:
-    - generic-boltzmann-brain
-    default-extensions:
-      NumericUnderscores
-      LambdaCase
-      BangPatterns
-      DerivingVia
-      FlexibleInstances
-      UndecidableInstances
-      TypeApplications
-      ScopedTypeVariables
-      Rank2Types
-
 tests:
   generic-boltzmann-brain-test:
     main:                Spec.hs
@@ -177,6 +97,7 @@ tests:
     - -Wredundant-constraints
     - -Wno-name-shadowing
     - -fwarn-missing-signatures
+    - -ddump-splices
     dependencies:
     - generic-boltzmann-brain-internal
     - generic-boltzmann-brain

profile/BinTree/BinTree.hs

@@ -1,37 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-
-module BinTree (BinTree (..), randomBinTreeListIO) where
-
-import Control.Monad (replicateM)
-
-import Data.Boltzmann (
-  BoltzmannSampler (..),
-  Constructable ((<:>)),
-  System (..),
-  evalIO,
-  mkBoltzmannSampler,
-  mkDefWeights,
-  toleranceRejectionSampler,
- )
-import Data.Default (Default (def))
-
-import System.Random.SplitMix (SMGen)
-
-data BinTree
-  = Leaf
-  | Node BinTree BinTree
-  deriving (Show)
-
-mkBoltzmannSampler
-  System
-    { targetType = ''BinTree
-    , meanSize = 1000
-    , frequencies = def
-    , weights =
-        ('Leaf, 0)
-          <:> $(mkDefWeights ''BinTree)
-    }
-
-randomBinTreeListIO :: Int -> IO [BinTree]
-randomBinTreeListIO n =
-  evalIO $ replicateM n (toleranceRejectionSampler @SMGen 1000 0.2)

profile/BinTree/BinTreeProfile.hs

@@ -1,4 +0,0 @@
-import BinTree (randomBinTreeListIO)
-
-main :: IO ()
-main = randomBinTreeListIO 100 >>= print

profile/Lambda/Lambda.hs

@@ -1,60 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-
-module Lambda (Lambda (..), randomLambdaListIO) where
-
-import Control.Monad (replicateM)
-
-import Data.Boltzmann (
-  BoltzmannSampler (..),
-  Constructable ((<:>)),
-  System (..),
-  evalIO,
-  mkBoltzmannSampler,
-  mkDefWeights,
-  toleranceRejectionSampler,
- )
-import Data.Default (Default (def))
-
-import System.Random.SplitMix (SMGen)
-
-data DeBruijn
-  = Z
-  | S DeBruijn
-  deriving (Show)
-
-data Lambda
-  = Index DeBruijn
-  | App Lambda Lambda
-  | Abs Lambda
-  deriving (Show)
-
-mkBoltzmannSampler
-  System
-    { targetType = ''Lambda
-    , meanSize = 10_000
-    , frequencies = def
-    , weights =
-        ('Index, 0)
-          <:> $(mkDefWeights ''Lambda)
-    }
-
-newtype BinLambda = MkBinLambda Lambda
-  deriving (Show)
-
-mkBoltzmannSampler
-  System
-    { targetType = ''BinLambda
-    , meanSize = 10_000
-    , frequencies =
-        ('Abs, 4500) <:> def
-    , weights =
-        ('Index, 0)
-          <:> ('App, 2)
-          <:> ('Abs, 2)
-          <:> $(mkDefWeights ''Lambda)
-    }
-
-randomLambdaListIO :: Int -> IO [BinLambda]
-randomLambdaListIO n =
-  evalIO $
-    replicateM n (toleranceRejectionSampler @SMGen 10_000 0.2)

profile/Lambda/LambdaProfile.hs

@@ -1,4 +0,0 @@
-import Lambda (randomLambdaListIO)
-
-main :: IO ()
-main = randomLambdaListIO 100 >>= print

profile/Tree/Tree.hs

@@ -1,28 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-
-module Tree (Tree (..), randomTreeListIO) where
-
-import Control.Monad (replicateM)
-
-import Data.Boltzmann (
-  BoltzmannSampler (..),
-  evalIO,
-  mkDefBoltzmannSampler,
-  toleranceRejectionSampler,
- )
-
-import System.Random.SplitMix (SMGen)
-
-data Tree = T [Tree]
-  deriving (Show)
-
-mkDefBoltzmannSampler ''Tree 100
-
-randomTreeListIO :: Int -> IO [Tree]
-randomTreeListIO n =
-  evalIO $ replicateM n (toleranceRejectionSampler @SMGen 1000 0.2)
-
-newtype Tree' = MkTree' Tree
-  deriving (Show)
-
-mkDefBoltzmannSampler ''Tree' 2000

profile/Tree/TreeProfile.hs

@@ -1,4 +0,0 @@
-import Tree (randomTreeListIO)
-
-main :: IO ()
-main = randomTreeListIO 100 >>= print

src/Data/Boltzmann.hs

@@ -8,11 +8,14 @@ module Data.Boltzmann (
 
   -- * Boltzmann samplers
   BoltzmannSampler (..),
+  LowerBound (..),
+  UpperBound (..),
   rejectionSampler,
   toleranceRejectionSampler,
   mkBoltzmannSampler,
   mkDefBoltzmannSampler,
-  hoistBoltzmannSampler,
+  hoistRejectionSampler,
+  hoistToleranceRejectionSampler,
 
   -- * Buffon machines
   BuffonMachine,
@@ -34,7 +37,10 @@ import Data.Boltzmann.System.TH (
 
 import Data.Boltzmann.Sampler (
   BoltzmannSampler (..),
-  hoistBoltzmannSampler,
+  LowerBound (..),
+  UpperBound (..),
+  hoistRejectionSampler,
+  hoistToleranceRejectionSampler,
   rejectionSampler,
   toleranceRejectionSampler,
  )

test/Spec.hs

@@ -1,5 +1,6 @@
 import Test.Tasty (TestTree, defaultMain, testGroup)
 import qualified Test.Unit.BuffonMachine as BuffonMachine
+import qualified Test.Unit.Sampler as Sampler
 
 main :: IO ()
 main = defaultMain tests
@@ -9,4 +10,6 @@ tests = testGroup "Unit tests" unitTests
 
 unitTests :: [TestTree]
 unitTests =
-  [BuffonMachine.unitTests]
+  [ BuffonMachine.unitTests
+  , Sampler.unitTests
+  ]

test/Test/Samplers/BinTree.hs

@@ -0,0 +1,44 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Test.Samplers.BinTree (BinTree (..), size) where
+
+import Data.Boltzmann (
+  BoltzmannSampler (..),
+  Constructable (..),
+  LowerBound (MkLowerBound),
+  System (..),
+  UpperBound (MkUpperBound),
+  hoistRejectionSampler,
+  mkBoltzmannSampler,
+  mkDefWeights,
+ )
+import Data.Default (def)
+import GHC.Generics (Generic)
+import Test.QuickCheck (Arbitrary (arbitrary, shrink))
+
+data BinTree
+  = Leaf
+  | Node BinTree BinTree
+  deriving (Generic, Show)
+
+size :: BinTree -> Int
+size = \case
+  Leaf -> 0
+  Node lt rt -> 1 + size lt + size rt
+
+mkBoltzmannSampler
+  System
+    { targetType = ''BinTree
+    , meanSize = 1000
+    , frequencies = def
+    , weights =
+        ('Leaf, 0)
+          <:> $(mkDefWeights ''BinTree)
+    }
+
+instance Arbitrary BinTree where
+  arbitrary =
+    hoistRejectionSampler $
+      const (MkLowerBound 800, MkUpperBound 1200)
+  shrink = const []

test/Test/Samplers/Lambda.hs

@@ -0,0 +1,94 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Test.Samplers.Lambda (
+  DeBruijn (..),
+  Lambda (..),
+  BinLambda (..),
+  size,
+  sizeBin,
+) where
+
+import Data.Boltzmann (
+  BoltzmannSampler (..),
+  Constructable (..),
+  LowerBound (MkLowerBound),
+  System (..),
+  UpperBound (MkUpperBound),
+  hoistRejectionSampler,
+  mkBoltzmannSampler,
+  mkDefWeights,
+ )
+import Data.Default (def)
+import GHC.Generics (Generic)
+import Test.QuickCheck (Arbitrary (arbitrary, shrink))
+
+data DeBruijn
+  = Z
+  | S DeBruijn
+  deriving (Generic, Show)
+
+instance Arbitrary DeBruijn where
+  arbitrary = undefined -- not used
+  shrink = const []
+
+data Lambda
+  = Index DeBruijn
+  | App Lambda Lambda
+  | Abs Lambda
+  deriving (Generic, Show)
+
+mkBoltzmannSampler
+  System
+    { targetType = ''Lambda
+    , meanSize = 10_000
+    , frequencies = ('Abs, 4_000) <:> def
+    , weights =
+        ('Index, 0)
+          <:> $(mkDefWeights ''Lambda)
+    }
+
+size' :: DeBruijn -> Int
+size' = \case
+  Z -> 1
+  S n -> 1 + size' n
+
+size :: Lambda -> Int
+size = \case
+  Index n -> size' n
+  App lt rt -> 1 + size lt + size rt
+  Abs t -> 1 + size t
+
+sizeBin :: BinLambda -> Int
+sizeBin = \case
+  MkBinLambda (Index n) -> size' n
+  MkBinLambda (App lt rt) ->
+    2 + sizeBin (MkBinLambda lt) + sizeBin (MkBinLambda rt)
+  MkBinLambda (Abs t) -> 2 + sizeBin (MkBinLambda t)
+
+instance Arbitrary Lambda where
+  arbitrary =
+    hoistRejectionSampler $
+      const (MkLowerBound 8_000, MkUpperBound 12_000)
+  shrink = const []
+
+newtype BinLambda = MkBinLambda Lambda
+  deriving (Generic, Show)
+
+mkBoltzmannSampler
+  System
+    { targetType = ''BinLambda
+    , meanSize = 6_000
+    , frequencies = def
+    , weights =
+        ('Index, 0)
+          <:> ('App, 2)
+          <:> ('Abs, 2)
+          <:> $(mkDefWeights ''Lambda)
+    }
+
+instance Arbitrary BinLambda where
+  arbitrary =
+    hoistRejectionSampler $
+      const (MkLowerBound 5_000, MkUpperBound 6_400)
+  shrink = const []

test/Test/Samplers/Tree.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Test.Samplers.Tree (Tree (..), size) where
+
+import Data.Boltzmann (
+  BoltzmannSampler (..),
+  LowerBound (MkLowerBound),
+  UpperBound (MkUpperBound),
+  hoistRejectionSampler,
+  mkDefBoltzmannSampler,
+ )
+import GHC.Generics (Generic)
+import Test.QuickCheck (Arbitrary (arbitrary, shrink))
+
+data Tree = T [Tree]
+  deriving (Generic, Show)
+
+mkDefBoltzmannSampler ''Tree 2000
+
+size :: Tree -> Int
+size = \case
+  T ts -> 1 + sum (map size ts)
+
+instance Arbitrary Tree where
+  arbitrary =
+    hoistRejectionSampler $
+      const (MkLowerBound 1600, MkUpperBound 2400)
+  shrink = const []

test/Test/Unit/Sampler.hs

@@ -0,0 +1,30 @@
+module Test.Unit.Sampler (unitTests) where
+
+import qualified Test.Samplers.BinTree as BinTree
+import qualified Test.Samplers.Lambda as Lambda
+import qualified Test.Samplers.Tree as Tree
+
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.QuickCheck as QC (testProperty)
+
+unitTests :: TestTree
+unitTests =
+  testGroup
+    "Sampler tests"
+    [ QC.testProperty "BinTree sampler respects size constraints" $
+        \binTree ->
+          let s = BinTree.size binTree
+           in 800 <= s && s <= 1200
+    , QC.testProperty "Tree sampler respects size constraints" $
+        \tree ->
+          let s = Tree.size tree
+           in 1600 <= s && s <= 2400
+    , QC.testProperty "Lambda sampler respects size constraints" $
+        \term ->
+          let s = Lambda.size term
+           in 8_000 <= s && s <= 12_000
+    , QC.testProperty "BinLambda sampler respects size constraints" $
+        \term ->
+          let s = Lambda.sizeBin term
+           in 5_000 <= s && s <= 6_400
+    ]