From 4d79aa8b198f411d0ab6d66d76d9f77dfd3f922f Mon Sep 17 00:00:00 2001 From: krangelov Date: Fri, 20 Sep 2019 10:37:50 +0200 Subject: [PATCH 1/2] remove obsolete code --- src/compiler/GF/Compile/CheckGrammar.hs | 29 +++++------ src/compiler/GF/Compile/Optimize.hs | 11 +--- src/compiler/GF/Compile/Rename.hs | 68 +++++++++++-------------- src/compiler/GF/Compile/Update.hs | 21 ++++---- src/compiler/GF/Data/Operations.hs | 52 +------------------ src/compiler/GF/Grammar/Lookup.hs | 10 ++-- src/compiler/GF/Grammar/Macros.hs | 11 ++-- src/compiler/GF/Grammar/Parser.y | 3 +- 8 files changed, 71 insertions(+), 134 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 + 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 - -- 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 +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 diff --git a/src/compiler/GF/Data/Operations.hs b/src/compiler/GF/Data/Operations.hs index 3c8b16b8a..7e16b6d17 100644 --- a/src/compiler/GF/Data/Operations.hs +++ b/src/compiler/GF/Data/Operations.hs @@ -28,14 +28,6 @@ module GF.Data.Operations ( -- ** Monadic operations on lists and pairs mapPairListM, mapPairsM, pairM, - - -- ** Binary search trees; now with FiniteMap - BinTree, emptyBinTree, isInBinTree, --justLookupTree, - lookupTree, --lookupTreeMany, - lookupTreeManyAll, updateTree, - buildTree, filterBinTree, - mapTree, --mapMTree, - tree2list, -- ** Printing indent, (+++), (++-), (++++), (+++-), (+++++), @@ -50,10 +42,6 @@ module GF.Data.Operations ( ifNull, combinations, done, readIntArg, --singleton, iterFix, chunks, -{- - -- ** State monad with error; from Agda 6\/11\/2001 - STM(..), appSTM, stm, stmr, readSTM, updateSTM, writeSTM, --} ) where @@ -117,44 +105,6 @@ unifyMaybeBy f (Just p1) (Just p2) unifyMaybeBy _ Nothing mp2 = return mp2 unifyMaybeBy _ mp1 _ = return mp1 --- binary search trees - -type BinTree a b = Map a b - -emptyBinTree :: BinTree a b -emptyBinTree = Map.empty - -isInBinTree :: (Ord a) => a -> BinTree a b -> Bool -isInBinTree = Map.member -{- -justLookupTree :: (ErrorMonad m,Ord a) => a -> BinTree a b -> m b -justLookupTree = lookupTree (const []) --} -lookupTree :: (ErrorMonad m,Ord a) => (a -> String) -> a -> BinTree a b -> m b -lookupTree pr x = maybeErr no . Map.lookup x - where no = "no occurrence of element" +++ pr x - -lookupTreeManyAll :: Ord a => (a -> String) -> [BinTree a b] -> a -> [b] -lookupTreeManyAll pr (t:ts) x = case lookupTree pr x t of - Ok v -> v : lookupTreeManyAll pr ts x - _ -> lookupTreeManyAll pr ts x -lookupTreeManyAll pr [] x = [] - -updateTree :: (Ord a) => (a,b) -> BinTree a b -> BinTree a b -updateTree (a,b) = Map.insert a b - -buildTree :: (Ord a) => [(a,b)] -> BinTree a b -buildTree = Map.fromList - -mapTree :: ((a,b) -> c) -> BinTree a b -> BinTree a c -mapTree f = Map.mapWithKey (\k v -> f (k,v)) - -filterBinTree :: Ord a => (a -> b -> Bool) -> BinTree a b -> BinTree a b -filterBinTree = Map.filterWithKey - -tree2list :: BinTree a b -> [(a,b)] -- inorder -tree2list = Map.toList - -- printing indent :: Int -> String -> String @@ -377,4 +327,4 @@ doUntil cond ms = case ms of v <- a if cond v then return v else doUntil cond as _ -> raise "no result" --} \ No newline at end of file +-} diff --git a/src/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs index 9435d1ec4..68c0191ae 100644 --- a/src/compiler/GF/Grammar/Lookup.hs +++ b/src/compiler/GF/Grammar/Lookup.hs @@ -51,11 +51,11 @@ lock c = lockRecType c -- return unlock c = unlockRecord c -- return -- to look up a constant etc in a search tree --- why here? AR 29/5/2008 -lookupIdent :: ErrorMonad m => Ident -> BinTree Ident b -> m b +lookupIdent :: ErrorMonad m => Ident -> Map.Map Ident b -> m b lookupIdent c t = - case lookupTree showIdent c t of - Ok v -> return v - Bad _ -> raise ("unknown identifier" +++ showIdent c) + case Map.lookup c t of + Just v -> return v + Nothing -> raise ("unknown identifier" +++ showIdent c) lookupIdentInfo :: ErrorMonad m => SourceModInfo -> Ident -> m Info lookupIdentInfo mo i = lookupIdent i (jments mo) @@ -148,7 +148,7 @@ lookupOrigInfo gr (m,c) = do allOrigInfos :: Grammar -> ModuleName -> [(QIdent,Info)] allOrigInfos gr m = fromErr [] $ do mo <- lookupModule gr m - return [((m,c),i) | (c,_) <- tree2list (jments mo), Ok (m,i) <- [lookupOrigInfo gr (m,c)]] + return [((m,c),i) | (c,_) <- Map.toList (jments mo), Ok (m,i) <- [lookupOrigInfo gr (m,c)]] lookupParamValues :: ErrorMonad m => Grammar -> QIdent -> m [Term] lookupParamValues gr c = do diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs index 00b5dbb20..ab2e53473 100644 --- a/src/compiler/GF/Grammar/Macros.hs +++ b/src/compiler/GF/Grammar/Macros.hs @@ -22,14 +22,13 @@ import GF.Data.Operations import GF.Data.Str import GF.Infra.Ident import GF.Grammar.Grammar ---import GF.Grammar.Values import GF.Grammar.Predef import GF.Grammar.Printer import Control.Monad.Identity(Identity(..)) import qualified Data.Traversable as T(mapM) +import qualified Data.Map as Map import Control.Monad (liftM, liftM2, liftM3) ---import Data.Char (isDigit) import Data.List (sortBy,nub) import Data.Monoid import GF.Text.Pretty(render,(<+>),hsep,fsep) @@ -608,9 +607,9 @@ sortRec = sortBy ordLabel where -- | dependency check, detecting circularities and returning topo-sorted list -allDependencies :: (ModuleName -> Bool) -> BinTree Ident Info -> [(Ident,[Ident])] +allDependencies :: (ModuleName -> Bool) -> Map.Map Ident Info -> [(Ident,[Ident])] allDependencies ism b = - [(f, nub (concatMap opty (pts i))) | (f,i) <- tree2list b] + [(f, nub (concatMap opty (pts i))) | (f,i) <- Map.toList b] where opersIn t = case t of Q (n,c) | ism n -> [c] @@ -634,7 +633,7 @@ topoSortJments (m,mi) = do return (\cyc -> raise (render ("circular definitions:" <+> fsep (head cyc)))) (topoTest (allDependencies (==m) (jments mi))) - return (reverse [(i,info) | i <- is, Ok info <- [lookupTree showIdent i (jments mi)]]) + return (reverse [(i,info) | i <- is, Just info <- [Map.lookup i (jments mi)]]) topoSortJments2 :: ErrorMonad m => SourceModule -> m [[(Ident,Info)]] topoSortJments2 (m,mi) = do @@ -644,4 +643,4 @@ topoSortJments2 (m,mi) = do <+> fsep (head cyc)))) (topoTest2 (allDependencies (==m) (jments mi))) return - [[(i,info) | i<-is,Ok info<-[lookupTree showIdent i (jments mi)]] | is<-iss] + [[(i,info) | i<-is,Just info<-[Map.lookup i (jments mi)]] | is<-iss] diff --git a/src/compiler/GF/Grammar/Parser.y b/src/compiler/GF/Grammar/Parser.y index 9377bd7d5..da96f9265 100644 --- a/src/compiler/GF/Grammar/Parser.y +++ b/src/compiler/GF/Grammar/Parser.y @@ -24,6 +24,7 @@ import GF.Grammar.Lexer import GF.Compile.Update (buildAnyTree) import Data.List(intersperse) import Data.Char(isAlphaNum) +import qualified Data.Map as Map import PGF(mkCId) } @@ -139,7 +140,7 @@ ModHeader : ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ; (mtype,id) = $2 ; (extends,with,opens) = $4 } - in (id, ModInfo mtype mstat noOptions extends with opens [] "" Nothing emptyBinTree) } + in (id, ModInfo mtype mstat noOptions extends with opens [] "" Nothing Map.empty) } ComplMod :: { ModuleStatus } ComplMod From 29662350dcdb350479576dfa099037fd71debc1a Mon Sep 17 00:00:00 2001 From: krangelov Date: Fri, 20 Sep 2019 10:49:29 +0200 Subject: [PATCH 2/2] removed more dead code --- src/compiler/GF/Compile/Coding.hs | 64 ------------------------------ src/compiler/GF/CompilerAPI.hs | 2 - src/compiler/GF/Data/Operations.hs | 36 ----------------- src/compiler/GF/Interactive.hs | 5 +-- src/compiler/GF/Interactive2.hs | 3 -- 5 files changed, 1 insertion(+), 109 deletions(-) delete mode 100644 src/compiler/GF/Compile/Coding.hs diff --git a/src/compiler/GF/Compile/Coding.hs b/src/compiler/GF/Compile/Coding.hs deleted file mode 100644 index 65d385022..000000000 --- a/src/compiler/GF/Compile/Coding.hs +++ /dev/null @@ -1,64 +0,0 @@ -module GF.Compile.Coding where -{- -import GF.Grammar.Grammar -import GF.Grammar.Macros -import GF.Text.Coding ---import GF.Infra.Option -import GF.Data.Operations - ---import Data.Char -import System.IO -import qualified Data.ByteString.Char8 as BS - -encodeStringsInModule :: TextEncoding -> SourceModule -> SourceModule -encodeStringsInModule enc = codeSourceModule (BS.unpack . encodeUnicode enc) - -decodeStringsInModule :: TextEncoding -> SourceModule -> SourceModule -decodeStringsInModule enc mo = codeSourceModule (decodeUnicode enc . BS.pack) mo - -codeSourceModule :: (String -> String) -> SourceModule -> SourceModule -codeSourceModule co (id,mo) = (id,mo{jments = mapTree codj (jments mo)}) - where - codj (c,info) = case info of - ResOper pty pt -> ResOper (codeLTerms co pty) (codeLTerms co pt) - ResOverload es tyts -> ResOverload es [(codeLTerm co ty,codeLTerm co t) | (ty,t) <- tyts] - CncCat mcat mdef mref mpr mpmcfg -> CncCat mcat (codeLTerms co mdef) (codeLTerms co mref) (codeLTerms co mpr) mpmcfg - CncFun mty mt mpr mpmcfg -> CncFun mty (codeLTerms co mt) (codeLTerms co mpr) mpmcfg - _ -> info - -codeLTerms co = fmap (codeLTerm co) - -codeLTerm :: (String -> String) -> L Term -> L Term -codeLTerm = fmap . codeTerm - -codeTerm :: (String -> String) -> Term -> Term -codeTerm co = codt - where - codt t = case t of - K s -> K (co s) - T ty cs -> T ty [(codp p,codt v) | (p,v) <- cs] - EPatt p -> EPatt (codp p) - _ -> composSafeOp codt t - - codp p = case p of --- really: composOpPatt - PR rs -> PR [(l,codp p) | (l,p) <- rs] - PString s -> PString (co s) - PChars s -> PChars (co s) - PT x p -> PT x (codp p) - PAs x p -> PAs x (codp p) - PNeg p -> PNeg (codp p) - PRep p -> PRep (codp p) - PSeq p q -> PSeq (codp p) (codp q) - PAlt p q -> PAlt (codp p) (codp q) - _ -> p - --- | Run an encoding function on all string literals within the given string. -codeStringLiterals :: (String -> String) -> String -> String -codeStringLiterals _ [] = [] -codeStringLiterals co ('"':cs) = '"' : inStringLiteral cs - where inStringLiteral [] = error "codeStringLiterals: unterminated string literal" - inStringLiteral ('"':ds) = '"' : codeStringLiterals co ds - inStringLiteral ('\\':d:ds) = '\\' : co [d] ++ inStringLiteral ds - inStringLiteral (d:ds) = co [d] ++ inStringLiteral ds -codeStringLiterals co (c:cs) = c : codeStringLiterals co cs --} \ No newline at end of file diff --git a/src/compiler/GF/CompilerAPI.hs b/src/compiler/GF/CompilerAPI.hs index c65b566c3..8415b4045 100644 --- a/src/compiler/GF/CompilerAPI.hs +++ b/src/compiler/GF/CompilerAPI.hs @@ -16,8 +16,6 @@ import GF.Compile.ReadFiles import GF.Compile.Update import GF.Compile.Refresh -import GF.Compile.Coding - import GF.Grammar.Grammar import GF.Grammar.Lookup import GF.Grammar.Printer diff --git a/src/compiler/GF/Data/Operations.hs b/src/compiler/GF/Data/Operations.hs index 7e16b6d17..cb9b3f9ac 100644 --- a/src/compiler/GF/Data/Operations.hs +++ b/src/compiler/GF/Data/Operations.hs @@ -247,42 +247,6 @@ chunks sep ws = case span (/= sep) ws of readIntArg :: String -> Int readIntArg n = if (not (null n) && all isDigit n) then read n else 0 -{- --- state monad with error; from Agda 6/11/2001 - -newtype STM s a = STM (s -> Err (a,s)) - -appSTM :: STM s a -> s -> Err (a,s) -appSTM (STM f) s = f s - -stm :: (s -> Err (a,s)) -> STM s a -stm = STM - -stmr :: (s -> (a,s)) -> STM s a -stmr f = stm (\s -> return (f s)) - -instance Functor (STM s) where fmap = liftM - -instance Applicative (STM s) where - pure = return - (<*>) = ap - -instance Monad (STM s) where - return a = STM (\s -> return (a,s)) - STM c >>= f = STM (\s -> do - (x,s') <- c s - let STM f' = f x - f' s') - -readSTM :: STM s s -readSTM = stmr (\s -> (s,s)) - -updateSTM :: (s -> s) -> STM s () -updateSTM f = stmr (\s -> ((),f s)) - -writeSTM :: s -> STM s () -writeSTM s = stmr (const ((),s)) --} -- | @return ()@ done :: Monad m => m () done = return () diff --git a/src/compiler/GF/Interactive.hs b/src/compiler/GF/Interactive.hs index 184ff7c96..7eb873fbc 100644 --- a/src/compiler/GF/Interactive.hs +++ b/src/compiler/GF/Interactive.hs @@ -1,10 +1,10 @@ {-# LANGUAGE CPP, ScopedTypeVariables, FlexibleInstances #-} -- | GF interactive mode module GF.Interactive (mainGFI,mainRunGFI,mainServerGFI) where + import Prelude hiding (putStrLn,print) import qualified Prelude as P(putStrLn) import GF.Command.Interpreter(CommandEnv(..),mkCommandEnv,interpretCommandLine) ---import GF.Command.Importing(importSource,importGrammar) import GF.Command.Commands(PGFEnv,HasPGFEnv(..),pgf,pgfEnv,pgfCommands) import GF.Command.CommonCommands(commonCommands,extend) import GF.Command.SourceCommands @@ -19,9 +19,6 @@ import GF.Infra.UseIO(ioErrorText,putStrLnE) import GF.Infra.SIO import GF.Infra.Option import qualified System.Console.Haskeline as Haskeline ---import GF.Text.Coding(decodeUnicode,encodeUnicode) - ---import GF.Compile.Coding(codeTerm) import PGF import PGF.Internal(abstract,funs,lookStartCat,emptyPGF) diff --git a/src/compiler/GF/Interactive2.hs b/src/compiler/GF/Interactive2.hs index ac8887bec..eaf149c3d 100644 --- a/src/compiler/GF/Interactive2.hs +++ b/src/compiler/GF/Interactive2.hs @@ -17,9 +17,6 @@ import GF.Infra.UseIO(ioErrorText,putStrLnE) import GF.Infra.SIO import GF.Infra.Option import qualified System.Console.Haskeline as Haskeline ---import GF.Text.Coding(decodeUnicode,encodeUnicode) - ---import GF.Compile.Coding(codeTerm) import qualified PGF2 as C import qualified PGF as H