From b1402e8bd6a68a891b00a214d6cf184d66defe19 Mon Sep 17 00:00:00 2001 From: aarne Date: Mon, 22 Sep 2003 13:16:55 +0000 Subject: Founding the newly structured GF2.0 cvs archive. --- src/GF/Shell/CommandL.hs | 135 +++++++++++++++ src/GF/Shell/Commands.hs | 443 +++++++++++++++++++++++++++++++++++++++++++++++ src/GF/Shell/JGF.hs | 59 +++++++ src/GF/Shell/PShell.hs | 115 ++++++++++++ src/GF/Shell/SubShell.hs | 43 +++++ 5 files changed, 795 insertions(+) create mode 100644 src/GF/Shell/CommandL.hs create mode 100644 src/GF/Shell/Commands.hs create mode 100644 src/GF/Shell/JGF.hs create mode 100644 src/GF/Shell/PShell.hs create mode 100644 src/GF/Shell/SubShell.hs (limited to 'src/GF/Shell') diff --git a/src/GF/Shell/CommandL.hs b/src/GF/Shell/CommandL.hs new file mode 100644 index 000000000..463b3d4e4 --- /dev/null +++ b/src/GF/Shell/CommandL.hs @@ -0,0 +1,135 @@ +module CommandL where + +import Operations +import UseIO + +import CMacros + +import GetTree +import ShellState +import Option +import Session +import Commands + +import Char +import List (intersperse) + +import UTF8 + +-- a line-based shell + +initEditLoop :: CEnv -> IO () -> IO () +initEditLoop env resume = do + let env' = addGlobalOptions (options [sizeDisplay "short"]) env + putStrLnFlush $ initEditMsg env' + let state = initSStateEnv env' + putStrLnFlush $ showCurrentState env' state + editLoop env' state resume + +editLoop :: CEnv -> SState -> IO () -> IO () +editLoop env state resume = do + putStrFlush "edit> " + c <- getCommand + if (isQuit c) then resume else do + (env',state') <- execCommand env c state + let package = case c of + CCEnvEmptyAndImport _ -> initEditMsgEmpty env' + _ -> showCurrentState env' state' + putStrLnFlush package + + editLoop env' state' resume + +getCommand :: IO Command +getCommand = do + s <- getLine + return $ pCommand s + +getCommandUTF :: IO Command +getCommandUTF = do + s <- getLine + return $ pCommand s -- the GUI is doing this: $ decodeUTF8 s + +pCommand = pCommandWords . words where + pCommandWords s = case s of + "n" : cat : _ -> CNewCat (strings2Cat cat) + "t" : ws -> CNewTree $ unwords ws + "g" : ws -> CRefineWithTree $ unwords ws -- *g*ive + "p" : ws -> CRefineParse $ unwords ws + ">" : i : _ -> CAhead $ readIntArg i + ">" : [] -> CAhead 1 + "<" : i : _ -> CBack $ readIntArg i + "<" : [] -> CBack 1 + ">>" : _ -> CNextMeta + "<<" : _ -> CPrevMeta + "'" : _ -> CTop + "+" : _ -> CLast + "r" : f : _ -> CRefineWithAtom f + "w" : f:i : _ -> CWrapWithFun (strings2Fun f, readIntArg i) + "ch": f : _ -> CChangeHead (strings2Fun f) + "ph": _ -> CPeelHead + "x" : ws -> CAlphaConvert $ unwords ws + "s" : i : _ -> CSelectCand (readIntArg i) + "f" : "unstructured" : _ -> CRemoveOption showStruct --- hmmm + "f" : "structured" : _ -> CAddOption showStruct --- hmmm + "f" : s : _ -> CAddOption (filterString s) + "u" : _ -> CUndo + "d" : _ -> CDelete + "c" : s : _ -> CTermCommand s + "a" : _ -> CRefineRandom --- *a*leatoire + "m" : _ -> CMenu +---- "ml" : s : _ -> changeMenuLanguage s +---- "ms" : s : _ -> changeMenuSize s +---- "mt" : s : _ -> changeMenuTyped s + "v" : _ -> CView + "q" : _ -> CQuit + "h" : _ -> CHelp initEditMsg + + "i" : file: _ -> CCEnvImport file + "e" : [] -> CCEnvEmpty + "e" : file: _ -> CCEnvEmptyAndImport file + + "open" : f: _ -> CCEnvOpenTerm f + "openstring": f: _ -> CCEnvOpenString f + + "on" :lang: _ -> CCEnvOn lang + "off":lang: _ -> CCEnvOff lang + "pfile" :f:_ -> CCEnvRefineParse f + "tfile" :f:_ -> CCEnvRefineWithTree f + +-- openstring file +-- pfile file +-- tfile file +-- on lang +-- off lang + + "gf": comm -> CCEnvGFShell (unwords comm) + + [] -> CVoid + _ -> CError + +-- well, this lists the commands of the line-based editor +initEditMsg env = unlines $ + "State-dependent editing commands are given in the menu:" : + " n = new, r = refine, w = wrap, d = delete, s = select." : + "Commands changing the environment:" : + " i [file] = import, e = empty." : + "Other commands:" : + " a = random, v = change view, u = undo, h = help, q = quit," : + " ml [Lang] = change menu language," : + " ms (short | long) = change menu command size," : + " mt (typed | untyped) = change menu item typing," : + " p [string] = refine by parsing, g [term] = refine by term," : + " > = down, < = up, ' = top, >> = next meta, << = previous meta." : +---- (" c [" ++ unwords (intersperse "|" allTermCommands) ++ "] = modify term") : +---- (" f [" ++ unwords (intersperse "|" allStringCommands) ++ "] = modify output") : + [] + +initEditMsgEmpty env = initEditMsg env +++++ unlines ( + "Start editing by n Cat selecting category\n\n" : + "-------------\n" : + ["n" +++ cat | (_,cat) <- newCatMenu env] + ) + +showCurrentState env' state' = + unlines (tr ++ ["",""] ++ msg ++ ["",""] ++ map fst menu) + where (tr,msg,menu) = displaySStateIn env' state' diff --git a/src/GF/Shell/Commands.hs b/src/GF/Shell/Commands.hs new file mode 100644 index 000000000..5c92c7bd6 --- /dev/null +++ b/src/GF/Shell/Commands.hs @@ -0,0 +1,443 @@ +module Commands where + +import Operations +import Zipper + +----import AccessGrammar (Term (Vr)) ---- +import qualified Grammar as G ---- Cat +import GFC +import qualified AbsGFC ---- Atom +import CMacros +import LookAbs + +import GetTree +import API +import ShellState + +import qualified Shell +import qualified Ident as I +import qualified PShell +import qualified Macros as M +import PrGrammar +import TypeCheck ---- tree2exp +import PGrammar +import IOGrammar +import UseIO +import Unicode + +import Option +import CF +----- import CFIdent (cat2CFCat, cfCat2Cat) +import Linear +import Randomized +import Editing +import Session +import Custom + +import Random (mkStdGen) +import Monad (liftM2) +import List (intersperse) +import Random (newStdGen) + +--- temporary hacks for GF 2.0 + +-- abstract command language for syntax editing. AR 22/8/2001 + +data Command = + CNewCat G.Cat + | CNewTree String + | CAhead Int + | CBack Int + | CNextMeta + | CPrevMeta + | CTop + | CLast + | CRefineWithTree String + | CRefineWithAtom String + | CRefineParse String + | CWrapWithFun (G.Fun,Int) + | CChangeHead G.Fun + | CPeelHead + | CAlphaConvert String + | CRefineRandom + | CSelectCand Int + | CTermCommand String + | CAddOption Option + | CRemoveOption Option + | CDelete + | CUndo + | CView + | CMenu + | CQuit + | CHelp (CEnv -> String) -- help message depends on grammar and interface + | CError -- syntax error in command + | CVoid -- empty command, e.g. just + +-- commands affecting CEnv + | CCEnvImport String + | CCEnvEmptyAndImport String + | CCEnvOpenTerm String + | CCEnvOpenString String + | CCEnvEmpty + + | CCEnvOn String + | CCEnvOff String + + | CCEnvGFShell String + +-- other commands using IO + | CCEnvRefineWithTree String + | CCEnvRefineParse String + +isQuit CQuit = True +isQuit _ = False + +-- an abstract environment type + +type CEnv = ShellState + +grammarCEnv = firstStateGrammar +canCEnv = canModules +concreteCEnv = cncId +abstractCEnv = absId + +stdGenCEnv env s = mkStdGen (length (displayJustStateIn env s) * 31 +11) --- + +initSStateEnv env = case getOptVal (stateOptions sgr) gStartCat of +---- Just cat -> action2commandNext (newCat gr (identC cat)) initSState + _ -> initSState + where + sgr = firstStateGrammar env + gr = stateGrammarST sgr + +-- the main function + +execCommand :: CEnv -> Command -> SState -> IO (CEnv,SState) +execCommand env c s = case c of +{- ---- +-- these commands do need IO + CCEnvImport file -> do + + gr <- optFile2grammar noOptions (maybeStateAbstract env) file + let lan = getLangNameOpt noOptions file + return (updateLanguage file (lan, getStateConcrete gr) + (initWithAbstract (stateAbstract gr) env), s) + + CCEnvEmptyAndImport file -> do + gr <- optFile2grammar noOptions Nothing file + let lan = getLangNameOpt noOptions file + return (updateLanguage file (lan, getStateConcrete gr) + (initWithAbstract (stateAbstract gr) emptyShellState), initSState) + + CCEnvEmpty -> do + return (emptyShellState, initSState) + + CCEnvGFShell command -> do + let cs = PShell.pCommandLines command + (msg,(env',_)) <- Shell.execLines False cs (Shell.initHState env) + return (env', changeMsg msg s) ---- + + CCEnvOpenTerm file -> do + c <- readFileIf file + let (fs,t) = envAndTerm file c + + env' <- shellStateFromFiles noOptions fs + return (env', (action2commandNext $ \x -> + (string2treeErr (grammarCEnv env') t x >>= + \t -> newTree t x)) s) + + CCEnvOpenString file -> do + c <- readFileIf file + let (fs,t) = envAndTerm file c + env' <- shellStateFromFiles noOptions fs + let gr = grammarCEnv env' + sgr = firstStateGrammar env' + agrs = allActiveGrammars env' + cat = firstCatOpts (stateOptions sgr) sgr + state0 <- err (const $ return (stateSState s)) return $ + newCat gr (cfCat2Cat cat) $ stateSState s + state1 <- return $ + refineByExps True gr (parseAny agrs cat t) $ changeState state0 s + return (env', state1) + + CCEnvOn name -> return (languageOn (language name) env,s) + CCEnvOff name -> return (languageOff (language name) env,s) +-} +-- this command is improved by the use of IO + CRefineRandom -> do + g <- newStdGen + return (env, action2commandNext (refineRandom g 41 cgr) s) + +-- these commands use IO + CCEnvRefineWithTree file -> do + str <- readFileIf file + execCommand env (CRefineWithTree str) s + CCEnvRefineParse file -> do + str <- readFileIf file + execCommand env (CRefineParse str) s + +-- other commands don't need IO; they are available in the fudget + c -> return (env, execECommand env c s) + + where + gr = grammarCEnv env + cgr = canCEnv env + opts = globalOptions env + + -- format for documents: import lines of form "-- file", then term + envAndTerm f s = + (map ((initFilePath f ++) . filter (/=' ') . drop 2) fs, unlines ss) where + (fs,ss) = span isImport (lines s) + isImport l = take 2 l == "--" + + +execECommand :: CEnv -> Command -> ECommand +execECommand env c = case c of + CNewCat cat -> action2commandNext $ \x -> do + s' <- newCat cgr cat x + uniqueRefinements cgr s' +{- ---- + CNewTree s -> action2commandNext $ \x -> do + t <- string2treeErr gr s + s' <- newTree t x + uniqueRefinements cgr s' +-} + CAhead n -> action2command (goAheadN n) + CBack n -> action2command (goBackN n) + CTop -> action2command $ return . goRoot + CLast -> action2command $ goLast + CNextMeta -> action2command goNextNewMeta + CPrevMeta -> action2command goPrevNewMeta + CRefineWithAtom s -> action2commandNext $ \x -> do + t <- string2ref gr s + s' <- refineWithAtom der cgr t x + uniqueRefinements cgr s' + CWrapWithFun fi -> action2commandNext $ wrapWithFun cgr fi + CChangeHead f -> action2commandNext $ changeFunHead cgr f + CPeelHead -> action2commandNext $ peelFunHead cgr +{- ---- + CAlphaConvert s -> action2commandNext $ \x -> + string2varPair s >>= \xy -> alphaConvert gr xy x + + CRefineWithTree s -> action2commandNext $ \x -> + (string2treeErr gr s x >>= \t -> refineWithTree der gr t x) + + CRefineParse str -> \s -> refineByExps der gr + (parseAny agrs (cat2CFCat (actCat (stateSState s))) str) s +-} + + CRefineRandom -> \s -> action2commandNext + (refineRandom (stdGenCEnv env s) 41 cgr) s + + CSelectCand i -> selectCand cgr i +{- ---- + CTermCommand c -> case c of + "paraphrase" -> \s -> + replaceByTermCommand gr c (actExp (stateSState s)) s + "transfer" -> action2commandNext $ + transferSubTree (stateTransferFun sgr) gr + _ -> replaceByEditCommand gr c +-} +---- CAddOption o -> changeStOptions (addOption o) +---- CRemoveOption o -> changeStOptions (removeOption o) + CDelete -> action2commandNext $ deleteSubTree cgr + CUndo -> undoCommand +---- CMenu -> \s -> changeMsg (menuState env s) s + CView -> changeView + CHelp h -> changeMsg [h env] + CVoid -> id + _ -> changeMsg ["command not yet implemented"] + where + sgr = firstStateGrammar env + agrs = [sgr] ---- allActiveGrammars env + cgr = canCEnv env + gr = grammarCEnv env + der = maybe True not $ caseYesNo (globalOptions env) noDepTypes + -- if there are dep types, then derived refs; deptypes is the default + +-- + + +{- ---- +string2varPair :: String -> Err (I.Ident,I.Ident) +string2varPair s = case words s of + x : y : [] -> liftM2 (,) (string2ident x) (string2ident y) + _ -> Bad "expected format 'x y'" + + +-- seen on display + +cMenuDisplay :: String -> Command +cMenuDisplay s = CAddOption (menuDisplay s) +-} +newCatMenu env = [(CNewCat c, prQIdent c) | ---- printname env initSState c) | + (c,[]) <- allCatsOf (canCEnv env)] + +mkRefineMenu :: CEnv -> SState -> [(Command,String)] +mkRefineMenu env sstate = [(c,s) | (c,(s,_)) <- mkRefineMenuAll env sstate] + +mkRefineMenuAll :: CEnv -> SState -> [(Command,(String,String))] +mkRefineMenuAll env sstate = + case (refinementsState cgr state, candsSState sstate, wrappingsState cgr state) of + ([],[],wraps) -> + [(CWrapWithFun fi, prWrap fit) | fit@(fi,_) <- wraps] ++ + [(CChangeHead f, prChangeHead f) | f <- headChangesState cgr state] ++ + [(CPeelHead, (ifShort "ph" "PeelHead", "ph")) | canPeelState cgr state] ++ + [(CDelete, (ifShort "d" "Delete", "d"))] + (refs,[],_) -> [(CRefineWithAtom (prRefinement f), prRef t) | t@(f,_) <- refs] + (_,cands,_) -> [(CSelectCand i, prCand (t,i)) | (t,i) <- zip cands [0..]] + + where + prRef (f,t) = + (ifShort "r" "Refine" +++ prOrLinExp f +++ ifTyped (":" +++ prt t), + "r" +++ prRefinement f) + prChangeHead f = + (ifShort "ch" "ChangeHead" +++ prOrLinFun f, + "ch" +++ prQIdent f) + prWrap ((f,i),t) = + (ifShort "w" "Wrap" +++ prOrLinFun f +++ ifTyped (":" +++ prt t) +++ + ifShort (show i) (prBracket (show i)), + "w" +++ prQIdent f +++ show i) + prCand (t,i) = + (ifShort ("s" +++ prOrLinExp t) ("Select" +++ prOrLinExp t),"s" +++ show i) + + gr = grammarCEnv env + cgr = canCEnv env + state = stateSState sstate + opts = addOptions (optsSState sstate) (globalOptions env) + ifOpt f v a b = case getOptVal opts f of + Just s | s == v -> a + _ -> b + ifShort = ifOpt sizeDisplay "short" + ifTyped t = ifOpt typeDisplay "typed" t "" + prOrLinExp t = prRefinement t --- maybe (prt t) prOrLinFun $ M.justIdentOf t + prOrLinTree t = case getOptVal opts menuDisplay of + Just "Abs" -> prt t + Just lang -> optLinearizeTreeVal (addOption firstLin opts) + (stateGrammarOfLang env (language lang)) t + _ -> prt t + prOrLinFun = printname env sstate + +-- there are three orthogonal parameters: Abs/[conc], short/long, typed/untyped +-- the default is Abs, long, untyped; the Menus menu changes the parameter + +emptyMenuItem = (CVoid,("","")) + + + +---- allStringCommands = snd $ customInfo customStringCommand +termCommandMenu, stringCommandMenu :: [(Command,String)] +termCommandMenu = [] +stringCommandMenu = [] + +displayCommandMenu :: CEnv -> [(Command,String)] +displayCommandMenu env = [] +{- ---- +---- allTermCommands = snd $ customInfo customEditCommand +termCommandMenu = [(CTermCommand s, s) | s <- allTermCommands] + +stringCommandMenu = + (CAddOption showStruct, "structured") : + (CRemoveOption showStruct, "unstructured") : + [(CAddOption (filterString s), s) | s <- allStringCommands] + +displayCommandMenu env = + [(CAddOption (menuDisplay s), s) | s <- "Abs" : langs] ++ + [(CAddOption (sizeDisplay s), s) | s <- ["short", "long"]] ++ + [(CAddOption (typeDisplay s), s) | s <- ["typed", "untyped"]] + where + langs = map prLanguage $ allLanguages env + +changeMenuLanguage, changeMenuSize, changeMenuTyped :: String -> Command +changeMenuLanguage s = CAddOption (menuDisplay s) +changeMenuSize s = CAddOption (sizeDisplay s) +changeMenuTyped s = CAddOption (typeDisplay s) +-} + +menuState env = map snd . mkRefineMenu env + +prState :: State -> [String] +prState s = prMarkedTree (loc2treeMarked s) + +displayJustStateIn env state = case displaySStateIn env state of + (t,msg,_) -> unlines (t ++ ["",""] ++ msg) --- ad hoc for CommandF + +displaySStateIn env state = (tree',msg,menu) where + (tree,msg,menu) = displaySState env state + grs = allStateGrammars env + lang = (viewSState state) `mod` (length grs + 3) + tree' = (tree : exp : linAll ++ separ (linAll ++ [tree])) !! lang + opts = addOptions (optsSState state) (globalOptions env) -- state opts override + lin g = linearizeState fudWrap opts g zipper + exp = return $ tree2string $ loc2tree zipper + zipper = stateSState state + linAll = map lin grs + separ = singleton . map unlines . intersperse [replicate 72 '*'] + +displaySStateJavaX env state = unlines $ tagXML "gfedit" $ concat [ + tagXML "linearizations" (concat + [tagAttrXML "lin" ("lang", prLanguage lang) ss | (lang,ss) <- lins]), + tagXML "tree" tree, + tagXML "message" msg, + tagXML "menu" (tagsXML "item" menu') + ] + where + (tree,msg,menu) = displaySState env state + menu' = [tagXML "show" [s] ++ tagXML "send" [c] | (s,c) <- menu] + (ls,grs) = unzip $ lgrs + lgrs = allStateGrammarsWithNames env --- allActiveStateGrammarsWithNames env + lins = (langAbstract, exp) : linAll + opts = addOptions (optsSState state) (globalOptions env) -- state opts override + lin (n,gr) = (n, map uni $ linearizeState noWrap opts gr zipper) where + uni = optEncodeUTF8 n gr . mkUnicode + exp = prprTree $ loc2tree zipper +--- xml = prExpXML gr $ tree2exp $ loc2tree zipper --- better: dir. from zipper + zipper = stateSState state + linAll = map lin lgrs + gr = firstStateGrammar env + +langAbstract = language "Abstract" +langXML = language "XML" + + +linearizeState :: (String -> [String]) -> Options -> GFGrammar -> State -> [String] +linearizeState wrap opts gr = + wrap . strop . unt . optLinearizeTreeVal opts gr . loc2tree + --- markedLinString br g + where + unt = id ---- customOrDefault (stateOptions g) useUntokenizer customUntokenizer g + strop = id ---- maybe id ($ g) $ customAsOptVal opts filterString customStringCommand + br = oElem showStruct opts + +noWrap, fudWrap :: String -> [String] +noWrap = lines +fudWrap = lines . wrapLines 0 --- + +displaySState :: CEnv -> SState -> ([String],[String],[(String,String)]) +displaySState env state = + (prState (stateSState state), msgSState state, menuSState env state) + +menuSState :: CEnv -> SState -> [(String,String)] +menuSState env state = [(s,c) | (_,(s,c)) <- mkRefineMenuAll env state] + +printname :: CEnv -> SState -> G.Fun -> String +printname env state f = case getOptVal opts menuDisplay of + Just "Abs" -> prQIdent f +---- Just lang -> printn lang f + _ -> prQIdent f + where + opts = addOptions (optsSState state) (globalOptions env) + printn lang = linearize gr ---- printOrLinearize (grammarOfLang env (language lang)) + gr = grammarCEnv env + + +--- XML printing; does not belong here! + +tagsXML t = concatMap (tagXML t) +tagAttrXML t av ss = mkTagAttrXML t av : map (indent 2) ss ++ [mkEndTagXML t] +tagXML t ss = mkTagXML t : map (indent 2) ss ++ [mkEndTagXML t] +mkTagXML t = '<':t ++ ">" +mkEndTagXML t = mkTagXML ('/':t) +mkTagAttrsXML t avs = '<':t +++ unwords [a++"="++v | (a,v) <- avs] ++">" +mkTagAttrXML t av = mkTagAttrsXML t [av] + diff --git a/src/GF/Shell/JGF.hs b/src/GF/Shell/JGF.hs new file mode 100644 index 000000000..215ad3e3e --- /dev/null +++ b/src/GF/Shell/JGF.hs @@ -0,0 +1,59 @@ +module JGF where + +import Operations +import UseIO + +import IOGrammar +import Option +import ShellState +import Session +import Commands +import CommandL + +import System +import UTF8 + + +-- GF editing session controlled by e.g. a Java program. AR 16/11/2001 + +sessionLineJ :: ShellState -> IO () +sessionLineJ env = do + putStrLnFlush $ initEditMsgJavaX env + let env' = addGlobalOptions (options [sizeDisplay "short"]) env + editLoopJ env' (initSState) + +editLoopJ :: CEnv -> SState -> IO () +editLoopJ = editLoopJnewX + +-- this is the real version, with XML + +editLoopJnewX :: CEnv -> SState -> IO () +editLoopJnewX env state = do + c <- getCommandUTF + case c of + CQuit -> return () + + c -> do + (env',state') <- execCommand env c state + let package = case c of + CCEnvImport _ -> initAndEditMsgJavaX env' state' + CCEnvEmptyAndImport _ -> initAndEditMsgJavaX env' state' + CCEnvOpenTerm _ -> initAndEditMsgJavaX env' state' + CCEnvOpenString _ -> initAndEditMsgJavaX env' state' + CCEnvEmpty -> initEditMsgJavaX env' + _ -> displaySStateJavaX env' state' + putStrLnFlush package + editLoopJnewX env' state' + +welcome = + "An experimental GF Editor for Java." ++ + "(c) Kristofer Johannisson, Janna Khegai, and Aarne Ranta 2002 under CNU GPL." + +initEditMsgJavaX env = encodeUTF8 $ unlines $ tagXML "gfinit" $ + tagsXML "newcat" [["n" +++ cat] | (_,cat) <- newCatMenu env] ++ + tagXML "language" [prLanguage langAbstract] ++ + concat [tagAttrXML "language" ("file",file) [prLanguage lang] | + (file,lang) <- zip (allGrammarFileNames env) (allLanguages env)] + +initAndEditMsgJavaX env state = + initEditMsgJavaX env ++++ displaySStateJavaX env state diff --git a/src/GF/Shell/PShell.hs b/src/GF/Shell/PShell.hs new file mode 100644 index 000000000..f28218f27 --- /dev/null +++ b/src/GF/Shell/PShell.hs @@ -0,0 +1,115 @@ +module PShell where + +import Operations +import UseIO +import ShellState +import Shell +import Option +import PGrammar (pzIdent, pTrm) --- (string2formsAndTerm) +import API +import Arch(fetchCommand) +import Char (isDigit) + +-- parsing GF shell commands. AR 11/11/2001 + +-- getting a sequence of command lines as input + +getCommandLines :: IO (String,[CommandLine]) +getCommandLines = do + s <- fetchCommand "> " + return (s,pCommandLines s) + +pCommandLines :: String -> [CommandLine] +pCommandLines = map pCommandLine . concatMap (chunks ";;" . words) . lines + +pCommandLine :: [String] -> CommandLine +pCommandLine 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 . chunks "|" + +pCommandOpt :: [String] -> (Command, Options, [CommandArg]) +pCommandOpt (w:ws) = let + (os, co) = getOptions "-" ws + (comm, args) = pCommand (w:co) + in + (comm, os, args) +pCommandOpt s = (CVoid, noOptions, [AError "no parse"]) + +pInputString :: String -> [CommandArg] +pInputString s = case s of + ('"':_:_) -> [AString (init (tail s))] + _ -> [AError "illegal string"] + +pCommand :: [String] -> (Command, [CommandArg]) +pCommand ws = case ws of + + "i" : f : [] -> aUnit (CImport f) + "rl" : l : [] -> aUnit (CRemoveLanguage (language l)) + "e" : [] -> aUnit CEmptyState + "tg" : f : [] -> aUnit (CTransformGrammar f) + "cl" : f : [] -> aUnit (CConvertLatex f) + + "ph" : [] -> aUnit CPrintHistory + + "l" : s -> aTermLi CLinearize s + + "p" : s -> aString CParse s + "t" : i:o: s -> aString (CTranslate (language i) (language o)) s + "gr" : [] -> aUnit (CGenerateRandom 1) + "gr" : n : [] -> aUnit (CGenerateRandom (readIntArg n)) -- deprecated 12/5/2001 + "pt" : s -> aTerm CPutTerm s +----- "wt" : f : s -> aTerm (CWrapTerm (string2id f)) s + "ma" : s -> aString CMorphoAnalyse s + "tt" : s -> aString CTestTokenizer s + "cc" : m : s -> aUnit $ CComputeConcrete (pzIdent m) $ unwords s + + "tq" : i:o:[] -> aUnit (CTranslationQuiz (language i) (language o)) + "tl":i:o:n:[] -> aUnit (CTranslationList (language i) (language o) (readIntArg n)) + "mq" : [] -> aUnit CMorphoQuiz + "ml" : n : [] -> aUnit (CMorphoList (readIntArg n)) + + "wf" : f : s -> aString (CWriteFile f) s + "af" : f : s -> aString (CAppendFile f) s + "rf" : f : [] -> aUnit (CReadFile f) + "sa" : s -> aString CSpeakAloud s + "ps" : s -> aString CPutString s + "st" : s -> aTerm CShowTerm s + "!" : s -> aUnit (CSystemCommand (unwords 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 + "po" : [] -> aUnit CPrintGlobalOptions + "pl" : [] -> aUnit CPrintLanguages + "h" : [] -> aUnit CHelp + + "q" : [] -> aImpure ICQuit + "eh" : f : [] -> aImpure (ICExecuteHistory f) + n : [] | all isDigit n -> aImpure (ICEarlierCommand (readIntArg n)) + + "es" : [] -> aImpure ICEditSession + "ts" : [] -> aImpure ICTranslateSession + + _ -> (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) diff --git a/src/GF/Shell/SubShell.hs b/src/GF/Shell/SubShell.hs new file mode 100644 index 000000000..c910d3dd0 --- /dev/null +++ b/src/GF/Shell/SubShell.hs @@ -0,0 +1,43 @@ +module SubShell where + +import Operations +import UseIO +import ShellState +import Option +import API + +import CommandL +import ArchEdit + +-- AR 20/4/2000 -- 12/11/2001 + +editSession :: Options -> ShellState -> IO () +editSession opts st + | oElem makeFudget opts = fudlogueEdit font st' + | otherwise = initEditLoop st' (return ()) + where + st' = addGlobalOptions opts st + font = maybe myUniFont mkOptFont $ getOptVal opts useFont + +myUniFont = "-mutt-clearlyu-medium-r-normal--0-0-100-100-p-0-iso10646-1" +mkOptFont = id +{- ---- +translateSession :: Options -> ShellState -> IO () +translateSession opts st = do + let grs = allStateGrammars st + cat = firstCatOpts opts (firstStateGrammar st) + trans = unlines . translateBetweenAll grs cat + translateLoop opts trans + +translateLoop opts trans = do + let fud = oElem makeFudget opts + font = maybe myUniFont mkOptFont $ getOptVal opts useFont + if fud then fudlogueWrite font trans else loopLine + where + loopLine = do + putStrFlush "trans> " + s <- getLine + if s == "." then return () else do + putStrLnFlush $ trans s + loopLine +-} -- cgit v1.2.3