From a77519ba1045d23a7bb8ea1c56cc90518e9fedb9 Mon Sep 17 00:00:00 2001
From: aarne <unknown>
Date: Wed, 16 Jun 2004 14:49:50 +0000
Subject: [PATCH] bug fixes ; command so ; reintroduce batch mode

---
 src/GF.hs                     |  79 ++++-----
 src/GF/API/IOGrammar.hs       |   5 +
 src/GF/Compile/ShellState.hs  |  10 +-
 src/GF/GFModes.hs             |  77 +++++++++
 src/GF/Grammar/Lookup.hs      | 296 +---------------------------------
 src/GF/Grammar/PrGrammar.hs   |   3 +
 src/GF/Infra/Modules.hs       |   3 +
 src/GF/Infra/Option.hs        |   3 +
 src/GF/Shell.hs               |  11 ++
 src/GF/Shell/PShell.hs        |   8 +
 src/GF/Shell/ShellCommands.hs |   3 +
 src/HelpFile                  |  11 ++
 src/HelpFile.hs               |  11 ++
 13 files changed, 187 insertions(+), 333 deletions(-)
 create mode 100644 src/GF/GFModes.hs

diff --git a/src/GF.hs b/src/GF.hs
index b29a3c797..5eafefe8d 100644
--- a/src/GF.hs
+++ b/src/GF.hs
@@ -1,5 +1,6 @@
 module Main where
 
+import GFModes
 import Operations
 import UseIO
 import Option
@@ -23,47 +24,49 @@ main :: IO ()
 main = do
   xs <- getArgs
   let (os,fs) = getOptions "-" xs
-      java    = oElem forJava os
-      isNew   = oElem newParser os ---- temporary hack to have two parallel GUIs
-  putStrLnFlush $ if java then encodeUTF8 welcomeMsg else welcomeMsg
-  st <- case fs of 
-    _ -> useIOE emptyShellState $ foldM (shellStateFromFiles os) emptyShellState fs
-  ---  _ -> return emptyShellState
-  if null fs then return () else putCPU 
-  if java then sessionLineJ isNew st else do
-  gfInteract (initHState st) 
-  return ()
+      opt j   = oElem j os
+  case 0 of
 
-gfInteract :: HState -> IO HState
-gfInteract st@(env,_) = do
-  -- putStrFlush "> " M.F 25/01-02 prompt moved to Arch.
-  (s,cs) <- getCommandLines
-  case ifImpure cs of
+    _ | opt getHelp -> do
+      putStrLnFlush $ encodeUTF8 helpMsg
 
-    -- these are the three impure commands
-    Just (ICQuit,_) -> do
-      putStrLn "See you."
-      return st
-    Just (ICExecuteHistory file,_) -> do
-      ss  <- readFileIf file
-      let co = pCommandLines ss
-      st' <- execLinesH s co st      
-      gfInteract st'      
-    Just (ICEarlierCommand i,_) -> do
-      let line = earlierCommandH st i
-          co   = pCommandLine $ words line
-      st' <- execLinesH line [co] st       -- s would not work in execLinesH
-      gfInteract st'
-    Just (ICEditSession,os) -> 
-      editSession (addOptions os opts) env >> gfInteract st
-    Just (ICTranslateSession,os) -> 
-      translateSession (addOptions os opts) env >> gfInteract st
-    -- this is a normal command sequence
+    _ | opt forJava -> do
+      putStrLnFlush $ encodeUTF8 welcomeMsg 
+      st <- useIOE emptyShellState $ 
+              foldM (shellStateFromFiles os) emptyShellState fs
+      sessionLineJ True st
+      return ()
+
+    _ | opt doMake -> do
+      case fs of
+        [f] -> batchCompile os f
+        _ -> putStrLnFlush "expecting exactly one gf file to compile"
+
+    _ | opt doBatch -> do
+      if opt beSilent then return () else putStrLnFlush "<gfbatch>"
+      st <- useIOE emptyShellState $ 
+              foldM (shellStateFromFiles os) emptyShellState fs
+      gfBatch (initHState st) 
+      if opt beSilent then return () else putStrLnFlush "</gfbatch>"
+      return ()
     _ -> do
