From 96721de3e310f4d2c3f4263c950f3d365b1cb444 Mon Sep 17 00:00:00 2001 From: aarne Date: Sat, 31 May 2008 14:40:46 +0000 Subject: [PATCH] added positions to Module record; avoided Module constructor where possible; moved Refresh to Compile/ --- src-3.0/GF/Compile.hs | 2 +- src-3.0/GF/Compile/BackOpt.hs | 4 ++-- src-3.0/GF/Compile/CheckGrammar.hs | 9 ++++---- src-3.0/GF/Compile/Compute.hs | 2 +- src-3.0/GF/Compile/Extend.hs | 12 +++++----- src-3.0/GF/Compile/GrammarToGFCC.hs | 9 ++++---- src-3.0/GF/Compile/Optimize.hs | 13 +++++------ src-3.0/GF/Compile/OptimizeGF.hs | 27 +++++++++++----------- src-3.0/GF/Compile/Rebuild.hs | 7 +++--- src-3.0/GF/{Grammar => Compile}/Refresh.hs | 8 +++---- src-3.0/GF/Compile/RemoveLiT.hs | 6 ++--- src-3.0/GF/Compile/Rename.hs | 6 ++--- src-3.0/GF/Compile/TypeCheck.hs | 2 +- src-3.0/GF/Grammar/MMacros.hs | 2 +- src-3.0/GF/Infra/Modules.hs | 16 +++++++------ src-3.0/GF/Source/SourceToGrammar.hs | 10 ++++---- 16 files changed, 71 insertions(+), 64 deletions(-) rename src-3.0/GF/{Grammar => Compile}/Refresh.hs (93%) diff --git a/src-3.0/GF/Compile.hs b/src-3.0/GF/Compile.hs index 0119b2107..71eb35bb4 100644 --- a/src-3.0/GF/Compile.hs +++ b/src-3.0/GF/Compile.hs @@ -12,9 +12,9 @@ import GF.Compile.OptimizeGFCC import GF.Compile.GrammarToGFCC import GF.Compile.ReadFiles import GF.Compile.Update +import GF.Compile.Refresh import GF.Grammar.Grammar -import GF.Grammar.Refresh import GF.Grammar.Lookup import GF.Grammar.PrGrammar diff --git a/src-3.0/GF/Compile/BackOpt.hs b/src-3.0/GF/Compile/BackOpt.hs index 2814448b4..8667023c0 100644 --- a/src-3.0/GF/Compile/BackOpt.hs +++ b/src-3.0/GF/Compile/BackOpt.hs @@ -34,8 +34,8 @@ type OptSpec = Set Optimization shareModule :: OptSpec -> (Ident, SourceModInfo) -> (Ident, SourceModInfo) shareModule opt (i,m) = case m of - M.ModMod (M.Module mt st fs me ops js) -> - (i,M.ModMod (M.Module mt st fs me ops (mapTree (shareInfo opt) js))) + M.ModMod mo -> + (i,M.ModMod (M.replaceJudgements mo (mapTree (shareInfo opt) (M.jments mo)))) _ -> (i,m) shareInfo opt (c, CncCat ty (Yes t) m) = (c,CncCat ty (Yes (shareOptim opt c t)) m) diff --git a/src-3.0/GF/Compile/CheckGrammar.hs b/src-3.0/GF/Compile/CheckGrammar.hs index f8383ea9f..587c2bf18 100644 --- a/src-3.0/GF/Compile/CheckGrammar.hs +++ b/src-3.0/GF/Compile/CheckGrammar.hs @@ -29,7 +29,7 @@ import GF.Infra.Modules import GF.Compile.TypeCheck -import GF.Grammar.Refresh +import GF.Compile.Refresh import GF.Grammar.Grammar import GF.Grammar.PrGrammar import GF.Grammar.Lookup @@ -65,9 +65,10 @@ mapsCheckTree f = checkErr . mapsErrTree (\t -> checkStart (f t) >>= return . fs checkModule :: [SourceModule] -> SourceModule -> Check [SourceModule] checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod of - ModMod mo@(Module mt st fs me ops js) -> do + ModMod mo -> do + let js = jments mo checkRestrictedInheritance ms (name, mo) - js' <- case mt of + js' <- case mtype mo of MTAbstract -> mapsCheckTree (checkAbsInfo gr name) js MTTransfer a b -> mapsCheckTree (checkAbsInfo gr name) js @@ -87,7 +88,7 @@ checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod -- checkCompleteInstance abs mo -- this is done in Rebuild mapsCheckTree (checkResInfo gr name) js - return $ (name, ModMod (Module mt st fs me ops js')) : ms + return $ (name, ModMod (replaceJudgements mo js')) : ms _ -> return $ (name,mod) : ms where diff --git a/src-3.0/GF/Compile/Compute.hs b/src-3.0/GF/Compile/Compute.hs index 1c68de71b..f35e7c6a9 100644 --- a/src-3.0/GF/Compile/Compute.hs +++ b/src-3.0/GF/Compile/Compute.hs @@ -24,7 +24,7 @@ import GF.Infra.Modules import GF.Grammar.Predef import GF.Grammar.Macros import GF.Grammar.Lookup -import GF.Grammar.Refresh +import GF.Compile.Refresh import GF.Grammar.PatternMatch import GF.Grammar.Lockfield (isLockLabel) ---- diff --git a/src-3.0/GF/Compile/Extend.hs b/src-3.0/GF/Compile/Extend.hs index ae87b3e71..0dcde340a 100644 --- a/src-3.0/GF/Compile/Extend.hs +++ b/src-3.0/GF/Compile/Extend.hs @@ -40,22 +40,22 @@ extendModule ms (name,mod) = case mod of mod' <- foldM extOne m (extend m) return (name,ModMod mod') where - extOne mod@(Module mt st fs es ops js) (n,cond) = do + extOne mo (n,cond) = do (m0,isCompl) <- do m <- lookupModMod (MGrammar ms) n -- test that the module types match, and find out if the old is complete - testErr (sameMType (mtype m) mt) + testErr (sameMType (mtype m) (mtype mo)) ("illegal extension type to module" +++ prt name) 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, isInherited cond) name (jments m0) js + js1 <- extendMod isCompl (n, isInherited cond) name (jments m0) (jments mo) -- if incomplete, throw away extension information - let me' = if isCompl then es else (filter ((/=n) . fst) es) - return $ Module mt st fs me' ops js1 + let es = extend mo + let es' = if isCompl then es else (filter ((/=n) . fst) es) + return $ mo {extend = es', jments = js1} -- | When extending a complete module: new information is inserted, -- and the process is interrupted if unification fails. diff --git a/src-3.0/GF/Compile/GrammarToGFCC.hs b/src-3.0/GF/Compile/GrammarToGFCC.hs index bf87d42fe..637f40ed8 100644 --- a/src-3.0/GF/Compile/GrammarToGFCC.hs +++ b/src-3.0/GF/Compile/GrammarToGFCC.hs @@ -218,11 +218,12 @@ mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do reorder :: Ident -> SourceGrammar -> SourceGrammar reorder abs cg = M.MGrammar $ (abs, M.ModMod $ - M.Module M.MTAbstract M.MSComplete aflags [] [] adefs): + M.Module M.MTAbstract M.MSComplete aflags [] [] adefs poss): [(c, M.ModMod $ - M.Module (M.MTConcrete abs) M.MSComplete fs [] [] (sorted2tree js)) + M.Module (M.MTConcrete abs) M.MSComplete fs [] [] (sorted2tree js) poss) | (c,(fs,js)) <- cncs] where + poss = emptyBinTree -- positions no longer needed mos = M.allModMod cg adefs = sorted2tree $ sortIds $ predefADefs ++ Look.allOrigInfos cg abs @@ -268,8 +269,8 @@ canon2canon abs = js2js ms = map (c2c (j2j (M.MGrammar ms))) ms c2c f2 (c,m) = case m of - M.ModMod mo@(M.Module _ _ _ _ _ js) -> - (c, M.ModMod $ M.replaceJudgements mo $ mapTree f2 js) + M.ModMod mo -> + (c, M.ModMod $ M.replaceJudgements mo $ mapTree f2 (M.jments mo)) _ -> (c,m) j2j cg (f,j) = case j of CncFun x (Yes tr) z -> (f,CncFun x (Yes (trace ("+ " ++ prt f) (t2t tr))) z) diff --git a/src-3.0/GF/Compile/Optimize.hs b/src-3.0/GF/Compile/Optimize.hs index 80ceed16d..d2b303bc6 100644 --- a/src-3.0/GF/Compile/Optimize.hs +++ b/src-3.0/GF/Compile/Optimize.hs @@ -22,7 +22,7 @@ import GF.Grammar.PrGrammar import GF.Grammar.Macros import GF.Grammar.Lookup import GF.Grammar.Predef -import GF.Grammar.Refresh +import GF.Compile.Refresh import GF.Compile.Compute import GF.Compile.BackOpt import GF.Compile.CheckGrammar @@ -52,8 +52,7 @@ type EEnv = () --- not used optimizeModule :: Options -> ([(Ident,SourceModInfo)],EEnv) -> (Ident,SourceModInfo) -> Err ((Ident,SourceModInfo),EEnv) optimizeModule opts mse@(ms,eenv) mo@(_,mi) = case mi of - ModMod m0@(Module mt st fs me ops js) | - st == MSComplete && isModRes m0 -> do + ModMod m0 | mstatus m0 == MSComplete && isModRes m0 -> do (mo1,_) <- evalModule oopts mse mo let mo2 = shareModule optim mo1 return (mo2,eenv) @@ -66,16 +65,16 @@ evalModule :: Options -> ([(Ident,SourceModInfo)],EEnv) -> (Ident,SourceModInfo) Err ((Ident,SourceModInfo),EEnv) evalModule oopts (ms,eenv) mo@(name,mod) = case mod of - ModMod m0@(Module mt st fs me ops js) | st == MSComplete -> case mt of + ModMod m0 | mstatus m0 == MSComplete -> case mtype m0 of _ | isModRes m0 -> do - let deps = allOperDependencies name js + let deps = allOperDependencies name (jments m0) ids <- topoSortOpers deps MGrammar (mod' : _) <- foldM evalOp gr ids return $ (mod',eenv) MTConcrete a -> do - js' <- mapMTree (evalCncInfo oopts gr name a) js ---- <- gr0 6/12/2005 - return $ ((name, ModMod (Module mt st fs me ops js')),eenv) + js' <- mapMTree (evalCncInfo oopts gr name a) (jments m0) + return $ ((name, ModMod (replaceJudgements m0 js')),eenv) _ -> return $ ((name,mod),eenv) _ -> return $ ((name,mod),eenv) diff --git a/src-3.0/GF/Compile/OptimizeGF.hs b/src-3.0/GF/Compile/OptimizeGF.hs index 8872a5105..41b828aa3 100644 --- a/src-3.0/GF/Compile/OptimizeGF.hs +++ b/src-3.0/GF/Compile/OptimizeGF.hs @@ -47,8 +47,8 @@ unshareModule gr = processModule (const (unoptim gr)) processModule :: (Ident -> Term -> Term) -> (Ident, SourceModInfo) -> (Ident, SourceModInfo) processModule opt (i,m) = case m of - M.ModMod (M.Module mt st fs me ops js) -> - (i,M.ModMod (M.Module mt st fs me ops (mapTree (shareInfo opt) js))) + M.ModMod mo -> + (i,M.ModMod (M.replaceJudgements mo (mapTree (shareInfo opt) (M.jments mo)))) _ -> (i,m) shareInfo opt (c, CncCat ty (Yes t) m) = (c,CncCat ty (Yes (opt c t)) m) @@ -168,19 +168,20 @@ cse is possible in the grammar. It is used by the flag pg -printer=subs. -} subexpModule :: SourceModule -> SourceModule -subexpModule (mo,m) = errVal (mo,m) $ case m of - M.ModMod (M.Module mt st fs me ops js) -> do - (tree,_) <- appSTM (getSubtermsMod mo (tree2list js)) (Map.empty,0) - js2 <- liftM buildTree $ addSubexpConsts mo tree $ tree2list js - return (mo,M.ModMod (M.Module mt st fs me ops js2)) - _ -> return (mo,m) +subexpModule (n,m) = errVal (n,m) $ case m of + M.ModMod mo -> do + let ljs = tree2list (M.jments mo) + (tree,_) <- appSTM (getSubtermsMod n ljs) (Map.empty,0) + js2 <- liftM buildTree $ addSubexpConsts n tree $ ljs + return (n,M.ModMod (M.replaceJudgements mo js2)) + _ -> return (n,m) unsubexpModule :: SourceModule -> SourceModule -unsubexpModule mo@(i,m) = case m of - M.ModMod (M.Module mt st fs me ops js) | hasSub ljs -> - (i, M.ModMod (M.Module mt st fs me ops +unsubexpModule sm@(i,m) = case m of + M.ModMod mo | hasSub ljs -> + (i, M.ModMod (M.replaceJudgements mo (rebuild (map unparInfo ljs)))) - where ljs = tree2list js + where ljs = tree2list (M.jments mo) _ -> (i,m) where -- perform this iff the module has opers @@ -194,7 +195,7 @@ unsubexpModule mo@(i,m) = case m of Q m c | isOperIdent c -> --- name convention of subexp opers errVal t $ liftM unparTerm $ lookupResDef gr m c _ -> C.composSafeOp unparTerm t - gr = M.MGrammar [mo] + gr = M.MGrammar [sm] rebuild = buildTree . concat -- implementation diff --git a/src-3.0/GF/Compile/Rebuild.hs b/src-3.0/GF/Compile/Rebuild.hs index b24373ba4..6dd6cf204 100644 --- a/src-3.0/GF/Compile/Rebuild.hs +++ b/src-3.0/GF/Compile/Rebuild.hs @@ -62,14 +62,14 @@ rebuildModule ms mo@(i,mi) = do -- add the instance opens to an incomplete module "with" instances -- ModWith mt stat ext me ops -> do - ModWith (Module mt stat fs_ me ops_ js_) (ext,incl) ops -> do + ModWith (Module mt stat fs_ me ops_ js_ ps_) (ext,incl) 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 ps0 <- lookupModMod gr ext let ops1 = nub $ ops_ ++ -- N.B. js has been name-resolved already ops ++ [o | o <- ops0, notElem (openedModule o) infs] @@ -80,7 +80,8 @@ rebuildModule ms mo@(i,mi) = do let fs1 = addModuleOptions fs fs_ -- new flags have priority let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c] let js1 = buildTree (tree2list js_ ++ js0) - return $ ModMod $ Module mt0 stat' fs1 me ops1 js1 + let ps1 = buildTree (tree2list ps_ ++ tree2list ps0) + return $ ModMod $ Module mt0 stat' fs1 me ops1 js1 ps1 ---- (mapTree (qualifInstanceInfo insts) js) -- not needed _ -> return mi diff --git a/src-3.0/GF/Grammar/Refresh.hs b/src-3.0/GF/Compile/Refresh.hs similarity index 93% rename from src-3.0/GF/Grammar/Refresh.hs rename to src-3.0/GF/Compile/Refresh.hs index bc77c1837..09c384266 100644 --- a/src-3.0/GF/Grammar/Refresh.hs +++ b/src-3.0/GF/Compile/Refresh.hs @@ -12,7 +12,7 @@ -- (Description of the module) ----------------------------------------------------------------------------- -module GF.Grammar.Refresh (refreshTerm, refreshTermN, +module GF.Compile.Refresh (refreshTerm, refreshTermN, refreshModule ) where @@ -110,9 +110,9 @@ refreshGrammar = liftM (MGrammar . snd) . foldM refreshModule (0,[]) . modules refreshModule :: (Int,[SourceModule]) -> SourceModule -> Err (Int,[SourceModule]) refreshModule (k,ms) mi@(i,m) = case m of - ModMod mo@(Module mt fs st me ops js) | (isModCnc mo || isModRes mo) -> do - (k',js') <- foldM refreshRes (k,[]) $ tree2list js - return (k', (i, ModMod(Module mt fs st me ops (buildTree js'))) : ms) + ModMod mo | (isModCnc mo || isModRes mo) -> do + (k',js') <- foldM refreshRes (k,[]) $ tree2list $ jments mo + return (k', (i, ModMod(replaceJudgements mo (buildTree js'))) : ms) _ -> return (k, mi:ms) where refreshRes (k,cs) ci@(c,info) = case info of diff --git a/src-3.0/GF/Compile/RemoveLiT.hs b/src-3.0/GF/Compile/RemoveLiT.hs index 02ff58bc7..d06b80400 100644 --- a/src-3.0/GF/Compile/RemoveLiT.hs +++ b/src-3.0/GF/Compile/RemoveLiT.hs @@ -34,9 +34,9 @@ removeLiT gr = liftM MGrammar $ mapM (remlModule gr) (modules gr) remlModule :: SourceGrammar -> (Ident,SourceModInfo) -> Err (Ident,SourceModInfo) remlModule gr mi@(name,mod) = case mod of - ModMod (Module mt st fs me ops js) -> do - js1 <- mapMTree (remlResInfo gr) js - let mod2 = ModMod $ Module mt st fs me ops js1 + ModMod mo -> do + js1 <- mapMTree (remlResInfo gr) (jments mo) + let mod2 = ModMod $ mo {jments = js1} return $ (name,mod2) _ -> return mi diff --git a/src-3.0/GF/Compile/Rename.hs b/src-3.0/GF/Compile/Rename.hs index 312dcb2dd..83bb97d50 100644 --- a/src-3.0/GF/Compile/Rename.hs +++ b/src-3.0/GF/Compile/Rename.hs @@ -55,11 +55,11 @@ renameSourceTerm g m t = do renameModule :: [SourceModule] -> SourceModule -> Err [SourceModule] renameModule ms (name,mod) = errIn ("renaming module" +++ prt name) $ case mod of - ModMod m@(Module mt st fs me ops js) -> do - let js1 = jments m + ModMod mo -> do + let js1 = jments mo status <- buildStatus (MGrammar ms) name mod js2 <- mapsErrTree (renameInfo status) js1 - let mod2 = ModMod $ Module mt st fs me (map forceQualif ops) js2 + let mod2 = ModMod $ mo {opens = map forceQualif (opens mo), jments = js2} return $ (name,mod2) : ms type Status = (StatusTree, [(OpenSpec Ident, StatusTree)]) diff --git a/src-3.0/GF/Compile/TypeCheck.hs b/src-3.0/GF/Compile/TypeCheck.hs index 0347dbab8..2d58a33ee 100644 --- a/src-3.0/GF/Compile/TypeCheck.hs +++ b/src-3.0/GF/Compile/TypeCheck.hs @@ -23,7 +23,7 @@ import GF.Data.Operations import GF.Data.Zipper import GF.Grammar.Abstract -import GF.Grammar.Refresh +import GF.Compile.Refresh import GF.Grammar.LookAbs import qualified GF.Grammar.Lookup as Lookup --- import GF.Grammar.Unify --- diff --git a/src-3.0/GF/Grammar/MMacros.hs b/src-3.0/GF/Grammar/MMacros.hs index a7b9bad94..f2a0f2cb2 100644 --- a/src-3.0/GF/Grammar/MMacros.hs +++ b/src-3.0/GF/Grammar/MMacros.hs @@ -20,7 +20,7 @@ import GF.Data.Zipper import GF.Grammar.Grammar import GF.Grammar.PrGrammar import GF.Infra.Ident -import GF.Grammar.Refresh +import GF.Compile.Refresh import GF.Grammar.Values ----import GrammarST import GF.Grammar.Macros diff --git a/src-3.0/GF/Infra/Modules.hs b/src-3.0/GF/Infra/Modules.hs index 8f9edbc68..001818d46 100644 --- a/src-3.0/GF/Infra/Modules.hs +++ b/src-3.0/GF/Infra/Modules.hs @@ -68,7 +68,8 @@ data Module i a = Module { flags :: ModuleOptions, extend :: [(i,MInclude i)], opens :: [OpenSpec i] , - jments :: BinTree i a + jments :: BinTree i a , + positions :: BinTree i (String,(Int,Int)) -- file, first line, last line } --- deriving Show instance Show (Module i a) where @@ -116,15 +117,15 @@ updateMGrammar old new = MGrammar $ ns = modules new updateModule :: Ord i => Module i t -> i -> t -> Module i t -updateModule (Module mt ms fs me ops js) i t = - Module mt ms fs me ops (updateTree (i,t) js) +updateModule (Module mt ms fs me ops js ps) i t = + Module mt ms fs me ops (updateTree (i,t) js) ps replaceJudgements :: Module i t -> BinTree i t -> Module i t -replaceJudgements (Module mt ms fs me ops _) js = Module mt ms fs me ops js +replaceJudgements (Module mt ms fs me ops _ ps) js = Module mt ms fs me ops js ps addOpenQualif :: i -> i -> Module i t -> Module i t -addOpenQualif i j (Module mt ms fs me ops js) = - Module mt ms fs me (oQualif i j : ops) js +addOpenQualif i j (Module mt ms fs me ops js ps) = + Module mt ms fs me (oQualif i j : ops) js ps addFlag :: ModuleOptions -> Module i t -> Module i t addFlag f mo = mo {flags = addModuleOptions (flags mo) f} @@ -267,7 +268,8 @@ emptyModInfo :: ModInfo i a emptyModInfo = ModMod emptyModule emptyModule :: Module i a -emptyModule = Module MTResource MSComplete noModuleOptions [] [] emptyBinTree +emptyModule = Module + MTResource MSComplete noModuleOptions [] [] emptyBinTree emptyBinTree -- | we store the module type with the identifier data IdentM i = IdentM { diff --git a/src-3.0/GF/Source/SourceToGrammar.hs b/src-3.0/GF/Source/SourceToGrammar.hs index 2ab1d58ac..ca4f488ea 100644 --- a/src-3.0/GF/Source/SourceToGrammar.hs +++ b/src-3.0/GF/Source/SourceToGrammar.hs @@ -99,6 +99,8 @@ transModDef x = case x of mkBody (mstat', trDef, mtyp', id') body where + poss = emptyBinTree ---- + mkBody xx@(mstat', trDef, mtyp', id') bod = case bod of MNoBody incls -> do mkBody xx $ MBody (Ext incls) NoOpens [] @@ -108,13 +110,13 @@ transModDef x = case x of defs0 <- mapM trDef $ getTopDefs defs defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds] flags' <- return $ concatModuleOptions [o | Right o <- defs0] - return (id',GM.ModMod (GM.Module mtyp' mstat' flags' extends' opens' defs')) + return (id',GM.ModMod (GM.Module mtyp' mstat' flags' extends' opens' defs' poss)) MReuse _ -> do - return (id', GM.ModMod (GM.Module mtyp' mstat' noModuleOptions [] [] emptyBinTree)) + return (id', GM.ModMod (GM.Module mtyp' mstat' noModuleOptions [] [] emptyBinTree poss)) MUnion imps -> do imps' <- mapM transIncluded imps return (id', - GM.ModMod (GM.Module (GM.MTUnion mtyp' imps') mstat' noModuleOptions [] [] emptyBinTree)) + GM.ModMod (GM.Module (GM.MTUnion mtyp' imps') mstat' noModuleOptions [] [] emptyBinTree poss)) MWith m insts -> mkBody xx $ MWithEBody [] m insts NoOpens [] MWithBody m insts opens defs -> mkBody xx $ MWithEBody [] m insts opens defs @@ -128,7 +130,7 @@ transModDef x = case x of defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds] flags' <- return $ concatModuleOptions [o | Right o <- defs0] return (id', - GM.ModWith (GM.Module mtyp' mstat' flags' extends' opens' defs') m' insts') + GM.ModWith (GM.Module mtyp' mstat' flags' extends' opens' defs' poss) m' insts') mkModRes id mtyp body = do id' <- transIdent id