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
142
143
144
145
146
147
148
149
150
|
----------------------------------------------------------------------
-- |
-- Module : ModDeps
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/11 23:24:34 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.14 $
--
-- Check correctness of module dependencies. Incomplete.
--
-- AR 13\/5\/2003
-----------------------------------------------------------------------------
module GF.Compile.ModDeps (mkSourceGrammar,
moduleDeps,
openInterfaces,
requiredCanModules
) where
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Infra.Option
import GF.Grammar.PrGrammar
import GF.Compile.Update
import GF.Grammar.Lookup
import GF.Infra.Modules
import GF.Data.Operations
import Control.Monad
import Data.List
-- | 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))
type Dependencies = [(IdentM Ident,[IdentM Ident])]
-- | to decide what modules immediately depend on what, and check if the
-- dependencies are appropriate
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 of-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 <- mapM (lookupModuleType gr) es
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 | 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 canonical gr.
-- its argument is typically a concrete module name
requiredCanModules :: (Ord i, Show i) => Bool -> MGrammar i f a -> i -> [i]
requiredCanModules isSingle gr c = nub $ filter notReuse ops ++ exts where
exts = allExtends gr c
ops = if isSingle
then map fst (modules gr)
else iterFix (concatMap more) $ exts
more i = errVal [] $ do
m <- lookupModMod gr i
return $ extends m ++ [o | o <- map openedModule (opens m)]
notReuse i = errVal True $ do
m <- lookupModMod gr i
return $ isModRes m -- to exclude reused Cnc and Abs from required
{-
-- 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
-}
|
