From 055c0d0d5a5bb0dc75904fe53df7f2e4f5732a8f Mon Sep 17 00:00:00 2001 From: aarne Date: Wed, 21 May 2008 09:26:44 +0000 Subject: GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3 --- src-3.0/GF/Shell/CommandL.hs | 198 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 198 insertions(+) create mode 100644 src-3.0/GF/Shell/CommandL.hs (limited to 'src-3.0/GF/Shell/CommandL.hs') diff --git a/src-3.0/GF/Shell/CommandL.hs b/src-3.0/GF/Shell/CommandL.hs new file mode 100644 index 000000000..efb6460b4 --- /dev/null +++ b/src-3.0/GF/Shell/CommandL.hs @@ -0,0 +1,198 @@ +---------------------------------------------------------------------- +-- | +-- Module : CommandL +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/08/17 15:13:55 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.21 $ +-- +-- (Description of the module) +----------------------------------------------------------------------------- + +module GF.Shell.CommandL where + +import GF.Data.Operations +import GF.Infra.UseIO + +import GF.Canon.CMacros +import GF.Grammar.Values (Tree) + +import GF.UseGrammar.GetTree +import GF.Compile.ShellState +import GF.Infra.Option +import GF.UseGrammar.Session +import GF.Shell.Commands +import GF.UseGrammar.Tokenize (wordsLits) + +import Data.Char +import Data.List (intersperse) +import Control.Monad (foldM) + +import GF.Text.UTF8 + +-- | a line-based shell +initEditLoop :: CEnv -> IO () -> IO () +initEditLoop env resume = do + let env' = startEditEnv 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 + +-- | execute a command script and return a tree +execCommandHistory :: CEnv -> String -> IO (CEnv,Tree) +execCommandHistory env s = do + let env' = startEditEnv env + let state = initSStateEnv env' + (env',state') <- foldM exec (env,state) $ lines s + return $ (env',treeSState state') + + where + + exec (env,state) l = do + let c = pCommand l + execCommand env c state + + + +getCommand :: IO Command +getCommand = do + s <- getLine + return $ pCommand s + +-- | decodes UTF8 if u==True, i.e. if the grammar uses UTF8; +-- used in the Java GUI, which always uses UTF8 +getCommandUTF :: Bool -> IO [(String,Command)] +getCommandUTF u = do + s <- getLine + return $ pCommandMsgs $ if u then decodeUTF8 s else s + +pCommandMsgs :: String -> [(String,Command)] +pCommandMsgs = map (pCommandMsg . unwords) . concatMap (chunks ";;" . words) . lines + +pCommand :: String -> Command +pCommand = snd . pCommandMsg + + +pCommandMsg :: String -> (String,Command) +pCommandMsg s = (m,pCommandWords $ words c) where + (m,c) = case s of + '[':s2 -> let (a,b) = span (/=']') s2 in (a,drop 1 b) + _ -> ("",s) + pCommandWords s = case s of + "n" : cat : _ -> CNewCat cat + "t" : ws -> CNewTree $ unwords ws + "g" : ws -> CRefineWithTree $ unwords ws -- example: *g*ive + "p" : ws -> CRefineParse $ unwords ws + "rc": i : _ -> CRefineWithClip (readIntArg i) + ">" : i : _ -> CAhead $ readIntArg i + ">" : [] -> CAhead 1 + "<" : i : _ -> CBack $ readIntArg i + "<" : [] -> CBack 1 + ">>" : _ -> CNextMeta + "<<" : _ -> CPrevMeta + "'" : _ -> CTop + "+" : _ -> CLast + "mp" : p -> CMovePosition (readIntList (unwords p)) + "ct" : p:q:_ -> CCopyPosition (readIntList p) (readIntList q) + "r" : f : _ -> CRefineWithAtom f + "w" : f:i : _ -> CWrapWithFun (f, readIntArg i) + "ch": f : _ -> CChangeHead f + "ph": f:i : _ -> CPeelHead (f, readIntArg i) + "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" : i : _ -> CUndo (readIntArg i) + "u" : _ -> CUndo 1 + "d" : _ -> CDelete + "ac" : _ -> CAddClip + "pc": i : _ -> CRemoveClip (readIntArg i) + "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 + "save":l:f:_ -> CCEnvSave l 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 :: CEnv -> String +initEditMsg env = unlines $ + "State-dependent editing commands are given in the menu:" : + " n [Cat] = new, r [Fun] = refine, w [Fun] [Int] = wrap,": + " ch [Fun] = change head, d = delete, s [Int] = select," : + " x [Var] [Var] = alpha convert." : + "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 :: CEnv -> String +initEditMsgEmpty env = initEditMsg env +++++ unlines ( + "Start editing by n Cat selecting category\n\n" : + "-------------\n" : + ["n" +++ cat | (_,cat) <- newCatMenu env] + ) + +showCurrentState :: CEnv -> SState -> String +showCurrentState env' state' = + unlines (tr ++ ["",""] ++ msg ++ ["",""] ++ map fst menu) + where (tr,msg,menu) = displaySStateIn env' state' + +-- | to read position; borrowed from Prelude; should be elsewhere +readIntList :: String -> [Int] +readIntList s = case [x | (x,t) <- reads s, ("","") <- lex t] of + [x] -> x + _ -> [] -- cgit v1.2.3