diff --git a/Mueval/ArgsParse.hs b/Mueval/ArgsParse.hs --- a/Mueval/ArgsParse.hs +++ b/Mueval/ArgsParse.hs @@ -1,8 +1,6 @@ module Mueval.ArgsParse (Options(..), interpreterOpts, getOptions) where -import Control.Monad (liftM) import System.Console.GetOpt -import System.Environment (getArgs) import qualified Codec.Binary.UTF8.String as Codec (decodeString) @@ -63,16 +61,14 @@ (NoArg (\opts -> opts { rlimits = True})) "Enable resource limits (using POSIX rlimits). Mueval does not by default since rlimits are broken on many systems." ] -interpreterOpts :: [String] -> IO (Options, [String]) +interpreterOpts :: [String] -> (Options, [String]) interpreterOpts argv = case getOpt Permute options argv of - (o,n,[]) -> return (foldl (flip id) defaultOptions o, n) - (_,_,er) -> ioError $ userError (concat er ++ usageInfo header options) + (o,n,[]) -> (foldl (flip id) defaultOptions o, n) + (_,_,er) -> error (concat er ++ usageInfo header options) where header = "Usage: mueval [OPTION...] --expression EXPRESSION..." --- | Just give us the end result options; this handles I/O and parsing for --- us. Bonus points for handling UTF. -getOptions :: IO Options -getOptions = do input <- liftM (map Codec.decodeString) getArgs - (opts,_) <- interpreterOpts $ input - return opts +-- | Just give us the end result options; this parsing for +-- us. Bonus points for handling UTF. +getOptions :: [String] -> Options +getOptions = fst . interpreterOpts . map Codec.decodeString diff --git a/Mueval/Context.hs b/Mueval/Context.hs --- a/Mueval/Context.hs +++ b/Mueval/Context.hs @@ -10,7 +10,7 @@ -- | Return false if any of the listed modules cannot be found in the whitelist. cleanModules :: [String] -> Bool -cleanModules = and . map (`elem` defaultModules) +cleanModules = all (`elem` defaultModules) {- | Modules which we should load by default. These are of course whitelisted. Specifically, we want the Prelude because otherwise things are horribly diff --git a/Mueval/Interpreter.hs b/Mueval/Interpreter.hs --- a/Mueval/Interpreter.hs +++ b/Mueval/Interpreter.hs @@ -7,12 +7,10 @@ import System.Exit (exitFailure) import System.FilePath.Posix (takeFileName) import qualified Control.OldException as E (evaluate,catch) - -import Language.Haskell.Extension(Extension(ExtendedDefaultRules)) import Language.Haskell.Interpreter (eval, set, reset, setImportsQ, loadModules, liftIO, installedModulesInScope, languageExtensions, typeOf, setTopLevelModules, runInterpreter, glasgowExtensions, - OptionVal(..), + OptionVal(..), Extension(ExtendedDefaultRules), Interpreter, InterpreterError(..),GhcError(..), ModuleName) import qualified Mueval.Resources (limitResources) import qualified Mueval.Context (qualifiedModules) @@ -20,14 +18,15 @@ import Control.Monad.Writer (Any(..),runWriterT,tell) import Data.List (stripPrefix) import Data.Char (isDigit) +import Control.Monad.Trans {- | The actual calling of Hint functionality. The heart of this just calls 'eval', but we do so much more - we disable Haskell extensions, hide all packages, make sure one cannot call unimported - functions, typecheck (and optionally print it), set resource limits for this + functions, typecheck, set resource limits for this thread, and do some error handling. -} -interpreter :: Bool -> Bool -> Bool -> Maybe [ModuleName] -> String -> String -> Interpreter () -interpreter prt exts rlimits modules lfl expr = do +interpreter :: Bool -> Bool -> Maybe [ModuleName] -> String -> String -> Interpreter (String,String,String) +interpreter exts rlimits modules lfl expr = do when exts $ set [languageExtensions := (ExtendedDefaultRules:glasgowExtensions)] reset -- Make sure nothing is available @@ -39,12 +38,10 @@ liftIO $ Mueval.Resources.limitResources rlimits - when doload $ do - let lfl' = takeFileName lfl + when doload $ do let lfl' = takeFileName lfl loadModules [lfl'] -- We need to mangle the String to - -- turn a filename into a - -- module + -- turn a filename into a module. setTopLevelModules [(takeWhile (/='.') lfl')] case modules of @@ -52,17 +49,15 @@ Just ms -> do let unqualModules = zip ms (repeat Nothing) setImportsQ (unqualModules ++ Mueval.Context.qualifiedModules) - when prt $ say expr -- we don't check if the expression typechecks -- this way we get an "InterpreterError" we can display - when prt $ say =<< typeOf expr + etype <- typeOf expr result <- eval expr - - say $ result - + return (expr, etype, result) + -- | Wrapper around 'interpreter'; supplies a fresh GHC API session and --- error-handling. The arguments are simply passed on. +-- error-handling. The arguments are largely passed on, and the results lightly parsed. interpreterSession :: Bool -- ^ Whether to print inferred type -> Bool -- ^ Whether to use GHC extensions -> Bool -- ^ Whether to use rlimits @@ -70,14 +65,13 @@ -> String -- ^ A local file from which to grab definitions; an -- empty string is treated as no file. -> String -- ^ The string to be interpreted as a Haskell expression - -> IO () -- ^ No real result, since printing is done deeper in - -- the stack. -interpreterSession prt exts rls mds lfl expr = do r <- runInterpreter (interpreter prt exts rls mds lfl expr) - case r of - Left err -> printInterpreterError err - Right () -> return () - - + -> IO () -- ^ No real result, since we print no matter the result. +interpreterSession prt exts rls mds lfl expr = do r <- runInterpreter (interpreter exts rls mds lfl expr) + case r of + Left err -> printInterpreterError err + Right (e,et,val) -> do when prt $ (sayIO e >> sayIO et) + sayIO val + mvload :: FilePath -> IO () mvload lfl = do canonfile <- makeRelativeToCurrentDirectory lfl liftIO $ copyFile canonfile $ "/tmp/" ++ takeFileName canonfile @@ -85,16 +79,13 @@ --------------------------------- -- Handling and outputting results --- | From inside the Interpreter monad, print the String (presumably the result +-- | Print the String (presumably the result -- of interpreting something), but only print the first 1024 characters to avoid -- flooding. Lambdabot has a similar limit. -say :: String -> Interpreter () -say = liftIO . sayIO - sayIO :: String -> IO () sayIO str = do (out,b) <- render 1024 str UTF.putStrLn out - when b $ exitFailure + when b exitFailure -- | Oh no, something has gone wrong. If it's a compilation error pretty print -- the first 1024 chars of it and throw an "ExitException" @@ -111,7 +102,7 @@ | Just s <- parseErr e = s | otherwise = e -- if the parse fails we fallback on printing the whole error parseErr e = do s <- stripPrefix ":" e - skipSpaces =<<(skipNumber =<< skipNumber s) + skipSpaces =<< (skipNumber =<< skipNumber s) skip x (y:xs) | x == y = Just xs | otherwise = Nothing skip _ _ = Nothing @@ -127,10 +118,11 @@ exceptionMsg :: String exceptionMsg = "* Exception: " --- | renders the input String including its exceptions using @exceptionMsg@ -render :: Int -- ^ max number of characters to include - -> String -- ^ input - -> IO (String, Bool) -- ^ ( output, @True@ if we found an exception ) +-- | Renders the input String including its exceptions using @exceptionMsg@ +render :: (Control.Monad.Trans.MonadIO m) => + Int -> -- ^ max number of characters to include + String -> -- ^ input + m (String, Bool) -- ^ ( output, @True@ if we found an exception ) render i xs = do (out,Any b) <- runWriterT $ render' i (toStream xs) return (out,b) diff --git a/Mueval/Parallel.hs b/Mueval/Parallel.hs --- a/Mueval/Parallel.hs +++ b/Mueval/Parallel.hs @@ -1,7 +1,7 @@ module Mueval.Parallel where import Prelude hiding (catch) -import Control.Concurrent (forkIO, killThread, myThreadId, threadDelay, throwTo, yield, ThreadId) +import Control.Concurrent (forkIO, killThread, myThreadId, threadDelay, throwTo, ThreadId) import System.Posix.Signals (sigXCPU, installHandler, Handler(CatchOnce)) import Control.OldException (Exception(ErrorCall),catch) import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar, MVar) @@ -18,11 +18,10 @@ forkIO $ do threadDelay (tout * 700000) -- Time's up. It's a good day to die. throwTo tid (ErrorCall "Time limit exceeded") - yield -- give the other thread a chance killThread tid -- Die now, srsly. error "Time expired" - return () -- Never reached. Either we error out in - -- watchDog, or the evaluation thread finishes. + return () -- Never reached. Either we error out here + -- or the evaluation thread finishes. -- | A basic blocking operation. block :: (t -> MVar a -> IO t1) -> t -> IO a @@ -35,12 +34,12 @@ forkedMain opts = block forkedMain' opts >> return () -- | Set a 'watchDog' on this thread, and then continue on with whatever. -forkedMain' :: Options -> MVar [Char] -> IO ThreadId +forkedMain' :: Options -> MVar String -> IO ThreadId forkedMain' opts mvar = do mainId <- myThreadId watchDog tout mainId hSetBuffering stdout NoBuffering - -- Our modules and expression are set up. Let's do stuff. + -- Our modules and expression are set up. Let's do stuff. forkIO $ (interpreterSession typeprint extend rls mdls fls expr >> putMVar mvar "Done.") `catch` throwTo mainId -- bounce exceptions to the main thread, diff --git a/main.hs b/main.hs --- a/main.hs +++ b/main.hs @@ -6,7 +6,9 @@ import Mueval.Parallel import Mueval.ArgsParse (getOptions) +import System.Environment main :: IO () -main = do opts <- getOptions +main = do args <- getArgs + let opts = getOptions args forkedMain opts diff --git a/mueval.cabal b/mueval.cabal --- a/mueval.cabal +++ b/mueval.cabal @@ -1,5 +1,5 @@ name: mueval -version: 0.7.0 +version: 0.7.1 license: BSD3 license-file: LICENSE @@ -32,7 +32,7 @@ exposed-modules: Mueval.Parallel, Mueval.Context, Mueval.Interpreter, Mueval.ArgsParse, Mueval.Resources build-depends: base>=4, containers, directory, mtl, filepath, unix, process, - hint>=0.3.0.0, show>=0.3, utf8-string, Cabal + hint>=0.3.1, show>=0.3, utf8-string, Cabal ghc-options: -Wall -static -O2 executable mueval-core diff --git a/watchdog.hs b/watchdog.hs --- a/watchdog.hs +++ b/watchdog.hs @@ -14,8 +14,10 @@ main :: IO () main = do args <- getArgs hdl <- runProcess "mueval-core" args Nothing Nothing Nothing Nothing Nothing - threadDelay (7 * 700000) - status <- getProcessExitCode hdl - case status of - Nothing -> terminateProcess hdl >> exitWith (ExitFailure 1) - Just a -> exitWith a + forkIO (do threadDelay (7 * 700000) + status <- getProcessExitCode hdl + case status of + Nothing -> terminateProcess hdl >> exitWith (ExitFailure 1) + Just a -> exitWith a) + stat <- waitForProcess hdl + exitWith stat