blob: 3d97a029ed5b9772f63c076a524908ead016bf7e (
plain)
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
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
|
module CompileM where
import Grammar
import Ident
import Option
import PrGrammar
import Update
import Lookup
import Modules
---import Rename
import Operations
import UseIO
import Monad
compileMGrammar :: Options -> SourceGrammar -> IOE SourceGrammar
compileMGrammar opts sgr = do
ioeErr $ checkUniqueModuleNames sgr
deps <- ioeErr $ moduleDeps sgr
deplist <- either return
(\ms -> ioeBad $ "circular modules" +++ unwords (map show ms)) $
topoTest deps
let deps' = closureDeps deps
foldM (compileModule opts deps' sgr) emptyMGrammar deplist
checkUniqueModuleNames :: MGrammar i f a r c -> Err ()
checkUniqueModuleNames gr = do
let ms = map fst $ tree2list $ modules gr
msg = checkUnique ms
if null msg then return () else Bad $ unlines msg
-- to decide what modules immediately depend on what, and check if the
-- dependencies are appropriate
moduleDeps :: MGrammar i f a c r -> Err Dependencies
moduleDeps gr = mapM deps $ tree2list $ modules gr where
deps (c,mi) = errIn ("checking dependencies of module" +++ prt c) $ case mi of
ModAbs m -> chDep (IdentM c MTAbstract)
(extends m) MTAbstract (opens m) MTAbstract
ModRes m -> chDep (IdentM c MTResource)
(extends m) MTResource (opens m) MTResource
ModCnc m -> do
a:ops <- case opens m of
os@(_:_) -> return os
_ -> Bad "no abstract indicated for concrete module"
aty <- lookupModuleType gr a
testErr (aty == MTAbstract) "the for-module is not an abstract syntax"
chDep (IdentM c (MTConcrete a)) (extends m) MTResource ops MTResource
chDep it es ety os oty = do
ests <- mapM (lookupModuleType gr) es
testErr (all (==ety) ests) "inappropriate extension module type"
osts <- mapM (lookupModuleType gr) os
testErr (all (==oty) osts) "inappropriate open module type"
return (it, [IdentM e ety | e <- es] ++ [IdentM o oty | o <- os])
type Dependencies = [(IdentM Ident,[IdentM Ident])]
---compileModule :: Options -> Dependencies -> SourceGrammar ->
--- CanonGrammar -> IdentM -> IOE CanonGrammar
compileModule opts deps sgr cgr i = do
let name = identM i
testIfCompiled deps name
mi <- ioeErr $ lookupModule sgr name
mi' <- case typeM i of
-- previously compiled cgr used as symbol table
MTAbstract -> compileAbstract cgr mi
MTResource -> compileResource cgr mi
MTConcrete a -> compileConcrete a cgr mi
ifIsOpt doOutput $ writeCanonFile name mi'
return $ addModule cgr name mi'
where
ifIsOpt o f = if (oElem o opts) then f else return ()
doOutput = iOpt "o"
testIfCompiled :: Dependencies -> Ident -> IOE Bool
testIfCompiled _ _ = return False ----
---writeCanonFile :: Ident -> CanonModInfo -> IOE ()
writeCanonFile name mi' = ioeIO $ writeFile (canonFileName name) [] ----
canonFileName n = n ++ ".gfc" ---- elsewhere!
---compileAbstract :: CanonGrammar -> SourceModInfo -> IOE CanonModInfo
compileAbstract can (ModAbs m0) = do
let m1 = renameMAbstract m0
{-
checkUnique
typeCheck
generateCode
addToCanon
-}
ioeBad "compile abs not yet"
---compileResource :: CanonGrammar -> SourceModInfo -> IOE CanonModInfo
compileResource can md = do
{-
checkUnique
typeCheck
topoSort
compileOpers -- conservative, since more powerful than lin
generateCode
addToCanon
-}
ioeBad "compile res not yet"
---compileConcrete :: Ident -> CanonGrammar -> SourceModInfo -> IOE CanonModInfo
compileConcrete ab can md = do
{-
checkUnique
checkComplete ab
typeCheck
topoSort
compileOpers
optimize
createPreservedOpers
generateCode
addToCanon
-}
ioeBad "compile cnc not yet"
-- to be imported
closureDeps :: [(a,[a])] -> [(a,[a])]
closureDeps ds = ds ---- fix-point iteration
|
