diff --git a/src/compiler/GF/Compile.hs b/src/compiler/GF/Compile.hs index 0e29192c6..b74fd340c 100644 --- a/src/compiler/GF/Compile.hs +++ b/src/compiler/GF/Compile.hs @@ -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 diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs index 5b707157c..aa39dea50 100644 --- a/src/compiler/GF/Compile/CheckGrammar.hs +++ b/src/compiler/GF/Compile/CheckGrammar.hs @@ -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 diff --git a/src/compiler/GF/Compile/GetGrammar.hs b/src/compiler/GF/Compile/GetGrammar.hs index 10a857bf9..6393d51d2 100644 --- a/src/compiler/GF/Compile/GetGrammar.hs +++ b/src/compiler/GF/Compile/GetGrammar.hs @@ -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 diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs index 8821d99ca..732693b49 100644 --- a/src/compiler/GF/Compile/Rename.hs +++ b/src/compiler/GF/Compile/Rename.hs @@ -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) diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs index 6821a2981..88f44a631 100644 --- a/src/compiler/GF/Compile/Update.hs +++ b/src/compiler/GF/Compile/Update.hs @@ -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 diff --git a/src/compiler/GF/Grammar/Parser.y b/src/compiler/GF/Grammar/Parser.y index 028da18c6..6f7f5854e 100644 --- a/src/compiler/GF/Grammar/Parser.y +++ b/src/compiler/GF/Grammar/Parser.y @@ -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" diff --git a/src/compiler/GF/Infra/CheckM.hs b/src/compiler/GF/Infra/CheckM.hs index f1d4ebbde..045ba4852 100644 --- a/src/compiler/GF/Infra/CheckM.hs +++ b/src/compiler/GF/Infra/CheckM.hs @@ -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)