From 46f85fb13a569e27863565b4ec99800038e3fd68 Mon Sep 17 00:00:00 2001 From: aarne Date: Wed, 29 Dec 2004 13:48:41 +0000 Subject: [PATCH] command cm --- src/GF/Compile/ShellState.hs | 15 +++++++----- src/GF/Shell.hs | 44 +++++++++++++++++++++-------------- src/GF/Shell/PShell.hs | 2 ++ src/GF/Shell/ShellCommands.hs | 3 ++- 4 files changed, 39 insertions(+), 25 deletions(-) diff --git a/src/GF/Compile/ShellState.hs b/src/GF/Compile/ShellState.hs index 34224e641..ae80af572 100644 --- a/src/GF/Compile/ShellState.hs +++ b/src/GF/Compile/ShellState.hs @@ -210,12 +210,14 @@ purgeShellState sh = ShSt { changeMain :: Maybe Ident -> ShellState -> Err ShellState changeMain Nothing (ShSt _ _ cs ms ss cfs pis mos os rs acs s) = - return (ShSt Nothing Nothing cs ms ss cfs pis mos os rs acs s) -changeMain (Just c) (ShSt _ _ cs ms ss cfs pis mos os rs acs s) = - case lookup c (map fst cs) of - Just i -> do - a <- M.abstractOfConcrete ms i - return (ShSt (Just a) (Just i) cs ms ss cfs pis mos os rs acs s) + return (ShSt Nothing Nothing [] ms ss cfs pis mos os rs acs s) +changeMain (Just c) st@(ShSt _ _ cs ms ss cfs pis mos os rs acs s) = + case lookup c (M.modules ms) of + Just _ -> do + a <- M.abstractOfConcrete ms c + let cas = M.allConcretes ms a + let cs' = [((c,c),True) | c <- cas] + return (ShSt (Just a) (Just c) cs' ms ss cfs pis mos os rs acs s) _ -> P.prtBad "The state has no concrete syntax named" c -- form just one state grammar, if unique, from a canonical grammar @@ -385,6 +387,7 @@ getLangNameOpt opts file = -- modify state type ShellStateOper = ShellState -> ShellState +type ShellStateOperErr = ShellState -> Err ShellState reinitShellState :: ShellStateOper reinitShellState = const emptyShellState diff --git a/src/GF/Shell.hs b/src/GF/Shell.hs index 4d0d9b879..a02357b92 100644 --- a/src/GF/Shell.hs +++ b/src/GF/Shell.hs @@ -102,8 +102,9 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = checkOptions st co >> case comm of CImport file -> useIOE sa $ do st1 <- shellStateFromFiles opts st file ioeIO $ changeState (const st1) sa --- \ ((_,h),a) -> ((st,h), a)) - CEmptyState -> changeState reinitShellState sa - CStripState -> changeState purgeShellState sa + CEmptyState -> changeState reinitShellState sa + CChangeMain ma -> changeStateErr (changeMain ma) sa + CStripState -> changeState purgeShellState sa {- CRemoveLanguage lan -> changeState (removeLanguage lan) sa @@ -173,7 +174,7 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = checkOptions st co >> case comm of 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 (prt . stripTerm) ( + justOutput opts (putStrLn (err id (prt . stripTerm) ( string2srcTerm src m t >>= Ch.justCheckLTerm src >>= Co.computeConcrete src))) sa @@ -182,7 +183,7 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = checkOptions st co >> case comm of 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) ( + justOutput opts (putStrLn (err id (unlines . map prOperSignature) ( string2srcTerm src m t >>= Co.computeConcrete src >>= return . L.opersForType src))) sa @@ -190,7 +191,7 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = checkOptions st co >> case comm of CTranslationQuiz il ol -> do warnDiscont opts - justOutput (teachTranslation opts (sgr il) (sgr ol)) sa + justOutput opts (teachTranslation opts (sgr il) (sgr ol)) sa CTranslationList il ol n -> do warnDiscont opts qs <- transTrainList opts (sgr il) (sgr ol) (toInteger n) @@ -198,17 +199,17 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = checkOptions st co >> case comm of CMorphoQuiz -> do warnDiscont opts - justOutput (teachMorpho opts gro) sa + justOutput opts (teachMorpho opts gro) sa CMorphoList n -> do warnDiscont opts qs <- useIOE [] $ morphoTrainList opts gro (toInteger n) returnArg (AString $ foldr (+++++) [] [unlines (s:ss) | (s,ss) <- qs]) sa CReadFile file -> returnArgIO (readFileIf file >>= return . AString) sa - CWriteFile file -> justOutputArg (writeFile file) sa - CAppendFile file -> justOutputArg (appendFile file) sa - CSpeakAloud -> justOutputArg (speechGenerate opts) sa - CSystemCommand s -> justOutput (system s >> return ()) sa + CWriteFile file -> justOutputArg opts (writeFile file) sa + CAppendFile file -> justOutputArg opts (appendFile file) sa + CSpeakAloud -> justOutputArg opts (speechGenerate opts) sa + CSystemCommand s -> justOutput opts (system s >> return ()) sa CPutString -> changeArg (opSS2CommandArg (optStringCommand opts gro)) sa ----- CShowTerm -> changeArg (opTS2CommandArg (optPrintTerm opts gro) . s2t) sa @@ -222,9 +223,9 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = checkOptions st co >> case comm of _ -> returnArg (AString txtHelpFileSummary) sa CPrintGrammar -> returnArg (AString (optPrintGrammar opts gro)) sa - CPrintGlobalOptions -> justOutput (putStrLn $ prShellStateInfo st) sa - CPrintInformation c -> justOutput (useIOE () $ showInformation opts st c) sa - CPrintLanguages -> justOutput + CPrintGlobalOptions -> justOutput opts (putStrLn $ prShellStateInfo st) sa + CPrintInformation c -> justOutput opts (useIOE () $ showInformation opts st c) sa + CPrintLanguages -> justOutput opts (putStrLn $ unwords $ map prLanguage $ allLanguages st) sa CPrintMultiGrammar -> do sa' <- changeState purgeShellState sa @@ -235,7 +236,7 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = checkOptions st co >> case comm of ---- CPrintGramlet -> returnArg (AString (Gr.prGramlet st)) sa ---- CPrintCanonXML -> returnArg (AString (Canon.prCanonXML st False)) sa ---- CPrintCanonXMLStruct -> returnArg (AString (Canon.prCanonXML st True)) sa - _ -> justOutput (putStrLn "command not understood") sa + _ -> justOutput opts (putStrLn "command not understood") sa where sgr = stateGrammarOfLang st @@ -264,6 +265,11 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = checkOptions st co >> case comm of changeState :: ShellStateOper -> ShellIO changeState f ((st,h),a) = return ((f st,h), a) +changeStateErr :: ShellStateOperErr -> ShellIO +changeStateErr f ((st,h),a) = case f st of + Ok st' -> return ((st',h), a) + Bad s -> return ((st, h),AError s) + changeArg :: (CommandArg -> CommandArg) -> ShellIO changeArg f (st,a) = return (st, f a) @@ -279,11 +285,13 @@ returnArg = changeArg . const returnArgIO :: IO CommandArg -> ShellIO returnArgIO io (st,_) = io >>= (\a -> return (st,a)) -justOutputArg :: (String -> IO ()) -> ShellIO -justOutputArg f sa@(st,a) = f (prCommandArg a) >> return (st, AUnit) +justOutputArg :: Options -> (String -> IO ()) -> ShellIO +justOutputArg opts f sa@(st,a) = f (utf (prCommandArg a)) >> return (st, AUnit) + where + utf = if (oElem useUTF8 opts) then encodeUTF8 else id -justOutput :: IO () -> ShellIO -justOutput = justOutputArg . const +justOutput :: Options -> IO () -> ShellIO +justOutput opts = justOutputArg opts . const -- type system for command arguments; instead of plain strings... diff --git a/src/GF/Shell/PShell.hs b/src/GF/Shell/PShell.hs index ff447fc6d..dd62067f2 100644 --- a/src/GF/Shell/PShell.hs +++ b/src/GF/Shell/PShell.hs @@ -68,6 +68,8 @@ pCommand ws = case ws of "i" : f : [] -> aUnit (CImport f) "rl" : l : [] -> aUnit (CRemoveLanguage (language l)) "e" : [] -> aUnit CEmptyState + "cm" : a : [] -> aUnit (CChangeMain (Just (pzIdent a))) + "cm" : [] -> aUnit (CChangeMain Nothing) "s" : [] -> aUnit CStripState "tg" : f : [] -> aUnit (CTransformGrammar f) "cl" : f : [] -> aUnit (CConvertLatex f) diff --git a/src/GF/Shell/ShellCommands.hs b/src/GF/Shell/ShellCommands.hs index e30b8010b..a3e5d3b94 100644 --- a/src/GF/Shell/ShellCommands.hs +++ b/src/GF/Shell/ShellCommands.hs @@ -20,6 +20,7 @@ data Command = CImport FilePath | CRemoveLanguage Language | CEmptyState + | CChangeMain (Maybe I.Ident) | CStripState | CTransformGrammar FilePath | CConvertLatex FilePath @@ -161,7 +162,7 @@ optionsOfCommand co = case co of CWriteFile _ -> none CAppendFile _ -> none CSpeakAloud -> flags "language" - CPutString -> flags "filter length" + CPutString -> both "utf8" "filter length" CShowTerm -> flags "printer" CSystemCommand _ -> none