-
Notifications
You must be signed in to change notification settings - Fork 0
/
Generator.hs
72 lines (60 loc) · 2.09 KB
/
Generator.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
module Generator where
import Lambda
import Control.Monad (liftM, liftM2)
import Data.List (elemIndices)
import Test.QuickCheck
instance Arbitrary Type where
arbitrary = sized genType
genType :: Int -> Gen Type
genType 0 = return Bool
genType n = do
n' <- choose (0, n `div` 2)
n'' <- choose (0, n `div` 2)
liftM2 Func (genType n') (genType n'')
instance Arbitrary Term where
arbitrary = genTerm [] =<< arbitrary
genTerm :: [Type] -> Type -> Gen Term
genTerm ctx typ
| null vars = genTerm' ctx typ
| otherwise = frequency [ (5, liftM Var (elements vars))
, (1, genTerm' ctx typ)
]
where vars = elemIndices typ ctx
genTerm' :: [Type] -> Type -> Gen Term
genTerm' ctx Bool = frequency [ (9, elements [Tru, Fls])
, (2, genIf ctx Bool)
, (1, genApp ctx Bool)
]
genTerm' ctx typ@(Func typ1 typ2) = frequency [ (6, genAbs ctx typ1 typ2)
, (2, genIf ctx typ)
, (1, genApp ctx typ)
]
genIf :: [Type] -> Type -> Gen Term
genIf ctx typ = do
cond <- genTerm ctx Bool
thenBranch <- genTerm ctx typ
elseBranch <- genTerm ctx typ
return (If cond thenBranch elseBranch)
genAbs :: [Type] -> Type -> Type -> Gen Term
genAbs ctx typ1 typ2 = do
let ctx' = typ1 : ctx
body <- genTerm ctx' typ2
name <- varName
return (Abs name typ1 body)
-- Generate a random one-letter variable name.
varName :: Gen String
varName = do
char <- elements ['a'..'z']
return [char]
genApp :: [Type] -> Type -> Gen Term
genApp ctx typ = do
argTyp <- genTypeFromCtx ctx
arg <- genTerm ctx argTyp
func <- genTerm ctx (Func argTyp typ)
return (App func arg)
-- If we have any types in the environment, return one of them instead of
-- generating a brand new one. This helps with finding suitable arguments
-- for randomly-generated App terms.
genTypeFromCtx :: [Type] -> Gen Type
genTypeFromCtx [] = arbitrary
genTypeFromCtx ctx = elements ctx