From 30eef61f0a400d6b9ec77721620e13b8132a9c2c Mon Sep 17 00:00:00 2001 From: krangelov Date: Fri, 20 Sep 2019 16:15:28 +0200 Subject: [PATCH] more dead code --- gf.cabal | 2 - src/compiler/GF/Compile/CheckGrammar.hs | 2 +- .../GF/Compile/Compute/AppPredefined.hs | 143 ------------------ .../GF/Compile/Compute/ConcreteNew.hs | 4 +- src/compiler/GF/Compile/Update.hs | 5 +- src/compiler/GF/CompileInParallel.hs | 6 +- src/compiler/GF/CompileOne.hs | 10 +- src/compiler/GF/Data/Operations.hs | 34 +---- src/compiler/GF/Grammar/Lookup.hs | 4 +- src/compiler/GF/Grammar/Macros.hs | 6 +- src/compiler/GF/Interactive.hs | 8 +- src/compiler/GF/Interactive2.hs | 8 +- 12 files changed, 29 insertions(+), 203 deletions(-) delete mode 100644 src/compiler/GF/Compile/Compute/AppPredefined.hs diff --git a/gf.cabal b/gf.cabal index 156f6518d..8feebf5aa 100644 --- a/gf.cabal +++ b/gf.cabal @@ -175,9 +175,7 @@ Library GF.Command.TreeOperations GF.Compile.CFGtoPGF GF.Compile.CheckGrammar - GF.Compile.Compute.AppPredefined GF.Compile.Compute.ConcreteNew --- GF.Compile.Compute.ConcreteNew1 GF.Compile.Compute.Predef GF.Compile.Compute.Value GF.Compile.ExampleBased diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs index c0d300e31..24582bba2 100644 --- a/src/compiler/GF/Compile/CheckGrammar.hs +++ b/src/compiler/GF/Compile/CheckGrammar.hs @@ -270,7 +270,7 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do chIn loc cat = checkInModule cwd mo loc ("Happened in" <+> cat <+> c) mkPar (f,co) = do - vs <- liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co + vs <- liftM sequence $ mapM (\(_,_,ty) -> allParamValues gr ty) co return $ map (mkApp (QC (m,f))) vs checkUniq xss = case xss of diff --git a/src/compiler/GF/Compile/Compute/AppPredefined.hs b/src/compiler/GF/Compile/Compute/AppPredefined.hs deleted file mode 100644 index 0869cedee..000000000 --- a/src/compiler/GF/Compile/Compute/AppPredefined.hs +++ /dev/null @@ -1,143 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : AppPredefined --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/06 14:21:34 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.13 $ --- --- Predefined function type signatures and definitions. ------------------------------------------------------------------------------ - -module GF.Compile.Compute.AppPredefined ({- - isInPredefined, typPredefined, arrityPredefined, predefModInfo, appPredefined-} - ) where -{- -import GF.Compile.TypeCheck.Primitives -import GF.Infra.Option -import GF.Data.Operations -import GF.Grammar -import GF.Grammar.Predef - -import qualified Data.Map as Map -import GF.Text.Pretty -import Data.Char (isUpper,toUpper,toLower) - --- predefined function type signatures and definitions. AR 12/3/2003. - -isInPredefined :: Ident -> Bool -isInPredefined f = Map.member f primitives - -arrityPredefined :: Ident -> Maybe Int -arrityPredefined f = do ty <- typPredefined f - let (ctxt,_) = typeFormCnc ty - return (length ctxt) - -predefModInfo :: SourceModInfo -predefModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] "Predef.gf" Nothing primitives - -appPredefined :: Term -> Err (Term,Bool) -appPredefined t = case t of - App f x0 -> do - (x,_) <- appPredefined x0 - case f of - -- one-place functions - Q (mod,f) | mod == cPredef -> - case x of - (K s) | f == cLength -> retb $ EInt $ length s - (K s) | f == cIsUpper -> retb $ if (all isUpper s) then predefTrue else predefFalse - (K s) | f == cToUpper -> retb $ K $ map toUpper s - (K s) | f == cToLower -> retb $ K $ map toLower s - (K s) | f == cError -> retb $ Error s - - _ -> retb t - - -- two-place functions - App (Q (mod,f)) z0 | mod == cPredef -> do - (z,_) <- appPredefined z0 - case (norm z, norm x) of - (EInt i, K s) | f == cDrop -> retb $ K (drop i s) - (EInt i, K s) | f == cTake -> retb $ K (take i s) - (EInt i, K s) | f == cTk -> retb $ K (take (max 0 (length s - i)) s) - (EInt i, K s) | f == cDp -> retb $ K (drop (max 0 (length s - i)) s) - (K s, K t) | f == cEqStr -> retb $ if s == t then predefTrue else predefFalse - (K s, K t) | f == cOccur -> retb $ if substring s t then predefTrue else predefFalse - (K s, K t) | f == cOccurs -> retb $ if any (flip elem t) s then predefTrue else predefFalse - (EInt i, EInt j) | f == cEqInt -> retb $ if i==j then predefTrue else predefFalse - (EInt i, EInt j) | f == cLessInt -> retb $ if i retb $ EInt $ i+j - (_, t) | f == cShow && notVar t -> retb $ foldrC $ map K $ words $ render (ppTerm Unqualified 0 t) - (_, K s) | f == cRead -> retb $ Cn (identS s) --- because of K, only works for atomic tags - (_, t) | f == cToStr -> trm2str t >>= retb - _ -> retb t ---- prtBad "cannot compute predefined" t - - -- three-place functions - App (App (Q (mod,f)) z0) y0 | mod == cPredef -> do - (y,_) <- appPredefined y0 - (z,_) <- appPredefined z0 - case (z, y, x) of - (ty,op,t) | f == cMapStr -> retf $ mapStr ty op t - _ | f == cEqVal && notVar y && notVar x -> retb $ if y==x then predefTrue else predefFalse - _ -> retb t ---- prtBad "cannot compute predefined" t - - _ -> retb t ---- prtBad "cannot compute predefined" t - _ -> retb t - ---- should really check the absence of arg variables - where - retb t = return (retc t,True) -- no further computing needed - retf t = return (retc t,False) -- must be computed further - retc t = case t of - K [] -> t - K s -> foldr1 C (map K (words s)) - _ -> t - norm t = case t of - Empty -> K [] - C u v -> case (norm u,norm v) of - (K x,K y) -> K (x +++ y) - _ -> t - _ -> t - notVar t = case t of - Vr _ -> False - App f a -> notVar f && notVar a - _ -> True ---- would need to check that t is a value - foldrC ts = if null ts then Empty else foldr1 C ts - --- read makes variables into constants - -predefTrue = QC (cPredef,cPTrue) -predefFalse = QC (cPredef,cPFalse) - -substring :: String -> String -> Bool -substring s t = case (s,t) of - (c:cs, d:ds) -> (c == d && substring cs ds) || substring s ds - ([],_) -> True - _ -> False - -trm2str :: Term -> Err Term -trm2str t = case t of - R ((_,(_,s)):_) -> trm2str s - T _ ((_,s):_) -> trm2str s - V _ (s:_) -> trm2str s - C _ _ -> return $ t - K _ -> return $ t - S c _ -> trm2str c - Empty -> return $ t - _ -> Bad (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 t)) - --- simultaneous recursion on type and term: type arg is essential! --- But simplify the task by assuming records are type-annotated --- (this has been done in type checking) -mapStr :: Type -> Term -> Term -> Term -mapStr ty f t = case (ty,t) of - _ | elem ty [typeStr,typeTok] -> App f t - (_, R ts) -> R [(l,mapField v) | (l,v) <- ts] - (Table a b,T ti cs) -> T ti [(p,mapStr b f v) | (p,v) <- cs] - _ -> t - where - mapField (mty,te) = case mty of - Just ty -> (mty,mapStr ty f te) - _ -> (mty,te) --} diff --git a/src/compiler/GF/Compile/Compute/ConcreteNew.hs b/src/compiler/GF/Compile/Compute/ConcreteNew.hs index f9edc931c..a9ae63960 100644 --- a/src/compiler/GF/Compile/Compute/ConcreteNew.hs +++ b/src/compiler/GF/Compile/Compute/ConcreteNew.hs @@ -15,7 +15,7 @@ import GF.Grammar.Lockfield(isLockLabel,lockRecType) --unlockRecord,lockLabel import GF.Compile.Compute.Value hiding (Error) import GF.Compile.Compute.Predef(predef,predefName,delta) import GF.Data.Str(Str,glueStr,str2strings,str,sstr,plusStr,strTok) -import GF.Data.Operations(Err,err,errIn,maybeErr,combinations,mapPairsM) +import GF.Data.Operations(Err,err,errIn,maybeErr,mapPairsM) import GF.Data.Utilities(mapFst,mapSnd) import GF.Infra.Option import Control.Monad(ap,liftM,liftM2) -- ,unless,mplus @@ -318,7 +318,7 @@ strsFromValue t = case t of return [strTok (str2strings def) vars | def <- d0, vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] | - vv <- combinations v0] + vv <- sequence v0] ] VFV ts -> concat # mapM strsFromValue ts VStrs ts -> concat # mapM strsFromValue ts diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs index 4c1520961..143a4f96f 100644 --- a/src/compiler/GF/Compile/Update.hs +++ b/src/compiler/GF/Compile/Update.hs @@ -109,8 +109,9 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js -- add the instance opens to an incomplete module "with" instances Just (ext,incl,ops) -> do let (infs,insts) = unzip ops - let stat' = ifNull MSComplete (const MSIncomplete) - [i | i <- is, notElem i infs] + let stat' = if all (flip elem infs) is + then MSComplete + else MSIncomplete unless (stat' == MSComplete || stat == MSIncomplete) (checkError ("module" <+> i <+> "remains incomplete")) ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- lookupModule gr ext diff --git a/src/compiler/GF/CompileInParallel.hs b/src/compiler/GF/CompileInParallel.hs index fecce0a68..68ac7aa4a 100644 --- a/src/compiler/GF/CompileInParallel.hs +++ b/src/compiler/GF/CompileInParallel.hs @@ -83,7 +83,7 @@ batchCompile1 lib_dir (opts,filepaths) = let rel = relativeTo lib_dir cwd prelude_dir = lib_dir"prelude" gfoDir = flag optGFODir opts - maybe done (D.createDirectoryIfMissing True) gfoDir + maybe (return ()) (D.createDirectoryIfMissing True) gfoDir {- liftIO $ writeFile (maybe "" id gfoDir"paths") (unlines . map (unwords . map rel) . nub $ map snd filepaths) @@ -241,14 +241,14 @@ instance (Functor m,Monad m) => Applicative (CollectOutput m) where (<*>) = ap instance Monad m => Monad (CollectOutput m) where - return x = CO (return (done,x)) + return x = CO (return (return (),x)) CO m >>= f = CO $ do (o1,x) <- m let CO m2 = f x (o2,y) <- m2 return (o1>>o2,y) instance MonadIO m => MonadIO (CollectOutput m) where liftIO io = CO $ do x <- liftIO io - return (done,x) + return (return (),x) instance Output m => Output (CollectOutput m) where ePutStr s = CO (return (ePutStr s,())) diff --git a/src/compiler/GF/CompileOne.hs b/src/compiler/GF/CompileOne.hs index 318d0d3a3..e873d6119 100644 --- a/src/compiler/GF/CompileOne.hs +++ b/src/compiler/GF/CompileOne.hs @@ -21,7 +21,7 @@ import GF.Grammar.Binary(decodeModule,encodeModule) import GF.Infra.Option import GF.Infra.UseIO(FullPath,IOE,isGFO,gf2gfo,MonadIO(..),Output(..),putPointE) import GF.Infra.CheckM(runCheck') -import GF.Data.Operations(ErrorMonad,liftErr,(+++),done) +import GF.Data.Operations(ErrorMonad,liftErr,(+++)) import GF.System.Directory(doesFileExist,getCurrentDirectory,renameFile) import System.FilePath(makeRelative) @@ -66,7 +66,7 @@ reuseGFO opts srcgr file = if flag optTagsOnly opts then writeTags opts srcgr (gf2gftags opts file) sm1 - else done + else return () return (Just file,sm) @@ -137,7 +137,7 @@ compileSourceModule opts cwd mb_gfFile gr = idump opts pass (dump out) return (ret out) - maybeM f = maybe done f + maybeM f = maybe (return ()) f --writeGFO :: Options -> InitPath -> FilePath -> SourceModule -> IOE () @@ -158,12 +158,12 @@ writeGFO opts cwd file mo = --intermOut :: Options -> Dump -> Doc -> IOE () intermOut opts d doc | dump opts d = ePutStrLn (render ("\n\n--#" <+> show d $$ doc)) - | otherwise = done + | otherwise = return () idump opts pass = intermOut opts (Dump pass) . ppModule Internal warnOut opts warnings - | null warnings = done + | null warnings = return () | otherwise = do t <- getTermColors ePutStr (blueFg t);ePutStr ws;ePutStrLn (restore t) where diff --git a/src/compiler/GF/Data/Operations.hs b/src/compiler/GF/Data/Operations.hs index cb9b3f9ac..4daa9c5d8 100644 --- a/src/compiler/GF/Data/Operations.hs +++ b/src/compiler/GF/Data/Operations.hs @@ -26,8 +26,8 @@ module GF.Data.Operations ( -- ** Checking checkUnique, unifyMaybeBy, unifyMaybe, - -- ** Monadic operations on lists and pairs - mapPairListM, mapPairsM, pairM, + -- ** Monadic operations on lists and pairs + mapPairsM, pairM, -- ** Printing indent, (+++), (++-), (++++), (+++-), (+++++), @@ -39,8 +39,7 @@ module GF.Data.Operations ( topoTest, topoTest2, -- ** Misc - ifNull, - combinations, done, readIntArg, --singleton, + readIntArg, iterFix, chunks, ) where @@ -60,9 +59,6 @@ infixr 5 ++- infixr 5 ++++ infixr 5 +++++ -ifNull :: b -> ([a] -> b) -> [a] -> b -ifNull b f xs = if null xs then b else f xs - -- the Error monad -- | Add msg s to 'Maybe' failures @@ -70,7 +66,7 @@ maybeErr :: ErrorMonad m => String -> Maybe a -> m a maybeErr s = maybe (raise s) return testErr :: ErrorMonad m => Bool -> String -> m () -testErr cond msg = if cond then done else raise msg +testErr cond msg = if cond then return () else raise msg errIn :: ErrorMonad m => String -> m a -> m a errIn msg m = handle m (\s -> raise (s ++++ "OCCURRED IN" ++++ msg)) @@ -78,9 +74,6 @@ errIn msg m = handle m (\s -> raise (s ++++ "OCCURRED IN" ++++ msg)) lookupErr :: (ErrorMonad m,Eq a,Show a) => a -> [(a,b)] -> m b lookupErr a abs = maybeErr ("Unknown" +++ show a) (lookup a abs) -mapPairListM :: Monad m => ((a,b) -> m c) -> [(a,b)] -> m [(a,c)] -mapPairListM f xys = mapM (\ p@(x,_) -> liftM ((,) x) (f p)) xys - mapPairsM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)] mapPairsM f xys = mapM (\ (x,y) -> liftM ((,) x) (f y)) xys @@ -193,21 +186,6 @@ wrapLines n s@(c:cs) = l = length w _ -> s -- give up!! ---- optWrapLines = if argFlag "wraplines" True then wrapLines 0 else id - --- | 'combinations' is the same as 'sequence'!!! --- peb 30\/5-04 -combinations :: [[a]] -> [[a]] -combinations t = case t of - [] -> [[]] - aa:uu -> [a:u | a <- aa, u <- combinations uu] - -{- --- | 'singleton' is the same as 'return'!!! -singleton :: a -> [a] -singleton = (:[]) --} - -- | Topological sorting with test of cyclicity topoTest :: Ord a => [(a,[a])] -> Either [a] [[a]] topoTest = topologicalSort . mkRel' @@ -247,10 +225,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 --- | @return ()@ -done :: Monad m => m () -done = return () - class (Functor m,Monad m) => ErrorMonad m where raise :: String -> m a handle :: m a -> (String -> m a) -> m a diff --git a/src/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs index 68c0191ae..9f774fb2c 100644 --- a/src/compiler/GF/Grammar/Lookup.hs +++ b/src/compiler/GF/Grammar/Lookup.hs @@ -166,11 +166,11 @@ allParamValues cnc ptyp = RecType r -> do let (ls,tys) = unzip $ sortByFst r tss <- mapM (allParamValues cnc) tys - return [R (zipAssign ls ts) | ts <- combinations tss] + return [R (zipAssign ls ts) | ts <- sequence tss] Table pt vt -> do pvs <- allParamValues cnc pt vvs <- allParamValues cnc vt - return [V pt ts | ts <- combinations (replicate (length pvs) vvs)] + return [V pt ts | ts <- sequence (replicate (length pvs) vvs)] _ -> raise (render ("cannot find parameter values for" <+> ptyp)) where -- to normalize records and record types diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs index ab2e53473..4c92fae8c 100644 --- a/src/compiler/GF/Grammar/Macros.hs +++ b/src/compiler/GF/Grammar/Macros.hs @@ -554,16 +554,12 @@ strsFromTerm t = case t of return [strTok (str2strings def) vars | def <- d0, vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] | - vv <- combinations v0] + vv <- sequence v0] ] FV ts -> mapM strsFromTerm ts >>= return . concat Strs ts -> mapM strsFromTerm ts >>= return . concat _ -> raise (render ("cannot get Str from term" <+> ppTerm Unqualified 0 t)) --- | to print an Str-denoting term as a string; if the term is of wrong type, the error msg -stringFromTerm :: Term -> String -stringFromTerm = err id (ifNull "" (sstr . head)) . strsFromTerm - getTableType :: TInfo -> Err Type getTableType i = case i of TTyped ty -> return ty diff --git a/src/compiler/GF/Interactive.hs b/src/compiler/GF/Interactive.hs index 7eb873fbc..b68a1bc2f 100644 --- a/src/compiler/GF/Interactive.hs +++ b/src/compiler/GF/Interactive.hs @@ -12,7 +12,7 @@ import GF.Command.CommandInfo import GF.Command.Help(helpCommand) import GF.Command.Abstract import GF.Command.Parse(readCommandLine,pCommand) -import GF.Data.Operations (Err(..),done) +import GF.Data.Operations (Err(..)) import GF.Data.Utilities(whenM,repeatM) import GF.Grammar hiding (Ident,isPrefixOf) import GF.Infra.UseIO(ioErrorText,putStrLnE) @@ -162,7 +162,7 @@ execute1' s0 = do execute . lines =<< lift (restricted (readFile w)) continue where - execute [] = done + execute [] = return () execute (line:lines) = whenM (execute1' line) (execute lines) execute_history _ = @@ -287,8 +287,8 @@ importInEnv opts files = pgf1 <- importGrammar pgf0 opts' files if (verbAtLeast opts Normal) then putStrLnFlush $ - unwords $ "\nLanguages:" : map showCId (languages pgf1) - else done + unwords $ "\nLanguages:" : map showCId (languages pgf1) + else return () return pgf1 tryGetLine = do diff --git a/src/compiler/GF/Interactive2.hs b/src/compiler/GF/Interactive2.hs index eaf149c3d..02e42e19e 100644 --- a/src/compiler/GF/Interactive2.hs +++ b/src/compiler/GF/Interactive2.hs @@ -10,7 +10,7 @@ import GF.Command.CommandInfo import GF.Command.Help(helpCommand) import GF.Command.Abstract import GF.Command.Parse(readCommandLine,pCommand) -import GF.Data.Operations (Err(..),done) +import GF.Data.Operations (Err(..)) import GF.Data.Utilities(whenM,repeatM) import GF.Infra.UseIO(ioErrorText,putStrLnE) @@ -164,7 +164,7 @@ execute1' s0 = continue where execute :: [String] -> ShellM () - execute [] = done + execute [] = return () execute (line:lines) = whenM (execute1' line) (execute lines) execute_history _ = @@ -279,14 +279,14 @@ importInEnv opts files = _ | flag optRetainResource opts -> putStrLnE "Flag -retain is not supported in this shell" [file] | takeExtensions file == ".pgf" -> importPGF file - [] -> done + [] -> return () _ -> do putStrLnE "Can only import one .pgf file" where importPGF file = do gfenv <- get case multigrammar gfenv of Just _ -> putStrLnE "Discarding previous grammar" - _ -> done + _ -> return () pgf1 <- lift $ readPGF2 file let gfenv' = gfenv { pgfenv = pgfEnv pgf1 } when (verbAtLeast opts Normal) $