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

Show relative file paths in error messages

Browse Source 
This is to avoid one trivial reason for failures in the test suite.
This commit is contained in:
hallgren
2013-12-06 15:43:34 +00:00
parent 1026824060
commit 41827b1aab
7 changed files with 63 additions and 63 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -62,7 +62,8 @@ batchCompile opts files = do
-- to compile a set of modules, e.g. an old GF or a .cf file
compileSourceGrammar :: Options -> SourceGrammar -> IOE SourceGrammar
compileSourceGrammar opts gr = do
(_,gr',_) <- foldM (\env -> compileSourceModule opts env Nothing)
cwd <- liftIO getCurrentDirectory
(_,gr',_) <- foldM (\env -> compileSourceModule opts cwd env Nothing)
(0,emptySourceGrammar,Map.empty)
(modules gr)
return gr'
@@ -132,6 +133,7 @@ compileOne opts env@(_,srcgr,_) file = do
let path = dropFileName file
let name = dropExtension file
cwd <- liftIO getCurrentDirectory
case takeExtensions file of
@@ -145,7 +147,7 @@ compileOne opts env@(_,srcgr,_) file = do
let sm1 = unsubexpModule sm0
(sm,warnings) <- {- putPointE Normal opts "creating indirections" $ -}
runCheck $ extendModule srcgr sm1
runCheck $ extendModule cwd srcgr sm1
warnOut opts warnings
if flag optTagsOnly opts
@@ -166,22 +168,22 @@ compileOne opts env@(_,srcgr,_) file = do
$ getSourceModule opts file
intermOut opts (Dump Source) (ppModule Internal sm)
compileSourceModule opts env (Just file) sm
compileSourceModule opts cwd env (Just file) sm
where
isConcr (_,m) = isModCnc m && mstatus m /= MSIncomplete
compileSourceModule :: Options -> CompileEnv -> Maybe FilePath -> SourceModule -> IOE CompileEnv
compileSourceModule opts env@(k,gr,_) mb_gfFile mo@(i,mi) = do
compileSourceModule :: Options -> FilePath -> CompileEnv -> Maybe FilePath -> SourceModule -> IOE CompileEnv
compileSourceModule opts cwd env@(k,gr,_) mb_gfFile mo@(i,mi) = do
mo1 <- runPass Rebuild "" (rebuildModule gr mo)
mo1b <- runPass Extend "" (extendModule gr mo1)
mo1 <- runPass Rebuild "" (rebuildModule cwd gr mo)
mo1b <- runPass Extend "" (extendModule cwd gr mo1)
case mo1b of
(_,n) | not (isCompleteModule n) ->
if tagsFlag then generateTags k mo1b else generateGFO k mo1b
_ -> do
mo2 <- runPass Rename "renaming" $ renameModule gr mo1b
mo3 <- runPass TypeCheck "type checking" $ checkModule opts gr mo2
mo2 <- runPass Rename "renaming" $ renameModule cwd gr mo1b
mo3 <- runPass TypeCheck "type checking" $ checkModule opts cwd gr mo2
if tagsFlag then generateTags k mo3 else compileCompleteModule k mo3
where
compileCompleteModule k mo3 = do

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

@@ -45,26 +45,25 @@ import Control.Monad
import Text.PrettyPrint
-- | checking is performed in the dependency order of modules
checkModule :: Options -> SourceGrammar -> SourceModule -> Check SourceModule
checkModule opts sgr mo@(m,mi) = do
checkRestrictedInheritance sgr mo
checkModule :: Options -> FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
checkModule opts cwd sgr mo@(m,mi) = do
checkRestrictedInheritance cwd sgr mo
mo <- case mtype mi of
MTConcrete a -> do let gr = prependModule sgr mo
abs <- lookupModule gr a
checkCompleteGrammar opts gr (a,abs) mo
checkCompleteGrammar opts cwd gr (a,abs) mo
_ -> return mo
infoss <- checkIn (ppLocation (msrc mi) NoLoc <> colon) $
topoSortJments2 mo
infoss <- checkInModule cwd mi NoLoc empty $ topoSortJments2 mo
foldM updateCheckInfos mo infoss
where
updateCheckInfos mo = fmap (foldl update mo) . parallelCheck . map check
where check (i,info) = fmap ((,) i) (checkInfo opts sgr mo i info)
where check (i,info) = fmap ((,) i) (checkInfo opts cwd sgr mo i info)
update mo@(m,mi) (i,info) = (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 :: SourceGrammar -> SourceModule -> Check ()
checkRestrictedInheritance sgr (name,mo) = checkIn (ppLocation (msrc mo) NoLoc <> colon) $ do
checkRestrictedInheritance :: FilePath -> SourceGrammar -> SourceModule -> Check ()
checkRestrictedInheritance cwd sgr (name,mo) = checkInModule cwd mo NoLoc empty $ 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]]
-- the restr. modules themself, with restr. infos
@@ -83,8 +82,8 @@ checkRestrictedInheritance sgr (name,mo) = checkIn (ppLocation (msrc mo) NoLoc <
nest 2 (vcat [ppIdent f <+> text "on" <+> fsep (map ppIdent is) | (f,is) <- cs]))
allDeps = concatMap (allDependencies (const True) . jments . snd) mos
checkCompleteGrammar :: Options -> SourceGrammar -> SourceModule -> SourceModule -> Check SourceModule
checkCompleteGrammar opts gr (am,abs) (cm,cnc) = checkIn (ppLocation (msrc cnc) NoLoc <> colon) $ do
checkCompleteGrammar :: Options -> FilePath -> SourceGrammar -> SourceModule -> SourceModule -> Check SourceModule
checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc empty $ do
let jsa = jments abs
let jsc = jments cnc
@@ -157,9 +156,9 @@ checkCompleteGrammar opts gr (am,abs) (cm,cnc) = checkIn (ppLocation (msrc cnc)
-- | General Principle: only Just-values are checked.
-- A May-value has always been checked in its origin module.
checkInfo :: Options -> SourceGrammar -> SourceModule -> Ident -> Info -> Check Info
checkInfo opts sgr (m,mo) c info = do
checkIn (ppLocation (msrc mo) NoLoc <> colon) $
checkInfo :: Options -> FilePath -> SourceGrammar -> SourceModule -> Ident -> Info -> Check Info
checkInfo opts cwd sgr (m,mo) c info = do
checkInModule cwd mo NoLoc empty $
checkReservedId c
case info of
AbsCat (Just (L loc cont)) ->
@@ -264,8 +263,8 @@ checkInfo opts sgr (m,mo) c info = do
_ -> return info
where
gr = prependModule sgr (m,mo)
chIn loc cat = checkIn (ppLocation (msrc mo) loc <> colon $$
nest 2 (text "Happened in" <+> text cat <+> ppIdent c))
chIn loc cat = checkInModule cwd mo loc
(text "Happened in" <+> text cat <+> ppIdent c)
mkPar (f,co) = do
vs <- liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co
@@ -280,9 +279,7 @@ checkInfo opts sgr (m,mo) c info = do
mkCheck loc cat ss = case ss of
[] -> return info
_ -> checkError (ppLocation (msrc mo) loc <> colon $$
nest 2 (text "Happened in" <+> text cat <+> ppIdent c $$
nest 2 (vcat ss)))
_ -> chIn loc cat $ checkError (vcat ss)
compAbsTyp g t = case t of
Vr x -> maybe (checkError (text "no value given to variable" <+> ppIdent x)) return $ lookup x g

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

@@ -33,18 +33,20 @@ import Data.Char(isAscii)
import Control.Monad (foldM,when,unless)
import System.Cmd (system)
--import System.IO(mkTextEncoding) --,utf8
import System.Directory(removeFile)
import System.Directory(removeFile,getCurrentDirectory)
import System.FilePath(makeRelative)
getSourceModule :: Options -> FilePath -> IOE SourceModule
getSourceModule opts file0 =
errIn file0 $
--errIn file0 $
do tmp <- lift $ foldM runPreprocessor (Source file0) (flag optPreprocessors opts)
raw <- lift $ keepTemp tmp
--ePutStrLn $ "1 "++file0
(optCoding,parsed) <- parseSource opts pModDef raw
case parsed of
Left (Pn l c,msg) -> do file <- lift $ writeTemp tmp
let location = file++":"++show l++":"++show c
cwd <- lift $ getCurrentDirectory
let location = makeRelative cwd file++":"++show l++":"++show c
raise (location++":\n "++msg)
Right (i,mi0) ->
do lift $ removeTemp tmp

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

@@ -46,13 +46,13 @@ import Text.PrettyPrint
renameSourceTerm :: SourceGrammar -> Ident -> Term -> Check Term
renameSourceTerm g m t = do
mi <- lookupModule g m
status <- buildStatus g (m,mi)
status <- buildStatus "" g (m,mi)
renameTerm status [] t
renameModule :: SourceGrammar -> SourceModule -> Check SourceModule
renameModule gr mo@(m,mi) = do
status <- buildStatus gr mo
js <- checkMapRecover (renameInfo status mo) (jments mi)
renameModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
renameModule cwd gr mo@(m,mi) = do
status <- buildStatus cwd gr mo
js <- checkMapRecover (renameInfo cwd status mo) (jments mi)
return (m, mi{jments = js})
type Status = (StatusTree, [(OpenSpec, StatusTree)])
@@ -123,8 +123,8 @@ tree2status o = case o of
OSimple i -> mapTree (info2status (Just i))
OQualif i j -> mapTree (info2status (Just j))
buildStatus :: SourceGrammar -> SourceModule -> Check Status
buildStatus gr mo@(m,mi) = checkIn (ppLocation (msrc mi) NoLoc <> colon) $ do
buildStatus :: FilePath -> SourceGrammar -> SourceModule -> Check Status
buildStatus cwd gr mo@(m,mi) = checkInModule cwd mi NoLoc empty $ do
let gr1 = prependModule gr mo
exts = [(OSimple m,mi) | (m,mi) <- allExtends gr1 m]
ops <- mapM (\o -> lookupModule gr1 (openedModule o) >>= \mi -> return (o,mi)) (mopens mi)
@@ -140,8 +140,8 @@ self2status :: Ident -> SourceModInfo -> StatusTree
self2status c m = mapTree (info2status (Just c)) (jments m)
renameInfo :: Status -> SourceModule -> Ident -> Info -> Check Info
renameInfo status (m,mi) i info =
renameInfo :: FilePath -> Status -> SourceModule -> Ident -> Info -> Check Info
renameInfo cwd 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)
@@ -165,7 +165,7 @@ renameInfo status (m,mi) i info =
renMaybe ren Nothing = return Nothing
renLoc ren (L loc x) =
checkIn (ppLocation (msrc mi) loc <> colon $$ text "Happened in the renaming of" <+> ppIdent i) $ do
checkInModule cwd mi loc (text "Happened in the renaming of" <+> ppIdent i) $ do
x <- ren x
return (L loc x)

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

@@ -29,7 +29,7 @@ import Control.Monad
import Text.PrettyPrint
-- | combine a list of definitions into a balanced binary search tree
buildAnyTree :: Ident -> [(Ident,Info)] -> Err (BinTree Ident Info)
buildAnyTree :: Monad m => Ident -> [(Ident,Info)] -> m (BinTree Ident Info)
buildAnyTree m = go Map.empty
where
go map [] = return map
@@ -37,20 +37,19 @@ buildAnyTree m = go Map.empty
case Map.lookup c map of
Just i -> case unifyAnyInfo m i j of
Ok k -> go (Map.insert c k map) is
Bad _ -> fail $ render (text "cannot unify the informations" $$
Bad _ -> fail $ render (text "conflicting information in module"<+>ppIdent m $$
nest 4 (ppJudgement Qualified (c,i)) $$
text "and" $+$
nest 4 (ppJudgement Qualified (c,j)) $$
text "in module" <+> ppIdent m)
nest 4 (ppJudgement Qualified (c,j)))
Nothing -> go (Map.insert c j map) is
extendModule :: SourceGrammar -> SourceModule -> Check SourceModule
extendModule gr (name,m)
extendModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
extendModule cwd gr (name,m)
---- Just to allow inheritance in incomplete concrete (which are not
---- compiled anyway), extensions are not built for them.
---- Should be replaced by real control. AR 4/2/2005
| mstatus m == MSIncomplete && isModCnc m = return (name,m)
| otherwise = checkIn (ppLocation (msrc m) NoLoc <> colon) $ do
| otherwise = checkInModule cwd m NoLoc empty $ do
m' <- foldM extOne m (mextend m)
return (name,m')
where
@@ -77,9 +76,9 @@ extendModule gr (name,m)
-- | rebuilding instance + interface, and "with" modules, prior to renaming.
-- AR 24/10/2003
rebuildModule :: SourceGrammar -> SourceModule -> Check SourceModule
rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js_)) =
checkIn (ppLocation msrc_ NoLoc <> colon) $ do
rebuildModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js_)) =
checkInModule cwd mi NoLoc empty $ do
---- deps <- moduleDeps ms
---- is <- openInterfaces deps i

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

