diff options
Diffstat (limited to 'src-3.0/GF/Shell')
| -rw-r--r-- | src-3.0/GF/Shell/CommandL.hs | 198 | ||||
| -rw-r--r-- | src-3.0/GF/Shell/Commands.hs | 568 | ||||
| -rw-r--r-- | src-3.0/GF/Shell/HelpFile.hs | 723 | ||||
| -rw-r--r-- | src-3.0/GF/Shell/JGF.hs | 89 | ||||
| -rw-r--r-- | src-3.0/GF/Shell/PShell.hs | 174 | ||||
| -rw-r--r-- | src-3.0/GF/Shell/ShellCommands.hs | 246 | ||||
| -rw-r--r-- | src-3.0/GF/Shell/SubShell.hs | 66 | ||||
| -rw-r--r-- | src-3.0/GF/Shell/TeachYourself.hs | 87 |
8 files changed, 2151 insertions, 0 deletions
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 + _ -> [] diff --git a/src-3.0/GF/Shell/Commands.hs b/src-3.0/GF/Shell/Commands.hs new file mode 100644 index 000000000..8699c2fe7 --- /dev/null +++ b/src-3.0/GF/Shell/Commands.hs @@ -0,0 +1,568 @@ +---------------------------------------------------------------------- +-- | +-- Module : Commands +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/10/06 10:02:33 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.42 $ +-- +-- temporary hacks for GF 2.0 +-- +-- Abstract command language for syntax editing. AR 22\/8\/2001. +-- Most arguments are strings, to make it easier to receive them from e.g. Java. +-- See "CommandsL" for a parser of a command language. +----------------------------------------------------------------------------- + +module GF.Shell.Commands where + +import GF.Data.Operations +import GF.Data.Zipper + +import qualified GF.Grammar.Grammar as G ---- Cat, Fun, Q, QC +import GF.Canon.GFC +import GF.Canon.CMacros +import GF.Grammar.Macros (qq)---- +import GF.Grammar.LookAbs +import GF.Canon.Look +import GF.Grammar.Values (loc2treeFocus,tree2exp)---- + +import GF.UseGrammar.GetTree +import GF.API +import GF.Compile.ShellState + +import qualified GF.Shell as Shell +import qualified GF.Shell.PShell as PShell +import qualified GF.Grammar.Macros as M +import GF.Grammar.PrGrammar +import GF.Compile.PGrammar +import GF.API.IOGrammar +import GF.Infra.UseIO +import GF.Text.Unicode + +import GF.CF.CF +import GF.CF.CFIdent (cat2CFCat, cfCat2Cat) +import GF.CF.PPrCF (prCFCat) +import GF.UseGrammar.Linear +import GF.UseGrammar.Randomized +import GF.UseGrammar.Editing +import GF.UseGrammar.Session +import GF.UseGrammar.Custom + +import qualified GF.Infra.Ident as I +import GF.Infra.Option +import GF.Data.Str (sstr) ---- +import GF.Text.UTF8 ---- + +import System.Random (StdGen, mkStdGen, newStdGen) +import Control.Monad (liftM2, foldM) +import Data.List (intersperse) + +--- temporary hacks for GF 2.0 + +-- Abstract command language for syntax editing. AR 22/8/2001 +-- Most arguments are strings, to make it easier to receive them from e.g. Java. +-- See CommandsL for a parser of a command language. + +data Command = + CNewCat String + | CNewTree String + | CAhead Int + | CBack Int + | CNextMeta + | CPrevMeta + | CTop + | CLast + | CMovePosition [Int] + | CCopyPosition [Int] [Int] + | CRefineWithTree String + | CRefineWithClip Int + | CRefineWithAtom String + | CRefineParse String + | CWrapWithFun (String,Int) + | CChangeHead String + | CPeelHead (String,Int) + | CAlphaConvert String + | CRefineRandom + | CSelectCand Int + | CTermCommand String + | CAddOption Option + | CRemoveOption Option + | CDelete + | CAddClip + | CRemoveClip Int + | CUndo Int + | CView + | CMenu + | CQuit + | CHelp (CEnv -> String) -- ^ help message depends on grammar and interface + | CError -- ^ syntax error in command + | CVoid -- ^ empty command, e.g. just \<enter\> + + | CCEnvImport String -- ^ |-- commands affecting 'CEnv' + | CCEnvEmptyAndImport String -- ^ | + | CCEnvOpenTerm String -- ^ | + | CCEnvOpenString String -- ^ | + | CCEnvEmpty -- ^ | + + | CCEnvOn String -- ^ | + | CCEnvOff String -- ^ | + + | CCEnvGFShell String -- ^ |========== + + | CCEnvRefineWithTree String -- ^ |-- other commands using 'IO' + | CCEnvRefineParse String -- ^ | + | CCEnvSave String FilePath -- ^ |========== + +isQuit :: Command -> Bool +isQuit CQuit = True +isQuit _ = False + +-- | an abstract environment type +type CEnv = ShellState + +grammarCEnv :: CEnv -> StateGrammar +grammarCEnv = firstStateGrammar + +canCEnv :: CEnv -> CanonGrammar +canCEnv = canModules + +concreteCEnv, abstractCEnv :: StateGrammar -> I.Ident +concreteCEnv = cncId +abstractCEnv = absId + +stdGenCEnv :: CEnv -> SState -> StdGen +stdGenCEnv env s = mkStdGen (length (displayJustStateIn env s) * 31 +11) --- + +initSStateEnv :: CEnv -> SState +initSStateEnv env = case getOptVal (stateOptions sgr) gStartCat of + Just cat -> action2commandNext (newCat gr (abs, I.identC cat)) initSState + _ -> initSState + where + sgr = firstStateGrammar env + abs = absId sgr + 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 -> useIOE (env,s) $ do + st <- shellStateFromFiles optss env file + return (st,s) + + CCEnvEmptyAndImport file -> useIOE (emptyShellState, initSState) $ do + st <- shellStateFromFiles optss emptyShellState file + return (startEditEnv st,initSState) + + CCEnvEmpty -> do + return (startEditEnv emptyShellState, initSState) + + CCEnvGFShell command -> do + let hs = Shell.initHState env + let cs = PShell.pCommandLines hs command + (msg,(env',_)) <- Shell.execLines False cs hs + return (env', changeMsg msg s) ---- + + CCEnvOpenTerm file -> do + c <- readFileIf file + let (fs,t) = envAndTerm file c +---- (env',_) <- execCommand env (CCEnvGFShell fs) s --TODO; next deprec +---- env' <- useIOE env $ foldM (shellStateFromFiles noOptions) env fs + let env' = env ---- + return (env', execECommand env' (CNewTree t) s) + + CCEnvOpenString file -> do + c <- readFileIf file + let (fs,t) = envAndTerm file c +---- (env',_) <- execCommand env (CCEnvGFShell fs) s --TODO; next deprec +---- env' <- useIOE env $ foldM (shellStateFromFiles noOptions) env fs + let env' = env ---- + return (env', execECommand env' (CRefineParse t) s) + + CCEnvOn name -> return (languageOn (language name) env,s) + CCEnvOff name -> return (languageOff (language name) env,s) + + CCEnvSave lang file -> do + let str = optLinearizeTreeVal opts (stateGrammarOfLang env (language lang)) $ treeSState s + writeFile file str + let msg = ["wrote file" +++ file] + return (env,changeMsg msg 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 + optss = addOption beSilent opts + + -- format for documents: + -- GF commands of form "-- command", then term or text + envAndTerm f s = + (unwords (intersperse ";;" 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 + cat' <- string2cat sgr cat + 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 + CMovePosition p -> action2command $ goPosition p + 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 (f,i) -> action2commandKeep $ wrapWithFun cgr (qualif f, i) + CChangeHead f -> action2commandKeep $ changeFunHead cgr (qualif f) + CPeelHead (f,i) -> action2commandKeep $ peelFunHead cgr (qualif f,i) + + CAlphaConvert s -> action2commandKeep $ \x -> + string2varPair s >>= \xy -> alphaConvert cgr xy x + + CRefineWithTree s -> action2commandNext $ \x -> + (string2treeInState gr s x >>= + \t -> refineWithTree der cgr t x) + CRefineWithClip i -> \s -> + let et = getNumberedClip i s + in (case et of + Ok t -> refineByTrees der cgr [t] s + Bad m -> changeMsg [m] s) + CCopyPosition p q -> action2command $ \s -> do + s1 <- goPosition p s + let t = actTree s1 + s2 <- goPosition q s1 + let compat = actVal s1 == actVal s2 + if compat + then refineWithTree der cgr t s2 + else return s + + CRefineParse str -> \s -> + let cat = cat2CFCat (qualifTop sgr (actCat (stateSState s))) + ts = parseAny agrs cat str + in (if null ts ---- debug + then withMsg ["parse failed in cat" +++ prCFCat cat] + else id) + (refineByTrees der cgr ts) s + + CRefineRandom -> \s -> action2commandNext + (refineRandom (stdGenCEnv env s) 41 cgr) s + + CSelectCand i -> selectCand cgr i + + CTermCommand c -> case c of + "reindex" -> \s -> + replaceByTermCommand der gr c (actTree (stateSState s)) s + "paraphrase" -> \s -> + replaceByTermCommand der gr c (actTree (stateSState s)) s +---- "transfer" -> action2commandNext $ +---- transferSubTree (stateTransferFun sgr) gr + "generate" -> \s -> + replaceByTermCommand der gr c (actTree (stateSState s)) s + _ -> replaceByEditCommand gr c + + CAddOption o -> changeStOptions (addOption o) + CRemoveOption o -> changeStOptions (removeOption o) + CDelete -> action2commandKeep $ deleteSubTree cgr + CAddClip -> \s -> (addtoClip (actTree (stateSState s))) s + CRemoveClip n -> \s -> (removeClip n) s + CUndo n -> undoCommand n + 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 = 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 + abs = absId sgr + qualif = string2Fun gr + +-- + + +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'" + + +startEditEnv :: CEnv -> CEnv +startEditEnv env = addGlobalOptions (options [sizeDisplay "short"]) env + +-- | seen on display +cMenuDisplay :: String -> Command +cMenuDisplay s = CAddOption (menuDisplay s) + +newCatMenu :: CEnv -> [(Command, String)] +newCatMenu env = [(CNewCat (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 (prQIdent_ f, i), prWrap "w" "Wrap" fit) + | fit@((f,i),_) <- wraps] ++ + [(CChangeHead (prQIdent_ f), prChangeHead f) + | f <- headChangesState cgr state] ++ + [(CPeelHead (prQIdent_ f, i), prPeel "ph" "PeelHead" fi) + | fi@(f,i) <- peelingsState cgr state] ++ + [(CDelete, (ifShort "d" "Delete", "d"))] ++ + [(CAddClip, (ifShort "ac" "AddClip", "ac"))] + (refs,[],_) -> + [(CRefineWithAtom (prRefinement f), prRef t) | t@(f,_) <- refs] ++ + [(CRefineWithClip i, prClip i t) | (i,t) <- possClipsSState gr sstate] + (_,cands,_) -> + [(CSelectCand i, prCand (t,i)) | (t,i) <- zip cands [0..]] + + where + prRef (f,(t,_)) = + (ifShort "r" "Refine" +++ prOrLinRef f +++ ifTyped (":" +++ prt_ t), + "r" +++ prRefinement f) + prClip i t = + (ifShort "rc" "Paste" +++ prOrLinTree t, + "rc" +++ show i) + prChangeHead f = + (ifShort "ch" "ChangeHead" +++ prOrLinFun f, + "ch" +++ prQIdent_ f) + prWrap sh lg ((f,i),t) = + (ifShort sh lg +++ prOrLinFun f +++ ifTyped (":" +++ prt t) +++ + ifShort (show i) (prBracket (show i)), + sh +++ prQIdent_ f +++ show i) + prPeel sh lg (f,i) = + (ifShort sh lg +++ prOrLinFun f +++ + ifShort (show i) (prBracket (show i)), + sh +++ 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 = err (const $ prt_ t) prOrLinTree $ annotateInState cgr t state + prOrLinRef t = case t of + G.Q m f -> printname env sstate (m,f) + G.QC m f -> printname env sstate (m,f) + _ -> prt_ t + prOrLinFun = printname env sstate + prOrLinTree t = case getOptVal opts menuDisplay of + Just "Abs" -> prt_ $ tree2exp t ---- prTermOpt opts $ tree2exp t + Just lang -> prQuotedString $ lin lang t + _ -> prTermOpt opts $ tree2exp t + lin lang t = optLinearizeTreeVal opts (stateGrammarOfLang env (language lang)) t + +-- there are three orthogonal parameters: Abs/[conc], short/long, typed/untyped +-- the default is Abs, long, untyped; the Menus menu changes the parameter + +emptyMenuItem :: (Command, (String, String)) +emptyMenuItem = (CVoid,("","")) + + + +---- allStringCommands = snd $ customInfo customStringCommand +termCommandMenu :: [(Command,String)] +termCommandMenu = [(CTermCommand s, s) | s <- allTermCommands] + +allTermCommands :: [String] +allTermCommands = snd $ customInfo customEditCommand + +stringCommandMenu :: [(Command,String)] +stringCommandMenu = [] + +displayCommandMenu :: CEnv -> [(Command,String)] +displayCommandMenu env = + [(CAddOption (menuDisplay s), s) | s <- "Abs" : langs] ++ + [(CAddOption (sizeDisplay s), s) | s <- ["short", "long"]] ++ + [(fo nostripQualif, s) | (fo,s) <- [(CAddOption,"qualified"), + (CRemoveOption,"unqualified")]] ++ + [(CAddOption (typeDisplay s), s) | s <- ["typed", "untyped"]] + where + langs = map prLanguage $ allLanguages env + +{- ---- + +stringCommandMenu = + (CAddOption showStruct, "structured") : + (CRemoveOption showStruct, "unstructured") : + [(CAddOption (filterString s), s) | s <- allStringCommands] +-} + +changeMenuLanguage, changeMenuSize, changeMenuTyped :: String -> Command +changeMenuLanguage s = CAddOption (menuDisplay s) +changeMenuSize s = CAddOption (sizeDisplay s) +changeMenuTyped s = CAddOption (typeDisplay s) + +menuState :: CEnv -> SState -> [String] +menuState env = map snd . mkRefineMenu env + +prState :: State -> [String] +prState s = prMarkedTree (loc2treeMarked s) + +displayJustStateIn :: CEnv -> SState -> String +displayJustStateIn env state = case displaySStateIn env state of + (t,msg,_) -> unlines (t ++ ["",""] ++ msg) --- ad hoc for CommandF + +displaySStateIn :: CEnv -> SState -> ([String],[String],[(String,String)]) +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) -- state opts override + (addOption (markLin markOptFocus) (globalOptions env)) + 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 '*'] + +-- | the Boolean is a temporary hack to have two parallel GUIs +displaySStateJavaX :: Bool -> CEnv -> SState -> String -> String +displaySStateJavaX isNew env state m = encodeUTF8 $ mkUnicode $ + unlines $ tagXML "gfedit" $ concat [ + if null m then [] else tagXML "hmsg" [m], + 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" [unicode s] ++ tagXML "send" [c] | (s,c) <- menu] + (ls,grs) = unzip $ lgrs + lgrs = allActiveStateGrammarsWithNames env + lins = (langAbstract, exp) : linAll + opts = addOptions (optsSState state) -- state opts override + (addOption (markLin mark) (globalOptions env)) + lin (n,gr) = (n, map uni $ linearizeState noWrap opts gr zipper) where + uni = optDecodeUTF8 gr + exp = prprTree $ loc2tree zipper + zipper = stateSState state + linAll = map lin lgrs + gr = firstStateGrammar env + mark = markOptXML -- markOptJava + + unicode = case getOptVal opts menuDisplay of + Just lang -> optDecodeUTF8 (stateGrammarOfLang env (language lang)) + _ -> id + +-- | the env is UTF8 if the display language is +-- +-- should be independent +isCEnvUTF8 :: CEnv -> SState -> Bool +isCEnvUTF8 env st = maybe False id $ do + lang <- getOptVal opts menuDisplay + co <- getOptVal (stateOptions (stateGrammarOfLang env (language lang))) uniCoding + return $ co == "utf8" + where + opts = addOptions (optsSState st) (globalOptions env) + +langAbstract, langXML :: I.Ident +langAbstract = language "Abstract" +langXML = language "XML" + +linearizeState :: (String -> [String]) -> Options -> GFGrammar -> State -> [String] +linearizeState wrap opts gr = + wrap . strop . unt . optLinearizeTreeVal opts gr . loc2treeFocus + + where + unt = customOrDefault (stateOptions gr) useUntokenizer customUntokenizer gr + strop = maybe id ($ gr) $ 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 = if null cs then [("[NO ALTERNATIVE]","")] else cs + where + cs = [(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 ---- prTermOpt opts (qq f) + where + opts = addOptions (optsSState state) (globalOptions env) + printn lang f = err id (ifNull (prQIdent_ f) (sstr . head)) $ do + t <- lookupPrintname gr mf + strsFromTerm t + where + sgr = stateGrammarOfLang env (language lang) + gr = grammar sgr + mf = ciq (cncId sgr) (snd f) + +-- * XML printing; does not belong here! + +tagsXML :: String -> [[String]] -> [String] +tagsXML t = concatMap (tagXML t) + +tagAttrXML :: String -> (String, String) -> [String] -> [String] +tagAttrXML t av ss = mkTagAttrXML t av : map (indent 2) ss ++ [mkEndTagXML t] + +tagXML :: String -> [String] -> [String] +tagXML t ss = mkTagXML t : map (indent 2) ss ++ [mkEndTagXML t] + +mkTagXML :: String -> String +mkTagXML t = '<':t ++ ">" + +mkEndTagXML :: String -> String +mkEndTagXML t = mkTagXML ('/':t) + +mkTagAttrsXML :: String -> [(String, String)] -> String +mkTagAttrsXML t avs = '<':t +++ unwords [a++"="++v | (a,v) <- avs] ++">" + +mkTagAttrXML :: String -> (String, String) -> String +mkTagAttrXML t av = mkTagAttrsXML t [av] + diff --git a/src-3.0/GF/Shell/HelpFile.hs b/src-3.0/GF/Shell/HelpFile.hs new file mode 100644 index 000000000..43fae7c42 --- /dev/null +++ b/src-3.0/GF/Shell/HelpFile.hs @@ -0,0 +1,723 @@ +---------------------------------------------------------------------- +-- | +-- Module : GF.Shell.HelpFile +-- Maintainer : Aarne Ranta +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/05/12 10:03:34 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.9 $ +-- +-- Help on shell commands. Generated from HelpFile by 'make help'. +-- PLEASE DON'T EDIT THIS FILE. +----------------------------------------------------------------------------- + + +module GF.Shell.HelpFile where + +import GF.Data.Operations + +txtHelpFileSummary = + unlines $ map (concat . take 1 . lines) $ paragraphs txtHelpFile + +txtHelpCommand c = + case lookup c [(takeWhile (/=',') p,p) | p <- paragraphs txtHelpFile] of + Just s -> s + _ -> "Command not found." + +txtHelpFile = + "\n-- GF help file updated for GF 2.6, 17/6/2006." ++ + "\n-- *: Commands and options marked with * are currently not implemented." ++ + "\n--" ++ + "\n-- Each command has a long and a short name, options, and zero or more" ++ + "\n-- arguments. Commands are sorted by functionality. The short name is" ++ + "\n-- given first." ++ + "\n" ++ + "\n-- Type \"h -all\" for full help file, \"h <CommandName>\" for full help on a command. " ++ + "\n" ++ + "\n-- commands that change the state" ++ + "\n" ++ + "\ni, import: i File" ++ + "\n Reads a grammar from File and compiles it into a GF runtime grammar." ++ + "\n Files \"include\"d in File are read recursively, nubbing repetitions." ++ + "\n If a grammar with the same language name is already in the state," ++ + "\n it is overwritten - but only if compilation succeeds. " ++ + "\n The grammar parser depends on the file name suffix:" ++ + "\n .gf normal GF source" ++ + "\n .gfc canonical GF" ++ + "\n .gfr precompiled GF resource " ++ + "\n .gfcm multilingual canonical GF" ++ + "\n .gfe example-based grammar files (only with the -ex option)" ++ + "\n .gfwl multilingual word list (preprocessed to abs + cncs)" ++ + "\n .ebnf Extended BNF format" ++ + "\n .cf Context-free (BNF) format" ++ + "\n .trc TransferCore format" ++ + "\n options:" ++ + "\n -old old: parse in GF<2.0 format (not necessary)" ++ + "\n -v verbose: give lots of messages " ++ + "\n -s silent: don't give error messages" ++ + "\n -src from source: ignore precompiled gfc and gfr files" ++ + "\n -gfc from gfc: use compiled modules whenever they exist" ++ + "\n -retain retain operations: read resource modules (needed in comm cc) " ++ + "\n -nocf don't build old-style context-free grammar (default without HOAS)" ++ + "\n -docf do build old-style context-free grammar (default with HOAS)" ++ + "\n -nocheckcirc don't eliminate circular rules from CF " ++ + "\n -cflexer build an optimized parser with separate lexer trie" ++ + "\n -noemit do not emit code (default with old grammar format)" ++ + "\n -o do emit code (default with new grammar format)" ++ + "\n -ex preprocess .gfe files if needed" ++ + "\n -prob read probabilities from top grammar file (format --# prob Fun Double)" ++ + "\n -treebank read a treebank file to memory (xml format)" ++ + "\n flags:" ++ + "\n -abs set the name used for abstract syntax (with -old option)" ++ + "\n -cnc set the name used for concrete syntax (with -old option)" ++ + "\n -res set the name used for resource (with -old option)" ++ + "\n -path use the (colon-separated) search path to find modules" ++ + "\n -optimize select an optimization to override file-defined flags" ++ + "\n -conversion select parsing method (values strict|nondet)" ++ + "\n -probs read probabilities from file (format (--# prob) Fun Double)" ++ + "\n -preproc use a preprocessor on each source file" ++ + "\n -noparse read nonparsable functions from file (format --# noparse Funs) " ++ + "\n examples:" ++ + "\n i English.gf -- ordinary import of Concrete" ++ + "\n i -retain german/ParadigmsGer.gf -- import of Resource to test" ++ + "\n" ++ + "\nr, reload: r" ++ + "\n Executes the previous import (i) command." ++ + "\n " ++ + "\nrl, remove_language: rl Language" ++ + "\n Takes away the language from the state." ++ + "\n" ++ + "\ne, empty: e" ++ + "\n Takes away all languages and resets all global flags." ++ + "\n" ++ + "\nsf, set_flags: sf Flag*" ++ + "\n The values of the Flags are set for Language. If no language" ++ + "\n is specified, the flags are set globally." ++ + "\n examples:" ++ + "\n sf -nocpu -- stop showing CPU time" ++ + "\n sf -lang=Swe -- make Swe the default concrete" ++ + "\n" ++ + "\ns, strip: s" ++ + "\n Prune the state by removing source and resource modules." ++ + "\n" ++ + "\ndc, define_command Name Anything" ++ + "\n Add a new defined command. The Name must star with '%'. Later," ++ + "\n if 'Name X' is used, it is replaced by Anything where #1 is replaced" ++ + "\n by X. " ++ + "\n Restrictions: Currently at most one argument is possible, and a defined" ++ + "\n command cannot appear in a pipe. " ++ + "\n To see what definitions are in scope, use help -defs." ++ + "\n examples:" ++ + "\n dc %tnp p -cat=NP -lang=Eng #1 | l -lang=Swe -- translate NPs" ++ + "\n %tnp \"this man\" -- translate and parse" ++ + "\n" ++ + "\ndt, define_term Name Tree" ++ + "\n Add a constant for a tree. The constant can later be called by" ++ + "\n prefixing it with '$'. " ++ + "\n Restriction: These terms are not yet usable as a subterm. " ++ + "\n To see what definitions are in scope, use help -defs." ++ + "\n examples:" ++ + "\n p -cat=NP \"this man\" | dt tm -- define tm as parse result" ++ + "\n l -all $tm -- linearize tm in all forms" ++ + "\n" ++ + "\n-- commands that give information about the state" ++ + "\n" ++ + "\npg, print_grammar: pg" ++ + "\n Prints the actual grammar (overridden by the -lang=X flag)." ++ + "\n The -printer=X flag sets the format in which the grammar is" ++ + "\n written." ++ + "\n N.B. since grammars are compiled when imported, this command" ++ + "\n generally does not show the grammar in the same format as the" ++ + "\n source. In particular, the -printer=latex is not supported. " ++ + "\n Use the command tg -printer=latex File to print the source " ++ + "\n grammar in LaTeX." ++ + "\n options:" ++ + "\n -utf8 apply UTF8-encoding to the grammar" ++ + "\n flags: " ++ + "\n -printer" ++ + "\n -lang" ++ + "\n -startcat -- The start category of the generated grammar." ++ + "\n Only supported by some grammar printers." ++ + "\n examples:" ++ + "\n pg -printer=cf -- show the context-free skeleton" ++ + "\n" ++ + "\npm, print_multigrammar: pm" ++ + "\n Prints the current multilingual grammar in .gfcm form." ++ + "\n (Automatically executes the strip command (s) before doing this.)" ++ + "\n options:" ++ + "\n -utf8 apply UTF8 encoding to the tokens in the grammar" ++ + "\n -utf8id apply UTF8 encoding to the identifiers in the grammar" ++ + "\n examples:" ++ + "\n pm | wf Letter.gfcm -- print the grammar into the file Letter.gfcm" ++ + "\n pm -printer=graph | wf D.dot -- then do 'dot -Tps D.dot > D.ps'" ++ + "\n" ++ + "\nvg, visualize_graph: vg" ++ + "\n Show the dependency graph of multilingual grammar via dot and gv." ++ + "\n" ++ + "\npo, print_options: po" ++ + "\n Print what modules there are in the state. Also" ++ + "\n prints those flag values in the current state that differ from defaults." ++ + "\n" ++ + "\npl, print_languages: pl" ++ + "\n Prints the names of currently available languages." ++ + "\n" ++ + "\npi, print_info: pi Ident" ++ + "\n Prints information on the identifier." ++ + "\n" ++ + "\n-- commands that execute and show the session history" ++ + "\n" ++ + "\neh, execute_history: eh File" ++ + "\n Executes commands in the file." ++ + "\n" ++ + "\nph, print_history; ph" ++ + "\n Prints the commands issued during the GF session." ++ + "\n The result is readable by the eh command." ++ + "\n examples:" ++ + "\n ph | wf foo.hist\" -- save the history into a file" ++ + "\n" ++ + "\n-- linearization, parsing, translation, and computation" ++ + "\n" ++ + "\nl, linearize: l PattList? Tree" ++ + "\n Shows all linearization forms of Tree by the actual grammar" ++ + "\n (which is overridden by the -lang flag). " ++ + "\n The pattern list has the form [P, ... ,Q] where P,...,Q follow GF " ++ + "\n syntax for patterns. All those forms are generated that match with the" ++ + "\n pattern list. Too short lists are filled with variables in the end." ++ + "\n Only the -table flag is available if a pattern list is specified." ++ + "\n HINT: see GF language specification for the syntax of Pattern and Term." ++ + "\n You can also copy and past parsing results." ++ + "\n options: " ++ + "\n -struct bracketed form" ++ + "\n -table show parameters (not compatible with -record, -all)" ++ + "\n -record record, i.e. explicit GF concrete syntax term (not compatible with -table, -all)" ++ + "\n -all show all forms and variants (not compatible with -record, -table)" ++ + "\n -multi linearize to all languages (can be combined with the other options)" ++ + "\n flags:" ++ + "\n -lang linearize in this grammar" ++ + "\n -number give this number of forms at most" ++ + "\n -unlexer filter output through unlexer" ++ + "\n examples:" ++ + "\n l -lang=Swe -table -- show full inflection table in Swe" ++ + "\n" ++ + "\np, parse: p String" ++ + "\n Shows all Trees returned for String by the actual" ++ + "\n grammar (overridden by the -lang flag), in the category S (overridden" ++ + "\n by the -cat flag)." ++ + "\n options for batch input:" ++ + "\n -lines parse each line of input separately, ignoring empty lines" ++ + "\n -all as -lines, but also parse empty lines" ++ + "\n -prob rank results by probability" ++ + "\n -cut stop after first lexing result leading to parser success" ++ + "\n -fail show strings whose parse fails prefixed by #FAIL" ++ + "\n -ambiguous show strings that have more than one parse prefixed by #AMBIGUOUS" ++ + "\n options for selecting parsing method:" ++ + "\n -fcfg parse using a fast variant of MCFG (default is no HOAS in grammar)" ++ + "\n -old parse using an overgenerating CFG (default if HOAS in grammar)" ++ + "\n -cfg parse using a much less overgenerating CFG" ++ + "\n -mcfg parse using an even less overgenerating MCFG" ++ + "\n Note: the first time parsing with -cfg, -mcfg, and -fcfg may take a long time" ++ + "\n options that only work for the -old default parsing method:" ++ + "\n -n non-strict: tolerates morphological errors" ++ + "\n -ign ignore unknown words when parsing" ++ + "\n -raw return context-free terms in raw form" ++ + "\n -v verbose: give more information if parsing fails" ++ + "\n flags:" ++ + "\n -cat parse in this category" ++ + "\n -lang parse in this grammar" ++ + "\n -lexer filter input through this lexer" ++ + "\n -parser use this parsing strategy" ++ + "\n -number return this many results at most" ++ + "\n examples:" ++ + "\n p -cat=S -mcfg \"jag \228r gammal\" -- parse an S with the MCFG" ++ + "\n rf examples.txt | p -lines -- parse each non-empty line of the file" ++ + "\n" ++ + "\nat, apply_transfer: at (Module.Fun | Fun)" ++ + "\n Transfer a term using Fun from Module, or the topmost transfer" ++ + "\n module. Transfer modules are given in the .trc format. They are" ++ + "\n shown by the 'po' command." ++ + "\n flags:" ++ + "\n -lang typecheck the result in this lang instead of default lang" ++ + "\n examples:" ++ + "\n p -lang=Cncdecimal \"123\" | at num2bin | l -- convert dec to bin" ++ + "\n" ++ + "\ntb, tree_bank: tb" ++ + "\n Generate a multilingual treebank from a list of trees (default) or compare" ++ + "\n to an existing treebank." ++ + "\n options:" ++ + "\n -c compare to existing xml-formatted treebank" ++ + "\n -trees return the trees of the treebank" ++ + "\n -all show all linearization alternatives (branches and variants)" ++ + "\n -table show tables of linearizations with parameters" ++ + "\n -record show linearization records" ++ + "\n -xml wrap the treebank (or comparison results) with XML tags" ++ + "\n -mem write the treebank in memory instead of a file TODO" ++ + "\n examples:" ++ + "\n gr -cat=S -number=100 | tb -xml | wf tb.xml -- random treebank into file" ++ + "\n rf tb.xml | tb -c -- compare-test treebank from file" ++ + "\n rf old.xml | tb -trees | tb -xml -- create new treebank from old" ++ + "\n" ++ + "\nut, use_treebank: ut String" ++ + "\n Lookup a string in a treebank and return the resulting trees." ++ + "\n Use 'tb' to create a treebank and 'i -treebank' to read one from" ++ + "\n a file." ++ + "\n options:" ++ + "\n -assocs show all string-trees associations in the treebank" ++ + "\n -strings show all strings in the treebank" ++ + "\n -trees show all trees in the treebank" ++ + "\n -raw return the lookup result as string, without typechecking it" ++ + "\n flags:" ++ + "\n -treebank use this treebank (instead of the latest introduced one)" ++ + "\n examples:" ++ + "\n ut \"He adds this to that\" | l -multi -- use treebank lookup as parser in translation" ++ + "\n ut -assocs | grep \"ComplV2\" -- show all associations with ComplV2" ++ + "\n" ++ + "\ntt, test_tokenizer: tt String" ++ + "\n Show the token list sent to the parser when String is parsed." ++ + "\n HINT: can be useful when debugging the parser." ++ + "\n flags: " ++ + "\n -lexer use this lexer" ++ + "\n examples:" ++ + "\n tt -lexer=codelit \"2*(x + 3)\" -- a favourite lexer for program code" ++ + "\n" ++ + "\ng, grep: g String1 String2" ++ + "\n Grep the String1 in the String2. String2 is read line by line," ++ + "\n and only those lines that contain String1 are returned." ++ + "\n flags:" ++ + "\n -v return those lines that do not contain String1." ++ + "\n examples:" ++ + "\n pg -printer=cf | grep \"mother\" -- show cf rules with word mother" ++ + "\n" ++ + "\ncc, compute_concrete: cc Term" ++ + "\n Compute a term by concrete syntax definitions. Uses the topmost" ++ + "\n resource module (the last in listing by command po) to resolve " ++ + "\n constant names. " ++ + "\n N.B. You need the flag -retain when importing the grammar, if you want " ++ + "\n the oper definitions to be retained after compilation; otherwise this" ++ + "\n command does not expand oper constants." ++ + "\n N.B.' The resulting Term is not a term in the sense of abstract syntax," ++ + "\n and hence not a valid input to a Tree-demanding command." ++ + "\n flags:" ++ + "\n -table show output in a similar readable format as 'l -table'" ++ + "\n -res use another module than the topmost one" ++ + "\n examples:" ++ + "\n cc -res=ParadigmsFin (nLukko \"hyppy\") -- inflect \"hyppy\" with nLukko" ++ + "\n" ++ + "\nso, show_operations: so Type" ++ + "\n Show oper operations with the given value type. Uses the topmost " ++ + "\n resource module to resolve constant names. " ++ + "\n N.B. You need the flag -retain when importing the grammar, if you want " ++ + "\n the oper definitions to be retained after compilation; otherwise this" ++ + "\n command does not find any oper constants." ++ + "\n N.B.' The value type may not be defined in a supermodule of the" ++ + "\n topmost resource. In that case, use appropriate qualified name." ++ + "\n flags:" ++ + "\n -res use another module than the topmost one" ++ + "\n examples:" ++ + "\n so -res=ParadigmsFin ResourceFin.N -- show N-paradigms in ParadigmsFin" ++ + "\n" ++ + "\nt, translate: t Lang Lang String" ++ + "\n Parses String in Lang1 and linearizes the resulting Trees in Lang2." ++ + "\n flags:" ++ + "\n -cat" ++ + "\n -lexer" ++ + "\n -parser" ++ + "\n examples:" ++ + "\n t Eng Swe -cat=S \"every number is even or odd\"" ++ + "\n" ++ + "\ngr, generate_random: gr Tree?" ++ + "\n Generates a random Tree of a given category. If a Tree" ++ + "\n argument is given, the command completes the Tree with values to" ++ + "\n the metavariables in the tree. " ++ + "\n options:" ++ + "\n -prob use probabilities (works for nondep types only)" ++ + "\n -cf use a very fast method (works for nondep types only)" ++ + "\n flags:" ++ + "\n -cat generate in this category" ++ + "\n -lang use the abstract syntax of this grammar" ++ + "\n -number generate this number of trees (not impl. with Tree argument)" ++ + "\n -depth use this number of search steps at most" ++ + "\n examples:" ++ + "\n gr -cat=Query -- generate in category Query" ++ + "\n gr (PredVP ? (NegVG ?)) -- generate a random tree of this form" ++ + "\n gr -cat=S -tr | l -- gererate and linearize" ++ + "\n" ++ + "\ngt, generate_trees: gt Tree?" ++ + "\n Generates all trees up to a given depth. If the depth is large," ++ + "\n a small -alts is recommended. If a Tree argument is given, the" ++ + "\n command completes the Tree with values to the metavariables in" ++ + "\n the tree." ++ + "\n options:" ++ + "\n -metas also return trees that include metavariables" ++ + "\n -all generate all (can be infinitely many, lazily)" ++ + "\n -lin linearize result of -all (otherwise, use pipe to linearize)" ++ + "\n flags:" ++ + "\n -depth generate to this depth (default 3)" ++ + "\n -atoms take this number of atomic rules of each category (default unlimited)" ++ + "\n -alts take this number of alternatives at each branch (default unlimited)" ++ + "\n -cat generate in this category" ++ + "\n -nonub don't remove duplicates (faster, not effective with -mem)" ++ + "\n -mem use a memorizing algorithm (often faster, usually more memory-consuming)" ++ + "\n -lang use the abstract syntax of this grammar" ++ + "\n -number generate (at most) this number of trees (also works with -all)" ++ + "\n -noexpand don't expand these categories (comma-separated, e.g. -noexpand=V,CN)" ++ + "\n -doexpand only expand these categories (comma-separated, e.g. -doexpand=V,CN)" ++ + "\n examples:" ++ + "\n gt -depth=10 -cat=NP -- generate all NP's to depth 10 " ++ + "\n gt (PredVP ? (NegVG ?)) -- generate all trees of this form" ++ + "\n gt -cat=S -tr | l -- generate and linearize" ++ + "\n gt -noexpand=NP | l -mark=metacat -- the only NP is meta, linearized \"?0 +NP\"" ++ + "\n gt | l | p -lines -ambiguous | grep \"#AMBIGUOUS\" -- show ambiguous strings" ++ + "\n" ++ + "\nma, morphologically_analyse: ma String" ++ + "\n Runs morphological analysis on each word in String and displays" ++ + "\n the results line by line." ++ + "\n options:" ++ + "\n -short show analyses in bracketed words, instead of separate lines" ++ + "\n -status show just the work at success, prefixed with \"*\" at failure" ++ + "\n flags:" ++ + "\n -lang" ++ + "\n examples:" ++ + "\n wf Bible.txt | ma -short | wf Bible.tagged -- analyse the Bible" ++ + "\n" ++ + "\n" ++ + "\n-- elementary generation of Strings and Trees" ++ + "\n" ++ + "\nps, put_string: ps String" ++ + "\n Returns its argument String, like Unix echo." ++ + "\n HINT. The strength of ps comes from the possibility to receive the " ++ + "\n argument from a pipeline, and altering it by the -filter flag." ++ + "\n flags:" ++ + "\n -filter filter the result through this string processor " ++ + "\n -length cut the string after this number of characters" ++ + "\n examples:" ++ + "\n gr -cat=Letter | l | ps -filter=text -- random letter as text" ++ + "\n" ++ + "\npt, put_tree: pt Tree" ++ + "\n Returns its argument Tree, like a specialized Unix echo." ++ + "\n HINT. The strength of pt comes from the possibility to receive " ++ + "\n the argument from a pipeline, and altering it by the -transform flag." ++ + "\n flags:" ++ + "\n -transform transform the result by this term processor" ++ + "\n -number generate this number of terms at most" ++ + "\n examples:" ++ + "\n p \"zero is even\" | pt -transform=solve -- solve ?'s in parse result" ++ + "\n" ++ + "\n* st, show_tree: st Tree" ++ + "\n Prints the tree as a string. Unlike pt, this command cannot be" ++ + "\n used in a pipe to produce a tree, since its output is a string." ++ + "\n flags:" ++ + "\n -printer show the tree in a special format (-printer=xml supported)" ++ + "\n" ++ + "\nwt, wrap_tree: wt Fun" ++ + "\n Wraps the tree as the sole argument of Fun." ++ + "\n flags:" ++ + "\n -c compute the resulting new tree to normal form" ++ + "\n" ++ + "\nvt, visualize_tree: vt Tree" ++ + "\n Shows the abstract syntax tree via dot and gv (via temporary files" ++ + "\n grphtmp.dot, grphtmp.ps)." ++ + "\n flags:" ++ + "\n -c show categories only (no functions)" ++ + "\n -f show functions only (no categories)" ++ + "\n -g show as graph (sharing uses of the same function)" ++ + "\n -o just generate the .dot file" ++ + "\n examples:" ++ + "\n p \"hello world\" | vt -o | wf my.dot ;; ! open -a GraphViz my.dot" ++ + "\n -- This writes the parse tree into my.dot and opens the .dot file" ++ + "\n -- with another application without generating .ps." ++ + "\n" ++ + "\n-- subshells" ++ + "\n" ++ + "\nes, editing_session: es" ++ + "\n Opens an interactive editing session." ++ + "\n N.B. Exit from a Fudget session is to the Unix shell, not to GF. " ++ + "\n options:" ++ + "\n -f Fudget GUI (necessary for Unicode; only available in X Window System)" ++ + "\n" ++ + "\nts, translation_session: ts" ++ + "\n Translates input lines from any of the actual languages to all other ones." ++ + "\n To exit, type a full stop (.) alone on a line." ++ + "\n N.B. Exit from a Fudget session is to the Unix shell, not to GF. " ++ + "\n HINT: Set -parser and -lexer locally in each grammar." ++ + "\n options:" ++ + "\n -f Fudget GUI (necessary for Unicode; only available in X Windows)" ++ + "\n -lang prepend translation results with language names" ++ + "\n flags:" ++ + "\n -cat the parser category" ++ + "\n examples:" ++ + "\n ts -cat=Numeral -lang -- translate numerals, show language names" ++ + "\n" ++ + "\ntq, translation_quiz: tq Lang Lang" ++ + "\n Random-generates translation exercises from Lang1 to Lang2," ++ + "\n keeping score of success." ++ + "\n To interrupt, type a full stop (.) alone on a line." ++ + "\n HINT: Set -parser and -lexer locally in each grammar." ++ + "\n flags:" ++ + "\n -cat" ++ + "\n examples:" ++ + "\n tq -cat=NP TestResourceEng TestResourceSwe -- quiz for NPs" ++ + "\n" ++ + "\ntl, translation_list: tl Lang Lang" ++ + "\n Random-generates a list of ten translation exercises from Lang1" ++ + "\n to Lang2. The number can be changed by a flag." ++ + "\n HINT: use wf to save the exercises in a file." ++ + "\n flags:" ++ + "\n -cat" ++ + "\n -number" ++ + "\n examples:" ++ + "\n tl -cat=NP TestResourceEng TestResourceSwe -- quiz list for NPs" ++ + "\n" ++ + "\nmq, morphology_quiz: mq" ++ + "\n Random-generates morphological exercises," ++ + "\n keeping score of success." ++ + "\n To interrupt, type a full stop (.) alone on a line." ++ + "\n HINT: use printname judgements in your grammar to" ++ + "\n produce nice expressions for desired forms." ++ + "\n flags:" ++ + "\n -cat" ++ + "\n -lang" ++ + "\n examples:" ++ + "\n mq -cat=N -lang=TestResourceSwe -- quiz for Swedish nouns" ++ + "\n" ++ + "\nml, morphology_list: ml" ++ + "\n Random-generates a list of ten morphological exercises," ++ + "\n keeping score of success. The number can be changed with a flag." ++ + "\n HINT: use wf to save the exercises in a file." ++ + "\n flags:" ++ + "\n -cat" ++ + "\n -lang" ++ + "\n -number" ++ + "\n examples:" ++ + "\n ml -cat=N -lang=TestResourceSwe -- quiz list for Swedish nouns" ++ + "\n" ++ + "\n" ++ + "\n-- IO related commands" ++ + "\n" ++ + "\nrf, read_file: rf File" ++ + "\n Returns the contents of File as a String; error if File does not exist." ++ + "\n" ++ + "\nwf, write_file: wf File String" ++ + "\n Writes String into File; File is created if it does not exist." ++ + "\n N.B. the command overwrites File without a warning." ++ + "\n" ++ + "\naf, append_file: af File" ++ + "\n Writes String into the end of File; File is created if it does not exist." ++ + "\n" ++ + "\n* tg, transform_grammar: tg File" ++ + "\n Reads File, parses as a grammar, " ++ + "\n but instead of compiling further, prints it. " ++ + "\n The environment is not changed. When parsing the grammar, the same file" ++ + "\n name suffixes are supported as in the i command." ++ + "\n HINT: use this command to print the grammar in " ++ + "\n another format (the -printer flag); pipe it to wf to save this format." ++ + "\n flags:" ++ + "\n -printer (only -printer=latex supported currently)" ++ + "\n" ++ + "\n* cl, convert_latex: cl File" ++ + "\n Reads File, which is expected to be in LaTeX form." ++ + "\n Three environments are treated in special ways:" ++ + "\n \\begGF - \\end{verbatim}, which contains GF judgements," ++ + "\n \\begTGF - \\end{verbatim}, which contains a GF expression (displayed)" ++ + "\n \\begInTGF - \\end{verbatim}, which contains a GF expressions (inlined)." ++ + "\n Moreover, certain macros should be included in the file; you can" ++ + "\n get those macros by applying 'tg -printer=latex foo.gf' to any grammar" ++ + "\n foo.gf. Notice that the same File can be imported as a GF grammar," ++ + "\n consisting of all the judgements in \\begGF environments." ++ + "\n HINT: pipe with 'wf Foo.tex' to generate a new Latex file." ++ + "\n" ++ + "\nsa, speak_aloud: sa String" ++ + "\n Uses the Flite speech generator to produce speech for String." ++ + "\n Works for American English spelling. " ++ + "\n examples:" ++ + "\n h | sa -- listen to the list of commands" ++ + "\n gr -cat=S | l | sa -- generate a random sentence and speak it aloud" ++ + "\n" ++ + "\nsi, speech_input: si" ++ + "\n Uses an ATK speech recognizer to get speech input. " ++ + "\n flags:" ++ + "\n -lang: The grammar to use with the speech recognizer." ++ + "\n -cat: The grammar category to get input in." ++ + "\n -language: Use acoustic model and dictionary for this language." ++ + "\n -number: The number of utterances to recognize." ++ + "\n" ++ + "\nh, help: h Command?" ++ + "\n Displays the paragraph concerning the command from this help file." ++ + "\n Without the argument, shows the first lines of all paragraphs." ++ + "\n options" ++ + "\n -all show the whole help file" ++ + "\n -defs show user-defined commands and terms" ++ + "\n -FLAG show the values of FLAG (works for grammar-independent flags)" ++ + "\n examples:" ++ + "\n h print_grammar -- show all information on the pg command" ++ + "\n" ++ + "\nq, quit: q" ++ + "\n Exits GF." ++ + "\n HINT: you can use 'ph | wf history' to save your session." ++ + "\n" ++ + "\n!, system_command: ! String" ++ + "\n Issues a system command. No value is returned to GF." ++ + "\n example:" ++ + "\n ! ls" ++ + "\n" ++ + "\n?, system_command: ? String" ++ + "\n Issues a system command that receives its arguments from GF pipe" ++ + "\n and returns a value to GF." ++ + "\n example:" ++ + "\n h | ? 'wc -l' | p -cat=Num" ++ + "\n" ++ + "\n" ++ + "\n-- Flags. The availability of flags is defined separately for each command." ++ + "\n" ++ + "\n-cat, category in which parsing is performed." ++ + "\n The default is S." ++ + "\n" ++ + "\n-depth, the search depth in e.g. random generation." ++ + "\n The default depends on application." ++ + "\n" ++ + "\n-filter, operation performed on a string. The default is identity." ++ + "\n -filter=identity no change" ++ + "\n -filter=erase erase the text" ++ + "\n -filter=take100 show the first 100 characters" ++ + "\n -filter=length show the length of the string" ++ + "\n -filter=text format as text (punctuation, capitalization)" ++ + "\n -filter=code format as code (spacing, indentation)" ++ + "\n" ++ + "\n-lang, grammar used when executing a grammar-dependent command." ++ + "\n The default is the last-imported grammar." ++ + "\n" ++ + "\n-language, voice used by Festival as its --language flag in the sa command. " ++ + "\n The default is system-dependent. " ++ + "\n" ++ + "\n-length, the maximum number of characters shown of a string. " ++ + "\n The default is unlimited." ++ + "\n" ++ + "\n-lexer, tokenization transforming a string into lexical units for a parser." ++ + "\n The default is words." ++ + "\n -lexer=words tokens are separated by spaces or newlines" ++ + "\n -lexer=literals like words, but GF integer and string literals recognized" ++ + "\n -lexer=vars like words, but \"x\",\"x_...\",\"$...$\" as vars, \"?...\" as meta" ++ + "\n -lexer=chars each character is a token" ++ + "\n -lexer=code use Haskell's lex" ++ + "\n -lexer=codevars like code, but treat unknown words as variables, ?? as meta " ++ + "\n -lexer=textvars like text, but treat unknown words as variables, ?? as meta " ++ + "\n -lexer=text with conventions on punctuation and capital letters" ++ + "\n -lexer=codelit like code, but treat unknown words as string literals" ++ + "\n -lexer=textlit like text, but treat unknown words as string literals" ++ + "\n -lexer=codeC use a C-like lexer" ++ + "\n -lexer=ignore like literals, but ignore unknown words" ++ + "\n -lexer=subseqs like ignore, but then try all subsequences from longest" ++ + "\n" ++ + "\n-number, the maximum number of generated items in a list. " ++ + "\n The default is unlimited." ++ + "\n" ++ + "\n-optimize, optimization on generated code." ++ + "\n The default is share for concrete, none for resource modules." ++ + "\n Each of the flags can have the suffix _subs, which performs" ++ + "\n common subexpression elimination after the main optimization." ++ + "\n Thus, -optimize=all_subs is the most aggressive one. The _subs" ++ + "\n strategy only works in GFC, and applies therefore in concrete but" ++ + "\n not in resource modules." ++ + "\n -optimize=share share common branches in tables" ++ + "\n -optimize=parametrize first try parametrize then do share with the rest" ++ + "\n -optimize=values represent tables as courses-of-values" ++ + "\n -optimize=all first try parametrize then do values with the rest" ++ + "\n -optimize=none no optimization" ++ + "\n" ++ + "\n-parser, parsing strategy. The default is chart. If -cfg or -mcfg are" ++ + "\n selected, only bottomup and topdown are recognized." ++ + "\n -parser=chart bottom-up chart parsing" ++ + "\n -parser=bottomup a more up to date bottom-up strategy" ++ + "\n -parser=topdown top-down strategy" ++ + "\n -parser=old an old bottom-up chart parser" ++ + "\n" ++ + "\n-printer, format in which the grammar is printed. The default is" ++ + "\n gfc. Those marked with M are (only) available for pm, the rest" ++ + "\n for pg." ++ + "\n -printer=gfc GFC grammar" ++ + "\n -printer=gf GF grammar" ++ + "\n -printer=old old GF grammar" ++ + "\n -printer=cf context-free grammar, with profiles" ++ + "\n -printer=bnf context-free grammar, without profiles" ++ + "\n -printer=lbnf labelled context-free grammar for BNF Converter" ++ + "\n -printer=plbnf grammar for BNF Converter, with precedence levels" ++ + "\n *-printer=happy source file for Happy parser generator (use lbnf!)" ++ + "\n -printer=haskell abstract syntax in Haskell, with transl to/from GF" ++ + "\n -printer=haskell_gadt abstract syntax GADT in Haskell, with transl to/from GF" ++ + "\n -printer=morpho full-form lexicon, long format" ++ + "\n *-printer=latex LaTeX file (for the tg command)" ++ + "\n -printer=fullform full-form lexicon, short format" ++ + "\n *-printer=xml XML: DTD for the pg command, object for st" ++ + "\n -printer=old old GF: file readable by GF 1.2" ++ + "\n -printer=stat show some statistics of generated GFC" ++ + "\n -printer=probs show probabilities of all functions" ++ + "\n -printer=gsl Nuance GSL speech recognition grammar" ++ + "\n -printer=jsgf Java Speech Grammar Format" ++ + "\n -printer=jsgf_sisr_old Java Speech Grammar Format with semantic tags in " ++ + "\n SISR WD 20030401 format" ++ + "\n -printer=srgs_abnf SRGS ABNF format" ++ + "\n -printer=srgs_abnf_non_rec SRGS ABNF format, without any recursion." ++ + "\n -printer=srgs_abnf_sisr_old SRGS ABNF format, with semantic tags in" ++ + "\n SISR WD 20030401 format" ++ + "\n -printer=srgs_xml SRGS XML format" ++ + "\n -printer=srgs_xml_non_rec SRGS XML format, without any recursion." ++ + "\n -printer=srgs_xml_prob SRGS XML format, with weights" ++ + "\n -printer=srgs_xml_sisr_old SRGS XML format, with semantic tags in" ++ + "\n SISR WD 20030401 format" ++ + "\n -printer=vxml Generate a dialogue system in VoiceXML." ++ + "\n -printer=slf a finite automaton in the HTK SLF format" ++ + "\n -printer=slf_graphviz the same automaton as slf, but in Graphviz format" ++ + "\n -printer=slf_sub a finite automaton with sub-automata in the " ++ + "\n HTK SLF format" ++ + "\n -printer=slf_sub_graphviz the same automaton as slf_sub, but in " ++ + "\n Graphviz format" ++ + "\n -printer=fa_graphviz a finite automaton with labelled edges" ++ + "\n -printer=regular a regular grammar in a simple BNF" ++ + "\n -printer=unpar a gfc grammar with parameters eliminated" ++ + "\n -printer=functiongraph abstract syntax functions in 'dot' format" ++ + "\n -printer=typegraph abstract syntax categories in 'dot' format" ++ + "\n -printer=transfer Transfer language datatype (.tr file format)" ++ + "\n -printer=cfg-prolog M cfg in prolog format (also pg)" ++ + "\n -printer=gfc-prolog M gfc in prolog format (also pg)" ++ + "\n -printer=gfcm M gfcm file (default for pm)" ++ + "\n -printer=graph M module dependency graph in 'dot' (graphviz) format" ++ + "\n -printer=header M gfcm file with header (for GF embedded in Java)" ++ + "\n -printer=js M JavaScript type annotator and linearizer" ++ + "\n -printer=mcfg-prolog M mcfg in prolog format (also pg)" ++ + "\n -printer=missing M the missing linearizations of each concrete" ++ + "\n" ++ + "\n-startcat, like -cat, but used in grammars (to avoid clash with keyword cat)" ++ + "\n" ++ + "\n-transform, transformation performed on a syntax tree. The default is identity." ++ + "\n -transform=identity no change" ++ + "\n -transform=compute compute by using definitions in the grammar" ++ + "\n -transform=nodup return the term only if it has no constants duplicated" ++ + "\n -transform=nodupatom return the term only if it has no atomic constants duplicated" ++ + "\n -transform=typecheck return the term only if it is type-correct" ++ + "\n -transform=solve solve metavariables as derived refinements" ++ + "\n -transform=context solve metavariables by unique refinements as variables" ++ + "\n -transform=delete replace the term by metavariable" ++ + "\n" ++ + "\n-unlexer, untokenization transforming linearization output into a string." ++ + "\n The default is unwords." ++ + "\n -unlexer=unwords space-separated token list (like unwords)" ++ + "\n -unlexer=text format as text: punctuation, capitals, paragraph <p>" ++ + "\n -unlexer=code format as code (spacing, indentation)" ++ + "\n -unlexer=textlit like text, but remove string literal quotes" ++ + "\n -unlexer=codelit like code, but remove string literal quotes" ++ + "\n -unlexer=concat remove all spaces" ++ + "\n -unlexer=bind like identity, but bind at \"&+\"" ++ + "\n" ++ + "\n-mark, marking of parts of tree in linearization. The default is none." ++ + "\n -mark=metacat append \"+CAT\" to every metavariable, showing its category" ++ + "\n -mark=struct show tree structure with brackets" ++ + "\n -mark=java show tree structure with XML tags (used in gfeditor)" ++ + "\n" ++ + "\n-coding, Some grammars are in UTF-8, some in isolatin-1." ++ + "\n If the letters \228 (a-umlaut) and \246 (o-umlaut) look strange, either" ++ + "\n change your terminal to isolatin-1, or rewrite the grammar with" ++ + "\n 'pg -utf8'. For Windows you also may have to change your font to TrueType." ++ + "\n" ++ + "\n-- *: Commands and options marked with * are not currently implemented." ++ + [] diff --git a/src-3.0/GF/Shell/JGF.hs b/src-3.0/GF/Shell/JGF.hs new file mode 100644 index 000000000..0ff678809 --- /dev/null +++ b/src-3.0/GF/Shell/JGF.hs @@ -0,0 +1,89 @@ +---------------------------------------------------------------------- +-- | +-- Module : JGF +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/06/03 22:44:36 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.13 $ +-- +-- GF editing session controlled by e.g. a Java program. AR 16\/11\/2001 +----------------------------------------------------------------------------- + +module GF.Shell.JGF where + +import GF.Data.Operations +import GF.Infra.UseIO +import GF.Text.Unicode + +import GF.API.IOGrammar +import GF.Infra.Option +import GF.Compile.ShellState +import GF.UseGrammar.Session +import GF.Shell.Commands +import GF.Shell.CommandL +import GF.Text.UTF8 + +import Control.Monad (foldM) +import System + + + +-- GF editing session controlled by e.g. a Java program. AR 16/11/2001 + +-- | the Boolean is a temporary hack to have two parallel GUIs +sessionLineJ :: Bool -> ShellState -> IO () +sessionLineJ isNew env = do + putStrLnFlush $ initEditMsgJavaX env + let env' = addGlobalOptions (options [sizeDisplay "short",beSilent]) env + editLoopJnewX isNew env' (initSState) + +-- | this is the real version, with XML +-- +-- the Boolean is a temporary hack to have two parallel GUIs +editLoopJnewX :: Bool -> CEnv -> SState -> IO () +editLoopJnewX isNew env state = do + mscs <- getCommandUTF (isCEnvUTF8 env state) ---- + let (ms,cs) = unzip mscs + m = unlines ms --- ? + if null cs + then editLoopJnewX isNew env state + else + case cs of + [CQuit] -> return () + _ -> do + (env',state') <- foldM exec (env,state) cs + let inits = initAndEditMsgJavaX isNew env' state' m + let + package = case last cs of + CCEnvImport _ -> inits + CCEnvEmptyAndImport _ -> inits + CCEnvOpenTerm _ -> inits + CCEnvOpenString _ -> inits + CCEnvEmpty -> initEditMsgJavaX env' + _ -> displaySStateJavaX isNew env' state' m + putStrLnFlush package + editLoopJnewX isNew env' state' + where + exec (env,state) c = do + execCommand env c state + +welcome :: String +welcome = + "An experimental GF Editor for Java." ++ + "(c) Kristofer Johannisson, Janna Khegai, and Aarne Ranta 2002 under CNU GPL." + +initEditMsgJavaX :: CEnv -> String +initEditMsgJavaX env = encodeUTF8 $ mkUnicode $ unlines $ tagXML "gfinit" $ + tagsXML "newcat" [["n" +++ cat] | (_,cat) <- newCatMenu env] ++ + tagXML "topic" [abstractName env] ++ + tagXML "language" [prLanguage langAbstract] ++ + concat [tagAttrXML "language" ("file",file) [prLanguage lang] | + (file,lang) <- zip (allGrammarFileNames env) (allLanguages env)] + + +initAndEditMsgJavaX :: Bool -> CEnv -> SState -> String -> String +initAndEditMsgJavaX isNew env state m = + initEditMsgJavaX env ++++ displaySStateJavaX isNew env state m 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) diff --git a/src-3.0/GF/Shell/ShellCommands.hs b/src-3.0/GF/Shell/ShellCommands.hs new file mode 100644 index 000000000..70238817b --- /dev/null +++ b/src-3.0/GF/Shell/ShellCommands.hs @@ -0,0 +1,246 @@ +---------------------------------------------------------------------- +-- | +-- Module : ShellCommands +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/11/14 16:03:41 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.46 $ +-- +-- The datatype of shell commands and the list of their options. +----------------------------------------------------------------------------- + +module GF.Shell.ShellCommands where + +import qualified GF.Infra.Ident as I +import GF.Compile.ShellState +import GF.UseGrammar.Custom +import GF.Grammar.PrGrammar + +import GF.Infra.Option +import GF.Data.Operations +import GF.Infra.Modules + +import Data.Char (isDigit) +import Control.Monad (mplus) + +-- shell commands and their options +-- moved to separate module and added option check: AR 27/5/2004 +--- TODO: single source for +--- (1) command interpreter (2) option check (3) help file + +data Command = + CImport FilePath + | CRemoveLanguage Language + | CEmptyState + | CChangeMain (Maybe I.Ident) + | CStripState + | CTransformGrammar FilePath + | CConvertLatex FilePath + + | CDefineCommand String [String] + | CDefineTerm String + + | CLinearize [()] ---- parameters + | CParse + | CTranslate Language Language + | CGenerateRandom + | CGenerateTrees + | CTreeBank + | CPutTerm + | CWrapTerm I.Ident + | CApplyTransfer (Maybe I.Ident, I.Ident) + | CMorphoAnalyse + | CTestTokenizer + | CComputeConcrete String + | CShowOpers String + + | CLookupTreebank + + | CTranslationQuiz Language Language + | CTranslationList Language Language + | CMorphoQuiz + | CMorphoList + + | CReadFile FilePath + | CWriteFile FilePath + | CAppendFile FilePath + | CSpeakAloud + | CSpeechInput + | CPutString + | CShowTerm + | CSystemCommand String + | CGrep String + + | CSetFlag + | CSetLocalFlag Language + + | CPrintGrammar + | CPrintGlobalOptions + | CPrintLanguages + | CPrintInformation I.Ident + | CPrintMultiGrammar + | CPrintSourceGrammar + | CShowGrammarGraph + | CShowTreeGraph + | CPrintGramlet + | CPrintCanonXML + | CPrintCanonXMLStruct + | CPrintHistory + | CHelp (Maybe String) + + | CImpure ImpureCommand + + | CVoid + +-- to isolate the commands that are executed on top level +data ImpureCommand = + ICQuit + | ICExecuteHistory FilePath + | ICEarlierCommand Int + | ICEditSession + | ICTranslateSession + | ICReload + +type CommandOpt = (Command, Options) + +-- the top-level option warning action + +checkOptions :: ShellState -> (Command,Options) -> IO () +checkOptions sh (co, Opts opts) = do + let (_,s) = errVal ([],"option check failed") $ mapErr check opts + if (null s) then return () + else putStr "WARNING: " >> putStrLn s + where + check = isValidOption sh co + +isValidOption :: ShellState -> Command -> Option -> Err () +isValidOption st co op = case op of + Opt (o,[]) -> + testErr (elem o $ optsOf co) ("invalid option:" +++ prOpt op) + Opt (o,[x]) -> do + testErr (elem o (flagsOf co)) ("invalid flag:" +++ o) + testValidFlag st co o x + _ -> Bad $ "impossible option" +++ prOpt op + where + optsOf co = ("tr" :) $ fst $ optionsOfCommand co + flagsOf co = snd $ optionsOfCommand co + +testValidFlag :: ShellState -> Command -> OptFunId -> String -> Err () +testValidFlag st co f x = case f of + "cat" -> testIn (map prQIdent_ (allCategories st)) + "lang" -> testIn (map prt (allLanguages st)) + "transfer" -> testIn (map prt (allTransfers st)) + "res" -> testIn (map prt (allResources (srcModules st))) + "number" -> testN + "printer" -> case co of + CPrintGrammar -> testInc customGrammarPrinter + CPrintMultiGrammar -> testInc customMultiGrammarPrinter + CSetFlag -> testInc customGrammarPrinter `mplus` + testInc customMultiGrammarPrinter + "lexer" -> testInc customTokenizer + "unlexer" -> testInc customUntokenizer + "depth" -> testN + "rawtrees"-> testN + "parser" -> testInc customParser + -- hack for the -newer parsers: (to be changed in the future) + -- `mplus` testIn (words "mcfg mcfg-bottomup mcfg-topdown cfg cfg-bottomup cfg-topdown bottomup topdown") + -- if not(null x) && head x `elem` "mc" then return () else Bad "" + "alts" -> testN + "transform" -> testInc customTermCommand + "filter" -> testInc customStringCommand + "length" -> testN + "optimize"-> testIn $ words "parametrize values all share none" + "conversion" -> testIn $ words "strict nondet finite finite2 finite3 singletons finite-strict finite-singletons" + _ -> return () + where + testInc ci = + let vs = snd (customInfo ci) in testIn vs + testIn vs = + if elem x vs + then return () + else Bad ("flag:" +++ f +++ "invalid value:" +++ x ++++ + "possible values:" +++ unwords vs) + testN = + if all isDigit x + then return () + else Bad ("flag:" +++ f +++ "invalid value:" +++ x ++++ + "expected integer") + + +optionsOfCommand :: Command -> ([String],[String]) +optionsOfCommand co = case co of + CSetFlag -> + both "utf8 table struct record all multi" + "cat lang lexer parser number depth rawtrees unlexer optimize path conversion printer" + CImport _ -> + both "old v s src make gfc retain docf nocf nocheckcirc cflexer noemit o make ex prob treebank" + "abs cnc res path optimize conversion cat preproc probs noparse" + CRemoveLanguage _ -> none + CEmptyState -> none + CStripState -> none + CTransformGrammar _ -> flags "printer" + CConvertLatex _ -> none + CLinearize _ -> both "utf8 table struct record all multi" "lang number unlexer mark" + CParse -> + both "ambiguous fail cut new newer old overload cfg mcfg fcfg n ign raw v lines all prob" + "cat lang lexer parser number rawtrees" + CTranslate _ _ -> opts "cat lexer parser" + CGenerateRandom -> both "cf prob" "cat lang number depth atoms noexpand doexpand" + CGenerateTrees -> both "metas" "atoms depth alts cat lang number noexpand doexpand" + CPutTerm -> flags "transform number" + CTreeBank -> opts "c xml trees all table record" + CLookupTreebank -> both "assocs raw strings trees" "treebank" + CWrapTerm _ -> opts "c" + CApplyTransfer _ -> flags "lang transfer" + CMorphoAnalyse -> both "short status" "lang" + CTestTokenizer -> flags "lexer" + CComputeConcrete _ -> both "table" "res" + CShowOpers _ -> flags "res" + + CTranslationQuiz _ _ -> flags "cat" + CTranslationList _ _ -> flags "cat number" + CMorphoQuiz -> flags "cat lang" + CMorphoList -> flags "cat lang number" + + CReadFile _ -> none + CWriteFile _ -> none + CAppendFile _ -> none + CSpeakAloud -> flags "language" + CSpeechInput -> flags "lang cat language number" + + CPutString -> both "utf8" "filter length" + CShowTerm -> flags "printer" + CShowTreeGraph -> opts "c f g o" + CSystemCommand _ -> none + CGrep _ -> opts "v" + + CPrintGrammar -> both "utf8" "printer lang startcat" + CPrintMultiGrammar -> both "utf8 utf8id" "printer" + CPrintSourceGrammar -> both "utf8" "printer" + + CHelp _ -> opts "all alts atoms coding defs filter length lexer unlexer printer probs transform depth number cat" + + CImpure ICEditSession -> both "f" "file" + CImpure ICTranslateSession -> both "f langs" "cat" + + _ -> none + +{- + CSetLocalFlag Language + CPrintGlobalOptions + CPrintLanguages + CPrintInformation I.Ident + CPrintGramlet + CPrintCanonXML + CPrintCanonXMLStruct + CPrintHistory + CVoid +-} + where + flags fs = ([],words fs) + opts fs = (words fs,[]) + both os fs = (words os,words fs) + none = ([],[]) diff --git a/src-3.0/GF/Shell/SubShell.hs b/src-3.0/GF/Shell/SubShell.hs new file mode 100644 index 000000000..5ef0459e5 --- /dev/null +++ b/src-3.0/GF/Shell/SubShell.hs @@ -0,0 +1,66 @@ +---------------------------------------------------------------------- +-- | +-- Module : SubShell +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:46:12 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.9 $ +-- +-- (Description of the module) +----------------------------------------------------------------------------- + +module GF.Shell.SubShell where + +import GF.Data.Operations +import GF.Infra.UseIO +import GF.Compile.ShellState +import GF.Infra.Option +import GF.API + +import GF.Shell.CommandL +import GF.System.ArchEdit + +import Data.List + +-- 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 :: String +myUniFont = "-mutt-clearlyu-medium-r-normal--0-0-100-100-p-0-iso10646-1" + +mkOptFont :: String -> String +mkOptFont = id + +translateSession :: Options -> ShellState -> IO () +translateSession opts st = do + let grs = allStateGrammars st + cat = firstCatOpts opts (firstStateGrammar st) + trans s = unlines $ + if oElem showLang opts then + sort $ [l +++ ":" +++ s | (l,s) <- zip (map (prIdent . cncId) grs) + (translateBetweenAll grs cat s)] + else translateBetweenAll grs cat s + translateLoop opts trans + +translateLoop :: Options -> (String -> String) -> IO () +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 diff --git a/src-3.0/GF/Shell/TeachYourself.hs b/src-3.0/GF/Shell/TeachYourself.hs new file mode 100644 index 000000000..7e5a8afe2 --- /dev/null +++ b/src-3.0/GF/Shell/TeachYourself.hs @@ -0,0 +1,87 @@ +---------------------------------------------------------------------- +-- | +-- Module : TeachYourself +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:46:13 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.7 $ +-- +-- translation and morphology quiz. AR 10\/5\/2000 -- 12\/4\/2002 +----------------------------------------------------------------------------- + +module GF.Shell.TeachYourself where + +import GF.Compile.ShellState +import GF.API +import GF.UseGrammar.Linear +import GF.Grammar.PrGrammar + +import GF.Infra.Option +import GF.System.Arch (myStdGen) +import GF.Data.Operations +import GF.Infra.UseIO + +import System.Random --- (randoms) --- bad import for hbc +import System + +-- translation and morphology quiz. AR 10/5/2000 -- 12/4/2002 + +teachTranslation :: Options -> GFGrammar -> GFGrammar -> IO () +teachTranslation opts ig og = do + tts <- transTrainList opts ig og infinity + let qas = [ (q, mkAnswer as) | (q,as) <- tts] + teachDialogue qas "Welcome to GF Translation Quiz." + +transTrainList :: + Options -> GFGrammar -> GFGrammar -> Integer -> IO [(String,[String])] +transTrainList opts ig og number = do + ts <- randomTreesIO (addOption beSilent opts) ig (fromInteger number) + return $ map mkOne $ ts + where + cat = firstCatOpts opts ig + mkOne t = (norml (linearize ig t),map (norml . linearize og) (homonyms ig cat t)) + + +teachMorpho :: Options -> GFGrammar -> IO () +teachMorpho opts ig = useIOE () $ do + tts <- morphoTrainList opts ig infinity + let qas = [ (q, mkAnswer as) | (q,as) <- tts] + ioeIO $ teachDialogue qas "Welcome to GF Morphology Quiz." + +morphoTrainList :: Options -> GFGrammar -> Integer -> IOE [(String,[String])] +morphoTrainList opts ig number = do + ts <- ioeIO $ randomTreesIO (addOption beSilent opts) ig (fromInteger number) + gen <- ioeIO $ myStdGen (fromInteger number) + mkOnes gen ts + where + mkOnes gen (t:ts) = do + psss <- ioeErr $ allLinTables True gr cnc t + let pss = concat $ map snd $ concat psss + let (i,gen') = randomR (0, length pss - 1) gen + (ps,ss) <- ioeErr $ pss !? i + (_,ss0) <- ioeErr $ pss !? 0 + let bas = unwords ss0 --- concat $ take 1 ss0 + more <- mkOnes gen' ts + return $ (bas +++ ":" +++ unwords (map prt_ ps), return (unwords ss)) : more + mkOnes gen [] = return [] + + gr = grammar ig + cnc = cncId ig + +-- | compare answer to the list of right answers, increase score and give feedback +mkAnswer :: [String] -> String -> (Integer, String) +mkAnswer as s = if (elem (norml s) as) + then (1,"Yes.") + else (0,"No, not" +++ s ++ ", but" ++++ unlines as) + + +norml :: String -> String +norml = unwords . words + +-- | the maximal number of precompiled quiz problems +infinity :: Integer +infinity = 123 + |