summaryrefslogtreecommitdiff
path: root/src/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'src/compiler')
-rw-r--r--src/compiler/GF/Compile.hs10
-rw-r--r--src/compiler/GF/Compile/CheckGrammar.hs4
-rw-r--r--src/compiler/GF/Compile/GrammarToPGF.hs17
-rw-r--r--src/compiler/GF/Compile/Optimize.hs2
-rw-r--r--src/compiler/GF/Compile/Refresh.hs2
-rw-r--r--src/compiler/GF/Compile/Rename.hs4
-rw-r--r--src/compiler/GF/Compile/SubExOpt.hs2
-rw-r--r--src/compiler/GF/Grammar/Binary.hs4
-rw-r--r--src/compiler/GF/Grammar/CF.hs2
-rw-r--r--src/compiler/GF/Grammar/Grammar.hs4
-rw-r--r--src/compiler/GF/Infra/Modules.hs36
-rw-r--r--src/compiler/GFI.hs2
12 files changed, 52 insertions, 37 deletions
diff --git a/src/compiler/GF/Compile.hs b/src/compiler/GF/Compile.hs
index 00b08dbf3..b0c228e53 100644
--- a/src/compiler/GF/Compile.hs
+++ b/src/compiler/GF/Compile.hs
@@ -69,8 +69,8 @@ batchCompile opts files = do
-- to compile a set of modules, e.g. an old GF or a .cf file
compileSourceGrammar :: Options -> SourceGrammar -> IOE SourceGrammar
-compileSourceGrammar opts gr@(MGrammar ms) = do
- (_,gr',_) <- foldM compOne (0,emptySourceGrammar,Map.empty) ms
+compileSourceGrammar opts gr = do
+ (_,gr',_) <- foldM compOne (0,emptySourceGrammar,Map.empty) (modules gr)
return gr'
where
compOne env mo = do
@@ -215,19 +215,19 @@ generateModuleCode opts file minfo = do
-- auxiliaries
-reverseModules (MGrammar ms) = MGrammar $ reverse ms
+--reverseModules (MGrammar ms) = MGrammar $ reverse ms
emptyCompileEnv :: CompileEnv
emptyCompileEnv = (0,emptyMGrammar,Map.empty)
-extendCompileEnvInt (_,MGrammar ss,menv) k mfile sm = do
+extendCompileEnvInt (_,gr,menv) k mfile sm = do
let (mod,imps) = importsOfModule sm
menv2 <- case mfile of
Just file -> do
t <- ioeIO $ getModificationTime file
return $ Map.insert mod (t,imps) menv
_ -> return menv
- return (k,MGrammar (sm:ss),menv2) --- reverse later
+ return (k,mGrammar (sm:modules gr),menv2) --- reverse later
extendCompileEnv e@(k,_,_) file sm = extendCompileEnvInt e k (Just file) sm
diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs
index 035b47238..b3129128b 100644
--- a/src/compiler/GF/Compile/CheckGrammar.hs
+++ b/src/compiler/GF/Compile/CheckGrammar.hs
@@ -47,7 +47,7 @@ checkModule :: [SourceModule] -> SourceModule -> Check SourceModule
checkModule ms m@(name,mo) = checkIn (text "checking module" <+> ppIdent name) $ do
checkRestrictedInheritance ms m
m <- case mtype mo of
- MTConcrete a -> do let gr = MGrammar (m:ms)
+ MTConcrete a -> do let gr = mGrammar (m:ms)
abs <- checkErr $ lookupModule gr a
checkCompleteGrammar gr (a,abs) m
_ -> return m
@@ -221,7 +221,7 @@ checkInfo ms (m,mo) c info = do
_ -> return info
where
- gr = MGrammar ((m,mo) : ms)
+ gr = mGrammar ((m,mo) : ms)
chIn loc cat = checkIn (text "Happened in" <+> text cat <+> ppIdent c <+> ppPosition m loc <> colon)
mkPar (L loc (f,co)) =
diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs
index a6c7035d5..ed10697fd 100644
--- a/src/compiler/GF/Compile/GrammarToPGF.hs
+++ b/src/compiler/GF/Compile/GrammarToPGF.hs
@@ -44,10 +44,13 @@ mkCanon2pgf opts cnc gr = (canon2pgf opts gr . reorder abs) gr
-- Generate PGF from grammar.
-canon2pgf :: Options -> SourceGrammar -> SourceGrammar -> IO D.PGF
-canon2pgf opts gr cgr@(M.MGrammar (am:cms)) = do
+type AbsConcsGrammar = (IdModInfo,[IdModInfo]) -- (abstract,concretes)
+type IdModInfo = (Ident,SourceModInfo)
+
+canon2pgf :: Options -> SourceGrammar -> AbsConcsGrammar -> IO D.PGF
+canon2pgf opts gr (am,cms) = do
if dump opts DumpCanon
- then putStrLn (render (vcat (map (ppModule Qualified) (M.modules cgr))))
+ then putStrLn (render (vcat (map (ppModule Qualified) (am:cms))))
else return ()
(an,abs) <- mkAbstr am
cncs <- mapM (mkConcr am) cms
@@ -148,12 +151,12 @@ compilePatt eqs = whilePP eqs Map.empty
-- return just one module per language
-reorder :: Ident -> SourceGrammar -> SourceGrammar
+reorder :: Ident -> SourceGrammar -> AbsConcsGrammar
reorder abs cg =
- M.MGrammar $
- (abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] [] adefs):
+-- M.MGrammar $
+ ((abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] [] adefs),
[(cnc, M.ModInfo (M.MTConcrete abs) M.MSComplete cflags [] Nothing [] [] cdefs)
- | cnc <- M.allConcretes cg abs, let (cflags,cdefs) = concr cnc]
+ | cnc <- M.allConcretes cg abs, let (cflags,cdefs) = concr cnc])
where
aflags =
concatOptions (reverse [M.flags mo | (_,mo) <- M.modules cg, M.isModAbs mo])
diff --git a/src/compiler/GF/Compile/Optimize.hs b/src/compiler/GF/Compile/Optimize.hs
index 10f6c08be..95ee460ef 100644
--- a/src/compiler/GF/Compile/Optimize.hs
+++ b/src/compiler/GF/Compile/Optimize.hs
@@ -96,7 +96,7 @@ evalInfo opts ms m c info = do
_ -> return info
where
- gr = MGrammar (m : ms)
+ gr = mGrammar (m : ms)
optim = flag optOptimizations opts
param = OptParametrize `Set.member` optim
eIn cat = errIn (render (text "Error optimizing" <+> cat <+> ppIdent c <+> colon))
diff --git a/src/compiler/GF/Compile/Refresh.hs b/src/compiler/GF/Compile/Refresh.hs
index 159c26a38..3780db2cf 100644
--- a/src/compiler/GF/Compile/Refresh.hs
+++ b/src/compiler/GF/Compile/Refresh.hs
@@ -108,7 +108,7 @@ refreshEquation pst = err Bad (return . fst) (appSTM (refr pst) initIdState) whe
-- for concrete and resource in grammar, before optimizing
refreshGrammar :: SourceGrammar -> Err SourceGrammar
-refreshGrammar = liftM (MGrammar . snd) . foldM refreshModule (0,[]) . modules
+refreshGrammar = liftM (mGrammar . snd) . foldM refreshModule (0,[]) . modules
refreshModule :: (Int,[SourceModule]) -> SourceModule -> Err (Int,[SourceModule])
refreshModule (k,ms) mi@(i,mo)
diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs
index c8bf8cdd9..f1c7e2022 100644
--- a/src/compiler/GF/Compile/Rename.hs
+++ b/src/compiler/GF/Compile/Rename.hs
@@ -62,7 +62,7 @@ renameSourceJudgement g m (i,t) = do
renameModule :: [SourceModule] -> SourceModule -> Check SourceModule
renameModule ms (name,mo) = checkIn (text "renaming module" <+> ppIdent name) $ do
let js1 = jments mo
- status <- buildStatus (MGrammar ms) name mo
+ status <- buildStatus (mGrammar ms) name mo
js2 <- checkMap (renameInfo status name) js1
return (name, mo {opens = map forceQualif (opens mo), jments = js2})
@@ -128,7 +128,7 @@ tree2status o = case o of
buildStatus :: SourceGrammar -> Ident -> SourceModInfo -> Check Status
buildStatus gr c mo = let mo' = self2status c mo in do
- let gr1 = MGrammar ((c,mo) : modules gr)
+ let gr1 = mGrammar ((c,mo) : modules gr)
ops = [OSimple e | e <- allExtends gr1 c] ++ opens mo
mods <- checkErr $ mapM (lookupModule gr1 . openedModule) ops
let sts = map modInfo2status $ zip ops mods
diff --git a/src/compiler/GF/Compile/SubExOpt.hs b/src/compiler/GF/Compile/SubExOpt.hs
index 42824845e..49d7efb81 100644
--- a/src/compiler/GF/Compile/SubExOpt.hs
+++ b/src/compiler/GF/Compile/SubExOpt.hs
@@ -61,7 +61,7 @@ unsubexpModule sm@(i,mo)
Q (m,c) | isOperIdent c -> --- name convention of subexp opers
errVal t $ liftM unparTerm $ lookupResDef gr (m,c)
_ -> C.composSafeOp unparTerm t
- gr = M.MGrammar [sm]
+ gr = M.mGrammar [sm]
rebuild = buildTree . concat
-- implementation
diff --git a/src/compiler/GF/Grammar/Binary.hs b/src/compiler/GF/Grammar/Binary.hs
index 0cee6f2c6..32ddfe6ad 100644
--- a/src/compiler/GF/Grammar/Binary.hs
+++ b/src/compiler/GF/Grammar/Binary.hs
@@ -27,8 +27,8 @@ instance Binary Ident where
else return (identC bs)
instance Binary a => Binary (MGrammar a) where
- put (MGrammar ms) = put ms
- get = fmap MGrammar get
+ put = put . modules
+ get = fmap mGrammar get
instance Binary a => Binary (ModInfo a) where
put mi = do put (mtype mi,mstatus mi,flags mi,extend mi,mwith mi,opens mi,mexdeps mi,jments mi)
diff --git a/src/compiler/GF/Grammar/CF.hs b/src/compiler/GF/Grammar/CF.hs
index 009bbd3c2..93ae10b4a 100644
--- a/src/compiler/GF/Grammar/CF.hs
+++ b/src/compiler/GF/Grammar/CF.hs
@@ -81,7 +81,7 @@ type CFFun = String
--------------------------
cf2gf :: String -> CF -> SourceGrammar
-cf2gf name cf = MGrammar [
+cf2gf name cf = mGrammar [
(aname, addFlag (modifyFlags (\fs -> fs{optStartCat = Just cat}))
(emptyModInfo{mtype = MTAbstract, jments = abs})),
(cname, emptyModInfo{mtype = MTConcrete aname, jments = cnc})
diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs
index f99ed0414..e29bc331a 100644
--- a/src/compiler/GF/Grammar/Grammar.hs
+++ b/src/compiler/GF/Grammar/Grammar.hs
@@ -15,7 +15,7 @@
-----------------------------------------------------------------------------
module GF.Grammar.Grammar (SourceGrammar,
- emptySourceGrammar,
+ emptySourceGrammar,mGrammar,
SourceModInfo,
SourceModule,
mapSourceModule,
@@ -56,7 +56,7 @@ import qualified Data.ByteString.Char8 as BS
-- | grammar as presented to the compiler
type SourceGrammar = MGrammar Info
-emptySourceGrammar = MGrammar []
+emptySourceGrammar = mGrammar []
type SourceModInfo = ModInfo Info
diff --git a/src/compiler/GF/Infra/Modules.hs b/src/compiler/GF/Infra/Modules.hs
index 5175dfdd5..8c54ddf30 100644
--- a/src/compiler/GF/Infra/Modules.hs
+++ b/src/compiler/GF/Infra/Modules.hs
@@ -15,12 +15,12 @@
--
-- The same structure will be used in both source code and canonical.
-- The parameters tell what kind of data is involved.
--- Invariant: modules are stored in dependency order
-----------------------------------------------------------------------------
module GF.Infra.Modules (
- MGrammar(..), ModInfo(..), ModuleType(..),
+ MGrammar, ModInfo(..), ModuleType(..),
MInclude (..),
+ mGrammar,modules,
extends, isInherited,inheritAll,
updateMGrammar, updateModule, replaceJudgements, addFlag,
addOpenQualif, flagsModule, allFlags, mapModules,
@@ -28,7 +28,8 @@ module GF.Infra.Modules (
ModuleStatus(..),
openedModule, depPathModule, allDepsModule, partOfGrammar,
allExtends, allExtendSpecs, allExtendsPlus, allExtensions,
- searchPathModule, addModule,
+ searchPathModule,
+ -- addModule,
emptyMGrammar, emptyModInfo,
abstractOfConcrete, abstractModOfConcrete,
lookupModule, lookupModuleType, lookupInfo,
@@ -50,10 +51,16 @@ import Text.PrettyPrint
-- The same structure will be used in both source code and canonical.
-- The parameters tell what kind of data is involved.
--- Invariant: modules are stored in dependency order
+-- No longer maintained invariant (TH 2011-08-30):
+-- modules are stored in dependency order
-newtype MGrammar a = MGrammar {modules :: [(Ident,ModInfo a)]}
+--mGrammar = MGrammar
+--newtype MGrammar a = MGrammar {modules :: [(Ident,ModInfo a)]}
+
+newtype MGrammar a = MGrammar {moduleMap :: Map.Map Ident (ModInfo a)}
deriving Show
+modules = Map.toList . moduleMap
+mGrammar = MGrammar . Map.fromList
data ModInfo a = ModInfo {
mtype :: ModuleType,
@@ -94,9 +101,9 @@ inheritAll i = (i,MIAll)
-- destructive update
--- | dep order preserved since old cannot depend on new
+-- | dep order preserved since old cannot depend on new (not anymore TH 2011-08-30)
updateMGrammar :: MGrammar a -> MGrammar a -> MGrammar a
-updateMGrammar old new = MGrammar $
+updateMGrammar old new = mGrammar $
[(i,m) | (i,m) <- os, notElem i (map fst ns)] ++ ns
where
os = modules old
@@ -121,7 +128,8 @@ allFlags :: MGrammar a -> Options
allFlags gr = concatOptions [flags m | (_,m) <- modules gr]
mapModules :: (ModInfo a -> ModInfo a) -> MGrammar a -> MGrammar a
-mapModules f (MGrammar ms) = MGrammar (map (onSnd f) ms)
+--mapModules f (MGrammar ms) = MGrammar (map (onSnd f) ms)
+mapModules f (MGrammar ms) = MGrammar (fmap f ms)
data OpenSpec =
OSimple Ident
@@ -159,7 +167,7 @@ allDepsModule gr m = iterFix add os0 where
-- | select just those modules that a given one depends on, including itself
partOfGrammar :: MGrammar a -> (Ident,ModInfo a) -> MGrammar a
-partOfGrammar gr (i,m) = MGrammar [mo | mo@(j,_) <- mods, elem j modsFor]
+partOfGrammar gr (i,m) = mGrammar [mo | mo@(j,_) <- mods, elem j modsFor]
where
mods = modules gr
modsFor = (i:) $ map openedModule $ allDepsModule gr m
@@ -208,12 +216,15 @@ allExtensions gr i =
searchPathModule :: ModInfo a -> [Ident]
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 :: MGrammar a -> Ident -> ModInfo a -> MGrammar a
-addModule gr name mi = MGrammar $ (modules gr ++ [(name,mi)])
+--addModule gr name mi = MGrammar $ (modules gr ++ [(name,mi)])
+addModule gr name mi = MGrammar $ Map.insert name mi (moduleMap gr)
+-}
emptyMGrammar :: MGrammar a
-emptyMGrammar = MGrammar []
+emptyMGrammar = mGrammar []
emptyModInfo :: ModInfo a
emptyModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] emptyBinTree
@@ -238,7 +249,8 @@ abstractModOfConcrete gr c = do
--- canonFileName s = prt s ++ ".gfc"
lookupModule :: MGrammar a -> Ident -> Err (ModInfo a)
-lookupModule gr m = case lookup m (modules gr) of
+--lookupModule gr m = case lookup m (modules gr) of
+lookupModule gr m = case Map.lookup m (moduleMap gr) of
Just i -> return i
Nothing -> Bad $ render (text "unknown module" <+> ppIdent m <+> text "among" <+> hsep (map (ppIdent . fst) (modules gr)))
diff --git a/src/compiler/GFI.hs b/src/compiler/GFI.hs
index ffae88c7d..6efd0f3e0 100644
--- a/src/compiler/GFI.hs
+++ b/src/compiler/GFI.hs
@@ -365,7 +365,7 @@ data GFEnv = GFEnv {
emptyGFEnv :: GFEnv
emptyGFEnv =
- GFEnv emptySourceGrammar{modules=[(identW,emptyModInfo)]} (mkCommandEnv emptyPGF) [] {-0-}
+ GFEnv (mGrammar [(identW,emptyModInfo)]) (mkCommandEnv emptyPGF) [] {-0-}
wordCompletion gfenv (left,right) = do
case wc_type (reverse left) of
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 06:39:42 +0000