diff options
Diffstat (limited to 'src-3.0/GF/Shell/Commands.hs')
| -rw-r--r-- | src-3.0/GF/Shell/Commands.hs | 568 |
1 files changed, 568 insertions, 0 deletions
diff --git a/src-3.0/GF/Shell/Commands.hs b/src-3.0/GF/Shell/Commands.hs new file mode 100644 index 000000000..8699c2fe7 --- /dev/null +++ b/src-3.0/GF/Shell/Commands.hs @@ -0,0 +1,568 @@ +---------------------------------------------------------------------- +-- | +-- Module : Commands +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/10/06 10:02:33 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.42 $ +-- +-- temporary hacks for GF 2.0 +-- +-- Abstract command language for syntax editing. AR 22\/8\/2001. +-- Most arguments are strings, to make it easier to receive them from e.g. Java. +-- See "CommandsL" for a parser of a command language. +----------------------------------------------------------------------------- + +module GF.Shell.Commands where + +import GF.Data.Operations +import GF.Data.Zipper + +import qualified GF.Grammar.Grammar as G ---- Cat, Fun, Q, QC +import GF.Canon.GFC +import GF.Canon.CMacros +import GF.Grammar.Macros (qq)---- +import GF.Grammar.LookAbs +import GF.Canon.Look +import GF.Grammar.Values (loc2treeFocus,tree2exp)---- + +import GF.UseGrammar.GetTree +import GF.API +import GF.Compile.ShellState + +import qualified GF.Shell as Shell +import qualified GF.Shell.PShell as PShell +import qualified GF.Grammar.Macros as M +import GF.Grammar.PrGrammar +import GF.Compile.PGrammar +import GF.API.IOGrammar +import GF.Infra.UseIO +import GF.Text.Unicode + +import GF.CF.CF +import GF.CF.CFIdent (cat2CFCat, cfCat2Cat) +import GF.CF.PPrCF (prCFCat) +import GF.UseGrammar.Linear +import GF.UseGrammar.Randomized +import GF.UseGrammar.Editing +import GF.UseGrammar.Session +import GF.UseGrammar.Custom + +import qualified GF.Infra.Ident as I +import GF.Infra.Option +import GF.Data.Str (sstr) ---- +import GF.Text.UTF8 ---- + +import System.Random (StdGen, mkStdGen, newStdGen) +import Control.Monad (liftM2, foldM) +import Data.List (intersperse) + +--- temporary hacks for GF 2.0 + +-- Abstract command language for syntax editing. AR 22/8/2001 +-- Most arguments are strings, to make it easier to receive them from e.g. Java. +-- See CommandsL for a parser of a command language. + +data Command = + CNewCat String + | CNewTree String + | CAhead Int + | CBack Int + | CNextMeta + | CPrevMeta + | CTop + | CLast + | CMovePosition [Int] + | CCopyPosition [Int] [Int] + | CRefineWithTree String + | CRefineWithClip Int + | CRefineWithAtom String + | CRefineParse String + | CWrapWithFun (String,Int) + | CChangeHead String + | CPeelHead (String,Int) + | CAlphaConvert String + | CRefineRandom + | CSelectCand Int + | CTermCommand String + | CAddOption Option + | CRemoveOption Option + | CDelete + | CAddClip + | CRemoveClip Int + | CUndo Int + | 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\> + + | CCEnvImport String -- ^ |-- commands affecting 'CEnv' + | CCEnvEmptyAndImport String -- ^ | + | CCEnvOpenTerm String -- ^ | + | CCEnvOpenString String -- ^ | + | CCEnvEmpty -- ^ | + + | CCEnvOn String -- ^ | + | CCEnvOff String -- ^ | + + | CCEnvGFShell String -- ^ |========== + + | CCEnvRefineWithTree String -- ^ |-- other commands using 'IO' + | CCEnvRefineParse String -- ^ | + | CCEnvSave String FilePath -- ^ |========== + +isQuit :: Command -> Bool +isQuit CQuit = True +isQuit _ = False + +-- | an abstract environment type +type CEnv = ShellState + +grammarCEnv :: CEnv -> StateGrammar +grammarCEnv = firstStateGrammar + +canCEnv :: CEnv -> CanonGrammar +canCEnv = canModules + +concreteCEnv, abstractCEnv :: StateGrammar -> I.Ident +concreteCEnv = cncId +abstractCEnv = absId + +stdGenCEnv :: CEnv -> SState -> StdGen +stdGenCEnv env s = mkStdGen (length (displayJustStateIn env s) * 31 +11) --- + +initSStateEnv :: CEnv -> SState +initSStateEnv env = case getOptVal (stateOptions sgr) gStartCat of + Just cat -> action2commandNext (newCat gr (abs, I.identC cat)) initSState + _ -> initSState + where + sgr = firstStateGrammar env + abs = absId sgr + 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 -> useIOE (env,s) $ do + st <- shellStateFromFiles optss env file + return (st,s) + + CCEnvEmptyAndImport file -> useIOE (emptyShellState, initSState) $ do + st <- shellStateFromFiles optss emptyShellState file + return (startEditEnv st,initSState) + + CCEnvEmpty -> do + return (startEditEnv emptyShellState, initSState) + + CCEnvGFShell command -> do + let hs = Shell.initHState env + let cs = PShell.pCommandLines hs command + (msg,(env',_)) <- Shell.execLines False cs hs + return (env', changeMsg msg s) ---- + + CCEnvOpenTerm file -> do + c <- readFileIf file + let (fs,t) = envAndTerm file c +---- (env',_) <- execCommand env (CCEnvGFShell fs) s --TODO; next deprec +---- env' <- useIOE env $ foldM (shellStateFromFiles noOptions) env fs + let env' = env ---- + return (env', execECommand env' (CNewTree t) s) + + CCEnvOpenString file -> do + c <- readFileIf file + let (fs,t) = envAndTerm file c +---- (env',_) <- execCommand env (CCEnvGFShell fs) s --TODO; next deprec +---- env' <- useIOE env $ foldM (shellStateFromFiles noOptions) env fs + let env' = env ---- + return (env', execECommand env' (CRefineParse t) s) + + CCEnvOn name -> return (languageOn (language name) env,s) + CCEnvOff name -> return (languageOff (language name) env,s) + + CCEnvSave lang file -> do + let str = optLinearizeTreeVal opts (stateGrammarOfLang env (language lang)) $ treeSState s + writeFile file str + let msg = ["wrote file" +++ file] + return (env,changeMsg msg 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 + optss = addOption beSilent opts + + -- format for documents: + -- GF commands of form "-- command", then term or text + envAndTerm f s = + (unwords (intersperse ";;" 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 + cat' <- string2cat sgr cat + 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 + CMovePosition p -> action2command $ goPosition p + 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 (f,i) -> action2commandKeep $ wrapWithFun cgr (qualif f, i) + CChangeHead f -> action2commandKeep $ changeFunHead cgr (qualif f) + CPeelHead (f,i) -> action2commandKeep $ peelFunHead cgr (qualif f,i) + + CAlphaConvert s -> action2commandKeep $ \x -> + string2varPair s >>= \xy -> alphaConvert cgr xy x + + CRefineWithTree s -> action2commandNext $ \x -> + (string2treeInState gr s x >>= + \t -> refineWithTree der cgr t x) + CRefineWithClip i -> \s -> + let et = getNumberedClip i s + in (case et of + Ok t -> refineByTrees der cgr [t] s + Bad m -> changeMsg [m] s) + CCopyPosition p q -> action2command $ \s -> do + s1 <- goPosition p s + let t = actTree s1 + s2 <- goPosition q s1 + let compat = actVal s1 == actVal s2 + if compat + then refineWithTree der cgr t s2 + else return s + + CRefineParse str -> \s -> + let cat = cat2CFCat (qualifTop sgr (actCat (stateSState s))) + ts = parseAny agrs cat str + in (if null ts ---- debug + then withMsg ["parse failed in cat" +++ prCFCat cat] + else id) + (refineByTrees der cgr ts) s + + CRefineRandom -> \s -> action2commandNext + (refineRandom (stdGenCEnv env s) 41 cgr) s + + CSelectCand i -> selectCand cgr i + + CTermCommand c -> case c of + "reindex" -> \s -> + replaceByTermCommand der gr c (actTree (stateSState s)) s + "paraphrase" -> \s -> + replaceByTermCommand der gr c (actTree (stateSState s)) s +---- "transfer" -> action2commandNext $ +---- transferSubTree (stateTransferFun sgr) gr + "generate" -> \s -> + replaceByTermCommand der gr c (actTree (stateSState s)) s + _ -> replaceByEditCommand gr c + + CAddOption o -> changeStOptions (addOption o) + CRemoveOption o -> changeStOptions (removeOption o) + CDelete -> action2commandKeep $ deleteSubTree cgr + CAddClip -> \s -> (addtoClip (actTree (stateSState s))) s + CRemoveClip n -> \s -> (removeClip n) s + CUndo n -> undoCommand n + 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 = 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 + abs = absId sgr + qualif = string2Fun gr + +-- + + +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'" + + +startEditEnv :: CEnv -> CEnv +startEditEnv env = addGlobalOptions (options [sizeDisplay "short"]) env + +-- | seen on display +cMenuDisplay :: String -> Command +cMenuDisplay s = CAddOption (menuDisplay s) + +newCatMenu :: CEnv -> [(Command, String)] +newCatMenu env = [(CNewCat (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 (prQIdent_ f, i), prWrap "w" "Wrap" fit) + | fit@((f,i),_) <- wraps] ++ + [(CChangeHead (prQIdent_ f), prChangeHead f) + | f <- headChangesState cgr state] ++ + [(CPeelHead (prQIdent_ f, i), prPeel "ph" "PeelHead" fi) + | fi@(f,i) <- peelingsState cgr state] ++ + [(CDelete, (ifShort "d" "Delete", "d"))] ++ + [(CAddClip, (ifShort "ac" "AddClip", "ac"))] + (refs,[],_) -> + [(CRefineWithAtom (prRefinement f), prRef t) | t@(f,_) <- refs] ++ + [(CRefineWithClip i, prClip i t) | (i,t) <- possClipsSState gr sstate] + (_,cands,_) -> + [(CSelectCand i, prCand (t,i)) | (t,i) <- zip cands [0..]] + + where + prRef (f,(t,_)) = + (ifShort "r" "Refine" +++ prOrLinRef f +++ ifTyped (":" +++ prt_ t), + "r" +++ prRefinement f) + prClip i t = + (ifShort "rc" "Paste" +++ prOrLinTree t, + "rc" +++ show i) + prChangeHead f = + (ifShort "ch" "ChangeHead" +++ prOrLinFun f, + "ch" +++ prQIdent_ f) + prWrap sh lg ((f,i),t) = + (ifShort sh lg +++ prOrLinFun f +++ ifTyped (":" +++ prt t) +++ + ifShort (show i) (prBracket (show i)), + sh +++ prQIdent_ f +++ show i) + prPeel sh lg (f,i) = + (ifShort sh lg +++ prOrLinFun f +++ + ifShort (show i) (prBracket (show i)), + sh +++ 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 = err (const $ prt_ t) prOrLinTree $ annotateInState cgr t state + prOrLinRef t = case t of + G.Q m f -> printname env sstate (m,f) + G.QC m f -> printname env sstate (m,f) + _ -> prt_ t + prOrLinFun = printname env sstate + prOrLinTree t = case getOptVal opts menuDisplay of + Just "Abs" -> prt_ $ tree2exp t ---- prTermOpt opts $ tree2exp t + Just lang -> prQuotedString $ lin lang t + _ -> prTermOpt opts $ tree2exp t + lin lang t = optLinearizeTreeVal opts (stateGrammarOfLang env (language lang)) t + +-- there are three orthogonal parameters: Abs/[conc], short/long, typed/untyped +-- the default is Abs, long, untyped; the Menus menu changes the parameter + +emptyMenuItem :: (Command, (String, String)) +emptyMenuItem = (CVoid,("","")) + + + +---- allStringCommands = snd $ customInfo customStringCommand +termCommandMenu :: [(Command,String)] +termCommandMenu = [(CTermCommand s, s) | s <- allTermCommands] + +allTermCommands :: [String] +allTermCommands = snd $ customInfo customEditCommand + +stringCommandMenu :: [(Command,String)] +stringCommandMenu = [] + +displayCommandMenu :: CEnv -> [(Command,String)] +displayCommandMenu env = + [(CAddOption (menuDisplay s), s) | s <- "Abs" : langs] ++ + [(CAddOption (sizeDisplay s), s) | s <- ["short", "long"]] ++ + [(fo nostripQualif, s) | (fo,s) <- [(CAddOption,"qualified"), + (CRemoveOption,"unqualified")]] ++ + [(CAddOption (typeDisplay s), s) | s <- ["typed", "untyped"]] + where + langs = map prLanguage $ allLanguages env + +{- ---- + +stringCommandMenu = + (CAddOption showStruct, "structured") : + (CRemoveOption showStruct, "unstructured") : + [(CAddOption (filterString s), s) | s <- allStringCommands] +-} + +changeMenuLanguage, changeMenuSize, changeMenuTyped :: String -> Command +changeMenuLanguage s = CAddOption (menuDisplay s) +changeMenuSize s = CAddOption (sizeDisplay s) +changeMenuTyped s = CAddOption (typeDisplay s) + +menuState :: CEnv -> SState -> [String] +menuState env = map snd . mkRefineMenu env + +prState :: State -> [String] +prState s = prMarkedTree (loc2treeMarked s) + +displayJustStateIn :: CEnv -> SState -> String +displayJustStateIn env state = case displaySStateIn env state of + (t,msg,_) -> unlines (t ++ ["",""] ++ msg) --- ad hoc for CommandF + +displaySStateIn :: CEnv -> SState -> ([String],[String],[(String,String)]) +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) -- state opts override + (addOption (markLin markOptFocus) (globalOptions env)) + 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 '*'] + +-- | the Boolean is a temporary hack to have two parallel GUIs +displaySStateJavaX :: Bool -> CEnv -> SState -> String -> String +displaySStateJavaX isNew env state m = encodeUTF8 $ mkUnicode $ + unlines $ tagXML "gfedit" $ concat [ + if null m then [] else tagXML "hmsg" [m], + 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" [unicode s] ++ tagXML "send" [c] | (s,c) <- menu] + (ls,grs) = unzip $ lgrs + lgrs = allActiveStateGrammarsWithNames env + lins = (langAbstract, exp) : linAll + opts = addOptions (optsSState state) -- state opts override + (addOption (markLin mark) (globalOptions env)) + lin (n,gr) = (n, map uni $ linearizeState noWrap opts gr zipper) where + uni = optDecodeUTF8 gr + exp = prprTree $ loc2tree zipper + zipper = stateSState state + linAll = map lin lgrs + gr = firstStateGrammar env + mark = markOptXML -- markOptJava + + unicode = case getOptVal opts menuDisplay of + Just lang -> optDecodeUTF8 (stateGrammarOfLang env (language lang)) + _ -> id + +-- | the env is UTF8 if the display language is +-- +-- should be independent +isCEnvUTF8 :: CEnv -> SState -> Bool +isCEnvUTF8 env st = maybe False id $ do + lang <- getOptVal opts menuDisplay + co <- getOptVal (stateOptions (stateGrammarOfLang env (language lang))) uniCoding + return $ co == "utf8" + where + opts = addOptions (optsSState st) (globalOptions env) + +langAbstract, langXML :: I.Ident +langAbstract = language "Abstract" +langXML = language "XML" + +linearizeState :: (String -> [String]) -> Options -> GFGrammar -> State -> [String] +linearizeState wrap opts gr = + wrap . strop . unt . optLinearizeTreeVal opts gr . loc2treeFocus + + where + unt = customOrDefault (stateOptions gr) useUntokenizer customUntokenizer gr + strop = maybe id ($ gr) $ 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 = if null cs then [("[NO ALTERNATIVE]","")] else cs + where + cs = [(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 ---- prTermOpt opts (qq f) + where + opts = addOptions (optsSState state) (globalOptions env) + printn lang f = err id (ifNull (prQIdent_ f) (sstr . head)) $ do + t <- lookupPrintname gr mf + strsFromTerm t + where + sgr = stateGrammarOfLang env (language lang) + gr = grammar sgr + mf = ciq (cncId sgr) (snd f) + +-- * XML printing; does not belong here! + +tagsXML :: String -> [[String]] -> [String] +tagsXML t = concatMap (tagXML t) + +tagAttrXML :: String -> (String, String) -> [String] -> [String] +tagAttrXML t av ss = mkTagAttrXML t av : map (indent 2) ss ++ [mkEndTagXML t] + +tagXML :: String -> [String] -> [String] +tagXML t ss = mkTagXML t : map (indent 2) ss ++ [mkEndTagXML t] + +mkTagXML :: String -> String +mkTagXML t = '<':t ++ ">" + +mkEndTagXML :: String -> String +mkEndTagXML t = mkTagXML ('/':t) + +mkTagAttrsXML :: String -> [(String, String)] -> String +mkTagAttrsXML t avs = '<':t +++ unwords [a++"="++v | (a,v) <- avs] ++">" + +mkTagAttrXML :: String -> (String, String) -> String +mkTagAttrXML t av = mkTagAttrsXML t [av] + |