Le.hs revision 7c57322afb6342e5cc8b1fdc96050b707407fc61
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
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
$Id$
Authors: Christian Maeder
Year: 2002/2003
abstract syntax after/during static analysis
-}
module Le where
import Id
import As
import MonadState
import FiniteMap
import List
import Result
data ClassInfo = ClassInfo { classId :: ClassId
, superClasses :: [ClassId]
, classDefn :: Class
, instances :: [Qual Pred]
} deriving (Show, Eq)
newClassInfo :: ClassId -> ClassInfo
newClassInfo cid = ClassInfo cid [] (Intersection [] []) []
-----------------------------------------------------------------------------
type ClassMap = FiniteMap ClassId ClassInfo
-- transitiv super classes
-- PRE: all superclasses and defns must be defined in ClassEnv
-- and there must be no cycle!
allSuperClasses :: ClassMap -> ClassId -> [ClassId]
allSuperClasses ce ci =
case lookupFM ce ci of
Just info -> nub $
ci: concatMap (allSuperClasses ce) (iclass $
classDefn info)
++ concatMap (allSuperClasses ce) (superClasses info)
Nothing -> error "allSuperClasses"
defCEntry :: ClassMap -> ClassId -> [ClassId] -> Class -> ClassMap
defCEntry ce cid sups defn = addToFM ce cid
(newClassInfo cid) { superClasses = sups
, classDefn = defn }
-----------------------------------------------------------------------------
-- assumptions
-----------------------------------------------------------------------------
type Assumps = FiniteMap Id [TypeScheme]
type TypeKinds = FiniteMap TypeId [Kind]
type ClassSyns = FiniteMap ClassId [ClassId]
-----------------------------------------------------------------------------
-- local env
-----------------------------------------------------------------------------
data Env = Env { classMap :: ClassMap
, classSyns :: ClassSyns
, typeKinds :: TypeKinds
, typeVars :: [TypeId]
, assumps :: Assumps
, envDiags :: [Diagnosis]
} deriving Show
initialEnv :: Env
initialEnv = Env emptyFM emptyFM emptyFM [] emptyFM []
appendDiags :: [Diagnosis] -> State Env ()
appendDiags ds =
if null ds then return () else
do e <- get
put $ e {envDiags = ds ++ envDiags e}
getClassMap :: State Env ClassMap
getClassMap = gets classMap
putClassMap :: ClassMap -> State Env ()
putClassMap ce = do { e <- get; put e { classMap = ce } }
getClassSyns :: State Env ClassSyns
getClassSyns = gets classSyns
getClassEnv :: State Env (ClassMap, ClassSyns)
getClassEnv = do cMap <- getClassMap
cSyns <- getClassSyns
return (cMap, cSyns)
putClassSyns :: ClassSyns -> State Env ()
putClassSyns ce = do { e <- get; put e { classSyns = ce } }
getTypeKinds :: State Env TypeKinds
getTypeKinds = gets typeKinds
putTypeKinds :: TypeKinds -> State Env ()
putTypeKinds tk = do { e <- get; put e { typeKinds = tk } }
getAssumps :: State Env Assumps
getAssumps = gets assumps
putAssumps :: Assumps -> State Env ()
putAssumps as = do { e <- get; put e { assumps = as } }
getTypeVars :: State Env [TypeId]
getTypeVars = gets typeVars
putTypeVars :: [TypeId] -> State Env ()
putTypeVars ts = do { e <- get; put e { typeVars = ts } }
addTypeVar :: TypeId -> State Env ()
addTypeVar t = do ts <- getTypeVars
putTypeVars $ insert t ts