diff --git a/AUTHORS b/AUTHORS --- a/AUTHORS +++ b/AUTHORS @@ -2,3 +2,4 @@ Contributions from: Evan Laforge +Gwern Branwen diff --git a/Changes b/Changes --- a/Changes +++ b/Changes @@ -1,3 +1,9 @@ +- ver 0.2.2 + * setOptimizations added + * Module Language.Haskell.Interpreter.GHC.Unsafe added + (contains unsafeSetGhcOption) + * unit tests now based on HUnit + - ver 0.2.1 * BUGFIX: Module reloading was broken under 6.8 * GHC.GhcExceptions are catched and turned into InterpreterErrors diff --git a/hint.cabal b/hint.cabal --- a/hint.cabal +++ b/hint.cabal @@ -1,5 +1,5 @@ name: hint -version: 0.2.1 +version: 0.2.2 description: This library defines an @Interpreter@ monad. It allows to load Haskell modules, browse them, type-check and evaluate strings with Haskell @@ -8,8 +8,7 @@ values). It is, esentially, a huge subset of the GHC API wrapped in a simpler - API. Works with GHC 6.6.x and 6.8.x. NOTE: Requires Cabal 1.2, currently - won't install with Cabal 1.3 and above. + API. Works with GHC 6.6.x and 6.8.x. synopsis: Runtime Haskell interpreter (GHC API wrapper) category: Language, Compilers/Interpreters license: BSD3 @@ -18,7 +17,7 @@ maintainer: jcpetruzza@gmail.com -- hackage rejects the correct cabal-version specification --- cabal-version: >= 1.2 && < 1.3 +-- cabal-version: >= 1.2 && < 1.5 cabal-version: >= 1.2 build-type: Custom tested-with: GHC==6.6.1, GHC==6.8.2 @@ -27,6 +26,7 @@ build-depends: base, haskell-src, ghc, mtl exposed-modules: Language.Haskell.Interpreter.GHC + Language.Haskell.Interpreter.GHC.Unsafe other-modules: Language.Haskell.Interpreter.GHC.Base Language.Haskell.Interpreter.GHC.Compat Language.Haskell.Interpreter.GHC.Conversions diff --git a/src/Language/Haskell/Interpreter/GHC.hs b/src/Language/Haskell/Interpreter/GHC.hs --- a/src/Language/Haskell/Interpreter/GHC.hs +++ b/src/Language/Haskell/Interpreter/GHC.hs @@ -20,6 +20,7 @@ withSession, -- ** Interpreter options setUseLanguageExtensions, + Optimizations(..), setOptimizations, -- ** Context handling ModuleName, loadModules, getLoadedModules, setTopLevelModules, @@ -69,24 +70,16 @@ -- | Set to true to allow GHC's extensions to Haskell 98. setUseLanguageExtensions :: Bool -> Interpreter () -setUseLanguageExtensions val = - do - ghc_session <- fromSessionState ghcSession - -- - let negate_or_not = if val then "" else "no-" - let flag = concat ["-f", negate_or_not, "glasgow-exts"] - -- - old_flags <- liftIO $ GHC.getSessionDynFlags ghc_session - (new_flags, not_parsed) <- liftIO $ GHC.parseDynamicFlags old_flags - [flag] - -- - when (not . null $ not_parsed) $ - throwError $ UnknownError (concat ["flag: '", flag, - "' not recognized"]) - -- - liftIO $ GHC.setSessionDynFlags ghc_session new_flags - -- - return () +setUseLanguageExtensions True = setGhcOption "-fglasgow-exts" +setUseLanguageExtensions False = setGhcOption "-fno-glasgow-exts" + +data Optimizations = None | Some | All deriving (Eq, Read, Show) + +-- | Set the optimization level (none, some, all) +setOptimizations :: Optimizations -> Interpreter () +setOptimizations None = setGhcOption "-O0" +setOptimizations Some = setGhcOption "-O1" +setOptimizations All = setGhcOption "-O2" -- | Module names are _not_ filepaths. type ModuleName = String diff --git a/src/Language/Haskell/Interpreter/GHC/Base.hs b/src/Language/Haskell/Interpreter/GHC/Base.hs --- a/src/Language/Haskell/Interpreter/GHC/Base.hs +++ b/src/Language/Haskell/Interpreter/GHC/Base.hs @@ -2,7 +2,7 @@ where -import Control.Monad ( liftM ) +import Control.Monad ( liftM, when ) import Control.Monad.Trans ( MonadIO(liftIO) ) import Control.Monad.Reader ( ReaderT, ask, runReaderT ) import Control.Monad.Error ( Error(..), MonadError(..), ErrorT, runErrorT ) @@ -149,3 +149,19 @@ ref <- fromSessionState target old_val <- liftIO $ atomicModifyIORef ref (\a -> (f a, a)) return old_val + +-- ================ Interpreter options ===================== + +setGhcOptions :: [String] -> Interpreter () +setGhcOptions opts = + do ghc_session <- fromSessionState ghcSession + old_flags <- liftIO $ GHC.getSessionDynFlags ghc_session + (new_flags, not_parsed) <- liftIO $ GHC.parseDynamicFlags old_flags opts + when (not . null $ not_parsed) $ + throwError $ UnknownError (concat ["flag: '", unwords opts, + "' not recognized"]) + liftIO $ GHC.setSessionDynFlags ghc_session new_flags + return () + +setGhcOption :: String -> Interpreter () +setGhcOption opt = setGhcOptions [opt] diff --git a/src/Language/Haskell/Interpreter/GHC/Unsafe.hs b/src/Language/Haskell/Interpreter/GHC/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Interpreter/GHC/Unsafe.hs @@ -0,0 +1,12 @@ +module Language.Haskell.Interpreter.GHC.Unsafe ( unsafeSetGhcOption ) + +where + +import Language.Haskell.Interpreter.GHC.Base ( Interpreter, setGhcOption ) + +-- | Set a GHC option for the current session, +-- eg. @unsafeSetGhcOption \"-fno-monomorphism-restriction\"@. +-- +-- Warning: Some options may interact badly with the Interpreter. +unsafeSetGhcOption :: String -> Interpreter () +unsafeSetGhcOption = setGhcOption diff --git a/unit-tests/run-unit-tests.hs b/unit-tests/run-unit-tests.hs --- a/unit-tests/run-unit-tests.hs +++ b/unit-tests/run-unit-tests.hs @@ -1,18 +1,26 @@ -import Control.Exception ( catchDyn ) -import System.Directory ( removeFile ) +import Control.Exception ( catchDyn, finally ) +import Control.Monad ( liftM, when ) +import Control.Monad.Trans ( MonadIO(liftIO) ) +import Control.Monad.Error ( catchError ) + +import System.Directory ( doesFileExist, removeFile ) +import System.Exit + +import Test.HUnit ( (@?=), (@?) ) +import qualified Test.HUnit as HUnit + import qualified Language.Haskell.Interpreter.GHC as H -test_reload_modified :: H.InterpreterSession -> IO Bool -test_reload_modified s = do writeFile mod_file mod_v1 +test_reload_modified :: H.InterpreterSession -> HUnit.Test +test_reload_modified s = testCase "reload_modifie" [mod_file] $ do + writeFile mod_file mod_v1 f_v1 <- H.withSession s get_f -- writeFile mod_file mod_v2 f_v2 <- H.withSession s get_f -- - removeFile mod_file - -- - return $ (f_v1 5, f_v2 5) == (5, 6) + (f_v1 5, f_v2 5) @?= (5, 6) -- where mod_name = "TEST_ReloadModified" mod_file = mod_name ++ ".hs" @@ -30,13 +38,51 @@ H.setTopLevelModules [mod_name] H.interpret "f" (H.as :: Int -> Int) +test_lang_exts :: H.InterpreterSession -> HUnit.Test +test_lang_exts s = testCase "lang_exts" [mod_file] $ do + writeFile mod_file "data T where T :: T" + H.withSession s $ do + loadFails @@? "first time, it shouldn't load" + -- + H.setUseLanguageExtensions True + loadSucceeds @@? "now, it should load" + -- + H.setUseLanguageExtensions False + loadFails @@? "it shouldn't load, again" + -- + where mod_name = "TEST_LangExts" + mod_file = mod_name ++ ".hs" + -- + loadFails = not `liftM` loadSucceeds + loadSucceeds = do H.loadModules [mod_name] + return True + `catchError` (\_ -> return False) + main :: IO () main = do s <- H.newSession - ok <- test_reload_modified s - if ok - then putStrLn "test ok" - else fail "test failed" + -- + c <- HUnit.runTestTT $ HUnit.TestList [ + test_reload_modified s, + test_lang_exts s] + -- + let failures = HUnit.errors c + HUnit.failures c + exit_code + | failures > 0 = ExitFailure failures + | otherwise = ExitSuccess + exitWith exit_code `catchDyn` printInterpreterError printInterpreterError :: H.InterpreterError -> IO () -printInterpreterError e = putStrLn $ "Ups... " ++ (show e) +printInterpreterError e = do putStrLn $ "Ups... " ++ (show e) + exitWith (ExitFailure $ -1) + +(@@?) :: (HUnit.AssertionPredicable p, MonadIO m) => m p -> String -> m () +p @@? msg = do b <- p; liftIO (b @? msg) + +testCase :: String -> [FilePath] -> HUnit.Assertion -> HUnit.Test +testCase title tmps test = HUnit.TestLabel title $ + HUnit.TestCase (test `finally` clean_up) + where clean_up = mapM_ removeIfExists tmps + removeIfExists f = do exists <- doesFileExist f + when exists $ + removeFile f