GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-06 01:32:50 -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

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