summaryrefslogtreecommitdiff
path: root/src/GF/Compile
diff options
context:
space:
mode:
Diffstat (limited to 'src/GF/Compile')
-rw-r--r--src/GF/Compile/Compile.hs26
-rw-r--r--src/GF/Compile/Extend.hs25
-rw-r--r--src/GF/Compile/Rebuild.hs8
3 files changed, 39 insertions, 20 deletions
diff --git a/src/GF/Compile/Compile.hs b/src/GF/Compile/Compile.hs
index 3b6f44d87..2c8016a61 100644
--- a/src/GF/Compile/Compile.hs
+++ b/src/GF/Compile/Compile.hs
@@ -165,12 +165,13 @@ extendCompileEnvCanon ((k,s,c),fts) cgr ft =
type TimedCompileEnv = (CompileEnv,[(FilePath,ModTime)])
compileOne :: Options -> TimedCompileEnv -> FullPath -> IOE TimedCompileEnv
-compileOne opts env file = do
+compileOne opts env@((_,srcgr,_),_) file = do
let putp = putPointE opts
let gf = fileSuffix file
let path = justInitPath file
let name = fileBody file
+ let mos = modules srcgr
case gf of
-- for multilingual canonical gf, just read the file and update environment
@@ -188,12 +189,13 @@ compileOne opts env file = do
-- for compiled resource, parse and organize, then update environment
"gfr" -> do
- sm0 <- putp ("| parsing" +++ file) $ getSourceModule file
- let mos = case env of ((_,gr,_),_) -> modules gr
+ sm0 <- putp ("| parsing" +++ file) $ getSourceModule file
sm <- {- putp "creating indirections" $ -} ioeErr $ extendModule mos sm0
+---- experiment with not optimizing gfr
+---- sm:_ <- putp " optimizing " $ ioeErr $ evalModule mos sm1
let gfc = gfcFile name
- cm <- putp ("+ reading" +++ gfc) $ getCanonModule gfc
- ft <- getReadTimes file
+ cm <- putp ("+ reading" +++ gfc) $ getCanonModule gfc
+ ft <- getReadTimes file
extendCompileEnv env (sm,cm) ft
-- for gf source, do full compilation
@@ -202,7 +204,12 @@ compileOne opts env file = do
(k',sm) <- makeSourceModule opts (fst env) sm0
cm <- putp " generating code... " $ generateModuleCode opts path sm
ft <- getReadTimes file
- extendCompileEnvInt env (k',sm,cm) ft
+
+ sm':_ <- case snd sm of
+---- ModMod n | isModRes n -> putp " optimizing " $ ioeErr $ evalModule mos sm
+ _ -> return [sm]
+
+ extendCompileEnvInt env (k',sm',cm) ft
-- dispatch reused resource at early stage
@@ -255,8 +262,11 @@ compileSourceModule opts env@(k,gr,can) mo@(i,mi) = do
(k',mo3r:_) <- ioeErr $ refreshModule (k,mos) mo3
- mo4:_ <- putp " optimizing " $ ioeErr $ evalModule mos mo3r
-
+ mo4:_ <-
+---- case snd mo1b of
+---- ModMod n | isModCnc n ->
+ putp " optimizing " $ ioeErr $ evalModule mos mo3r
+---- _ -> return [mo3r]
return (k',mo4)
where
---- prDebug mo = ioeIO $ putStrLn $ prGrammar $ MGrammar [mo] ---- debug
diff --git a/src/GF/Compile/Extend.hs b/src/GF/Compile/Extend.hs
index e0c56e31f..3f2570570 100644
--- a/src/GF/Compile/Extend.hs
+++ b/src/GF/Compile/Extend.hs
@@ -31,6 +31,12 @@ import Monad
extendModule :: [SourceModule] -> SourceModule -> Err SourceModule
extendModule ms (name,mod) = case mod of
+
+ ---- 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
+ ModMod m | mstatus m == MSIncomplete && isModCnc m -> return (name,mod)
+
ModMod m -> do
mod' <- foldM extOne m (extends m)
return (name,ModMod mod')
@@ -42,10 +48,11 @@ extendModule ms (name,mod) = case mod of
-- test that the module types match, and find out if the old is complete
testErr (sameMType (mtype m) mt)
("illegal extension type to module" +++ prt name)
- return (m,isCompleteModule m)
+ return (m, isCompleteModule m)
+---- return (m, if (isCompleteModule m) then True else not (isCompleteModule mod))
-- build extension in a way depending on whether the old module is complete
- js1 <- extendMod isCompl n (jments m0) js
+ js1 <- extendMod isCompl n name (jments m0) js
-- if incomplete, throw away extension information
let me' = if isCompl then es else (filter (/=n) es)
@@ -55,11 +62,11 @@ extendModule ms (name,mod) = case mod of
-- and the process is interrupted if unification fails.
-- If the extended module is incomplete, its judgements are just copied.
-extendMod :: Bool -> Ident -> BinTree (Ident,Info) -> BinTree (Ident,Info) ->
+extendMod :: Bool -> Ident -> Ident -> BinTree (Ident,Info) -> BinTree (Ident,Info) ->
Err (BinTree (Ident,Info))
-extendMod isCompl name old new = foldM try new $ tree2list old where
+extendMod isCompl name base old new = foldM try new $ tree2list old where
try t i@(c,_) = errIn ("constant" +++ prt c) $
- tryInsert (extendAnyInfo isCompl name) indirIf t i
+ tryInsert (extendAnyInfo isCompl name base) indirIf t i
indirIf = if isCompl then indirInfo name else id
indirInfo :: Ident -> Info -> Info
@@ -76,8 +83,9 @@ perhIndir n p = case p of
Yes _ -> May n
_ -> p
-extendAnyInfo :: Bool -> Ident -> Info -> Info -> Err Info
-extendAnyInfo isc n i j = errIn ("building extension for" +++ prt n) $ case (i,j) of
+extendAnyInfo :: Bool -> Ident -> Ident -> Info -> Info -> Err Info
+extendAnyInfo isc n o i j =
+ errIn ("building extension for" +++ prt n +++ "in" +++ prt o) $ case (i,j) of
(AbsCat mc1 mf1, AbsCat mc2 mf2) ->
liftM2 AbsCat (updn isc n mc1 mc2) (updn isc n mf1 mf2) --- add cstrs
(AbsFun mt1 md1, AbsFun mt2 md2) ->
@@ -107,7 +115,8 @@ extendAnyInfo isc n i j = errIn ("building extension for" +++ prt n) $ case (i,j
--- where
-updn isc n = if isc then (updatePerhaps n) else (updatePerhapsHard n)
+updn isc n = if isc then (updatePerhaps n) else (updatePerhapsHard n)
+updc isc n = if True then (updatePerhaps n) else (updatePerhapsHard n)
diff --git a/src/GF/Compile/Rebuild.hs b/src/GF/Compile/Rebuild.hs
index 815f6aa46..bdd759fa0 100644
--- a/src/GF/Compile/Rebuild.hs
+++ b/src/GF/Compile/Rebuild.hs
@@ -9,7 +9,7 @@
-- > CVS $Author $
-- > CVS $Revision $
--
--- (Description of the module)
+-- Rebuild a source module from incomplete and its with-instance.
-----------------------------------------------------------------------------
module Rebuild where
@@ -45,7 +45,7 @@ rebuildModule ms mo@(i,mi) = do
m1 <- lookupModMod gr i0
testErr (isModRes m1) ("interface expected instead of" +++ prt i0)
m' <- do
- js' <- extendMod False i0 (jments m1) (jments m)
+ js' <- extendMod False i0 i (jments m1) (jments m)
--- to avoid double inclusions, in instance I of I0 = J0 ** ...
case extends m of
[] -> return $ replaceJudgements m js'
@@ -60,14 +60,14 @@ rebuildModule ms mo@(i,mi) = do
_ -> return mi
-- add the instance opens to an incomplete module "with" instances
- ModWith mt stat ext ops -> do
+ ModWith mt stat ext me ops -> do
let insts = [(inf,inst) | OQualif _ inf inst <- ops]
let infs = map fst insts
let stat' = ifNull MSComplete (const MSIncomplete)
[i | i <- is, notElem i infs]
testErr (stat' == MSComplete || stat == MSIncomplete)
("module" +++ prt i +++ "remains incomplete")
- Module mt0 _ fs me ops0 js <- lookupModMod gr ext
+ Module mt0 _ fs me' ops0 js <- lookupModMod gr ext
let ops1 = ops ++ [o | o <- ops0, notElem (openedModule o) infs]
++ [oQualif i i | i <- map snd insts] ----
++ [oSimple i | i <- map snd insts] ----
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 21:17:43 +0000