summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/GF.hs79
-rw-r--r--src/GF/API/IOGrammar.hs5
-rw-r--r--src/GF/Compile/ShellState.hs10
-rw-r--r--src/GF/GFModes.hs77
-rw-r--r--src/GF/Grammar/Lookup.hs296
-rw-r--r--src/GF/Grammar/PrGrammar.hs3
-rw-r--r--src/GF/Infra/Modules.hs3
-rw-r--r--src/GF/Infra/Option.hs3
-rw-r--r--src/GF/Shell.hs11
-rw-r--r--src/GF/Shell/PShell.hs8
-rw-r--r--src/GF/Shell/ShellCommands.hs3
-rw-r--r--src/HelpFile11
-rw-r--r--src/HelpFile.hs11
13 files changed, 187 insertions, 333 deletions
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:" ++
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 15:35:56 +0000