module NLP.GenI.Console ( consoleGeni, loadNextSuite ) where
import Control.Applicative (pure, (<$>))
import Control.Monad
import Control.Monad.Trans.Error
import qualified Data.ByteString as B
import Data.IORef (modifyIORef, readIORef)
import Data.List (find, partition)
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import Data.Time (formatTime, getCurrentTime)
import Data.Typeable
import System.Directory
import System.Exit
import System.FilePath (takeFileName, (</>))
import System.IO (stderr)
import System.Locale
import System.Timeout (timeout)
import System.Log.Logger
import Text.JSON
import Text.JSON.Pretty (pp_value, render)
import NLP.GenI
import NLP.GenI.Configuration
import NLP.GenI.General (ePutStr, ePutStrLn)
import NLP.GenI.General (mkLogname)
import NLP.GenI.GeniShow
import NLP.GenI.LexicalSelection
import NLP.GenI.Pretty
import NLP.GenI.Simple.SimpleBuilder
import NLP.GenI.TestSuite (TestCase (..))
consoleGeni :: ProgStateRef -> CustomSem sem -> IO()
consoleGeni pstRef wrangler = do
config <- pa <$> readIORef pstRef
loadEverything pstRef wrangler
pst <- readIORef pstRef
let job | hasFlag FromStdinFlg config = runStdinTestCase pst wrangler
| hasFlag BatchDirFlg config = runInstructions pstRef wrangler
| Just tc <- getFlag TestCaseFlg config = runSpecificTestCase pst wrangler tc
| otherwise = runInstructions pstRef wrangler
case getFlag TimeoutFlg config of
Nothing -> job
Just t -> withGeniTimeOut t job
withGeniTimeOut :: Int
-> 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)
runStdinTestCase :: ProgState -> CustomSem sem -> IO ()
runStdinTestCase pst wrangler = do
let config = pa pst
cstr <- T.getContents
case customSemParser wrangler cstr of
Left err ->
fail $ "I didn't understand the semantics you gave me: " ++ show err
Right tc ->
runOnSemInput pst (runAsStandalone config) wrangler tc >> return ()
runSpecificTestCase :: ProgState -> CustomSem sem -> Text -> IO ()
runSpecificTestCase pst wrangler cname = do
let config = pa pst
fullsuite <- loadTestSuite pst wrangler
case find (\x -> tcName x == cname) fullsuite of
Nothing ->
fail $ "No such test case: " ++ T.unpack cname
Just tc ->
runOnSemInput pst (runAsStandalone config) wrangler tc >> return ()
runInstructions :: ProgStateRef -> CustomSem sem -> IO ()
runInstructions pstRef wrangler = do
pst <- readIORef pstRef
batchDir <- case getFlag BatchDirFlg pst of
Nothing -> do
t <- getTemporaryDirectory
utc <- fmtTime <$> getCurrentTime
return (t </> "geni-" ++ utc)
Just bdir -> return bdir
runBatch batchDir
unless (hasFlag BatchDirFlg pst) $ 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
pst <- readIORef pstRef
let instructions = getListFlag TestInstructionsFlg pst
mapM_ (runSuite bdir) instructions
runSuite bdir next@(file, _) = do
suite <- loadNextSuite pstRef wrangler next
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 tc = do
pst <- readIORef pstRef
let verbose = hasFlag VerboseModeFlg pst
earlyDeath = hasFlag EarlyDeathFlg pst
when verbose $
ePutStrLn "======================================================"
gresults <- runOnSemInput pst (PartOfSuite (tcName tc) bdir) wrangler tc
let res = grResults gresults
T.hPutStrLn stderr $ summary tc gresults
when (null res && earlyDeath) $ do
T.hPutStrLn stderr $ "Exiting early because test case" <+> tcName tc <+> "failed."
exitFailure
summary tc gresults =
" " <> tcName tc <+> "-" <+> pretty (length goodres) <+> "results" <+>
(if null badres then "" else parens (pretty (length badres) <+> "failures"))
where
(goodres, badres) = partition isSuccess (grResults gresults)
loadNextSuite :: ProgStateRef
-> CustomSem sem
-> (FilePath, Maybe [Text])
-> IO [TestCase sem]
loadNextSuite pstRef wrangler (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 (setFlag TestSuiteFlg file)
pst <- readIORef pstRef
let mspecific = getFlag TestCaseFlg pst
debugM logname . T.unpack $ "Test case to pick out:" <+> fromMaybe "none" mspecific
fullsuite <- loadTestSuite pst wrangler
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 "" $ getFlag OutputFileFlg config)
(fromMaybe "" $ getFlag StatsFileFlg config)
runOnSemInput :: ProgState
-> RunAs
-> CustomSem sem
-> TestCase sem
-> IO GeniResults
runOnSemInput pst args wrangler tc = do
case getBuilderType (pa pst) of
SimpleBuilder -> helper simpleBuilder_2p
SimpleOnePhaseBuilder -> helper simpleBuilder_1p
where
csem = tcSem tc
cstr = tcSemString tc
helper builder = do
res <- simplifyResults <$> (runErrorT $ runGeni pst wrangler builder tc)
writeResults pst args wrangler cstr csem res
return res
allWarnings :: GeniResults -> [Text]
allWarnings res = concat
$ grGlobalWarnings res
: [ grWarnings s | GSuccess s <- grResults res ]
writeResults :: ProgState
-> RunAs
-> CustomSem sem
-> Text
-> sem
-> GeniResults -> IO ()
writeResults pst args wrangler cstr csem gresults = do
case args of
PartOfSuite n f -> createDirectoryIfMissing True (f </> T.unpack n)
_ -> return ()
if dump
then writeResponses $ ppJSON results
else writeResponses $ T.unlines . concatMap (fromResult formatResponses) $ results
when (isJust $ getFlag MetricsFlg pst) $
writeStats (ppJSON stats)
unless (null warnings) $ do
T.hPutStrLn stderr $ "Warnings:\n" <> formatWarnings warnings
writeBatchFile "warnings" $ T.unlines warnings
writeBatchFile "raw-semantics" cstr
writeBatchFile "custom-semantics" $
customRenderSem wrangler csem
writeBatchFile "semantics" $
either ("ERROR:" <+>) geniShowText $
fromCustomSemInput wrangler csem
writeBatchFile "derivations"$ ppJSON results
where
results = grResults gresults
warnings = allWarnings gresults
stats = grStatistics gresults
dump = hasFlag DumpDerivationFlg pst
formatResponses = if isNothing (ranking (pa pst))
then grRealisations
else pure . prettyResult pst
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
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")
data MNAME = MNAME deriving Typeable
logname :: String
logname = mkLogname MNAME