maciej-bendkowski/generic-boltzmann-brain
1
1
Fork 0
mirror of https://github.com/maciej-bendkowski/generic-boltzmann-brain.git synced 2024-08-17 00:20:40 +03:00
Code Issues Projects Releases Wiki Activity

Enable fourmolu code formatter

Browse Source
This commit is contained in:
Maciej Bendkowski 2022-01-23 14:13:59 +01:00
parent 04bfff59c9
commit 2924341479
17 changed files with 347 additions and 347 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
benchmark/BinTree.hs
View File

@ -7,16 +7,16 @@ module BinTree where
import Control.DeepSeq (NFData) import Control.DeepSeq (NFData)
import Data.Boltzmann.Sampler (BoltzmannSampler (..)) import Data.Boltzmann.Sampler (BoltzmannSampler (..))
import Data.Boltzmann.Sampler.Utils (mkSampler) import Data.Boltzmann.Sampler.Utils (mkSampler)
import Data.Boltzmann.Specifiable import Data.Boltzmann.Specifiable (
( Specifiable, Specifiable,
) )
import Data.Boltzmann.Specification import Data.Boltzmann.Specification (
( SystemSpec, SystemSpec,
specification, specification,
withSystem, withSystem,
withWeights, withWeights,
(==>), (==>),
) )
import GHC.Generics (Generic) import GHC.Generics (Generic)
data BinTree data BinTree
@ -28,10 +28,10 @@ binTreeSysSpec :: SystemSpec
binTreeSysSpec = binTreeSysSpec =
(undefined :: BinTree, 4000) (undefined :: BinTree, 4000)
`withSystem` [ specification `withSystem` [ specification
(undefined :: BinTree) (undefined :: BinTree)
( withWeights ( withWeights
['Leaf ==> 0] ['Leaf ==> 0]
) )
] ]
$(mkSampler ''BinTree) $(mkSampler ''BinTree)

8
fourmolu.yaml Normal file
View File

@ -0,0 +1,8 @@
indentation: 2
comma-style: leading
record-brace-space: true
indent-wheres: true
diff-friendly-import-export: true
respectful: true
haddock-style: single-line
newlines-between-decls: 1

95
src/Data/Boltzmann/Oracle.hs
View File

@ -8,59 +8,56 @@
-- License : BSD3 -- License : BSD3
-- Maintainer : maciej.bendkowski@gmail.com -- Maintainer : maciej.bendkowski@gmail.com
-- Stability : experimental -- Stability : experimental
-- module Data.Boltzmann.Oracle (
-- mkSpecSampler,
module Data.Boltzmann.Oracle ) where
( mkSpecSampler,
)
where
import Control.Monad (replicateM) import Control.Monad (replicateM)
import Data.Boltzmann.Sampler (BoltzmannSampler (sample)) import Data.Boltzmann.Sampler (BoltzmannSampler (sample))
import Data.Boltzmann.Specifiable import Data.Boltzmann.Specifiable (
( Cons (args, name), Cons (args, name),
Specifiable (..), Specifiable (..),
SpecifiableType (..), SpecifiableType (..),
TypeDef, TypeDef,
) )
import Data.Boltzmann.Specification (getWeight) import Data.Boltzmann.Specification (getWeight)
import qualified Data.Boltzmann.Specification as S import qualified Data.Boltzmann.Specification as S
import Data.BuffonMachine (DDG) import Data.BuffonMachine (DDG)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Map.Strict (Map) import Data.Map.Strict (Map)
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import Data.Paganini import Data.Paganini (
( Expr, Expr,
FromVariable, FromVariable,
Let (Let), Let (Let),
PaganiniError, PaganiniError,
Spec, Spec,
ddg, ddg,
debugPaganini, debugPaganini,
tune, tune,
variable, variable,
variable', variable',
(.=.), (.=.),
) )
import Data.Set (Set) import Data.Set (Set)
import qualified Data.Set as Set import qualified Data.Set as Set
import Data.Vector import Data.Vector (
( fromList, fromList,
) )
import Instances.TH.Lift () import Instances.TH.Lift ()
import Language.Haskell.TH import Language.Haskell.TH (
( Exp (LamCaseE), Exp (LamCaseE),
Lit (IntegerL), Lit (IntegerL),
runIO, runIO,
) )
import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax (
( Body (NormalB), Body (NormalB),
Exp (LitE), Exp (LitE),
Lit (StringL), Lit (StringL),
Match (Match), Match (Match),
Pat (LitP), Pat (LitP),
Q, Q,
) )
-- nicer sum for non-empty lists. -- nicer sum for non-empty lists.
sum' :: Num a => [a] -> a sum' :: Num a => [a] -> a
@ -95,10 +92,10 @@ mkMarkingVariables sys = do
return $ Map.fromList xs return $ Map.fromList xs
data Params = Params data Params = Params
{ sizeVar :: forall a. FromVariable a => a, { sizeVar :: forall a. FromVariable a => a
typeVariable :: Map String Let, , typeVariable :: Map String Let
markingVariable :: Map String Let, , markingVariable :: Map String Let
systemSpec :: S.SystemSpec , systemSpec :: S.SystemSpec
} }
mkTypeVariables :: Params -> Set SpecifiableType -> Spec () mkTypeVariables :: Params -> Set SpecifiableType -> Spec ()
@ -155,10 +152,10 @@ paganiniSpec sys@(S.SystemSpec {S.targetType = target, S.meanSize = n}) = do
let params = let params =
Params Params
{ sizeVar = z, { sizeVar = z
typeVariable = varDefs, , typeVariable = varDefs
markingVariable = markDefs, , markingVariable = markDefs
systemSpec = sys , systemSpec = sys
} }
mkTypeVariables params specifiableTypes mkTypeVariables params specifiableTypes

