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
|
module ModDeps where
import Grammar
import Ident
import Option
import PrGrammar
import Update
import Lookup
import Modules
import Operations
import Monad
import List
-- AR 13/5/2003
-- to check uniqueness of module names and import names, the
-- appropriateness of import and extend types,
-- to build a dependency graph of modules, and to sort them topologically
mkSourceGrammar :: [(Ident,SourceModInfo)] -> Err SourceGrammar
mkSourceGrammar ms = do
let ns = map fst ms
checkUniqueErr ns
mapM (checkUniqueImportNames ns . snd) ms
deps <- moduleDeps ms
deplist <- either
return
(\ms -> Bad $ "circular modules" +++ unwords (map show ms)) $
topoTest deps
return $ MGrammar [(m, maybe undefined id $ lookup m ms) | IdentM m _ <- deplist]
checkUniqueErr :: (Show i, Eq i) => [i] -> Err ()
checkUniqueErr ms = do
let msg = checkUnique ms
if null msg then return () else Bad $ unlines msg
-- check that import names don't clash with module names
checkUniqueImportNames :: [Ident] -> SourceModInfo -> Err ()
checkUniqueImportNames ns mo = case mo of
ModMod m -> test [n | OQualif _ n v <- opens m, n /= v]
where
test ms = testErr (all (`notElem` ns) ms)
("import names clashing with module names among" +++
unwords (map prt ms))
-- to decide what modules immediately depend on what, and check if the
-- dependencies are appropriate
type Dependencies = [(IdentM Ident,[IdentM Ident])]
moduleDeps :: [(Ident,SourceModInfo)] -> Err Dependencies
moduleDeps ms = mapM deps ms where
deps (c,mi) = errIn ("checking dependencies of module" +++ prt c) $ case mi of
ModMod m -> case mtype m of
MTConcrete a -> do
aty <- lookupModuleType gr a
testErr (aty == MTAbstract) "the for-module is not an abstract syntax"
chDep (IdentM c (MTConcrete a))
(extends m) (MTConcrete a) (opens m) MTResource
t -> chDep (IdentM c t) (extends m) t (opens m) t
chDep it es ety os oty = do
ests <- case es of
Just e -> liftM singleton $ lookupModuleType gr e
_ -> return []
testErr (all (compatMType ety) ests) "inappropriate extension module type"
osts <- mapM (lookupModuleType gr . openedModule) os
testErr (all (compatOType oty) osts) "inappropriate open module type"
let ab = case it of
IdentM _ (MTConcrete a) -> [IdentM a MTAbstract]
_ -> [] ----
return (it, ab ++
[IdentM e ety | Just e <- [es]] ++
[IdentM (openedModule o) oty | o <- os])
-- check for superficial compatibility, not submodule relation etc: what can be extended
compatMType mt0 mt = case (mt0,mt) of
(MTConcrete _, MTConcrete _) -> True
(MTInstance _, MTInstance _) -> True
(MTReuse _, MTReuse _) -> True
(MTInstance _, MTResource) -> True
(MTResource, MTInstance _) -> True
---- some more?
_ -> mt0 == mt
-- in the same way; this defines what can be opened
compatOType mt0 mt = case mt0 of
MTAbstract -> mt == MTAbstract
MTTransfer _ _ -> mt == MTAbstract
_ -> case mt of
MTResource -> True
MTReuse _ -> True
MTInterface -> True
MTInstance _ -> True
_ -> False
gr = MGrammar ms --- hack
openInterfaces :: Dependencies -> Ident -> Err [Ident]
openInterfaces ds m = do
let deps = [(i,ds) | (IdentM i _,ds) <- ds]
let more (c,_) = [(i,mt) | Just is <- [lookup c deps], IdentM i mt <- is]
let mods = iterFix (concatMap more) (more (m,undefined))
return $ [i | (i,MTInterface) <- mods]
-- this function finds out what modules are really needed in the canoncal gr.
-- its argument is typically a concrete module name
requiredCanModules :: (Eq i, Show i) => MGrammar i f a -> i -> [i]
requiredCanModules gr = nub . iterFix (concatMap more) . singleton where
more i = errVal [] $ do
m <- lookupModMod gr i
return $ maybe [] return (extends m) ++ map openedModule (opens m)
{-
-- to test
exampleDeps = [
(ir "Nat",[ii "Gen", ir "Adj"]),
(ir "Adj",[ii "Num", ii "Gen", ir "Nou"]),
(ir "Nou",[ii "Cas"])
]
ii s = IdentM (IC s) MTInterface
ir s = IdentM (IC s) MTResource
-}
|
