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

Now the errors messages from GF.Compile.Update also follow the new format

Browse Source
This commit is contained in:
kr.angelov
2011-11-15 15:33:52 +00:00
parent ebac9525f0
commit 0163942df9
2 changed files with 37 additions and 29 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -150,7 +150,8 @@ compileOne opts env@(_,srcgr,_) file = do
intermOut opts DumpSource (ppModule Qualified sm0) intermOut opts DumpSource (ppModule Qualified sm0)
let sm1 = unsubexpModule sm0 let sm1 = unsubexpModule sm0
sm <- {- putPointE Normal opts "creating indirections" $ -} ioeErr $ extendModule srcgr sm1 (sm,warnings) <- {- putPointE Normal opts "creating indirections" $ -} ioeErr $ runCheck $ extendModule srcgr sm1
warnOut opts warnings
if flag optTagsOnly opts if flag optTagsOnly opts
then writeTags opts srcgr (gf2gftags opts file) sm1 then writeTags opts srcgr (gf2gftags opts file) sm1
@@ -182,10 +183,12 @@ compileSourceModule opts env@(k,gr,_) mb_gfFile mo@(i,mi) = do
let putpp = putPointE Verbose opts let putpp = putPointE Verbose opts
mo1 <- ioeErr $ rebuildModule gr mo (mo1,warnings) <- ioeErr $ runCheck $ rebuildModule gr mo
warnOut opts warnings
intermOut opts DumpRebuild (ppModule Qualified mo1) intermOut opts DumpRebuild (ppModule Qualified mo1)
mo1b <- ioeErr $ extendModule gr mo1 (mo1b,warnings) <- ioeErr $ runCheck $ extendModule gr mo1
warnOut opts warnings
intermOut opts DumpExtend (ppModule Qualified mo1b) intermOut opts DumpExtend (ppModule Qualified mo1b)
case mo1b of case mo1b of

57
src/compiler/GF/Compile/Update.hs
View File