17
src/Data/Boltzmann/Sampler.hs
View File

@ -12,15 +12,14 @@
-- License : BSD3 -- License : BSD3
-- Maintainer : maciej.bendkowski@gmail.com -- Maintainer : maciej.bendkowski@gmail.com
-- Stability : experimental -- Stability : experimental
module Data.Boltzmann.Sampler module Data.Boltzmann.Sampler (
( RejectionSampler, RejectionSampler,
DDGSelector, DDGSelector,
WeightSelector, WeightSelector,
BoltzmannSampler (..), BoltzmannSampler (..),
rejectionSampler, rejectionSampler,
rejectionSamplerIO, rejectionSamplerIO,
) ) where
where
import Control.Monad (guard) import Control.Monad (guard)
import Control.Monad.Trans (MonadTrans (lift)) import Control.Monad.Trans (MonadTrans (lift))

58
src/Data/Boltzmann/Sampler/Utils.hs
View File

@ -17,27 +17,27 @@ import qualified Control.Monad.Trans as T
import Data.Boltzmann.Sampler (sample) import Data.Boltzmann.Sampler (sample)
import Data.BuffonMachine (choice) import Data.BuffonMachine (choice)
import Language.Haskell.TH (Exp (DoE, LamCaseE, TupE), Pat (VarP), Stmt (NoBindS), newName) import Language.Haskell.TH (Exp (DoE, LamCaseE, TupE), Pat (VarP), Stmt (NoBindS), newName)
import Language.Haskell.TH.Datatype import Language.Haskell.TH.Datatype (
( ConstructorInfo (constructorName), ConstructorInfo (constructorName),
DatatypeInfo (..), DatatypeInfo (..),
constructorFields, constructorFields,
constructorName, constructorName,
reifyDatatype, reifyDatatype,
) )
import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax (
( Body (NormalB), Body (NormalB),
Clause (Clause), Clause (Clause),
Dec (FunD, InstanceD), Dec (FunD, InstanceD),
Exp (AppE, ConE, InfixE, LamE, LitE, VarE), Exp (AppE, ConE, InfixE, LamE, LitE, VarE),
Lit (IntegerL, StringL), Lit (IntegerL, StringL),
Match (Match), Match (Match),
Name, Name,
Pat (LitP, TupP), Pat (LitP, TupP),
Q, Q,
Stmt (BindS), Stmt (BindS),
Type (AppT, ConT), Type (AppT, ConT),
mkName, mkName,
) )
import Prelude hiding (sum) import Prelude hiding (sum)
application :: Exp -> Exp -> [Exp] -> Exp application :: Exp -> Exp -> [Exp] -> Exp
@ -108,9 +108,9 @@ genConstrApplication s args' = do
return $ foldl AppE con args' return $ foldl AppE con args'
data ArgStmtExpr = ArgStmtExpr data ArgStmtExpr = ArgStmtExpr
{ stmts :: [Stmt], { stmts :: [Stmt]
objs :: [Exp], , objs :: [Exp]
weights :: [Exp] , weights :: [Exp]
} }
genArgExprs :: ConstructorInfo -> Q ArgStmtExpr genArgExprs :: ConstructorInfo -> Q ArgStmtExpr
@ -130,9 +130,9 @@ genArgExprs' ubExpr (_ : as) = do
let stmt = BindS (TupP [xp, wp]) (AppE (AppE (AppE argExpr (VarE $ mkName "ddgs")) (VarE $ mkName "weight")) ubExpr) let stmt = BindS (TupP [xp, wp]) (AppE (AppE (AppE argExpr (VarE $ mkName "ddgs")) (VarE $ mkName "weight")) ubExpr)
return return
ArgStmtExpr ArgStmtExpr
{ stmts = stmt : stmts argStmtExpr, { stmts = stmt : stmts argStmtExpr
objs = x : objs argStmtExpr, , objs = x : objs argStmtExpr
weights = w : weights argStmtExpr , weights = w : weights argStmtExpr
} }
genChoiceExpr :: Name -> Q Exp genChoiceExpr :: Name -> Q Exp
@ -167,8 +167,8 @@ gen typ = do
[pat "ddgs", pat "weight", pat "ub"] [pat "ddgs", pat "weight", pat "ub"]
$ DoE $ DoE
Nothing Nothing
[ NoBindS guardExpr, [ NoBindS guardExpr
NoBindS $ InfixE (Just choiceExpr) bindOp (Just caseExpr) , NoBindS $ InfixE (Just choiceExpr) bindOp (Just caseExpr)
] ]
genConstrGroup :: Name -> Q [(ConstructorInfo, Integer)] genConstrGroup :: Name -> Q [(ConstructorInfo, Integer)]

45
src/Data/Boltzmann/Specifiable.hs
View File

