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
| 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
-> 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 :: 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 ()
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 ()
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
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
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) }
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)
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
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
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 $ getFlagP MetricsFlg config) $
writeStats (ppJSON stats)
unless (null warnings) $ do
T.hPutStrLn stderr $ "Warnings:\n" <> formatWarnings warnings
writeBatchFile "warnings" $ T.unlines warnings
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
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
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