diff options
Diffstat (limited to 'src/GF/Shell/Commands.hs')
| -rw-r--r-- | src/GF/Shell/Commands.hs | 568 |
1 files changed, 0 insertions, 568 deletions
diff --git a/src/GF/Shell/Commands.hs b/src/GF/Shell/Commands.hs deleted file mode 100644 index 8699c2fe7..000000000 --- a/src/GF/Shell/Commands.hs +++ /dev/null @@ -1,568 +0,0 @@ ----------------------------------------------------------------------- --- | --- 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] - |