-      st' <- execLinesH s cs st
-      gfInteract st'
-   where
-     opts = globalOptions env
+      putStrLnFlush $ welcomeMsg
+      st <- useIOE emptyShellState $ 
+              foldM (shellStateFromFiles os) emptyShellState fs
+      if null fs then return () else putCPU 
+      gfInteract (initHState st) 
+      return ()
+
+helpMsg = unlines [
+  "Usage: gf <option>* <file>*",
+  "Options:",
+  "  -make    batch-compile files",
+  "   -noemit do not emit code when compiling",
+  "   -v      be verbose when compiling",
+  "  -batch   structure session by XML tags (use > to send into a file)",
+  "  -help    show this message",
+  "To use the GUI: jgf <option>* <file>*"
+  ]
 
 welcomeMsg = 
   "Welcome to " ++ authorMsg ++++ welcomeArch ++ "\n\nType 'h' for help."
diff --git a/src/GF/API/IOGrammar.hs b/src/GF/API/IOGrammar.hs
index 7d0f0f15f..73fb0b438 100644
--- a/src/GF/API/IOGrammar.hs
+++ b/src/GF/API/IOGrammar.hs
@@ -55,3 +55,8 @@ shellStateFromFiles opts st file = case fileSuffix file of
      grts <- compileModule osb st file
      ioeErr $ updateShellState opts' st grts
      --- liftM (changeModTimes rts) $ grammar2shellState opts gr
+
+getShellStateFromFiles :: Options -> FilePath -> IO ShellState
+getShellStateFromFiles os = 
+  useIOE emptyShellState . 
+  shellStateFromFiles os emptyShellState
diff --git a/src/GF/Compile/ShellState.hs b/src/GF/Compile/ShellState.hs
index 6a25ed1cb..acf87494f 100644
--- a/src/GF/Compile/ShellState.hs
+++ b/src/GF/Compile/ShellState.hs
@@ -323,6 +323,10 @@ firstCatOpts opts sgr =
   maybe (stateFirstCat sgr) (string2CFCat (P.prt (absId sgr))) $ 
     getOptVal opts firstCat
 
+-- the first cat for random generation
+firstAbsCat :: Options -> StateGrammar -> G.QIdent
+firstAbsCat opts = cfCat2Cat . firstCatOpts opts
+
 -- a grammar can have start category as option startcat=foo ; default is S 
 stateFirstCat sgr =
   maybe (string2CFCat a "S") (string2CFCat a) $ 
@@ -330,12 +334,6 @@ stateFirstCat sgr =
  where 
    a = P.prt (absId sgr)
 