@ -17,28 +17,27 @@
-- Stability : experimental -- Stability : experimental
-- --
-- Specifiable types, i.e. types which have corresponding (multiparametric) samplers. -- Specifiable types, i.e. types which have corresponding (multiparametric) samplers.
module Data.Boltzmann.Specifiable module Data.Boltzmann.Specifiable (
( SpecifiableType (..), SpecifiableType (..),
TypeDef, TypeDef,
Cons (..), Cons (..),
Specifiable (..), Specifiable (..),
listTypeName, listTypeName,
) ) where
where
import GHC.Generics import GHC.Generics (
( C1, C1,
Constructor (conName), Constructor (conName),
D1, D1,
Datatype (datatypeName, moduleName), Datatype (datatypeName, moduleName),
Generic (Rep, from), Generic (Rep, from),
K1, K1,
R, R,
S1, S1,
U1, U1,
type (:*:), type (:*:),
type (:+:), type (:+:),
) )
import Language.Haskell.TH.Syntax (Lift) import Language.Haskell.TH.Syntax (Lift)
-- | Specifiable, algebraic type definition given -- | Specifiable, algebraic type definition given
@ -48,8 +47,8 @@ type TypeDef = [Cons]
-- | Type constructors. -- | Type constructors.
data Cons = Cons data Cons = Cons
{ -- | Fully-qualified constructor name. { -- | Fully-qualified constructor name.
name :: String, name :: String
-- | List of (specifiable) arguments. , -- | List of (specifiable) arguments.
args :: [SpecifiableType] args :: [SpecifiableType]
} }
deriving (Eq, Show, Lift) deriving (Eq, Show, Lift)

77
src/Data/Boltzmann/Specification.hs
View File

@ -8,30 +8,29 @@
-- License : BSD3 -- License : BSD3
-- Maintainer : maciej.bendkowski@gmail.com -- Maintainer : maciej.bendkowski@gmail.com
-- Stability : experimental -- Stability : experimental
module Data.Boltzmann.Specification module Data.Boltzmann.Specification (
( TypeSpec (..), TypeSpec (..),
SystemSpec (..), SystemSpec (..),
defaultTypeSpec, defaultTypeSpec,
withWeights, withWeights,
withFrequencies, withFrequencies,
specification, specification,
withSystem, withSystem,
(==>), (==>),
collectTypes, collectTypes,
ConsFreq, ConsFreq,
Value, Value,
constructorFrequencies, constructorFrequencies,
getWeight, getWeight,
getFrequency, getFrequency,
) ) where
where
import Data.Bifunctor (Bifunctor (first)) import Data.Bifunctor (Bifunctor (first))
import Data.Boltzmann.Specifiable import Data.Boltzmann.Specifiable (
( Cons (args), Cons (args),
Specifiable (..), Specifiable (..),
SpecifiableType (..), SpecifiableType (..),
) )
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Map.Strict (Map) import Data.Map.Strict (Map)
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
@ -44,11 +43,11 @@ data TypeSpec = forall a.
Specifiable a => Specifiable a =>
TypeSpec TypeSpec
{ -- | Corresponding specifiable type `a`. { -- | Corresponding specifiable type `a`.
specifiableType :: a, specifiableType :: a
-- | Constructors of `a` mapped to their (custom) weight. If no custom , -- | Constructors of `a` mapped to their (custom) weight. If no custom
-- weight is provided, a default one of 1 is assumed. -- weight is provided, a default one of 1 is assumed.
weight :: Map String Integer, weight :: Map String Integer
-- | Constructors of `a` mapped to their (custom) frequencies. If no custom , -- | Constructors of `a` mapped to their (custom) frequencies. If no custom
-- frequency is provided, no frequency is assumed. -- frequency is provided, no frequency is assumed.
frequency :: Map String Integer frequency :: Map String Integer
} }
@ -66,10 +65,10 @@ data SystemSpec = forall a.
Specifiable a => Specifiable a =>
SystemSpec SystemSpec
{ -- | Specifiable which is designated as the "target" tuning type. { -- | Specifiable which is designated as the "target" tuning type.
targetType :: a, targetType :: a
-- | Target mean size of the objects corresponding to the tuned system. , -- | Target mean size of the objects corresponding to the tuned system.
meanSize :: Integer, meanSize :: Integer
-- | Set of interdependent, specifiable types. , -- | Set of interdependent, specifiable types.
typeSpecs :: Set TypeSpec typeSpecs :: Set TypeSpec
} }
@ -109,13 +108,13 @@ getFrequency' name spec = name `Map.lookup` frequency spec
defaultTypeSpec :: Specifiable a => a -> TypeSpec defaultTypeSpec :: Specifiable a => a -> TypeSpec
defaultTypeSpec typ = defaultTypeSpec typ =
TypeSpec TypeSpec
{ specifiableType = typ, { specifiableType = typ
weight = , weight =
Map.fromList Map.fromList
[ (show '[], 0), [ (show '[], 0)
(show '(:), 0) , (show '(:), 0)
], ]
frequency = Map.empty , frequency = Map.empty
} }
-- | Constructor names with associated numeric values (for either weights or frequencies). -- | Constructor names with associated numeric values (for either weights or frequencies).
@ -154,9 +153,9 @@ withSystem ::
SystemSpec SystemSpec
withSystem (typ, size) specs = withSystem (typ, size) specs =
SystemSpec SystemSpec
{ targetType = typ, { targetType = typ
meanSize = size, , meanSize = size
typeSpecs = Set.fromList specs , typeSpecs = Set.fromList specs
} }
toSpecifiableTypes :: SystemSpec -> Set SpecifiableType toSpecifiableTypes :: SystemSpec -> Set SpecifiableType

41
src/Data/BuffonMachine.hs
View File

