Founding the newly structured GF2.0 cvs archive.

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'

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 <enter>
+
+-- 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]
+

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

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)

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
+-}