Convenience mkSystemBoltzmannSampler

generic-boltzmann-brain.cabal

@@ -31,6 +31,7 @@ library
       Data.Boltzmann.Sampler
       Data.Boltzmann.Sampler.TH
       Data.Boltzmann.System
+      Data.Boltzmann.System.TH
       Data.Boltzmann.Weighed
       Data.Boltzmann.Weighed.TH
       Data.BuffonMachine
@@ -61,7 +62,6 @@ executable binTreeProfile
   main-is: BinTreeProfile.hs
   other-modules:
       BinTree
-      BinTreeSampler
       Paths_generic_boltzmann_brain
   hs-source-dirs:
       profile/BinTree

profile/BinTree/BinTree.hs

@@ -1,32 +1,32 @@
 {-# LANGUAGE TemplateHaskell #-}
 
-module BinTree (BinTree (..)) where
+module BinTree (BinTree (..), randomBinTreeListIO) where
 
-import Data.Boltzmann.Samplable (Distribution, Samplable (..))
-import Data.Boltzmann.Samplable.TH (mkSamplable)
-import Data.Boltzmann.Sampler (BoltzmannSampler (..))
-import Data.Boltzmann.Sampler.TH (mkSampler)
+import Control.Monad (replicateM)
+import Data.Boltzmann.Samplable (Distribution (..), Samplable (..))
+import Data.Boltzmann.Sampler (BoltzmannSampler (..), rejectionSampler)
 import Data.Boltzmann.System (System (..))
+import Data.Boltzmann.System.TH (mkSystemBoltzmannSampler)
 import Data.Boltzmann.Weighed (Weighed (..))
-import Data.Boltzmann.Weighed.TH (mkWeighed)
+import Data.BuffonMachine (evalIO)
+import System.Random.SplitMix (SMGen)
 
 data BinTree
   = Leaf
   | Node BinTree BinTree
   deriving (Show)
 
-mkWeighed
-  ''BinTree
-  [ ('Leaf, 0)
-  , ('Node, 1)
-  ]
-
-mkSamplable
+mkSystemBoltzmannSampler
   System
     { targetType = ''BinTree
     , meanSize = 1000
     , frequencies = []
-    , weights = []
+    , weights =
+        [ ('Leaf, 0)
+        , ('Node, 1)
+        ]
     }
 
-mkSampler ''BinTree
+randomBinTreeListIO :: Int -> Int -> Int -> IO [BinTree]
+randomBinTreeListIO lb ub n =
+  evalIO $ replicateM n (rejectionSampler @SMGen lb ub)

profile/BinTree/BinTreeProfile.hs

@@ -1,5 +1,4 @@
-import BinTree (BinTree)
-import BinTreeSampler (randomBinTreeListIO)
+import BinTree (BinTree, randomBinTreeListIO)
 
 sampler :: Int -> IO [BinTree]
 sampler = randomBinTreeListIO 8000 12000

profile/BinTree/BinTreeSampler.hs

@@ -1,12 +0,0 @@
-module BinTreeSampler (randomBinTreeListIO) where
-
-import BinTree (BinTree (..))
-import Control.Monad (replicateM)
-import Data.Boltzmann.Sampler (rejectionSampler)
-import Data.BuffonMachine (evalIO)
-import System.Random.SplitMix (SMGen)
-
-randomBinTreeListIO :: Int -> Int -> Int -> IO [BinTree]
-randomBinTreeListIO lb ub n =
-  evalIO $
-    replicateM n (rejectionSampler @SMGen lb ub)

src/Data/Boltzmann/Samplable/TH.hs

@@ -4,7 +4,7 @@ module Data.Boltzmann.Samplable.TH (mkSamplable) where
 
 import Control.Monad (forM, void)
 import Data.Boltzmann.System (
-  System,
+  System (..),
   collectTypes,
   hasAdmissibleFrequencies,
   paganiniSpecIO,

src/Data/Boltzmann/Sampler/TH.hs

@@ -7,7 +7,7 @@
 -- License     : BSD3
 -- Maintainer  : maciej.bendkowski@gmail.com
 -- Stability   : experimental
-module Data.Boltzmann.Sampler.TH (mkSampler) where
+module Data.Boltzmann.Sampler.TH (mkBoltzmannSampler) where
 
 import Control.Monad (guard)
 import qualified Control.Monad.Trans as T
@@ -185,8 +185,8 @@ genConstrGroup typ = do
   return $ zip consInfo [0 :: Integer ..]
 
 -- | Given a type name `a`, instantiates it as `BoltzmannSampler` of `a`.
-mkSampler :: Name -> Q [Dec]
-mkSampler typ = do
+mkBoltzmannSampler :: Name -> Q [Dec]
+mkBoltzmannSampler typ = do
   samplerBody <- gen typ
   let clazz = AppT (ConT $ mkName "BoltzmannSampler") (ConT typ)
       funDec = FunD (mkName "sample") [Clause [] (NormalB samplerBody) []]

src/Data/Boltzmann/System.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE Rank2Types #-}
-
 module Data.Boltzmann.System (
   collectTypes,
   System (..),

src/Data/Boltzmann/System/TH.hs

@@ -0,0 +1,15 @@
+module Data.Boltzmann.System.TH (mkSystemBoltzmannSampler) where
+
+import Data.Boltzmann.System (System (targetType, weights))
+
+import Data.Boltzmann.Samplable.TH (mkSamplable)
+import Data.Boltzmann.Sampler.TH (mkBoltzmannSampler)
+import Data.Boltzmann.Weighed.TH (mkWeighed)
+import Language.Haskell.TH (Q)
+import Language.Haskell.TH.Syntax (Dec)
+
+mkSystemBoltzmannSampler :: System -> Q [Dec]
+mkSystemBoltzmannSampler sys =
+  mkWeighed (targetType sys) (weights sys)
+    <> mkSamplable sys
+    <> mkBoltzmannSampler (targetType sys)