diff --git a/Mueval/Concurrent.hs b/Mueval/Concurrent.hs --- a/Mueval/Concurrent.hs +++ b/Mueval/Concurrent.hs @@ -1,8 +1,9 @@ module Mueval.Concurrent where +import Prelude hiding (catch) import Control.Concurrent (forkIO, killThread, myThreadId, threadDelay, throwTo, yield, ThreadId) import System.Posix.Signals (sigXCPU, installHandler, Handler(CatchOnce)) -import Control.Exception (catchDyn, Exception(ErrorCall)) +import Control.Exception (Exception(ErrorCall),catch) import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar, MVar) import System.IO (hSetBuffering, stdout, BufferMode(NoBuffering)) @@ -35,13 +36,15 @@ -- | Set a 'watchDog' on this thread, and then continue on with whatever. forkedMain' :: Options -> MVar [Char] -> IO ThreadId -forkedMain' opts mvar = do myThreadId >>= watchDog tout +forkedMain' opts mvar = do mainId <- myThreadId + watchDog tout mainId hSetBuffering stdout NoBuffering -- Our modules and expression are set up. Let's do stuff. - forkIO (interpreterSession typeprint extend mdls fls expr - `catchDyn` (printInterpreterError) - >> putMVar mvar "Done.") + forkIO $ (interpreterSession typeprint extend mdls fls expr + >> putMVar mvar "Done.") + `catch` throwTo mainId -- bounce exceptions to the main thread, + -- so they are reliably printed out where mdls = if impq then Nothing else Just (modules opts) expr = expression opts tout = timeLimit opts diff --git a/Mueval/Context.hs b/Mueval/Context.hs --- a/Mueval/Context.hs +++ b/Mueval/Context.hs @@ -29,6 +29,7 @@ sources. -} defaultModules :: [String] defaultModules = ["Prelude", "ShowQ", "ShowFun", "SimpleReflect", "Data.Function", + "Control.Applicative", "Control.Monad", "Control.Monad.Cont", "Control.Monad.Error", @@ -88,7 +89,7 @@ > mueval --module Data.Map -e "Prelude.map (+1) [1..100]" -} safeModules :: [String] -safeModules = defaultModules ++ ["Control.Applicative", +safeModules = defaultModules ++ [ "Control.Arrow", "Control.Arrow.Operations", "Control.Arrow.Transformer", diff --git a/Mueval/Interpreter.hs b/Mueval/Interpreter.hs --- a/Mueval/Interpreter.hs +++ b/Mueval/Interpreter.hs @@ -2,33 +2,49 @@ module Mueval.Interpreter where import Control.Monad (when) -import qualified Control.Exception (catch) +import qualified Control.Exception as E (bracket,catchDyn) import Control.Monad.Trans (liftIO) import System.Directory (copyFile, makeRelativeToCurrentDirectory, removeFile) import System.FilePath.Posix (takeFileName) - +import System.Exit (exitFailure) import Language.Haskell.Interpreter.GHC (eval, newSession, reset, setImports, loadModules, setOptimizations, setUseLanguageExtensions, setInstalledModsAreInScopeQualified, - typeChecks, typeOf, withSession, setTopLevelModules, - Interpreter, InterpreterError, ModuleName, Optimizations(All)) + typeOf, withSession, setTopLevelModules, + Interpreter, InterpreterError(..),GhcError(..), ModuleName, Optimizations(All)) import qualified Codec.Binary.UTF8.String as Codec (decodeString) -import qualified System.IO.UTF8 as UTF (putStr) +import qualified System.IO.UTF8 as UTF (putStrLn) + import qualified Mueval.Resources (limitResources) -- | From inside the Interpreter monad, 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 . UTF.putStr . Codec.decodeString . take 1024 +say = liftIO . sayIO --- | Oh no, something has gone wrong. Call 'error' and then, as with 'say', --- print out a maximum of 1024 characters. +sayIO :: String -> IO () +sayIO = UTF.putStrLn . Codec.decodeString . take 1024 + +-- | Oh no, something has gone wrong. If it's a compilation error prettyprint +-- the first 1024 chars of it and throw an ExitExcetion +-- otherwise rethrow the exception in String form. printInterpreterError :: InterpreterError -> IO () -printInterpreterError = error . take 1024 . ("Oops... " ++) . show +printInterpreterError (WontCompile errors) = + -- if we get a compilation error we print it directly to avoid "mueval: .." + -- maybe it should go to stderr? + do sayIO $ concatMap (dropLinePosition . errMsg) errors + exitFailure + where + -- each error starts with the line position, which is uninteresting + dropLinePosition = unlines . tail . lines +-- other exceptions indicate some problem in mueval or the environment, +-- so we rethrow them for debugging purpouses +printInterpreterError other = error (show other) + {- | The actual calling of Hint functionality. The heart of this just calls 'eval', but we do so much more - we disable Haskell extensions, turn on optimizations, hide all packages, make sure one cannot call unimported @@ -64,17 +80,14 @@ Nothing -> return () Just ms -> setImports ms - when prt (say $ expr ++ "\n") + 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 - checks <- typeChecks expr + result <- eval expr - if checks then do - if prt then do say =<< typeOf expr - say "\n" - else return () - result <- eval expr - say $ result ++ "\n" - else error "Expression did not type check." + say $ result -- | Wrapper around 'interpreter'; supplies a fresh GHC API session and -- error-handling. The arguments are simply passed on. @@ -86,13 +99,15 @@ -> 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 mds lfl expr = Control.Exception.catch - (newSession >>= (flip withSession) (interpreter prt exts mds lfl expr)) - (\_ -> do case lfl of - "" -> return () - l -> do canonfile <- (makeRelativeToCurrentDirectory l) - removeFile ("/tmp/" ++ takeFileName canonfile) - error "Expression did not compile.") +interpreterSession prt exts mds lfl expr = E.bracket newSession cleanTmpFile $ \session -> + withSession session (interpreter prt exts mds lfl expr) + `E.catchDyn` printInterpreterError + where + cleanTmpFile _ = case lfl of + "" -> return () + l -> do canonfile <- makeRelativeToCurrentDirectory l + removeFile $ "/tmp/" ++ takeFileName canonfile + mvload :: FilePath -> IO () mvload lfl = do canonfile <- (makeRelativeToCurrentDirectory lfl) diff --git a/mueval.cabal b/mueval.cabal --- a/mueval.cabal +++ b/mueval.cabal @@ -1,5 +1,5 @@ name: mueval -version: 0.6.2 +version: 0.6.3 license: BSD3 license-file: LICENSE diff --git a/tests.sh b/tests.sh --- a/tests.sh +++ b/tests.sh @@ -10,6 +10,9 @@ echo "Test some valid expressions \n" ## Does anything work? m 'True' +## TODO: Test comments +# m 'True -- testing' +m 'True {- Testing -}' ## OK, let's try some simple math. m '1*100+1' m '(1*100) +1+1' --module Control.Monad @@ -49,8 +52,10 @@ m 'runIdentity $ mfix (return . (0:) . scanl (+) 1)' m 'fix ((1:).(1:).(zipWith (+) `ap` tail))' m 'runST (return 0)' +m 'map return [1,2] :: [Either String Int]' ## Test defaulting of expressions m 'show []' -E +m '(+1) <$> [1..3]' ## Now let's do file loading echo "module TmpModule (foo, bar) where\nfoo x = x + 1 \nbar x = x + 2" > "TmpModule.hs" m '1+1' --loadfile="TmpModule.hs"