-- GenI surface realiser -- Copyright (C) 2005 Carlos Areces and Eric Kow -- -- This program is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License -- as published by the Free Software Foundation; either version 2 -- of the License, or (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- -- You should have received a copy of the GNU General Public License -- along with this program; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -- | The console user interface including batch processing on entire -- test suites. {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings #-} module NLP.GenI.Console ( consoleGeni, loadNextSuite ) where import Control.Applicative ( pure, (<$>) ) import Control.Monad import Data.IORef(readIORef, modifyIORef) import Data.List ( find, partition ) import Data.Maybe ( fromMaybe, isJust ) import Data.Text ( Text ) import Data.Time ( getCurrentTime, formatTime ) import Data.Typeable import System.Log.Logger import System.Locale ( defaultTimeLocale, iso8601DateFormat ) import System.Directory( createDirectoryIfMissing, getTemporaryDirectory ) import System.Exit ( exitWith, exitFailure, ExitCode(..) ) import System.FilePath ( (), takeFileName ) import System.IO ( stderr ) import System.Timeout ( timeout ) import qualified Data.ByteString as B import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Text.Encoding as T import NLP.GenI.General ( ePutStr, ePutStrLn, ) import NLP.GenI import NLP.GenI.Configuration ( Params , BatchDirFlg(..), DumpDerivationFlg(..), EarlyDeathFlg(..) , MetricsFlg(..), RankingConstraintsFlg(..) , TestCaseFlg(..), TestSuiteFlg(..), TestInstructionsFlg(..) , FromStdinFlg(..), OutputFileFlg(..), StatsFileFlg(..) , TimeoutFlg(..), VerboseModeFlg(..) , hasFlagP, getListFlagP, getFlagP, setFlagP , builderType , BuilderType(..) ) import NLP.GenI.General ( mkLogname ) import NLP.GenI.Pretty import NLP.GenI.Semantics ( SemInput ) import NLP.GenI.Simple.SimpleBuilder import NLP.GenI.TestSuite ( TestCase(..) ) import Text.JSON import Text.JSON.Pretty ( render, pp_value ) consoleGeni :: ProgStateRef -> IO() consoleGeni pstRef = do config <- pa <$> readIORef pstRef loadEverything pstRef let job | hasFlagP FromStdinFlg config = runStdinTestCase pstRef | hasFlagP BatchDirFlg config = runInstructions pstRef -- even if there is a testcase | Just tc <- getFlagP TestCaseFlg config = runSpecificTestCase pstRef tc | otherwise = runInstructions pstRef case getFlagP TimeoutFlg config of Nothing -> job Just t -> withGeniTimeOut t job withGeniTimeOut :: Int -- ^ seconds -> IO () -> IO () withGeniTimeOut t job = do status <- timeout (fromIntegral t * 1000000) job case status of Just () -> return () Nothing -> do ePutStrLn $ "GenI timed out after " ++ show t ++ "s" exitWith (ExitFailure 2) -- | Run GenI without reading any test suites, just grab semantics from stdin runStdinTestCase :: ProgStateRef -> IO () runStdinTestCase pstRef = do config <- pa <$> readIORef pstRef mSemInput <- parseSemInput <$> getContents case mSemInput of Left err -> fail $ "I didn't understand the semantics you gave me: " ++ show err Right semInput -> runOnSemInput pstRef (runAsStandalone config) semInput >> return () -- | Run a test case with the specified name runSpecificTestCase :: ProgStateRef -> Text -> IO () runSpecificTestCase pstRef cname = do config <- pa <$> readIORef pstRef fullsuite <- loadTestSuite pstRef case find (\x -> tcName x == cname) fullsuite of Nothing -> fail ("No such test case: " ++ T.unpack cname) Just s -> runOnSemInput pstRef (runAsStandalone config) (tcSem s) >> return () -- | Runs the tests specified in our instructions list. -- We assume that the grammar and lexicon are already -- loaded into the monadic state. -- If batch processing is enabled, save the results to the batch output -- directory with one subdirectory per suite and per case within that suite. runInstructions :: ProgStateRef -> IO () runInstructions pstRef = do pst <- readIORef pstRef let config = pa pst batchDir <- case getFlagP BatchDirFlg config of Nothing -> do t <- getTemporaryDirectory utc <- fmtTime <$> getCurrentTime return (t "geni-" ++ utc) Just bdir -> return bdir runBatch batchDir unless (hasFlagP BatchDirFlg config) $ do ePutStr $ unlines [ "" , "Results saved to directory " ++ batchDir , "To save results in a different directory, use the --batchdir flag" ] where fmtTime = formatTime defaultTimeLocale (iso8601DateFormat (Just "%H%M")) runBatch bdir = do config <- pa <$> readIORef pstRef mapM_ (runSuite bdir) $ getListFlagP TestInstructionsFlg config runSuite bdir next@(file, _) = do suite <- loadNextSuite pstRef next -- we assume the that the suites have unique filenames let bsubdir = bdir takeFileName file createDirectoryIfMissing True bsubdir if any (T.null . tcName) suite then fail $ "Can't do batch processing. The test suite " ++ file ++ " has cases with no name." else do ePutStrLn "Batch processing mode" mapM_ (runCase bsubdir) suite runCase bdir (TestCase { tcName = n, tcSem = s }) = do config <- pa `fmap` readIORef pstRef let verbose = hasFlagP VerboseModeFlg config earlyDeath = hasFlagP EarlyDeathFlg config when verbose $ ePutStrLn "======================================================" gresults <- runOnSemInput pstRef (PartOfSuite n bdir) s let res = grResults gresults (goodres, badres) = partition isSuccess (grResults gresults) T.hPutStrLn stderr $ " " <> n <+> "-" <+> pretty (length goodres) <+> "results" <+> parens (pretty (length badres)) when (null res && earlyDeath) $ do T.hPutStrLn stderr $ "Exiting early because test case" <+> n <+> "failed." exitFailure -- | Used in processing instructions files. Each instruction consists of a -- suite file and a list of test case names from that file -- -- See for -- how testsuite, testcase, and instructions are expected to interact -- -- (Exported for use by regression testing code) loadNextSuite :: ProgStateRef -> (FilePath, Maybe [Text]) -> IO [TestCase] loadNextSuite pstRef (file, mtcs) = do debugM logname $ "Loading next test suite: " ++ file debugM logname $ "Test case filter: " ++ maybe "none" (\xs -> show (length xs) ++ " items") mtcs modifyIORef pstRef $ \p -> p { pa = setFlagP TestSuiteFlg file (pa p) } -- yucky statefulness! :-( config <- pa `fmap` readIORef pstRef let mspecific = getFlagP TestCaseFlg config debugM logname . T.unpack $ "Test case to pick out:" <+> fromMaybe "none" mspecific fullsuite <- loadTestSuite pstRef return (filterSuite mtcs mspecific fullsuite) where filterSuite _ (Just c) suite = filter (\t -> tcName t == c) suite filterSuite Nothing Nothing suite = suite filterSuite (Just cs) Nothing suite = filter (\t -> tcName t `elem` cs) suite data RunAs = Standalone FilePath FilePath | PartOfSuite Text FilePath runAsStandalone :: Params -> RunAs runAsStandalone config = Standalone (fromMaybe "" $ getFlagP OutputFileFlg config) (fromMaybe "" $ getFlagP StatsFileFlg config) -- | Runs a case in the test suite. If the user does not specify any test -- cases, we run the first one. If the user specifies a non-existing -- test case we raise an error. runOnSemInput :: ProgStateRef -> RunAs -> SemInput -> IO GeniResults runOnSemInput pstRef args semInput = do pst <- readIORef pstRef case builderType (pa pst) of SimpleBuilder -> helper pst simpleBuilder_2p SimpleOnePhaseBuilder -> helper pst simpleBuilder_1p where helper pst builder = do (res,_) <- runGeni pstRef semInput builder writeResults pst args semInput res return res -- | Not just the global warnings but the ones local to each response too allWarnings :: GeniResults -> [Text] allWarnings res = concat $ grGlobalWarnings res : [ grWarnings s | GSuccess s <- grResults res ] writeResults :: ProgState -> RunAs -> SemInput -> GeniResults -> IO () writeResults pst args semInput gresults = do -- create output directory as needed case args of PartOfSuite n f -> createDirectoryIfMissing True (f T.unpack n) _ -> return () -- print responses if dump then writeResponses $ ppJSON results else writeResponses $ T.unlines . concatMap (fromResult formatResponses) $ results -- print out statistical data (if available) when (isJust $ getFlagP MetricsFlg config) $ writeStats (ppJSON stats) -- print any warnings we picked up along the way unless (null warnings) $ do T.hPutStrLn stderr $ "Warnings:\n" <> formatWarnings warnings writeBatchFile "warnings" $ T.unlines warnings -- other outputs when run in batch mode writeBatchFile "semantics" $ pretty semInput writeBatchFile "derivations"$ ppJSON results where results = grResults gresults warnings = allWarnings gresults stats = grStatistics gresults config = pa pst dump = hasFlagP DumpDerivationFlg config -- do we print ranking information and all that other jazz? formatResponses = if hasFlagP RankingConstraintsFlg config then pure . prettyResult pst else grRealisations formatWarnings = T.unlines . map (" - " <>) -- writeBatchFile key = case args of Standalone _ _ -> const (return ()) PartOfSuite n f -> writeFileUtf8 (f T.unpack n key) writeResponses = case args of Standalone "" _ -> putStrLnUtf8 Standalone f _ -> writeFileUtf8 f PartOfSuite _ _ -> writeBatchFile "responses" writeStats = case args of Standalone _ "" -> putStrLnUtf8 Standalone _ f -> writeFileUtf8 f PartOfSuite _ _ -> writeBatchFile "stats" -- fromResult :: (GeniSuccess -> [Text]) -> GeniResult -> [Text] fromResult _ (GError errs) = [ pretty errs ] fromResult f (GSuccess x) = f x -- | TODO: If somebody puts together a render function that emits Data.Text -- we should just use that instead ppJSON :: JSON a => a -> Text ppJSON = T.pack . render . pp_value . showJSON writeFileUtf8 :: FilePath -> Text -> IO () writeFileUtf8 f = B.writeFile f . T.encodeUtf8 putStrLnUtf8 :: Text -> IO () putStrLnUtf8 = B.putStr . T.encodeUtf8 . (<> "\n") -- ---------------------------------------------------------------------- -- Odds and ends -- ---------------------------------------------------------------------- data MNAME = MNAME deriving Typeable logname :: String logname = mkLogname MNAME