-
Notifications
You must be signed in to change notification settings - Fork 0
/
Rules.hs
76 lines (60 loc) · 2.77 KB
/
Rules.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
73
74
75
76
-- Rules for checking
-- Author: Ben Blum <bblum@andrew.cmu.edu>
module Rules
--(Context,Annotation,effect,subtype,satisfies,intersect,disjoin,entryContext,entryDefault)
where
data Context = Nested Int | Infinity deriving (Show,Eq) -- user-defined
data Effect = IncDec Int | Enable | Disable deriving Eq -- user-defined
newtype Rule = Rule Context deriving (Eq,Ord)
newtype Annotation = Annotation (Rule,Effect) deriving Eq
instance Ord Context where -- subtyping relation; user-defined
(Nested x) <= (Nested y) = y <= x
(Nested _) <= Infinity = False
Infinity <= (Nested _) = True
Infinity <= Infinity = True
instance Show Rule where -- user-defined
show (Rule (Nested 0)) = "might_sleep"
show (Rule (Nested 1)) = "nested_one"
show (Rule (Nested x)) = "[unknown rule: " ++ show x ++ "]"
show (Rule Infinity) = "wont_sleep"
instance Show Effect where -- user-defined
show (IncDec 0) = "no_change"
show (IncDec (-1)) = "exit_nested"
show (IncDec 1) = "enter_nested"
show Enable = "force_enable"
show Disable = "force_disable" -- is this ever used?
show (IncDec x) = "[unknown effect: " ++ show x ++ "]"
instance Show Annotation where
show (Annotation (r, IncDec 0)) = show r
show (Annotation (r,e)) = show r ++ ", " ++ show e
-- Change the context somehow.
effect :: Annotation -> Context -> Maybe Context -- user-defined
effect (Annotation (_,Enable)) _ = Just $ Nested 0
effect (Annotation (_,Disable)) _ = Just Infinity
effect (Annotation (_,_)) Infinity = Just Infinity
effect (Annotation (_,IncDec y)) (Nested x) =
if x + y < 0 then Nothing else Just $ Nested $ x + y
-- Is the second argument a subtype of the first? (is assignment legal?)
subtype :: Annotation -> Annotation -> Bool
subtype (Annotation (Rule r1,e1)) (Annotation (Rule r2,e2)) =
(r2 <= r1) && (e1 == e2)
-- Does the provided code context satisfy the annotation?
satisfies :: Annotation -> Context -> Bool
satisfies (Annotation (Rule r,_)) c = r <= c
-- For intersect and disjoin, below.
merge :: (Context -> Context -> Context)
-> Annotation -> Annotation -> Maybe Annotation
merge f (Annotation (Rule r1, e1)) (Annotation (Rule r2, e2)) =
if e1 == e2 then Just $ Annotation (Rule $ f r1 r2, e1) else Nothing
-- Gives an annotation that is a subtype of both inputs.
intersect :: Annotation -> Annotation -> Maybe Annotation
intersect = merge min
-- Gives an annotation that both inputs are subtypes of.
disjoin :: Annotation -> Annotation -> Maybe Annotation
disjoin = merge max
-- Gives the most restrictive context that a function may be called from.
entryContext :: Annotation -> Context
entryContext (Annotation (Rule r, _)) = r
-- Gives a default context to start checking function bodies.
entryDefault :: Context -- user-defined
entryDefault = Infinity