@@ -116,9 +116,7 @@ ModDef
(extends,with,content) = $4
(opens,jments,opts) = case content of { Just c -> c; Nothing -> ([],[],noOptions) }
jments <- mapM (checkInfoType mtype) jments
defs <- case buildAnyTree id jments of
Ok x -> return x
Bad msg -> fail (optDecode opts msg)
defs <- buildAnyTree id jments
return (id, ModInfo mtype mstat opts extends with opens [] "" Nothing defs) }
ModHeader :: { SourceModule }
@@ -614,12 +612,6 @@ Posn
happyError :: P a
happyError = fail "syntax error"
-- Quick fix to render error messages from UTF-8-encoded source files correctly.
optDecode opts =
{-if map toLower (getEncoding opts) `elem` ["utf8","utf-8"]
then decodeString
else-} id
mkListId,mkConsId,mkBaseId :: Ident -> Ident
mkListId = prefixIdent "List"
mkConsId = prefixIdent "Cons"

14
src/compiler/GF/Infra/CheckM.hs
View File

@@ -15,17 +15,18 @@
module GF.Infra.CheckM
(Check, CheckResult, Message, runCheck,
checkError, checkCond, checkWarn, checkWarnings, checkAccumError,
{-checkErr,-} checkIn, checkMap, checkMapRecover,
checkIn, checkInModule, checkMap, checkMapRecover,
parallelCheck, accumulateError, commitCheck,
) where
import GF.Data.Operations
--import GF.Infra.Ident
--import GF.Grammar.Grammar(Context)
--import GF.Grammar.Printer
import GF.Grammar.Grammar(msrc) -- ,Context
import GF.Grammar.Printer(ppLocation)
import qualified Data.Map as Map
import Text.PrettyPrint
import System.FilePath(makeRelative)
import Control.Parallel.Strategies(parList,rseq,using)
import Control.Monad(liftM)
@@ -146,3 +147,10 @@ checkIn msg c = Check $ \{-ctxt-} msgs0 ->
augment' msgs0 msgs' = (msg $$ nest 3 (vcat (reverse msgs'))):msgs0
augment1 msg' = msg $$ nest 3 msg'
-- | Augment error messages with a relative path to the source module and
-- an contextual hint (which can be left 'empty')
checkInModule cwd mi loc context =
checkIn (ppLocation relpath loc <> colon $$ nest 2 context)
where
relpath = makeRelative cwd (msrc mi)