@ -15,24 +15,23 @@
-- * J. Lumbroso : "Optimal Discrete Uniform Generation from Coin Flips, and Applications". -- * J. Lumbroso : "Optimal Discrete Uniform Generation from Coin Flips, and Applications".
-- * F. A. Saad, C. E. Freer, M. C. Rinard, V.K. Mansinghka "Optimal Approximate -- * F. A. Saad, C. E. Freer, M. C. Rinard, V.K. Mansinghka "Optimal Approximate
-- Sampling from Discrete Probability Distributions", POPL'20 (2020). -- Sampling from Discrete Probability Distributions", POPL'20 (2020).
module Data.BuffonMachine module Data.BuffonMachine (
( BuffonMachine, BuffonMachine,
Discrete, Discrete,
Oracle (..), Oracle (..),
DDG, DDG,
choice, choice,
run, run,
runIO, runIO,
) ) where
where
import Control.Monad.Trans.State.Strict import Control.Monad.Trans.State.Strict (
( State, State,
evalState, evalState,
get, get,
modify', modify',
put, put,
) )
import Data.Bits (Bits (testBit)) import Data.Bits (Bits (testBit))
import Data.Vector (Vector, null, (!)) import Data.Vector (Vector, null, (!))
import Data.Word (Word32) import Data.Word (Word32)
@ -42,10 +41,10 @@ import Prelude hiding (null)
-- | Buffered random bit oracle. -- | Buffered random bit oracle.
data Oracle g = Oracle data Oracle g = Oracle
{ -- | 32-bit buffer of random bits. { -- | 32-bit buffer of random bits.
buffer :: !Word32, buffer :: !Word32
-- | Number of bits consumed from the current buffer. , -- | Number of bits consumed from the current buffer.
usedBits :: !Int, usedBits :: !Int
-- | Random number generator used to obtain random bits. , -- | Random number generator used to obtain random bits.
rng :: g rng :: g
} }

38
test/Data/Types/BinTree.hs
View File

@ -6,19 +6,19 @@ module Data.Types.BinTree where
import Data.Boltzmann.Sampler (BoltzmannSampler (..)) import Data.Boltzmann.Sampler (BoltzmannSampler (..))
import Data.Boltzmann.Sampler.Utils (mkSampler) import Data.Boltzmann.Sampler.Utils (mkSampler)
import Data.Boltzmann.Specifiable import Data.Boltzmann.Specifiable (
( Cons (..), Cons (..),
Specifiable, Specifiable,
SpecifiableType (..), SpecifiableType (..),
TypeDef, TypeDef,
) )
import Data.Boltzmann.Specification import Data.Boltzmann.Specification (
( SystemSpec, SystemSpec,
specification, specification,
withSystem, withSystem,
withWeights, withWeights,
(==>), (==>),
) )
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Test.Unit.Utils (Size (..)) import Test.Unit.Utils (Size (..))
@ -36,18 +36,18 @@ binTree = SpecifiableType (undefined :: BinTree)
expectedTypeDef :: TypeDef expectedTypeDef :: TypeDef
expectedTypeDef = expectedTypeDef =
[ Cons {name = "Data.Types.BinTree.Leaf", args = []}, [ Cons {name = "Data.Types.BinTree.Leaf", args = []}
Cons {name = "Data.Types.BinTree.Node", args = [binTree, binTree]} , Cons {name = "Data.Types.BinTree.Node", args = [binTree, binTree]}
] ]
binTreeSysSpec :: SystemSpec binTreeSysSpec :: SystemSpec
binTreeSysSpec = binTreeSysSpec =
(undefined :: BinTree, 4000) (undefined :: BinTree, 4000)
`withSystem` [ specification `withSystem` [ specification
(undefined :: BinTree) (undefined :: BinTree)
( withWeights ( withWeights
['Leaf ==> 0] ['Leaf ==> 0]
) )
] ]
$(mkSampler ''BinTree) $(mkSampler ''BinTree)

46
test/Data/Types/Custom.hs
View File

@ -4,18 +4,18 @@
module Data.Types.Custom where module Data.Types.Custom where
import Data.Boltzmann.Specifiable import Data.Boltzmann.Specifiable (
( Specifiable, Specifiable,
SpecifiableType (..), SpecifiableType (..),
) )
import Data.Boltzmann.Specification import Data.Boltzmann.Specification (
( SystemSpec, SystemSpec,
specification, specification,
withFrequencies, withFrequencies,
withSystem, withSystem,
withWeights, withWeights,
(==>), (==>),
) )
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Test.Unit.Utils (Size (..)) import Test.Unit.Utils (Size (..))
@ -48,15 +48,15 @@ customSysSpec :: SystemSpec
customSysSpec = customSysSpec =
(undefined :: Custom, 10000) (undefined :: Custom, 10000)
`withSystem` [ specification `withSystem` [ specification
(undefined :: Custom) (undefined :: Custom)
( withWeights ( withWeights
[ 'ConsA ==> 2, [ 'ConsA ==> 2
'ConsB ==> 3, , 'ConsB ==> 3
'ConsC ==> 4 , 'ConsC ==> 4
] ]
. withFrequencies . withFrequencies
[ 'ConsA ==> 800, [ 'ConsA ==> 800
'ConsB ==> 900 , 'ConsB ==> 900
] ]
) )
] ]

58
test/Data/Types/Lambda.hs
View File

