From d53f8e0644ba06fab84e09db8d0d5c13082e23f9 Mon Sep 17 00:00:00 2001 From: aarne Date: Wed, 1 Oct 2008 16:01:51 +0000 Subject: [PATCH] added mode 'gf --run' for running silently a script ; made quizzes handle character encoding correctly ; for this end, collected coding functions in GF.Text.Coding --- src/GF.hs | 1 + src/GF/Command/Commands.hs | 33 ++++++++++--------- src/GF/Command/Interpreter.hs | 4 +-- src/GF/Compile.hs | 10 ++++-- src/GF/Infra/Option.hs | 3 +- src/GF/Text/Coding.hs | 14 ++++++++ src/GFI.hs | 60 +++++++++++++++++++++-------------- src/PGF/Quiz.hs | 20 +++++++----- 8 files changed, 93 insertions(+), 52 deletions(-) create mode 100644 src/GF/Text/Coding.hs diff --git a/src/GF.hs b/src/GF.hs index 5b1776987..de288df10 100644 --- a/src/GF.hs +++ b/src/GF.hs @@ -37,5 +37,6 @@ mainOpts opts files = ModeVersion -> putStrLn $ "Grammatical Framework (GF) version " ++ showVersion version ModeHelp -> putStrLn helpMessage ModeInteractive -> mainGFI opts files + ModeRun -> mainRunGFI opts files ModeCompiler -> dieIOE (mainGFC opts files) diff --git a/src/GF/Command/Commands.hs b/src/GF/Command/Commands.hs index 31c3ec652..baeb6ba41 100644 --- a/src/GF/Command/Commands.hs +++ b/src/GF/Command/Commands.hs @@ -28,6 +28,7 @@ import GF.Text.Lexing import GF.Text.Transliterations import GF.Data.Operations +import GF.Text.Coding import Data.Maybe import qualified Data.Map as Map @@ -63,10 +64,10 @@ emptyCommandInfo = CommandInfo { lookCommand :: String -> Map.Map String CommandInfo -> Maybe CommandInfo lookCommand = Map.lookup -commandHelpAll :: (String -> String) -> PGF -> [Option] -> String -commandHelpAll enc pgf opts = unlines +commandHelpAll :: String -> PGF -> [Option] -> String +commandHelpAll cod pgf opts = unlines [commandHelp (isOpt "full" opts) (co,info) - | (co,info) <- Map.assocs (allCommands enc pgf)] + | (co,info) <- Map.assocs (allCommands cod pgf)] commandHelp :: Bool -> (String,CommandInfo) -> String commandHelp full (co,info) = unlines $ [ @@ -82,8 +83,8 @@ commandHelp full (co,info) = unlines $ [ ] else [] -- this list must no more be kept sorted by the command name -allCommands :: (String -> String) -> PGF -> Map.Map String CommandInfo -allCommands enc pgf = Map.fromList [ +allCommands :: String -> PGF -> Map.Map String CommandInfo +allCommands cod pgf = Map.fromList [ ("cc", emptyCommandInfo { longname = "compute_concrete", syntax = "cc (-all | -table | -unqual)? TERM", @@ -206,10 +207,10 @@ allCommands enc pgf = Map.fromList [ _ | isOpt "coding" opts -> codingMsg _ | isOpt "license" opts -> licenseMsg [t] -> let co = getCommandOp (showTree t) in - case lookCommand co (allCommands enc pgf) of ---- new map ??!! + case lookCommand co (allCommands cod pgf) of ---- new map ??!! Just info -> commandHelp True (co,info) _ -> "command not found" - _ -> commandHelpAll enc pgf opts + _ -> commandHelpAll cod pgf opts in return (fromString msg) }), ("i", emptyCommandInfo { @@ -253,6 +254,7 @@ allCommands enc pgf = Map.fromList [ exec = \opts -> return . fromStrings . map (optLin opts), options = [ ("all","show all forms and variants"), + ("multi","linearize to all languages (default)"), ("record","show source-code-like record"), ("table","show all forms labelled by parameters"), ("term", "show PGF term"), @@ -282,7 +284,7 @@ allCommands enc pgf = Map.fromList [ exec = \opts _ -> do let lang = optLang opts let cat = optCat opts - morphologyQuiz pgf lang cat + morphologyQuiz cod pgf lang cat return void, flags = [ ("lang","language of the quiz"), @@ -402,7 +404,7 @@ allCommands enc pgf = Map.fromList [ let from = valIdOpts "from" (optLang opts) opts let to = valIdOpts "to" (optLang opts) opts let cat = optCat opts - translationQuiz pgf from to cat + translationQuiz cod pgf from to cat return void, flags = [ ("from","translate from this language"), @@ -507,6 +509,7 @@ allCommands enc pgf = Map.fromList [ }) ] where + enc = encodeUnicode cod lin opts t = unlines [linearize pgf lang t | lang <- optLangs opts] par opts s = concat [parse pgf lang (optCat opts) s | lang <- optLangs opts] @@ -616,15 +619,15 @@ stringOpOptions = [ ("words","lexer that assumes tokens separated by spaces (default)") ] -translationQuiz :: PGF -> Language -> Language -> Category -> IO () -translationQuiz pgf ig og cat = do +translationQuiz :: String -> PGF -> Language -> Language -> Category -> IO () +translationQuiz cod pgf ig og cat = do tts <- translationList pgf ig og cat infinity - mkQuiz "Welcome to GF Translation Quiz." tts + mkQuiz cod "Welcome to GF Translation Quiz." tts -morphologyQuiz :: PGF -> Language -> Category -> IO () -morphologyQuiz pgf ig cat = do +morphologyQuiz :: String -> PGF -> Language -> Category -> IO () +morphologyQuiz cod pgf ig cat = do tts <- morphologyList pgf ig cat infinity - mkQuiz "Welcome to GF Morphology Quiz." tts + mkQuiz cod "Welcome to GF Morphology Quiz." tts -- | the maximal number of precompiled quiz problems infinity :: Int diff --git a/src/GF/Command/Interpreter.hs b/src/GF/Command/Interpreter.hs index f4e3e220d..eff6e8b58 100644 --- a/src/GF/Command/Interpreter.hs +++ b/src/GF/Command/Interpreter.hs @@ -28,11 +28,11 @@ data CommandEnv = CommandEnv { expmacros :: Map.Map String Tree } -mkCommandEnv :: (String -> String) -> PGF -> CommandEnv +mkCommandEnv :: String -> PGF -> CommandEnv mkCommandEnv enc pgf = CommandEnv pgf (allCommands enc pgf) Map.empty Map.empty emptyCommandEnv :: CommandEnv -emptyCommandEnv = mkCommandEnv encodeUTF8 emptyPGF +emptyCommandEnv = mkCommandEnv "utf8" emptyPGF interpretCommandLine :: (String -> String) -> CommandEnv -> String -> IO () interpretCommandLine enc env line = diff --git a/src/GF/Compile.hs b/src/GF/Compile.hs index 5d5081541..289bdd92b 100644 --- a/src/GF/Compile.hs +++ b/src/GF/Compile.hs @@ -52,12 +52,16 @@ compileToPGF opts fs = link opts name gr link :: Options -> String -> SourceGrammar -> IOE PGF -link opts cnc gr = - do gc1 <- putPointE Normal opts "linking ... " $ +link opts cnc gr = do + let isv = (verbAtLeast opts Normal) + gc1 <- putPointE Normal opts "linking ... " $ let (abs,gc0) = mkCanon2gfcc opts cnc gr in case checkPGF gc0 of Ok (gc,b) -> do - ioeIO $ putStrLn $ if b then "OK" else "Corrupted PGF" + case (isv,b) of + (True, True) -> ioeIO $ putStrLn "OK" + (False,True) -> return () + _ -> ioeIO $ putStrLn $ "Corrupted PGF" return gc Bad s -> fail s return $ buildParser opts $ optimize opts gc1 diff --git a/src/GF/Infra/Option.hs b/src/GF/Infra/Option.hs index 8e8d44aff..10b5dcd21 100644 --- a/src/GF/Infra/Option.hs +++ b/src/GF/Infra/Option.hs @@ -68,7 +68,7 @@ errors = fail . unlines -- Types -data Mode = ModeVersion | ModeHelp | ModeInteractive | ModeCompiler +data Mode = ModeVersion | ModeHelp | ModeInteractive | ModeRun | ModeCompiler deriving (Show,Eq,Ord) data Verbosity = Quiet | Normal | Verbose | Debug @@ -413,6 +413,7 @@ optDescr = Option ['q','s'] ["quiet"] (NoArg (verbosity (Just "0"))) "Quiet, same as -v 0.", Option [] ["batch"] (NoArg (mode ModeCompiler)) "Run in batch compiler mode.", Option [] ["interactive"] (NoArg (mode ModeInteractive)) "Run in interactive mode (default).", + Option [] ["run"] (NoArg (mode ModeRun)) "Run in interactive mode, showing output only (no other messages).", Option ['E'] [] (NoArg (phase Preproc)) "Stop after preprocessing (with --preproc).", Option ['C'] [] (NoArg (phase Convert)) "Stop after conversion to .gf.", Option ['c'] [] (NoArg (phase Compile)) "Stop after compiling to .gfo (default) .", diff --git a/src/GF/Text/Coding.hs b/src/GF/Text/Coding.hs new file mode 100644 index 000000000..47aaa5cb5 --- /dev/null +++ b/src/GF/Text/Coding.hs @@ -0,0 +1,14 @@ +module GF.Text.Coding where + +import GF.Text.UTF8 +import GF.Text.CP1251 + +encodeUnicode e = case e of + "utf8" -> encodeUTF8 + "cp1251" -> encodeCP1251 + _ -> id + +decodeUnicode e = case e of + "utf8" -> decodeUTF8 + "cp1251" -> decodeCP1251 + _ -> id diff --git a/src/GFI.hs b/src/GFI.hs index 04c4c5d75..03fbb184f 100644 --- a/src/GFI.hs +++ b/src/GFI.hs @@ -1,4 +1,4 @@ -module GFI (mainGFI) where +module GFI (mainGFI,mainRunGFI) where import GF.Command.Interpreter import GF.Command.Importing @@ -11,8 +11,7 @@ import GF.Infra.UseIO import GF.Infra.Option import GF.System.Readline -import GF.Text.UTF8 ---- -import GF.Text.CP1251 +import GF.Text.Coding import PGF import PGF.Data @@ -28,10 +27,17 @@ import System.CPUTime import Control.Exception import Data.Version import GF.System.Signal - +--import System.IO.Error (try) import Paths_gf +mainRunGFI :: Options -> [FilePath] -> IO () +mainRunGFI opts files = do + let opts1 = addOptions (modifyFlags (\f -> f{optVerbosity=Quiet})) opts + gfenv <- importInEnv emptyGFEnv opts1 files + loop opts1 gfenv + return () + mainGFI :: Options -> [FilePath] -> IO () mainGFI opts files = do putStrLn welcome @@ -39,17 +45,25 @@ mainGFI opts files = do loop opts gfenv return () -loopNewCPU gfenv' = do - cpu' <- getCPUTime - putStrLnFlush (show ((cpu' - cputime gfenv') `div` 1000000000) ++ " msec") - return $ gfenv' {cputime = cpu'} +loopOptNewCPU opts gfenv' + | not (verbAtLeast opts Normal) = return gfenv' + | otherwise = do + cpu' <- getCPUTime + putStrLnFlush (show ((cpu' - cputime gfenv') `div` 1000000000) ++ " msec") + return $ gfenv' {cputime = cpu'} loop :: Options -> GFEnv -> IO GFEnv loop opts gfenv0 = do + let loopNewCPU = loopOptNewCPU opts + let isv = verbAtLeast opts Normal + let ifv act = if isv then act else return () let env = commandenv gfenv0 let sgr = sourcegrammar gfenv0 setCompletionFunction (Just (wordCompletion gfenv0)) - s0 <- fetchCommand (prompt env) + let fetch = case flag optMode opts of + ModeRun -> tryGetLine + _ -> fetchCommand (prompt env) + s0 <- fetch let gfenv = gfenv0 {history = s0 : history gfenv0} let enc = encode gfenv @@ -62,7 +76,7 @@ loop opts gfenv0 = do case pwords of - "q":_ -> putStrLn "See you." >> return gfenv + "q":_ -> ifv (putStrLn "See you.") >> return gfenv _ -> do r <- runInterruptibly $ case pwords of @@ -132,8 +146,16 @@ importInEnv gfenv opts files do let opts' = addOptions (setOptimization OptCSE False) opts pgf0 = multigrammar (commandenv gfenv) pgf1 <- importGrammar pgf0 opts' files - putStrLnFlush $ unwords $ "\nLanguages:" : languages pgf1 - return $ gfenv { commandenv = mkCommandEnv (encode gfenv) pgf1 } + if (verbAtLeast opts Normal) + then putStrLnFlush $ unwords $ "\nLanguages:" : languages pgf1 + else return () + return $ gfenv { commandenv = mkCommandEnv (coding gfenv) pgf1 } + +tryGetLine = do + res <- try getLine + case res of + Left e -> return "q" + Right l -> return l welcome = unlines [ " ", @@ -168,18 +190,10 @@ data GFEnv = GFEnv { } emptyGFEnv :: GFEnv -emptyGFEnv = GFEnv emptyGrammar (mkCommandEnv encodeUTF8 emptyPGF) [] 0 "utf8" - -encode env = case coding env of - "utf8" -> encodeUTF8 - "cp1251" -> encodeCP1251 - _ -> id - -decode env = case coding env of - "utf8" -> decodeUTF8 - "cp1251" -> decodeCP1251 - _ -> id +emptyGFEnv = GFEnv emptyGrammar (mkCommandEnv "utf8" emptyPGF) [] 0 "utf8" +encode = encodeUnicode . coding +decode = decodeUnicode . coding wordCompletion gfenv line0 prefix0 p = case wc_type (take p line) of diff --git a/src/PGF/Quiz.hs b/src/PGF/Quiz.hs index 7f5bae201..096930f46 100644 --- a/src/PGF/Quiz.hs +++ b/src/PGF/Quiz.hs @@ -23,6 +23,7 @@ import PGF.ShowLinearize import GF.Data.Operations import GF.Infra.UseIO +import GF.Text.Coding import System.Random @@ -32,9 +33,9 @@ import Data.List (nub) -- generic quiz function -mkQuiz :: String -> [(String,[String])] -> IO () -mkQuiz msg tts = do - let qas = [ (q, mkAnswer as) | (q,as) <- tts] +mkQuiz :: String -> String -> [(String,[String])] -> IO () +mkQuiz cod msg tts = do + let qas = [ (q, mkAnswer cod as) | (q,as) <- tts] teachDialogue qas msg translationList :: @@ -57,11 +58,14 @@ morphologyList pgf ig cat number = do (pws,i) <- zip ss forms, let (par,ws) = pws !! i] -- | compare answer to the list of right answers, increase score and give feedback -mkAnswer :: [String] -> String -> (Integer, String) -mkAnswer as s = if (elem (norml s) as) - then (1,"Yes.") - else (0,"No, not" +++ s ++ ", but" ++++ unlines as) +mkAnswer :: String -> [String] -> String -> (Integer, String) +mkAnswer cod as s = + if (elem (norm s) as) + then (1,"Yes.") + else (0,"No, not" +++ s ++ ", but" ++++ enc (unlines as)) + where + norm = unwords . words . decodeUnicode cod + enc = encodeUnicode cod -norml :: String -> String norml = unwords . words