Initial commit

This commit is contained in:
Maciej Bendkowski 2022-01-12 16:47:07 +01:00
commit 83f4479808
25 changed files with 1453 additions and 0 deletions

24
.gitignore vendored Normal file
View File

@ -0,0 +1,24 @@
dist
dist-*
cabal-dev
*.o
*.hi
*.hie
*.chi
*.chs.h
*.dyn_o
*.dyn_hi
.hpc
.hsenv
.cabal-sandbox/
cabal.sandbox.config
*.prof
*.aux
*.hp
*.eventlog
.stack-work/
cabal.project.local
cabal.project.local~
.HTF/
.ghc.environment.*
*~

30
LICENSE Normal file
View File

@ -0,0 +1,30 @@
Copyright Maciej Bendkowski (c) 2022
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Author name here nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

1
README.md Normal file
View File

@ -0,0 +1 @@
# generic-boltzmann-brain

2
Setup.hs Normal file
View File

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

View File

@ -0,0 +1,84 @@
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.34.4.
--
-- see: https://github.com/sol/hpack
name: generic-boltzmann-brain
version: 0.1.0.0
description: Please see the README on GitHub at <https://github.com/maciej-bendkowski/generic-boltzmann-brain#readme>
homepage: https://github.com/maciej-bendkowski/generic-boltzmann-brain#readme
bug-reports: https://github.com/maciej-bendkowski/generic-boltzmann-brain/issues
author: Maciej Bendkowski
maintainer: maciej.bendkowski@gmail.com
copyright: 2022 Maciej Bendkowski
license: BSD3
license-file: LICENSE
build-type: Simple
extra-source-files:
README.md
source-repository head
type: git
location: https://github.com/maciej-bendkowski/generic-boltzmann-brain
library
exposed-modules:
Data.Boltzmann.Oracle
Data.Boltzmann.Sampler
Data.Boltzmann.Sampler.Utils
Data.Boltzmann.Specifiable
Data.Boltzmann.Specification
Data.BuffonMachine
other-modules:
Paths_generic_boltzmann_brain
hs-source-dirs:
src
ghc-options: -O2 -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-name-shadowing -fwarn-missing-signatures -ddump-splices
build-depends:
base >=4.7 && <5
, containers >=0.6.4
, mtl >=2.2.2
, paganini-hs >=0.3.0.0
, random >=1.2.0
, template-haskell >=2.16.0.0
, th-abstraction >=0.4.3.0
, 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:
Data.Samplers.BinTree
Data.Samplers.Lambda
Data.Samplers.Tree
Data.Types.BinTree
Data.Types.Lambda
Data.Types.Tree
Test.Unit.Sampler
Test.Unit.Specifiable
Test.Unit.Utils
Paths_generic_boltzmann_brain
hs-source-dirs:
test
ghc-options: -O2 -Wall -Wcompat -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
, generic-boltzmann-brain
, mtl >=2.2.2
, paganini-hs >=0.3.0.0
, random >=1.2.0
, tasty >=1.4.2
, tasty-hunit >=0.10.0
, tasty-quickcheck >=0.10.0
, template-haskell >=2.16.0.0
, th-abstraction >=0.4.3.0
, th-lift-instances >=0.1.18
, transformers >=0.5.6
, vector >=0.12.3.1
default-language: Haskell2010

7
hie.yaml Normal file
View File

@ -0,0 +1,7 @@
cradle:
stack:
- path: "./src"
component: "generic-boltzmann-brain:lib"
- path: "./test"
component: "generic-boltzmann-brain:test:generic-boltzmann-brain-test"

65
package.yaml Normal file
View File

@ -0,0 +1,65 @@
name: generic-boltzmann-brain
version: 0.1.0.0
github: "maciej-bendkowski/generic-boltzmann-brain"
license: BSD3
author: "Maciej Bendkowski"
maintainer: "maciej.bendkowski@gmail.com"
copyright: "2022 Maciej Bendkowski"
extra-source-files:
- README.md
# Metadata used when publishing your package
# synopsis: Short description of your package
# category: Web
# To avoid duplicated efforts in documentation and dealing with the
# complications of embedding Haddock markup inside cabal files, it is
# common to point users to the README.md file.
description: Please see the README on GitHub at <https://github.com/maciej-bendkowski/generic-boltzmann-brain#readme>
dependencies:
- base >= 4.7 && < 5
- containers >= 0.6.4
- vector >= 0.12.3.1
- random >= 1.2.0
- transformers >= 0.5.6
- template-haskell >= 2.16.0.0
- th-abstraction >= 0.4.3.0
- th-lift-instances >= 0.1.18
- mtl >= 2.2.2
- paganini-hs >= 0.3.0.0
library:
source-dirs: src
ghc-options:
- -O2
- -Wall
- -Wcompat
- -Wincomplete-record-updates
- -Wincomplete-uni-patterns
- -Wredundant-constraints
- -Wno-name-shadowing
- -fwarn-missing-signatures
- -ddump-splices
tests:
generic-boltzmann-brain-test:
main: Spec.hs
source-dirs: test
ghc-options:
- -O2
- -Wall
- -Wcompat
- -Wincomplete-record-updates
- -Wincomplete-uni-patterns
- -Wredundant-constraints
- -Wno-name-shadowing
- -fwarn-missing-signatures
- -ddump-splices
dependencies:
- generic-boltzmann-brain
- tasty >= 1.4.2
- tasty-hunit >= 0.10.0
- tasty-quickcheck >= 0.10.0
- QuickCheck >= 2.14.2

View File

