forked from GitHub/gf-core
GF.Devel.ModDeps is removed. The only used function is moved to GrammarToGFCC
This commit is contained in:
@@ -19,7 +19,6 @@ import qualified GF.Infra.Option as O
|
|||||||
import GF.Conversion.SimpleToFCFG (convertConcrete)
|
import GF.Conversion.SimpleToFCFG (convertConcrete)
|
||||||
import GF.Parsing.FCFG.PInfo (buildFCFPInfo)
|
import GF.Parsing.FCFG.PInfo (buildFCFPInfo)
|
||||||
import GF.Devel.PrintGFCC
|
import GF.Devel.PrintGFCC
|
||||||
import GF.Devel.ModDeps
|
|
||||||
import GF.Infra.Ident
|
import GF.Infra.Ident
|
||||||
import GF.Infra.Option
|
import GF.Infra.Option
|
||||||
import GF.Data.Operations
|
import GF.Data.Operations
|
||||||
@@ -539,3 +538,17 @@ prtTrace tr n =
|
|||||||
prTrace tr n = trace ("-- OBSERVE" +++ A.prt tr +++ show n +++ show tr) n
|
prTrace tr n = trace ("-- OBSERVE" +++ A.prt tr +++ show n +++ show tr) n
|
||||||
|
|
||||||
|
|
||||||
|
-- | 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 -> M.MGrammar i f a -> i -> [i]
|
||||||
|
requiredCanModules isSingle gr c = nub $ filter notReuse ops ++ exts where
|
||||||
|
exts = M.allExtends gr c
|
||||||
|
ops = if isSingle
|
||||||
|
then map fst (M.modules gr)
|
||||||
|
else iterFix (concatMap more) $ exts
|
||||||
|
more i = errVal [] $ do
|
||||||
|
m <- M.lookupModMod gr i
|
||||||
|
return $ M.extends m ++ [o | o <- map M.openedModule (M.opens m)]
|
||||||
|
notReuse i = errVal True $ do
|
||||||
|
m <- M.lookupModMod gr i
|
||||||
|
return $ M.isModRes m -- to exclude reused Cnc and Abs from required
|
||||||
|
|||||||
@@ -1,153 +0,0 @@
|
|||||||
----------------------------------------------------------------------
|
|
||||||
-- |
|
|
||||||
-- 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.Devel.ModDeps (mkSourceGrammar,
|
|
||||||
moduleDeps,
|
|
||||||
openInterfaces,
|
|
||||||
requiredCanModules
|
|
||||||
) where
|
|
||||||
|
|
||||||
import GF.Infra.Ident
|
|
||||||
import GF.Infra.Option
|
|
||||||
import GF.Infra.Modules
|
|
||||||
import GF.Grammar.Grammar
|
|
||||||
import GF.Grammar.PrGrammar
|
|
||||||
import GF.Grammar.Lookup
|
|
||||||
import GF.Compile.Update
|
|
||||||
|
|
||||||
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]
|
|
||||||
_ -> return () --- Bad $ "bug: ModDeps does not treat" +++ show mo
|
|
||||||
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
|
|
||||||
(MTResource, MTConcrete _) -> True
|
|
||||||
(MTInstance _, MTConcrete _) -> True
|
|
||||||
(MTInterface, MTAbstract) -> True
|
|
||||||
(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
|
|
||||||
-}
|
|
||||||
|
|
||||||
Reference in New Issue
Block a user