msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

bug fix in the module dependencies checker

Browse Source
This commit is contained in:
krasimir
2009-01-31 10:49:01 +00:00
parent f207a4038e
commit 99c430e5f5
9 changed files with 73 additions and 58 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/GF/Compile.hs
View File

@@ -173,7 +173,7 @@ compileOne opts env@(_,srcgr,_) file = do
-- sm is optimized before generation, but not in the env
extendCompileEnvInt env k' (Just gfo) sm1
where
isConcr (_,m) = isModCnc m && mstatus m /= MSIncomplete && isNothing (mwith m)
isConcr (_,m) = isModCnc m && mstatus m /= MSIncomplete
compileSourceModule :: Options -> CompileEnv -> SourceModule -> IOE (Int,SourceModule)
compileSourceModule opts env@(k,gr,_) mo@(i,mi) = do

29
src/GF/Compile/Extend.hs
View File

@@ -27,6 +27,7 @@ import GF.Grammar.Macros
import GF.Data.Operations
import Control.Monad
import Data.List(nub)
extendModule :: [SourceModule] -> SourceModule -> Err SourceModule
extendModule ms (name,m)
@@ -38,21 +39,25 @@ extendModule ms (name,m)
return (name,m')
where
extOne mo (n,cond) = do
(m0,isCompl) <- do
m <- lookupModule (MGrammar ms) n
m0 <- lookupModule (MGrammar ms) n
-- test that the module types match, and find out if the old is complete
testErr (sameMType (mtype m) (mtype mo))
("illegal extension type to module" +++ prt name)
return (m, isCompleteModule m)
-- test that the module types match, and find out if the old is complete
testErr (sameMType (mtype m) (mtype mo))
("illegal extension type to module" +++ prt name)
-- build extension in a way depending on whether the old module is complete
js1 <- extendMod isCompl (n, isInherited cond) name (jments m0) (jments mo)
let isCompl = isCompleteModule m0
-- if incomplete, throw away extension information
let es = extend mo
let es' = if isCompl then es else (filter ((/=n) . fst) es)
return $ mo {extend = es', jments = js1}
-- build extension in a way depending on whether the old module is complete
js1 <- extendMod isCompl (n, isInherited cond) name (jments m0) (jments mo)
-- if incomplete, throw away extension information
return $
if isCompl
then mo {jments = js1}
else mo {extend = filter ((/=n) . fst) (extend mo)
,mexdeps= nub (n : mexdeps mo)
,jments = js1
}
-- | When extending a complete module: new information is inserted,
-- and the process is interrupted if unification fails.

4
src/GF/Compile/GrammarToGFCC.hs
View File

@@ -223,8 +223,8 @@ mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do
reorder :: Ident -> SourceGrammar -> SourceGrammar
reorder abs cg = M.MGrammar $
(abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] adefs poss):
[(c, M.ModInfo (M.MTConcrete abs) M.MSComplete fs [] Nothing [] (sorted2tree js) poss)
(abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] [] adefs poss):
[(c, M.ModInfo (M.MTConcrete abs) M.MSComplete fs [] Nothing [] [] (sorted2tree js) poss)
| (c,(fs,js)) <- cncs]
where
poss = emptyBinTree -- positions no longer needed

9
src/GF/Compile/ReadFiles.hs
View File

@@ -179,6 +179,7 @@ importsOfModule (m,mi) = (modName m,depModInfo mi [])
depModType (mtype mi) .
depExtends (extend mi) .
depWith (mwith mi) .
depExDeps (mexdeps mi).
depOpens (opens mi)
depModType (MTAbstract) xs = xs
@@ -190,16 +191,22 @@ importsOfModule (m,mi) = (modName m,depModInfo mi [])
depExtends es xs = foldr depInclude xs es
depWith (Just (m,_,os)) xs = modName m : depOpens os xs
depWith (Just (m,_,is)) xs = modName m : depInsts is xs
depWith Nothing xs = xs
depExDeps eds xs = map modName eds ++ xs
depOpens os xs = foldr depOpen xs os
depInsts is xs = foldr depInst xs is
depInclude (m,_) xs = modName m:xs
depOpen (OSimple n ) xs = modName n:xs
depOpen (OQualif _ n) xs = modName n:xs
depInst (m,n) xs = modName m:modName n:xs
modName = prIdent
-- | options can be passed to the compiler by comments in @--#@, in the main file

45
src/GF/Compile/Rebuild.hs
View File

@@ -32,62 +32,59 @@ import Data.Maybe (isNothing)
-- | rebuilding instance + interface, and "with" modules, prior to renaming.
-- AR 24/10/2003
rebuildModule :: [SourceModule] -> SourceModule -> Err SourceModule
rebuildModule ms mo@(i,mi) = do
rebuildModule ms mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_ ps_)) = do
let gr = MGrammar ms
---- deps <- moduleDeps ms
---- is <- openInterfaces deps i
let is = [] ---- the method above is buggy: try "i -src" for two grs. AR 8/3/2005
mi' <- case mi of
mi' <- case mw of
-- add the information given in interface into an instance module
m | isNothing (mwith m) -> do
testErr (null is || mstatus m == MSIncomplete)
Nothing -> do
testErr (null is || mstatus mi == MSIncomplete)
("module" +++ prt i +++
"has open interfaces and must therefore be declared incomplete")
case mtype m of
case mt of
MTInstance i0 -> do
m1 <- lookupModule gr i0
testErr (isModRes m1) ("interface expected instead of" +++ prt i0)
m' <- do
js' <- extendMod False (i0,const True) i (jments m1) (jments m)
--- to avoid double inclusions, in instance I of I0 = J0 ** ...
case extends m of
[] -> return $ replaceJudgements m js'
j0s -> do
js' <- extendMod False (i0,const True) i (jments m1) (jments mi)
--- to avoid double inclusions, in instance I of I0 = J0 ** ...
case extends mi of
[] -> return $ replaceJudgements mi js'
j0s -> do
m0s <- mapM (lookupModule gr) j0s
let notInM0 c _ = all (not . isInBinTree c . jments) m0s
let js2 = filterBinTree notInM0 js'
return $ (replaceJudgements m js2)
return $ (replaceJudgements mi js2)
{positions =
buildTree (tree2list (positions m1) ++
tree2list (positions m))}
-- checkCompleteInstance m1 m'
return m'
tree2list (positions mi))}
_ -> return mi
-- add the instance opens to an incomplete module "with" instances
ModInfo mt stat fs_ me (Just (ext,incl,ops)) ops_ js_ ps_ -> do
let insts = [(inf,inst) | OQualif inf inst <- ops]
let infs = map fst insts
Just (ext,incl,ops) -> do
let (infs,insts) = unzip ops
let stat' = ifNull MSComplete (const MSIncomplete)
[i | i <- is, notElem i infs]
testErr (stat' == MSComplete || stat == MSIncomplete)
("module" +++ prt i +++ "remains incomplete")
ModInfo mt0 _ fs me' _ ops0 js ps0 <- lookupModule gr ext
ModInfo mt0 _ fs me' _ ops0 _ js ps0 <- lookupModule gr ext
let ops1 = nub $
ops_ ++ -- N.B. js has been name-resolved already
ops ++ [o | o <- ops0, notElem (openedModule o) infs]
++ [OQualif i i | i <- map snd insts] ----
++ [OSimple i | i <- map snd insts] ----
[OQualif i j | (i,j) <- ops] ++
[o | o <- ops0, notElem (openedModule o) infs] ++
[OQualif i i | i <- insts] ++
[OSimple i | i <- insts]
--- check if me is incomplete
let fs1 = fs `addOptions` fs_ -- new flags have priority
let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c]
let js1 = buildTree (tree2list js_ ++ js0)
let ps1 = buildTree (tree2list ps_ ++ tree2list ps0)
return $ ModInfo mt0 stat' fs1 me Nothing ops1 js1 ps1
let med1= nub (ext : infs ++ insts ++ med_)
return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 js1 ps1
_ -> return mi
return (i,mi')
checkCompleteInstance :: SourceModInfo -> SourceModInfo -> Err ()

10
src/GF/Grammar/Binary.hs
View File

@@ -31,9 +31,9 @@ instance (Ord i, Binary i, Binary a) => Binary (MGrammar i a) where
get = fmap MGrammar get
instance (Ord i, Binary i, Binary a) => Binary (ModInfo i a) where
put mi = do put (mtype mi,mstatus mi,flags mi,extend mi,mwith mi,opens mi,jments mi,positions mi)
get = do (mtype,mstatus,flags,extend,mwith,opens,jments,positions) <- get
return (ModInfo mtype mstatus flags extend mwith opens jments positions)
put mi = do put (mtype mi,mstatus mi,flags mi,extend mi,mwith mi,opens mi,mexdeps mi,jments mi,positions mi)
get = do (mtype,mstatus,flags,extend,mwith,opens,med,jments,positions) <- get
return (ModInfo mtype mstatus flags extend mwith opens med jments positions)
instance (Binary i) => Binary (ModuleType i) where
put MTAbstract = putWord8 0
@@ -264,5 +264,5 @@ instance Binary MetaSymb where
decodeModHeader :: FilePath -> IO SourceModule
decodeModHeader fpath = do
(m,mtype,mstatus,flags,extend,mwith,opens) <- decodeFile fpath
return (m,ModInfo mtype mstatus flags extend mwith opens Map.empty Map.empty)
(m,mtype,mstatus,flags,extend,mwith,opens,med) <- decodeFile fpath
return (m,ModInfo mtype mstatus flags extend mwith opens med Map.empty Map.empty)

6
src/GF/Grammar/Printer.hs
View File

@@ -25,7 +25,7 @@ import Data.Maybe (maybe)
import Data.List (intersperse)
ppModule :: SourceModule -> Doc
ppModule (mn, ModInfo mtype mstat opts exts with opens jments _) =
ppModule (mn, ModInfo mtype mstat opts exts with opens _ jments _) =
(let defs = tree2list jments
in if null defs
then hdr
@@ -58,7 +58,7 @@ ppModule (mn, ModInfo mtype mstat opts exts with opens jments _) =
ppExtends (id,MIOnly incs) = ppIdent id <+> brackets (commaPunct ppIdent incs)
ppExtends (id,MIExcept incs) = ppIdent id <+> char '-' <+> brackets (commaPunct ppIdent incs)
ppWith (id,ext,opens) = ppExtends (id,ext) <+> text "with" <+> commaPunct ppOpenSpec opens
ppWith (id,ext,opens) = ppExtends (id,ext) <+> text "with" <+> commaPunct ppInstSpec opens
ppOptions opts =
text "flags" $$
@@ -210,6 +210,8 @@ ppLabel = ppIdent . label2ident
ppOpenSpec (OSimple id) = ppIdent id
ppOpenSpec (OQualif id n) = parens (ppIdent id <+> equals <+> ppIdent n)
ppInstSpec (id,n) = parens (ppIdent id <+> equals <+> ppIdent n)
ppLocDef (id, (mbt, e)) =
ppIdent id <+>
(case mbt of {Just t -> colon <+> ppTerm 0 t; Nothing -> empty} <+> equals <+> ppTerm 0 e) <+> semi

15
src/GF/Infra/Modules.hs
View File

@@ -61,14 +61,13 @@ data ModInfo i a = ModInfo {
mstatus :: ModuleStatus ,
flags :: Options,
extend :: [(i,MInclude i)],
mwith :: Maybe (i,MInclude i,[OpenSpec i]),
mwith :: Maybe (i,MInclude i,[(i,i)]),
opens :: [OpenSpec i] ,
mexdeps :: [i] ,
jments :: BinTree i a ,
positions :: BinTree i (String,(Int,Int)) -- file, first line, last line
}
--- deriving Show
instance Show (ModInfo i a) where
show _ = "cannot show ModInfo with FiniteMap"
deriving Show
-- | encoding the type of the module
data ModuleType i =
@@ -107,13 +106,13 @@ updateMGrammar old new = MGrammar $
ns = modules new
updateModule :: Ord i => ModInfo i t -> i -> t -> ModInfo i t
updateModule (ModInfo mt ms fs me mw ops js ps) i t = ModInfo mt ms fs me mw ops (updateTree (i,t) js) ps
updateModule (ModInfo mt ms fs me mw ops med js ps) i t = ModInfo mt ms fs me mw ops med (updateTree (i,t) js) ps
replaceJudgements :: ModInfo i t -> BinTree i t -> ModInfo i t
replaceJudgements (ModInfo mt ms fs me mw ops _ ps) js = ModInfo mt ms fs me mw ops js ps
replaceJudgements (ModInfo mt ms fs me mw ops med _ ps) js = ModInfo mt ms fs me mw ops med js ps
addOpenQualif :: i -> i -> ModInfo i t -> ModInfo i t
addOpenQualif i j (ModInfo mt ms fs me mw ops js ps) = ModInfo mt ms fs me mw (OQualif i j : ops) js ps
addOpenQualif i j (ModInfo mt ms fs me mw ops med js ps) = ModInfo mt ms fs me mw (OQualif i j : ops) med js ps
addFlag :: Options -> ModInfo i t -> ModInfo i t
addFlag f mo = mo {flags = flags mo `addOptions` f}
@@ -225,7 +224,7 @@ emptyMGrammar :: MGrammar i a
emptyMGrammar = MGrammar []
emptyModInfo :: ModInfo i a
emptyModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] emptyBinTree emptyBinTree
emptyModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] emptyBinTree emptyBinTree
-- | we store the module type with the identifier
data IdentM i = IdentM {

11
src/GF/Source/SourceToGrammar.hs
View File

@@ -110,7 +110,7 @@ transModDef x = case x of
defs' <- U.buildAnyTree [(i,d) | Left ds <- defs0, (i,_,d) <- ds]
flags' <- return $ concatOptions [o | Right o <- defs0]
let poss1 = buildPosTree id' poss0
return (id', GM.ModInfo mtyp' mstat' flags' extends' Nothing opens' defs' poss1)
return (id', GM.ModInfo mtyp' mstat' flags' extends' Nothing opens' [] defs' poss1)
MWith m insts -> mkBody xx $ MWithEBody [] m insts NoOpens []
MWithBody m insts opens defs -> mkBody xx $ MWithEBody [] m insts opens defs
@@ -118,14 +118,14 @@ transModDef x = case x of
MWithEBody extends m insts opens defs -> do
extends' <- mapM transIncludedExt extends
m' <- transIncludedExt m
insts' <- mapM transOpen insts
insts' <- mapM transInst insts
opens' <- transOpens opens
defs0 <- mapM trDef $ getTopDefs defs
poss0 <- return [(i,p) | Left ds <- defs0, (i,p,_) <- ds]
defs' <- U.buildAnyTree [(i,d) | Left ds <- defs0, (i,_,d) <- ds]
flags' <- return $ concatOptions [o | Right o <- defs0]
let poss1 = buildPosTree id' poss0
return (id', GM.ModInfo mtyp' mstat' flags' extends' (Just (fst m',snd m',insts')) opens' defs' poss1)
return (id', GM.ModInfo mtyp' mstat' flags' extends' (Just (fst m',snd m',insts')) opens' [] defs' poss1)
mkModRes id mtyp body = do
id' <- transIdent id
@@ -178,6 +178,11 @@ transOpen x = case x of
OQualQO q id -> liftM GM.OSimple (transIdent id)
OQual q id m -> liftM2 GM.OQualif (transIdent id) (transIdent m)
transInst :: Open -> Err (Ident,Ident)
transInst x = case x of
OQual q id m -> liftM2 (,) (transIdent id) (transIdent m)
_ -> Bad "qualified open expected"
transIncluded :: Included -> Err (Ident,[Ident])
transIncluded x = case x of
IAll i -> liftM (flip (curry id) []) $ transIdent i