GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

fix the generation of warnings in CheckGrammar. They are printed even in quiet mode and the prefix "Warning" is added automatically

Browse Source
This commit is contained in:
krasimir
2009-05-20 17:05:58 +00:00
parent 880665ad0f
commit 6de94f5300
5 changed files with 20 additions and 15 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
src/GF/Compile.hs
View File

@@ -194,7 +194,7 @@ compileOne opts env@(_,srcgr,_) file = do
compileSourceModule :: Options -> CompileEnv -> SourceModule -> IOE (Int,SourceModule)
compileSourceModule opts env@(k,gr,_) mo@(i,mi) = do
let putp = putPointE Normal opts
let puts = putPointE Quiet opts
putpp = putPointE Verbose opts
mo1 <- ioeErr $ rebuildModule gr mo
@@ -213,7 +213,7 @@ compileSourceModule opts env@(k,gr,_) mo@(i,mi) = do
intermOut opts DumpRename (ppModule Qualified mo2)
(mo3:_,warnings) <- putpp " type checking" $ ioeErr $ showCheckModule mos mo2
if null warnings then return () else putp warnings $ return ()
if null warnings then return () else puts warnings $ return ()
intermOut opts DumpTypeCheck (ppModule Qualified mo3)
(k',mo3r:_) <- putpp " refreshing " $ ioeErr $ refreshModule (k,mos) mo3

22
src/GF/Compile/CheckGrammar.hs
View File

@@ -182,7 +182,7 @@ checkCompleteGrammar gr abs cnc = do
-- remove those lincat and lin in concrete that are not in abstract
let unkn = filter (not . flip isInBinTree jsa) fsc
jsc1 <- if (null unkn) then return jsc else do
checkWarn $ "WARNING: ignoring constants not in abstract:" +++
checkWarn $ "ignoring constants not in abstract:" +++
unwords (map prt unkn)
return $ filterBinTree (\f _ -> notElem f unkn) jsc
@@ -209,24 +209,24 @@ checkCompleteGrammar gr abs cnc = do
Ok (CncFun cty Nothing pn) ->
case mb_def of
Ok def -> return $ updateTree (c,CncFun cty (Just def) pn) js
Bad _ -> do checkWarn $ "WARNING: no linearization of" +++ prt c
Bad _ -> do checkWarn $ "no linearization of" +++ prt c
return js
_ -> do
case mb_def of
Ok def -> return $ updateTree (c,CncFun Nothing (Just def) Nothing) js
Bad _ -> do checkWarn $ "WARNING: no linearization of" +++ prt c
Bad _ -> do checkWarn $ "no linearization of" +++ prt c
return js
AbsCat (Just _) _ -> case lookupIdent c js of
Ok (AnyInd _ _) -> return js
Ok (CncCat (Just _) _ _) -> return js
Ok (CncCat _ mt mp) -> do
checkWarn $
"Warning: no linearization type for" +++ prt c ++
"no linearization type for" +++ prt c ++
", inserting default {s : Str}"
return $ updateTree (c,CncCat (Just defLinType) mt mp) js
_ -> do
checkWarn $
"Warning: no linearization type for" +++ prt c ++
"no linearization type for" +++ prt c ++
", inserting default {s : Str}"
return $ updateTree (c,CncCat (Just defLinType) Nothing Nothing) js
_ -> return js
@@ -421,7 +421,7 @@ checkPrintname _ _ = return ()
-- | for grammars obtained otherwise than by parsing ---- update!!
checkReservedId :: Ident -> Check ()
checkReservedId x
| isReservedWord (ident2bs x) = checkWarn ("Warning: reserved word used as identifier:" +++ prt x)
| isReservedWord (ident2bs x) = checkWarn ("reserved word used as identifier:" +++ prt x)
| otherwise = return ()
-- to normalize records and record types
@@ -532,7 +532,7 @@ inferLType gr trm = case trm of
then do
let ss = foldr C Empty (map K (words s))
----- removed irritating warning AR 24/5/2008
----- checkWarn ("WARNING: token \"" ++ s ++
----- checkWarn ("token \"" ++ s ++
----- "\" converted to token list" ++ prt ss)
return (ss, typeStr)
else return (trm, typeStr)
@@ -552,7 +552,7 @@ inferLType gr trm = case trm of
---- hack from Rename.identRenameTerm, to live with files with naming conflicts 18/6/2007
Strs (Cn c : ts) | c == cConflict -> do
trace ("WARNING: unresolved constant, could be any of" +++ unwords (map prt ts)) (infer $ head ts)
-- checkWarn ("WARNING: unresolved constant, could be any of" +++ unwords (map prt ts))
-- checkWarn ("unresolved constant, could be any of" +++ unwords (map prt ts))
-- infer $ head ts
Strs ts -> do
@@ -714,7 +714,7 @@ getOverload env@gr mt ot = case appForm ot of
return (mkApp fun tts, val)
----- unsafely exclude irritating warning AR 24/5/2008
----- checkWarn $ "WARNING: overloading of" +++ prt f +++
----- checkWarn $ "overloading of" +++ prt f +++
----- "resolved by excluding partial applications:" ++++
----- unlines [prtType env ty | (ty,_) <- vfs', not (noProd ty)]
@@ -791,7 +791,7 @@ checkLType env trm typ0 = do
ps <- checkErr $ testOvershadow ps0 vs
if null ps
then return ()
---- else checkWarn $ "WARNING: patterns never reached:" +++
---- else checkWarn $ "patterns never reached:" +++
---- concat (intersperse ", " (map prt ps))
else trace ("WARNING: patterns never reached:" +++
concat (intersperse ", " (map prt ps))) (return ())
@@ -1002,7 +1002,7 @@ checkIfEqLType env t u trm = do
--- better: use a flag to forgive? (AR 31/1/2006)
_ -> case missingLock [] t' u' of
Ok lo -> do
checkWarn $ "WARNING: missing lock field" +++ unwords (map prt lo)
checkWarn $ "missing lock field" +++ unwords (map prt lo)
return (True,t',u',[])
Bad s -> return (False,t',u',s)

2
src/GF/Infra/CheckM.hs
View File

@@ -35,7 +35,7 @@ checkCond s b = if b then return () else checkError s
-- | warnings should be reversed in the end
checkWarn :: String -> Check ()
checkWarn s = updateSTM (\ (cont,msg) -> (cont, s:msg))
checkWarn s = updateSTM (\ (cont,msg) -> (cont, ("Warning: "++s):msg))
checkUpdate :: Decl -> Check ()
checkUpdate d = updateSTM (\ (cont,msg) -> (d:cont, msg))

2
testsuite/check/lins/lins.gfs
View File

@@ -1,2 +1,2 @@
i -erasing=on testsuite\check\lins\linsCnc.gf
i -src -erasing=on testsuite\check\lins\linsCnc.gf
pg -printer=pmcfg_pretty

5
testsuite/check/lins/lins.gfs.gold
View File

@@ -1,3 +1,8 @@
checking module linsCnc
Warning: no linearization type for C, inserting default {s : Str}
checking module linsCnc
Warning: no linearization of test