From d95ca4a103c9023aa104b25acdc9c21418de6a14 Mon Sep 17 00:00:00 2001 From: krasimir Date: Mon, 19 Jan 2009 13:23:03 +0000 Subject: [PATCH] refactor the GF.Grammar.Grammar syntax. The obsolete constructions are removed --- src/GF/Compile.hs | 10 +- src/GF/Compile/BackOpt.hs | 7 +- src/GF/Compile/CheckGrammar.hs | 34 ++--- src/GF/Compile/Coding.hs | 15 +- src/GF/Compile/Extend.hs | 13 +- src/GF/Compile/GrammarToGFCC.hs | 30 ++-- src/GF/Compile/ModDeps.hs | 25 ++- src/GF/Compile/Optimize.hs | 42 +++-- src/GF/Compile/OptimizeGF.hs | 37 ++--- src/GF/Compile/Rebuild.hs | 25 ++- src/GF/Compile/Refresh.hs | 8 +- src/GF/Compile/RemoveLiT.hs | 15 +- src/GF/Compile/Rename.hs | 55 +++---- src/GF/Compile/Update.hs | 8 +- src/GF/Grammar/Grammar.hs | 12 +- src/GF/Grammar/LookAbs.hs | 30 ++-- src/GF/Grammar/Lookup.hs | 147 ++++++++---------- src/GF/Grammar/PrGrammar.hs | 6 +- src/GF/Infra/Dependencies.hs | 2 +- src/GF/Infra/Modules.hs | 253 +++++++++++-------------------- src/GF/Source/CF.hs | 4 +- src/GF/Source/GrammarToSource.hs | 19 +-- src/GF/Source/SourceToGrammar.hs | 53 +------ src/exper/Evaluate.hs | 2 +- src/exper/Optimize.hs | 15 +- 25 files changed, 325 insertions(+), 542 deletions(-) diff --git a/src/GF/Compile.hs b/src/GF/Compile.hs index e7e16013c..e4804bd18 100644 --- a/src/GF/Compile.hs +++ b/src/GF/Compile.hs @@ -39,6 +39,7 @@ import System.Time import qualified Data.Map as Map import qualified Data.Set as Set import Data.List(nub) +import Data.Maybe (isNothing) import PGF.Check import PGF.CId @@ -172,12 +173,9 @@ compileOne opts env@(_,srcgr,_) file = do -- sm is optimized before generation, but not in the env extendCompileEnvInt env k' (Just gfo) sm1 where - isConcr (_,mi) = case mi of - ModMod m -> isModCnc m && mstatus m /= MSIncomplete - _ -> False + isConcr (_,m) = isModCnc m && mstatus m /= MSIncomplete && isNothing (mwith m) -compileSourceModule :: Options -> CompileEnv -> - SourceModule -> IOE (Int,SourceModule) +compileSourceModule :: Options -> CompileEnv -> SourceModule -> IOE (Int,SourceModule) compileSourceModule opts env@(k,gr,_) mo@(i,mi) = do let putp = putPointE Normal opts @@ -191,7 +189,7 @@ compileSourceModule opts env@(k,gr,_) mo@(i,mi) = do intermOut opts DumpExtend (prModule mo1b) case mo1b of - (_,ModMod n) | not (isCompleteModule n) -> do + (_,n) | not (isCompleteModule n) -> do return (k,mo1b) -- refresh would fail, since not renamed _ -> do mo2:_ <- putpp " renaming " $ ioeErr $ renameModule mos mo1b diff --git a/src/GF/Compile/BackOpt.hs b/src/GF/Compile/BackOpt.hs index aeb3bcb8d..484b1f1f0 100644 --- a/src/GF/Compile/BackOpt.hs +++ b/src/GF/Compile/BackOpt.hs @@ -32,11 +32,8 @@ import qualified Data.Set as Set type OptSpec = Set Optimization -shareModule :: OptSpec -> (Ident, SourceModInfo) -> (Ident, SourceModInfo) -shareModule opt (i,m) = case m of - M.ModMod mo -> - (i,M.ModMod (M.replaceJudgements mo (mapTree (shareInfo opt) (M.jments mo)))) - _ -> (i,m) +shareModule :: OptSpec -> SourceModule -> SourceModule +shareModule opt (i,mo) = (i,M.replaceJudgements mo (mapTree (shareInfo opt) (M.jments mo))) shareInfo :: OptSpec -> (Ident, Info) -> Info shareInfo opt (c, CncCat ty (Yes t) m) = CncCat ty (Yes (shareOptim opt c t)) m diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs index 5b9e6d923..2d93394e3 100644 --- a/src/GF/Compile/CheckGrammar.hs +++ b/src/GF/Compile/CheckGrammar.hs @@ -63,9 +63,7 @@ mapsCheckTree f = checkErr . mapsErrTree (\t -> checkStart (f t) >>= return . fs -- | checking is performed in the dependency order of modules checkModule :: [SourceModule] -> SourceModule -> Check [SourceModule] -checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod of - - ModMod mo -> do +checkModule ms (name,mo) = checkIn ("checking module" +++ prt name) $ do let js = jments mo checkRestrictedInheritance ms (name, mo) js' <- case mtype mo of @@ -77,29 +75,25 @@ checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod MTConcrete a -> do checkErr $ topoSortOpers $ allOperDependencies name js - ModMod abs <- checkErr $ lookupModule gr a + abs <- checkErr $ lookupModule gr a js1 <- checkCompleteGrammar abs mo mapsCheckTree (checkCncInfo gr name mo (a,abs)) js1 MTInterface -> mapsCheckTree (checkResInfo gr name mo) js MTInstance a -> do - -- ModMod abs <- checkErr $ lookupModule gr a - -- checkCompleteInstance abs mo -- this is done in Rebuild mapsCheckTree (checkResInfo gr name mo) js - return $ (name, ModMod (replaceJudgements mo js')) : ms - - _ -> return $ (name,mod) : ms + return $ (name, replaceJudgements mo js') : ms where - gr = MGrammar $ (name,mod):ms + gr = MGrammar $ (name,mo):ms -- check if restricted inheritance modules are still coherent -- i.e. that the defs of remaining names don't depend on omitted names ----checkRestrictedInheritance :: [SourceModule] -> SourceModule -> Check () +checkRestrictedInheritance :: [SourceModule] -> SourceModule -> Check () checkRestrictedInheritance mos (name,mo) = do let irs = [ii | ii@(_,mi) <- extend mo, mi /= MIAll] -- names with restr. inh. - let mrs = [((i,m),mi) | (i,ModMod m) <- mos, Just mi <- [lookup i irs]] + let mrs = [((i,m),mi) | (i,m) <- mos, Just mi <- [lookup i irs]] -- the restr. modules themself, with restr. infos mapM_ checkRem mrs where @@ -115,10 +109,7 @@ checkRestrictedInheritance mos (name,mo) = do ", dependence of excluded constants:" ++++ unlines [" " ++ prt f +++ "on" +++ unwords (map prt is) | (f,is) <- cs] - allDeps = ---- transClosure $ Map.fromList $ - concatMap (allDependencies (const True)) - [jments m | (_,ModMod m) <- mos] - transClosure ds = ds ---- TODO: check in deeper modules + allDeps = concatMap (allDependencies (const True) . jments . snd) mos -- | check if a term is typable justCheckLTerm :: SourceGrammar -> Term -> Err Term @@ -127,7 +118,7 @@ justCheckLTerm src t = do return t' checkAbsInfo :: - SourceGrammar -> Ident -> Module Ident Info -> (Ident,Info) -> Check (Ident,Info) + SourceGrammar -> Ident -> SourceModInfo -> (Ident,Info) -> Check (Ident,Info) checkAbsInfo st m mo (c,info) = do ---- checkReservedId c case info of @@ -183,7 +174,7 @@ checkAbsInfo st m mo (c,info) = do R fs -> mkApp t (map (snd . snd) fs) _ -> mkApp t [a] -checkCompleteGrammar :: SourceAbs -> SourceCnc -> Check (BinTree Ident Info) +checkCompleteGrammar :: SourceModInfo -> SourceModInfo -> Check (BinTree Ident Info) checkCompleteGrammar abs cnc = do let jsa = jments abs let fsa = tree2list jsa @@ -227,8 +218,7 @@ checkCompleteGrammar abs cnc = do -- | General Principle: only Yes-values are checked. -- A May-value has always been checked in its origin module. -checkResInfo :: - SourceGrammar -> Ident -> Module Ident Info -> (Ident,Info) -> Check (Ident,Info) +checkResInfo :: SourceGrammar -> Ident -> SourceModInfo -> (Ident,Info) -> Check (Ident,Info) checkResInfo gr mo mm (c,info) = do checkReservedId c case info of @@ -281,8 +271,8 @@ checkResInfo gr mo mm (c,info) = do _ -> return () -checkCncInfo :: SourceGrammar -> Ident -> Module Ident Info -> - (Ident,SourceAbs) -> +checkCncInfo :: SourceGrammar -> Ident -> SourceModInfo -> + (Ident,SourceModInfo) -> (Ident,Info) -> Check (Ident,Info) checkCncInfo gr m mo (a,abs) (c,info) = do checkReservedId c diff --git a/src/GF/Compile/Coding.hs b/src/GF/Compile/Coding.hs index 665b5916d..088f7b8e8 100644 --- a/src/GF/Compile/Coding.hs +++ b/src/GF/Compile/Coding.hs @@ -14,17 +14,14 @@ encodeStringsInModule :: SourceModule -> SourceModule encodeStringsInModule = codeSourceModule encodeUTF8 decodeStringsInModule :: SourceModule -> SourceModule -decodeStringsInModule mo = case mo of - (_,ModMod m) -> case flag optEncoding (flags m) of - UTF_8 -> codeSourceModule decodeUTF8 mo +decodeStringsInModule mo = + case flag optEncoding (flagsModule mo) of + UTF_8 -> codeSourceModule decodeUTF8 mo CP_1251 -> codeSourceModule decodeCP1251 mo - _ -> mo - _ -> mo + _ -> mo -codeSourceModule :: (String -> String) -> SourceModule -> SourceModule -codeSourceModule co (id,moi) = case moi of - ModMod mo -> (id, ModMod $ replaceJudgements mo (mapTree codj (jments mo))) - _ -> (id,moi) +codeSourceModule :: (String -> String) -> SourceModule -> SourceModule +codeSourceModule co (id,mo) = (id,replaceJudgements mo (mapTree codj (jments mo))) where codj (c,info) = case info of ResOper pty pt -> ResOper (mapP codt pty) (mapP codt pt) diff --git a/src/GF/Compile/Extend.hs b/src/GF/Compile/Extend.hs index 8344a1696..4cf2101de 100644 --- a/src/GF/Compile/Extend.hs +++ b/src/GF/Compile/Extend.hs @@ -29,20 +29,17 @@ import GF.Data.Operations import Control.Monad extendModule :: [SourceModule] -> SourceModule -> Err SourceModule -extendModule ms (name,mod) = case mod of - +extendModule ms (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 - ModMod m | mstatus m == MSIncomplete && isModCnc m -> return (name,mod) - - ModMod m -> do - mod' <- foldM extOne m (extend m) - return (name,ModMod mod') + | mstatus m == MSIncomplete && isModCnc m = return (name,m) + | otherwise = do m' <- foldM extOne m (extend m) + return (name,m') where extOne mo (n,cond) = do (m0,isCompl) <- do - m <- lookupModMod (MGrammar ms) n + m <- lookupModule (MGrammar ms) n -- test that the module types match, and find out if the old is complete testErr (sameMType (mtype m) (mtype mo)) diff --git a/src/GF/Compile/GrammarToGFCC.hs b/src/GF/Compile/GrammarToGFCC.hs index 27c732573..81029117d 100644 --- a/src/GF/Compile/GrammarToGFCC.hs +++ b/src/GF/Compile/GrammarToGFCC.hs @@ -58,7 +58,7 @@ addParsers opts pgf = CM.mapConcretes conv pgf -- this assumes a grammar translated by canon2canon canon2gfcc :: Options -> (Ident -> Ident -> C.Term) -> SourceGrammar -> D.PGF -canon2gfcc opts pars cgr@(M.MGrammar ((a,M.ModMod abm):cms)) = +canon2gfcc opts pars cgr@(M.MGrammar ((a,abm):cms)) = (if dump opts DumpCanon then trace (prGrammar cgr) else id) $ D.PGF an cns gflags abs cncs where @@ -82,7 +82,7 @@ canon2gfcc opts pars cgr@(M.MGrammar ((a,M.ModMod abm):cms)) = catfuns = Map.fromList [(cat,[f | (f, (C.DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats] - cncs = Map.fromList [mkConcr lang (i2i lang) mo | (lang,M.ModMod mo) <- cms] + cncs = Map.fromList [mkConcr lang (i2i lang) mo | (lang,mo) <- cms] mkConcr lang0 lang mo = (lang,D.Concr flags lins opers lincats lindefs printnames params fcfg) where @@ -223,20 +223,18 @@ 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 poss): - [(c, M.ModMod $ - M.Module (M.MTConcrete abs) M.MSComplete fs [] [] (sorted2tree js) poss) + (abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] adefs poss): + [(c, M.ModInfo (M.MTConcrete abs) M.MSComplete fs [] Nothing [] (sorted2tree js) poss) | (c,(fs,js)) <- cncs] where poss = emptyBinTree -- positions no longer needed - mos = M.allModMod cg + mos = M.modules cg adefs = sorted2tree $ sortIds $ predefADefs ++ Look.allOrigInfos cg abs predefADefs = [(c, AbsCat (Yes []) Nope) | c <- [cFloat,cInt,cString]] aflags = - concatOptions [M.flags mo | (_,mo) <- M.allModMod cg, M.isModAbs mo] + concatOptions [M.flags mo | (_,mo) <- M.modules cg, M.isModAbs mo] cncs = sortIds [(lang, concr lang) | lang <- M.allConcretes cg abs] concr la = (flags, @@ -257,7 +255,7 @@ reorder abs cg = M.MGrammar $ repartition :: Ident -> SourceGrammar -> [SourceGrammar] repartition abs cg = [M.partOfGrammar cg (lang,mo) | - let mos = M.allModMod cg, + let mos = M.modules cg, lang <- case M.allConcretes cg abs of [] -> [abs] -- to make pgf nonempty even when there are no concretes cncs -> cncs, @@ -276,10 +274,8 @@ canon2canon opts abs cg0 = js2js ms = map (c2c (j2j (M.MGrammar ms))) ms - c2c f2 (c,m) = case m of - M.ModMod mo -> - (c, M.ModMod $ M.replaceJudgements mo $ mapTree f2 (M.jments mo)) - _ -> (c,m) + c2c f2 (c,mo) = (c, M.replaceJudgements mo $ mapTree f2 (M.jments mo)) + j2j cg (f,j) = let debug = if verbAtLeast opts Verbose then trace ("+ " ++ prt f) else id in case j of @@ -323,7 +319,7 @@ purgeGrammar abstr gr = needed = nub $ concatMap (requiredCanModules isSingle gr) acncs acncs = abstr : M.allConcretes gr abstr isSingle = True - complete (i,M.ModMod m) = M.isCompleteModule m --- not . isIncompleteCanon + complete (i,m) = M.isCompleteModule m --- not . isIncompleteCanon unopt = unshareModule gr -- subexp elim undone when compiled type ParamEnv = @@ -373,7 +369,7 @@ paramValues cgr = (labels,untyps,typs) where updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr _ -> GM.composOp typsFromTrm tr - mods = traceD (unwords (map (prt . fst) ms)) ms where ms = M.allModMod cgr + mods = traceD (unwords (map (prt . fst) ms)) ms where ms = M.modules cgr jments = [(m,j) | (m,mo) <- mods, j <- tree2list $ M.jments mo] @@ -555,8 +551,8 @@ requiredCanModules isSingle gr c = nub $ filter notReuse ops ++ exts where then map fst (M.modules gr) else iterFix (concatMap more) $ exts more i = errVal [] $ do - m <- M.lookupModMod gr i + m <- M.lookupModule gr i return $ M.extends m ++ [o | o <- map M.openedModule (M.opens m)] notReuse i = errVal True $ do - m <- M.lookupModMod gr i + m <- M.lookupModule gr i return $ M.isModRes m -- to exclude reused Cnc and Abs from required diff --git a/src/GF/Compile/ModDeps.hs b/src/GF/Compile/ModDeps.hs index b5b1b798c..8bfead11b 100644 --- a/src/GF/Compile/ModDeps.hs +++ b/src/GF/Compile/ModDeps.hs @@ -36,7 +36,7 @@ import Data.List -- | to check uniqueness of module names and import names, the -- appropriateness of import and extend types, -- to build a dependency graph of modules, and to sort them topologically -mkSourceGrammar :: [(Ident,SourceModInfo)] -> Err SourceGrammar +mkSourceGrammar :: [SourceModule] -> Err SourceGrammar mkSourceGrammar ms = do let ns = map fst ms checkUniqueErr ns @@ -55,23 +55,18 @@ checkUniqueErr ms = do -- | check that import names don't clash with module names checkUniqueImportNames :: [Ident] -> SourceModInfo -> Err () -checkUniqueImportNames ns mo = case mo of - ModMod m -> test [n | OQualif _ n v <- opens m, n /= v] - _ -> return () --- Bad $ "bug: ModDeps does not treat" +++ show mo +checkUniqueImportNames ns mo = test [n | OQualif n v <- opens mo, n /= v] where - - test ms = testErr (all (`notElem` ns) ms) - ("import names clashing with module names among" +++ - unwords (map prt ms)) + test ms = testErr (all (`notElem` ns) ms) + ("import names clashing with module names among" +++ unwords (map prt ms)) type Dependencies = [(IdentM Ident,[IdentM Ident])] -- | to decide what modules immediately depend on what, and check if the -- dependencies are appropriate -moduleDeps :: [(Ident,SourceModInfo)] -> Err Dependencies +moduleDeps :: [SourceModule] -> Err Dependencies moduleDeps ms = mapM deps ms where - deps (c,mi) = errIn ("checking dependencies of module" +++ prt c) $ case mi of - ModMod m -> case mtype m of + deps (c,m) = errIn ("checking dependencies of module" +++ prt c) $ case mtype m of MTConcrete a -> do aty <- lookupModuleType gr a testErr (aty == MTAbstract) "the of-module is not an abstract syntax" @@ -98,7 +93,6 @@ moduleDeps ms = mapM deps ms where (MTInterface, MTAbstract) -> True (MTConcrete _, MTConcrete _) -> True (MTInstance _, MTInstance _) -> True - (MTReuse _, MTReuse _) -> True (MTInstance _, MTResource) -> True (MTResource, MTInstance _) -> True ---- some more? @@ -109,7 +103,6 @@ moduleDeps ms = mapM deps ms where MTTransfer _ _ -> mt == MTAbstract _ -> case mt of MTResource -> True - MTReuse _ -> True MTInterface -> True MTInstance _ -> True _ -> False @@ -129,13 +122,13 @@ requiredCanModules :: (Ord i, Show i) => Bool -> MGrammar i a -> i -> [i] requiredCanModules isSingle gr c = nub $ filter notReuse ops ++ exts where exts = allExtends gr c ops = if isSingle - then map fst (modules gr) + then map fst (modules gr) else iterFix (concatMap more) $ exts more i = errVal [] $ do - m <- lookupModMod gr i + m <- lookupModule gr i return $ extends m ++ [o | o <- map openedModule (opens m)] notReuse i = errVal True $ do - m <- lookupModMod gr i + m <- lookupModule gr i return $ isModRes m -- to exclude reused Cnc and Abs from required diff --git a/src/GF/Compile/Optimize.hs b/src/GF/Compile/Optimize.hs index da18e6e3e..31564d444 100644 --- a/src/GF/Compile/Optimize.hs +++ b/src/GF/Compile/Optimize.hs @@ -49,40 +49,38 @@ prtIf b t = if b then trace (" " ++ prt t) t else t type EEnv = () --- not used -- only do this for resource: concrete is optimized in gfc form -optimizeModule :: Options -> ([(Ident,SourceModInfo)],EEnv) -> - (Ident,SourceModInfo) -> Err ((Ident,SourceModInfo),EEnv) -optimizeModule opts mse@(ms,eenv) mo@(_,mi) = case mi of - ModMod m0 | mstatus m0 == MSComplete && isModRes m0 -> do +optimizeModule :: Options -> ([SourceModule],EEnv) -> SourceModule -> Err (SourceModule,EEnv) +optimizeModule opts mse@(ms,eenv) mo@(_,mi) + | mstatus mi == MSComplete && isModRes mi = do (mo1,_) <- evalModule oopts mse mo let mo2 = shareModule optim mo1 return (mo2,eenv) - _ -> evalModule oopts mse mo + | otherwise = evalModule oopts mse mo where oopts = opts `addOptions` flagsModule mo optim = flag optOptimizations oopts -evalModule :: Options -> ([(Ident,SourceModInfo)],EEnv) -> (Ident,SourceModInfo) -> - Err ((Ident,SourceModInfo),EEnv) -evalModule oopts (ms,eenv) mo@(name,mod) = case mod of +evalModule :: Options -> ([SourceModule],EEnv) -> SourceModule -> Err (SourceModule,EEnv) +evalModule oopts (ms,eenv) mo@(name,m0) + | mstatus m0 == MSComplete = + case mtype m0 of + _ | isModRes m0 -> do + let deps = allOperDependencies name (jments m0) + ids <- topoSortOpers deps + MGrammar (mod' : _) <- foldM evalOp gr ids + return $ (mod',eenv) - ModMod m0 | mstatus m0 == MSComplete -> case mtype m0 of - _ | isModRes m0 -> do - 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) (jments m0) + return $ ((name,replaceJudgements m0 js'),eenv) - MTConcrete a -> do - js' <- mapMTree (evalCncInfo oopts gr name a) (jments m0) - return $ ((name, ModMod (replaceJudgements m0 js')),eenv) - - _ -> return $ ((name,mod),eenv) - _ -> return $ ((name,mod),eenv) + _ -> return $ (mo,eenv) + | otherwise = return $ (mo,eenv) where gr0 = MGrammar $ ms - gr = MGrammar $ (name,mod) : ms + gr = MGrammar $ mo : ms - evalOp g@(MGrammar ((_, ModMod m) : _)) i = do + evalOp g@(MGrammar ((_,m) : _)) i = do info <- lookupTree prt i $ jments m info' <- evalResInfo oopts gr (i,info) return $ updateRes g name i info' diff --git a/src/GF/Compile/OptimizeGF.hs b/src/GF/Compile/OptimizeGF.hs index 785d73994..27627b137 100644 --- a/src/GF/Compile/OptimizeGF.hs +++ b/src/GF/Compile/OptimizeGF.hs @@ -33,23 +33,19 @@ import qualified Data.Map as Map import qualified Data.ByteString.Char8 as BS import Data.List -optModule :: (Ident, SourceModInfo) -> (Ident, SourceModInfo) +optModule :: SourceModule -> SourceModule optModule = subexpModule . shareModule shareModule = processModule optim -unoptModule :: SourceGrammar -> (Ident, SourceModInfo) -> (Ident, SourceModInfo) +unoptModule :: SourceGrammar -> SourceModule -> SourceModule unoptModule gr = unshareModule gr . unsubexpModule -unshareModule :: SourceGrammar -> (Ident, SourceModInfo) -> (Ident, SourceModInfo) +unshareModule :: SourceGrammar -> SourceModule -> SourceModule unshareModule gr = processModule (const (unoptim gr)) -processModule :: - (Ident -> Term -> Term) -> (Ident, SourceModInfo) -> (Ident, SourceModInfo) -processModule opt (i,m) = case m of - M.ModMod mo -> - (i,M.ModMod (M.replaceJudgements mo (mapTree (shareInfo opt) (M.jments mo)))) - _ -> (i,m) +processModule :: (Ident -> Term -> Term) -> SourceModule -> SourceModule +processModule opt (i,mo) = (i,M.replaceJudgements mo (mapTree (shareInfo opt) (M.jments mo))) shareInfo :: (Ident -> Term -> Term) -> (Ident,Info) -> Info shareInfo opt (c, CncCat ty (Yes t) m) = CncCat ty (Yes (opt c t)) m @@ -169,22 +165,19 @@ cse is possible in the grammar. It is used by the flag pg -printer=subs. -} subexpModule :: SourceModule -> SourceModule -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) +subexpModule (n,mo) = errVal (n,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.replaceJudgements mo js2) unsubexpModule :: SourceModule -> SourceModule -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 (M.jments mo) - _ -> (i,m) +unsubexpModule sm@(i,mo) + | hasSub ljs = (i,M.replaceJudgements mo (rebuild (map unparInfo ljs))) + | otherwise = sm where + ljs = tree2list (M.jments mo) + -- perform this iff the module has opers hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs] unparInfo (c,info) = case info of diff --git a/src/GF/Compile/Rebuild.hs b/src/GF/Compile/Rebuild.hs index 04fc43d10..53f1ec0f1 100644 --- a/src/GF/Compile/Rebuild.hs +++ b/src/GF/Compile/Rebuild.hs @@ -27,6 +27,7 @@ import GF.Infra.Option import GF.Data.Operations import Data.List (nub) +import Data.Maybe (isNothing) -- | rebuilding instance + interface, and "with" modules, prior to renaming. -- AR 24/10/2003 @@ -39,13 +40,13 @@ rebuildModule ms mo@(i,mi) = do mi' <- case mi of -- add the information given in interface into an instance module - ModMod m -> do + m | isNothing (mwith m) -> do testErr (null is || mstatus m == MSIncomplete) ("module" +++ prt i +++ "has open interfaces and must therefore be declared incomplete") case mtype m of MTInstance i0 -> do - m1 <- lookupModMod gr i0 + m1 <- lookupModule gr i0 testErr (isModRes m1) ("interface expected instead of" +++ prt i0) m' <- do js' <- extendMod False (i0,const True) i (jments m1) (jments m) @@ -53,7 +54,7 @@ rebuildModule ms mo@(i,mi) = do case extends m of [] -> return $ replaceJudgements m js' j0s -> do - m0s <- mapM (lookupModMod gr) j0s + m0s <- mapM (lookupModule gr) j0s let notInM0 c _ = all (not . isInBinTree c . jments) m0s let js2 = filterBinTree notInM0 js' return $ (replaceJudgements m js2) @@ -61,37 +62,35 @@ rebuildModule ms mo@(i,mi) = do buildTree (tree2list (positions m1) ++ tree2list (positions m))} -- checkCompleteInstance m1 m' - return $ ModMod m' + return m' _ -> return mi -- 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_ ps_) (ext,incl) ops -> do - let insts = [(inf,inst) | OQualif _ inf inst <- ops] + ModInfo mt stat fs_ me (Just (ext,incl,ops)) ops_ js_ ps_ -> 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 ps0 <- lookupModMod gr ext + ModInfo mt0 _ fs me' _ ops0 js ps0 <- lookupModule gr ext let ops1 = nub $ ops_ ++ -- N.B. js has been name-resolved already ops ++ [o | o <- ops0, notElem (openedModule o) infs] - ++ [oQualif i i | i <- map snd insts] ---- - ++ [oSimple i | i <- map snd insts] ---- + ++ [OQualif i i | i <- map snd insts] ---- + ++ [OSimple i | i <- map snd insts] ---- --- check if me is incomplete let fs1 = fs `addOptions` fs_ -- new flags have priority let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c] let js1 = buildTree (tree2list js_ ++ js0) let ps1 = buildTree (tree2list ps_ ++ tree2list ps0) - return $ ModMod $ Module mt0 stat' fs1 me ops1 js1 ps1 - ---- (mapTree (qualifInstanceInfo insts) js) -- not needed + return $ ModInfo mt0 stat' fs1 me Nothing ops1 js1 ps1 _ -> return mi return (i,mi') -checkCompleteInstance :: SourceRes -> SourceRes -> Err () +checkCompleteInstance :: SourceModInfo -> SourceModInfo -> Err () checkCompleteInstance abs cnc = ifNull (return ()) (Bad . unlines) $ checkComplete [f | (f, ResOper (Yes _) _) <- abs'] cnc' where diff --git a/src/GF/Compile/Refresh.hs b/src/GF/Compile/Refresh.hs index 39fb57db0..d446008d0 100644 --- a/src/GF/Compile/Refresh.hs +++ b/src/GF/Compile/Refresh.hs @@ -109,11 +109,11 @@ refreshGrammar :: SourceGrammar -> Err SourceGrammar 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 | (isModCnc mo || isModRes mo) -> do +refreshModule (k,ms) mi@(i,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) + return (k', (i, replaceJudgements mo (buildTree js')) : ms) + | otherwise = return (k, mi:ms) where refreshRes (k,cs) ci@(c,info) = case info of ResOper ptyp (Yes trm) -> do ---- refresh ptyp diff --git a/src/GF/Compile/RemoveLiT.hs b/src/GF/Compile/RemoveLiT.hs index a641737eb..14a9a1da1 100644 --- a/src/GF/Compile/RemoveLiT.hs +++ b/src/GF/Compile/RemoveLiT.hs @@ -32,13 +32,10 @@ import Control.Monad removeLiT :: SourceGrammar -> Err SourceGrammar 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 mo -> do - js1 <- mapMTree (remlResInfo gr) (jments mo) - let mod2 = ModMod $ mo {jments = js1} - return $ (name,mod2) - _ -> return mi +remlModule :: SourceGrammar -> SourceModule -> Err SourceModule +remlModule gr mi@(name,mo) = do + js1 <- mapMTree (remlResInfo gr) (jments mo) + return (name,mo{jments = js1}) remlResInfo :: SourceGrammar -> (Ident,Info) -> Err Info remlResInfo gr (i,info) = case info of @@ -59,6 +56,6 @@ remlTerm gr trm = case trm of _ -> composOp (remlTerm gr) trm where look c = err (const $ return defLinType) return $ lookupLincat gr m c - m = case [cnc | (cnc,ModMod m) <- modules gr, isModCnc m] of + m = case [cnc | (cnc,m) <- modules gr, isModCnc m] of cnc:_ -> cnc -- actually there is always exactly one - _ -> cCNC + _ -> cCNC diff --git a/src/GF/Compile/Rename.hs b/src/GF/Compile/Rename.hs index bfa342702..ba14cb02e 100644 --- a/src/GF/Compile/Rename.hs +++ b/src/GF/Compile/Rename.hs @@ -49,18 +49,16 @@ renameGrammar g = liftM (MGrammar . reverse) $ foldM renameModule [] (modules g) -- | this gives top-level access to renaming term input in the cc command renameSourceTerm :: SourceGrammar -> Ident -> Term -> Err Term renameSourceTerm g m t = do - mo <- lookupErr m (modules g) + mo <- lookupModule g m status <- buildStatus g m mo renameTerm status [] t renameModule :: [SourceModule] -> SourceModule -> Err [SourceModule] -renameModule ms (name,mod) = errIn ("renaming module" +++ prt name) $ case mod of - ModMod mo -> do - let js1 = jments mo - status <- buildStatus (MGrammar ms) name mod - js2 <- mapsErrTree (renameInfo mo status) js1 - let mod2 = ModMod $ mo {opens = map forceQualif (opens mo), jments = js2} - return $ (name,mod2) : ms +renameModule ms (name,mo) = errIn ("renaming module" +++ prt name) $ do + let js1 = jments mo + status <- buildStatus (MGrammar ms) name mo + js2 <- mapsErrTree (renameInfo mo status) js1 + return $ (name, mo {opens = map forceQualif (opens mo), jments = js2}) : ms type Status = (StatusTree, [(OpenSpec Ident, StatusTree)]) @@ -86,9 +84,9 @@ renameIdentTerm env@(act,imps) t = return $ f c _ -> return t where - opens = [st | (OSimple _ _,st) <- imps] - qualifs = [(m, st) | (OQualif _ m _, st) <- imps] ++ - [(m, st) | (OSimple _ m, st) <- imps] -- qualif is always possible + opens = [st | (OSimple _,st) <- imps] + qualifs = [(m, st) | (OQualif m _, st) <- imps] ++ + [(m, st) | (OSimple m, st) <- imps] -- qualif is always possible -- this facility is mainly for BWC with GF1: you need not import PredefAbs predefAbs c s @@ -126,47 +124,38 @@ info2status mq (c,i) = case i of tree2status :: OpenSpec Ident -> BinTree Ident Info -> BinTree Ident StatusInfo tree2status o = case o of - OSimple _ i -> mapTree (info2status (Just i)) - OQualif _ i j -> mapTree (info2status (Just j)) + OSimple i -> mapTree (info2status (Just i)) + OQualif i j -> mapTree (info2status (Just j)) buildStatus :: SourceGrammar -> Ident -> SourceModInfo -> Err Status -buildStatus gr c mo = let mo' = self2status c mo in case mo of - ModMod m -> do - let gr1 = MGrammar $ (c,mo) : modules gr - ops = [OSimple OQNormal e | e <- allExtends gr1 c] ++ allOpens m +buildStatus gr c mo = let mo' = self2status c mo in do + let gr1 = MGrammar ((c,mo) : modules gr) + ops = [OSimple e | e <- allExtends gr1 c] ++ allOpens mo mods <- mapM (lookupModule gr1 . openedModule) ops let sts = map modInfo2status $ zip ops mods - return $ if isModCnc m + return $ if isModCnc mo then (emptyBinTree, reverse sts) -- the module itself does not define any names else (mo',reverse sts) -- so the empty ident is not needed modInfo2status :: (OpenSpec Ident,SourceModInfo) -> (OpenSpec Ident, StatusTree) -modInfo2status (o,i) = (o,case i of - ModMod m -> tree2status o (jments m) - ) +modInfo2status (o,mo) = (o,tree2status o (jments mo)) self2status :: Ident -> SourceModInfo -> StatusTree -self2status c i = mapTree (info2status (Just c)) js where -- qualify internal - js = case i of - ModMod m - | isModTrans m -> sorted2tree $ filter noTrans $ tree2list $ jments m - | otherwise -> jments m - noTrans (_,d) = case d of -- to enable other than transfer js in transfer module - AbsTrans _ -> False - _ -> True +self2status c m = mapTree (info2status (Just c)) js where -- qualify internal + js | isModTrans m = sorted2tree $ tree2list $ jments m + | otherwise = jments m forceQualif o = case o of - OSimple q i -> OQualif q i i - OQualif q _ i -> OQualif q i i + OSimple i -> OQualif i i + OQualif _ i -> OQualif i i -renameInfo :: Module Ident Info -> Status -> (Ident,Info) -> Err (Ident,Info) +renameInfo :: SourceModInfo -> Status -> (Ident,Info) -> Err (Ident,Info) renameInfo mo status (i,info) = errIn ("renaming definition of" +++ prt i +++ showPosition mo i) $ liftM ((,) i) $ case info of AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco) (renPerh (mapM rent) pfs) AbsFun pty ptr -> liftM2 AbsFun (ren pty) (ren ptr) - AbsTrans f -> liftM AbsTrans (rent f) ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr) ResOverload os tysts -> diff --git a/src/GF/Compile/Update.hs b/src/GF/Compile/Update.hs index 82d7a609e..a0aefeea5 100644 --- a/src/GF/Compile/Update.hs +++ b/src/GF/Compile/Update.hs @@ -32,11 +32,9 @@ import Control.Monad -- | update a resource module by adding a new or changing an old definition updateRes :: SourceGrammar -> Ident -> Ident -> Info -> SourceGrammar updateRes gr@(MGrammar ms) m i info = MGrammar $ map upd ms where - upd (n,mod) - | n /= m = (n,mod) - | n == m = case mod of - ModMod r -> (m,ModMod $ updateModule r i info) - _ -> (n,mod) --- no error msg + upd (n,mo) + | n /= m = (n,mo) + | n == m = (n,updateModule mo i info) -- | combine a list of definitions into a balanced binary search tree buildAnyTree :: [(Ident,Info)] -> Err (BinTree Ident Info) diff --git a/src/GF/Grammar/Grammar.hs b/src/GF/Grammar/Grammar.hs index a3735c32f..c1ec709f3 100644 --- a/src/GF/Grammar/Grammar.hs +++ b/src/GF/Grammar/Grammar.hs @@ -18,9 +18,6 @@ module GF.Grammar.Grammar (SourceGrammar, emptySourceGrammar, SourceModInfo, SourceModule, - SourceAbs, - SourceRes, - SourceCnc, mapSourceModule, Info(..), PValues, @@ -72,12 +69,8 @@ type SourceModInfo = ModInfo Ident Info type SourceModule = (Ident, SourceModInfo) -type SourceAbs = Module Ident Info -type SourceRes = Module Ident Info -type SourceCnc = Module Ident Info - -mapSourceModule :: (Module Ident Info -> Module Ident Info) -> SourceModule -> SourceModule -mapSourceModule f (i,mi) = (i, mapModules' f mi) +mapSourceModule :: (SourceModInfo -> SourceModInfo) -> (SourceModule -> SourceModule) +mapSourceModule f (i,mi) = (i, f mi) -- this is created in CheckGrammar, and so are Val and PVal type PValues = [Term] @@ -95,7 +88,6 @@ data Info = -- judgements in abstract syntax AbsCat (Perh Context) (Perh [Term]) -- ^ (/ABS/) constructors; must be 'Id' or 'QId' | AbsFun (Perh Type) (Perh Term) -- ^ (/ABS/) 'Yes f' = canonical - | AbsTrans Term -- ^ (/ABS/) -- judgements in resource | ResParam (Perh ([Param],Maybe PValues)) -- ^ (/RES/) diff --git a/src/GF/Grammar/LookAbs.hs b/src/GF/Grammar/LookAbs.hs index f9a251eb1..137e602aa 100644 --- a/src/GF/Grammar/LookAbs.hs +++ b/src/GF/Grammar/LookAbs.hs @@ -29,25 +29,19 @@ import Control.Monad -- | this is needed at compile time lookupFunType :: Grammar -> Ident -> Ident -> Err Type lookupFunType gr m c = do - mi <- lookupModule gr m - case mi of - ModMod mo -> do - info <- lookupIdentInfo mo c - case info of - AbsFun (Yes t) _ -> return t - AnyInd _ n -> lookupFunType gr n c - _ -> prtBad "cannot find type of" c - _ -> Bad $ prt m +++ "is not an abstract module" + mo <- lookupModule gr m + info <- lookupIdentInfo mo c + case info of + AbsFun (Yes t) _ -> return t + AnyInd _ n -> lookupFunType gr n c + _ -> prtBad "cannot find type of" c -- | this is needed at compile time lookupCatContext :: Grammar -> Ident -> Ident -> Err Context lookupCatContext gr m c = do - mi <- lookupModule gr m - case mi of - ModMod mo -> do - info <- lookupIdentInfo mo c - case info of - AbsCat (Yes co) _ -> return co - AnyInd _ n -> lookupCatContext gr n c - _ -> prtBad "unknown category" c - _ -> Bad $ prt m +++ "is not an abstract module" + mo <- lookupModule gr m + info <- lookupIdentInfo mo c + case info of + AbsCat (Yes co) _ -> return co + AnyInd _ n -> lookupCatContext gr n c + _ -> prtBad "unknown category" c diff --git a/src/GF/Grammar/Lookup.hs b/src/GF/Grammar/Lookup.hs index 4a11a0d3f..1dcb47a21 100644 --- a/src/GF/Grammar/Lookup.hs +++ b/src/GF/Grammar/Lookup.hs @@ -56,56 +56,50 @@ lookupResDefKind gr m c ---- was PredefAbs till 3/9/2008, with explanation: need this in gf3 12/6/2008 | otherwise = look True m c where look isTop m c = do - mi <- lookupModule gr m - case mi of - ModMod mo -> do - info <- lookupIdentInfoIn mo m c - case info of - ResOper _ (Yes t) -> return (qualifAnnot m t, 0) - ResOper _ Nope -> return (Q m c, 0) ---- if isTop then lookExt m c + mo <- lookupModule gr m + info <- lookupIdentInfoIn mo m c + case info of + ResOper _ (Yes t) -> return (qualifAnnot m t, 0) + ResOper _ Nope -> return (Q m c, 0) ---- if isTop then lookExt m c ---- else prtBad "cannot find in exts" c - CncCat (Yes ty) _ _ -> liftM (flip (,) 1) $ lock c ty - CncCat _ _ _ -> liftM (flip (,) 1) $ lock c defLinType - CncFun (Just (cat,_)) (Yes tr) _ -> liftM (flip (,) 1) $ unlock cat tr + CncCat (Yes ty) _ _ -> liftM (flip (,) 1) $ lock c ty + CncCat _ _ _ -> liftM (flip (,) 1) $ lock c defLinType + CncFun (Just (cat,_)) (Yes tr) _ -> liftM (flip (,) 1) $ unlock cat tr - CncFun _ (Yes tr) _ -> liftM (flip (,) 1) (return tr) ---- $ unlock c tr + CncFun _ (Yes tr) _ -> liftM (flip (,) 1) (return tr) ---- $ unlock c tr - AnyInd _ n -> look False n c - ResParam _ -> return (QC m c,2) - ResValue _ -> return (QC m c,2) - _ -> Bad $ prt c +++ "is not defined in resource" +++ prt m - _ -> Bad $ prt m +++ "is not a resource" + AnyInd _ n -> look False n c + ResParam _ -> return (QC m c,2) + ResValue _ -> return (QC m c,2) + _ -> Bad $ prt c +++ "is not defined in resource" +++ prt m lookExt m c = checks ([look False n c | n <- allExtensions gr m] ++ [return (Q m c,3)]) lookupResType :: SourceGrammar -> Ident -> Ident -> Err Type lookupResType gr m c = do - mi <- lookupModule gr m - case mi of - ModMod mo -> do - info <- lookupIdentInfo mo c - case info of - ResOper (Yes t) _ -> return $ qualifAnnot m t - ResOper (May n) _ -> lookupResType gr n c + mo <- lookupModule gr m + info <- lookupIdentInfo mo c + case info of + ResOper (Yes t) _ -> return $ qualifAnnot m t + ResOper (May n) _ -> lookupResType gr n c - -- used in reused concrete - CncCat _ _ _ -> return typeType - CncFun (Just (cat,(cont@(_:_),val))) _ _ -> do + -- used in reused concrete + CncCat _ _ _ -> return typeType + CncFun (Just (cat,(cont@(_:_),val))) _ _ -> do val' <- lock cat val return $ mkProd (cont, val', []) - CncFun _ _ _ -> lookFunType m m c - AnyInd _ n -> lookupResType gr n c - ResParam _ -> return $ typePType - ResValue (Yes (t,_)) -> return $ qualifAnnotPar m t - _ -> Bad $ prt c +++ "has no type defined in resource" +++ prt m - _ -> Bad $ prt m +++ "is not a resource" + CncFun _ _ _ -> lookFunType m m c + AnyInd _ n -> lookupResType gr n c + ResParam _ -> return $ typePType + ResValue (Yes (t,_)) -> return $ qualifAnnotPar m t + _ -> Bad $ prt c +++ "has no type defined in resource" +++ prt m where lookFunType e m c = do a <- abstractOfConcrete gr m lookFun e m c a lookFun e m c a = do - mu <- lookupModMod gr a + mu <- lookupModule gr a info <- lookupIdentInfo mu c case info of AbsFun (Yes ty) _ -> return $ redirectTerm e ty @@ -115,44 +109,35 @@ lookupResType gr m c = do lookupOverload :: SourceGrammar -> Ident -> Ident -> Err [([Type],(Type,Term))] lookupOverload gr m c = do - mi <- lookupModule gr m - case mi of - ModMod mo -> do - info <- lookupIdentInfo mo c - case info of - ResOverload os tysts -> do + mo <- lookupModule gr m + info <- lookupIdentInfo mo c + case info of + ResOverload os tysts -> do tss <- mapM (\x -> lookupOverload gr x c) os return $ [(map snd args,(val,tr)) | (ty,tr) <- tysts, Ok (args,val) <- [typeFormCnc ty]] ++ concat tss - AnyInd _ n -> lookupOverload gr n c - _ -> Bad $ prt c +++ "is not an overloaded operation" - _ -> Bad $ prt m +++ "is not a resource" + AnyInd _ n -> lookupOverload gr n c + _ -> Bad $ prt c +++ "is not an overloaded operation" lookupOrigInfo :: SourceGrammar -> Ident -> Ident -> Err Info lookupOrigInfo gr m c = do - mi <- lookupModule gr m - case mi of - ModMod mo -> do - info <- lookupIdentInfo mo c - case info of - AnyInd _ n -> lookupOrigInfo gr n c - i -> return i - _ -> Bad $ prt m +++ "is not run-time module" + mo <- lookupModule gr m + info <- lookupIdentInfo mo c + case info of + AnyInd _ n -> lookupOrigInfo gr n c + i -> return i lookupParams :: SourceGrammar -> Ident -> Ident -> Err ([Param],Maybe PValues) lookupParams gr = look True where look isTop m c = do - mi <- lookupModule gr m - case mi of - ModMod mo -> do - info <- lookupIdentInfo mo c - case info of - ResParam (Yes psm) -> return psm - AnyInd _ n -> look False n c - _ -> Bad $ prt c +++ "has no parameters defined in resource" +++ prt m - _ -> Bad $ prt m +++ "is not a resource" + mo <- lookupModule gr m + info <- lookupIdentInfo mo c + case info of + ResParam (Yes psm) -> return psm + AnyInd _ n -> look False n c + _ -> Bad $ prt c +++ "has no parameters defined in resource" +++ prt m lookExt m c = checks [look False n c | n <- allExtensions gr m] @@ -190,11 +175,10 @@ lookupIndexValue gr ty i = do allOrigInfos :: SourceGrammar -> Ident -> [(Ident,Info)] allOrigInfos gr m = errVal [] $ do - mi <- lookupModule gr m - case mi of - ModMod mo -> return [(c,i) | (c,_) <- tree2list (jments mo), Ok i <- [look c]] - where - look = lookupOrigInfo gr m + mo <- lookupModule gr m + return [(c,i) | (c,_) <- tree2list (jments mo), Ok i <- [look c]] + where + look = lookupOrigInfo gr m allParamValues :: SourceGrammar -> Type -> Err [Term] allParamValues cnc ptyp = case ptyp of @@ -225,36 +209,29 @@ qualifAnnotPar m t = case t of lookupAbsDef :: SourceGrammar -> Ident -> Ident -> Err (Maybe Term) lookupAbsDef gr m c = errIn ("looking up absdef of" +++ prt c) $ do - mi <- lookupModule gr m - case mi of - ModMod mo -> do - info <- lookupIdentInfo mo c - case info of - AbsFun _ (Yes t) -> return $ return t - AnyInd _ n -> lookupAbsDef gr n c - _ -> return Nothing - _ -> Bad $ prt m +++ "is not an abstract module" + mo <- lookupModule gr m + info <- lookupIdentInfo mo c + case info of + AbsFun _ (Yes t) -> return (Just t) + AnyInd _ n -> lookupAbsDef gr n c + _ -> return Nothing lookupLincat :: SourceGrammar -> Ident -> Ident -> Err Type lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed? lookupLincat gr m c = do - mi <- lookupModule gr m - case mi of - ModMod mo -> do - info <- lookupIdentInfo mo c - case info of - CncCat (Yes t) _ _ -> return t - AnyInd _ n -> lookupLincat gr n c - _ -> Bad $ prt c +++ "has no linearization type in" +++ prt m - _ -> Bad $ prt m +++ "is not concrete" - + mo <- lookupModule gr m + info <- lookupIdentInfo mo c + case info of + CncCat (Yes t) _ _ -> return t + AnyInd _ n -> lookupLincat gr n c + _ -> Bad $ prt c +++ "has no linearization type in" +++ prt m -- The first type argument is uncomputed, usually a category symbol. -- This is a hack to find implicit (= reused) opers. opersForType :: SourceGrammar -> Type -> Type -> [(QIdent,Term)] opersForType gr orig val = - [((i,f),ty) | (i,m) <- allModMod gr, (f,ty) <- opers i m val] where + [((i,f),ty) | (i,m) <- modules gr, (f,ty) <- opers i m val] where opers i m val = [(f,ty) | (f,ResOper (Yes ty) _) <- tree2list $ jments m, @@ -263,7 +240,7 @@ opersForType gr orig val = ] ++ let cat = err error snd (valCat orig) in --- ignore module [(f,ty) | - Ok a <- [abstractOfConcrete gr i >>= lookupModMod gr], + Ok a <- [abstractOfConcrete gr i >>= lookupModule gr], (f, AbsFun (Yes ty0) _) <- tree2list $ jments a, let ty = redirectTerm i ty0, Ok valt <- [valCat ty], diff --git a/src/GF/Grammar/PrGrammar.hs b/src/GF/Grammar/PrGrammar.hs index df8c014c7..e359d360b 100644 --- a/src/GF/Grammar/PrGrammar.hs +++ b/src/GF/Grammar/PrGrammar.hs @@ -78,7 +78,7 @@ pprintTree = compactPrint . P.printTree prGrammar :: SourceGrammar -> String prGrammar = pprintTree . trGrammar -prModule :: (Ident, SourceModInfo) -> String +prModule :: SourceModule -> String prModule = pprintTree . trModule instance Print Term where @@ -254,10 +254,10 @@ lookupIdent c t = case lookupTree prt c t of Ok v -> return v _ -> prtBad "unknown identifier" c -lookupIdentInfo :: Module Ident a -> Ident -> Err a +lookupIdentInfo :: ModInfo Ident a -> Ident -> Err a lookupIdentInfo mo i = lookupIdent i (jments mo) -lookupIdentInfoIn :: Module Ident a -> Ident -> Ident -> Err a +lookupIdentInfoIn :: ModInfo Ident a -> Ident -> Ident -> Err a lookupIdentInfoIn mo m i = err (\s -> Bad (s +++ "in module" +++ prt m)) return $ lookupIdentInfo mo i diff --git a/src/GF/Infra/Dependencies.hs b/src/GF/Infra/Dependencies.hs index 084cfce1c..1eff523b8 100644 --- a/src/GF/Infra/Dependencies.hs +++ b/src/GF/Infra/Dependencies.hs @@ -46,7 +46,7 @@ data ModDeps = ModDeps { noModDeps = ModDeps MTAbstract [] [] [] [] [] [] grammar2moddeps :: SourceGrammar -> [(Ident,ModDeps)] -grammar2moddeps gr = [(i,depMod m) | (i,ModMod m) <- modules gr] where +grammar2moddeps gr = [(i,depMod m) | (i,m) <- modules gr] where depMod m = noModDeps{ modtype = mtype m, ofs = case mtype m of diff --git a/src/GF/Infra/Modules.hs b/src/GF/Infra/Modules.hs index fc319f6b3..56cfb8063 100644 --- a/src/GF/Infra/Modules.hs +++ b/src/GF/Infra/Modules.hs @@ -19,23 +19,22 @@ ----------------------------------------------------------------------------- module GF.Infra.Modules ( - MGrammar(..), ModInfo(..), Module(..), ModuleType(..), - MReuseType(..), MInclude (..), + MGrammar(..), ModInfo(..), ModuleType(..), + MInclude (..), extends, isInherited,inheritAll, updateMGrammar, updateModule, replaceJudgements, addFlag, - addOpenQualif, flagsModule, allFlags, mapModules, mapModules', - MainGrammar(..), MainConcreteSpec(..), OpenSpec(..), OpenQualif(..), - oSimple, oQualif, + addOpenQualif, flagsModule, allFlags, mapModules, + OpenSpec(..), ModuleStatus(..), openedModule, allOpens, depPathModule, allDepsModule, partOfGrammar, allExtends, allExtendSpecs, allExtendsPlus, allExtensions, searchPathModule, addModule, - emptyMGrammar, emptyModInfo, emptyModule, + emptyMGrammar, emptyModInfo, IdentM(..), - typeOfModule, abstractOfConcrete, abstractModOfConcrete, - lookupModule, lookupModuleType, lookupModMod, lookupInfo, + abstractOfConcrete, abstractModOfConcrete, + lookupModule, lookupModuleType, lookupInfo, lookupPosition, showPosition, - allModMod, isModAbs, isModRes, isModCnc, isModTrans, + isModAbs, isModRes, isModCnc, isModTrans, sameMType, isCompilableModule, isCompleteModule, allAbstracts, greatestAbstract, allResources, greatestResource, allConcretes, allConcreteModules @@ -54,27 +53,22 @@ import Data.List -- The parameters tell what kind of data is involved. -- Invariant: modules are stored in dependency order -data MGrammar i a = MGrammar {modules :: [(i,ModInfo i a)]} +newtype MGrammar i a = MGrammar {modules :: [(i,ModInfo i a)]} deriving Show -data ModInfo i a = - ModMainGrammar (MainGrammar i) - | ModMod (Module i a) - | ModWith (Module i a) (i,MInclude i) [OpenSpec i] - deriving Show - -data Module i a = Module { +data ModInfo i a = ModInfo { mtype :: ModuleType i , mstatus :: ModuleStatus , flags :: Options, extend :: [(i,MInclude i)], + mwith :: Maybe (i,MInclude i,[OpenSpec i]), opens :: [OpenSpec i] , jments :: BinTree i a , positions :: BinTree i (String,(Int,Int)) -- file, first line, last line } --- deriving Show -instance Show (Module i a) where - show _ = "cannot show Module with FiniteMap" +instance Show (ModInfo i a) where + show _ = "cannot show ModInfo with FiniteMap" -- | encoding the type of the module data ModuleType i = @@ -85,17 +79,12 @@ data ModuleType i = -- ^ up to this, also used in GFC. Below, source only. | MTInterface | MTInstance i - | MTReuse (MReuseType i) - | MTUnion (ModuleType i) [(i,[i])] -- ^ not meant to be recursive - deriving (Eq,Ord,Show) - -data MReuseType i = MRInterface i | MRInstance i i | MRResource i deriving (Eq,Ord,Show) data MInclude i = MIAll | MIOnly [i] | MIExcept [i] deriving (Eq,Ord,Show) -extends :: Module i a -> [i] +extends :: ModInfo i a -> [i] extends = map fst . extend isInherited :: Eq i => MInclude i -> i -> Bool @@ -117,68 +106,32 @@ updateMGrammar old new = MGrammar $ os = modules old ns = modules new -updateModule :: Ord i => Module i t -> i -> t -> Module i t -updateModule (Module mt ms fs me ops js ps) i t = - Module mt ms fs me ops (updateTree (i,t) js) ps +updateModule :: Ord i => ModInfo i t -> i -> t -> ModInfo i t +updateModule (ModInfo mt ms fs me mw ops js ps) i t = ModInfo mt ms fs me mw ops (updateTree (i,t) js) ps -replaceJudgements :: Module i t -> BinTree i t -> Module i t -replaceJudgements (Module mt ms fs me ops _ ps) js = Module mt ms fs me ops js ps +replaceJudgements :: ModInfo i t -> BinTree i t -> ModInfo i t +replaceJudgements (ModInfo mt ms fs me mw ops _ ps) js = ModInfo mt ms fs me mw ops js ps -addOpenQualif :: i -> i -> Module i t -> Module i t -addOpenQualif i j (Module mt ms fs me ops js ps) = - Module mt ms fs me (oQualif i j : ops) js ps +addOpenQualif :: i -> i -> ModInfo i t -> ModInfo i t +addOpenQualif i j (ModInfo mt ms fs me mw ops js ps) = ModInfo mt ms fs me mw (OQualif i j : ops) js ps -addFlag :: Options -> Module i t -> Module i t +addFlag :: Options -> ModInfo i t -> ModInfo i t addFlag f mo = mo {flags = flags mo `addOptions` f} flagsModule :: (i,ModInfo i a) -> Options -flagsModule (_,mi) = case mi of - ModMod m -> flags m - _ -> noOptions +flagsModule (_,mi) = flags mi allFlags :: MGrammar i a -> Options -allFlags gr = concatOptions $ map flags $ [m | (_, ModMod m) <- modules gr] +allFlags gr = concatOptions [flags m | (_,m) <- modules gr] -mapModules :: (Module i a -> Module i a) - -> MGrammar i a -> MGrammar i a -mapModules f = MGrammar . map (onSnd (mapModules' f)) . modules - -mapModules' :: (Module i a -> Module i a) - -> ModInfo i a -> ModInfo i a -mapModules' f (ModMod m) = ModMod (f m) -mapModules' _ m = m - -data MainGrammar i = MainGrammar { - mainAbstract :: i , - mainConcretes :: [MainConcreteSpec i] - } - deriving Show - -data MainConcreteSpec i = MainConcreteSpec { - concretePrintname :: i , - concreteName :: i , - transferIn :: Maybe (OpenSpec i) , -- ^ if there is an in-transfer - transferOut :: Maybe (OpenSpec i) -- ^ if there is an out-transfer - } - deriving Show +mapModules :: (ModInfo i a -> ModInfo i a) -> MGrammar i a -> MGrammar i a +mapModules f (MGrammar ms) = MGrammar (map (onSnd f) ms) data OpenSpec i = - OSimple OpenQualif i - | OQualif OpenQualif i i + OSimple i + | OQualif i i deriving (Eq,Ord,Show) -data OpenQualif = - OQNormal - | OQInterface - | OQIncomplete - deriving (Eq,Ord,Show) - -oSimple :: i -> OpenSpec i -oSimple = OSimple OQNormal - -oQualif :: i -> i -> OpenSpec i -oQualif = OQualif OQNormal - data ModuleStatus = MSComplete | MSIncomplete @@ -186,29 +139,31 @@ data ModuleStatus = openedModule :: OpenSpec i -> i openedModule o = case o of - OSimple _ m -> m - OQualif _ _ m -> m + OSimple m -> m + OQualif _ m -> m -allOpens :: Module i a -> [OpenSpec i] +allOpens :: ModInfo i a -> [OpenSpec i] allOpens m = case mtype m of MTTransfer a b -> a : b : opens m _ -> opens m -- | initial dependency list -depPathModule :: Ord i => Module i a -> [OpenSpec i] -depPathModule m = fors m ++ exts m ++ opens m where - fors m = case mtype m of - MTTransfer i j -> [i,j] - MTConcrete i -> [oSimple i] - MTInstance i -> [oSimple i] - _ -> [] - exts m = map oSimple $ extends m +depPathModule :: Ord i => ModInfo i a -> [OpenSpec i] +depPathModule m = fors m ++ exts m ++ opens m + where + fors m = + case mtype m of + MTTransfer i j -> [i,j] + MTConcrete i -> [OSimple i] + MTInstance i -> [OSimple i] + _ -> [] + exts m = map OSimple (extends m) -- | all dependencies -allDepsModule :: Ord i => MGrammar i a -> Module i a -> [OpenSpec i] +allDepsModule :: Ord i => MGrammar i a -> ModInfo i a -> [OpenSpec i] allDepsModule gr m = iterFix add os0 where os0 = depPathModule m - add os = [m | o <- os, Just (ModMod n) <- [lookup (openedModule o) mods], + add os = [m | o <- os, Just n <- [lookup (openedModule o) mods], m <- depPathModule n] mods = modules gr @@ -217,48 +172,49 @@ partOfGrammar :: Ord i => MGrammar i a -> (i,ModInfo i a) -> MGrammar i a partOfGrammar gr (i,m) = MGrammar [mo | mo@(j,_) <- mods, elem j modsFor] where mods = modules gr - modsFor = case m of - ModMod n -> (i:) $ map openedModule $ allDepsModule gr n - ---- ModWith n i os -> i : map openedModule os ++ partOfGrammar (ModMod n) ---- - _ -> [i] + modsFor = (i:) $ map openedModule $ allDepsModule gr m -- | all modules that a module extends, directly or indirectly, without restricts allExtends :: (Show i,Ord i) => MGrammar i a -> i -> [i] -allExtends gr i = case lookupModule gr i of - Ok (ModMod m) -> case extends m of - [] -> [i] - is -> i : concatMap (allExtends gr) is - _ -> [] +allExtends gr i = + case lookupModule gr i of + Ok m -> case extends m of + [] -> [i] + is -> i : concatMap (allExtends gr) is + _ -> [] -- | all modules that a module extends, directly or indirectly, with restricts allExtendSpecs :: (Show i,Ord i) => MGrammar i a -> i -> [(i,MInclude i)] -allExtendSpecs gr i = case lookupModule gr i of - Ok (ModMod m) -> case extend m of - [] -> [(i,MIAll)] - is -> (i,MIAll) : concatMap (allExtendSpecs gr . fst) is - _ -> [] +allExtendSpecs gr i = + case lookupModule gr i of + Ok m -> case extend m of + [] -> [(i,MIAll)] + is -> (i,MIAll) : concatMap (allExtendSpecs gr . fst) is + _ -> [] -- | this plus that an instance extends its interface allExtendsPlus :: (Show i,Ord i) => MGrammar i a -> i -> [i] -allExtendsPlus gr i = case lookupModule gr i of - Ok (ModMod m) -> i : concatMap (allExtendsPlus gr) (exts m) - _ -> [] - where - exts m = extends m ++ [j | MTInstance j <- [mtype m]] +allExtendsPlus gr i = + case lookupModule gr i of + Ok m -> i : concatMap (allExtendsPlus gr) (exts m) + _ -> [] + where + exts m = extends m ++ [j | MTInstance j <- [mtype m]] -- | conversely: all modules that extend a given module, incl. instances of interface allExtensions :: (Show i,Ord i) => MGrammar i a -> i -> [i] -allExtensions gr i = case lookupModule gr i of - Ok (ModMod m) -> let es = exts i in es ++ concatMap (allExtensions gr) es - _ -> [] +allExtensions gr i = + case lookupModule gr i of + Ok m -> let es = exts i in es ++ concatMap (allExtensions gr) es + _ -> [] where exts i = [j | (j,m) <- mods, elem i (extends m) || elem (MTInstance i) [mtype m]] - mods = [(j,m) | (j,ModMod m) <- modules gr] + mods = modules gr -- | initial search path: the nonqualified dependencies -searchPathModule :: Ord i => Module i a -> [i] -searchPathModule m = [i | OSimple _ i <- depPathModule m] +searchPathModule :: Ord i => ModInfo i a -> [i] +searchPathModule m = [i | OSimple i <- depPathModule m] -- | a new module can safely be added to the end, since nothing old can depend on it addModule :: Ord i => @@ -269,11 +225,7 @@ emptyMGrammar :: MGrammar i a emptyMGrammar = MGrammar [] emptyModInfo :: ModInfo i a -emptyModInfo = ModMod emptyModule - -emptyModule :: Module i a -emptyModule = Module - MTResource MSComplete noOptions [] [] emptyBinTree emptyBinTree +emptyModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] emptyBinTree emptyBinTree -- | we store the module type with the identifier data IdentM i = IdentM { @@ -282,27 +234,18 @@ data IdentM i = IdentM { } deriving (Eq,Ord,Show) -typeOfModule :: ModInfo i a -> ModuleType i -typeOfModule mi = case mi of - ModMod m -> mtype m - abstractOfConcrete :: (Show i, Eq i) => MGrammar i a -> i -> Err i abstractOfConcrete gr c = do - m <- lookupModule gr c - case m of - ModMod n -> case mtype n of - MTConcrete a -> return a - _ -> Bad $ "expected concrete" +++ show c + n <- lookupModule gr c + case mtype n of + MTConcrete a -> return a _ -> Bad $ "expected concrete" +++ show c abstractModOfConcrete :: (Show i, Eq i) => - MGrammar i a -> i -> Err (Module i a) + MGrammar i a -> i -> Err (ModInfo i a) abstractModOfConcrete gr c = do a <- abstractOfConcrete gr c - m <- lookupModule gr a - case m of - ModMod n -> return n - _ -> Bad $ "expected abstract" +++ show c + lookupModule gr a -- the canonical file name @@ -318,56 +261,41 @@ lookupModule gr m = case lookup m (modules gr) of lookupModuleType :: (Show i,Eq i) => MGrammar i a -> i -> Err (ModuleType i) lookupModuleType gr m = do mi <- lookupModule gr m - return $ typeOfModule mi + return $ mtype mi -lookupModMod :: (Show i,Eq i) => MGrammar i a -> i -> Err (Module i a) -lookupModMod gr i = do - mo <- lookupModule gr i - case mo of - ModMod m -> return m - _ -> Bad $ "expected proper module, not" +++ show i - -lookupInfo :: (Show i, Ord i) => Module i a -> i -> Err a +lookupInfo :: (Show i, Ord i) => ModInfo i a -> i -> Err a lookupInfo mo i = lookupTree show i (jments mo) -lookupPosition :: (Show i, Ord i) => Module i a -> i -> Err (String,(Int,Int)) +lookupPosition :: (Show i, Ord i) => ModInfo i a -> i -> Err (String,(Int,Int)) lookupPosition mo i = lookupTree show i (positions mo) -showPosition :: (Show i, Ord i) => Module i a -> i -> String +showPosition :: (Show i, Ord i) => ModInfo i a -> i -> String showPosition mo i = case lookupPosition mo i of Ok (f,(b,e)) | b == e -> "in" +++ f ++ ", line" +++ show b Ok (f,(b,e)) -> "in" +++ f ++ ", lines" +++ show b ++ "-" ++ show e _ -> "" - -allModMod :: (Show i,Eq i) => MGrammar i a -> [(i,Module i a)] -allModMod gr = [(i,m) | (i, ModMod m) <- modules gr] - -isModAbs :: Module i a -> Bool +isModAbs :: ModInfo i a -> Bool isModAbs m = case mtype m of MTAbstract -> True ---- MTUnion t -> isModAbs t _ -> False -isModRes :: Module i a -> Bool +isModRes :: ModInfo i a -> Bool isModRes m = case mtype m of MTResource -> True - MTReuse _ -> True ----- MTUnion t -> isModRes t --- maybe not needed, since eliminated early MTInterface -> True --- MTInstance _ -> True _ -> False -isModCnc :: Module i a -> Bool +isModCnc :: ModInfo i a -> Bool isModCnc m = case mtype m of MTConcrete _ -> True ----- MTUnion t -> isModCnc t _ -> False -isModTrans :: Module i a -> Bool +isModTrans :: ModInfo i a -> Bool isModTrans m = case mtype m of MTTransfer _ _ -> True ----- MTUnion t -> isModTrans t _ -> False sameMType :: Eq i => ModuleType i -> ModuleType i -> Bool @@ -390,21 +318,20 @@ sameMType m n = case (n,m) of -- | don't generate code for interfaces and for incomplete modules isCompilableModule :: ModInfo i a -> Bool -isCompilableModule m = case m of - ModMod m -> case mtype m of +isCompilableModule m = + case mtype m of MTInterface -> False - _ -> mstatus m == MSComplete - _ -> False --- + _ -> mstatus m == MSComplete -- | interface and "incomplete M" are not complete -isCompleteModule :: (Eq i) => Module i a -> Bool +isCompleteModule :: (Eq i) => ModInfo i a -> Bool isCompleteModule m = mstatus m == MSComplete && mtype m /= MTInterface -- | all abstract modules sorted from least to most dependent allAbstracts :: (Ord i, Show i) => MGrammar i a -> [i] allAbstracts gr = - case topoTest [(i,extends m) | (i,ModMod m) <- modules gr, mtype m == MTAbstract] of + case topoTest [(i,extends m) | (i,m) <- modules gr, mtype m == MTAbstract] of Left is -> is Right cycles -> error $ "Cyclic abstract modules: " ++ show cycles @@ -416,7 +343,7 @@ greatestAbstract gr = case allAbstracts gr of -- | all resource modules allResources :: MGrammar i a -> [i] -allResources gr = [i | (i,ModMod m) <- modules gr, isModRes m || isModCnc m] +allResources gr = [i | (i,m) <- modules gr, isModRes m || isModCnc m] -- | the greatest resource in dependency order greatestResource :: MGrammar i a -> Maybe i @@ -427,9 +354,9 @@ greatestResource gr = case allResources gr of -- | all concretes for a given abstract allConcretes :: Eq i => MGrammar i a -> i -> [i] allConcretes gr a = - [i | (i, ModMod m) <- modules gr, mtype m == MTConcrete a, isCompleteModule m] + [i | (i, m) <- modules gr, mtype m == MTConcrete a, isCompleteModule m] -- | all concrete modules for any abstract allConcreteModules :: Eq i => MGrammar i a -> [i] allConcreteModules gr = - [i | (i, ModMod m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m] + [i | (i, m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m] diff --git a/src/GF/Source/CF.hs b/src/GF/Source/CF.hs index b268a8ecd..ae42958b6 100644 --- a/src/GF/Source/CF.hs +++ b/src/GF/Source/CF.hs @@ -81,8 +81,8 @@ type CFFun = String cf2gf :: String -> CF -> SourceGrammar cf2gf name cf = MGrammar [ - (aname, ModMod (emptyModule {mtype = MTAbstract, jments = abs})), - (cname, ModMod (emptyModule {mtype = MTConcrete aname, jments = cnc})) + (aname, emptyModInfo{mtype = MTAbstract, jments = abs}), + (cname, emptyModInfo{mtype = MTConcrete aname, jments = cnc}) ] where (abs,cnc) = cf2grammar cf diff --git a/src/GF/Source/GrammarToSource.hs b/src/GF/Source/GrammarToSource.hs index 73b0feafd..d16d75971 100644 --- a/src/GF/Source/GrammarToSource.hs +++ b/src/GF/Source/GrammarToSource.hs @@ -35,13 +35,13 @@ trGrammar :: SourceGrammar -> P.Grammar trGrammar (MGrammar ms) = P.Gr (map trModule ms) -- no includes trModule :: (Ident,SourceModInfo) -> P.ModDef -trModule (i,mo) = case mo of - ModMod m -> P.MModule compl typ body where +trModule (i,m) = P.MModule compl typ body + where compl = case mstatus m of MSIncomplete -> P.CMIncompl _ -> P.CMCompl i' = tri i - typ = case typeOfModule mo of + typ = case mtype m of MTResource -> P.MTResource i' MTAbstract -> P.MTAbstract i' MTConcrete a -> P.MTConcrete i' (tri a) @@ -66,15 +66,8 @@ forName (MTConcrete a) = tri a trOpen :: OpenSpec Ident -> P.Open trOpen o = case o of - OSimple OQNormal i -> P.OName (tri i) - OSimple q i -> P.OQualQO (trQualOpen q) (tri i) - OQualif q i j -> P.OQual (trQualOpen q) (tri i) (tri j) - -trQualOpen q = case q of - OQNormal -> P.QOCompl - OQIncomplete -> P.QOIncompl - OQInterface -> P.QOInterface - + OSimple i -> P.OName (tri i) + OQualif i j -> P.OQual P.QOCompl (tri i) (tri j) mkOpens ds = if null ds then P.NoOpens else P.OpenIn ds mkTopDefs ds = ds @@ -87,8 +80,6 @@ trAnyDef (i,info) = let i' = tri i in case info of Yes t -> [P.DefDef [P.DDef [mkName i'] (trt t)]] _ -> [] AbsFun (May b) _ -> [P.DefFun [P.FunDef [i'] (P.EIndir (tri b))]] - ---- don't destroy definitions! - AbsTrans f -> [P.DefTrans [P.DDef [mkName i'] (trt f)]] ResOper pty ptr -> [P.DefOper [trDef i' pty ptr]] ResParam pp -> [P.DefPar [case pp of diff --git a/src/GF/Source/SourceToGrammar.hs b/src/GF/Source/SourceToGrammar.hs index da5ab180d..61912704b 100644 --- a/src/GF/Source/SourceToGrammar.hs +++ b/src/GF/Source/SourceToGrammar.hs @@ -70,15 +70,9 @@ transGrammar x = case x of moddefs' <- mapM transModDef moddefs GD.mkSourceGrammar moddefs' -transModDef :: ModDef -> Err (Ident, G.SourceModInfo) +transModDef :: ModDef -> Err G.SourceModule transModDef x = case x of - MMain id0 id concspecs -> do - id0' <- transIdent id0 - id' <- transIdent id - concspecs' <- mapM transConcSpec concspecs - return $ (id0', GM.ModMainGrammar (GM.MainGrammar id' concspecs')) - MModule compl mtyp body -> do let mstat' = transComplMod compl @@ -117,14 +111,7 @@ transModDef x = case x of defs' <- U.buildAnyTree [(i,d) | Left ds <- defs0, (i,_,d) <- ds] flags' <- return $ concatOptions [o | Right o <- defs0] let poss1 = buildPosTree id' poss0 - return (id', - GM.ModMod (GM.Module mtyp' mstat' flags' extends' opens' defs' poss1)) - MReuse _ -> do - return (id', GM.ModMod (GM.Module mtyp' mstat' noOptions [] [] emptyBinTree poss)) - MUnion imps -> do - imps' <- mapM transIncluded imps - return (id', - GM.ModMod (GM.Module (GM.MTUnion mtyp' imps') mstat' noOptions [] [] emptyBinTree poss)) + return (id', GM.ModInfo mtyp' mstat' flags' extends' Nothing opens' defs' poss1) MWith m insts -> mkBody xx $ MWithEBody [] m insts NoOpens [] MWithBody m insts opens defs -> mkBody xx $ MWithEBody [] m insts opens defs @@ -139,21 +126,11 @@ transModDef x = case x of defs' <- U.buildAnyTree [(i,d) | Left ds <- defs0, (i,_,d) <- ds] flags' <- return $ concatOptions [o | Right o <- defs0] let poss1 = buildPosTree id' poss0 - return (id', - GM.ModWith (GM.Module mtyp' mstat' flags' extends' opens' defs' poss1) m' insts') + return (id', GM.ModInfo mtyp' mstat' flags' extends' (Just (fst m',snd m',insts')) opens' defs' poss1) mkModRes id mtyp body = do id' <- transIdent id - case body of - MReuse c -> do - c' <- transIdent c - mtyp' <- trMReuseType mtyp c' - return (transResDef, GM.MTReuse mtyp', id') - _ -> return (transResDef, mtyp, id') - trMReuseType mtyp c = case mtyp of - GM.MTInterface -> return $ GM.MRInterface c - GM.MTInstance op -> return $ GM.MRInstance c op - GM.MTResource -> return $ GM.MRResource c + return (transResDef, mtyp, id') transComplMod :: ComplMod -> GM.ModuleStatus @@ -164,13 +141,6 @@ transComplMod x = case x of getTopDefs :: [TopDef] -> [TopDef] getTopDefs x = x -transConcSpec :: ConcSpec -> Err (GM.MainConcreteSpec Ident) -transConcSpec x = case x of - ConcSpec id concexp -> do - id' <- transIdent id - (m,mi,mo) <- transConcExp concexp - return $ GM.MainConcreteSpec id' m mi mo - transConcExp :: ConcExp -> Err (Ident, Maybe (GM.OpenSpec Ident),Maybe (GM.OpenSpec Ident)) transConcExp x = case x of @@ -205,15 +175,9 @@ transOpens x = case x of transOpen :: Open -> Err (GM.OpenSpec Ident) transOpen x = case x of - OName id -> liftM (GM.OSimple GM.OQNormal) $ transIdent id - OQualQO q id -> liftM2 GM.OSimple (transQualOpen q) (transIdent id) - OQual q id m -> liftM3 GM.OQualif (transQualOpen q) (transIdent id) (transIdent m) - -transQualOpen :: QualOpen -> Err GM.OpenQualif -transQualOpen x = case x of - QOCompl -> return GM.OQNormal - QOInterface -> return GM.OQInterface - QOIncompl -> return GM.OQIncomplete + OName id -> liftM GM.OSimple (transIdent id) + OQualQO q id -> liftM GM.OSimple (transIdent id) + OQual q id m -> liftM2 GM.OQualif (transIdent id) (transIdent m) transIncluded :: Included -> Err (Ident,[Ident]) transIncluded x = case x of @@ -261,9 +225,6 @@ transAbsDef x = case x of returnl $ [(c, nopos, G.AbsCat nope (yes ps)) | (c,ps) <- ds'] ++ [(f, nopos, G.AbsFun nope (yes G.EData)) | (_,fs) <- ds', tf <- fs, f <- funs tf] - DefTrans defs -> do - defs' <- liftM concat $ mapM getDefsGen defs - returnl [(c, nopos, G.AbsTrans f) | ((c,p),(_,Yes f)) <- defs'] DefFlag defs -> liftM (Right . concatOptions) $ mapM transFlagDef defs _ -> Bad $ "illegal definition in abstract module:" ++++ printTree x where diff --git a/src/exper/Evaluate.hs b/src/exper/Evaluate.hs index 7c5fb4b6a..413c82402 100644 --- a/src/exper/Evaluate.hs +++ b/src/exper/Evaluate.hs @@ -386,7 +386,7 @@ evalConcrete gr mo = mapMTree evaldef mo where Bad s -> raise s noExpand p = errVal False $ do - mo <- lookupModMod gr p + mo <- lookupModule gr p return $ case getOptVal (iOpts (flags mo)) useOptimizer of Just "noexpand" -> True _ -> False diff --git a/src/exper/Optimize.hs b/src/exper/Optimize.hs index 93346bc70..7cf88554f 100644 --- a/src/exper/Optimize.hs +++ b/src/exper/Optimize.hs @@ -37,10 +37,10 @@ import Data.List -- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005. -- only do this for resource: concrete is optimized in gfc form -optimizeModule :: Options -> [(Ident,SourceModInfo)] -> (Ident,SourceModInfo) -> - Err (Ident,SourceModInfo) +optimizeModule :: Options -> [(Ident,SourceModule)] -> (Ident,SourceModule) -> + Err (Ident,SourceModule) optimizeModule opts ms mo@(_,mi) = case mi of - ModMod m0@(Module mt st fs me ops js) | st == MSComplete && isModRes m0 -> do + m0@(Module mt st fs me ops js) | st == MSComplete && isModRes m0 -> do mo1 <- evalModule oopts ms mo return $ case optim of "parametrize" -> shareModule paramOpt mo1 -- parametrization and sharing @@ -54,11 +54,10 @@ optimizeModule opts ms mo@(_,mi) = case mi of oopts = addOptions opts (iOpts (flagsModule mo)) optim = maybe "all" id $ getOptVal oopts useOptimizer -evalModule :: Options -> [(Ident,SourceModInfo)] -> (Ident,SourceModInfo) -> - Err (Ident,SourceModInfo) +evalModule :: Options -> [(Ident,SourceModule)] -> (Ident,SourceModule) -> Err (Ident,SourceModule) evalModule oopts ms mo@(name,mod) = case mod of - ModMod m0@(Module mt st fs me ops js) | st == MSComplete -> case mt of + m0@(Module mt st fs me ops js) | st == MSComplete -> case mt of {- -- now: don't optimize resource @@ -72,7 +71,7 @@ evalModule oopts ms mo@(name,mod) = case mod of ----- js0 <- appEvalConcrete gr js js' <- mapMTree (evalCncInfo oopts gr name a) js0 ---- <- gr0 6/12/2005 - return $ (name, ModMod (Module mt st fs me ops js')) + return $ (name, Module mt st fs me ops js') _ -> return $ (name,mod) _ -> return $ (name,mod) @@ -80,7 +79,7 @@ evalModule oopts ms mo@(name,mod) = case mod of gr0 = MGrammar $ ms gr = MGrammar $ (name,mod) : ms - evalOp g@(MGrammar ((_, ModMod m) : _)) i = do + evalOp g@(MGrammar ((_, m) : _)) i = do info <- lookupTree prt i $ jments m info' <- evalResInfo oopts gr (i,info) return $ updateRes g name i info'