--- the first cat for random generation
-firstAbsCat :: Options -> StateGrammar -> G.QIdent
-firstAbsCat opts sgr = 
-  maybe (absId sgr, identC "S") (\c -> (absId sgr, identC c)) $ ----
-    getOptVal opts firstCat
-
 {-
 -- command-line option -cat=foo overrides the possible start cat of a grammar
 stateTransferFun :: StateGrammar -> Maybe Fun
diff --git a/src/GF/GFModes.hs b/src/GF/GFModes.hs
new file mode 100644
index 000000000..6944dd0d3
--- /dev/null
+++ b/src/GF/GFModes.hs
@@ -0,0 +1,77 @@
+module GFModes where
+
+import Operations
+import UseIO
+import Option
+import ShellState
+import ShellCommands
+import Shell
+import SubShell
+import PShell
+import JGF
+import Char (isSpace)
+
+-- separated from GF Main 24/6/2003
+
+gfInteract :: HState -> IO HState
+gfInteract st@(env,_) = do
+  -- putStrFlush "> " M.F 25/01-02 prompt moved to Arch.
+  (s,cs) <- getCommandLines
+  case ifImpure cs of
+
+    -- these are the three impure commands
+    Just (ICQuit,_) -> do
+      putStrLnFlush "See you."
+      return st
+    Just (ICExecuteHistory file,_) -> do
+      ss  <- readFileIf file
+      let co = pCommandLines ss
+      st' <- execLinesH s co st      
+      gfInteract st'      
+    Just (ICEarlierCommand i,_) -> do
+      let line = earlierCommandH st i
+          co   = pCommandLine $ words line
+      st' <- execLinesH line [co] st       -- s would not work in execLinesH
+      gfInteract st'
+
+    Just (ICEditSession,os) -> 
+      editSession (addOptions os opts) env >> gfInteract st
+    Just (ICTranslateSession,os) -> 
+      translateSession (addOptions os opts) env >> gfInteract st
+
+    -- this is a normal command sequence
+    _ -> do
+      st' <- execLinesH s cs st
+      gfInteract st'
+   where
+     opts = globalOptions env
+
+gfBatch :: HState -> IO HState
+gfBatch st@(sh,_) = do
+  (s,cs) <- getCommandLinesBatch
+  if s == "q" then return st else do
+    st' <- if all isSpace s then return st else do
+        putVe "<gfcommand>"
+        putVe s
+        putVe "</gfcommand>"
+        putVe "<gfreply>"
+        (_,st') <- execLines True cs st
+        putVe "</gfreply>"
+        return st'
+    gfBatch st'
+ where
+   putVe = putVerb st
+
+putVerb st@(sh,_) s = if (oElem beSilent (globalOptions sh))
+                          then return ()
+                          else putStrLnFlush s 
+
+batchCompile :: Options -> FilePath -> IO ()
+batchCompile os file = do
+  let file' = mkGFC file
+  let s     = "i -o" +++ (unwords $ map ('-':) $ words $ prOpts os) +++ file
+  let cs    = pCommandLines s
+  execLines True cs (initHState emptyShellState)
+  return ()
+
+mkGFC = reverse . ("cfg" ++) . dropWhile (/='.') . reverse
diff --git a/src/GF/Grammar/Lookup.hs b/src/GF/Grammar/Lookup.hs
index 684b08cff..05b0bf39e 100644
--- a/src/GF/Grammar/Lookup.hs
+++ b/src/GF/Grammar/Lookup.hs
@@ -113,292 +113,10 @@ lookupLincat gr m c = do
     _ -> Bad $ prt m +++ "is not concrete"
 
 
-
-{-
--- the type of oper may have to be inferred at TC, so it may be junk before it
-
-lookupResIdent :: Ident -> [(Ident, SourceRes)] -> Err (Term,Type)
-lookupResIdent c ms = case lookupWhich ms c of
-  Ok (i,info)  -> case info of
-    ResOper (Yes t) _ -> return (Q i c, t)
-    ResOper _ _       -> return (Q i c, undefined) ----
-    ResParam _        -> return (Q i c, typePType)
-    ResValue (Yes t)  -> return (QC i c, t)
-  _   -> Bad $ "not found in resource" +++ prt c
-
--- NB we only have to look up cnc in canonical!
-
--- you may want to strip the qualification if the module is the current one
-
-stripMod :: Ident -> Term -> Term
-stripMod m t = case t of
-  Q  n c | n==m -> Cn c
-  QC n c | n==m -> Con c
-  _ -> t
-
--- what you want may be a pattern and not a term. Then use Macros.term2patt
-
-
-
-
--- an auxiliary for making ordered search through a list of modules
-
-lookups :: Ord i => (i -> m -> Err (Perhaps a m)) -> i -> [m] -> Err (Perhaps a m)
-lookups look c [] = Bad "not found in any module"
-lookups look c (m:ms) = case look c m of
-  Ok (Yes v)  -> return $ Yes v
-  Ok (May m') -> look c m'
-  _   -> lookups look c ms
-
-
-lookupAbstract :: AbstractST -> Ident -> Err AbsInfo
-lookupAbstract g i = errIn ("not found in abstract" +++ prt i) $ lookupTree prt i g
-
-lookupFunsToCat :: AbstractST -> Ident -> Err [Fun]
-lookupFunsToCat g c = errIn ("looking up functions to category" +++ prt c) $ do
-  info <- lookupAbstract g c
-  case info of
-    AbsCat _ _ fs _ -> return fs
-    _ -> prtBad "not category" c
-
-allFunsWithValCat ab = [(f,c) | (c, AbsCat _ _ fs _) <- abstr2list ab, f <- fs]
-
-allDefs ab = [(f,d) | (f,AbsFun _ (Just d)) <- abstr2list ab]
-
-lookupCatContext :: AbstractST -> Ident -> Err Context
-lookupCatContext g c = errIn "context of category" $ do
-  info <- lookupAbstract g c
-  case info of
-    AbsCat c _ _ _ -> return c
-    _ -> prtBad "not category" c
-
-lookupFunType :: AbstractST -> Ident -> Err Term
-lookupFunType g c = errIn "looking up type of function" $ case c of
-  IL s -> lookupLiteral s >>= return . fst
-  _ -> do
-    info <- lookupAbstract g c
-    case info of
-      AbsFun t _ -> return t
-      AbsType t  -> return typeType
-      _ -> prtBad "not function" c
-
-lookupFunArity :: AbstractST -> Ident -> Err Int
-lookupFunArity g c = do
-  typ <- lookupFunType g c
-  ctx <- contextOfType typ
-  return $ length ctx
-
-lookupAbsDef :: AbstractST -> Ident -> Err (Maybe Term)
-lookupAbsDef g c = errIn "looking up definition in abstract syntax" $ do
-  info <- lookupAbstract g c
-  case info of
-    AbsFun _ t -> return t
-    AbsType t  -> return $ Just t
-    _ -> return $ Nothing  -- constant found and accepted as primitive
-
-
-allCats :: AbstractST -> [Ident]
-allCats abstr = [c | (c, AbsCat _ _ _ _) <- abstr2list abstr]
-
-allIndepCats :: AbstractST -> [Ident]
-allIndepCats abstr = [c | (c, AbsCat [] _ _ _) <- abstr2list abstr]
-
-lookupConcrete :: ConcreteST -> Ident -> Err CncInfo
-lookupConcrete g i = errIn ("not found in concrete" +++ prt i) $ lookupTree prt i g
-
-lookupPackage :: ConcreteST -> Ident -> Err ([Ident], ConcreteST)
-lookupPackage g p = do
-  info <- lookupConcrete g p
-  case info of
-    CncPackage ps ins -> return (ps,ins)
-    _ -> prtBad "not package" p
-
-lookupInPackage :: ConcreteST -> (Ident,Ident) -> Err CncInfo
-lookupInPackage = lookupLift (flip (lookupTree prt))
-
-lookupInAll :: [BinTree (Ident,b)] -> Ident -> Err b
-lookupInAll = lookInAll (flip (lookupTree prt)) 
-
-lookInAll :: (BinTree (Ident,c)  -> Ident -> Err b) -> 
-              [BinTree (Ident,c)] -> Ident -> Err b
-lookInAll look ts c = case ts of
-  t : ts' -> err (const $ lookInAll look ts' c) return $ look t c
-  [] -> prtBad "not found in any package" c
-
-lookupLift :: (ConcreteST -> Ident -> Err b) -> 
-              ConcreteST  -> (Ident,Ident) -> Err b
-lookupLift look g (p,f) = do
-  (ps,ins) <- lookupPackage g p
-  ps' <- mapM (lookupPackage g) ps
-  lookInAll look (ins : reverse (map snd ps')) f
-
-termFromPackage :: ConcreteST -> Ident -> Term -> Err Term
-termFromPackage g p = termFP where
-  termFP t = case t of
-    Cn c -> return $ if isInPack c
-               then Q p c
-               else Cn c 
-    T (TTyped t) cs -> do
-      t' <- termFP t
-      liftM (T (TTyped t')) $ mapM branchInPack cs
-    T i cs -> liftM (T i) $ mapM branchInPack cs
-    _ -> composOp termFP t
-  isInPack c = case lookupInPackage g (p,c) of
-    Ok _ -> True
-    _    -> False
-  branchInPack (q,t) = do
-    p' <- pattInPack q
-    t' <- termFP t
-    return (p',t')
-  pattInPack q = case q of
-    PC c ps -> do
-      let pc = if isInPack c
-                  then PP p c
-                  else PC c
-      ps' <- mapM pattInPack ps 
-      return $ pc ps'
-    _ -> return q
-
-lookupCncDef :: ConcreteST -> Ident -> Err Term
-lookupCncDef g t@(IL _) = return $ cn t
-lookupCncDef g c = errIn "looking up defining term" $ do
-  info <- lookupConcrete g c
-  case info of
-    CncOper _ t _  -> return t  -- the definition
-    CncCat t _ _ _ -> return t  -- the linearization type
-    _ -> return $ Cn c -- constant found and accepted
-
-lookupOperDef :: ConcreteST -> Ident -> Err Term
-lookupOperDef g c = errIn "looking up defining term of oper" $ do
-  info <- lookupConcrete g c
-  case info of
-    CncOper _ t _ -> return t
-    _ -> prtBad "not oper" c
-
-lookupLincat :: ConcreteST -> Ident -> Err Term
-lookupLincat g c = return $ errVal defaultLinType $ do
-  info <- lookupConcrete g c
-  case info of
-    CncCat t _ _ _ -> return t
-    _ -> prtBad "not category" c
-
-lookupLindef :: ConcreteST -> Ident -> Err Term
-lookupLindef g c = return $ errVal linDefStr $ do
-  info <- lookupConcrete g c
-  case info of
-    CncCat _ (Just t) _ _ -> return t
-    CncCat _ _ _ _        -> return $ linDefStr --- wrong: this is only sof {s:Str}
-    _ -> prtBad "not category" c
-
-lookupLinType :: ConcreteST -> Ident -> Err Type
-lookupLinType g c = errIn "looking up type in concrete syntax" $ do
-  info <- lookupConcrete g c
-  case info of
-    CncParType _ _ _ -> return typeType
-    CncParam ty _ -> return ty
-    CncOper (Just ty) _ _ -> return ty
-    _ -> prtBad "no type found for" c
-
-lookupLin :: ConcreteST -> Ident -> Err Term
-lookupLin g c = errIn "looking up linearization rule" $ do
-  info <- lookupConcrete g c
-  case info of
-    CncFun t _ -> return t
-    _ -> prtBad "not category" c
-
-lookupFirstTag :: ConcreteST -> Ident -> Err Term
-lookupFirstTag g c = do
-  vs <- lookupParamValues g c
-  case vs of
-    v:_ -> return v
-    _ -> prtBad "empty parameter type" c
-
-lookupPrintname :: ConcreteST -> Ident -> Err String
-lookupPrintname g c = case lookupConcrete g c of
-  Ok info -> case info of
-    CncCat _ _ _ m   -> mpr m
-    CncFun _ m       -> mpr m
-    CncParType _ _ m -> mpr m
-    CncOper _ _ m    -> mpr m
-    _ -> Bad "no possible printname"
-  Bad s -> Bad s
- where
-     mpr = maybe (Bad "no printname") (return . stringFromTerm)
-
--- this variant succeeds even if there's only abstr syntax
-lookupPrintname' g c = case lookupConcrete g c of
-  Bad _   -> return $ prt c 
-  Ok info -> case info of
-    CncCat _ _ _ m   -> mpr m
-    CncFun _ m       -> mpr m
-    CncParType _ _ m -> mpr m
-    CncOper _ _ m    -> mpr m
-    _ -> return $ prt c
-   where
-     mpr = return . maybe (prt c) stringFromTerm
-
-allOperDefs :: ConcreteST -> [(Ident,CncInfo)]
-allOperDefs cnc = [d | d@(_, CncOper _ _ _) <- concr2list cnc]
-
-allPackageDefs :: ConcreteST -> [(Ident,CncInfo)]
-allPackageDefs cnc = [d | d@(_, CncPackage _ _) <- concr2list cnc]
-
-allOperDependencies :: ConcreteST -> [(Ident,[Ident])]
-allOperDependencies cnc = 
-  [(f, filter (/= f) $ -- package name may occur in the package itself
-       nub (concatMap (opersInCncInfo cnc f . snd) (tree2list ds))) | 
-                             (f, CncPackage _ ds) <- allPackageDefs cnc] ++
-  [(f, nub (opersInTerm cnc t)) | 
-                             (f, CncOper _ t _) <- allOperDefs cnc]
-
-opersInTerm :: ConcreteST -> Term -> [Ident]
-opersInTerm cnc t = case t of
-     Cn c -> [c | isOper c]
-     Q p c -> [p]
-     _ -> collectOp ops t
-  where
-   isOper (IL _) = False 
-   isOper c = errVal False $ lookupOperDef cnc c >>= return . const True
-   ops = opersInTerm cnc
-
--- this is used inside packages, to find references to outside the package
-opersInCncInfo :: ConcreteST -> Ident -> CncInfo -> [Ident]
-opersInCncInfo cnc p i = case i of
-   CncOper _ t _-> filter (not . internal) $ opersInTerm cnc t
-   _ -> []
-  where
-    internal c = case lookupInPackage cnc (p,c) of
-      Ok _ -> True
-      _ -> False
-   
-opersUsedInLins ::  ConcreteST -> [(Ident,[Ident])] -> [Ident]
-opersUsedInLins cnc deps = do
-  let ops0 = concat [opersInTerm cnc t | (_, CncFun t _) <- concr2list cnc]
-  nub $ closure ops0
- where
-   closure ops = case [g | (f,fs) <- deps, elem f ops, g <- fs, notElem g ops] of
-     [] -> ops
-     ops' -> ops ++ closure ops'
-   -- presupposes deps are not circular: check this first!
-
-
-
-
--- create refinement and wrapping lists
-
-
-varOrConst :: AbstractST -> Ident -> Err Term
-varOrConst abstr c = case lookupFunType abstr c of
-  Ok _ -> return $ Cn c   --- bindings cannot overshadow constants
-  _ -> case c of
-    IL _ -> return $ Cn c
-    _ -> return $ Vr c
-
--- a rename operation for parsing term input; for abstract syntax and parameters
-renameTrm :: (Ident -> Err a) -> Term -> Term
-renameTrm look = ren [] where
-  ren vars t = case t of
-    Vr x | notElem x vars && isNotError (look x) -> Cn x
-    Abs x b -> Abs x $ ren (x:vars) b
-    _ -> composSafeOp (ren vars) t
--}
+opersForType :: SourceGrammar -> Type -> [(QIdent,Term)]
+opersForType gr val = 
+  [((i,f),ty) | (i,m) <- allModMod gr, 
+                (f,ResOper (Yes ty) _) <- tree2list $ jments m,
+                Ok valt <- [valTypeCnc ty],
+                valt == val
+  ]
diff --git a/src/GF/Grammar/PrGrammar.hs b/src/GF/Grammar/PrGrammar.hs
index 1a3754f04..ffa6581cf 100644
--- a/src/GF/Grammar/PrGrammar.hs
+++ b/src/GF/Grammar/PrGrammar.hs
@@ -224,3 +224,6 @@ prRefinement t = case t of
     Q m c  -> prQIdent (m,c)
     QC m c -> prQIdent (m,c)
     _ -> prt t
+
+prOperSignature :: (QIdent,Type) -> String
+prOperSignature (f, t) = prQIdent f +++ ":" +++ prt t
diff --git a/src/GF/Infra/Modules.hs b/src/GF/Infra/Modules.hs
index b43eb7b4d..8272635f7 100644
--- a/src/GF/Infra/Modules.hs
+++ b/src/GF/Infra/Modules.hs
@@ -244,6 +244,9 @@ lookupModMod gr i = do
 lookupInfo :: (Show i, Ord i) => Module i f a -> i -> Err a
 lookupInfo mo i = lookupTree show i (jments mo)
 
+allModMod :: (Show i,Eq i) => MGrammar i f a -> [(i,Module i f a)]
+allModMod gr = [(i,m) | (i, ModMod m) <- modules gr]
+
 isModAbs m = case mtype m of
   MTAbstract -> True
 ----  MTUnion t -> isModAbs t
diff --git a/src/GF/Infra/Option.hs b/src/GF/Infra/Option.hs
index c04d40244..dcfbc3b17 100644
--- a/src/GF/Infra/Option.hs
+++ b/src/GF/Infra/Option.hs
@@ -148,6 +148,9 @@ beVerbose    = iOpt "v"
 showInfo     = iOpt "i"
 beSilent     = iOpt "s"
 emitCode     = iOpt "o"
+getHelp      = iOpt "help"
+doMake       = iOpt "make"
+doBatch      = iOpt "batch"
 notEmitCode  = iOpt "noemit"
 makeMulti    = iOpt "multi"
 beShort      = iOpt "short"
diff --git a/src/GF/Shell.hs b/src/GF/Shell.hs
index ebfa332b0..e00382bff 100644
--- a/src/GF/Shell.hs
+++ b/src/GF/Shell.hs
@@ -5,6 +5,7 @@ import Str
 import qualified Grammar as G
 import qualified Ident as I
 import qualified Compute as Co
+import qualified Lookup as L
 import qualified GFC
 import Values
 import GetTree
@@ -158,6 +159,16 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = checkOptions st co >> case comm of
              getOptVal opts useResource             -- flag -res=m
     justOutput (putStrLn (err id (prt . stripTerm) (
                 string2srcTerm src m t >>= Co.computeConcrete src))) sa
+  CShowOpers t -> do
+    m <- return $
+         maybe (I.identC "?") id $  -- meaningful if no opers in t 
+           maybe (resourceOfShellState st) (return . I.identC) $ -- topmost res
+             getOptVal opts useResource             -- flag -res=m
+    justOutput (putStrLn (err id (unlines . map prOperSignature) (
+                string2srcTerm src m t >>= 
+                Co.computeConcrete src >>= 
+                return . L.opersForType src))) sa
+
 
   CTranslationQuiz il ol -> justOutput (teachTranslation opts (sgr il) (sgr ol)) sa
   CTranslationList il ol n -> do 
diff --git a/src/GF/Shell/PShell.hs b/src/GF/Shell/PShell.hs
index d58b18c16..230a6e62a 100644
--- a/src/GF/Shell/PShell.hs
+++ b/src/GF/Shell/PShell.hs
@@ -9,7 +9,9 @@ import Option
 import PGrammar (pzIdent, pTrm) --- (string2formsAndTerm)
 import API
 import Arch(fetchCommand)
+
 import Char (isDigit)
+import IO
 
 -- parsing GF shell commands. AR 11/11/2001
 
@@ -20,6 +22,11 @@ getCommandLines = do
   s <- fetchCommand "> "
   return (s,pCommandLines s)
 
+getCommandLinesBatch :: IO (String,[CommandLine])
+getCommandLinesBatch = do
+  s <- catch getLine (\e -> if IO.isEOFError e then return "q" else ioError e)
+  return $ (s,pCommandLines s)
+
 pCommandLines :: String -> [CommandLine]
 pCommandLines = map pCommandLine . concatMap (chunks ";;" . words) . lines
 
@@ -80,6 +87,7 @@ pCommand ws = case ws of
   "ma" : s      -> aString CMorphoAnalyse s
   "tt" : s      -> aString CTestTokenizer s
   "cc" : s      -> aUnit   $ CComputeConcrete $ unwords s
+  "so" : s      -> aUnit   $ CShowOpers $ unwords s
 
   "tq" : i:o:[] -> aUnit   (CTranslationQuiz (language i) (language o))
   "tl":i:o:n:[] -> aUnit   (CTranslationList (language i) (language o) (readIntArg n))
diff --git a/src/GF/Shell/ShellCommands.hs b/src/GF/Shell/ShellCommands.hs
index 650364d45..03e8fafbd 100644
--- a/src/GF/Shell/ShellCommands.hs
+++ b/src/GF/Shell/ShellCommands.hs
@@ -33,6 +33,7 @@ data Command =
  | CMorphoAnalyse
  | CTestTokenizer
  | CComputeConcrete String
+ | CShowOpers String
 
  | CTranslationQuiz Language Language
  | CTranslationList Language Language Int
@@ -98,6 +99,7 @@ testValidFlag :: ShellState -> OptFunId -> String -> Err ()
 testValidFlag st f x = case f of
   "cat"     -> testIn (map prQIdent_ (allCategories st))
   "lang"    -> testIn (map prt (allLanguages st))
+  "res"     -> testIn (map prt (allResources (srcModules st)))
   "number"  -> testN
   "printer" -> testInc customGrammarPrinter
   "lexer"   -> testInc customTokenizer
@@ -143,6 +145,7 @@ optionsOfCommand co = case co of
   CMorphoAnalyse -> both "short" "lang"
   CTestTokenizer -> flags "lexer"
   CComputeConcrete _ -> flags "res"
+  CShowOpers _ -> flags "res"
 
   CTranslationQuiz _ _ -> flags "cat"
   CTranslationList _ _ _ ->  flags "cat"
diff --git a/src/HelpFile b/src/HelpFile
index 833d0c1f4..bd8b096ea 100644
--- a/src/HelpFile
+++ b/src/HelpFile
@@ -145,6 +145,17 @@ cc, compute_concrete: cc Term
   flags:
      -res      use another module than the topmost one
 
+so, show_operations: so Type
+      Show oper operations with the given value type. Uses the topmost 
+      resource module to resolve constant names. 
+      N.B. You need the flag -retain when importing the grammar, if you want 
+      the oper definitions to be retained after compilation; otherwise this
+      command does not find any oper constants.
+      N.B.' The value type may not be defined in a supermodule of the
+      topmost resource. In that case, use appropriate qualified name.
+  flags:
+     -res      use another module than the topmost one
+
 t,  translate: t Lang Lang String
       Parses String in Lang1 and linearizes the resulting Trees in Lang2.
   flags:
diff --git a/src/HelpFile.hs b/src/HelpFile.hs
index 59f2702b9..d397977e1 100644
--- a/src/HelpFile.hs
+++ b/src/HelpFile.hs
@@ -158,6 +158,17 @@ txtHelpFile =
   "\n  flags:" ++
   "\n     -res      use another module than the topmost one" ++
   "\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" ++
   "\nt,  translate: t Lang Lang String" ++
   "\n      Parses String in Lang1 and linearizes the resulting Trees in Lang2." ++
   "\n  flags:" ++