diff options
Diffstat (limited to 'src/compiler/GF/Compile')
| -rw-r--r-- | src/compiler/GF/Compile/CheckGrammar.hs | 29 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/Optimize.hs | 11 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/Rename.hs | 70 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/Update.hs | 21 |
4 files changed, 59 insertions, 72 deletions
diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs index 5d6922704..c0d300e31 100644 --- a/src/compiler/GF/Compile/CheckGrammar.hs +++ b/src/compiler/GF/Compile/CheckGrammar.hs @@ -34,14 +34,13 @@ import qualified GF.Compile.Compute.ConcreteNew as CN import GF.Grammar import GF.Grammar.Lexer import GF.Grammar.Lookup ---import GF.Grammar.Predef ---import GF.Grammar.PatternMatch import GF.Data.Operations import GF.Infra.CheckM import Data.List import qualified Data.Set as Set +import qualified Data.Map as Map import Control.Monad import GF.Text.Pretty @@ -59,7 +58,7 @@ checkModule opts cwd sgr mo@(m,mi) = do where updateCheckInfos mo = fmap (foldl update mo) . parallelCheck . map check where check (i,info) = fmap ((,) i) (checkInfo opts cwd sgr mo i info) - update mo@(m,mi) (i,info) = (m,mi{jments=updateTree (i,info) (jments mi)}) + update mo@(m,mi) (i,info) = (m,mi{jments=Map.insert i info (jments mi)}) -- check if restricted inheritance modules are still coherent -- i.e. that the defs of remaining names don't depend on omitted names @@ -72,7 +71,7 @@ checkRestrictedInheritance cwd sgr (name,mo) = checkInModule cwd mo NoLoc empty where mos = modules sgr checkRem ((i,m),mi) = do - let (incl,excl) = partition (isInherited mi) (map fst (tree2list (jments m))) + let (incl,excl) = partition (isInherited mi) (Map.keys (jments m)) let incld c = Set.member c (Set.fromList incl) let illegal c = Set.member c (Set.fromList excl) let illegals = [(f,is) | @@ -89,10 +88,10 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc let jsc = jments cnc -- check that all concrete constants are in abstract; build types for all lin - jsc <- foldM checkCnc emptyBinTree (tree2list jsc) + jsc <- foldM checkCnc Map.empty (Map.toList jsc) -- check that all abstract constants are in concrete; build default lin and lincats - jsc <- foldM checkAbs jsc (tree2list jsa) + jsc <- foldM checkAbs jsc (Map.toList jsa) return (cm,cnc{jments=jsc}) where @@ -113,17 +112,17 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc case lookupIdent c js of Ok (AnyInd _ _) -> return js Ok (CncFun ty (Just def) mn mf) -> - return $ updateTree (c,CncFun ty (Just def) mn mf) js + return $ Map.insert c (CncFun ty (Just def) mn mf) js Ok (CncFun ty Nothing mn mf) -> case mb_def of - Ok def -> return $ updateTree (c,CncFun ty (Just (L NoLoc def)) mn mf) js + Ok def -> return $ Map.insert c (CncFun ty (Just (L NoLoc def)) mn mf) js Bad _ -> do noLinOf c return js _ -> do case mb_def of Ok def -> do (cont,val) <- linTypeOfType gr cm ty let linty = (snd (valCat ty),cont,val) - return $ updateTree (c,CncFun (Just linty) (Just (L NoLoc def)) Nothing Nothing) js + return $ Map.insert c (CncFun (Just linty) (Just (L NoLoc def)) Nothing Nothing) js Bad _ -> do noLinOf c return js where noLinOf c = checkWarn ("no linearization of" <+> c) @@ -132,24 +131,24 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc Ok (CncCat (Just _) _ _ _ _) -> return js Ok (CncCat Nothing md mr mp mpmcfg) -> do checkWarn ("no linearization type for" <+> c <> ", inserting default {s : Str}") - return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) md mr mp mpmcfg) js + return $ Map.insert c (CncCat (Just (L NoLoc defLinType)) md mr mp mpmcfg) js _ -> do checkWarn ("no linearization type for" <+> c <> ", inserting default {s : Str}") - return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) Nothing Nothing Nothing Nothing) js + return $ Map.insert c (CncCat (Just (L NoLoc defLinType)) Nothing Nothing Nothing Nothing) js _ -> return js - checkCnc js i@(c,info) = + checkCnc js (c,info) = case info of CncFun _ d mn mf -> case lookupOrigInfo gr (am,c) of Ok (_,AbsFun (Just (L _ ty)) _ _ _) -> do (cont,val) <- linTypeOfType gr cm ty let linty = (snd (valCat ty),cont,val) - return $ updateTree (c,CncFun (Just linty) d mn mf) js + return $ Map.insert c (CncFun (Just linty) d mn mf) js _ -> do checkWarn ("function" <+> c <+> "is not in abstract") return js CncCat {} -> case lookupOrigInfo gr (am,c) of - Ok (_,AbsCat _) -> return $ updateTree i js + Ok (_,AbsCat _) -> return $ Map.insert c info js {- -- This might be too pedantic: Ok (_,AbsFun {}) -> checkError ("lincat:"<+>c<+>"is a fun, not a cat") @@ -157,7 +156,7 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc _ -> do checkWarn ("category" <+> c <+> "is not in abstract") return js - _ -> return $ updateTree i js + _ -> return $ Map.insert c info js -- | General Principle: only Just-values are checked. diff --git a/src/compiler/GF/Compile/Optimize.hs b/src/compiler/GF/Compile/Optimize.hs index 4fec7e0b6..393deb020 100644 --- a/src/compiler/GF/Compile/Optimize.hs +++ b/src/compiler/GF/Compile/Optimize.hs @@ -21,23 +21,16 @@ import GF.Grammar.Printer import GF.Grammar.Macros import GF.Grammar.Lookup import GF.Grammar.Predef ---import GF.Compile.Refresh ---import GF.Compile.Compute.Concrete import GF.Compile.Compute.ConcreteNew(GlobalEnv,normalForm,resourceValues) ---import GF.Compile.CheckGrammar ---import GF.Compile.Update - import GF.Data.Operations ---import GF.Infra.CheckM import GF.Infra.Option import Control.Monad ---import Data.List import qualified Data.Set as Set +import qualified Data.Map as Map import GF.Text.Pretty import Debug.Trace - -- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005. optimizeModule :: Options -> SourceGrammar -> SourceModule -> Err SourceModule @@ -54,7 +47,7 @@ optimizeModule opts sgr m@(name,mi) updateEvalInfo mi (i,info) = do info <- evalInfo oopts resenv sgr (name,mi) i info - return (mi{jments=updateTree (i,info) (jments mi)}) + return (mi{jments=Map.insert i info (jments mi)}) evalInfo :: Options -> GlobalEnv -> SourceGrammar -> SourceModule -> Ident -> Info -> Err Info evalInfo opts resenv sgr m c info = do diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs index 36f90ef46..5eb83cd4b 100644 --- a/src/compiler/GF/Compile/Rename.hs +++ b/src/compiler/GF/Compile/Rename.hs @@ -27,19 +27,20 @@ module GF.Compile.Rename ( renameModule ) where +import GF.Infra.Ident +import GF.Infra.CheckM import GF.Grammar.Grammar import GF.Grammar.Values import GF.Grammar.Predef -import GF.Infra.Ident -import GF.Infra.CheckM +import GF.Grammar.Lookup import GF.Grammar.Macros import GF.Grammar.Printer ---import GF.Grammar.Lookup ---import GF.Grammar.Printer import GF.Data.Operations import Control.Monad import Data.List (nub,(\\)) +import qualified Data.Map as Map +import Data.Maybe(mapMaybe) import GF.Text.Pretty -- | this gives top-level access to renaming term input in the cc command @@ -55,9 +56,9 @@ renameModule cwd gr mo@(m,mi) = do js <- checkMapRecover (renameInfo cwd status mo) (jments mi) return (m, mi{jments = js}) -type Status = (StatusTree, [(OpenSpec, StatusTree)]) +type Status = (StatusMap, [(OpenSpec, StatusMap)]) -type StatusTree = BinTree Ident StatusInfo +type StatusMap = Map.Map Ident StatusInfo type StatusInfo = Ident -> Term @@ -73,12 +74,12 @@ renameIdentTerm' env@(act,imps) t0 = Q (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0 Q (m',c) -> do m <- lookupErr m' qualifs - f <- lookupTree showIdent c m + f <- lookupIdent c m return $ f c QC (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0 QC (m',c) -> do m <- lookupErr m' qualifs - f <- lookupTree showIdent c m + f <- lookupIdent c m return $ f c _ -> return t0 where @@ -93,30 +94,21 @@ renameIdentTerm' env@(act,imps) t0 = | otherwise = checkError s ident alt c = - case lookupTree showIdent c act of - Ok f -> return (f c) - _ -> case lookupTreeManyAll showIdent opens c of - [f] -> return (f c) - [] -> alt c ("constant not found:" <+> c $$ - "given" <+> fsep (punctuate ',' (map fst qualifs))) - fs -> case nub [f c | f <- fs] of - [tr] -> return tr -{- - ts -> return $ AdHocOverload ts - -- name conflicts resolved as overloading in TypeCheck.RConcrete AR 31/1/2014 - -- the old definition is below and still presupposed in TypeCheck.Concrete --} - ts@(t:_) -> do checkWarn ("atomic term" <+> ppTerm Qualified 0 t0 $$ - "conflict" <+> hsep (punctuate ',' (map (ppTerm Qualified 0) ts)) $$ - "given" <+> fsep (punctuate ',' (map fst qualifs))) - return t - - -- a warning will be generated in CheckGrammar, and the head returned - -- in next V: - -- Bad $ "conflicting imports:" +++ unwords (map prt ts) - -info2status :: Maybe ModuleName -> (Ident,Info) -> StatusInfo -info2status mq (c,i) = case i of + case Map.lookup c act of + Just f -> return (f c) + _ -> case mapMaybe (Map.lookup c) opens of + [f] -> return (f c) + [] -> alt c ("constant not found:" <+> c $$ + "given" <+> fsep (punctuate ',' (map fst qualifs))) + fs -> case nub [f c | f <- fs] of + [tr] -> return tr + ts@(t:_) -> do checkWarn ("atomic term" <+> ppTerm Qualified 0 t0 $$ + "conflict" <+> hsep (punctuate ',' (map (ppTerm Qualified 0) ts)) $$ + "given" <+> fsep (punctuate ',' (map fst qualifs))) + return t + +info2status :: Maybe ModuleName -> Ident -> Info -> StatusInfo +info2status mq c i = case i of AbsFun _ _ Nothing _ -> maybe Con (curry QC) mq ResValue _ -> maybe Con (curry QC) mq ResParam _ _ -> maybe Con (curry QC) mq @@ -124,10 +116,10 @@ info2status mq (c,i) = case i of AnyInd False m -> maybe Cn (const (curry Q m)) mq _ -> maybe Cn (curry Q) mq -tree2status :: OpenSpec -> BinTree Ident Info -> BinTree Ident StatusInfo +tree2status :: OpenSpec -> Map.Map Ident Info -> StatusMap tree2status o = case o of - OSimple i -> mapTree (info2status (Just i)) - OQualif i j -> mapTree (info2status (Just j)) + OSimple i -> Map.mapWithKey (info2status (Just i)) + OQualif i j -> Map.mapWithKey (info2status (Just j)) buildStatus :: FilePath -> Grammar -> Module -> Check Status buildStatus cwd gr mo@(m,mi) = checkInModule cwd mi NoLoc empty $ do @@ -136,14 +128,14 @@ buildStatus cwd gr mo@(m,mi) = checkInModule cwd mi NoLoc empty $ do ops <- mapM (\o -> lookupModule gr1 (openedModule o) >>= \mi -> return (o,mi)) (mopens mi) let sts = map modInfo2status (exts++ops) return (if isModCnc mi - then (emptyBinTree, reverse sts) -- the module itself does not define any names + then (Map.empty, reverse sts) -- the module itself does not define any names else (self2status m mi,reverse sts)) -- so the empty ident is not needed -modInfo2status :: (OpenSpec,ModuleInfo) -> (OpenSpec, StatusTree) +modInfo2status :: (OpenSpec,ModuleInfo) -> (OpenSpec, StatusMap) modInfo2status (o,mo) = (o,tree2status o (jments mo)) -self2status :: ModuleName -> ModuleInfo -> StatusTree -self2status c m = mapTree (info2status (Just c)) (jments m) +self2status :: ModuleName -> ModuleInfo -> StatusMap +self2status c m = Map.mapWithKey (info2status (Just c)) (jments m) renameInfo :: FilePath -> Status -> Module -> Ident -> Info -> Check Info diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs index 9556b6554..4c1520961 100644 --- a/src/compiler/GF/Compile/Update.hs +++ b/src/compiler/GF/Compile/Update.hs @@ -29,7 +29,7 @@ import Control.Monad import GF.Text.Pretty -- | combine a list of definitions into a balanced binary search tree -buildAnyTree :: Monad m => ModuleName -> [(Ident,Info)] -> m (BinTree Ident Info) +buildAnyTree :: Monad m => ModuleName -> [(Ident,Info)] -> m (Map.Map Ident Info) buildAnyTree m = go Map.empty where go map [] = return map @@ -101,8 +101,8 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js [] -> return mi{jments=js'} j0s -> do m0s <- mapM (lookupModule gr) j0s - let notInM0 c _ = all (not . isInBinTree c . jments) m0s - let js2 = filterBinTree notInM0 js' + let notInM0 c _ = all (not . Map.member c . jments) m0s + let js2 = Map.filterWithKey notInM0 js' return mi{jments=js2} _ -> return mi @@ -123,8 +123,11 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js --- check if me is incomplete let fs1 = fs `addOptions` fs_ -- new flags have priority - let js0 = [(c,globalizeLoc fpath j) | (c,j) <- tree2list js, isInherited incl c] - let js1 = buildTree (tree2list js_ ++ js0) + let js0 = Map.mapMaybeWithKey (\c j -> if isInherited incl c + then Just (globalizeLoc fpath j) + else Nothing) + js + let js1 = Map.union js0 js_ let med1= nub (ext : infs ++ insts ++ med_) return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 msrc_ env_ js1 @@ -135,14 +138,14 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js -- If the extended module is incomplete, its judgements are just copied. extendMod :: Grammar -> Bool -> (Module,Ident -> Bool) -> ModuleName -> - BinTree Ident Info -> Check (BinTree Ident Info) + Map.Map Ident Info -> Check (Map.Map Ident Info) extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi) where try new (c,i0) | not (cond c) = return new | otherwise = case Map.lookup c new of Just j -> case unifyAnyInfo name i j of - Ok k -> return $ updateTree (c,k) new + Ok k -> return $ Map.insert c k new Bad _ -> do (base,j) <- case j of AnyInd _ m -> lookupOrigInfo gr (m,c) _ -> return (base,j) @@ -155,8 +158,8 @@ extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jme nest 4 (ppJudgement Qualified (c,j)) $$ "in module" <+> base) Nothing-> if isCompl - then return $ updateTree (c,indirInfo name i) new - else return $ updateTree (c,i) new + then return $ Map.insert c (indirInfo name i) new + else return $ Map.insert c i new where i = globalizeLoc (msrc mi) i0 |