@@ -15,10 +15,11 @@
module GF.Compile.Update (buildAnyTree, extendModule, rebuildModule) where module GF.Compile.Update (buildAnyTree, extendModule, rebuildModule) where
import GF.Infra.Ident import GF.Infra.Ident
import GF.Infra.Option
import GF.Infra.CheckM
import GF.Grammar.Grammar import GF.Grammar.Grammar
import GF.Grammar.Printer import GF.Grammar.Printer
import GF.Grammar.Lookup import GF.Grammar.Lookup
import GF.Infra.Option
import GF.Data.Operations import GF.Data.Operations
@@ -43,21 +44,22 @@ buildAnyTree m = go Map.empty
text "in module" <+> ppIdent m) text "in module" <+> ppIdent m)
Nothing -> go (Map.insert c j map) is Nothing -> go (Map.insert c j map) is
extendModule :: SourceGrammar -> SourceModule -> Err SourceModule extendModule :: SourceGrammar -> SourceModule -> Check SourceModule
extendModule gr (name,m) extendModule gr (name,m)
---- Just to allow inheritance in incomplete concrete (which are not ---- Just to allow inheritance in incomplete concrete (which are not
---- compiled anyway), extensions are not built for them. ---- compiled anyway), extensions are not built for them.
---- Should be replaced by real control. AR 4/2/2005 ---- Should be replaced by real control. AR 4/2/2005
| mstatus m == MSIncomplete && isModCnc m = return (name,m) | mstatus m == MSIncomplete && isModCnc m = return (name,m)
| otherwise = do m' <- foldM extOne m (mextend m) | otherwise = checkIn (ppLocation (msrc m) NoLoc <> colon) $ do
m' <- foldM extOne m (mextend m)
return (name,m') return (name,m')
where where
extOne mo (n,cond) = do extOne mo (n,cond) = do
m0 <- lookupModule gr n m0 <- checkErr $ lookupModule gr n
-- test that the module types match, and find out if the old is complete -- test that the module types match, and find out if the old is complete
testErr (sameMType (mtype m) (mtype mo)) unless (sameMType (mtype m) (mtype mo))
("illegal extension type to module" +++ showIdent name) (checkError (text "illegal extension type to module" <+> ppIdent name))
let isCompl = isCompleteModule m0 let isCompl = isCompleteModule m0
@@ -75,8 +77,10 @@ extendModule gr (name,m)
-- | rebuilding instance + interface, and "with" modules, prior to renaming. -- | rebuilding instance + interface, and "with" modules, prior to renaming.
-- AR 24/10/2003 -- AR 24/10/2003
rebuildModule :: SourceGrammar -> SourceModule -> Err SourceModule rebuildModule :: SourceGrammar -> SourceModule -> Check SourceModule
rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ src_ env_ js_)) = do rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js_)) =
checkIn (ppLocation msrc_ NoLoc <> colon) $ do
---- deps <- moduleDeps ms ---- deps <- moduleDeps ms
---- is <- openInterfaces deps i ---- is <- openInterfaces deps i
let is = [] ---- the method above is buggy: try "i -src" for two grs. AR 8/3/2005 let is = [] ---- the method above is buggy: try "i -src" for two grs. AR 8/3/2005
@@ -84,19 +88,20 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ src_ env_ js_)) =
-- add the information given in interface into an instance module -- add the information given in interface into an instance module
Nothing -> do Nothing -> do
testErr (null is || mstatus mi == MSIncomplete) unless (null is || mstatus mi == MSIncomplete)
("module" +++ showIdent i +++ (checkError (text "module" <+> ppIdent i <+>
"has open interfaces and must therefore be declared incomplete") text "has open interfaces and must therefore be declared incomplete"))
case mt of case mt of
MTInstance (i0,mincl) -> do MTInstance (i0,mincl) -> do
m1 <- lookupModule gr i0 m1 <- checkErr $ lookupModule gr i0
testErr (isModRes m1) ("interface expected instead of" +++ showIdent i0) unless (isModRes m1)
(checkError (text "interface expected instead of" <+> ppIdent i0))
js' <- extendMod gr False ((i0,m1), isInherited mincl) i (jments mi) js' <- extendMod gr False ((i0,m1), isInherited mincl) i (jments mi)
--- to avoid double inclusions, in instance I of I0 = J0 ** ... --- to avoid double inclusions, in instance I of I0 = J0 ** ...
case extends mi of case extends mi of
[] -> return mi{jments=js'} [] -> return mi{jments=js'}
j0s -> do j0s -> do
m0s <- mapM (lookupModule gr) j0s m0s <- checkErr $ mapM (lookupModule gr) j0s
let notInM0 c _ = all (not . isInBinTree c . jments) m0s let notInM0 c _ = all (not . isInBinTree c . jments) m0s
let js2 = filterBinTree notInM0 js' let js2 = filterBinTree notInM0 js'
return mi{jments=js2} return mi{jments=js2}
@@ -107,9 +112,9 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ src_ env_ js_)) =
let (infs,insts) = unzip ops let (infs,insts) = unzip ops
let stat' = ifNull MSComplete (const MSIncomplete) let stat' = ifNull MSComplete (const MSIncomplete)
[i | i <- is, notElem i infs] [i | i <- is, notElem i infs]
testErr (stat' == MSComplete || stat == MSIncomplete) unless (stat' == MSComplete || stat == MSIncomplete)
("module" +++ showIdent i +++ "remains incomplete") (checkError (text "module" <+> ppIdent i <+> text "remains incomplete"))
ModInfo mt0 _ fs me' _ ops0 _ _ _ js <- lookupModule gr ext ModInfo mt0 _ fs me' _ ops0 _ _ _ js <- checkErr $ lookupModule gr ext
let ops1 = nub $ let ops1 = nub $
ops_ ++ -- N.B. js has been name-resolved already ops_ ++ -- N.B. js has been name-resolved already
[OQualif i j | (i,j) <- ops] ++ [OQualif i j | (i,j) <- ops] ++
@@ -122,7 +127,7 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ src_ env_ js_)) =
let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c] let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c]
let js1 = buildTree (tree2list js_ ++ js0) let js1 = buildTree (tree2list js_ ++ js0)
let med1= nub (ext : infs ++ insts ++ med_) let med1= nub (ext : infs ++ insts ++ med_)
return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 src_ env_ js1 return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 msrc_ env_ js1
return (i,mi') return (i,mi')
@@ -131,7 +136,7 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ src_ env_ js_)) =
-- If the extended module is incomplete, its judgements are just copied. -- If the extended module is incomplete, its judgements are just copied.
extendMod :: SourceGrammar -> extendMod :: SourceGrammar ->
Bool -> (SourceModule,Ident -> Bool) -> Ident -> Bool -> (SourceModule,Ident -> Bool) -> Ident ->
BinTree Ident Info -> Err (BinTree Ident Info) BinTree Ident Info -> Check (BinTree Ident Info)
extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi) extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi)
where where
try new (c,i0) try new (c,i0)
@@ -140,16 +145,16 @@ extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jme
Just j -> case unifyAnyInfo name i j of Just j -> case unifyAnyInfo name i j of
Ok k -> return $ updateTree (c,k) new Ok k -> return $ updateTree (c,k) new
Bad _ -> do (base,j) <- case j of Bad _ -> do (base,j) <- case j of
AnyInd _ m -> lookupOrigInfo gr (m,c) AnyInd _ m -> checkErr $ lookupOrigInfo gr (m,c)
_ -> return (base,j) _ -> return (base,j)
(name,i) <- case i of (name,i) <- case i of
AnyInd _ m -> lookupOrigInfo gr (m,c) AnyInd _ m -> checkErr $ lookupOrigInfo gr (m,c)
_ -> return (name,i) _ -> return (name,i)
fail $ render (text "cannot unify the information" $$ checkError (text "cannot unify the information" $$
nest 4 (ppJudgement Qualified (c,i)) $$ nest 4 (ppJudgement Qualified (c,i)) $$
text "in module" <+> ppIdent name <+> text "with" $$ text "in module" <+> ppIdent name <+> text "with" $$
nest 4 (ppJudgement Qualified (c,j)) $$ nest 4 (ppJudgement Qualified (c,j)) $$
text "in module" <+> ppIdent base) text "in module" <+> ppIdent base)
Nothing-> if isCompl Nothing-> if isCompl
then return $ updateTree (c,indirInfo name i) new then return $ updateTree (c,indirInfo name i) new
else return $ updateTree (c,i) new else return $ updateTree (c,i) new