msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

refactor the GF.Grammar.Grammar syntax. The obsolete constructions are removed

Browse Source
This commit is contained in:
krasimir
2009-01-19 13:23:03 +00:00
parent fa7ab84471
commit d95ca4a103
25 changed files with 325 additions and 542 deletions
Download Patch File Download Diff File Expand all files Collapse all files

7
src/GF/Compile/BackOpt.hs
View File

@@ -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

34
src/GF/Compile/CheckGrammar.hs
View File

@@ -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

15
src/GF/Compile/Coding.hs
View File

@@ -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)

13
src/GF/Compile/Extend.hs
View File

@@ -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))

30
src/GF/Compile/GrammarToGFCC.hs
View File

@@ -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

25
src/GF/Compile/ModDeps.hs
View File

@@ -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

42
src/GF/Compile/Optimize.hs
View File

@@ -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'

37
src/GF/Compile/OptimizeGF.hs
View File

@@ -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

25
src/GF/Compile/Rebuild.hs
View File

@@ -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

8
src/GF/Compile/Refresh.hs
View File

@@ -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

15
src/GF/Compile/RemoveLiT.hs
View File

@@ -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

55
src/GF/Compile/Rename.hs
View File

@@ -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 ->

8
src/GF/Compile/Update.hs
View File

@@ -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)