mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-17 08:49:31 -06:00
in GF.Grammar.Update - remove the indirection before to print the error message
This commit is contained in:
krasimir
@@ -141,7 +141,6 @@ compileOne opts env@(_,srcgr,_) file = do
|
||||
let gf = takeExtensions file
|
||||
let path = dropFileName file
|
||||
let name = dropExtension file
|
||||
let mos = modules srcgr
|
||||
|
||||
case gf of
|
||||
|
||||
@@ -154,7 +153,7 @@ compileOne opts env@(_,srcgr,_) file = do
|
||||
intermOut opts DumpSource (ppModule Qualified sm0)
|
||||
|
||||
let sm1 = unsubexpModule sm0
|
||||
sm <- {- putPointE Normal opts "creating indirections" $ -} ioeErr $ extendModule mos sm1
|
||||
sm <- {- putPointE Normal opts "creating indirections" $ -} ioeErr $ extendModule srcgr sm1
|
||||
|
||||
extendCompileEnv env file sm
|
||||
|
||||
@@ -186,18 +185,19 @@ compileSourceModule opts env@(k,gr,_) mo@(i,mi) = do
|
||||
|
||||
let putp = putPointE Normal opts
|
||||
putpp = putPointE Verbose opts
|
||||
mos = modules gr
|
||||
|
||||
mo1 <- ioeErr $ rebuildModule mos mo
|
||||
mo1 <- ioeErr $ rebuildModule gr mo
|
||||
intermOut opts DumpRebuild (ppModule Qualified mo1)
|
||||
|
||||
mo1b <- ioeErr $ extendModule mos mo1
|
||||
mo1b <- ioeErr $ extendModule gr mo1
|
||||
intermOut opts DumpExtend (ppModule Qualified mo1b)
|
||||
|
||||
case mo1b of
|
||||
(_,n) | not (isCompleteModule n) -> do
|
||||
return (k,mo1b) -- refresh would fail, since not renamed
|
||||
_ -> do
|
||||
let mos = modules gr
|
||||
|
||||
mo2:_ <- putpp " renaming " $ ioeErr $ renameModule mos mo1b
|
||||
intermOut opts DumpRename (ppModule Qualified mo2)
|
||||
|
||||
|
||||
@@ -17,6 +17,7 @@ module GF.Compile.Update (buildAnyTree, extendModule, rebuildModule) where
|
||||
import GF.Infra.Ident
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.Printer
|
||||
import GF.Grammar.Lookup
|
||||
import GF.Infra.Modules
|
||||
import GF.Infra.Option
|
||||
|
||||
@@ -43,8 +44,8 @@ buildAnyTree m = go Map.empty
|
||||
text "in module" <+> ppIdent m)
|
||||
Nothing -> go (Map.insert c j map) is
|
||||
|
||||
extendModule :: [SourceModule] -> SourceModule -> Err SourceModule
|
||||
extendModule ms (name,m)
|
||||
extendModule :: SourceGrammar -> SourceModule -> Err SourceModule
|
||||
extendModule 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
|
||||
@@ -53,7 +54,7 @@ extendModule ms (name,m)
|
||||
return (name,m')
|
||||
where
|
||||
extOne mo (n,cond) = do
|
||||
m0 <- lookupModule (MGrammar ms) n
|
||||
m0 <- lookupModule gr n
|
||||
|
||||
-- test that the module types match, and find out if the old is complete
|
||||
testErr (sameMType (mtype m) (mtype mo))
|
||||
@@ -62,7 +63,7 @@ extendModule ms (name,m)
|
||||
let isCompl = isCompleteModule m0
|
||||
|
||||
-- build extension in a way depending on whether the old module is complete
|
||||
js1 <- extendMod isCompl (n, isInherited cond) name (jments m0) (jments mo)
|
||||
js1 <- extendMod gr isCompl (n, isInherited cond) name (jments m0) (jments mo)
|
||||
|
||||
-- if incomplete, throw away extension information
|
||||
return $
|
||||
@@ -75,9 +76,8 @@ extendModule ms (name,m)
|
||||
|
||||
-- | rebuilding instance + interface, and "with" modules, prior to renaming.
|
||||
-- AR 24/10/2003
|
||||
rebuildModule :: [SourceModule] -> SourceModule -> Err SourceModule
|
||||
rebuildModule ms mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_ ps_)) = do
|
||||
let gr = MGrammar ms
|
||||
rebuildModule :: SourceGrammar -> SourceModule -> Err SourceModule
|
||||
rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_ ps_)) = do
|
||||
---- deps <- moduleDeps ms
|
||||
---- is <- openInterfaces deps i
|
||||
let is = [] ---- the method above is buggy: try "i -src" for two grs. AR 8/3/2005
|
||||
@@ -92,7 +92,7 @@ rebuildModule ms mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_ ps_)) = do
|
||||
MTInstance i0 -> do
|
||||
m1 <- lookupModule gr i0
|
||||
testErr (isModRes m1) ("interface expected instead of" +++ prIdent i0)
|
||||
js' <- extendMod False (i0,const True) i (jments m1) (jments mi)
|
||||
js' <- extendMod gr False (i0,const True) i (jments m1) (jments mi)
|
||||
--- to avoid double inclusions, in instance I of I0 = J0 ** ...
|
||||
case extends mi of
|
||||
[] -> return $ replaceJudgements mi js'
|
||||
@@ -132,24 +132,31 @@ rebuildModule ms mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_ ps_)) = do
|
||||
-- | When extending a complete module: new information is inserted,
|
||||
-- and the process is interrupted if unification fails.
|
||||
-- If the extended module is incomplete, its judgements are just copied.
|
||||
extendMod :: Bool -> (Ident,Ident -> Bool) -> Ident ->
|
||||
extendMod :: SourceGrammar ->
|
||||
Bool -> (Ident,Ident -> Bool) -> Ident ->
|
||||
BinTree Ident Info -> BinTree Ident Info ->
|
||||
Err (BinTree Ident Info)
|
||||
extendMod isCompl (name,cond) base old new = foldM try new $ Map.toList old
|
||||
extendMod gr isCompl (name,cond) base old new = foldM try new $ Map.toList old
|
||||
where
|
||||
try new (c,i)
|
||||
| not (cond c) = return new
|
||||
| otherwise = case Map.lookup c new of
|
||||
Just j -> case unifyAnyInfo c i j of
|
||||
Ok k -> return $ updateTree (c,k) new
|
||||
Bad _ -> fail $ render (text "cannot unify the information" $$
|
||||
nest 4 (ppJudgement Qualified (c,i)) $$
|
||||
text "in module" <+> ppIdent name <+> text "with" $$
|
||||
nest 4 (ppJudgement Qualified (c,j)) $$
|
||||
text "in module" <+> ppIdent base)
|
||||
Nothing -> if isCompl
|
||||
then return $ updateTree (c,indirInfo name i) new
|
||||
else return $ updateTree (c,i) new
|
||||
Bad _ -> do (base,j) <- case j of
|
||||
AnyInd _ m -> lookupOrigInfo gr m c
|
||||
_ -> return (base,j)
|
||||
(name,i) <- case i of
|
||||
AnyInd _ m -> lookupOrigInfo gr m c
|
||||
_ -> return (name,i)
|
||||
fail $ render (text "cannot unify the information" $$
|
||||
nest 4 (ppJudgement Qualified (c,i)) $$
|
||||
text "in module" <+> ppIdent name <+> text "with" $$
|
||||
nest 4 (ppJudgement Qualified (c,j)) $$
|
||||
text "in module" <+> ppIdent base)
|
||||
Nothing-> if isCompl
|
||||
then return $ updateTree (c,indirInfo name i) new
|
||||
else return $ updateTree (c,i) new
|
||||
|
||||
indirInfo :: Ident -> Info -> Info
|
||||
indirInfo n info = AnyInd b n' where
|
||||
|
||||
@@ -19,6 +19,7 @@ module GF.Grammar.Lookup (
|
||||
lookupIdent,
|
||||
lookupIdentInfo,
|
||||
lookupIdentInfoIn,
|
||||
lookupOrigInfo,
|
||||
lookupResDef,
|
||||
lookupResDefKind,
|
||||
lookupResType,
|
||||
@@ -139,13 +140,14 @@ lookupOverload gr m c = do
|
||||
AnyInd _ n -> lookupOverload gr n c
|
||||
_ -> Bad $ prt c +++ "is not an overloaded operation"
|
||||
|
||||
lookupOrigInfo :: SourceGrammar -> Ident -> Ident -> Err Info
|
||||
-- | returns the original 'Info' and the module where it was found
|
||||
lookupOrigInfo :: SourceGrammar -> Ident -> Ident -> Err (Ident,Info)
|
||||
lookupOrigInfo gr m c = do
|
||||
mo <- lookupModule gr m
|
||||
info <- lookupIdentInfo mo c
|
||||
case info of
|
||||
AnyInd _ n -> lookupOrigInfo gr n c
|
||||
i -> return i
|
||||
i -> return (m,i)
|
||||
|
||||
lookupParams :: SourceGrammar -> Ident -> Ident -> Err ([Param],Maybe PValues)
|
||||
lookupParams gr = look True where
|
||||
@@ -194,7 +196,7 @@ lookupIndexValue gr ty i = do
|
||||
allOrigInfos :: SourceGrammar -> Ident -> [(Ident,Info)]
|
||||
allOrigInfos gr m = errVal [] $ do
|
||||
mo <- lookupModule gr m
|
||||
return [(c,i) | (c,_) <- tree2list (jments mo), Ok i <- [look c]]
|
||||
return [(c,i) | (c,_) <- tree2list (jments mo), Ok (_,i) <- [look c]]
|
||||
where
|
||||
look = lookupOrigInfo gr m
|
||||
|
||||
|
||||
Reference in New Issue
Block a user