summaryrefslogtreecommitdiff
path: root/src/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'src/compiler')
-rw-r--r--src/compiler/GF/Compile.hs20
-rw-r--r--src/compiler/GF/Compile/CheckGrammar.hs35
-rw-r--r--src/compiler/GF/Compile/GetGrammar.hs8
-rw-r--r--src/compiler/GF/Compile/Rename.hs20
-rw-r--r--src/compiler/GF/Compile/Update.hs19
-rw-r--r--src/compiler/GF/Grammar/Parser.y10
-rw-r--r--src/compiler/GF/Infra/CheckM.hs14
7 files changed, 63 insertions, 63 deletions
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)
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 06:45:09 +0000