@ -0,0 +1,201 @@
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
-- |
-- Module : Data.Boltzmann.Oracle
-- Description :
-- Copyright : (c) Maciej Bendkowski, 2022
-- License : BSD3
-- Maintainer : maciej.bendkowski@gmail.com
-- Stability : experimental
module Data.Boltzmann.Oracle
( mkChoiceFun,
mkWeightFun,
)
where
import Control.Monad (replicateM)
import Data.Boltzmann.Specifiable
( Cons (args, name),
Specifiable (..),
SpecifiableType (..),
TypeDef,
)
import Data.Boltzmann.Specification (getWeight)
import qualified Data.Boltzmann.Specification as S
import qualified Data.Map as Map
import Data.Map.Strict (Map)
import Data.Maybe (fromJust)
import Data.Paganini
( Expr,
FromVariable,
Let (Let),
PaganiniError,
Spec,
ddg,
debugPaganini,
tune,
variable,
variable',
(.=.),
)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Vector
( Vector,
fromList,
)
import Instances.TH.Lift ()
import Language.Haskell.TH
( Exp (LamCaseE),
Lit (IntegerL),
runIO,
)
import Language.Haskell.TH.Syntax
( Body (NormalB),
Exp (LitE),
Lit (StringL),
Match (Match),
Pat (LitP),
Q,
)
-- nicer sum for non-empty lists.
sum' :: Num a => [a] -> a
sum' = foldl1 (+)
type VarDefs = Map String Let
-- Discrete distribution generating tree.
type SystemDDGs = Map String (Vector Int)
mkVariables :: Set SpecifiableType -> Spec VarDefs
mkVariables sys = do
let n = Set.size sys
xs <- replicateM n variable
let sys' = Set.toList sys
names = map (\(SpecifiableType a) -> typeName a) sys'
return (Map.fromList $ names `zip` xs)
mkMarkingVariables :: S.SystemSpec -> Spec VarDefs
mkMarkingVariables sys = do
let constrFreq = Map.toList $ S.constructorFrequencies sys
xs <-
mapM
( \(n, freq) -> do
x <- variable' freq
return (show n, x)
)
constrFreq
return $ Map.fromList xs
-- FIXME: rename
data Variables = Variables
{ sizeVar :: forall a. FromVariable a => a,
typeVariable :: Map String Let,
markingVariable :: Map String Let,
systemSpec :: S.SystemSpec
}
mkTypeVariables :: Variables -> Set SpecifiableType -> Spec ()
mkTypeVariables variables types =
mapM_ (mkTypeVariable variables) (Set.toList types)
mkTypeVariable :: Variables -> SpecifiableType -> Spec ()
mkTypeVariable variables (SpecifiableType typ) = do
let (Let x) = typeVariable variables Map.! typeName typ
x .=. typeExpr variables (typedef typ)
typeExpr :: Variables -> TypeDef -> Expr
typeExpr variables = sum' . map (consExpr variables)
consExpr :: Variables -> Cons -> Expr
consExpr variables cons = defaults u * z ^ w * product args'
where
z = sizeVar variables
u = name cons `Map.lookup` markingVariable variables
w = systemSpec variables `getWeight` name cons
args' = map (argExpr variables) (args cons)
argExpr :: Variables -> SpecifiableType -> Expr
argExpr variables (SpecifiableType typ) =
let Let x = typeVariable variables Map.! typeName typ in x
defaults :: (Num p, FromVariable p) => Maybe Let -> p
defaults Nothing = 1
defaults (Just (Let x)) = x
mkDDGs :: Variables -> Spec SystemDDGs
mkDDGs variables = do
let typeList = Map.toList $ typeVariable variables
ddgs <-
mapM
( \(n, x) -> do
ddgTree <- ddg x
return (n, fromList $ fromJust ddgTree)
)
typeList
return $ Map.fromList ddgs
paganiniSpec :: S.SystemSpec -> Spec SystemDDGs
paganiniSpec sys@(S.SystemSpec {S.targetType = target, S.meanSize = n}) = do
let samplableTypes = S.collectTypes sys
Let z <- variable' n
varDefs <- mkVariables samplableTypes
markDefs <- mkMarkingVariables sys
let variables =
Variables
{ sizeVar = z,
typeVariable = varDefs,
markingVariable = markDefs,
systemSpec = sys
}
mkTypeVariables variables samplableTypes
let (Let t) = varDefs Map.! typeName target
tune t -- tune for target variable.
mkDDGs variables
paganiniSpecIO :: S.SystemSpec -> IO (Either PaganiniError SystemDDGs)
paganiniSpecIO = debugPaganini . paganiniSpec
systemDDGs :: S.SystemSpec -> IO SystemDDGs
systemDDGs sys = do
spec <- paganiniSpecIO sys
return $ case spec of
Left err -> error (show err)
Right x -> x
mkChoiceFun :: S.SystemSpec -> Q Exp
mkChoiceFun sys = do
ddgs <- runIO $ systemDDGs sys
matches <- mapM mkChoiceFun' $ Map.toList ddgs
return $ LamCaseE matches
mkChoiceFun' :: (String, Vector Int) -> Q Match
mkChoiceFun' (s, ddg) = do
listExpr <- [|ddg|]
return $ Match (LitP (StringL s)) (NormalB listExpr) []
mkWeightFun :: S.SystemSpec -> Q Exp
mkWeightFun sys = do
let types = S.collectTypes sys
typedefs = map (\(SpecifiableType typ) -> typedef typ) $ Set.toList types
conMatches <- mapM (mkWeightFun' sys) typedefs
return $ LamCaseE (concat conMatches)
mkWeightFun' :: S.SystemSpec -> TypeDef -> Q [Match]
mkWeightFun' sys = mapM (mkWeightMatch sys)
mkWeightMatch :: S.SystemSpec -> Cons -> Q Match
mkWeightMatch sys cons = return $ Match (LitP (StringL s)) (NormalB $ LitE (IntegerL w)) []
where
s = name cons
w = sys `S.getWeight` s

View File

@ -0,0 +1,61 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE UndecidableInstances #-}
-- |
-- Module : Data.Boltzmann.Sampler
-- Description :
-- Copyright : (c) Maciej Bendkowski, 2022
-- License : BSD3
-- Maintainer : maciej.bendkowski@gmail.com
-- Stability : experimental
module Data.Boltzmann.Sampler
( RejectionSampler,
BoltzmannSampler (..),
rejectionSampler,
rejectionSamplerIO,
)
where
import Control.Monad (guard)
import Control.Monad.Trans (MonadTrans (lift))
import Control.Monad.Trans.Maybe (MaybeT, runMaybeT)
import Data.Boltzmann.Specifiable (Specifiable, listTypeName)
import Data.BuffonMachine (BuffonMachine, choice, runIO)
import Data.Vector (Vector)
import System.Random (RandomGen, StdGen)
type RejectionSampler g a = MaybeT (BuffonMachine g) (a, Int)
class BoltzmannSampler a where
sample :: RandomGen g => (String -> Vector Int) -> (String -> Int) -> Int -> RejectionSampler g a
instance (Specifiable a, BoltzmannSampler a) => BoltzmannSampler [a] where
sample ddgs weight ub = do
guard (ub > 0)
lift (choice (ddgs $ listTypeName (undefined :: a)))
>>= ( \case
0 -> return ([], weight (show '[]))
_ -> do
let wcons = weight (show '(:))
(x, w) <- sample ddgs weight (ub - wcons)
(xs, ws) <- sample ddgs weight (ub - wcons - w)
return (x : xs, w + ws + wcons)
)
rejectionSampler :: RandomGen g => (Int -> RejectionSampler g a) -> Int -> Int -> BuffonMachine g a
rejectionSampler sam lb ub =
do
str <- runMaybeT (sam ub)
case str of
Nothing -> rejectionSampler sam lb ub
Just (x, s) ->
if lb <= s && s <= ub
then return x
else rejectionSampler sam lb ub
rejectionSamplerIO :: (Int -> RejectionSampler StdGen a) -> Int -> Int -> IO a
rejectionSamplerIO sam lb ub = runIO (rejectionSampler sam lb ub)

View File

@ -0,0 +1,173 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
-- |
-- Module : Data.Boltzmann.Oracle
-- Description :
-- Copyright : (c) Maciej Bendkowski, 2022
-- License : BSD3
-- Maintainer : maciej.bendkowski@gmail.com
-- Stability : experimental
module Data.Boltzmann.Sampler.Utils (mkSampler) where
import Control.Monad (guard)
import qualified Control.Monad.Trans as T
import Data.Boltzmann.Sampler (sample)
import Data.BuffonMachine (choice)
import Language.Haskell.TH (Exp (DoE, LamCaseE, TupE), Pat (VarP), Stmt (NoBindS), newName)
import Language.Haskell.TH.Datatype
( ConstructorInfo (constructorName),
DatatypeInfo (..),
constructorFields,
constructorName,
reifyDatatype,
)
import Language.Haskell.TH.Syntax (Body (NormalB), Clause (Clause), Dec (FunD, InstanceD), Exp (AppE, ConE, InfixE, LamE, LitE, VarE), Lit (IntegerL, StringL), Match (Match), Name, Pat (LitP, TupP), Q, Stmt (BindS), Type (AppT, ConT), mkName)
import Prelude hiding (sum)
application :: Exp -> Exp -> [Exp] -> Exp
application op = foldl (\a b -> InfixE (Just a) op (Just b))
sum :: Exp -> [Exp] -> Q Exp
sum expr params = do
op <- [|(+)|]
return $ application op expr params
minus :: Exp -> [Exp] -> Q Exp
minus expr params = do
op <- [|(-)|]
return $ application op expr params
pat :: String -> Pat
pat = VarP . mkName
var :: String -> Exp
var = VarE . mkName
lit :: Integer -> Exp
lit = LitE . IntegerL
fresh :: String -> Q (Pat, Exp)
fresh s = do
x <- newName s
return (VarP x, VarE x)
constructor :: Name -> Q Exp
constructor = return . ConE . mkName . show -- note: we're using fully qualified constructors
weightQuery :: Name -> Q Exp
weightQuery name =
return $ AppE (var "weight") (LitE (StringL (show name)))
genMatchExprs :: [(ConstructorInfo, Integer)] -> Q Exp
genMatchExprs constrGroup = do
matchExprs <- mapM genMatchExpr constrGroup
return $ LamCaseE matchExprs
genMatchExpr :: (ConstructorInfo, Integer) -> Q Match
genMatchExpr (con, n) = do
let n' = LitP $ IntegerL n
conExpr <- genConExpr con
return $ Match n' (NormalB conExpr) []
genConExpr :: ConstructorInfo -> Q Exp
genConExpr con = do
argStmtExpr <- genArgExprs con
case stmts argStmtExpr of
[] -> [|return ($(constructor (constructorName con)), $(weightQuery (constructorName con)))|]
_ -> do
w <- weightQuery (constructorName con)
constrApp <- genConstrApplication (constructorName con) (objs argStmtExpr)
weightSum <- sum w (weights argStmtExpr)
return' <- [|return|]
return $
DoE
Nothing
( stmts argStmtExpr
++ [NoBindS $ AppE return' (TupE [Just constrApp, Just weightSum])]
)
genConstrApplication :: Name -> [Exp] -> Q Exp
genConstrApplication s args' = do
con <- constructor s
return $ foldl AppE con args'
data ArgStmtExpr = ArgStmtExpr
{ stmts :: [Stmt],
objs :: [Exp],
weights :: [Exp]
}
genArgExprs :: ConstructorInfo -> Q ArgStmtExpr
genArgExprs con = do
w <- weightQuery (constructorName con)
ubExpr <- var "ub" `minus` [w]
genArgExprs' ubExpr (constructorFields con)
genArgExprs' :: Exp -> [Type] -> Q ArgStmtExpr
genArgExprs' _ [] = return ArgStmtExpr {stmts = [], objs = [], weights = []}
genArgExprs' ubExpr (_ : as) = do
(xp, x) <- fresh "x"
(wp, w) <- fresh "w"
argExpr <- [|sample|]
ubExpr' <- ubExpr `minus` [w]
argStmtExpr <- genArgExprs' ubExpr' as
let stmt = BindS (TupP [xp, wp]) (AppE (AppE (AppE argExpr (VarE $ mkName "ddgs")) (VarE $ mkName "weight")) ubExpr)
return
ArgStmtExpr
{ stmts = stmt : stmts argStmtExpr,
objs = x : objs argStmtExpr,
weights = w : weights argStmtExpr
}
genChoiceExpr :: Name -> Q Exp
genChoiceExpr typ = do
choice' <- [|choice|]
lift' <- [|T.lift|]
ddgs' <- [|ddgs $(genName typ)|]
return $ foldr AppE ddgs' [lift', choice']
genName :: Name -> Q Exp
genName name = return (LitE $ StringL (show name))
genGuardExpr :: Q Exp
genGuardExpr = do
compOp <- [|(>)|]
let ub = var "ub"
compExpr = InfixE (Just ub) compOp (Just $ lit 0)
guardExpr <- [|guard|]
return $ AppE guardExpr compExpr
gen :: Name -> Q Exp
gen typ = do
guardExpr <- genGuardExpr
choiceExpr <- genChoiceExpr typ
constrGroup <- genConstrGroup typ
caseExpr <- genMatchExprs constrGroup
bindOp <- [|(>>=)|]
return $
LamE
[pat "ddgs", pat "weight", pat "ub"]
$ DoE
Nothing
[ NoBindS guardExpr,
NoBindS $ InfixE (Just choiceExpr) bindOp (Just caseExpr)
]
genConstrGroup :: Name -> Q [(ConstructorInfo, Integer)]
genConstrGroup typ = do
typInfo <- reifyDatatype typ
let consInfo = datatypeCons typInfo
return $ zip consInfo [0 :: Integer ..]
mkSampler :: Name -> Q [Dec]
mkSampler typ = do
samplerBody <- gen typ
let clazz = AppT (ConT $ mkName "BoltzmannSampler") (ConT typ)
funDec = FunD (mkName "sample") [Clause [] (NormalB samplerBody) []]
inst = InstanceD Nothing [] clazz [funDec]
return [inst]

View File

@ -0,0 +1,125 @@
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-missing-methods #-}
-- |
-- Module : Data.Boltzmann.Specifiable
-- Description :
-- Copyright : (c) Maciej Bendkowski, 2022
-- License : BSD3
-- Maintainer : maciej.bendkowski@gmail.com
-- Stability : experimental
module Data.Boltzmann.Specifiable
( SpecifiableType (..),
TypeDef,
Cons (..),
Specifiable (..),
listTypeName,
)
where
import GHC.Generics
( C1,
Constructor (conName),
D1,
Datatype (datatypeName, moduleName),
Generic (Rep, from),
K1,
R,
S1,
U1,
type (:*:),
type (:+:),
)
import Language.Haskell.TH.Syntax (Lift)
-- | Specifiable, algebraic type definitions given
-- as a list of respective type constructors.
type TypeDef = [Cons]
data Cons = Cons
{ name :: String,
args :: [SpecifiableType]
}
deriving (Eq, Show, Lift)
data SpecifiableType
= forall a. (Specifiable a) => SpecifiableType a
instance Show SpecifiableType where
show (SpecifiableType x) = typeName x
instance Eq SpecifiableType where
x == y = show x == show y
instance Ord SpecifiableType where
x <= y = show x <= show y
instance Lift SpecifiableType
class GWithTypeName f where
gtypeName :: f a -> String
instance (Datatype d) => GWithTypeName (D1 d f) where
gtypeName x = moduleName x ++ "." ++ datatypeName x
class Specifiable a where
typedef :: a -> TypeDef
default typedef :: (Generic a, GSpecifiable (Rep a)) => a -> TypeDef
typedef = gtypedef . from
typeName :: a -> String
default typeName :: (Generic a, GWithTypeName (Rep a)) => a -> String
typeName = gtypeName . from
bracket :: String -> String
bracket s = "[" ++ s ++ "]"
listTypeName :: Specifiable a => a -> String
listTypeName = bracket . typeName
-- handle lists.
instance {-# OVERLAPS #-} (Generic a, Specifiable a) => Specifiable [a] where
typeName _ = "[" ++ typeName (undefined :: a) ++ "]"
class GSpecifiable f where
gtypedef :: f a -> TypeDef
instance (Datatype d, GSpecifiable' f) => GSpecifiable (D1 d f) where
gtypedef x = gtypedef' (moduleName x) (undefined :: f a)
type ModuleName = String
class GSpecifiable' f where
gtypedef' :: ModuleName -> f a -> TypeDef
instance (GSpecifiable' f, GSpecifiable' g) => GSpecifiable' (f :+: g) where
gtypedef' moduleName (_ :: (f :+: g) a) =
gtypedef' moduleName (undefined :: f a) ++ gtypedef' moduleName (undefined :: g a)
instance (Constructor c, GConsArg f) => GSpecifiable' (C1 c f) where
gtypedef' moduleName x = [Cons (qualifier ++ conName x) (gargs (undefined :: f a))]
where
qualifier = moduleName ++ "."
class GConsArg f where
gargs :: f a -> [SpecifiableType]
instance GConsArg U1 where
gargs _ = []
instance (Specifiable a) => GConsArg (K1 R a) where
gargs _ = [SpecifiableType (undefined :: a)]
instance (GConsArg f) => GConsArg (S1 s f) where
gargs _ = gargs (undefined :: f a)
instance (GConsArg f, GConsArg g) => GConsArg (f :*: g) where
gargs (_ :: (f :*: g) a) =
gargs (undefined :: f a) ++ gargs (undefined :: g a)

View File

@ -0,0 +1,158 @@
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
-- |
-- Module : Data.Boltzmann.Specification
-- Description :
-- Copyright : (c) Maciej Bendkowski, 2022
-- License : BSD3
-- Maintainer : maciej.bendkowski@gmail.com
-- Stability : experimental
module Data.Boltzmann.Specification
( TypeSpec,
SystemSpec (..),
samplableType,
weight,
frequency,
defaultTypeSpec,
withWeights,
withFrequencies,
specification,
withSystem,
(==>),
collectTypes,
ConsFreq,
constructorFrequencies,
getWeight,
getFrequency,
)
where
import Data.Bifunctor (Bifunctor (first))
import Data.Boltzmann.Specifiable
( Cons (args),
Specifiable (..),
SpecifiableType (..),
)
import qualified Data.Map as Map
import Data.Map.Strict (Map)
import Data.Maybe (fromJust)
import Data.Set (Set)
import qualified Data.Set as Set
import Language.Haskell.TH.Syntax (Name)
data TypeSpec = forall a.
Specifiable a =>
TypeSpec
{ samplableType :: a,
weight :: Map String Integer,
frequency :: Map String Integer
}
instance Eq TypeSpec where
TypeSpec {samplableType = typ} == TypeSpec {samplableType = typ'} =
typeName typ == typeName typ'
instance Ord TypeSpec where
TypeSpec {samplableType = typ} <= TypeSpec {samplableType = typ'} =
typeName typ <= typeName typ'
data SystemSpec = forall a.
Specifiable a =>
SystemSpec {targetType :: a, meanSize :: Integer, typeSpecs :: Set TypeSpec}
getWeight :: SystemSpec -> String -> Integer
getWeight sys name =
if Set.size res == 0
then 1 -- default weight
else fromJust (head $ Set.toList res)
where
res = Nothing `Set.delete` Set.map (getWeight' name) (typeSpecs sys)
getWeight' :: String -> TypeSpec -> Maybe Integer
getWeight' name spec = name `Map.lookup` weight spec
getFrequency :: SystemSpec -> String -> Maybe Integer
getFrequency sys name =
if Set.size res == 0
then Nothing -- default frequency
else head $ Set.toList res
where
res = Nothing `Set.delete` Set.map (getFrequency' name) (typeSpecs sys)
getFrequency' :: String -> TypeSpec -> Maybe Integer
getFrequency' name spec = name `Map.lookup` frequency spec
defaultTypeSpec :: Specifiable a => a -> TypeSpec
defaultTypeSpec typ =
TypeSpec
{ samplableType = typ,
weight =
Map.fromList
[ (show '[], 0),
(show '(:), 0)
],
frequency = Map.empty
}
type Value = (Name, Integer)
(==>) :: Name -> Integer -> Value
consName ==> w = (consName, w)
infix 6 ==>
withWeights :: [Value] -> TypeSpec -> TypeSpec
withWeights values spec = spec {weight = weight spec `Map.union` valMap}
where
valMap = Map.fromList $ map (first show) values
withFrequencies :: [Value] -> TypeSpec -> TypeSpec
withFrequencies values spec =
spec {frequency = frequency spec `Map.union` valMap}
where
valMap = Map.fromList $ map (first show) values
specification :: Specifiable a => a -> (TypeSpec -> TypeSpec) -> TypeSpec
specification typ f = f (defaultTypeSpec typ)
withSystem :: Specifiable a => (a, Integer) -> [TypeSpec] -> SystemSpec
withSystem (typ, size) specs =
SystemSpec
{ targetType = typ,
meanSize = size,
typeSpecs = Set.fromList specs
}
toSpecifiableTypes :: SystemSpec -> Set SpecifiableType
toSpecifiableTypes = Set.map toSpecifiableType . typeSpecs
toSpecifiableType :: TypeSpec -> SpecifiableType
toSpecifiableType (TypeSpec {samplableType = t}) = SpecifiableType t
collectTypes :: SystemSpec -> Set SpecifiableType
collectTypes sys =
foldl collectTypesFromSpecifiableType Set.empty (toSpecifiableTypes sys)
collectTypesFromSpecifiableType ::
Set SpecifiableType -> SpecifiableType -> Set SpecifiableType
collectTypesFromSpecifiableType types st@(SpecifiableType typ)
| st `Set.member` types = types
| otherwise = foldl collectTypesFromCons types' (typedef typ)
where
types' = st `Set.insert` types
collectTypesFromCons :: Set SpecifiableType -> Cons -> Set SpecifiableType
collectTypesFromCons types cons =
foldl collectTypesFromSpecifiableType types (args cons)
type ConsFreq = Map String Integer
constructorFrequencies :: SystemSpec -> ConsFreq
constructorFrequencies sys = Map.unions consFreqs
where
typeSpecs' = Set.toList (typeSpecs sys)
consFreqs = map constructorFrequencies' typeSpecs'
constructorFrequencies' :: TypeSpec -> ConsFreq
constructorFrequencies' (TypeSpec {frequency = freq}) = freq

97
src/Data/BuffonMachine.hs Normal file
View File

@ -0,0 +1,97 @@
-- |
-- Module : Data.BuffonMachine
-- Description :
-- Copyright : (c) Maciej Bendkowski, 2022
-- License : BSD3
-- Maintainer : maciej.bendkowski@gmail.com
-- Stability : experimental
module Data.BuffonMachine
( BuffonMachine,
Discrete,
choice,
run,
runIO,
)
where
import Control.Monad.Trans.State.Strict
( State,
evalState,
get,
modify',
put,
)
import Data.Bits (Bits (testBit))
import Data.Vector (Vector, null, (!))
import Data.Word (Word32)
import System.Random (Random (random), RandomGen, StdGen, getStdGen)
import Prelude hiding (null)
data Oracle g = Oracle
{ buffer :: !Word32,
usedBits :: !Int,
rng :: g
}
fresh :: RandomGen g => g -> Oracle g
fresh g = case random g of
(x, g') -> Oracle {buffer = x, usedBits = 0, rng = g'}
{-# INLINE fresh #-}
useBit :: Oracle g -> Oracle g
useBit oracle = oracle {usedBits = succ (usedBits oracle)}
{-# INLINE useBit #-}
currentBit :: Oracle g -> Bool
currentBit oracle = testBit (buffer oracle) (usedBits oracle)
{-# INLINE currentBit #-}
-- | Buffon machines depending on the given random number generator 'g'.
type BuffonMachine g = State (Oracle g)
type Bern g = BuffonMachine g Bool
regenerate :: RandomGen g => Oracle g -> Oracle g
regenerate oracle =
case usedBits oracle of
32 -> fresh (rng oracle)
_ -> oracle
{-# INLINE regenerate #-}
getBit :: RandomGen g => Bern g
getBit = do
modify' regenerate
oracle <- get
put $ useBit oracle
return $ currentBit oracle
-- | Discrete random variables.
type Discrete g = BuffonMachine g Int
-- |
-- Given a compact discrete distribution generating tree (in vector form)
-- computes a discrete random variable following that distribution.
choice :: RandomGen g => Vector Int -> Discrete g
choice enc
| null enc = return 0 -- note: single-point probability distributions.
| otherwise = choice' enc 0
{-# SPECIALIZE choice :: Vector Int -> Discrete StdGen #-}
choice' :: RandomGen g => Vector Int -> Int -> Discrete g
choice' enc c = do
h <- getBit
let b = fromEnum h
let c' = enc ! (c + b)
if enc ! c' < 0 then return $ -(1 + enc ! c') else choice' enc c'
-- |
-- Runs the given Buffon machine computation
-- using the given random generator.
run :: RandomGen g => BuffonMachine g a -> g -> a
run m = evalState m . fresh
-- |
-- Runs the given Buffon machine computation within the IO monad
-- using StdGen as its random bit oracle.
runIO :: BuffonMachine StdGen a -> IO a
runIO m = run m <$> getStdGen

74
stack.yaml Normal file
View File

@ -0,0 +1,74 @@
# This file was automatically generated by 'stack init'
#
# Some commonly used options have been documented as comments in this file.
# For advanced use and comprehensive documentation of the format, please see:
# https://docs.haskellstack.org/en/stable/yaml_configuration/
# Resolver to choose a 'specific' stackage snapshot or a compiler version.
# A snapshot resolver dictates the compiler version and the set of packages
# to be used for project dependencies. For example:
#
# resolver: lts-3.5
# resolver: nightly-2015-09-21
# resolver: ghc-7.10.2
#
# The location of a snapshot can be provided as a file or url. Stack assumes
# a snapshot provided as a file might change, whereas a url resource does not.
#
# resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml
resolver:
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/16.yaml
compiler: ghc-9.0.1
# User packages to be built.
# Various formats can be used as shown in the example below.
#
# packages:
# - some-directory
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
# subdirs:
# - auto-update
# - wai
packages:
- .
# Dependency packages to be pulled from upstream that are not in the resolver.
# These entries can reference officially published versions as well as
# forks / in-progress versions pinned to a git hash. For example:
#
extra-deps:
- git: https://github.com/maciej-bendkowski/paganini-hs
commit: 941e8f6314ea49b79c2cf1a03924cbedc981917e
- git: https://github.com/OctopiChalmers/BinderAnn
commit: 8f082b23ebd4e79e86e934f41ddfcba59652fadd
# - acme-missiles-0.3
# - git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
#
# extra-deps: []
# Override default flag values for local packages and extra-deps
# flags: {}
# Extra package databases containing global packages
# extra-package-dbs: []
# Control whether we use the GHC we find on the path
# system-ghc: true
#
# Require a specific version of stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: ">=2.7"
#
# Override the architecture used by stack, especially useful on Windows
# arch: i386
# arch: x86_64
#
# Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]
#
# Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor

35
stack.yaml.lock Normal file
View File

@ -0,0 +1,35 @@
# This file was autogenerated by Stack.
# You should not edit this file by hand.
# For more information, please see the documentation at:
# https://docs.haskellstack.org/en/stable/lock_files
packages:
- completed:
name: paganini-hs
version: 0.3.0.0
git: https://github.com/maciej-bendkowski/paganini-hs
pantry-tree:
size: 949
sha256: c20a013dc0ceed7d03a3381d0e32b4122140e183b8b3f764b9fa493fda52bc5a
commit: 941e8f6314ea49b79c2cf1a03924cbedc981917e
original:
git: https://github.com/maciej-bendkowski/paganini-hs
commit: 941e8f6314ea49b79c2cf1a03924cbedc981917e
- completed:
name: BinderAnn
version: 0.1.0.0
git: https://github.com/OctopiChalmers/BinderAnn
pantry-tree:
size: 1631
sha256: 2e2b0b9828f0bd3698344940c4da689947b4530ae75ccc51b03c77db171244e3
commit: 8f082b23ebd4e79e86e934f41ddfcba59652fadd
original:
git: https://github.com/OctopiChalmers/BinderAnn
commit: 8f082b23ebd4e79e86e934f41ddfcba59652fadd
snapshots:
- completed:
size: 586286
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/16.yaml
sha256: cdead65fca0323144b346c94286186f4969bf85594d649c49c7557295675d8a5
original:
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/16.yaml

View File

@ -0,0 +1,12 @@
{-# LANGUAGE TemplateHaskell #-}
module Data.Samplers.BinTree where
import Data.Boltzmann.Oracle (mkChoiceFun, mkWeightFun)
import Data.Boltzmann.Sampler (BoltzmannSampler (..), rejectionSamplerIO)
import Data.Types.BinTree (BinTree, binTreeSysSpec)
randomBinTreeIO :: Int -> Int -> IO BinTree
randomBinTreeIO =
rejectionSamplerIO
(sample $(mkChoiceFun binTreeSysSpec) $(mkWeightFun binTreeSysSpec))

View File

@ -0,0 +1,12 @@
{-# LANGUAGE TemplateHaskell #-}
module Data.Samplers.Lambda where
import Data.Boltzmann.Oracle (mkChoiceFun, mkWeightFun)
import Data.Boltzmann.Sampler (BoltzmannSampler (..), rejectionSamplerIO)
import Data.Types.Lambda (Lambda, lambdaSysSpec)
randomLambdaIO :: Int -> Int -> IO Lambda
randomLambdaIO =
rejectionSamplerIO
(sample $(mkChoiceFun lambdaSysSpec) $(mkWeightFun lambdaSysSpec))

View File

@ -0,0 +1,12 @@
{-# LANGUAGE TemplateHaskell #-}
module Data.Samplers.Tree where
import Data.Boltzmann.Oracle (mkChoiceFun, mkWeightFun)
import Data.Boltzmann.Sampler (BoltzmannSampler (..), rejectionSamplerIO)
import Data.Types.Tree (Tree, treeSysSpec)
randomTreeIO :: Int -> Int -> IO Tree
randomTreeIO =
rejectionSamplerIO
(sample $(mkChoiceFun treeSysSpec) $(mkWeightFun treeSysSpec))

View File

@ -0,0 +1,53 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Types.BinTree where
import Data.Boltzmann.Sampler (BoltzmannSampler (..))
import Data.Boltzmann.Sampler.Utils (mkSampler)
import Data.Boltzmann.Specifiable
( Cons (..),
Specifiable,
SpecifiableType (..),
TypeDef,
)
import Data.Boltzmann.Specification
( SystemSpec,
specification,
withSystem,
withWeights,
(==>),
)
import GHC.Generics (Generic)
import Test.Unit.Utils (Size (..))
data BinTree
= Leaf
| Node BinTree BinTree
deriving (Show, Generic, Specifiable)
instance Size BinTree where
size Leaf = 0
size (Node ln rn) = 1 + size ln + size rn
binTree :: SpecifiableType
binTree = SpecifiableType (undefined :: BinTree)
expectedTypeDef :: TypeDef
expectedTypeDef =
[ Cons {name = "Data.Types.BinTree.Leaf", args = []},
Cons {name = "Data.Types.BinTree.Node", args = [binTree, binTree]}
]
binTreeSysSpec :: SystemSpec
binTreeSysSpec =
(undefined :: BinTree, 1000)
`withSystem` [ specification
(undefined :: BinTree)
( withWeights
['Leaf ==> 0]
)
]
$(mkSampler ''BinTree)

74
test/Data/Types/Lambda.hs Normal file
View File

@ -0,0 +1,74 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Types.Lambda where
import Data.Boltzmann.Sampler (BoltzmannSampler (..))
import Data.Boltzmann.Sampler.Utils (mkSampler)
import Data.Boltzmann.Specifiable
( Cons (..),
Specifiable,
SpecifiableType (..),
TypeDef,
)
import Data.Boltzmann.Specification
( SystemSpec,
specification,
withSystem,
withWeights,
(==>),
)
import GHC.Generics (Generic)
import Test.Unit.Utils (Size (..))
data DeBruijn = S DeBruijn | Z
deriving (Generic, Show, Specifiable)
instance Size DeBruijn where
size (S n) = 1 + size n
size Z = 1
data Lambda
= Abs Lambda
| App Lambda Lambda
| Index DeBruijn
deriving (Generic, Show, Specifiable)
instance Size Lambda where
size (Abs t) = 1 + size t
size (App lt rt) = 1 + size lt + size rt
size (Index n) = size n
deBruijn :: SpecifiableType
deBruijn = SpecifiableType (undefined :: DeBruijn)
lambda :: SpecifiableType
lambda = SpecifiableType (undefined :: Lambda)
expectedDeBruijnTypeDef :: TypeDef
expectedDeBruijnTypeDef =
[ Cons {name = "Data.Types.Lambda.S", args = [deBruijn]},
Cons {name = "Data.Types.Lambda.Z", args = []}
]
expectedLambdaTypeDef :: TypeDef
expectedLambdaTypeDef =
[ Cons {name = "Data.Types.Lambda.Abs", args = [lambda]},
Cons {name = "Data.Types.Lambda.App", args = [lambda, lambda]},
Cons {name = "Data.Types.Lambda.Index", args = [deBruijn]}
]
lambdaSysSpec :: SystemSpec
lambdaSysSpec =
(undefined :: Lambda, 1000)
`withSystem` [ specification
(undefined :: Lambda)
( withWeights
['Index ==> 0]
)
]
$(mkSampler ''DeBruijn)
$(mkSampler ''Lambda)

41
test/Data/Types/Tree.hs Normal file
View File

@ -0,0 +1,41 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Types.Tree where
import Data.Boltzmann.Sampler (BoltzmannSampler (..))
import Data.Boltzmann.Sampler.Utils (mkSampler)
import Data.Boltzmann.Specifiable
( Cons (..),
Specifiable,
SpecifiableType (..),
TypeDef,
)
import Data.Boltzmann.Specification
( SystemSpec,
defaultTypeSpec,
withSystem,
)
import GHC.Generics (Generic)
import Test.Unit.Utils (Size (..))
newtype Tree = Node [Tree]
deriving (Show, Generic, Specifiable)
treeList :: SpecifiableType
treeList = SpecifiableType (undefined :: [Tree])
expectedTypeDef :: TypeDef
expectedTypeDef =
[Cons {name = "Data.Types.Tree.Node", args = [treeList]}]
instance Size Tree where
size (Node xs) = 1 + sum (map size xs)
treeSysSpec :: SystemSpec
treeSysSpec =
(undefined :: Tree, 1000)
`withSystem` [defaultTypeSpec (undefined :: Tree)]
$(mkSampler ''Tree)

15
test/Spec.hs Normal file
View File

@ -0,0 +1,15 @@
import Test.Tasty (TestTree, defaultMain, testGroup)
import qualified Test.Unit.Specifiable as Specifiable
import qualified Test.Unit.Sampler as Sampler
main :: IO ()
main = defaultMain tests
tests :: TestTree
tests = testGroup "Unit tests" unitTests
unitTests :: [TestTree]
unitTests =
[ Specifiable.unitTests,
Sampler.unitTests
]

44
test/Test/Unit/Sampler.hs Normal file
View File

@ -0,0 +1,44 @@
module Test.Unit.Sampler (unitTests) where
import Data.Boltzmann.Sampler ()
import Data.Samplers.BinTree
import Data.Samplers.Lambda
import Data.Samplers.Tree
import Test.QuickCheck.Monadic
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck
import Test.Unit.Utils (size)
unitTests :: TestTree
unitTests =
testGroup
"Sampler"
sampleSizeTests
sampleSizeTests :: [TestTree]
sampleSizeTests =
[ 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 "Tree sampler respects size constraints for sizes around the mean of 1,000" treeSamplerSizeProp
]
lambdaSamplerSizeProp :: Positive Int -> Property
lambdaSamplerSizeProp (Positive x) = monadicIO $ do
let (lb, ub) = (800 + x, 1200 + x)
term <- run $ randomLambdaIO lb ub
let n = size term
assert $ lb <= n && n <= ub
binTreeSamplerSizeProp :: Positive Int -> Property
binTreeSamplerSizeProp (Positive x) = monadicIO $ do
let (lb, ub) = (800 + x, 1200 + x)
tree <- run $ randomBinTreeIO lb ub
let n = size tree
assert $ lb <= n && n <= ub
treeSamplerSizeProp :: Positive Int -> Property
treeSamplerSizeProp (Positive x) = monadicIO $ do
let (lb, ub) = (800 + x, 1200 + x)
tree <- run $ randomTreeIO lb ub
let n = size tree
assert $ lb <= n && n <= ub

View File

@ -0,0 +1,49 @@
{-# LANGUAGE TemplateHaskellQuotes #-}
module Test.Unit.Specifiable (unitTests) where
import Data.Boltzmann.Specifiable (typeName, typedef)
import Data.Types.BinTree (BinTree)
import qualified Data.Types.BinTree as BinTree
import Data.Types.Lambda (DeBruijn, Lambda)
import qualified Data.Types.Lambda as Lambda
import Data.Types.Tree (Tree)
import qualified Data.Types.Tree as Tree
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase, (@=?))
unitTests :: TestTree
unitTests =
testGroup
"Specifiable"
[typeDefinitionTests, typeNameTests]
typeDefinitionTests :: TestTree
typeDefinitionTests =
testGroup
"Type definition tests"
[ testCase "BinTree is correctly mapped into a type definition" $
BinTree.expectedTypeDef @=? typedef (undefined :: BinTree),
testCase "Tree is correctly mapped into a type definition" $
Tree.expectedTypeDef @=? typedef (undefined :: Tree),
testCase "DeBruijn is correctly mapped into a type definition" $
Lambda.expectedDeBruijnTypeDef @=? typedef (undefined :: DeBruijn),
testCase "Lambda is correctly mapped into a type definition" $
Lambda.expectedLambdaTypeDef @=? typedef (undefined :: Lambda)
]
typeNameTests :: TestTree
typeNameTests =
testGroup
"Type name tests"
[ testCase ("BinTree's type name is '" ++ show ''BinTree ++ "'") $
show ''BinTree @=? typeName (undefined :: BinTree),
testCase ("Tree's type name is '" ++ show ''Tree ++ "'") $
show ''Tree @=? typeName (undefined :: Tree),
testCase ("Lambda's type name is '" ++ show ''Lambda ++ "'") $
show ''Lambda @=? typeName (undefined :: Lambda),
testCase "[DeBruijn]'s type name is [Data.Types.Lambda.DeBruijn]" $
"[Data.Types.Lambda.DeBruijn]" @=? typeName (undefined :: [DeBruijn]),
testCase "[[DeBruijn]]'s type name is [[Data.Types.Lambda.DeBruijn]]" $
"[[Data.Types.Lambda.DeBruijn]]" @=? typeName (undefined :: [[DeBruijn]])
]

4
test/Test/Unit/Utils.hs Normal file
View File

@ -0,0 +1,4 @@
module Test.Unit.Utils (Size (..)) where
class Size a where
size :: a -> Int