@ -7,20 +7,20 @@ module Data.Types.Lambda where
import Data.Boltzmann.Sampler (BoltzmannSampler (..)) import Data.Boltzmann.Sampler (BoltzmannSampler (..))
import Data.Boltzmann.Sampler.Utils (mkSampler) import Data.Boltzmann.Sampler.Utils (mkSampler)
import Data.Boltzmann.Specifiable import Data.Boltzmann.Specifiable (
( Cons (..), Cons (..),
Specifiable, Specifiable,
SpecifiableType (..), SpecifiableType (..),
TypeDef, TypeDef,
) )
import Data.Boltzmann.Specification import Data.Boltzmann.Specification (
( SystemSpec, SystemSpec,
specification, specification,
withFrequencies, withFrequencies,
withSystem, withSystem,
withWeights, withWeights,
(==>), (==>),
) )
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Test.Unit.Utils (Size (..)) import Test.Unit.Utils (Size (..))
@ -50,37 +50,37 @@ lambda = SpecifiableType (undefined :: Lambda)
expectedDeBruijnTypeDef :: TypeDef expectedDeBruijnTypeDef :: TypeDef
expectedDeBruijnTypeDef = expectedDeBruijnTypeDef =
[ Cons {name = "Data.Types.Lambda.S", args = [deBruijn]}, [ Cons {name = "Data.Types.Lambda.S", args = [deBruijn]}
Cons {name = "Data.Types.Lambda.Z", args = []} , Cons {name = "Data.Types.Lambda.Z", args = []}
] ]
expectedLambdaTypeDef :: TypeDef expectedLambdaTypeDef :: TypeDef
expectedLambdaTypeDef = expectedLambdaTypeDef =
[ Cons {name = "Data.Types.Lambda.Abs", args = [lambda]}, [ Cons {name = "Data.Types.Lambda.Abs", args = [lambda]}
Cons {name = "Data.Types.Lambda.App", args = [lambda, lambda]}, , Cons {name = "Data.Types.Lambda.App", args = [lambda, lambda]}
Cons {name = "Data.Types.Lambda.Index", args = [deBruijn]} , Cons {name = "Data.Types.Lambda.Index", args = [deBruijn]}
] ]
lambdaSysSpec :: SystemSpec lambdaSysSpec :: SystemSpec
lambdaSysSpec = lambdaSysSpec =
(undefined :: Lambda, 1000) (undefined :: Lambda, 1000)
`withSystem` [ specification `withSystem` [ specification
(undefined :: Lambda) (undefined :: Lambda)
( withWeights ( withWeights
['Index ==> 0] ['Index ==> 0]
. withFrequencies . withFrequencies
['Abs ==> 330] ['Abs ==> 330]
) )
] ]
lambdaListSysSpec :: SystemSpec lambdaListSysSpec :: SystemSpec
lambdaListSysSpec = lambdaListSysSpec =
(undefined :: [Lambda], 1000) (undefined :: [Lambda], 1000)
`withSystem` [ specification `withSystem` [ specification
(undefined :: [Lambda]) (undefined :: [Lambda])
( withWeights ( withWeights
['Index ==> 0] ['Index ==> 0]
) )
] ]
$(mkSampler ''DeBruijn) $(mkSampler ''DeBruijn)

22
test/Data/Types/Tree.hs
View File

@ -6,17 +6,17 @@ module Data.Types.Tree where
import Data.Boltzmann.Sampler (BoltzmannSampler (..)) import Data.Boltzmann.Sampler (BoltzmannSampler (..))
import Data.Boltzmann.Sampler.Utils (mkSampler) import Data.Boltzmann.Sampler.Utils (mkSampler)
import Data.Boltzmann.Specifiable import Data.Boltzmann.Specifiable (
( Cons (..), Cons (..),
Specifiable, Specifiable,
SpecifiableType (..), SpecifiableType (..),
TypeDef, TypeDef,
) )
import Data.Boltzmann.Specification import Data.Boltzmann.Specification (
( SystemSpec, SystemSpec,
defaultTypeSpec, defaultTypeSpec,
withSystem, withSystem,
) )
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Test.Unit.Utils (Size (..)) import Test.Unit.Utils (Size (..))

8
test/Spec.hs
View File

@ -12,8 +12,8 @@ tests = testGroup "Unit tests" unitTests
unitTests :: [TestTree] unitTests :: [TestTree]
unitTests = unitTests =
[ Specifiable.unitTests, [ Specifiable.unitTests
Specification.unitTests, , Specification.unitTests
BuffonMachine.unitTests, , BuffonMachine.unitTests
Sampler.unitTests , Sampler.unitTests
] ]

30
test/Test/Unit/BuffonMachine.hs
View File

@ -4,15 +4,15 @@ import Control.Monad (replicateM)
import Data.BuffonMachine (choice, runIO) import Data.BuffonMachine (choice, runIO)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Vector (Vector, fromList) import Data.Vector (Vector, fromList)
import Test.Tasty import Test.Tasty (
( TestTree, TestTree,
testGroup, testGroup,
) )
import Test.Tasty.HUnit import Test.Tasty.HUnit (
( Assertion, Assertion,
assertBool, assertBool,
testCase, testCase,
) )
unitTests :: TestTree unitTests :: TestTree
unitTests = unitTests =
@ -27,18 +27,18 @@ choiceTests =
[ testCase "[1/2, 1/2] is correctly sampled from" $ do [ testCase "[1/2, 1/2] is correctly sampled from" $ do
[(0, a), (1, b)] <- choiceTest distributionA 1000000 [(0, a), (1, b)] <- choiceTest distributionA 1000000
a `almostEqual` 0.5 a `almostEqual` 0.5
b `almostEqual` 0.5, b `almostEqual` 0.5
testCase "[1/3, 1/3, 1/3] is correctly sampled from" $ do , testCase "[1/3, 1/3, 1/3] is correctly sampled from" $ do
[(0, a), (1, b), (2, c)] <- choiceTest distributionB 1000000 [(0, a), (1, b), (2, c)] <- choiceTest distributionB 1000000
a `almostEqual` 0.33 a `almostEqual` 0.33
b `almostEqual` 0.33 b `almostEqual` 0.33
c `almostEqual` 0.33, c `almostEqual` 0.33
testCase "[1/7, 4/7, 2/7] is correctly sampled from" $ do , testCase "[1/7, 4/7, 2/7] is correctly sampled from" $ do
[(0, a), (1, b), (2, c)] <- choiceTest distributionC 1000000 [(0, a), (1, b), (2, c)] <- choiceTest distributionC 1000000
a `almostEqual` 0.14 a `almostEqual` 0.14
b `almostEqual` 0.57 b `almostEqual` 0.57
c `almostEqual` 0.28, c `almostEqual` 0.28
testCase "[1/1] is correctly sampled from" $ do , testCase "[1/1] is correctly sampled from" $ do
[(0, a)] <- choiceTest distributionD 1000000 [(0, a)] <- choiceTest distributionD 1000000
a `almostEqual` 1.0 a `almostEqual` 1.0
] ]

