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

more dead code

Browse Source
This commit is contained in:
krangelov
2019-09-20 16:15:28 +02:00
parent 29662350dc
commit 30eef61f0a
12 changed files with 29 additions and 203 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
gf.cabal
View File

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

2
src/compiler/GF/Compile/CheckGrammar.hs
View File

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

143
src/compiler/GF/Compile/Compute/AppPredefined.hs
View File

@@ -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<j then predefTrue else predefFalse
(EInt i, EInt j) | f == cPlus -> 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)
-}

4
src/compiler/GF/Compile/Compute/ConcreteNew.hs
View File

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

5
src/compiler/GF/Compile/Update.hs
View File

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

6
src/compiler/GF/CompileInParallel.hs
View File

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

10
src/compiler/GF/CompileOne.hs
View File

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

34
src/compiler/GF/Data/Operations.hs
View File

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

4
src/compiler/GF/Grammar/Lookup.hs
View File

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

6
src/compiler/GF/Grammar/Macros.hs
View File

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

8
src/compiler/GF/Interactive.hs
View File

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

8
src/compiler/GF/Interactive2.hs
View File

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