mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
285 lines
12 KiB
Haskell
285 lines
12 KiB
Haskell
-- | Commands that work in any type of environment, either because they don't
|
|
-- use the PGF, or because they are just documented here and implemented
|
|
-- elsewhere
|
|
module GF.Command.CommonCommands where
|
|
import Data.List(sort)
|
|
import Data.Char (isSpace)
|
|
import GF.Command.CommandInfo
|
|
import qualified Data.Map as Map
|
|
import GF.Infra.SIO
|
|
import GF.Infra.UseIO(writeUTF8File)
|
|
import GF.Infra.Option(renameEncoding)
|
|
import GF.System.Console(changeConsoleEncoding)
|
|
import GF.System.Process
|
|
import GF.Command.Abstract --(isOpt,valStrOpts,prOpt)
|
|
import GF.Text.Pretty
|
|
import GF.Text.Transliterations
|
|
import GF.Text.Lexing(stringOp,opInEnv)
|
|
import Data.Char (isSpace)
|
|
|
|
import qualified PGF as H(showCId,showExpr,toATree,toTrie,Trie(..))
|
|
|
|
extend old new = Map.union (Map.fromList new) old -- Map.union is left-biased
|
|
|
|
commonCommands :: (Monad m,MonadSIO m) => Map.Map String (CommandInfo m)
|
|
commonCommands = fmap (mapCommandExec liftSIO) $ Map.fromList [
|
|
("!", emptyCommandInfo {
|
|
synopsis = "system command: escape to system shell",
|
|
syntax = "! SYSTEMCOMMAND",
|
|
examples = [
|
|
("! ls *.gf", "list all GF files in the working directory")
|
|
]
|
|
}),
|
|
("?", emptyCommandInfo {
|
|
synopsis = "system pipe: send value from previous command to a system command",
|
|
syntax = "? SYSTEMCOMMAND",
|
|
examples = [
|
|
("gt | l | ? wc", "generate, linearize, word-count")
|
|
]
|
|
}),
|
|
("dc", emptyCommandInfo {
|
|
longname = "define_command",
|
|
syntax = "dc IDENT COMMANDLINE",
|
|
synopsis = "define a command macro",
|
|
explanation = unlines [
|
|
"Defines IDENT as macro for COMMANDLINE, until IDENT gets redefined.",
|
|
"A call of the command has the form %IDENT. The command may take an",
|
|
"argument, which in COMMANDLINE is marked as ?0. Both strings and",
|
|
"trees can be arguments. Currently at most one argument is possible.",
|
|
"This command must be a line of its own, and thus cannot be a part",
|
|
"of a pipe."
|
|
]
|
|
}),
|
|
("dt", emptyCommandInfo {
|
|
longname = "define_tree",
|
|
syntax = "dt IDENT (TREE | STRING | \"<\" COMMANDLINE)",
|
|
synopsis = "define a tree or string macro",
|
|
explanation = unlines [
|
|
"Defines IDENT as macro for TREE or STRING, until IDENT gets redefined.",
|
|
"The defining value can also come from a command, preceded by \"<\".",
|
|
"If the command gives many values, the first one is selected.",
|
|
"A use of the macro has the form %IDENT. Currently this use cannot be",
|
|
"a subtree of another tree. This command must be a line of its own",
|
|
"and thus cannot be a part of a pipe."
|
|
],
|
|
examples = [
|
|
mkEx ("dt ex \"hello world\" -- define ex as string"),
|
|
mkEx ("dt ex UseN man_N -- define ex as string"),
|
|
mkEx ("dt ex < p -cat=NP \"the man in the car\" -- define ex as parse result"),
|
|
mkEx ("l -lang=LangSwe %ex | ps -to_utf8 -- linearize the tree ex")
|
|
]
|
|
}),
|
|
("e", emptyCommandInfo {
|
|
longname = "empty",
|
|
synopsis = "empty the environment"
|
|
}),
|
|
("eh", emptyCommandInfo {
|
|
longname = "execute_history",
|
|
syntax = "eh FILE",
|
|
synopsis = "read commands from a file and execute them"
|
|
}),
|
|
("ph", emptyCommandInfo {
|
|
longname = "print_history",
|
|
synopsis = "print command history",
|
|
explanation = unlines [
|
|
"Prints the commands issued during the GF session.",
|
|
"The result is readable by the eh command.",
|
|
"The result can be used as a script when starting GF."
|
|
],
|
|
examples = [
|
|
mkEx "ph | wf -file=foo.gfs -- save the history into a file"
|
|
]
|
|
}),
|
|
("ps", emptyCommandInfo {
|
|
longname = "put_string",
|
|
syntax = "ps OPT? STRING",
|
|
synopsis = "return a string, possibly processed with a function",
|
|
explanation = unlines [
|
|
"Returns a string obtained from its argument string by applying",
|
|
"string processing functions in the order given in the command line",
|
|
"option list. Thus 'ps -f -g s' returns g (f s). Typical string processors",
|
|
"are lexers and unlexers, but also character encoding conversions are possible.",
|
|
"The unlexers preserve the division of their input to lines.",
|
|
"To see transliteration tables, use command ut."
|
|
],
|
|
examples = [
|
|
-- mkEx "l (EAdd 3 4) | ps -code -- linearize code-like output",
|
|
mkEx "l (EAdd 3 4) | ps -unlexcode -- linearize code-like output",
|
|
-- mkEx "ps -lexer=code | p -cat=Exp -- parse code-like input",
|
|
mkEx "ps -lexcode | p -cat=Exp -- parse code-like input",
|
|
mkEx "gr -cat=QCl | l | ps -bind -- linearization output from LangFin",
|
|
mkEx "ps -to_devanagari \"A-p\" -- show Devanagari in UTF8 terminal",
|
|
mkEx "rf -file=Hin.gf | ps -env=quotes -to_devanagari -- convert translit to UTF8",
|
|
mkEx "rf -file=Ara.gf | ps -from_utf8 -env=quotes -from_arabic -- convert UTF8 to transliteration",
|
|
mkEx "ps -to=chinese.trans \"abc\" -- apply transliteration defined in file chinese.trans",
|
|
mkEx "ps -lexgreek \"a)gavoi` a)'nvrwpoi' tines*\" -- normalize ancient greek accentuation"
|
|
],
|
|
exec = \opts x-> do
|
|
let (os,fs) = optsAndFlags opts
|
|
trans <- optTranslit opts
|
|
|
|
case opts of
|
|
_ | isOpt "lines" opts -> return $ fromStrings $ map (trans . stringOps (envFlag fs) (map prOpt os)) $ toStrings x
|
|
_ | isOpt "paragraphs" opts -> return $ fromStrings $ map (trans . stringOps (envFlag fs) (map prOpt os)) $ toParagraphs $ toStrings x
|
|
_ -> return ((fromString . trans . stringOps (envFlag fs) (map prOpt os) . toString) x),
|
|
options = [
|
|
("lines","apply the operation separately to each input line, returning a list of lines"),
|
|
("paragraphs","apply separately to each input paragraph (as separated by empty lines), returning a list of lines")
|
|
] ++
|
|
stringOpOptions,
|
|
flags = [
|
|
("env","apply in this environment only"),
|
|
("from","backward-apply transliteration defined in this file (format 'unicode translit' per line)"),
|
|
("to", "forward-apply transliteration defined in this file")
|
|
]
|
|
}),
|
|
("q", emptyCommandInfo {
|
|
longname = "quit",
|
|
synopsis = "exit GF interpreter"
|
|
}),
|
|
("r", emptyCommandInfo {
|
|
longname = "reload",
|
|
synopsis = "repeat the latest import command"
|
|
}),
|
|
|
|
("se", emptyCommandInfo {
|
|
longname = "set_encoding",
|
|
synopsis = "set the encoding used in current terminal",
|
|
syntax = "se ID",
|
|
examples = [
|
|
mkEx "se cp1251 -- set encoding to cp1521",
|
|
mkEx "se utf8 -- set encoding to utf8 (default)"
|
|
],
|
|
needsTypeCheck = False,
|
|
exec = \ opts ts ->
|
|
case words (toString ts) of
|
|
[c] -> do let cod = renameEncoding c
|
|
restricted $ changeConsoleEncoding cod
|
|
return void
|
|
_ -> return (pipeMessage "se command not parsed")
|
|
}),
|
|
("sp", emptyCommandInfo {
|
|
longname = "system_pipe",
|
|
synopsis = "send argument to a system command",
|
|
syntax = "sp -command=\"SYSTEMCOMMAND\", alt. ? SYSTEMCOMMAND",
|
|
exec = \opts arg -> do
|
|
let syst = optComm opts -- ++ " " ++ tmpi
|
|
{-
|
|
let tmpi = "_tmpi" ---
|
|
let tmpo = "_tmpo"
|
|
restricted $ writeFile tmpi $ toString arg
|
|
restrictedSystem $ syst ++ " <" ++ tmpi ++ " >" ++ tmpo
|
|
fmap fromString $ restricted $ readFile tmpo,
|
|
-}
|
|
fmap (fromStrings . lines) . restricted . readShellProcess syst . unlines . map (dropWhile (=='\n')) $ toStrings $ arg,
|
|
|
|
flags = [
|
|
("command","the system command applied to the argument")
|
|
],
|
|
examples = [
|
|
mkEx "gt | l | ? wc -- generate trees, linearize, and count words"
|
|
]
|
|
}),
|
|
("tt", emptyCommandInfo {
|
|
longname = "to_trie",
|
|
syntax = "to_trie",
|
|
synopsis = "combine a list of trees into a trie",
|
|
exec = \ _ -> return . fromString . trie . toExprs
|
|
}),
|
|
("ut", emptyCommandInfo {
|
|
longname = "unicode_table",
|
|
synopsis = "show a transliteration table for a unicode character set",
|
|
exec = \opts _ -> do
|
|
let t = concatMap prOpt (take 1 opts)
|
|
let out = maybe "no such transliteration" characterTable $ transliteration t
|
|
return $ fromString out,
|
|
options = transliterationPrintNames
|
|
}),
|
|
("wf", emptyCommandInfo {
|
|
longname = "write_file",
|
|
synopsis = "send string or tree to a file",
|
|
exec = \opts arg-> do
|
|
let file = valStrOpts "file" "_gftmp" opts
|
|
if isOpt "append" opts
|
|
then restricted $ appendFile file (toLines arg)
|
|
else restricted $ writeUTF8File file (toLines arg)
|
|
return void,
|
|
options = [
|
|
("append","append to file, instead of overwriting it")
|
|
],
|
|
flags = [("file","the output filename")]
|
|
})
|
|
]
|
|
where
|
|
optComm opts = valStrOpts "command" "" opts
|
|
|
|
optTranslit opts = case (valStrOpts "to" "" opts, valStrOpts "from" "" opts) of
|
|
("","") -> return id
|
|
(file,"") -> do
|
|
src <- restricted $ readFile file
|
|
return $ transliterateWithFile file src False
|
|
(_,file) -> do
|
|
src <- restricted $ readFile file
|
|
return $ transliterateWithFile file src True
|
|
|
|
stringOps menv opts s = foldr (menvop . app) s (reverse opts)
|
|
where
|
|
app f = maybe id id (stringOp (const False) f)
|
|
menvop op = maybe op (\ (b,e) -> opInEnv b e op) menv
|
|
|
|
envFlag fs =
|
|
case valStrOpts "env" "global" fs of
|
|
"quotes" -> Just ("\"","\"")
|
|
_ -> Nothing
|
|
|
|
stringOpOptions = sort $ [
|
|
("bind","bind tokens separated by Prelude.BIND, i.e. &+"),
|
|
("chars","lexer that makes every non-space character a token"),
|
|
("from_cp1251","decode from cp1251 (Cyrillic used in Bulgarian resource)"),
|
|
("from_utf8","decode from utf8 (default)"),
|
|
("lextext","text-like lexer"),
|
|
("lexcode","code-like lexer"),
|
|
("lexmixed","mixture of text and code, as in LaTeX (code between $...$, \\(...)\\, \\[...\\])"),
|
|
("lexgreek","lexer normalizing ancient Greek accentuation"),
|
|
("lexgreek2","lexer normalizing ancient Greek accentuation for text with vowel length annotations"),
|
|
("to_cp1251","encode to cp1251 (Cyrillic used in Bulgarian resource)"),
|
|
("to_html","wrap in a html file with linebreaks"),
|
|
("to_utf8","encode to utf8 (default)"),
|
|
("unlextext","text-like unlexer"),
|
|
("unlexcode","code-like unlexer"),
|
|
("unlexmixed","mixture of text and code (code between $...$, \\(...)\\, \\[...\\])"),
|
|
("unchars","unlexer that puts no spaces between tokens"),
|
|
("unlexgreek","unlexer de-normalizing ancient Greek accentuation"),
|
|
("unwords","unlexer that puts a single space between tokens (default)"),
|
|
("words","lexer that assumes tokens separated by spaces (default)")
|
|
] ++
|
|
concat [
|
|
[("from_" ++ p, "from unicode to GF " ++ n ++ " transliteration"),
|
|
("to_" ++ p, "from GF " ++ n ++ " transliteration to unicode")] |
|
|
(p,n) <- transliterationPrintNames]
|
|
|
|
trie = render . pptss . H.toTrie . map H.toATree
|
|
where
|
|
pptss [ts] = "*"<+>nest 2 (ppts ts)
|
|
pptss tss = vcat [i<+>nest 2 (ppts ts)|(i,ts)<-zip [(1::Int)..] tss]
|
|
|
|
ppts = vcat . map ppt
|
|
|
|
ppt t =
|
|
case t of
|
|
H.Oth e -> pp (H.showExpr [] e)
|
|
H.Ap f [[]] -> pp (H.showCId f)
|
|
H.Ap f tss -> H.showCId f $$ nest 2 (pptss tss)
|
|
|
|
-- ** Converting command input
|
|
toString = unwords . toStrings
|
|
toLines = unlines . toStrings
|
|
|
|
toParagraphs = map (unwords . words) . toParas
|
|
where
|
|
toParas ls = case break (all isSpace) ls of
|
|
([],[]) -> []
|
|
([],_:ll) -> toParas ll
|
|
(l, []) -> [unwords l]
|
|
(l, _:ll) -> unwords l : toParas ll
|