mueval 0.7.0 → 0.7.1
raw patch · 7 files changed
+51/−60 lines, 7 filesdep ~hint
Dependency ranges changed: hint
Files
- Mueval/ArgsParse.hs +7/−11
- Mueval/Context.hs +1/−1
- Mueval/Interpreter.hs +26/−34
- Mueval/Parallel.hs +5/−6
- main.hs +3/−1
- mueval.cabal +2/−2
- watchdog.hs +7/−5
Mueval/ArgsParse.hs view
@@ -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
Mueval/Context.hs view
@@ -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
Mueval/Interpreter.hs view
@@ -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 "<interactive>:" 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)
Mueval/Parallel.hs view
@@ -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,
main.hs view
@@ -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
mueval.cabal view
@@ -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
watchdog.hs view
@@ -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