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

more structured format for errors and warnings from the compiler

Browse Source
This commit is contained in:
kr.angelov
2011-11-15 13:33:44 +00:00
parent 9b482722c3
commit 48558197a8
8 changed files with 110 additions and 105 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/compiler/GF.hs
View File

@@ -46,4 +46,4 @@ mainOpts opts files =
ModeInteractive -> mainGFI opts files
ModeRun -> mainRunGFI opts files
ModeServer -> mainServerGFI opts files
ModeCompiler -> dieIOE (mainGFC opts files)
ModeCompiler -> mainGFC opts files

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

@@ -82,6 +82,13 @@ intermOut opts d doc
| dump opts d = ioeIO (hPutStrLn stderr (render (text "\n\n--#" <+> text (show d) $$ doc)))
| otherwise = return ()
warnOut opts warnings
| null warnings = return ()
| otherwise = ioeIO (hPutStrLn stderr $
if flag optVerbosity opts == Normal
then ('\n':warnings)
else warnings)
-- | the environment
type CompileEnv = (Int,SourceGrammar,ModEnv)
@@ -173,8 +180,7 @@ compileOne opts env@(_,srcgr,_) file = do
compileSourceModule :: Options -> CompileEnv -> Maybe FilePath -> SourceModule -> IOE CompileEnv
compileSourceModule opts env@(k,gr,_) mb_gfFile mo@(i,mi) = do
let puts = putPointE Quiet opts
putpp = putPointE Verbose opts
let putpp = putPointE Verbose opts
mo1 <- ioeErr $ rebuildModule gr mo
intermOut opts DumpRebuild (ppModule Qualified mo1)
@@ -198,11 +204,11 @@ compileSourceModule opts env@(k,gr,_) mb_gfFile mo@(i,mi) = do
let mos = modules gr
(mo2,warnings) <- putpp " renaming " $ ioeErr $ runCheck (renameModule mos mo1b)
if null warnings then return () else puts warnings $ return ()
warnOut opts warnings
intermOut opts DumpRename (ppModule Qualified mo2)
(mo3,warnings) <- putpp " type checking" $ ioeErr $ runCheck (checkModule mos mo2)
if null warnings then return () else puts warnings $ return ()
warnOut opts warnings
intermOut opts DumpTypeCheck (ppModule Qualified mo3)
if not (flag optTagsOnly opts)

56
src/compiler/GF/Compile/CheckGrammar.hs
View File