8
test/Test/Unit/Sampler.hs
View File

@ -17,10 +17,10 @@ unitTests =
sampleSizeTests :: [TestTree] sampleSizeTests :: [TestTree]
sampleSizeTests = sampleSizeTests =
[ testProperty "Lambda sampler respects size constraints for sizes around the mean of 1,000" lambdaSamplerSizeProp, [ testProperty "Lambda sampler respects size constraints for sizes around the mean of 1,000" lambdaSamplerSizeProp
testProperty "BinTree sampler respects size constraints for sizes around the mean of 1,000" binTreeSamplerSizeProp, , testProperty "BinTree sampler respects size constraints for sizes around the mean of 1,000" binTreeSamplerSizeProp
testProperty "Tree sampler respects size constraints for sizes around the mean of 1,000" treeSamplerSizeProp, , testProperty "Tree sampler respects size constraints for sizes around the mean of 1,000" treeSamplerSizeProp
testProperty "Lambda list sampler respects size constraints for sizes around the mean of 1,000" lambdaListSamplerSizeProp , testProperty "Lambda list sampler respects size constraints for sizes around the mean of 1,000" lambdaListSamplerSizeProp
] ]
lambdaSamplerSizeProp :: Positive Int -> Property lambdaSamplerSizeProp :: Positive Int -> Property

28
test/Test/Unit/Specifiable.hs
View File

@ -23,12 +23,12 @@ typeDefinitionTests =
testGroup testGroup
"Type definition unit tests" "Type definition unit tests"
[ testCase "BinTree has a correct type definition" $ [ testCase "BinTree has a correct type definition" $
BinTree.expectedTypeDef @=? typedef (undefined :: BinTree), BinTree.expectedTypeDef @=? typedef (undefined :: BinTree)
testCase "Tree has a correct type definition" $ , testCase "Tree has a correct type definition" $
Tree.expectedTypeDef @=? typedef (undefined :: Tree), Tree.expectedTypeDef @=? typedef (undefined :: Tree)
testCase "DeBruijn has a correct type definition" $ , testCase "DeBruijn has a correct type definition" $
Lambda.expectedDeBruijnTypeDef @=? typedef (undefined :: DeBruijn), Lambda.expectedDeBruijnTypeDef @=? typedef (undefined :: DeBruijn)
testCase "Lambda has a correct type definition" $ , testCase "Lambda has a correct type definition" $
Lambda.expectedLambdaTypeDef @=? typedef (undefined :: Lambda) Lambda.expectedLambdaTypeDef @=? typedef (undefined :: Lambda)
] ]
@ -37,13 +37,13 @@ typeNameTests =
testGroup testGroup
"Type name unit tests" "Type name unit tests"
[ testCase "BinTree's type name is correct" $ [ testCase "BinTree's type name is correct" $
show ''BinTree @=? typeName (undefined :: BinTree), show ''BinTree @=? typeName (undefined :: BinTree)
testCase "Tree's type name is correct" $ , testCase "Tree's type name is correct" $
show ''Tree @=? typeName (undefined :: Tree), show ''Tree @=? typeName (undefined :: Tree)
testCase "Lambda's type name is correct" $ , testCase "Lambda's type name is correct" $
show ''Lambda @=? typeName (undefined :: Lambda), show ''Lambda @=? typeName (undefined :: Lambda)
testCase "[DeBruijn]'s type name is correct" $ , testCase "[DeBruijn]'s type name is correct" $
"[Data.Types.Lambda.DeBruijn]" @=? typeName (undefined :: [DeBruijn]), "[Data.Types.Lambda.DeBruijn]" @=? typeName (undefined :: [DeBruijn])
testCase "[[DeBruijn]]'s type name is correct" $ , testCase "[[DeBruijn]]'s type name is correct" $
"[[Data.Types.Lambda.DeBruijn]]" @=? typeName (undefined :: [[DeBruijn]]) "[[Data.Types.Lambda.DeBruijn]]" @=? typeName (undefined :: [[DeBruijn]])
] ]

87
test/Test/Unit/Specification.hs
View File

