summaryrefslogtreecommitdiff
path: root/src/GF/Shell/Commands.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/GF/Shell/Commands.hs')
-rw-r--r--src/GF/Shell/Commands.hs443
1 files changed, 443 insertions, 0 deletions
diff --git a/src/GF/Shell/Commands.hs b/src/GF/Shell/Commands.hs
new file mode 100644
index 000000000..5c92c7bd6
--- /dev/null
+++ b/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]
+
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 07:02:08 +0000