@@ -43,26 +43,26 @@ import Text.PrettyPrint
-- | checking is performed in the dependency order of modules
checkModule :: [SourceModule] -> SourceModule -> Check SourceModule
checkModule ms m@(name,mo) = checkIn (text "checking module" <+> ppIdent name) $ do
checkRestrictedInheritance ms m
m <- case mtype mo of
MTConcrete a -> do let gr = mGrammar (m:ms)
abs <- checkErr $ lookupModule gr a
checkCompleteGrammar gr (a,abs) m
_ -> return m
infos <- checkErr $ topoSortJments m
foldM updateCheckInfo m infos
checkModule mos mo@(m,mi) = do
checkRestrictedInheritance mos mo
mo <- case mtype mi of
MTConcrete a -> do let gr = mGrammar (mo:mos)
abs <- checkErr $ lookupModule gr a
checkCompleteGrammar gr (a,abs) mo
_ -> return mo
infos <- checkErr $ topoSortJments mo
foldM updateCheckInfo mo infos
where
updateCheckInfo (name,mo) (i,info) = do
info <- checkInfo ms (name,mo) i info
return (name,mo{jments=updateTree (i,info) (jments mo)})
updateCheckInfo mo@(m,mi) (i,info) = do
info <- checkInfo mos mo i info
return (m,mi{jments=updateTree (i,info) (jments mi)})
-- check if restricted inheritance modules are still coherent
-- i.e. that the defs of remaining names don't depend on omitted names
checkRestrictedInheritance :: [SourceModule] -> SourceModule -> Check ()
checkRestrictedInheritance mos (name,mo) = do
checkRestrictedInheritance mos (name,mo) = checkIn (ppLocation (msrc mo) NoLoc <> colon) $ do
let irs = [ii | ii@(_,mi) <- mextend mo, mi /= MIAll] -- names with restr. inh.
let mrs = [((i,m),mi) | (i,m) <- mos, Just mi <- [lookup i irs]]
let mrs = [((i,m),mi) | (i,m) <- mos, Just mi <- [lookup i irs]]
-- the restr. modules themself, with restr. infos
mapM_ checkRem mrs
where
@@ -79,7 +79,7 @@ checkRestrictedInheritance mos (name,mo) = do
allDeps = concatMap (allDependencies (const True) . jments . snd) mos
checkCompleteGrammar :: SourceGrammar -> SourceModule -> SourceModule -> Check SourceModule
checkCompleteGrammar gr (am,abs) (cm,cnc) = do
checkCompleteGrammar gr (am,abs) (cm,cnc) = checkIn (ppLocation (msrc cnc) NoLoc <> colon) $ do
let jsa = jments abs
let jsc = jments cnc
@@ -112,25 +112,23 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do
Ok (CncFun ty Nothing mn mf) ->
case mb_def of
Ok def -> return $ updateTree (c,CncFun ty (Just (L NoLoc def)) mn mf) js
Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c
Bad _ -> do checkWarn (text "no linearization of" <+> ppIdent c)
return js
_ -> do
case mb_def of
Ok def -> do (cont,val) <- linTypeOfType gr cm ty
let linty = (snd (valCat ty),cont,val)
return $ updateTree (c,CncFun (Just linty) (Just (L NoLoc def)) Nothing Nothing) js
Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c
Bad _ -> do checkWarn (text "no linearization of" <+> ppIdent c)
return js
AbsCat (Just _) -> case lookupIdent c js of
Ok (AnyInd _ _) -> return js
Ok (CncCat (Just _) _ _ _) -> return js
Ok (CncCat _ mt mp mpmcfg) -> do
checkWarn $
text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}"
Ok (CncCat Nothing mt mp mpmcfg) -> do
checkWarn (text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}")
return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) mt mp mpmcfg) js
_ -> do
checkWarn $
text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}"
checkWarn (text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}")
return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) Nothing Nothing Nothing) js
_ -> return js
@@ -141,11 +139,11 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do
do (cont,val) <- linTypeOfType gr cm ty
let linty = (snd (valCat ty),cont,val)
return $ updateTree (c,CncFun (Just linty) d mn mf) js
_ -> do checkWarn $ text "function" <+> ppIdent c <+> text "is not in abstract"
_ -> do checkWarn (text "function" <+> ppIdent c <+> text "is not in abstract")
return js
CncCat _ _ _ _ -> case lookupOrigInfo gr (am,c) of
Ok _ -> return $ updateTree i js
_ -> do checkWarn $ text "category" <+> ppIdent c <+> text "is not in abstract"
_ -> do checkWarn (text "category" <+> ppIdent c <+> text "is not in abstract")
return js
_ -> return $ updateTree i js
@@ -154,7 +152,8 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do
-- A May-value has always been checked in its origin module.
checkInfo :: [SourceModule] -> SourceModule -> Ident -> Info -> Check Info
checkInfo ms (m,mo) c info = do
checkReservedId c
checkIn (ppLocation (msrc mo) NoLoc <> colon) $
checkReservedId c
case info of
AbsCat (Just (L loc cont)) ->
mkCheck loc "the category" $
@@ -242,7 +241,8 @@ checkInfo ms (m,mo) c info = do
_ -> return info
where
gr = mGrammar ((m,mo) : ms)
chIn loc cat = checkIn (ppLocation (msrc mo) loc <> colon $$ text "Happened in" <+> text cat <+> ppIdent c)
chIn loc cat = checkIn (ppLocation (msrc mo) loc <> colon $$
nest 2 (text "Happened in" <+> text cat <+> ppIdent c))
mkPar (f,co) = do
vs <- checkErr $ liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co
@@ -257,7 +257,9 @@ checkInfo ms (m,mo) c info = do
mkCheck loc cat ss = case ss of
[] -> return info
_ -> checkError (ppLocation (msrc mo) loc <> colon $$ text "Happened in" <+> text cat <+> ppIdent c $$ nest 3 (vcat ss))
_ -> checkError (ppLocation (msrc mo) loc <> colon $$
nest 2 (text "Happened in" <+> text cat <+> ppIdent c $$
nest 2 (vcat ss)))
compAbsTyp g t = case t of
Vr x -> maybe (checkError (text "no value given to variable" <+> ppIdent x)) return $ lookup x g

2
src/compiler/GF/Compile/GetGrammar.hs
View File

@@ -38,7 +38,7 @@ getSourceModule opts file0 = ioe $
case runP pModDef content of
Left (Pn l c,msg) -> do file <- writeTemp tmp
let location = file++":"++show l++":"++show c
return (Bad (location++": "++msg))
return (Bad (location++":\n "++msg))
Right (i,mi) -> do removeTemp tmp
return (Ok (i,mi{mflags=mflags mi `addOptions` opts, msrc=file0}))
`catch` (return . Bad . show)

112
src/compiler/GF/Compile/Rename.hs
View File