@ -1,9 +1,8 @@
{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE TemplateHaskellQuotes #-}
module Test.Unit.Specification module Test.Unit.Specification (
( unitTests, unitTests,
) ) where
where
import qualified Data.Boltzmann.Specification as Specification import qualified Data.Boltzmann.Specification as Specification
import qualified Data.Map as Map import qualified Data.Map as Map
@ -14,14 +13,14 @@ import qualified Data.Types.Custom as Custom
import Data.Types.Lambda (Lambda) import Data.Types.Lambda (Lambda)
import qualified Data.Types.Lambda as Lambda import qualified Data.Types.Lambda as Lambda
import qualified Data.Types.Tree as Tree import qualified Data.Types.Tree as Tree
import Test.Tasty import Test.Tasty (
( TestTree, TestTree,
testGroup, testGroup,
) )
import Test.Tasty.HUnit import Test.Tasty.HUnit (
( testCase, testCase,
(@=?), (@=?),
) )
unitTests :: TestTree unitTests :: TestTree
unitTests = unitTests =
@ -35,14 +34,14 @@ collectTypesTests =
"Type collection unit tests" "Type collection unit tests"
[ testCase "BinTree's types are collected correctly" $ [ testCase "BinTree's types are collected correctly" $
Set.singleton BinTree.binTree Set.singleton BinTree.binTree
@=? Specification.collectTypes BinTree.binTreeSysSpec, @=? Specification.collectTypes BinTree.binTreeSysSpec
testCase "Lambda's types are collected correctly" $ , testCase "Lambda's types are collected correctly" $
Set.fromList [Lambda.lambda, Lambda.deBruijn] Set.fromList [Lambda.lambda, Lambda.deBruijn]
@=? Specification.collectTypes Lambda.lambdaSysSpec, @=? Specification.collectTypes Lambda.lambdaSysSpec
testCase "Trees's types are collected correctly" $ , testCase "Trees's types are collected correctly" $
Set.fromList [Tree.tree, Tree.treeList] Set.fromList [Tree.tree, Tree.treeList]
@=? Specification.collectTypes Tree.treeSysSpec, @=? Specification.collectTypes Tree.treeSysSpec
testCase "Custom's types are collected correctly" $ , testCase "Custom's types are collected correctly" $
Set.fromList [Custom.custom, Custom.custom', Custom.customList'] Set.fromList [Custom.custom, Custom.custom', Custom.customList']
@=? Specification.collectTypes Custom.customSysSpec @=? Specification.collectTypes Custom.customSysSpec
] ]
@ -52,13 +51,13 @@ constructorFrequenciesTests =
testGroup testGroup
"Constructor frequency tests" "Constructor frequency tests"
[ testCase "BinTree's constructor frequencies are collected correctly" $ [ testCase "BinTree's constructor frequencies are collected correctly" $
Map.empty @=? Specification.constructorFrequencies BinTree.binTreeSysSpec, Map.empty @=? Specification.constructorFrequencies BinTree.binTreeSysSpec
testCase "Lambda's constructor frequencies are collected correctly" $ , testCase "Lambda's constructor frequencies are collected correctly" $
Map.fromList [("Data.Types.Lambda.Abs", 330)] Map.fromList [("Data.Types.Lambda.Abs", 330)]
@=? Specification.constructorFrequencies Lambda.lambdaSysSpec, @=? Specification.constructorFrequencies Lambda.lambdaSysSpec
testCase "Tree's constructor frequencies are collected correctly" $ , testCase "Tree's constructor frequencies are collected correctly" $
Map.empty @=? Specification.constructorFrequencies Tree.treeSysSpec, Map.empty @=? Specification.constructorFrequencies Tree.treeSysSpec
testCase "Custom's constructor frequencies are collected correctly" $ , testCase "Custom's constructor frequencies are collected correctly" $
Map.fromList [("Data.Types.Custom.ConsA", 800), ("Data.Types.Custom.ConsB", 900)] Map.fromList [("Data.Types.Custom.ConsA", 800), ("Data.Types.Custom.ConsB", 900)]
@=? Specification.constructorFrequencies Custom.customSysSpec @=? Specification.constructorFrequencies Custom.customSysSpec
] ]
@ -69,18 +68,18 @@ getWeightTests =
"Constructor weight unit tests" "Constructor weight unit tests"
[ testCase "BinTree's constructor weights are computed correctly" $ do [ testCase "BinTree's constructor weights are computed correctly" $ do
0 @=? BinTree.binTreeSysSpec `Specification.getWeight` show 'BinTree.Leaf 0 @=? BinTree.binTreeSysSpec `Specification.getWeight` show 'BinTree.Leaf
1 @=? BinTree.binTreeSysSpec `Specification.getWeight` show 'BinTree.Node, 1 @=? BinTree.binTreeSysSpec `Specification.getWeight` show 'BinTree.Node
testCase "Lambda's constructor weights are computed correctly" $ do , testCase "Lambda's constructor weights are computed correctly" $ do
0 @=? Lambda.lambdaSysSpec `Specification.getWeight` show 'Lambda.Index 0 @=? Lambda.lambdaSysSpec `Specification.getWeight` show 'Lambda.Index
1 @=? Lambda.lambdaSysSpec `Specification.getWeight` show 'Lambda.Abs 1 @=? Lambda.lambdaSysSpec `Specification.getWeight` show 'Lambda.Abs
1 @=? Lambda.lambdaSysSpec `Specification.getWeight` show 'Lambda.App 1 @=? Lambda.lambdaSysSpec `Specification.getWeight` show 'Lambda.App
1 @=? Lambda.lambdaSysSpec `Specification.getWeight` show 'Lambda.S 1 @=? Lambda.lambdaSysSpec `Specification.getWeight` show 'Lambda.S
1 @=? Lambda.lambdaSysSpec `Specification.getWeight` show 'Lambda.Z, 1 @=? Lambda.lambdaSysSpec `Specification.getWeight` show 'Lambda.Z
testCase "Tree's constructor weights are computed correctly" $ do , testCase "Tree's constructor weights are computed correctly" $ do
1 @=? Tree.treeSysSpec `Specification.getWeight` show 'Tree.Node 1 @=? Tree.treeSysSpec `Specification.getWeight` show 'Tree.Node
0 @=? Tree.treeSysSpec `Specification.getWeight` show '[] 0 @=? Tree.treeSysSpec `Specification.getWeight` show '[]
0 @=? Tree.treeSysSpec `Specification.getWeight` show '(:), 0 @=? Tree.treeSysSpec `Specification.getWeight` show '(:)
testCase "Custom's constructor weights are computed correctly" $ do , testCase "Custom's constructor weights are computed correctly" $ do
2 @=? Custom.customSysSpec `Specification.getWeight` show 'Custom.ConsA 2 @=? Custom.customSysSpec `Specification.getWeight` show 'Custom.ConsA
3 @=? Custom.customSysSpec `Specification.getWeight` show 'Custom.ConsB 3 @=? Custom.customSysSpec `Specification.getWeight` show 'Custom.ConsB
4 @=? Custom.customSysSpec `Specification.getWeight` show 'Custom.ConsC 4 @=? Custom.customSysSpec `Specification.getWeight` show 'Custom.ConsC
@ -92,18 +91,18 @@ getFrequencyTests =
"Constructor frequencies unit tests" "Constructor frequencies unit tests"
[ testCase "BinTree's constructor frequencies are computed correctly" $ do [ testCase "BinTree's constructor frequencies are computed correctly" $ do
Nothing @=? BinTree.binTreeSysSpec `Specification.getFrequency` show 'BinTree.Leaf Nothing @=? BinTree.binTreeSysSpec `Specification.getFrequency` show 'BinTree.Leaf
Nothing @=? BinTree.binTreeSysSpec `Specification.getFrequency` show 'BinTree.Node, Nothing @=? BinTree.binTreeSysSpec `Specification.getFrequency` show 'BinTree.Node
testCase "Lambda's constructor frequencies are computed correctly" $ do , testCase "Lambda's constructor frequencies are computed correctly" $ do
Nothing @=? Lambda.lambdaSysSpec `Specification.getFrequency` show 'Lambda.Index Nothing @=? Lambda.lambdaSysSpec `Specification.getFrequency` show 'Lambda.Index
Just 330 @=? Lambda.lambdaSysSpec `Specification.getFrequency` show 'Lambda.Abs Just 330 @=? Lambda.lambdaSysSpec `Specification.getFrequency` show 'Lambda.Abs
Nothing @=? Lambda.lambdaSysSpec `Specification.getFrequency` show 'Lambda.App Nothing @=? Lambda.lambdaSysSpec `Specification.getFrequency` show 'Lambda.App
Nothing @=? Lambda.lambdaSysSpec `Specification.getFrequency` show 'Lambda.S Nothing @=? Lambda.lambdaSysSpec `Specification.getFrequency` show 'Lambda.S
Nothing @=? Lambda.lambdaSysSpec `Specification.getFrequency` show 'Lambda.Z, Nothing @=? Lambda.lambdaSysSpec `Specification.getFrequency` show 'Lambda.Z
testCase "Tree's constructor frequencies are computed correctly" $ do , testCase "Tree's constructor frequencies are computed correctly" $ do
Nothing @=? Tree.treeSysSpec `Specification.getFrequency` show 'Tree.Node Nothing @=? Tree.treeSysSpec `Specification.getFrequency` show 'Tree.Node
Nothing @=? Tree.treeSysSpec `Specification.getFrequency` show '[] Nothing @=? Tree.treeSysSpec `Specification.getFrequency` show '[]
Nothing @=? Tree.treeSysSpec `Specification.getFrequency` show '(:), Nothing @=? Tree.treeSysSpec `Specification.getFrequency` show '(:)
testCase "Custom's constructor frequencies are computed correctly" $ do , testCase "Custom's constructor frequencies are computed correctly" $ do
Just 800 @=? Custom.customSysSpec `Specification.getFrequency` show 'Custom.ConsA Just 800 @=? Custom.customSysSpec `Specification.getFrequency` show 'Custom.ConsA
Just 900 @=? Custom.customSysSpec `Specification.getFrequency` show 'Custom.ConsB Just 900 @=? Custom.customSysSpec `Specification.getFrequency` show 'Custom.ConsB
Nothing @=? Custom.customSysSpec `Specification.getFrequency` show 'Custom.ConsC Nothing @=? Custom.customSysSpec `Specification.getFrequency` show 'Custom.ConsC
@ -115,8 +114,8 @@ typeSpecTests =
"TypeSpec unit tests" "TypeSpec unit tests"
[ testCase "Equal type specs are correctly identified" $ do [ testCase "Equal type specs are correctly identified" $ do
True @=? a == a True @=? a == a
False @=? a == b, False @=? a == b
testCase "Type specs are correctly ordered" $ do , testCase "Type specs are correctly ordered" $ do
True @=? a <= a True @=? a <= a
True @=? b <= a True @=? b <= a
False @=? a <= b False @=? a <= b
@ -124,14 +123,14 @@ typeSpecTests =
where where
a = a =
Specification.TypeSpec Specification.TypeSpec
{ Specification.specifiableType = undefined :: Lambda, { Specification.specifiableType = undefined :: Lambda
Specification.weight = Map.empty, , Specification.weight = Map.empty
Specification.frequency = Map.empty , Specification.frequency = Map.empty
} }
b = b =
Specification.TypeSpec Specification.TypeSpec
{ Specification.specifiableType = undefined :: BinTree, { Specification.specifiableType = undefined :: BinTree
Specification.weight = Map.empty, , Specification.weight = Map.empty
Specification.frequency = Map.empty , Specification.frequency = Map.empty
} }