diff options
Diffstat (limited to 'src-3.0/GF/Shell/PShell.hs')
| -rw-r--r-- | src-3.0/GF/Shell/PShell.hs | 174 |
1 files changed, 174 insertions, 0 deletions
diff --git a/src-3.0/GF/Shell/PShell.hs b/src-3.0/GF/Shell/PShell.hs new file mode 100644 index 000000000..68cb4d629 --- /dev/null +++ b/src-3.0/GF/Shell/PShell.hs @@ -0,0 +1,174 @@ +---------------------------------------------------------------------- +-- | +-- Module : PShell +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/10/06 14:21:34 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.28 $ +-- +-- parsing GF shell commands. AR 11\/11\/2001 +----------------------------------------------------------------------------- + +module GF.Shell.PShell where + +import GF.Data.Operations +import GF.Infra.UseIO +import GF.Compile.ShellState +import GF.Shell.ShellCommands +import GF.Shell +import GF.Infra.Option +import GF.Compile.PGrammar (pzIdent, pTrm) --- (string2formsAndTerm) +import GF.API +import GF.System.Arch (fetchCommand) +import GF.UseGrammar.Tokenize (wordsLits) + +import Data.Char (isDigit, isSpace) +import System.IO.Error + +-- parsing GF shell commands. AR 11/11/2001 + +-- | getting a sequence of command lines as input +getCommandLines :: HState -> IO (String,[CommandLine]) +getCommandLines st = do + s <- fetchCommand "> " + return (s,pCommandLines st s) + +getCommandLinesBatch :: HState -> IO (String,[CommandLine]) +getCommandLinesBatch st = do + s <- catch getLine (\e -> if isEOFError e then return "q" else ioError e) + return $ (s,pCommandLines st s) + +pCommandLines :: HState -> String -> [CommandLine] +pCommandLines st = + map (pCommandLine st) . concatMap (chunks ";;" . wordsLits) . lines + +-- | Remove single or double quotes around a string +unquote :: String -> String +unquote (x:xs@(_:_)) | x `elem` "\"'" && x == last xs = init xs +unquote s = s + +pCommandLine :: HState -> [String] -> CommandLine +pCommandLine st (c@('%':_):args) = pCommandLine st $ resolveShMacro st c args +pCommandLine st (dc:c:def) | abbrevCommand dc == "dc" = ((CDefineCommand c def, noOptions),AUnit,[]) +pCommandLine st s = pFirst (chks s) where + pFirst cos = case cos of + (c,os,[a]) : cs -> ((c,os), a, pCont cs) + _ -> ((CVoid,noOptions), AError "no parse", []) + pCont cos = case cos of + (c,os,_) : cs -> (c,os) : pCont cs + _ -> [] + chks = map (pCommandOpt st) . chunks "|" + +pCommandOpt :: HState -> [String] -> (Command, Options, [CommandArg]) +pCommandOpt _ (w:ws) = let + (os, co) = getOptions "-" ws + (comm, args) = pCommand (abbrevCommand w:co) + in + (comm, os, args) +pCommandOpt _ s = (CVoid, noOptions, [AError "no parse"]) + +pInputString :: String -> [CommandArg] +pInputString s = case s of + ('"':_:_) | last s == '"' -> [AString (read s)] + _ -> [AError "illegal string"] + +-- | command @rl@ can be written @remove_language@ etc. +abbrevCommand :: String -> String +abbrevCommand = hds . words . map u2sp where + u2sp c = if c=='_' then ' ' else c + hds s = case s of + [w@[_,_]] -> w + _ -> map head s + +pCommand :: [String] -> (Command, [CommandArg]) +pCommand ws = case ws of + + "i" : f : [] -> aUnit (CImport (unquote f)) + "rl" : l : [] -> aUnit (CRemoveLanguage (language l)) + "e" : [] -> aUnit CEmptyState + "cm" : a : [] -> aUnit (CChangeMain (Just (pzIdent a))) + "cm" : [] -> aUnit (CChangeMain Nothing) + "s" : [] -> aUnit CStripState + "tg" : f : [] -> aUnit (CTransformGrammar f) + "cl" : f : [] -> aUnit (CConvertLatex f) + + "ph" : [] -> aUnit CPrintHistory + "dt" : f : t -> aTerm (CDefineTerm (unquote f)) t + + "l" : s -> aTermLi CLinearize s + + "p" : s -> aString CParse s + "t" : i:o: s -> aString (CTranslate (language i) (language o)) s + "gr" : [] -> aUnit CGenerateRandom + "gr" : t -> aTerm CGenerateRandom t + "gt" : [] -> aUnit CGenerateTrees + "gt" : t -> aTerm CGenerateTrees t + "pt" : s -> aTerm CPutTerm s + "wt" : f : s -> aTerm (CWrapTerm (pzIdent f)) s + "at" : f : s -> aTerm (CApplyTransfer (pmIdent f)) s + "ma" : s -> aString CMorphoAnalyse s + "tt" : s -> aString CTestTokenizer s + "cc" : s -> aUnit $ CComputeConcrete $ unwords s + "so" : s -> aUnit $ CShowOpers $ unwords s + "tb" : [] -> aUnit CTreeBank + "ut" : s -> aString CLookupTreebank s + + "tq" : i:o:[] -> aUnit (CTranslationQuiz (language i) (language o)) + "tl":i:o:[] -> aUnit (CTranslationList (language i) (language o)) + "mq" : [] -> aUnit CMorphoQuiz + "ml" : [] -> aUnit CMorphoList + + "wf" : f : s -> aString (CWriteFile (unquote f)) s + "af" : f : s -> aString (CAppendFile (unquote f)) s + "rf" : f : [] -> aUnit (CReadFile (unquote f)) + "sa" : s -> aString CSpeakAloud s + "si" : [] -> aUnit CSpeechInput + "ps" : s -> aString CPutString s + "st" : s -> aTerm CShowTerm s + "!" : s -> aUnit (CSystemCommand (unwords s)) + "?" : s : x -> aString (CSystemCommand (unquote s)) x + "sc" : s -> aUnit (CSystemCommand (unwords s)) + "g" : f : s -> aString (CGrep (unquote f)) s + + "sf" : l : [] -> aUnit (CSetLocalFlag (language l)) + "sf" : [] -> aUnit CSetFlag + + "pg" : [] -> aUnit CPrintGrammar + "pi" : c : [] -> aUnit $ CPrintInformation (pzIdent c) + + "pj" : [] -> aUnit CPrintGramlet + "pxs" : [] -> aUnit CPrintCanonXMLStruct + "px" : [] -> aUnit CPrintCanonXML + "pm" : [] -> aUnit CPrintMultiGrammar + "vg" : [] -> aUnit CShowGrammarGraph + "vt" : s -> aTerm CShowTreeGraph s + "sg" : [] -> aUnit CPrintSourceGrammar + "po" : [] -> aUnit CPrintGlobalOptions + "pl" : [] -> aUnit CPrintLanguages + "h" : c : [] -> aUnit $ CHelp (Just (abbrevCommand c)) + "h" : [] -> aUnit $ CHelp Nothing + + "q" : [] -> aImpure ICQuit + "eh" : f : [] -> aImpure (ICExecuteHistory f) + n : [] | all isDigit n -> aImpure (ICEarlierCommand (readIntArg n)) + + "es" : [] -> aImpure ICEditSession + "ts" : [] -> aImpure ICTranslateSession + "r" : [] -> aImpure ICReload + _ -> (CVoid, []) + + where + aString c ss = (c, pInputString (unwords ss)) + aTerm c ss = (c, [ASTrm $ unwords ss]) ---- [ASTrms [s2t (unwords ss)]]) + aUnit c = (c, [AUnit]) + aImpure = aUnit . CImpure + + aTermLi c ss = (c [], [ASTrm $ unwords ss]) + ---- (c forms, [ASTrms [term]]) where + ---- (forms,term) = ([], s2t (unwords ss)) ----string2formsAndTerm(unwords ss) + pmIdent m = case span (/='.') m of + (k,_:f) -> (Just (pzIdent k), pzIdent f) + _ -> (Nothing,pzIdent m) |