@@ -24,7 +24,6 @@
module GF.Compile.Rename (
renameSourceTerm,
renameSourceJudgement,
renameModule
) where
@@ -47,20 +46,12 @@ import Text.PrettyPrint
renameSourceTerm :: SourceGrammar -> Ident -> Term -> Check Term
renameSourceTerm g m t = do
mi <- checkErr $ lookupModule g m
status <- buildStatus g m mi
status <- buildStatus g (m,mi)
renameTerm status [] t
-- | this gives top-level access to renaming term input in the cj command
renameSourceJudgement :: SourceGrammar -> Ident -> (Ident,Info) -> Check (Ident,Info)
renameSourceJudgement g m (i,t) = do
mi <- checkErr $ lookupModule g m
status <- buildStatus g m mi
t2 <- renameInfo status (m,mi) i t
return (i,t2)
renameModule :: [SourceModule] -> SourceModule -> Check SourceModule
renameModule ms mo@(m,mi) = checkIn (text "renaming module" <+> ppIdent m) $ do
status <- buildStatus (mGrammar ms) m mi
renameModule ms mo@(m,mi) = do
status <- buildStatus (mGrammar ms) mo
js <- checkMap (renameInfo status mo) (jments mi)
return (m, mi{jments = js})
@@ -71,42 +62,45 @@ type StatusTree = BinTree Ident StatusInfo
type StatusInfo = Ident -> Term
renameIdentTerm :: Status -> Term -> Check Term
renameIdentTerm env@(act,imps) t =
checkIn (text "atomic term" <+> ppTerm Qualified 0 t $$ text "given" <+> hsep (punctuate comma (map (ppIdent . fst) qualifs))) $
case t of
Vr c -> ident predefAbs c
Cn c -> ident (\_ s -> checkError s) c
Q (m',c) | m' == cPredef {- && isInPredefined c -} -> return t
Q (m',c) -> do
m <- checkErr (lookupErr m' qualifs)
f <- lookupTree showIdent c m
return $ f c
QC (m',c) | m' == cPredef {- && isInPredefined c -} -> return t
QC (m',c) -> do
m <- checkErr (lookupErr m' qualifs)
f <- lookupTree showIdent c m
return $ f c
_ -> return t
where
opens = [st | (OSimple _,st) <- imps]
qualifs = [(m, st) | (OQualif m _, st) <- imps] ++
[(m, st) | (OQualif _ m, st) <- imps] ++
[(m, st) | (OSimple m, st) <- imps] -- qualif is always possible
renameIdentTerm env@(act,imps) t0 =
case t0 of
Vr c -> ident predefAbs c
Cn c -> ident (\_ s -> checkError s) c
Q (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0
Q (m',c) -> do
m <- checkErr (lookupErr m' qualifs)
f <- lookupTree showIdent c m
return $ f c
QC (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0
QC (m',c) -> do
m <- checkErr (lookupErr m' qualifs)
f <- lookupTree showIdent c m
return $ f c
_ -> return t0
where
opens = [st | (OSimple _,st) <- imps]
qualifs = [(m, st) | (OQualif m _, st) <- imps] ++
[(m, st) | (OQualif _ m, st) <- imps] ++
[(m, st) | (OSimple m, st) <- imps] -- qualif is always possible
-- this facility is mainly for BWC with GF1: you need not import PredefAbs
predefAbs c s
| isPredefCat c = return $ Q (cPredefAbs,c)
| otherwise = checkError s
-- this facility is mainly for BWC with GF1: you need not import PredefAbs
predefAbs c s
| isPredefCat c = return (Q (cPredefAbs,c))
| otherwise = checkError s
ident alt c = case lookupTree showIdent c act of
Ok f -> return $ f c
_ -> case lookupTreeManyAll showIdent opens c of
[f] -> return $ f c
[] -> alt c (text "constant not found:" <+> ppIdent c)
fs -> case nub [f c | f <- fs] of
[tr] -> return tr
ts@(t:_) -> do checkWarn (text "conflict" <+> hsep (punctuate comma (map (ppTerm Qualified 0) ts)))
return t
ident alt c =
case lookupTree showIdent c act of
Ok f -> return (f c)
_ -> case lookupTreeManyAll showIdent opens c of
[f] -> return (f c)
[] -> alt c (text "constant not found:" <+> ppIdent c $$
text "given" <+> fsep (punctuate comma (map (ppIdent . fst) qualifs)))
fs -> case nub [f c | f <- fs] of
[tr] -> return tr
ts@(t:_) -> do checkWarn (text "atomic term" <+> ppTerm Qualified 0 t0 $$
text "conflict" <+> hsep (punctuate comma (map (ppTerm Qualified 0) ts)) $$
text "given" <+> fsep (punctuate comma (map (ppIdent . fst) qualifs)))
return t
-- a warning will be generated in CheckGrammar, and the head returned
-- in next V:
-- Bad $ "conflicting imports:" +++ unwords (map prt ts)
@@ -125,15 +119,15 @@ tree2status o = case o of
OSimple i -> mapTree (info2status (Just i))
OQualif i j -> mapTree (info2status (Just j))
buildStatus :: SourceGrammar -> Ident -> SourceModInfo -> Check Status
buildStatus gr c mo = let mo' = self2status c mo in do
let gr1 = prependModule gr (c,mo)
ops = [OSimple e | e <- allExtends gr1 c] ++ mopens mo
mods <- checkErr $ mapM (lookupModule gr1 . openedModule) ops
let sts = map modInfo2status $ zip ops mods
return $ if isModCnc mo
then (emptyBinTree, reverse sts) -- the module itself does not define any names
else (mo',reverse sts) -- so the empty ident is not needed
buildStatus :: SourceGrammar -> SourceModule -> Check Status
buildStatus gr mo@(m,mi) = checkIn (ppLocation (msrc mi) NoLoc <> colon) $ do
let gr1 = prependModule gr mo
ops = [OSimple e | e <- allExtends gr1 m] ++ mopens mi
mods <- checkErr $ mapM (lookupModule gr1 . openedModule) ops
let sts = map modInfo2status $ zip ops mods
return (if isModCnc mi
then (emptyBinTree, reverse sts) -- the module itself does not define any names
else (self2status m mi,reverse sts)) -- so the empty ident is not needed
modInfo2status :: (OpenSpec,SourceModInfo) -> (OpenSpec, StatusTree)
modInfo2status (o,mo) = (o,tree2status o (jments mo))
@@ -143,7 +137,7 @@ self2status c m = mapTree (info2status (Just c)) (jments m)
renameInfo :: Status -> SourceModule -> Ident -> Info -> Check Info
renameInfo status (m,mi) i info =
renameInfo status (m,mi) i info =
case info of
AbsCat pco -> liftM AbsCat (renPerh (renameContext status) pco)
AbsFun pty pa ptr poper -> liftM4 AbsFun (renTerm pty) (return pa) (renMaybe (mapM (renLoc (renEquation status))) ptr) (return poper)
@@ -171,9 +165,9 @@ renameInfo status (m,mi) i info =
x <- ren x
return (L loc x)
renPair ren (L locx x, L locy y) = do x <- ren x
y <- ren y
return (L locx x, L locy y)
renPair ren (x, y) = do x <- renLoc ren x
y <- renLoc ren y
return (x, y)
renEquation :: Status -> Equation -> Check Equation
renEquation b (ps,t) = do

2
src/compiler/GF/Grammar/Parser.y
View File

@@ -603,7 +603,7 @@ Posn
{
happyError :: P a
happyError = fail "parse error"
happyError = fail "syntax error"
mkListId,mkConsId,mkBaseId :: Ident -> Ident
mkListId = prefixId (BS.pack "List")

3
src/compiler/GF/Infra/UseIO.hs
View File

@@ -158,9 +158,6 @@ foldIOE f s xs = case xs of
Ok v -> foldIOE f v xx
Bad m -> return $ (s, Just m)
dieIOE :: IOE a -> IO a
dieIOE x = appIOE x >>= err die return
die :: String -> IO a
die s = do hPutStrLn stderr s
exitFailure

24
src/compiler/GFC.hs
View File

@@ -24,15 +24,21 @@ import System.IO
import Control.Exception
mainGFC :: Options -> [FilePath] -> IOE ()
mainGFC opts fs =
case () of
_ | null fs -> fail $ "No input files."
_ | all (extensionIs ".cf") fs -> compileCFFiles opts fs
_ | all (\f -> extensionIs ".gf" f || extensionIs ".gfo" f) fs -> compileSourceFiles opts fs
_ | all (extensionIs ".pgf") fs -> unionPGFFiles opts fs
_ -> fail $ "Don't know what to do with these input files: " ++ unwords fs
where extensionIs ext = (== ext) . takeExtension
mainGFC :: Options -> [FilePath] -> IO ()
mainGFC opts fs = do
r <- appIOE (case () of
_ | null fs -> fail $ "No input files."
_ | all (extensionIs ".cf") fs -> compileCFFiles opts fs
_ | all (\f -> extensionIs ".gf" f || extensionIs ".gfo" f) fs -> compileSourceFiles opts fs
_ | all (extensionIs ".pgf") fs -> unionPGFFiles opts fs
_ -> fail $ "Don't know what to do with these input files: " ++ unwords fs)
case r of
Ok x -> return x
Bad msg -> die $ if flag optVerbosity opts == Normal
then ('\n':msg)
else msg
where
extensionIs ext = (== ext) . takeExtension
compileSourceFiles :: Options -> [FilePath] -> IOE ()
compileSourceFiles opts fs =